type TItemCompareEvent = function(Item1, Item2: TCoreClassObject; Info: pointer): integer of object; TItemCompareMethod = function(Item1, Item2: TCoreClassObject; Info: pointer): integer; TCustomObjectList = class(TCoreClassObjectList) public procedure Append(AItem: TCoreClassObject); end; // TCustomSortedList is a TObjectList descendant providing easy sorting // capabilities, while keeping simplicity. Override the DoCompare method // to compare two items. TCustomSortedList = class(TCustomObjectList) private FSorted: boolean; procedure SetSorted(AValue: boolean); protected // Override this method to implement the object comparison between two // items. The default just compares the item pointers function DoCompare(Item1, Item2: TCoreClassObject): integer; virtual; abstract; public constructor Create(AutoFreeObj_: boolean); function Add(AItem: TCoreClassObject): integer; // AddUnique behaves just like Add but checks if the item to add is unique // by checking the result of the Find function. If the item is found it is // replaced by the new item (old item removed), unless RaiseError = True, in // that case an exception is raised. function AddUnique(Item: TCoreClassObject; RaiseError: boolean = false): integer; virtual; function Find(Item: TCoreClassObject; out Index: integer): boolean; virtual; // Find (multiple) items equal to Item, and return Index of first equal // item and the number of multiples in Count procedure FindMultiple(Item: TCoreClassObject; out AIndex, ACount: integer); virtual; procedure Sort; virtual; property Sorted: boolean read FSorted write SetSorted default true; end; // TSortedList is an object list that provides an events or method template // to compare items. Assign either OnCompare (for an event) or CompareMethod // (for a method template) to do the comparison of items. Additional information // required for the compare method can be passed with the CompareInfo pointer. TSortedList = class(TCustomSortedList) private FCompareInfo: pointer; FOnCompare_: TItemCompareEvent; FCompareMethod: TItemCompareMethod; protected function DoCompare(Item1, Item2: TCoreClassObject): integer; override; public property CompareInfo: pointer read FCompareInfo write FCompareInfo; // Use CompareMethod if you want to specify a compare method as stand-alone method property CompareMethod: TItemCompareMethod read FCompareMethod write FCompareMethod; // Use OnCompare if you want to specify a compare method as a method of a class property OnCompare: TItemCompareEvent read FOnCompare_ write FOnCompare_; end; TPoing2D_ = record case byte of 0: (X, Y: double); 1: (Elem: array [0 .. 1] of double); end; PPoing2D_ = ^TPoing2D_; TTriangle2D_ = class; TTriMesh2D_ = class; // Basic 2D vertex class, containing an FPoint (TPoing2D_) field with X and Y coordinate. TVertex2D_ = class(TCoreClassPersistent) private FPoint: TPoing2D_; function GetX: double; function GetY: double; procedure SetX(const Value: double); procedure SetY(const Value: double); function GetPoint: PPoing2D_; protected function GetTriangle: TTriangle2D_; virtual; abstract; procedure SetTriangle(const Value: TTriangle2D_); virtual; abstract; public constructor Create; virtual; constructor CreateWithCoords(const AX, AY: double); procedure Assign(Source: TCoreClassPersistent); override; property X: double read GetX write SetX; property Y: double read GetY write SetY; property Point: PPoing2D_ read GetPoint; // Reference back to the triangle this vertex belongs to. In fact, there can // be many triangles this vertex belongs to, but this is one of them (not // specified which one). If Triangle = nil, there is no reference yet. property Triangle: TTriangle2D_ read GetTriangle write SetTriangle; end; TVertex2DClass_ = class of TVertex2D_; TVertex2DList_ = class(TCoreClassObjectList) private function GetItems(Index: integer): TVertex2D_; procedure SetItems(Index: integer; const Value: TVertex2D_); public property Items[Index: integer]: TVertex2D_ read GetItems write SetItems; default; end; // 2D vertex class with additional Triangle pointer TTriVertex2D_ = class(TVertex2D_) private FTriangle: TTriangle2D_; protected function GetTriangle: TTriangle2D_; override; procedure SetTriangle(const Value: TTriangle2D_); override; public procedure Assign(Source: TCoreClassPersistent); override; end; // A segment is a boundary that connects two vertices. When a segment is present // the triangles bordering it cannot be swapped, thus constraining the triangulation TSegment2D_ = class(TCoreClassPersistent) private FValidMetrics: boolean; FVertex1: TVertex2D_; FVertex2: TVertex2D_; FCenter: TPoing2D_; FNormal: TPoing2D_; FSquaredEncroachRadius: double; procedure SetVertex1(const Value: TVertex2D_); procedure SetVertex2(const Value: TVertex2D_); function GetCenter: TPoing2D_; function GetSquaredEncroachRadius: double; function GetNormal: TPoing2D_; protected procedure CalculateMetrics; virtual; public constructor CreateWithVertices(AVertex1, AVertex2: TVertex2D_); procedure Assign(Source: TCoreClassPersistent); override; procedure Invalidate; // Replaces references in the segment to OldVertex by a reference to NewVertex. procedure ReplaceVertex(OldVertex, NewVertex: TVertex2D_); // Find the intersection point of us with ASegment, and create and return a vertex // if it does, or nil if no intersection. function IntersectWith(ASegment: TSegment2D_): TVertex2D_; // Is AVertex lying on this segment? Use the passed precision as tolerance // (pass the square of required precision) function IsVertexOnSegment(AVertex: TVertex2D_; APrecisionSqr: double): boolean; // Does point P encroach on this segment? function PointEncroaches(const P: TPoing2D_): boolean; // Reference to start vertex of this segment property Vertex1: TVertex2D_ read FVertex1 write SetVertex1; // Reference to end vertex of this segment property Vertex2: TVertex2D_ read FVertex2 write SetVertex2; // Center (midpoint) between the two vertices property Center: TPoing2D_ read GetCenter; // The normal of this segment. It points outwards from the graph, perpendicular // to the segment, and is unit length property Normal: TPoing2D_ read GetNormal; // The encroach radius is slightly bigger (10%) than the actual radius of // the segment's circle. This way, points encroach on it slightly quicker // esp near segment endpoints. property SquaredEncroachRadius: double read GetSquaredEncroachRadius; end; TSegment2DClass_ = class of TSegment2D_; TSegment2DList_ = class(TCoreClassObjectList) private function GetItems(Index: integer): TSegment2D_; public property Items[Index: integer]: TSegment2D_ read GetItems; default; end; // hit-test result for hit-testing triangles THitTestTriangle_ = ( httNone, // Not on the triangle httBody, // On the body of the triangle httVtx0, // On or close to triangle's vertex 0 httVtx1, // On or close to triangle's vertex 1 httVtx2, // On or close to triangle's vertex 2 httEdge0, // On the body, and on edge 0 httEdge1, // On the body, and on edge 1 httEdge2, // On the body, and on edge 2 httClose0, // Not on the body but close to edge 0 httClose1, // Not on the body but close to edge 1 httClose2 // Not on the body but close to edge 2 ); // Basic class for triangles that are present in a triangular 2D mesh TTriangle2D_ = class(TCoreClassPersistent) private FVertices: array [0 .. 2] of TVertex2D_; FNormals: array [0 .. 2] of TPoing2D_; FNeighbours: array [0 .. 2] of TTriangle2D_; FCenter: TPoing2D_; FRegionIndex: integer; function GetVertices(Index: integer): TVertex2D_; procedure SetVertices(Index: integer; const Value: TVertex2D_); function GetNeighbours(Index: integer): TTriangle2D_; procedure SetNeighbours(Index: integer; const Value: TTriangle2D_); function GetCenter: TPoing2D_; protected FValidMetrics: boolean; FMesh: TTriMesh2D_; // pointer back to mesh function GetSegments(Index: integer): TSegment2D_; virtual; procedure SetSegments(Index: integer; const Value: TSegment2D_); virtual; // Calcuate metrics for this triangle, may be overridden in descendants to // calculate more metrics procedure CalculateMetrics; virtual; procedure InvalidateSegments; public constructor Create; virtual; procedure Invalidate; // Set the vertices a, b, c all at the same time procedure HookupVertices(VertexA, VertexB, VertexC: TVertex2D_); // Set the neighbours a, b, c all at the same time procedure HookupNeighbours(TriangleA, TriangleB, TriangleC: TTriangle2D_); // Replace the neighbour OldNeighbour (if we have it) by NewNeighbour procedure ReplaceNeighbour(OldNeighbour, NewNeighbour: TTriangle2D_); // Returns index 0, 1, or 2 if ATriangle is one of it's neighbours, or -1 // if ATriangle isn't function NeighbourIndex(ATriangle: TTriangle2D_): integer; // Returns index 0, 1, or 2 if AVertex is one of the vertices of ATriangle, // or -1 if not function VertexIndex(AVertex: TVertex2D_): integer; // Returns index 0, 1, or 2 if ASegment is one of the segments of ATriangle, // or -1 if not function SegmentIndex(ASegment: TSegment2D_): integer; // Hit-test the triangle with APoint, and return one of the hittest // values. function HitTest(const APoint: TPoing2D_): THitTestTriangle_; // Returns the edge index of the edge that crosses the line when going from // the center of this triangle to point APoint (and beyond). function EdgeFromCenterTowardsPoint(const APoint: TPoing2D_): integer; // Returns the signed area of this triangle (result is positive when triangle // is defined counter-clockwise, and negative if clockwise). function Area: double; // Returns the cosine of the angle at vertex Index function AngleCosine(Index: integer): double; // Returns the cosine of the smallest angle in the triangle function SmallestAngleCosine: double; // Returns the square of the length of the longest edge function SquaredLongestEdgeLength: double; // References to the vertices of which this triangle consists. The vertices // are numbered 0, 1, 2 (also referred to as a, b, c). // The triangle must always be described in counterclockwise direction. property Vertices[Index: integer]: TVertex2D_ read GetVertices write SetVertices; // References to the neighbouring triangles, or nil if there is none at this location // Neighbour 0 corresponds to the neighbour along edge ab, neighbour 1 to edge bc // and neighbour 2 to edge ca. property Neighbours[Index: integer]: TTriangle2D_ read GetNeighbours write SetNeighbours; // Returns reference to the segment at edge Index. Segments are only actually // added in a descendant class, so in the base class TTriangle2D_ nil is returned property Segments[Index: integer]: TSegment2D_ read GetSegments write SetSegments; // Returns center of triangle (3 points averaged) property Center: TPoing2D_ read GetCenter; // Index of the region this triangle belongs to, or -1 if none property RegionIndex: integer read FRegionIndex write FRegionIndex; end; TTriangle2DClass_ = class of TTriangle2D_; // List of triangles. TTriangle2DList_ = class(TCoreClassObjectList) private function GetItems(Index: integer): TTriangle2D_; public property Items[Index: integer]: TTriangle2D_ read GetItems; default; end; // The object represents general triangle-edge group. // Capacity will be increased when needed, but will never be reduced, to avoid memory fragmentation. TTriangleGroup2D_ = class(TCoreClassPersistent) private FTriangles: array of TTriangle2D_; FEdges: array of integer; FCount: integer; FCapacity: integer; function GetTriangles(Index: integer): TTriangle2D_; protected function GetEdges(Index: integer): integer; procedure SetEdges(Index: integer; const Value: integer); public procedure Clear; virtual; // Add a triangle reference and edge index to the end of the list procedure AddTriangleAndEdge(ATriangle: TTriangle2D_; AEdge: integer); // Insert a triangle reference and edge index in the list at AIndex procedure InsertTriangleAndEdge(AIndex: integer; ATriangle: TTriangle2D_; AEdge: integer); // Delete triangle and edge at AIndex procedure Delete(AIndex: integer); // Exchange triangle/edge pairs at Index1 and Index2 procedure Exchange(Index1, Index2: integer); // List of triangles in this triangle group property Triangles[Index: integer]: TTriangle2D_ read GetTriangles; // Number of triangles in the triangle group property Count: integer read FCount; end; // Represents a fan of triangles around the Vertex. This class is used in linear searches. TTriangleFan2D_ = class(TTriangleGroup2D_) private FCenter: TVertex2D_; procedure SetCenter(const Value: TVertex2D_); function GetVertices(Index: integer): TVertex2D_; protected procedure BuildTriangleFan(ABase: TTriangle2D_); virtual; public procedure Clear; override; // Move the triangle fan to another center vertex that lies on the other end // of the outgoing edge of triangle at AIndex procedure MoveToVertexAt(AIndex: integer); // Return the index of the triangle that might cover the point APoint function TriangleIdxInDirection(const APoint: TPoing2D_): integer; // Return the triangle that might cover the vertex AVertex function TriangleInDirection(const APoint: TPoing2D_): TTriangle2D_; // Runs through the Vertices array, and if a vertex matches, it's index is // returned. If none matches, -1 is returned. function VertexIndex(AVertex: TVertex2D_): integer; // The center vertex of the triangle fan. Set Center to a vertex in the mesh // and the triangle fan around it will be rebuilt. Center must have a pointer // back to a triangle (it cannot be nil) property Center: TVertex2D_ read FCenter write SetCenter; // List of outward pointing edge indices in this triangle fan property OutwardEdges[Index: integer]: integer read GetEdges; // Vertices at the other end of the outward pointing edge at Index in the // triangle fan property Vertices[Index: integer]: TVertex2D_ read GetVertices; end; // A triangle chain between vertex1 and vertex2 TTriangleChain2D_ = class(TTriangleGroup2D_) private FVertex1, FVertex2: TVertex2D_; public // Build a triangle chain from Vertex1 to Vertex2. For searching, use ASearchFan // if assigned, or use temporary search fan if nil. If a chain was found, // the function result is true function BuildChain(AVertex1, AVertex2: TVertex2D_; var ASearchFan: TTriangleFan2D_): boolean; // List of edge indices in this triangle chain.. the edge index points to the // edge crossing the line from Vertex1 to Vertex2, except for the last one, // where it indicates the index of Vertex2. property Edges[Index: integer]: integer read GetEdges write SetEdges; end; // A mesh consisting of triangles and vertices, where each triangle contains reference to 3 vertices. TTriMesh2D_ = class(TCoreClassPersistent) private FPrecision: double; FVertices: TVertex2DList_; FTriangles: TTriangle2DList_; FSegments: TSegment2DList_; FSearchSteps: integer; // comparison function to sort triagles by Center.X, smallest values first function TriangleCompareLeft(Item1, Item2: TCoreClassObject; Info: pointer): integer; protected FPrecisionSqr: double; procedure SetPrecision(const Value: double); virtual; // Create a new vertex of correct class function NewVertex: TVertex2D_; class function GetVertexClass: TVertex2DClass_; virtual; // Create a new triangle of correct class function NewTriangle: TTriangle2D_; class function GetTriangleClass: TTriangle2DClass_; virtual; // Create a new segment of correct class function NewSegment: TSegment2D_; class function GetSegmentClass: TSegment2DClass_; virtual; // Initialize info properties procedure InitializeInfo; virtual; public constructor Create; virtual; destructor Destroy; override; // Clear the mesh procedure Clear; virtual; // Create a convex hull around all the vertices in the mesh procedure ConvexHull; // Optimize the mesh for usage in a finite element method. The triangle list // is sorted such that the triangles form a long chain going up and down from // left to right, and all vertices used are placed in the AVertices list, which // is also sorted by usage in the triangles. Thus, vertices connected to each // other usually are also have an index relatively close in the Vertices list, // which accomplishes that the finite element matrix is more banded than with // a random distribution (and gauss elimination works faster). The AVertices // array must be initialized, it will be cleared and then filled with all // vertices used by the triangles. procedure OptimizeForFEM(AVertices: TVertex2DList_); // Remove all segments that are non-functional (e.g. vertex pointers are nil, // or vertex1 and vertex2 point to the same vertex) procedure RemoveNonSegments; // Get the min and max location of the mesh. Returns false if there are no // vertices function BoundingBox(var AMin, AMax: TPoing2D_): boolean; // Returns the sum of all triangle's absolute area function AbsoluteArea: double; // Returns the sum of all triangle's signed area function SignedArea: double; // Locate the vertex that is closest to APoint. The function returns the closest // vertex from the vertex list to APoint. If there are no vertices in the list, // nil is returned. The basic algorithm is a linear search but this can // be overridden in descendants (to implement e.g. a quadtree approach). // A TTriangleFan2D_ object can be passed in Fan to speed up searching. function LocateClosestVertex(const APoint: TPoing2D_; AFan: TTriangleFan2D_ = nil): TVertex2D_; virtual; // List of vertices used in this mesh property Vertices: TVertex2DList_ read FVertices; // List of triangles used in this mesh property Triangles: TTriangle2DList_ read FTriangles; // List of segments used in this mesh property Segments: TSegment2DList_ read FSegments; // Precision used when generating mesh. If a point lies within precision // from a triangle edge, it is considered to be on it, the edge will be // split instead of the body. // When a vertex lays within Precision of another vertex, no new triangle // will be created, thus the vertex is skipped (not triangulated). property Precision: double read FPrecision write SetPrecision; // Number of search steps performed in linear search. property SearchSteps: integer read FSearchSteps; end; TTriMesh2DClass_ = class of TTriMesh2D_; TConvexHull_ = class(TCoreClassPersistent) private FMesh: TTriMesh2D_; // Add a new segment in the hull, using vertices with Idx1, Idx2 procedure AddSegment(Idx1, Idx2: integer); // Is the vertex AVertex left of line V1-V2? (looking from point V1) function IsLeftOfLine(const V1, V2, AVertex: TVertex2D_): boolean; // Does AVertex violate ASegment (outside of it?) function SegmentViolated(ASegment: TSegment2D_; AVertex: TVertex2D_): boolean; // Add a new vertex to the hull. This updates the hull segments if the // vertex falls outside of them procedure AddVertexToHull(AVertex: TVertex2D_); public procedure MakeConvexHull(AMesh: TTriMesh2D_); end; // Class encapsulating 2D Planar Straightline Graphs (PSLG) TGraph2D_ = class(TCoreClassPersistent) private FVertices: TVertex2DList_; FSegments: TSegment2DList_; public constructor Create; destructor Destroy; override; procedure Clear; virtual; // Replaces references in the segment list to OldVertex by a reference to // NewVertex. procedure ReplaceVertex(OldVertex, NewVertex: TVertex2D_); // List of vertices in this PSLG property Vertices: TVertex2DList_ read FVertices; // List of segments in this PSLG property Segments: TSegment2DList_ read FSegments; end; // A Segment Triangle contains references for each edge to a segment, or nil // if there is no graph segment for this edge. TSegmentTriangle2D_ = class(TTriangle2D_) private FSegments: array [0 .. 2] of TSegment2D_; protected function GetSegments(Index: integer): TSegment2D_; override; procedure SetSegments(Index: integer; const Value: TSegment2D_); override; end; TMeshRegion_ = class(TCoreClassObject) private FWindingNumber: integer; FIsOuterRegion: boolean; public // Winding number of this region property WindingNumber: integer read FWindingNumber write FWindingNumber; // This region is the outer region (only one) property IsOuterRegion: boolean read FIsOuterRegion write FIsOuterRegion; end; TMeshRegionList_ = class(TCoreClassObjectList) private function GetItems(Index: integer): TMeshRegion_; public property Items[Index: integer]: TMeshRegion_ read GetItems; default; end; TTriangulationEvent = procedure(Sender: TCoreClassObject; const AMessage: SystemString) of object; // Which triangles should be removed after triangulation? TRemovalStyle_ = ( rsNone, // Remove no triagles rsOutside, // Remove all triangles that are connected to construction vertices rsEvenOdd, // Even-Odd fillrule removal rsNonZero, // Non-Zero fillrule removal rsNegative // Remove all triangles with windingnumber < 0 ); // Triangulates a polygon or other Planar Straightline Graphs (PSLG) into a triangular mesh. TTriangulationMesh2D_ = class(TTriMesh2D_) private FCornerPoints: TVertex2DList_; FRemovals: TTriangle2DList_; FRegions: TMeshRegionList_; FSegmentChain: TTriangleChain2D_; FSearchFan: TTriangleFan2D_; FTick: TTimeTick; FVertexSkipCount: integer; FSplitEdgeCount: integer; FSplitBodyCount: integer; FHitTests: integer; FAreaInitial: double; FCalculationTime: double; FOnExecutionStep: TTriangulationEvent; FOnPhaseComplete: TTriangulationEvent; FOnStatus: TTriangulationEvent; protected FBBMin, FBBMax: TPoing2D_; FMeshMin, FMeshMax: TPoing2D_; class function GetTriangleClass: TTriangle2DClass_; override; // perform the execution step event procedure DoExecutionStep(const AMessage: SystemString); // perform phase complete event procedure DoPhaseComplete(const AMessage: SystemString); // perform status event procedure DoStatus(const AMessage: SystemString); // Replace OldVertex by NewVertex in all segments procedure ReplaceVertexInSegments(Old_, New_: TVertex2D_); // Prepare the mesh so it can triangulate vertices by adding 4 corner points // and 2 initial triangles procedure PrepareMeshConstruction; virtual; // Remove the mesh construction elements that were created initially procedure RemoveMeshConstruction(ARemovalStyle: TRemovalStyle_); virtual; // Detect all the regions in the mesh, give each triangle a region index procedure DetectRegions; virtual; // Add another segment to the triangulation function AddSegmentToTriangulation(ASegment: TSegment2D_): boolean; // Add another vertex to the triangulation, subsequently dividing the mesh. // When False is returned, the vertex was not added (it fell on top of another vertex) function AddVertexToTriangulation(AVertex: TVertex2D_; Updates: TTriangle2DList_): boolean; virtual; // Split the triangle into 3 sub-triangles, at point AVertex on the body. The // point is guaranteed to lie on the triangle prior before calling this // method. procedure SplitTriangleBody(ATriangle: TTriangle2D_; AVertex: TVertex2D_; Updates: TTriangle2DList_); // Split the triangle into 2 on the edge (with AEdge index) at AVertex, and do the same with the triangle opposing the edge. // In some rare cases, this might lead to degenerate triangles at the opposing edge, // in this case the triangle's body is split. AVertex is guaranteed to lie in the triangle, or just on the edge. procedure SplitTriangleEdge(ATriangle: TTriangle2D_; AEdge: integer; AVertex: TVertex2D_; Updates: TTriangle2DList_); // Hittest the triangle list to find the triangle under the position where // AVertex is located. If a triangle was hit, it is returned in the ATriangle. // Result indicates where the triangle was hit. If ATriangle contains a // reference upon calling, it will be used as an initial guess. Set UseQuick // to true if the ATriangle input is expected to be far away from the hit, // or set to False if ATriangle is probably the one hit. If called with // UseQuick = false, ATriangle *must* be assigned! function HitTestTriangles(const APoint: TPoing2D_; var ATriangle: TTriangle2D_; UseQuick: boolean): THitTestTriangle_; // This routine can be called when separate triangle groups in the mesh may be no longer // connected (after removal). Since the normal method relies on connectedness, // it can fail. This method is *much* slower, simply verifies each triangle, // but guarantees a result is returned in these odd cases. function BruteForceHitTestTriangles(const APoint: TPoing2D_; var ATriangle: TTriangle2D_): THitTestTriangle_; // Do post-processing on the mesh. procedure PostProcessMesh; virtual; // Check triangle after it was inserted, the AEdge indicates the edge number // for which neighbours need to be checked. procedure CheckTriangleWithEdge(ATriangle: TTriangle2D_; AEdge: integer; Updates: TTriangle2DList_); virtual; // Generate a list of triangles that occur around AVertex. The list AList will // be cleared before this is done. AVertex should have a valid pointer to // one of the triangles it belongs to. If the result is false, AVertex didn't // have a pointer, or it was an invalid pointer. function BuildTriangleFan(AList: TTriangle2DList_; AVertex: TVertex2D_): boolean; // Remove ATriangle from the mesh. This also resets the neighbours so they // do not point to the triangle. ATriangle will be disposed of. procedure RemoveTriangleFromMesh(ATriangle: TTriangle2D_); // Reduce the chain by swapping triangles. Since this is a delaunay action, // we do not implement it here but in descendant. procedure ReduceSegmentChain(AChain: TTriangleChain2D_; ARemovals: TTriangle2DList_); virtual; // Initialize info properties procedure InitializeInfo; override; // Finalize info properties procedure FinalizeInfo; virtual; public constructor Create; override; destructor Destroy; override; // Clear all vertices, triangles and segments in the mesh, and initialize // all statistics. procedure Clear; override; // Add the vertices and segments of AGraph to our mesh. This doesn't triangulate // them yet, call Triangulate to triangulate all the graphs that have been added. procedure AddGraph(AGraph: TGraph2D_); virtual; // Triangulate the graphs that were added with AddGraph, by adding all the // vertices and segments in turn to the mesh. Before this is done, the mesh // is cleared and 4 corner points are added well outside the polygon's // bounding box. Between these 4 points, 2 initial triangles are added. // After the triangulation finishes, but before post-processing, the bounding // corners + triangles not part of the final mesh will be removed, unless // ARemovalStyle = rsNone. procedure Triangulate(ARemovalStyle: TRemovalStyle_ = rsOutside); // List of mesh regions. Regions have a winding number which indicates // visibility according to fill rule property Regions: TMeshRegionList_ read FRegions; // Number of vertices skipped in triangulation. Skipping happens because sometimes // vertices may lay almost on top of other vertices (within Precision), and // these vertices will be skipped. property VertexSkipCount: integer read FVertexSkipCount; // Number of triangle body splits that occurred in triangulation property SplitBodyCount: integer read FSplitBodyCount; // Number of triangle edge splits that occurred in triangulation property SplitEdgeCount: integer read FSplitEdgeCount; // The number of triangle hit tests performed. property HitTests: integer read FHitTests; // Initial area after creating the bounding box property AreaInitial: double read FAreaInitial; // Total time in seconds for triangulation (including postprocessing) property CalculationTime: double read FCalculationTime; // Connect an event to this handler to get information on each step in the execution property OnExecutionStep: TTriangulationEvent read FOnExecutionStep write FOnExecutionStep; // Connect an event to this handler to get information on completed phases property OnPhaseComplete: TTriangulationEvent read FOnPhaseComplete write FOnPhaseComplete; // Information for the status line (fast update rate) property OnStatus: TTriangulationEvent read FOnStatus write FOnStatus; end; TDelaunayTriangle2D_ = class(TSegmentTriangle2D_) private FSquaredRadius: double; FCircleCenter: TPoing2D_; function GetCircleCenter: TPoing2D_; function GetSquaredRadius: double; protected procedure CalculateMetrics; override; public // Test whether AVertex lies within the Delaunay circle of this triangle function VertexInCircle(AVertex: TVertex2D_): boolean; // Check if this triangle is in fact abiding the delaunay criterium (no neighbouring // triangle's opposite points inside the circle going through its 3 vertices) function IsDelaunay: boolean; // Returns the Delaunay circle center of this triangle property CircleCenter: TPoing2D_ read GetCircleCenter; // Returns the squared radius of the Delaunay circle of this triangle property SquaredRadius: double read GetSquaredRadius; end; TQualityTriangle2D_ = class(TDelaunayTriangle2D_) private FQuality: double; function GetOffCenter: TPoing2D_; protected function GetQuality: double; virtual; procedure CalculateMetrics; override; public // Does this triangle have an encroached segment? function HasEncroachedSegment: boolean; // Return the segment that is encroached due to APoint, or nil if none function EncroachedSegmentFromPoint(const APoint: TPoing2D_): TSegment2D_; // Calculate and return the OffCenter point for this triangle property OffCenter: TPoing2D_ read GetOffCenter; // Quality is defined as the smallest angle cosine. Larger values mean worse quality property Quality: double read GetQuality; end; TSortedTriangle2DList_ = class(TCustomSortedList) private function GetItems(Index: integer): TQualityTriangle2D_; protected function DoCompare(Item1, Item2: TCoreClassObject): integer; override; public property Items[Index: integer]: TQualityTriangle2D_ read GetItems; default; end; TEncroachItem_ = class(TCoreClassObject) private FSegment: TSegment2D_; FEncroacher: TTriangle2D_; FTriangle: TTriangle2D_; public // The triangle that encroaches upon the segment property Encroacher: TTriangle2D_ read FEncroacher write FEncroacher; // The segment that was encroached property Segment: TSegment2D_ read FSegment write FSegment; // The triangle that connects to the encroached segment property Triangle: TTriangle2D_ read FTriangle write FTriangle; end; TEncroachItemList_ = class(TCustomSortedList) private function GetItems(Index: integer): TEncroachItem_; protected function DoCompare(Item1, Item2: TCoreClassObject): integer; override; public // Add a new item if not yet present. AEncroacher is the triangle causing // the encroach, ATriangle is the triangle having a segment ASegment that is // encroached procedure AddItem(AEncroacher, ATriangle: TTriangle2D_; ASegment: TSegment2D_); // Return the index of an item that has ATriangle as triangle, or -1 if none function IndexByTriangle(ATriangle: TTriangle2D_): integer; // Remove all items that have ATriangle as Encroacher or Triangle procedure RemoveAllItemsWithTriangle(ATriangle: TTriangle2D_); procedure RemoveAllItemsWithSegment(ASegment: TSegment2D_); property Items[Index: integer]: TEncroachItem_ read GetItems; default; end; // TDelaunayMesh2D_ implements a delaunay triangulation of a polygon or point cloud. TDelaunayMesh2D_ = class(TTriangulationMesh2D_) private FSwapCount: integer; FCircleCalcCount: integer; FDelaunayPrecision: double; protected procedure SetPrecision(const Value: double); override; class function GetTriangleClass: TTriangle2DClass_; override; // Check triangle after it was inserted, the AEdge indicates the edge number // for which neighbours need to be checked. See if we need to swap this // triangle. procedure CheckTriangleWithEdge(ATriangle: TTriangle2D_; AEdge: integer; Updates: TTriangle2DList_); override; // The T1 and T2 triangles should swap their common edge. However, this may not // be done under some circumstances. This check should evaluate these. For the // standard Delaunay this check ensures the triangles form a convex hull, and // that they are not constrained by a segment. function AllowSwapTriangles(T1, T2: TTriangle2D_; E1, E2: integer): boolean; virtual; // Reduce the chain by swapping triangle pairs procedure ReduceSegmentChain(AChain: TTriangleChain2D_; ARemovals: TTriangle2DList_); override; // Do the actual swap of triangle T1 and T2 along edges E1 and E2. This function // does *not* check if the swap may be made, see AllowSwapTriangles for the // check. procedure SwapTriangles(T1, T2: TTriangle2D_; E1, E2: integer; Updates: TTriangle2DList_); procedure InitializeInfo; override; public // Count the number of triangles that do not abide Delaunay function NonDelaunayTriangleCount: integer; // Check whether all triangles abide Delaunay function IsDelaunay: boolean; // Iterate through the triangles and try to force the non-delaunay ones // to adapt. This method can be called after completion of Triangulate. It // makes no sense to call this method more than once, unless changes are made // to the mesh (the procedure already contains a loop). The return is the new // number of non-delaunay triangles. function ForceDelaunay: integer; // Number of triangle swaps that occurred during triangulation property SwapCount: integer read FSwapCount; // Number of circle calculations that occurred during triangulation. A // circle calculation is used to determine the circle through the 3 points // of a triangle. property CircleCalcCount: integer read FCircleCalcCount; end; TQualityMesh2D_ = class(TDelaunayMesh2D_) private FBadTriangles: TSortedTriangle2DList_; // List of bad triangles FEncroached: TEncroachItemList_; // List of encroached segments + info FUpdates: TTriangle2DList_; FSteinerPoints: TVertex2DList_; FSquaredBeta: double; FBeta: double; FMinimumAngleDeg: double; FMinimumAngleCos: double; FMinimumSegmentLength: double; FMinSegLengthSqr: double; FMaximumElementSize: double; procedure SetBeta(const Value: double); procedure SetMinimumAngle(const Value: double); procedure SetMinimumSegmentLength(const Value: double); protected class function GetTriangleClass: TTriangle2DClass_; override; // Post process the mesh: in this process we subdivide the triangles and // add Steiner points. procedure PostProcessMesh; override; procedure BuildBadTriangleList; virtual; procedure ProcessBadTriangleList; virtual; procedure UpdateLists; virtual; procedure SplitEncroachedSegment(AItem: TEncroachItem_); virtual; procedure SplitBadTriangle(ATriangle: TQualityTriangle2D_; TestOnly: boolean); virtual; function IsDegenerate(ASegment: TSegment2D_): boolean; // Is this a bad triangle? (its smallest angle is smaller than the minimum set) function IsBadTriangle(ATriangle: TQualityTriangle2D_): boolean; public constructor Create; override; destructor Destroy; override; procedure Clear; override; // Refines the mesh locally around X, Y until the element under X,Y is not // larger than AMaximumElementSize procedure LocalRefine(const X, Y, AMaximumElementSize: double); // Returns the minimum angle found in the mesh, in degrees. function MinimumAngleInMesh: double; // Number of degenerate triangles present in the mesh (due to segment angles // being too small) function DegenerateTriangleCount: integer; // Specify the minimum angle in degrees that may appear within each triangle in the // quality triangulation. The practical upper limit for this value is around 33 degrees. property MinimumAngle: double read FMinimumAngleDeg write SetMinimumAngle; // If segments are to be split, this will not be done if the resulting segments' // length is smaller than this value. property MinimumSegmentLength: double read FMinimumSegmentLength write SetMinimumSegmentLength; // Maximum element size allowed (triangles with larger area will be split). // If no maximum size is required, then leave this value on 0 (default) property MaximumElementSize: double read FMaximumElementSize write FMaximumElementSize; // List of steiner points that were generated property SteinerPoints: TVertex2DList_ read FSteinerPoints; end;