unit Clipper.Engine; (******************************************************************************* * Author : Angus Johnson * * Date : 3 November 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2010-2022 * * Purpose : This is the main polygon clipping module * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) interface {$I Clipper.inc} uses Classes, Math, Clipper.Core; type //PathType: // 1. only subject paths may be open // 2. for closed paths, all boolean clipping operations except for // Difference are commutative. (In other words, subjects and clips // could be swapped and the same solution will be returned.) TPathType = (ptSubject, ptClip); // Vertex: a pre-clipping data structure. It is used to separate polygons // into ascending and descending 'bounds' (or sides) that start at local // minima and ascend to a local maxima, before descending again. TVertexFlag = (vfOpenStart, vfOpenEnd, vfLocMax, vfLocMin); TVertexFlags = set of TVertexFlag; PVertex = ^TVertex; TVertex = record pt : TPoint64; next : PVertex; prev : PVertex; flags : TVertexFlags; end; PLocalMinima = ^TLocalMinima; TLocalMinima = record vertex : PVertex; polytype : TPathType; isOpen : Boolean; end; // forward declarations POutRec = ^TOutRec; PJoiner = ^TJoiner; PActive = ^TActive; TPolyPathBase = class; TPolyTree64 = class; TPolyTreeD = class; // OutPt: vertex data structure for clipping solutions POutPt = ^TOutPt; TOutPt = record pt : TPoint64; next : POutPt; prev : POutPt; outrec : POutRec; joiner : PJoiner; end; TOutRecArray = array of POutRec; // OutRec: path data structure for clipping solutions TOutRec = record idx : Integer; owner : POutRec; splits : TOutRecArray; frontE : PActive; backE : PActive; pts : POutPt; polypath : TPolyPathBase; bounds : TRect64; path : TPath64; isOpen : Boolean; end; // Joiner: structure used in merging "touching" solution polygons TJoiner = record idx : integer; op1 : POutPt; op2 : POutPt; next1 : PJoiner; next2 : PJoiner; nextH : PJoiner; end; /////////////////////////////////////////////////////////////////// // Important: UP and DOWN here are premised on Y-axis positive down // displays, which is the orientation used in Clipper's development. /////////////////////////////////////////////////////////////////// // Active: represents an edge in the Active Edge Table (Vatti's AET) TActive = record bot : TPoint64; top : TPoint64; currX : Int64; dx : Double; // inverse of edge slope (zero = vertical) windDx : Integer; // wind direction (ascending: +1; descending: -1) windCnt : Integer; // current wind count windCnt2 : Integer; // current wind count of the opposite TPolyType outrec : POutRec; // AEL: 'active edge list' (Vatti's AET - active edge table) // a linked list of all edges (from left to right) that are present // (or 'active') within the current scanbeam (a horizontal 'beam' that // sweeps from bottom to top over the paths in the clipping operation). prevInAEL: PActive; nextInAEL: PActive; // SEL: 'sorted edge list' (Vatti's ST - sorted table) // linked list used when sorting edges into their new positions at the // top of scanbeams, but also (re)used to process horizontals. prevInSEL: PActive; nextInSEL: PActive; jump : PActive; // fast merge sorting (see BuildIntersectList()) vertTop : PVertex; locMin : PLocalMinima; // the bottom of an edge 'bound' (also Vatti) isLeftB : Boolean; end; // IntersectNode: a structure representing 2 intersecting edges. // Intersections must be sorted so they are processed from the largest // Y coordinates to the smallest while keeping edges adjacent. PIntersectNode = ^TIntersectNode; TIntersectNode = record active1 : PActive; active2 : PActive; pt : TPoint64; end; // Scanline: a virtual line representing current position // while processing edges using a "sweep line" algorithm. PScanLine = ^TScanLine; TScanLine = record y : Int64; next : PScanLine; end; {$IFDEF USINGZ} TZCallback64 = procedure (const bot1, top1, bot2, top2: TPoint64; var intersectPt: TPoint64) of object; TZCallbackD = procedure (const bot1, top1, bot2, top2: TPointD; var intersectPt: TPointD) of object; {$ENDIF} // ClipperBase: abstract base of Clipper class TClipperBase = class {$IFDEF STRICT}strict{$ENDIF} private FBotY : Int64; FScanLine : PScanLine; FCurrentLocMinIdx : Integer; FClipType : TClipType; FFillRule : TFillRule; FPreserveCollinear : Boolean; FIntersectList : TList; FOutRecList : TList; FLocMinList : TList; FVertexArrayList : TList; FJoinerList : TList; // FActives: see AEL above FActives : PActive; // FSel: see SEL above. // BUT also used to store horz. edges for later processing FSel : PActive; FHorzTrials : PJoiner; FHasOpenPaths : Boolean; FLocMinListSorted : Boolean; FSucceeded : Boolean; FReverseSolution : Boolean; {$IFDEF USINGZ} fZCallback : TZCallback64; {$ENDIF} procedure Reset; procedure InsertScanLine(const Y: Int64); function PopScanLine(out Y: Int64): Boolean; function PopLocalMinima(Y: Int64; out localMinima: PLocalMinima): Boolean; procedure DisposeScanLineList; procedure DisposeOutRecsAndJoiners; procedure DisposeVerticesAndLocalMinima; function IsContributingClosed(e: PActive): Boolean; function IsContributingOpen(e: PActive): Boolean; procedure SetWindCountForClosedPathEdge(e: PActive); procedure SetWindCountForOpenPathEdge(e: PActive); procedure InsertLocalMinimaIntoAEL(const botY: Int64); procedure InsertLeftEdge(e: PActive); procedure PushHorz(e: PActive); {$IFDEF INLINING} inline; {$ENDIF} function PopHorz(out e: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} function StartOpenPath(e: PActive; const pt: TPoint64): POutPt; procedure UpdateEdgeIntoAEL(var e: PActive); function IntersectEdges(e1, e2: PActive; pt: TPoint64): POutPt; procedure DeleteEdges(var e: PActive); procedure DeleteFromAEL(e: PActive); procedure AdjustCurrXAndCopyToSEL(topY: Int64); procedure DoIntersections(const topY: Int64); procedure DisposeIntersectNodes; procedure AddNewIntersectNode(e1, e2: PActive; topY: Int64); function BuildIntersectList(const topY: Int64): Boolean; procedure ProcessIntersectList; procedure SwapPositionsInAEL(e1, e2: PActive); function AddOutPt(e: PActive; const pt: TPoint64): POutPt; function AddLocalMinPoly(e1, e2: PActive; const pt: TPoint64; IsNew: Boolean = false): POutPt; function AddLocalMaxPoly(e1, e2: PActive; const pt: TPoint64): POutPt; procedure JoinOutrecPaths(e1, e2: PActive); function DoMaxima(e: PActive): PActive; procedure DoHorizontal(horzEdge: PActive); procedure DoTopOfScanbeam(Y: Int64); procedure UpdateOutrecOwner(outRec: POutRec); procedure AddTrialHorzJoin(op: POutPt); procedure DeleteTrialHorzJoin(op: POutPt); procedure ConvertHorzTrialsToJoins; procedure AddJoin(op1, op2: POutPt); procedure SafeDeleteOutPtJoiners(op: POutPt); procedure DeleteJoin(joiner: PJoiner); procedure ProcessJoinList; function ProcessJoin(joiner: PJoiner): POutRec; function ValidateClosedPathEx(var op: POutPt): Boolean; procedure CompleteSplit(op1, op2: POutPt; OutRec: POutRec); procedure SafeDisposeOutPts(var op: POutPt); procedure CleanCollinear(outRec: POutRec); procedure DoSplitOp(outrec: POutRec; splitOp: POutPt); procedure FixSelfIntersects(outrec: POutRec); protected FUsingPolytree : Boolean; procedure AddPath(const path: TPath64; pathType: TPathType; isOpen: Boolean); procedure AddPaths(const paths: TPaths64; pathType: TPathType; isOpen: Boolean); procedure ClearSolution; // unlike Clear, CleanUp preserves added paths procedure ExecuteInternal(clipType: TClipType; fillRule: TFillRule; usingPolytree: Boolean); function DeepCheckOwner(outrec, owner: POutRec): Boolean; function BuildPaths(out closedPaths, openPaths: TPaths64): Boolean; procedure BuildTree(polytree: TPolyPathBase; out openPaths: TPaths64); {$IFDEF USINGZ} procedure SetZ( e1, e2: PActive; var intersectPt: TPoint64); property ZCallback : TZCallback64 read fZCallback write fZCallback; {$ENDIF} property Succeeded : Boolean read FSucceeded; public constructor Create; virtual; destructor Destroy; override; procedure Clear; function GetBounds: TRect64; property PreserveCollinear: Boolean read FPreserveCollinear write FPreserveCollinear; property ReverseSolution: Boolean read FReverseSolution write FReverseSolution; end; TClipper64 = class(TClipperBase) // for integer coordinates public procedure AddSubject(const subject: TPath64); overload; procedure AddSubject(const subjects: TPaths64); overload; procedure AddOpenSubject(const subject: TPath64); overload; procedure AddOpenSubject(const subjects: TPaths64); overload; procedure AddClip(const clip: TPath64); overload; procedure AddClip(const clips: TPaths64); overload; function Execute(clipType: TClipType; fillRule: TFillRule; out closedSolutions: TPaths64): Boolean; overload; virtual; function Execute(clipType: TClipType; fillRule: TFillRule; out closedSolutions, openSolutions: TPaths64): Boolean; overload; virtual; function Execute(clipType: TClipType; fillRule: TFillRule; var solutionTree: TPolyTree64; out openSolutions: TPaths64): Boolean; overload; virtual; {$IFDEF USINGZ} property ZCallback; {$ENDIF} end; // PolyPathBase: ancestor of TPolyPath and TPolyPathD TPolyPathBase = class {$IFDEF STRICT}strict{$ENDIF} private FParent : TPolyPathBase; FChildList : TList; function GetChildCnt: Integer; function GetIsHole: Boolean; protected function GetChild(index: Integer): TPolyPathBase; function AddChild(const path: TPath64): TPolyPathBase; virtual; abstract; property ChildList: TList read FChildList; property Parent: TPolyPathBase read FParent write FParent; public constructor Create; virtual; destructor Destroy; override; procedure Clear; virtual; property IsHole: Boolean read GetIsHole; property Count: Integer read GetChildCnt; property Child[index: Integer]: TPolyPathBase read GetChild; default; end; TPolyPath64 = class(TPolyPathBase) {$IFDEF STRICT}strict{$ENDIF} private FPath : TPath64; function GetChild64(index: Integer): TPolyPath64; protected function AddChild(const path: TPath64): TPolyPathBase; override; public property Child[index: Integer]: TPolyPath64 read GetChild64; default; property Polygon: TPath64 read FPath; end; // PolyTree: is intended as a READ-ONLY data structure to receive closed path // solutions to clipping operations. While this structure is more complex than // the alternative TPaths structure, it does model path ownership (ie paths // that are contained by other paths). This will be useful to some users. TPolyTree64 = class(TPolyPath64); // FLOATING POINT POLYGON COORDINATES (D suffix to indicate double precision) // To preserve numerical robustness, clipping must be done using integer // coordinates. Consequently, polygons that are defined with floating point // coordinates will need these converted into integer values together with // scaling to achieve the desired floating point precision. TClipperD = class(TClipperBase) // for floating point coordinates {$IFDEF STRICT}strict{$ENDIF} private FScale: double; FInvScale: double; {$IFDEF USINGZ} fZCallback : TZCallbackD; procedure ZCB(const bot1, top1, bot2, top2: TPoint64; var intersectPt: TPoint64); procedure CheckCallback; {$ENDIF} public procedure AddSubject(const pathD: TPathD); overload; procedure AddSubject(const pathsD: TPathsD); overload; procedure AddOpenSubject(const pathD: TPathD); overload; procedure AddOpenSubject(const pathsD: TPathsD); overload; procedure AddClip(const pathD: TPathD); overload; procedure AddClip(const pathsD: TPathsD); overload; constructor Create(precision: integer = 2); reintroduce; overload; function Execute(clipType: TClipType; fillRule: TFillRule; out closedSolutions: TPathsD): Boolean; overload; function Execute(clipType: TClipType; fillRule: TFillRule; out closedSolutions, openSolutions: TPathsD): Boolean; overload; function Execute(clipType: TClipType; fillRule: TFillRule; var solutionsTree: TPolyTreeD; out openSolutions: TPathsD): Boolean; overload; {$IFDEF USINGZ} property ZCallback : TZCallbackD read fZCallback write fZCallback; {$ENDIF} end; TPolyPathD = class(TPolyPathBase) {$IFDEF STRICT}strict{$ENDIF} private FPath : TPathD; function GetChildD(index: Integer): TPolyPathD; protected FScale : double; function AddChild(const path: TPath64): TPolyPathBase; override; public property Polygon: TPathD read FPath; property Child[index: Integer]: TPolyPathD read GetChildD; default; end; TPolyTreeD = class(TPolyPathD) protected procedure SetScale(value: double); // alternative to friend class public property Scale: double read FScale; end; implementation //OVERFLOWCHECKS OFF is a necessary workaround for a compiler bug that very //occasionally reports incorrect overflow errors in Delphi versions before 10.2. //see https://forums.embarcadero.com/message.jspa?messageID=871444 {$OVERFLOWCHECKS OFF} resourcestring rsClipper_PolyTreeErr = 'The TPolyTree parameter must be assigned.'; rsClipper_ClippingErr = 'Undefined clipping error'; const DefaultClipperDScale = 100; //------------------------------------------------------------------------------ // Miscellaneous Functions ... //------------------------------------------------------------------------------ function UnsafeGet(List: TList; Index: Integer): Pointer; {$IFDEF INLINING} inline; {$ENDIF} begin Result := List.List[Index]; end; //------------------------------------------------------------------------------ function IsOpen(e: PActive): Boolean; overload; {$IFDEF INLINING} inline; {$ENDIF} begin Result := e.locMin.isOpen; end; //------------------------------------------------------------------------------ function IsOpenEnd(e: PActive): Boolean; overload; {$IFDEF INLINING} inline; {$ENDIF} begin Result := e.locMin.isOpen and (e.vertTop.flags * [vfOpenStart, vfOpenEnd] <> []); end; //------------------------------------------------------------------------------ function IsHotEdge(e: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := assigned(e.outrec); end; //------------------------------------------------------------------------------ function GetPrevHotEdge(e: PActive): PActive; {$IFDEF INLINING} inline; {$ENDIF} begin Result := e.prevInAEL; while assigned(Result) and (IsOpen(Result) or not IsHotEdge(Result)) do Result := Result.prevInAEL; end; //------------------------------------------------------------------------------ function IsFront(e: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := (e = e.outrec.frontE); end; //------------------------------------------------------------------------------ function IsValidPath(op: POutPt): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin result := assigned(op) and (op.next <> op); end; //------------------------------------------------------------------------------ function PtsReallyClose(const pt1, pt2: TPoint64): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := (abs(pt1.X - pt2.X) < 2) and (abs(pt1.Y - pt2.Y) < 2); end; //------------------------------------------------------------------------------ function IsVerySmallTriangle(op: POutPt): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin //also treat inconsequential polygons as invalid Result := (op.next.next = op.prev) and (PtsReallyClose(op.prev.pt, op.next.pt) or PtsReallyClose(op.pt, op.next.pt) or PtsReallyClose(op.pt, op.prev.pt)); end; //------------------------------------------------------------------------------ function IsValidClosedPath(op: POutPt): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin result := assigned(op) and (op.next <> op) and (op.next <> op.prev) and not IsVerySmallTriangle(op); end; //------------------------------------------------------------------------------ (******************************************************************************* * Dx: 0(90deg) * * | * * +inf (180deg) <--- o ---> -inf (0deg) * *******************************************************************************) function GetDx(const pt1, pt2: TPoint64): double; {$IFDEF INLINING} inline; {$ENDIF} var dy: Int64; begin dy := (pt2.Y - pt1.Y); if dy <> 0 then result := (pt2.X - pt1.X) / dy else if (pt2.X > pt1.X) then result := NegInfinity else result := Infinity; end; //------------------------------------------------------------------------------ function TopX(e: PActive; const currentY: Int64): Int64; overload; {$IFDEF INLINING} inline; {$ENDIF} begin if (currentY = e.top.Y) or (e.top.X = e.bot.X) then Result := e.top.X else if (currentY = e.bot.Y) then Result := e.bot.X else Result := e.bot.X + Round(e.dx*(currentY - e.bot.Y)); end; //------------------------------------------------------------------------------ function IsHorizontal(e: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := (e.top.Y = e.bot.Y); end; //------------------------------------------------------------------------------ function IsHeadingRightHorz(e: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := (e.dx = NegInfinity); end; //------------------------------------------------------------------------------ function IsHeadingLeftHorz(e: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := (e.dx = Infinity); end; //------------------------------------------------------------------------------ procedure SwapActives(var e1, e2: PActive); {$IFDEF INLINING} inline; {$ENDIF} var e: PActive; begin e := e1; e1 := e2; e2 := e; end; //------------------------------------------------------------------------------ function GetPolyType(const e: PActive): TPathType; {$IFDEF INLINING} inline; {$ENDIF} begin Result := e.locMin.polytype; end; //------------------------------------------------------------------------------ function IsSamePolyType(const e1, e2: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := e1.locMin.polytype = e2.locMin.polytype; end; //------------------------------------------------------------------------------ function DblToInt64(val: double): Int64; {$IFDEF INLINE} inline; {$ENDIF} var exp: integer; i64: UInt64 absolute val; begin //https://en.wikipedia.org/wiki/Double-precision_floating-point_format Result := 0; if i64 = 0 then Exit; exp := Integer(Cardinal(i64 shr 52) and $7FF) - 1023; //nb: when exp == 1024 then val == INF or NAN. if exp < 0 then Exit; Result := ((i64 and $1FFFFFFFFFFFFF) shr (52 - exp)) or (UInt64(1) shl exp); if val < 0 then Result := -Result; end; //------------------------------------------------------------------------------ function GetIntersectPoint(e1, e2: PActive): TPoint64; var b1, b2, m: Double; begin m := (e1.dx - e2.dx); if Abs(m) < 1.0e-5 then begin Result := GetClosestLineEnd(e1.bot, e1.top, e2.bot, e2.top); Exit; end else if e1.dx = 0 then begin Result.X := e1.bot.X; if IsHorizontal(e2) then Result.Y := e2.bot.Y else begin with e2^ do b2 := bot.Y - (bot.X/dx); Result.Y := round(Result.X/e2.dx + b2); end; end else if e2.dx = 0 then begin Result.X := e2.bot.X; if IsHorizontal(e1) then Result.Y := e1.bot.Y else begin with e1^ do b1 := bot.Y - (bot.X/dx); Result.Y := round(Result.X/e1.dx + b1); end; end else begin with e1^ do b1 := bot.X - bot.Y * dx; with e2^ do b2 := bot.X - bot.Y * dx; m := (b2 - b1) / m; Result.Y := DblToInt64(m); //Round(m); if Abs(e1.dx) < Abs(e2.dx) then Result.X := DblToInt64(e1.dx * m + b1) else Result.X := DblToInt64(e2.dx * m + b2); end; end; //------------------------------------------------------------------------------ procedure SetDx(e: PActive); {$IFDEF INLINING} inline; {$ENDIF} begin e.dx := GetDx(e.bot, e.top); end; //------------------------------------------------------------------------------ function IsLeftBound(e: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := e.isLeftB; end; //------------------------------------------------------------------------------ function NextVertex(e: PActive): PVertex; // ie heading (inverted Y-axis) "up" {$IFDEF INLINING} inline; {$ENDIF} begin if e.windDx > 0 then Result := e.vertTop.next else Result := e.vertTop.prev; end; //------------------------------------------------------------------------------ //PrevPrevVertex: useful to get the (inverted Y-axis) top of the //alternate edge (ie left or right bound) during edge insertion. function PrevPrevVertex(e: PActive): PVertex; {$IFDEF INLINING} inline; {$ENDIF} begin if e.windDx > 0 then Result := e.vertTop.prev.prev else Result := e.vertTop.next.next; end; //------------------------------------------------------------------------------ function IsMaxima(vertex: PVertex): Boolean; overload; {$IFDEF INLINING} inline; {$ENDIF} begin Result := vfLocMax in vertex.flags; end; //------------------------------------------------------------------------------ function IsMaxima(e: PActive): Boolean; overload; {$IFDEF INLINING} inline; {$ENDIF} begin Result := vfLocMax in e.vertTop.flags; end; //------------------------------------------------------------------------------ function GetCurrYMaximaVertex(e: PActive): PVertex; begin // nb: function not safe with open paths Result := e.vertTop; if e.windDx > 0 then while Result.next.pt.Y = Result.pt.Y do Result := Result.next else while Result.prev.pt.Y = Result.pt.Y do Result := Result.prev; if not IsMaxima(Result) then Result := nil; // not a maxima end; //------------------------------------------------------------------------------ function GetMaximaPair(e: PActive): PActive; begin Result := e.nextInAEL; while assigned(Result) do begin if Result.vertTop = e.vertTop then Exit; // Found! Result := Result.nextInAEL; end; Result := nil; end; //------------------------------------------------------------------------------ function GetHorzMaximaPair(horz: PActive; maxVert: PVertex): PActive; begin // we can't be sure whether the MaximaPair is on the left or right, so ... Result := horz.prevInAEL; while assigned(Result) and (Result.currX >= maxVert.pt.X) do begin if Result.vertTop = maxVert then Exit; // Found! Result := Result.prevInAEL; end; Result := horz.nextInAEL; while assigned(Result) and (TopX(Result, horz.top.Y) <= maxVert.pt.X) do begin if Result.vertTop = maxVert then Exit; // Found! Result := Result.nextInAEL; end; Result := nil; end; //------------------------------------------------------------------------------ function PointCount(pts: POutPt): Integer; {$IFDEF INLINING} inline; {$ENDIF} var p: POutPt; begin Result := 0; if not Assigned(pts) then Exit; p := pts; repeat Inc(Result); p := p.next; until p = pts; end; //------------------------------------------------------------------------------ function GetRealOutRec(outRec: POutRec): POutRec; {$IFDEF INLINING} inline; {$ENDIF} begin Result := outRec; while Assigned(Result) and not Assigned(Result.pts) do Result := Result.owner; end; //------------------------------------------------------------------------------ procedure UncoupleOutRec(e: PActive); var outRec: POutRec; begin if not Assigned(e.outrec) then Exit; outRec := e.outrec; outRec.frontE.outrec := nil; outRec.backE.outrec := nil; outRec.frontE := nil; outRec.backE := nil; end; //------------------------------------------------------------------------------ procedure AddPathsToVertexList(const paths: TPaths64; polyType: TPathType; isOpen: Boolean; vertexList, LocMinList: TList); var i, j, len, totalVerts: integer; p: PPoint64; v, va0, vaCurr, vaPrev: PVertex; ascending, ascending0: Boolean; procedure AddLocMin(vert: PVertex); var lm: PLocalMinima; begin if vfLocMin in vert.flags then Exit; // ie already added Include(vert.flags, vfLocMin); new(lm); lm.vertex := vert; lm.polytype := polyType; lm.isOpen := isOpen; LocMinList.Add(lm); // nb: sorted in Reset() end; //--------------------------------------------------------- begin // count the total (maximum) number of vertices required totalVerts := 0; for i := 0 to High(paths) do totalVerts := totalVerts + Length(paths[i]); if (totalVerts = 0) then Exit; // allocate memory GetMem(v, sizeof(TVertex) * totalVerts); vertexList.Add(v); for i := 0 to High(paths) do begin len := Length(paths[i]); if len = 0 then Continue; p := @paths[i][0]; va0 := v; vaCurr := v; vaCurr.pt := p^; vaCurr.prev := nil; inc(p); vaCurr.flags := []; vaPrev := vaCurr; inc(vaCurr); for j := 1 to len -1 do begin if PointsEqual(vaPrev.pt, p^) then begin inc(p); Continue; // skips duplicates end; vaPrev.next := vaCurr; vaCurr.prev := vaPrev; vaCurr.pt := p^; vaCurr.flags := []; vaPrev := vaCurr; inc(vaCurr); inc(p); end; if not Assigned(vaPrev.prev) then Continue; if not isOpen and PointsEqual(vaPrev.pt, va0.pt) then vaPrev := vaPrev.prev; vaPrev.next := va0; va0.prev := vaPrev; v := vaCurr; // ie get ready for next path if isOpen and (va0.next = va0) then Continue; // now find and assign local minima if (isOpen) then begin vaCurr := va0.next; while (vaCurr <> va0) and (vaCurr.pt.Y = va0.pt.Y) do vaCurr := vaCurr.next; ascending := vaCurr.pt.Y <= va0.pt.Y; if (ascending) then begin va0.flags := [vfOpenStart]; AddLocMin(va0); end else va0.flags := [vfOpenStart, vfLocMax]; end else begin // closed path vaPrev := va0.prev; while (vaPrev <> va0) and (vaPrev.pt.Y = va0.pt.Y) do vaPrev := vaPrev.prev; if (vaPrev = va0) then Continue; // only open paths can be completely flat ascending := vaPrev.pt.Y > va0.pt.Y; end; ascending0 := ascending; vaPrev := va0; vaCurr := va0.next; while (vaCurr <> va0) do begin if (vaCurr.pt.Y > vaPrev.pt.Y) and ascending then begin Include(vaPrev.flags, vfLocMax); ascending := false; end else if (vaCurr.pt.Y < vaPrev.pt.Y) and not ascending then begin ascending := true; AddLocMin(vaPrev); end; vaPrev := vaCurr; vaCurr := vaCurr.next; end; if (isOpen) then begin Include(vaPrev.flags, vfOpenEnd); if ascending then Include(vaPrev.flags, vfLocMax) else AddLocMin(vaPrev); end else if (ascending <> ascending0) then begin if (ascending0) then AddLocMin(vaPrev) else Include(vaPrev.flags, vfLocMax); end; end; end; //------------------------------------------------------------------------------ function BuildPath(op: POutPt; reverse, isOpen: Boolean; out path: TPath64): Boolean; var i,j, cnt: integer; begin cnt := PointCount(op); if (cnt < 3) and (not isOpen or (Cnt < 2)) then begin Result := false; Exit; end; if (cnt = 3) and IsVerySmallTriangle(op) then begin Result := false; Exit; end; setLength(path, cnt); if reverse then begin path[0] := op.pt; op := op.prev; end else begin op := op.next; path[0] := op.pt; op := op.next; end; j := 0; for i := 0 to cnt -2 do begin if not PointsEqual(path[j], op.pt) then begin inc(j); path[j] := op.pt; end; if reverse then op := op.prev else op := op.next; end; setLength(path, j+1); if isOpen then Result := (j > 0) else Result := (j > 1); end; //------------------------------------------------------------------------------ function DisposeOutPt(op: POutPt): POutPt; begin if op.next = op then Result := nil else Result := op.next; op.prev.next := op.next; op.next.prev := op.prev; Dispose(Op); end; //------------------------------------------------------------------------------ procedure DisposeOutPts(op: POutPt); {$IFDEF INLINING} inline; {$ENDIF} var tmpPp: POutPt; begin op.prev.next := nil; while Assigned(op) do begin tmpPp := op; op := op.next; Dispose(tmpPp); end; end; //------------------------------------------------------------------------------ function LocMinListSort(item1, item2: Pointer): Integer; var q: Int64; lm1: PLocalMinima absolute item1; lm2: PLocalMinima absolute item2; begin q := lm2.vertex.pt.Y - lm1.vertex.pt.Y; if q < 0 then Result := -1 else if q > 0 then Result := 1 else begin q := lm2.vertex.pt.X - lm1.vertex.pt.X; if q < 0 then Result := 1 else if q > 0 then Result := -1 else Result := 0; end; end; //------------------------------------------------------------------------------ procedure SetSides(outRec: POutRec; startEdge, endEdge: PActive); {$IFDEF INLINING} inline; {$ENDIF} begin outRec.frontE := startEdge; outRec.backE := endEdge; end; //------------------------------------------------------------------------------ procedure SwapOutRecs(e1, e2: PActive); var or1, or2: POutRec; e: PActive; begin or1 := e1.outrec; or2 := e2.outrec; if (or1 = or2) then begin // nb: at least one edge is 'hot' e := or1.frontE; or1.frontE := or1.backE; or1.backE := e; Exit; end; if assigned(or1) then begin if e1 = or1.frontE then or1.frontE := e2 else or1.backE := e2; end; if assigned(or2) then begin if e2 = or2.frontE then or2.frontE := e1 else or2.backE := e1; end; e1.outrec := or2; e2.outrec := or1; end; //------------------------------------------------------------------------------ function Area(op: POutPt): Double; var op2: POutPt; d: double; begin // https://en.wikipedia.org/wiki/Shoelace_formula Result := 0; if not Assigned(op) then Exit; op2 := op; repeat d := (op2.prev.pt.Y + op2.pt.Y); Result := Result + d * (op2.prev.pt.X - op2.pt.X); op2 := op2.next; until op2 = op; Result := Result * 0.5; end; //------------------------------------------------------------------------------ function AreaTriangle(const pt1, pt2, pt3: TPoint64): double; var d1,d2,d3,d4,d5,d6: double; begin d1 := (pt3.y + pt1.y); d2 := (pt3.x - pt1.x); d3 := (pt1.y + pt2.y); d4 := (pt1.x - pt2.x); d5 := (pt2.y + pt3.y); d6 := (pt2.x - pt3.x); result := d1 * d2 + d3 *d4 + d5 *d6; end; //------------------------------------------------------------------------------ procedure ReverseOutPts(op: POutPt); var op1, op2: POutPt; begin if not Assigned(op) then Exit; op1 := op; repeat op2:= op1.next; op1.next := op1.prev; op1.prev := op2; op1 := op2; until op1 = op; end; //------------------------------------------------------------------------------ function OutrecIsAscending(hotEdge: PActive): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := (hotEdge = hotEdge.outrec.frontE); end; //------------------------------------------------------------------------------ procedure SwapFrontBackSides(outRec: POutRec); {$IFDEF INLINING} inline; {$ENDIF} var e2: PActive; begin // while this proc. is needed for open paths // it's almost never needed for closed paths e2 := outRec.frontE; outRec.frontE := outRec.backE; outRec.backE := e2; outRec.pts := outRec.pts.next; end; //------------------------------------------------------------------------------ function EdgesAdjacentInAEL(node: PIntersectNode): Boolean; {$IFDEF INLINING} inline; {$ENDIF} var active1, active2: PActive; begin active1 := node.active1; active2 := node.active2; Result := (active1.nextInAEL = active2) or (active1.prevInAEL = active2); end; //------------------------------------------------------------------------------ function TestJoinWithPrev1(e: PActive): Boolean; begin // this is marginally quicker than TestJoinWithPrev2 // but can only be used when e.PrevInAEL.currX is accurate Result := IsHotEdge(e) and not IsOpen(e) and Assigned(e.prevInAEL) and (e.prevInAEL.currX = e.currX) and IsHotEdge(e.prevInAEL) and not IsOpen(e.prevInAEL) and (CrossProduct(e.prevInAEL.top, e.bot, e.top) = 0); end; //------------------------------------------------------------------------------ function TestJoinWithPrev2(e: PActive; const currPt: TPoint64): Boolean; begin Result := IsHotEdge(e) and not IsOpen(e) and Assigned(e.prevInAEL) and not IsOpen(e.prevInAEL) and IsHotEdge(e.prevInAEL) and (Abs(TopX(e.prevInAEL, currPt.Y) - currPt.X) < 2) and (e.prevInAEL.top.Y < currPt.Y) and (CrossProduct(e.prevInAEL.top, currPt, e.top) = 0); end; //------------------------------------------------------------------------------ function TestJoinWithNext1(e: PActive): Boolean; begin // this is marginally quicker than TestJoinWithNext2 // but can only be used when e.NextInAEL.currX is accurate Result := IsHotEdge(e) and Assigned(e.nextInAEL) and IsHotEdge(e.nextInAEL) and not IsOpen(e) and not IsOpen(e.nextInAEL) and (e.nextInAEL.currX = e.currX) and (CrossProduct(e.nextInAEL.top, e.bot, e.top) = 0); end; //------------------------------------------------------------------------------ function TestJoinWithNext2(e: PActive; const currPt: TPoint64): Boolean; begin Result := IsHotEdge(e) and Assigned(e.nextInAEL) and IsHotEdge(e.nextInAEL) and not IsOpen(e) and not IsOpen(e.nextInAEL) and (Abs(TopX(e.nextInAEL, currPt.Y) - currPt.X) < 2) and // safer (e.nextInAEL.top.Y < currPt.Y) and (CrossProduct(e.nextInAEL.top, currPt, e.top) = 0); end; //------------------------------------------------------------------------------ function GetHorzTrialParent(op: POutPt): PJoiner; {$IFDEF INLINING} inline; {$ENDIF} begin Result := op.joiner; while Assigned(Result) do if Result.op1 = op then begin if Assigned(Result.next1) and (Result.next1.idx < 0) then Exit else Result := Result.next1; end else begin if Assigned(Result.next2) and (Result.next2.idx < 0) then Exit else Result := Result.next1; end; end; //------------------------------------------------------------------------------ function MakeDummyJoiner(horz: POutPt; nextJoiner: PJoiner): PJoiner; {$IFDEF INLINING} inline; {$ENDIF} begin new(Result); Result.idx := -1; Result.op1 := horz; Result.op2 := nil; Result.next1 := horz.joiner; horz.joiner := Result; Result.next2 := nil; Result.nextH := nextJoiner; end; //------------------------------------------------------------------------------ function OutPtInTrialHorzList(op: POutPt): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin Result := Assigned(op.joiner) and ((op.joiner.idx < 0) or Assigned(GetHorzTrialParent(op))); end; //------------------------------------------------------------------------------ function InsertOp(const pt: TPoint64; insertAfter: POutPt): POutPt; {$IFDEF INLINING} inline; {$ENDIF} begin new(Result); Result.pt := pt; Result.joiner := nil; Result.outrec := insertAfter.outrec; Result.next := insertAfter.next; insertAfter.next.prev := Result; insertAfter.next := Result; Result.prev := insertAfter; end; //------------------------------------------------------------------------------ // TClipperBase methods ... //------------------------------------------------------------------------------ constructor TClipperBase.Create; begin FLocMinList := TList.Create; FOutRecList := TList.Create; FJoinerList := TList.Create; FIntersectList := TList.Create; FVertexArrayList := TList.Create; FPreserveCollinear := true; FReverseSolution := false; end; //------------------------------------------------------------------------------ destructor TClipperBase.Destroy; begin Clear; FLocMinList.Free; FOutRecList.Free; FJoinerList.Free; FIntersectList.Free; FVertexArrayList.Free; inherited; end; //------------------------------------------------------------------------------ procedure TClipperBase.ClearSolution; var dummy: Int64; begin try // in case of exceptions ... DeleteEdges(FActives); while assigned(FScanLine) do PopScanLine(dummy); DisposeIntersectNodes; DisposeScanLineList; DisposeOutRecsAndJoiners; FHorzTrials := nil; except end; end; //------------------------------------------------------------------------------ procedure TClipperBase.Clear; begin ClearSolution; DisposeVerticesAndLocalMinima; FCurrentLocMinIdx := 0; FLocMinListSorted := false; FHasOpenPaths := False; end; //------------------------------------------------------------------------------ procedure TClipperBase.Reset; var i: Integer; begin if not FLocMinListSorted then begin FLocMinList.Sort(LocMinListSort); FLocMinListSorted := true; end; for i := FLocMinList.Count -1 downto 0 do InsertScanLine(PLocalMinima(UnsafeGet(FLocMinList, i)).vertex.pt.Y); FCurrentLocMinIdx := 0; FActives := nil; FSel := nil; FSucceeded := true; end; //------------------------------------------------------------------------------ {$IFDEF USINGZ} function XYCoordsEqual(const pt1, pt2: TPoint64): Boolean; begin Result := (pt1.X = pt2.X) and (pt1.Y = pt2.Y); end; //------------------------------------------------------------------------------ procedure TClipperBase.SetZ(e1, e2: PActive; var intersectPt: TPoint64); begin if not Assigned(fZCallback) then Exit; // prioritize subject vertices over clip vertices // and pass the subject vertices before clip vertices in the callback if (GetPolyType(e1) = ptSubject) then begin if (XYCoordsEqual(intersectPt, e1.bot)) then intersectPt.Z := e1.bot.Z else if (XYCoordsEqual(intersectPt, e1.top)) then intersectPt.Z := e1.top.Z else if (XYCoordsEqual(intersectPt, e2.bot)) then intersectPt.Z := e2.bot.Z else if (XYCoordsEqual(intersectPt, e2.top)) then intersectPt.Z := e2.top.Z; fZCallback(e1.bot, e1.top, e2.bot, e2.top, intersectPt); end else begin if (XYCoordsEqual(intersectPt, e2.bot)) then intersectPt.Z := e2.bot.Z else if (XYCoordsEqual(intersectPt, e2.top)) then intersectPt.Z := e2.top.Z else if (XYCoordsEqual(intersectPt, e1.bot)) then intersectPt.Z := e1.bot.Z else if (XYCoordsEqual(intersectPt, e1.top)) then intersectPt.Z := e1.top.Z; fZCallback(e2.bot, e2.top, e1.bot, e1.top, intersectPt); end; end; //------------------------------------------------------------------------------ {$ENDIF} procedure TClipperBase.InsertScanLine(const Y: Int64); var newSl, sl: PScanLine; begin // The scanline list is a single-linked list of all the Y coordinates of // subject and clip vertices in the clipping operation (sorted descending). // However, only scanline Y's at Local Minima are inserted before clipping // starts. While scanlines are removed sequentially during the sweep operation, // new scanlines are only inserted whenever edge bounds are updated. This keeps // the scanline list relatively short, optimising performance. if not Assigned(FScanLine) then begin new(newSl); newSl.y := Y; FScanLine := newSl; newSl.next := nil; end else if Y > FScanLine.y then begin new(newSl); newSl.y := Y; newSl.next := FScanLine; FScanLine := newSl; end else begin sl := FScanLine; while Assigned(sl.next) and (Y <= sl.next.y) do sl := sl.next; if Y = sl.y then Exit; // skip duplicates new(newSl); newSl.y := Y; newSl.next := sl.next; sl.next := newSl; end; end; //------------------------------------------------------------------------------ function TClipperBase.PopScanLine(out Y: Int64): Boolean; var sl: PScanLine; begin Result := assigned(FScanLine); if not Result then Exit; Y := FScanLine.y; sl := FScanLine; FScanLine := FScanLine.next; dispose(sl); end; //------------------------------------------------------------------------------ function TClipperBase.PopLocalMinima(Y: Int64; out localMinima: PLocalMinima): Boolean; begin Result := false; if FCurrentLocMinIdx = FLocMinList.Count then Exit; localMinima := PLocalMinima(UnsafeGet(FLocMinList, FCurrentLocMinIdx)); if (localMinima.vertex.pt.Y = Y) then begin inc(FCurrentLocMinIdx); Result := true; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DisposeScanLineList; var sl: PScanLine; begin while Assigned(FScanLine) do begin sl := FScanLine.next; Dispose(FScanLine); FScanLine := sl; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DisposeOutRecsAndJoiners; var i: Integer; outrec: POutRec; begin // just in case joiners haven't already been disposed for i := 0 to FJoinerList.Count -1 do if Assigned(UnsafeGet(FJoinerList, i)) then Dispose(PJoiner(UnsafeGet(FJoinerList, i))); FJoinerList.Clear; FHorzTrials := nil; for i := 0 to FOutRecList.Count -1 do begin outrec := UnsafeGet(FOutRecList, i); if Assigned(outrec.pts) then DisposeOutPts(outrec.pts); Dispose(outrec); end; FOutRecList.Clear; end; //------------------------------------------------------------------------------ procedure TClipperBase.DisposeVerticesAndLocalMinima; var i: Integer; begin for i := 0 to FLocMinList.Count -1 do Dispose(PLocalMinima(UnsafeGet(FLocMinList, i))); FLocMinList.Clear; for i := 0 to FVertexArrayList.Count -1 do FreeMem(UnsafeGet(FVertexArrayList, i)); FVertexArrayList.Clear; end; //------------------------------------------------------------------------------ procedure TClipperBase.AddPath(const path: TPath64; pathType: TPathType; isOpen: Boolean); var pp: TPaths64; begin SetLength(pp, 1); pp[0] := path; AddPaths(pp, pathType, isOpen); end; //------------------------------------------------------------------------------ procedure TClipperBase.AddPaths(const paths: TPaths64; pathType: TPathType; isOpen: Boolean); begin if isOpen then FHasOpenPaths := true; FLocMinListSorted := false; AddPathsToVertexList(paths, pathType, isOpen, FVertexArrayList, FLocMinList); end; //------------------------------------------------------------------------------ function TClipperBase.IsContributingClosed(e: PActive): Boolean; begin Result := false; case FFillRule of frNonZero: if abs(e.windCnt) <> 1 then Exit; frPositive: if (e.windCnt <> 1) then Exit; frNegative: if (e.windCnt <> -1) then Exit; end; case FClipType of ctIntersection: case FFillRule of frPositive: Result := (e.windCnt2 > 0); frNegative: Result := (e.windCnt2 < 0); else Result := (e.windCnt2 <> 0); end; ctUnion: case FFillRule of frPositive: Result := (e.windCnt2 <= 0); frNegative: Result := (e.windCnt2 >= 0); else Result := (e.windCnt2 = 0); end; ctDifference: begin case FFillRule of frPositive: Result := (e.windCnt2 <= 0); frNegative: Result := (e.windCnt2 >= 0); else Result := (e.windCnt2 = 0); end; if GetPolyType(e) <> ptSubject then Result := not Result; end; ctXor: Result := true; end; end; //------------------------------------------------------------------------------ function TClipperBase.IsContributingOpen(e: PActive): Boolean; var isInSubj, isInClip: Boolean; begin case FFillRule of frPositive: begin isInSubj := e.windCnt > 0; isInClip := e.windCnt2 > 0; end; frNegative: begin isInSubj := e.windCnt < 0; isInClip := e.windCnt2 < 0; end; else begin isInSubj := e.windCnt <> 0; isInClip := e.windCnt2 <> 0; end; end; case FClipType of ctIntersection: Result := isInClip; ctUnion: Result := not isInSubj and not isInClip; else Result := not isInClip; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.SetWindCountForClosedPathEdge(e: PActive); var e2: PActive; begin // Wind counts refer to polygon regions not edges, so here an edge's WindCnt // indicates the higher of the wind counts for the two regions touching the // edge. (nb: Adjacent regions can only ever have their wind counts differ by // one. Also, open paths have no meaningful wind directions or counts.) e2 := e.prevInAEL; // find the nearest closed path edge of the same PolyType in AEL (heading left) while Assigned(e2) and (not IsSamePolyType(e2, e) or IsOpen(e2)) do e2 := e2.prevInAEL; if not Assigned(e2) then begin e.windCnt := e.windDx; e2 := FActives; end else if (FFillRule = frEvenOdd) then begin e.windCnt := e.windDx; e.windCnt2 := e2.windCnt2; e2 := e2.nextInAEL; end else begin // NonZero, positive, or negative filling here ... // when e2's WindCnt is in the SAME direction as its WindDx, // then polygon will fill on the right of 'e2' (and 'e' will be inside) // nb: neither e2.WindCnt nor e2.WindDx should ever be 0. if (e2.windCnt * e2.windDx < 0) then begin // opposite directions so 'e' is outside 'e2' ... if (Abs(e2.windCnt) > 1) then begin // outside prev poly but still inside another. if (e2.windDx * e.windDx < 0) then // reversing direction so use the same WC e.windCnt := e2.windCnt else // otherwise keep 'reducing' the WC by 1 (ie towards 0) ... e.windCnt := e2.windCnt + e.windDx; end // now outside all polys of same polytype so set own WC ... else e.windCnt := e.windDx; end else begin //'e' must be inside 'e2' if (e2.windDx * e.windDx < 0) then // reversing direction so use the same WC e.windCnt := e2.windCnt else // otherwise keep 'increasing' the WC by 1 (ie away from 0) ... e.windCnt := e2.windCnt + e.windDx; end; e.windCnt2 := e2.windCnt2; e2 := e2.nextInAEL; end; // update WindCnt2 ... if FFillRule = frEvenOdd then while (e2 <> e) do begin if IsSamePolyType(e2, e) or IsOpen(e2) then // do nothing else if e.windCnt2 = 0 then e.windCnt2 := 1 else e.windCnt2 := 0; e2 := e2.nextInAEL; end else while (e2 <> e) do begin if not IsSamePolyType(e2, e) and not IsOpen(e2) then Inc(e.windCnt2, e2.windDx); e2 := e2.nextInAEL; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.SetWindCountForOpenPathEdge(e: PActive); var e2: PActive; cnt1, cnt2: Integer; begin e2 := FActives; if FFillRule = frEvenOdd then begin cnt1 := 0; cnt2 := 0; while (e2 <> e) do begin if (GetPolyType(e2) = ptClip) then inc(cnt2) else if not IsOpen(e2) then inc(cnt1); e2 := e2.nextInAEL; end; if Odd(cnt1) then e.windCnt := 1 else e.windCnt := 0; if Odd(cnt2) then e.windCnt2 := 1 else e.windCnt2 := 0; end else begin // if FClipType in [ctUnion, ctDifference] then e.WindCnt := e.WindDx; while (e2 <> e) do begin if (GetPolyType(e2) = ptClip) then inc(e.windCnt2, e2.windDx) else if not IsOpen(e2) then inc(e.windCnt, e2.windDx); e2 := e2.nextInAEL; end; end; end; //------------------------------------------------------------------------------ function IsValidAelOrder(resident, newcomer: PActive): Boolean; var botY: Int64; newcomerIsLeft: Boolean; d: double; begin if newcomer.currX <> resident.currX then begin Result := newcomer.currX > resident.currX; Exit; end; // get the turning direction a1.top, a2.bot, a2.top d := CrossProduct(resident.top, newcomer.bot, newcomer.top); if d <> 0 then begin Result := d < 0; Exit; end; // edges must be collinear to get here if not IsMaxima(resident) and (resident.top.Y > newcomer.top.Y) then begin Result := CrossProduct(newcomer.bot, resident.top, NextVertex(resident).pt) <= 0; Exit; end else if not IsMaxima(newcomer) and (newcomer.top.Y > resident.top.Y) then begin Result := CrossProduct(newcomer.bot, newcomer.top, NextVertex(newcomer).pt) >= 0; Exit; end; botY := newcomer.bot.Y; newcomerIsLeft := IsLeftBound(newcomer); if (resident.bot.Y <> botY) or (resident.locMin.vertex.pt.Y <> botY) then Result := newcomerIsLeft // resident must also have just been inserted else if IsLeftBound(resident) <> newcomerIsLeft then Result := newcomerIsLeft else if (CrossProduct(PrevPrevVertex(resident).pt, resident.bot, resident.top) = 0) then Result := true else // otherwise compare turning direction of the alternate bound Result := (CrossProduct(PrevPrevVertex(resident).pt, newcomer.bot, PrevPrevVertex(newcomer).pt) > 0) = newcomerIsLeft; end; //------------------------------------------------------------------------------ procedure TClipperBase.InsertLeftEdge(e: PActive); var e2: PActive; begin if not Assigned(FActives) then begin e.prevInAEL := nil; e.nextInAEL := nil; FActives := e; end else if not IsValidAelOrder(FActives, e) then begin e.prevInAEL := nil; e.nextInAEL := FActives; FActives.prevInAEL := e; FActives := e; end else begin e2 := FActives; while Assigned(e2.nextInAEL) and IsValidAelOrder(e2.nextInAEL, e) do e2 := e2.nextInAEL; e.nextInAEL := e2.nextInAEL; if Assigned(e2.nextInAEL) then e2.nextInAEL.prevInAEL := e; e.prevInAEL := e2; e2.nextInAEL := e; end; end; //---------------------------------------------------------------------- procedure InsertRightEdge(e, e2: PActive); begin e2.nextInAEL := e.nextInAEL; if Assigned(e.nextInAEL) then e.nextInAEL.prevInAEL := e2; e2.prevInAEL := e; e.nextInAEL := e2; end; //---------------------------------------------------------------------- procedure TClipperBase.InsertLocalMinimaIntoAEL(const botY: Int64); var leftB, rightB: PActive; op: POutPt; locMin: PLocalMinima; contributing: Boolean; begin // Add local minima (if any) at BotY ... // nb: horizontal local minima edges should contain locMin.Vertex.prev while PopLocalMinima(botY, locMin) do begin if (vfOpenStart in locMin.vertex.flags) then begin leftB := nil; end else begin new(leftB); FillChar(leftB^, sizeof(TActive), 0); leftB.locMin := locMin; leftB.outrec := nil; leftB.bot := locMin.vertex.pt; leftB.windDx := -1; leftB.vertTop := locMin.vertex.prev; leftB.top := leftB.vertTop.pt; leftB.currX := leftB.bot.X; SetDx(leftB); end; if (vfOpenEnd in locMin.vertex.flags) then begin rightB := nil; end else begin new(rightB); FillChar(rightB^, sizeof(TActive), 0); rightB.locMin := locMin; rightB.outrec := nil; rightB.bot := locMin.vertex.pt; rightB.windDx := 1; rightB.vertTop := locMin.vertex.next; rightB.top := rightB.vertTop.pt; rightB.currX := rightB.bot.X; SetDx(rightB); end; // Currently LeftB is just descending and RightB is ascending, // so now we swap them if LeftB isn't actually on the left. if assigned(leftB) and assigned(rightB) then begin if IsHorizontal(leftB) then begin if IsHeadingRightHorz(leftB) then SwapActives(leftB, rightB); end else if IsHorizontal(rightB) then begin if IsHeadingLeftHorz(rightB) then SwapActives(leftB, rightB); end else if (leftB.dx < rightB.dx) then SwapActives(leftB, rightB); //so when leftB has windDx == 1, the polygon will be oriented //counter-clockwise in Cartesian coords (clockwise with inverted Y). end else if not assigned(leftB) then begin leftB := rightB; rightB := nil; end; LeftB.isLeftB := true; // nb: we can't use winddx instead InsertLeftEdge(leftB); //////////////// if IsOpen(leftB) then begin SetWindCountForOpenPathEdge(leftB); contributing := IsContributingOpen(leftB); end else begin SetWindCountForClosedPathEdge(leftB); contributing := IsContributingClosed(leftB); end; if assigned(rightB) then begin rightB.windCnt := leftB.windCnt; rightB.windCnt2 := leftB.windCnt2; InsertRightEdge(leftB, rightB); //////////////// if contributing then begin AddLocalMinPoly(leftB, rightB, leftB.bot, true); if not IsHorizontal(leftB) and TestJoinWithPrev1(leftB) then begin op := AddOutPt(leftB.prevInAEL, leftB.bot); AddJoin(op, leftB.outrec.pts); end; end; while Assigned(rightB.nextInAEL) and IsValidAelOrder(rightB.nextInAEL, rightB) do begin IntersectEdges(rightB, rightB.nextInAEL, rightB.bot); SwapPositionsInAEL(rightB, rightB.nextInAEL); end; if not IsHorizontal(rightB) and TestJoinWithNext1(rightB) then begin op := AddOutPt(rightB.nextInAEL, rightB.bot); AddJoin(rightB.outrec.pts, op); end; if IsHorizontal(rightB) then PushHorz(rightB) else InsertScanLine(rightB.top.Y); end else if contributing then StartOpenPath(leftB, leftB.bot); if IsHorizontal(leftB) then PushHorz(leftB) else InsertScanLine(leftB.top.Y); end; end; //------------------------------------------------------------------------------ procedure TClipperBase.PushHorz(e: PActive); begin if assigned(FSel) then e.nextInSEL := FSel else e.nextInSEL := nil; FSel := e; end; //------------------------------------------------------------------------------ function TClipperBase.PopHorz(out e: PActive): Boolean; begin Result := assigned(FSel); if not Result then Exit; e := FSel; FSel := FSel.nextInSEL; end; //------------------------------------------------------------------------------ function TClipperBase.AddLocalMinPoly(e1, e2: PActive; const pt: TPoint64; IsNew: Boolean = false): POutPt; var newOr: POutRec; prevHotEdge: PActive; begin new(newOr); newOr.idx := FOutRecList.Add(newOr); newOr.pts := nil; newOr.splits := nil; newOr.polypath := nil; e1.outrec := newOr; e2.outrec := newOr; // Setting the owner and inner/outer states (above) is an essential // precursor to setting edge 'sides' (ie left and right sides of output // polygons) and hence the orientation of output paths ... if IsOpen(e1) then begin newOr.owner := nil; newOr.isOpen := true; if e1.windDx > 0 then SetSides(newOr, e1, e2) else SetSides(newOr, e2, e1); end else begin prevHotEdge := GetPrevHotEdge(e1); newOr.isOpen := false; // e.windDx is the winding direction of the **input** paths // and unrelated to the winding direction of output polygons. // Output orientation is determined by e.outrec.frontE which is // the ascending edge (see AddLocalMinPoly). if Assigned(prevHotEdge) then begin newOr.owner := prevHotEdge.outrec; if OutrecIsAscending(prevHotEdge) = isNew then SetSides(newOr, e2, e1) else SetSides(newOr, e1, e2); end else begin newOr.owner := nil; if isNew then SetSides(newOr, e1, e2) else SetSides(newOr, e2, e1); end; end; new(Result); newOr.pts := Result; Result.pt := pt; Result.joiner := nil; Result.outrec := newOr; Result.prev := Result; Result.next := Result; end; //------------------------------------------------------------------------------ procedure TClipperBase.SafeDisposeOutPts(var op: POutPt); var tmpOp: POutPt; outRec: POutRec; begin outRec := GetRealOutRec(op.outrec); if Assigned(outRec.frontE) then outRec.frontE.outrec := nil; if Assigned(outRec.backE) then outRec.backE.outrec := nil; op.prev.next := nil; while Assigned(op) do begin SafeDeleteOutPtJoiners(op); tmpOp := op; op := op.next; Dispose(tmpOp); end; outRec.pts := nil; //must do this last (due to var parameter) end; //------------------------------------------------------------------------------ procedure TClipperBase.CleanCollinear(outRec: POutRec); var op2, startOp: POutPt; begin outRec := GetRealOutRec(outRec); if not Assigned(outRec) or outRec.isOpen or Assigned(outRec.frontE) or not ValidateClosedPathEx(outRec.pts) then Exit; startOp := outRec.pts; op2 := startOp; while true do begin if Assigned(op2.joiner) then Exit; if (CrossProduct(op2.prev.pt, op2.pt, op2.next.pt) = 0) and (PointsEqual(op2.pt,op2.prev.pt) or PointsEqual(op2.pt,op2.next.pt) or not FPreserveCollinear or (DotProduct(op2.prev.pt, op2.pt, op2.next.pt) < 0)) then begin if op2 = outRec.pts then outRec.pts := op2.prev; op2 := DisposeOutPt(op2); if not ValidateClosedPathEx(op2) then begin outRec.pts := nil; Exit; end; startOp := op2; Continue; end; op2 := op2.next; if op2 = startOp then Break; end; FixSelfIntersects(outRec); end; //------------------------------------------------------------------------------ procedure TClipperBase.DoSplitOp(outrec: POutRec; splitOp: POutPt); var newOp, newOp2, prevOp, nextNextOp: POutPt; ip: TPoint64; area1, area2, absArea1, absArea2: double; newOutRec: POutRec; begin // splitOp.prev -> splitOp && // splitOp.next -> splitOp.next.next are intersecting prevOp := splitOp.prev; nextNextOp := splitOp.next.next; outrec.pts := prevOp; ip := Point64(Clipper.Core.GetIntersectPointD( prevOp.pt, splitOp.pt, splitOp.next.pt, nextNextOp.pt)); {$IFDEF USINGZ} if Assigned(fZCallback) then fZCallback(prevOp.Pt, splitOp.Pt, splitOp.Next.Pt, nextNextOp.Pt, ip); {$ENDIF} area1 := Area(outrec.pts); absArea1 := abs(area1); if absArea1 < 2 then begin SafeDisposeOutPts(splitOp); Exit; end; // nb: area1 is the path's area *before* splitting, whereas area2 is // the area of the triangle containing splitOp & splitOp.next. // So the only way for these areas to have the same sign is if // the split triangle is larger than the path containing prevOp or // if there's more than one self=intersection. area2 := AreaTriangle(ip, splitOp.pt, splitOp.next.pt); absArea2 := abs(area2); // de-link splitOp and splitOp.next from the path // while inserting the intersection point if PointsEqual(ip, prevOp.pt) or PointsEqual(ip, nextNextOp.pt) then begin nextNextOp.prev := prevOp; prevOp.next := nextNextOp; end else begin new(newOp2); newOp2.pt := ip; newOp2.joiner := nil; newOp2.outrec := outrec; newOp2.prev := prevOp; newOp2.next := nextNextOp; nextNextOp.prev := newOp2; prevOp.next := newOp2; end; SafeDeleteOutPtJoiners(splitOp.next); SafeDeleteOutPtJoiners(splitOp); if (absArea2 > 1) and ((absArea2 > absArea1) or ((area2 > 0) = (area1 > 0))) then begin new(newOutRec); FillChar(newOutRec^, SizeOf(TOutRec), 0); newOutRec.idx := FOutRecList.Add(newOutRec); newOutRec.owner := outrec.owner; newOutRec.isOpen := false; newOutRec.polypath := nil; newOutRec.splits := nil; splitOp.outrec := newOutRec; splitOp.next.outrec := newOutRec; new(newOp); newOp.pt := ip; newOp.joiner := nil; newOp.outrec := newOutRec; newOp.prev := splitOp.next; newOp.next := splitOp; splitOp.prev := newOp; splitOp.next.next := newOp; newOutRec.pts := newOp; end else begin Dispose(splitOp.next); Dispose(splitOp); end; end; //------------------------------------------------------------------------------ procedure TClipperBase.FixSelfIntersects(outrec: POutRec); var op2: POutPt; begin op2 := outrec.pts; while true do begin // triangles can't self-intersect if (op2.prev = op2.next.next) then Break else if SegmentsIntersect(op2.prev.pt, op2.pt, op2.next.pt, op2.next.next.pt) then begin DoSplitOp(outrec, op2); if not assigned(outrec.pts) then Break; op2 := outrec.pts; Continue; end else op2 := op2.next; if (op2 = outrec.pts) then Break; end; end; //------------------------------------------------------------------------------ function TClipperBase.AddLocalMaxPoly(e1, e2: PActive; const pt: TPoint64): POutPt; var outRec: POutRec; begin if (IsFront(e1) = IsFront(e2)) then begin if IsOpenEnd(e1) then SwapFrontBackSides(e1.outrec) else if IsOpenEnd(e2) then SwapFrontBackSides(e2.outrec) else begin FSucceeded := false; Result := nil; Exit; end; end; Result := AddOutPt(e1, pt); if (e1.outrec = e2.outrec) then begin outRec := e1.outrec; outRec.pts := Result; UncoupleOutRec(e1); if not IsOpen(e1) then CleanCollinear(outRec); Result := outRec.pts; outRec.owner := GetRealOutRec(outRec.owner); if FUsingPolytree and Assigned(outRec.owner) and not Assigned(outRec.owner.frontE) then outRec.owner := GetRealOutRec(outRec.owner.owner); end // and to preserve the winding orientation of Outrec ... else if IsOpen(e1) then begin if e1.windDx < 0 then JoinOutrecPaths(e1, e2) else JoinOutrecPaths(e2, e1); end else if e1.outrec.idx < e2.outrec.idx then JoinOutrecPaths(e1, e2) else JoinOutrecPaths(e2, e1); end; //------------------------------------------------------------------------------ procedure TClipperBase.JoinOutrecPaths(e1, e2: PActive); var p1_start, p1_end, p2_start, p2_end: POutPt; begin // join e2 outrec path onto e1 outrec path and then delete e2 outrec path // pointers. (see joining_outpt.svg) p1_start := e1.outrec.pts; p2_start := e2.outrec.pts; p1_end := p1_start.next; p2_end := p2_start.next; if IsFront(e1) then begin p2_end.prev := p1_start; p1_start.next := p2_end; p2_start.next := p1_end; p1_end.prev := p2_start; e1.outrec.pts := p2_start; // nb: if IsOpen(e1) then e1 & e2 must be a 'maximaPair' e1.outrec.frontE := e2.outrec.frontE; if Assigned(e1.outrec.frontE) then e1.outrec.frontE.outrec := e1.outrec; end else begin p1_end.prev := p2_start; p2_start.next := p1_end; p1_start.next := p2_end; p2_end.prev := p1_start; e1.outrec.backE := e2.outrec.backE; if Assigned(e1.outrec.backE) then e1.outrec.backE.outrec := e1.outrec; end; // an owner must have a lower idx otherwise // it won't be a valid owner if assigned(e2.outrec.owner) and (e2.outrec.owner.idx < e1.outrec.idx) then begin if not assigned(e1.outrec.owner) or (e2.outrec.owner.idx < e1.outrec.owner.idx) then e1.outrec.owner := e2.outrec.owner; end; // after joining, the e2.OutRec mustn't contains vertices e2.outrec.frontE := nil; e2.outrec.backE := nil; e2.outrec.pts := nil; e2.outrec.owner := e1.outrec; if IsOpenEnd(e1) then begin e2.outrec.pts := e1.outrec.pts; e1.outrec.pts := nil; end; // and e1 and e2 are maxima and are about to be dropped from the Actives list. e1.outrec := nil; e2.outrec := nil; end; //------------------------------------------------------------------------------ function TClipperBase.AddOutPt(e: PActive; const pt: TPoint64): POutPt; var opFront, opBack: POutPt; toFront: Boolean; outrec: POutRec; begin // Outrec.OutPts: a circular doubly-linked-list of POutPt where ... // opFront[.Prev]* ~~~> opBack & opBack == opFront.Next outrec := e.outrec; toFront := IsFront(e); opFront := outrec.pts; opBack := opFront.next; if toFront and PointsEqual(pt, opFront.pt) then result := opFront else if not toFront and PointsEqual(pt, opBack.pt) then result := opBack else begin new(Result); Result.pt := pt; Result.joiner := nil; Result.outrec := outrec; opBack.prev := Result; Result.prev := opFront; Result.next := opBack; opFront.next := Result; if toFront then outrec.pts := Result; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.AddJoin(op1, op2: POutPt); var joiner: PJoiner; begin if (op1.outrec = op2.outrec) and ((op1 = op2) or // unless op1.next or op1.prev crosses the start-end divide // don't waste time trying to join adjacent vertices ((op1.next = op2) and (op1 <> op1.outrec.pts)) or ((op2.next = op1) and (op2 <> op1.outrec.pts))) then Exit; new(joiner); joiner.idx := FJoinerList.Add(joiner); joiner.op1 := op1; joiner.op2 := op2; joiner.nextH := nil; joiner.next1 := op1.joiner; joiner.next2 := op2.joiner; op1.joiner := joiner; op2.joiner := joiner; end; //------------------------------------------------------------------------------ function FindJoinParent(joiner: PJoiner; op: POutPt): PJoiner; {$IFDEF INLINING} inline; {$ENDIF} begin Result := op.joiner; while true do begin if (op = Result.op1) then begin if Result.next1 = joiner then Exit else Result := Result.next1; end else begin if Result.next2 = joiner then Exit else Result := Result.next2; end; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DeleteJoin(joiner: PJoiner); var op1, op2: POutPt; parentJnr: PJoiner; begin // This method deletes a single join, and it doesn't check for or // delete trial horz. joins. For that, use the following method. op1 := joiner.op1; op2 := joiner.op2; // both op1 and op2 can be associated with multiple joiners which // are chained together so we need to break and rejoin that chain if op1.joiner <> joiner then begin parentJnr := FindJoinParent(joiner, op1); if parentJnr.op1 = op1 then parentJnr.next1 := joiner.next1 else parentJnr.next2 := joiner.next1; end else op1.joiner := Joiner.next1; if op2.joiner <> joiner then begin parentJnr := FindJoinParent(joiner, op2); if parentJnr.op1 = op2 then parentJnr.next1 := joiner.next2 else parentJnr.next2 := joiner.next2; end else op2.joiner := joiner.next2; FJoinerList[joiner.idx] := nil; Dispose(joiner); end; //------------------------------------------------------------------------------ procedure TClipperBase.SafeDeleteOutPtJoiners(op: POutPt); var joiner: PJoiner; begin if not Assigned(op.joiner) then Exit; joiner := op.joiner; while Assigned(joiner) do begin if joiner.idx < 0 then DeleteTrialHorzJoin(op) else if Assigned(FHorzTrials) then begin if OutPtInTrialHorzList(joiner.op1) then DeleteTrialHorzJoin(joiner.op1); if OutPtInTrialHorzList(joiner.op2) then DeleteTrialHorzJoin(joiner.op2); DeleteJoin(joiner); end else DeleteJoin(joiner); joiner := op.joiner; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.ProcessJoinList; var i: integer; joiner: PJoiner; outRec: POutRec; begin for i := 0 to FJoinerList.Count -1 do begin if Assigned(UnsafeGet(FJoinerList, i)) then begin joiner := UnsafeGet(FJoinerList, i); outrec := ProcessJoin(joiner); CleanCollinear(outRec); end; end; FJoinerList.Clear; end; //------------------------------------------------------------------------------ procedure TClipperBase.UpdateOutrecOwner(outRec: POutRec); var opCurr : POutPt; begin opCurr := outRec.pts; repeat opCurr.outrec := outRec; opCurr := opCurr.next; until opCurr = outRec.pts; end; //------------------------------------------------------------------------------ procedure TClipperBase.CompleteSplit(op1, op2: POutPt; OutRec: POutRec); var i: integer; area1, area2: double; signsChange: Boolean; newOr: POutRec; begin area1 := Area(op1); area2 := Area(op2); signsChange := (area1 > 0) = (area2 < 0); // delete trivial splits (with zero or almost zero areas) if (area1 = 0) or (signsChange and (Abs(area1) < 2)) then begin SafeDisposeOutPts(op1); OutRec.pts := op2; end else if (area2 = 0) or (signsChange and (Abs(area2) < 2)) then begin SafeDisposeOutPts(op2); OutRec.pts := op1; end else begin new(newOr); FillChar(newOr^, SizeOf(TOutRec), 0); newOr.idx := FOutRecList.Add(newOr); newOr.polypath := nil; newOr.splits := nil; if (FUsingPolytree) then begin i := Length(OutRec.splits); SetLength(OutRec.splits, i +1); OutRec.splits[i] := newOr; end; if Abs(area1) >= Abs(area2) then begin OutRec.pts := op1; newOr.pts := op2; end else begin OutRec.pts := op2; newOr.pts := op1; end; if (area1 > 0) = (area2 > 0) then newOr.owner := OutRec.owner else newOr.owner := OutRec; UpdateOutrecOwner(newOr); CleanCollinear(newOr); end; end; //------------------------------------------------------------------------------ function CollinearSegsOverlap(const seg1a, seg1b, seg2a, seg2b: TPoint64): Boolean; begin // precondition: seg1 and seg2 are collinear Result := false; if (seg1a.X = seg1b.X) then begin if (seg2a.X <> seg1a.X) or (seg2a.X <> seg2b.X) then Exit; end else if (seg1a.X < seg1b.X) then begin if (seg2a.X < seg2b.X) then begin if (seg2a.X >= seg1b.X) or (seg2b.X <= seg1a.X) then Exit; end else if (seg2b.X >= seg1b.X) or (seg2a.X <= seg1a.X) then Exit; end else begin if (seg2a.X < seg2b.X) then begin if (seg2a.X >= seg1a.X) or (seg2b.X <= seg1b.X) then Exit; end else if (seg2b.X >= seg1a.X) or (seg2a.X <= seg1b.X) then Exit; end; if (seg1a.Y = seg1b.Y) then begin if (seg2a.Y <> seg1a.Y) or (seg2a.Y <> seg2b.Y) then Exit; end else if (seg1a.Y < seg1b.Y) then begin if (seg2a.Y < seg2b.Y) then begin if (seg2a.Y >= seg1b.Y) or (seg2b.Y <= seg1a.Y) then Exit; end else if (seg2b.Y >= seg1b.Y) or (seg2a.Y <= seg1a.Y) then Exit; end else begin if (seg2a.Y < seg2b.Y) then begin if (seg2a.Y >= seg1a.Y) or (seg2b.Y <= seg1b.Y) then Exit; end else if (seg2b.Y >= seg1a.Y) or (seg2a.Y <= seg1b.Y) then Exit; end; Result := true; end; //------------------------------------------------------------------------------ function PointEqualOrBetween(const pt, corner1, corner2: TPoint64): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin // nb: points may not be collinear Result := ValueEqualOrBetween(pt.X, corner1.X, corner2.X) and ValueEqualOrBetween(pt.Y, corner1.Y, corner2.Y); end; //------------------------------------------------------------------------------ function PointBetween(const pt, corner1, corner2: TPoint64): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin // nb: points may not be collinear Result := ValueBetween(pt.X, corner1.X, corner2.X) and ValueBetween(pt.Y, corner1.Y, corner2.Y); end; //------------------------------------------------------------------------------ function CheckDisposeAdjacent(var op: POutPt; guard: POutPt; outRec: POutRec): Boolean; begin Result := false; while (op.prev <> op) do begin if PointsEqual(op.pt, op.prev.pt) and (op <> guard) and Assigned(op.prev.joiner) and not Assigned(op.joiner) then begin if op = outRec.pts then outRec.pts := op.prev; op := DisposeOutPt(op); op := op.prev; end else break; end; while (op.next <> op) do begin if PointsEqual(op.pt, op.next.pt) and (op <> guard) and Assigned(op.next.joiner) and not Assigned(op.joiner) then begin if op = outRec.pts then outRec.pts := op.prev; op := DisposeOutPt(op); op := op.prev; end else break; end; end; //------------------------------------------------------------------------------ function TClipperBase.ProcessJoin(joiner: PJoiner): POutRec; var op1, op2: POutPt; opA, opB: POutPt; or1, or2: POutRec; begin op1 := joiner.op1; op2 := joiner.op2; or1 := GetRealOutRec(op1.outrec); or2 := GetRealOutRec(op2.outrec); op1.outrec := or1; op2.outrec := or2; DeleteJoin(joiner); Result := or1; if not Assigned(or2.pts) then Exit else if not IsValidClosedPath(op2) then begin SafeDisposeOutPts(op2); Exit; end else if not Assigned(or1.pts) or not IsValidClosedPath(op1) then begin SafeDisposeOutPts(op1); Result := or2; // ie tidy or2 in calling function; Exit; end else if (or1 = or2) and ((op1 = op2) or (op1.next = op2) or (op1.prev = op2)) then begin Exit; end; CheckDisposeAdjacent(op1, op2, or1); CheckDisposeAdjacent(op2, op1, or2); if (op1.next = op2) or (op2.next = op1) then Exit; while True do begin if not IsValidPath(op1) or not IsValidPath(op2) or ((or1 = or2) and ((op1.prev = op2) or (op1.next = op2))) then Exit; if PointsEqual(op1.prev.pt, op2.next.pt) or ((CrossProduct(op1.prev.pt, op1.pt, op2.next.pt) = 0) and CollinearSegsOverlap(op1.prev.pt, op1.pt, op2.pt, op2.next.pt)) then begin if or1 = or2 then begin // SPLIT REQUIRED // make sure op1.prev and op2.next match positions // by inserting an extra vertex if needed if not PointsEqual(op1.prev.pt, op2.next.pt) then begin if PointEqualOrBetween(op1.prev.pt, op2.pt, op2.next.pt) then op2.next := InsertOp(op1.prev.pt, op2) else op1.prev := InsertOp(op2.next.pt, op1.prev); end; // current to new // op1.p[opA] >>> op1 ... opA \ / op1 // op2.n[opB] <<< op2 ... opB / \ op2 opA := op1.prev; opB := op2.next; opA.next := opB; opB.prev := opA; op1.prev := op2; op2.next := op1; CompleteSplit(op1, opA, or1); end else begin // JOIN, NOT SPLIT opA := op1.prev; opB := op2.next; opA.next := opB; opB.prev := opA; op1.prev := op2; op2.next := op1; if (or1.idx < or2.idx) then begin or1.pts := op1; or2.pts := nil; if Assigned(or1.owner) and (not Assigned(or2.owner) or (or2.owner.idx < or1.owner.idx)) then or1.owner := or2.owner; or2.owner := or1 end else begin or2.pts := op1; or1.pts := nil; if Assigned(or2.owner) and (not Assigned(or1.owner) or (or1.owner.idx < or2.owner.idx)) then or2.owner := or1.owner; or1.owner := or2; end; end; Break; end else if PointsEqual(op1.next.pt, op2.prev.pt) or ((CrossProduct(op1.next.pt, op2.pt, op2.prev.pt) = 0) and CollinearSegsOverlap(op1.next.pt, op1.pt, op2.pt, op2.prev.pt)) then begin if or1 = or2 then begin // SPLIT REQUIRED // make sure op2.prev and op1.next match positions // by inserting an extra vertex if needed if not PointsEqual(op1.next.pt, op2.prev.pt) then begin if PointEqualOrBetween(op2.prev.pt, op1.pt, op1.next.pt) then op1.next := InsertOp(op2.prev.pt, op1) else op2.prev := InsertOp(op1.next.pt, op2.prev); end; // current to new // op2.p[opA] >>> op2 ... opA \ / op2 // op1.n[opB] <<< op1 ... opB / \ op1 opA := op2.prev; opB := op1.next; opA.next := opB; opB.prev := opA; op2.prev := op1; op1.next := op2; CompleteSplit(op1, opA, or1); end else begin // JOIN, NOT SPLIT opA := op1.next; opB := op2.prev; opA.prev := opB; opB.next := opA; op1.next := op2; op2.prev := op1; // SafeDeleteOutPtJoiners(op2); // DisposeOutPt(op2); if or1.idx < or2.idx then begin or1.pts := op1; or2.pts := nil; if Assigned(or1.owner) and (not Assigned(or2.owner) or (or2.owner.idx < or1.owner.idx)) then or1.owner := or2.owner; or2.owner := or1; end else begin Result := or2; or2.pts := op1; or1.pts := nil; if Assigned(or2.owner) and (not Assigned(or1.owner) or (or1.owner.idx < or2.owner.idx)) then or2.owner := or1.owner; or1.owner := or2; end; end; Break; end else if PointBetween(op1.next.pt, op2.pt, op2.prev.pt) and (DistanceFromLineSqrd(op1.next.pt, op2.pt, op2.prev.pt) < 2.01) then begin InsertOp(op1.next.pt, op2.prev); Continue; end else if PointBetween(op2.next.pt, op1.pt, op1.prev.pt) and (DistanceFromLineSqrd(op2.next.pt, op1.pt, op1.prev.pt) < 2.01) then begin InsertOp(op2.next.pt, op1.prev); Continue; end else if PointBetween(op1.prev.pt, op2.pt, op2.next.pt) and (DistanceFromLineSqrd(op1.prev.pt, op2.pt, op2.next.pt) < 2.01) then begin InsertOp(op1.prev.pt, op2); Continue; end else if PointBetween(op2.prev.pt, op1.pt, op1.next.pt) and (DistanceFromLineSqrd(op2.prev.pt, op1.pt, op1.next.pt) < 2.01) then begin InsertOp(op2.prev.pt, op1); Continue; end; // something odd needs tidying up if CheckDisposeAdjacent(op1, op2, or1) then Continue else if CheckDisposeAdjacent(op2, op1, or1) then Continue else if not PointsEqual(op1.prev.pt, op2.next.pt) and (DistanceSqr(op1.prev.pt, op2.next.pt) < 2.01) then begin op1.prev.pt := op2.next.pt; Continue; end else if not PointsEqual(op1.next.pt, op2.prev.pt) and (DistanceSqr(op1.next.pt, op2.prev.pt) < 2.01) then begin op2.prev.pt := op1.next.pt; Continue; end else begin // OK, there doesn't seem to be a way to join afterall // so just tidy up the polygons or1.pts := op1; if or2 <> or1 then begin or2.pts := op2; CleanCollinear(or2); end; Break; end; end; // end while end; //------------------------------------------------------------------------------ function TClipperBase.StartOpenPath(e: PActive; const pt: TPoint64): POutPt; var newOr: POutRec; begin new(newOr); newOr.idx := FOutRecList.Add(newOr); newOr.owner := nil; newOr.isOpen := true; newOr.pts := nil; newOr.splits := nil; newOr.polypath := nil; if e.windDx > 0 then begin newOr.frontE := e; newOr.backE := nil; end else begin newOr.frontE := nil; newOr.backE := e; end; e.outrec := newOr; new(Result); newOr.pts := Result; Result.pt := pt; Result.joiner := nil; Result.prev := Result; Result.next := Result; Result.outrec := newOr; end; //------------------------------------------------------------------------------ procedure TClipperBase.UpdateEdgeIntoAEL(var e: PActive); var op1, op2: POutPt; begin e.bot := e.top; e.vertTop := NextVertex(e); e.top := e.vertTop.pt; e.currX := e.bot.X; SetDx(e); if IsHorizontal(e) then Exit; InsertScanLine(e.top.Y); if TestJoinWithPrev1(e) then begin op1 := AddOutPt(e.prevInAEL, e.bot); op2 := AddOutPt(e, e.bot); AddJoin(op1, op2); end; end; //------------------------------------------------------------------------------ function FindEdgeWithMatchingLocMin(e: PActive): PActive; begin Result := e.nextInAEL; while Assigned(Result) do begin if (Result.locMin = e.locMin) then Exit; if not IsHorizontal(Result) and not PointsEqual(e.bot, Result.bot) then Result := nil else Result := Result.nextInAEL; end; Result := e.prevInAEL; while Assigned(Result) do begin if (Result.locMin = e.locMin) then Exit; if not IsHorizontal(Result) and not PointsEqual(e.bot, Result.bot) then Result := nil else Result := Result.prevInAEL; end; end; //------------------------------------------------------------------------------ {$IFNDEF USINGZ} {$HINTS OFF} {$ENDIF} function TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64): POutPt; var e1WindCnt, e2WindCnt, e1WindCnt2, e2WindCnt2: Integer; e3: PActive; op2: POutPt; begin Result := nil; // MANAGE OPEN PATH INTERSECTIONS SEPARATELY ... if FHasOpenPaths and (IsOpen(e1) or IsOpen(e2)) then begin if IsOpen(e1) and IsOpen(e2) then Exit; // the following line avoids duplicating quite a bit of code if IsOpen(e2) then SwapActives(e1, e2); case FClipType of ctUnion: if not IsHotEdge(e2) then Exit; else if e2.locMin.polytype = ptSubject then Exit; end; case FFillRule of frPositive: if e2.windCnt <> 1 then Exit; frNegative: if e2.windCnt <> -1 then Exit; else if (abs(e2.windCnt) <> 1) then Exit; end; // toggle contribution ... if IsHotEdge(e1) then begin Result := AddOutPt(e1, pt); if IsFront(e1) then e1.outrec.frontE := nil else e1.outrec.backE := nil; e1.outrec := nil; end // horizontal edges can pass under open paths at a LocMins else if PointsEqual(pt, e1.locMin.vertex.pt) and (e1.locMin.vertex.flags * [vfOpenStart, vfOpenEnd] = []) then begin // find the other side of the LocMin and // if it's 'hot' join up with it ... e3 := FindEdgeWithMatchingLocMin(e1); if assigned(e3) and IsHotEdge(e3) then begin e1.outrec := e3.outrec; if e1.windDx > 0 then SetSides(e3.outrec, e1, e3) else SetSides(e3.outrec, e3, e1); Result := e3.outrec.pts; Exit; end else Result := StartOpenPath(e1, pt); end else Result := StartOpenPath(e1, pt); {$IFDEF USINGZ} SetZ(e1, e2, Result.pt); {$ENDIF} Exit; end; // MANAGING CLOSED PATHS FROM HERE ON // FIRST, UPDATE WINDING COUNTS if IsSamePolyType(e1, e2) then begin if FFillRule = frEvenOdd then begin e1WindCnt := e1.windCnt; e1.windCnt := e2.windCnt; e2.windCnt := e1WindCnt; end else begin if e1.windCnt + e2.windDx = 0 then e1.windCnt := -e1.windCnt else Inc(e1.windCnt, e2.windDx); if e2.windCnt - e1.windDx = 0 then e2.windCnt := -e2.windCnt else Dec(e2.windCnt, e1.windDx); end; end else begin if FFillRule <> frEvenOdd then Inc(e1.windCnt2, e2.windDx) else if e1.windCnt2 = 0 then e1.windCnt2 := 1 else e1.windCnt2 := 0; if FFillRule <> frEvenOdd then Dec(e2.windCnt2, e1.windDx) else if e2.windCnt2 = 0 then e2.windCnt2 := 1 else e2.windCnt2 := 0; end; case FFillRule of frPositive: begin e1WindCnt := e1.windCnt; e2WindCnt := e2.windCnt; end; frNegative: begin e1WindCnt := -e1.windCnt; e2WindCnt := -e2.windCnt; end; else begin e1WindCnt := abs(e1.windCnt); e2WindCnt := abs(e2.windCnt); end; end; if (not IsHotEdge(e1) and not (e1WindCnt in [0,1])) or (not IsHotEdge(e2) and not (e2WindCnt in [0,1])) then Exit; // NOW PROCESS THE INTERSECTION // if both edges are 'hot' ... if IsHotEdge(e1) and IsHotEdge(e2) then begin if not (e1WindCnt in [0,1]) or not (e2WindCnt in [0,1]) or (not IsSamePolyType(e1, e2) and (fClipType <> ctXor)) then begin Result := AddLocalMaxPoly(e1, e2, pt); {$IFDEF USINGZ} if Assigned(Result) then SetZ(e1, e2, Result.pt); {$ENDIF} end else if IsFront(e1) or (e1.outrec = e2.outrec) then begin // this 'else if' condition isn't strictly needed but // it's sensible to split polygons that ony touch at // a common vertex (not at common edges). Result := AddLocalMaxPoly(e1, e2, pt); op2 := AddLocalMinPoly(e1, e2, pt); {$IFDEF USINGZ} if Assigned(Result) then SetZ(e1, e2, Result.pt); SetZ(e1, e2, op2.pt); {$ENDIF} if Assigned(Result) and PointsEqual(Result.pt, op2.pt) and not IsHorizontal(e1) and not IsHorizontal(e2) and (CrossProduct(e1.bot, Result.pt, e2.bot) = 0) then AddJoin(Result, op2); end else begin // can't treat as maxima & minima Result := AddOutPt(e1, pt); op2 := AddOutPt(e2, pt); {$IFDEF USINGZ} SetZ(e1, e2, Result.pt); SetZ(e1, e2, op2.pt); {$ENDIF} SwapOutRecs(e1, e2); end; end // if one or other edge is 'hot' ... else if IsHotEdge(e1) then begin Result := AddOutPt(e1, pt); {$IFDEF USINGZ} SetZ(e1, e2, Result.pt); {$ENDIF} SwapOutRecs(e1, e2); end else if IsHotEdge(e2) then begin Result := AddOutPt(e2, pt); {$IFDEF USINGZ} SetZ(e1, e2, Result.pt); {$ENDIF} SwapOutRecs(e1, e2); end // else neither edge is 'hot' else begin case FFillRule of frPositive: begin e1WindCnt2 := e1.windCnt2; e2WindCnt2 := e2.windCnt2; end; frNegative: begin e1WindCnt2 := -e1.windCnt2; e2WindCnt2 := -e2.windCnt2; end; else begin e1WindCnt2 := abs(e1.windCnt2); e2WindCnt2 := abs(e2.windCnt2); end; end; if not IsSamePolyType(e1, e2) then begin Result := AddLocalMinPoly(e1, e2, pt, false); {$IFDEF USINGZ} SetZ(e1, e2, Result.pt); {$ENDIF} end else if (e1WindCnt = 1) and (e2WindCnt = 1) then begin Result := nil; case FClipType of ctIntersection: if (e1WindCnt2 <= 0) or (e2WindCnt2 <= 0) then Exit else Result := AddLocalMinPoly(e1, e2, pt, false); ctUnion: if (e1WindCnt2 <= 0) and (e2WindCnt2 <= 0) then Result := AddLocalMinPoly(e1, e2, pt, false); ctDifference: if ((GetPolyType(e1) = ptClip) and (e1WindCnt2 > 0) and (e2WindCnt2 > 0)) or ((GetPolyType(e1) = ptSubject) and (e1WindCnt2 <= 0) and (e2WindCnt2 <= 0)) then Result := AddLocalMinPoly(e1, e2, pt, false); else // xOr Result := AddLocalMinPoly(e1, e2, pt, false); end; {$IFDEF USINGZ} if assigned(Result) then SetZ(e1, e2, Result.pt); {$ENDIF} end; end; end; //------------------------------------------------------------------------------ {$IFNDEF USINGZ} {$HINTS ON} {$ENDIF} function TClipperBase.ValidateClosedPathEx(var op: POutPt): Boolean; begin Result := IsValidClosedPath(op); if Result then Exit; if Assigned(op) then SafeDisposeOutPts(op); end; //------------------------------------------------------------------------------ procedure TClipperBase.DeleteEdges(var e: PActive); var e2: PActive; begin while Assigned(e) do begin e2 := e; e := e.nextInAEL; Dispose(e2); end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DeleteFromAEL(e: PActive); var aelPrev, aelNext: PActive; begin aelPrev := e.prevInAEL; aelNext := e.nextInAEL; if not Assigned(aelPrev) and not Assigned(aelNext) and (e <> FActives) then Exit; // already deleted if Assigned(aelPrev) then aelPrev.nextInAEL := aelNext else FActives := aelNext; if Assigned(aelNext) then aelNext.prevInAEL := aelPrev; Dispose(e); end; //------------------------------------------------------------------------------ procedure TClipperBase.AdjustCurrXAndCopyToSEL(topY: Int64); var e: PActive; begin FSel := FActives; e := FActives; while Assigned(e) do begin e.prevInSEL := e.prevInAEL; e.nextInSEL := e.nextInAEL; e.jump := e.nextInSEL; e.currX := TopX(e, topY); e := e.nextInAEL; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.ExecuteInternal(clipType: TClipType; fillRule: TFillRule; usingPolytree: Boolean); var Y: Int64; e: PActive; begin if clipType = ctNone then Exit; FFillRule := fillRule; FClipType := clipType; Reset; if not PopScanLine(Y) then Exit; while FSucceeded do begin InsertLocalMinimaIntoAEL(Y); while PopHorz(e) do DoHorizontal(e); ConvertHorzTrialsToJoins; FBotY := Y; // FBotY == bottom of current scanbeam if not PopScanLine(Y) then Break; // Y == top of current scanbeam DoIntersections(Y); DoTopOfScanbeam(Y); while PopHorz(e) do DoHorizontal(e); end; if FSucceeded then ProcessJoinList; end; //------------------------------------------------------------------------------ procedure TClipperBase.DoIntersections(const topY: Int64); begin if BuildIntersectList(topY) then try ProcessIntersectList; finally DisposeIntersectNodes; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DisposeIntersectNodes; var i: Integer; begin for i := 0 to FIntersectList.Count - 1 do Dispose(PIntersectNode(UnsafeGet(FIntersectList,i))); FIntersectList.Clear; end; //------------------------------------------------------------------------------ procedure TClipperBase.AddNewIntersectNode(e1, e2: PActive; topY: Int64); var pt: TPoint64; node: PIntersectNode; begin pt := GetIntersectPoint(e1, e2); // Rounding errors can occasionally place the calculated intersection // point either below or above the scanbeam, so check and correct ... if (pt.Y > FBotY) then begin // E.Curr.Y is still at the bottom of scanbeam here pt.Y := FBotY; // use the more vertical of the 2 edges to derive pt.X ... if (abs(e1.dx) < abs(e2.dx)) then pt.X := TopX(e1, FBotY) else pt.X := TopX(e2, FBotY); end else if pt.Y < topY then begin // TopY = top of scanbeam pt.Y := topY; if e1.top.Y = topY then pt.X := e1.top.X else if e2.top.Y = topY then pt.X := e2.top.X else if (abs(e1.dx) < abs(e2.dx)) then pt.X := e1.currX else pt.X := e2.currX; end; new(node); node.active1 := e1; node.active2 := e2; node.pt := pt; FIntersectList.Add(node); end; //------------------------------------------------------------------------------ function ExtractFromSEL(edge: PActive): PActive; begin // nb: edge.PrevInSEL is always assigned Result := edge.nextInSEL; if Assigned(Result) then Result.prevInSEL := edge.prevInSEL; edge.prevInSEL.nextInSEL := Result; end; //------------------------------------------------------------------------------ procedure Insert1Before2InSEL(edge1, edge2: PActive); begin edge1.prevInSEL := edge2.prevInSEL; if Assigned(edge1.prevInSEL) then edge1.prevInSEL.nextInSEL := edge1; edge1.nextInSEL := edge2; edge2.prevInSEL := edge1; end; //------------------------------------------------------------------------------ function TClipperBase.BuildIntersectList(const topY: Int64): Boolean; var q, base,prevBase,left,right, lend, rend: PActive; begin result := false; if not Assigned(FActives) or not Assigned(FActives.nextInAEL) then Exit; // Calculate edge positions at the top of the current scanbeam, and from this // we will determine the intersections required to reach these new positions. AdjustCurrXAndCopyToSEL(topY); // Find all edge intersections in the current scanbeam using a stable merge // sort that ensures only adjacent edges are intersecting. Intersect info is // stored in FIntersectList ready to be processed in ProcessIntersectList. left := FSel; while Assigned(left.jump) do begin prevBase := nil; while Assigned(left) and Assigned(left.jump) do begin base := left; right := left.jump; rend := right.jump; left.jump := rend; lend := right; rend := right.jump; while (left <> lend) and (right <> rend) do begin if right.currX < left.currX then begin // save edge intersections q := right.prevInSEL; while true do begin AddNewIntersectNode(q, right, topY); if q = left then Break; q := q.prevInSEL; end; // now move the out of place edge on the right // to its new ordered place on the left. q := right; right := ExtractFromSEL(q); // ie returns the new right lend := right; Insert1Before2InSEL(q, left); if left = base then begin base := q; base.jump := rend; if Assigned(prevBase) then prevBase.jump := base else FSel := base; end; end else left := left.nextInSEL; end; prevBase := base; left := rend; end; left := FSel; end; result := FIntersectList.Count > 0; end; //------------------------------------------------------------------------------ function IntersectListSort(node1, node2: Pointer): Integer; var pt1, pt2: PPoint64; i: Int64; begin if node1 = node2 then begin Result := 0; Exit; end; pt1 := @PIntersectNode(node1).pt; pt2 := @PIntersectNode(node2).pt; i := pt2.Y - pt1.Y; // note to self - can't return int64 values :) if i > 0 then Result := 1 else if i < 0 then Result := -1 else if (pt1 = pt2) then Result := 0 else begin // Sort by X too. Not essential, but it significantly // speeds up the secondary sort in ProcessIntersectList . i := pt1.X - pt2.X; if i > 0 then Result := 1 else if i < 0 then Result := -1 else Result := 0; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.ProcessIntersectList; var i: Integer; nodeQ: PIntersectNode; nodeI, nodeJ: ^PIntersectNode; op1, op2: POutpt; begin // The list of required intersections now needs to be processed in a // specific order such that intersection points with the largest Y coords // are processed before those with the smallest Y coords. However, // it's critical that edges are adjacent at the time of intersection, but // that can only be checked during processing (when edge positions change). // First we do a quicksort so that intersections will be processed // mostly from largest Y to smallest FIntersectList.Sort(IntersectListSort); nodeI := @FIntersectList.List[0]; for i := 0 to FIntersectList.Count - 1 do begin // during processing, make sure edges are adjacent before // proceeding, and swapping the order if they aren't adjacent. if not EdgesAdjacentInAEL(nodeI^) then begin nodeJ := nodeI; repeat inc(nodeJ); until EdgesAdjacentInAEL(nodeJ^); // now swap intersection order nodeQ := nodeI^; nodeI^ := nodeJ^; nodeJ^ := nodeQ; end; // now process the intersection with nodeI^^ do begin IntersectEdges(active1, active2, pt); SwapPositionsInAEL(active1, active2); if TestJoinWithPrev2(active2, pt) then begin op1 := AddOutPt(active2.prevInAEL, pt); op2 := AddOutPt(active2, pt); if op1 <> op2 then AddJoin(op1, op2); end else if TestJoinWithNext2(active1, pt) then begin op1 := AddOutPt(active1, pt); op2 := AddOutPt(active1.nextInAEL, pt); if op1 <> op2 then AddJoin(op1, op2); end; end; inc(nodeI); end; // Edges should once again be correctly ordered (left to right) in the AEL. end; //------------------------------------------------------------------------------ procedure TClipperBase.SwapPositionsInAEL(e1, e2: PActive); var prev, next: PActive; begin // preconditon: e1 must be immediately prior to e2 next := e2.nextInAEL; if Assigned(next) then next.prevInAEL := e1; prev := e1.prevInAEL; if Assigned(prev) then prev.nextInAEL := e2; e2.prevInAEL := prev; e2.nextInAEL := e1; e1.prevInAEL := e2; e1.nextInAEL := next; if not Assigned(e2.prevInAEL) then FActives := e2; end; //------------------------------------------------------------------------------ function HorzIsSpike(horzEdge: PActive): Boolean; var nextPt: TPoint64; begin nextPt := NextVertex(horzEdge).pt; Result := (nextPt.Y = horzEdge.top.Y) and (horzEdge.bot.X < horzEdge.top.X) <> (horzEdge.top.X < nextPt.X); end; //------------------------------------------------------------------------------ procedure TrimHorz(horzEdge: PActive; preserveCollinear: Boolean); var pt: TPoint64; wasTrimmed: Boolean; begin wasTrimmed := false; pt := NextVertex(horzEdge).pt; while (pt.Y = horzEdge.top.Y) do begin // always trim 180 deg. spikes (in closed paths) // but otherwise break if preserveCollinear = true if preserveCollinear and ((pt.X < horzEdge.top.X) <> (horzEdge.bot.X < horzEdge.top.X)) then break; horzEdge.vertTop := NextVertex(horzEdge); horzEdge.top := pt; wasTrimmed := true; if IsMaxima(horzEdge) then Break; pt := NextVertex(horzEdge).pt; end; if wasTrimmed then SetDx(horzEdge); // +/-infinity end; //------------------------------------------------------------------------------ function HorzEdgesOverlap(x1a, x1b, x2a, x2b: Int64): Boolean; const minOverlap: Int64 = 2; begin if x1a > x1b + minOverlap then begin if x2a > x2b + minOverlap then Result := not ((x1a <= x2b) or (x2a <= x1b)) else Result := not ((x1a <= x2a) or (x2b <= x1b)); end else if x1b > x1a + minOverlap then begin if x2a > x2b + minOverlap then Result := not ((x1b <= x2b) or (x2a <= x1a)) else Result := not ((x1b <= x2a) or (x2b <= x1a)); end else Result := false; end; //------------------------------------------------------------------------------ procedure TClipperBase.AddTrialHorzJoin(op: POutPt); begin // make sure 'op' isn't added more than once if not (op.outrec.isOpen) and not OutPtInTrialHorzList(op) then FHorzTrials := MakeDummyJoiner(op, FHorzTrials); end; //------------------------------------------------------------------------------ function FindTrialJoinParent(var joiner: PJoiner; op: POutPt): PJoiner; begin Result := joiner; while Assigned(Result) do begin if (op = Result.op1) then begin if Assigned(Result.next1) and (Result.next1.idx < 0) then begin joiner := Result.next1; Exit; end; Result := Result.next1; end else begin if Assigned(Result.next2) and (Result.next2.idx < 0) then begin joiner := Result.next2; Exit; end; Result := Result.next2; end; end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DeleteTrialHorzJoin(op: POutPt); var joiner, parentOp, parentH: PJoiner; begin if not Assigned(FHorzTrials) then Exit; joiner := op.joiner; parentOp := nil; while Assigned(joiner) do begin if (joiner.idx < 0) then begin // first remove joiner from FHorzTrials list if joiner = FHorzTrials then FHorzTrials := joiner.nextH else begin parentH := FHorzTrials; while parentH.nextH <> joiner do parentH := parentH.nextH; parentH.nextH := joiner.nextH; end; // now remove joiner from op's joiner list if not Assigned(parentOp) then begin // joiner must be first one in list op.joiner := joiner.next1; Dispose(joiner); joiner := op.joiner; end else begin // this trial joiner isn't op's first // nb: trial joiners only have a single 'op' if op = parentOp.op1 then parentOp.next1 := joiner.next1 else parentOp.next2 := joiner.next1; // never joiner.next2 Dispose(joiner); joiner := parentOp; end; // loop in case there's more than one trial join end else begin // not a trial join but just to be sure there isn't one // a little deeper, look further along the linked list parentOp := FindTrialJoinParent(joiner, op); if not Assigned(parentOp) then Break; end; end; end; //------------------------------------------------------------------------------ function GetHorzExtendedHorzSeg(var op, op2: POutPt): Boolean; var outRec: POutRec; begin outRec := GetRealOutRec(op.outrec); op2 := op; if Assigned(outRec.frontE) then begin while (op.prev <> outRec.pts) and (op.prev.pt.Y = op.pt.Y) do op := op.prev; while (op2 <> outRec.pts) and (op2.next.pt.Y = op2.pt.Y) do op2 := op2.next; Result := (op2 <> op); end else begin while (op.prev <> op2) and (op.prev.pt.Y = op.pt.Y) do op := op.prev; while (op2.next <> op) and (op2.next.pt.Y = op2.pt.Y) do op2 := op2.next; Result := (op2 <> op) and (op2.next <> op); end; end; //------------------------------------------------------------------------------ procedure TClipperBase.ConvertHorzTrialsToJoins; var op1a, op1b, op2a, op2b: POutPt; joiner, joinerParent: PJoiner; joined: Boolean; begin while Assigned(FHorzTrials) do begin joiner := FHorzTrials; FHorzTrials := FHorzTrials.nextH; op1a := joiner.op1; if op1a.joiner = joiner then begin op1a.joiner := joiner.next1; end else begin joinerParent := FindJoinParent(joiner, op1a); if joinerParent.op1 = op1a then joinerParent.next1 := joiner.next1 else joinerParent.next2 := joiner.next1; end; Dispose(joiner); if not GetHorzExtendedHorzSeg(op1a, op1b) then begin CleanCollinear(op1a.outrec); Continue; end; joined := false; joiner := FHorzTrials; while Assigned(joiner) do begin op2a := joiner.op1; if GetHorzExtendedHorzSeg(op2a, op2b) and HorzEdgesOverlap(op1a.pt.X, op1b.pt.X, op2a.pt.X, op2b.pt.X) then begin joined := true; // overlap found so promote to a 'real' join if PointsEqual(op1a.pt, op2b.pt) then AddJoin(op1a, op2b) else if PointsEqual(op1a.pt, op2a.pt) then AddJoin(op1a, op2a) else if PointsEqual(op1b.pt, op2a.pt) then AddJoin(op1b, op2a) else if PointsEqual(op1b.pt, op2b.pt) then AddJoin(op1b, op2b) else if ValueBetween(op1a.pt.X, op2a.pt.X, op2b.pt.X) then AddJoin(op1a, InsertOp(op1a.pt, op2a)) else if ValueBetween(op1b.pt.X, op2a.pt.X, op2b.pt.X) then AddJoin(op1b, InsertOp(op1b.pt, op2a)) else if ValueBetween(op2a.pt.X, op1a.pt.X, op1b.pt.X) then AddJoin(op2a, InsertOp(op2a.pt, op1a)) else if ValueBetween(op2b.pt.X, op1a.pt.X, op1b.pt.X) then AddJoin(op2b, InsertOp(op2b.pt, op1a)); Break; end; joiner := joiner.nextH; end; if not joined then CleanCollinear(op1a.outrec); end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DoHorizontal(horzEdge: PActive); var maxPair: PActive; horzLeft, horzRight: Int64; function ResetHorzDirection: Boolean; var e: PActive; begin if (horzEdge.bot.X = horzEdge.top.X) then begin // the horizontal edge is going nowhere ... horzLeft := horzEdge.currX; horzRight := horzEdge.currX; e := horzEdge.nextInAEL; while assigned(e) and (e <> maxPair) do e := e.nextInAEL; Result := assigned(e); // nb: this block isn't yet redundant end else if horzEdge.currX < horzEdge.top.X then begin horzLeft := horzEdge.currX; horzRight := horzEdge.top.X; Result := true; end else begin horzLeft := horzEdge.top.X; horzRight := horzEdge.currX; Result := false; end; end; //------------------------------------------------------------------------ var Y: Int64; e: PActive; pt: TPoint64; op, op2: POutPt; maxVertex: PVertex; isLeftToRight, horzIsOpen: Boolean; begin (******************************************************************************* * Notes: Horizontal edges (HEs) at scanline intersections (ie at the top or * * bottom of a scanbeam) are processed as if layered. The order in which HEs * * are processed doesn't matter. HEs intersect with the bottom vertices of * * other HEs [#] and with non-horizontal edges [*]. Once these intersections * * are completed, intermediate HEs are 'promoted' to the next edge in their * * bounds, and they in turn may be intersected [%] by other HEs. * * * * eg: 3 horizontals at a scanline: / | / / * * | / | (HE3) o=========%==========o * * o=======o (HE2) / | / / * * o============#=========*======*========#=========o (HE1) * * / | / | / * *******************************************************************************) horzIsOpen := IsOpen(horzEdge); Y := horzEdge.bot.Y; maxVertex := nil; maxPair := nil; if not horzIsOpen then begin maxVertex := GetCurrYMaximaVertex(horzEdge); if Assigned(maxVertex) then begin maxPair := GetHorzMaximaPair(horzEdge, maxVertex); // remove 180 deg.spikes and also simplify // consecutive horizontals when PreserveCollinear = true if (maxVertex <> horzEdge.vertTop) then TrimHorz(horzEdge, FPreserveCollinear); end; end; isLeftToRight := ResetHorzDirection; // nb: TrimHorz above hence not using Bot.X here if IsHotEdge(horzEdge) then AddOutPt(horzEdge, Point64(horzEdge.currX, Y)); while true do // loop through consec. horizontal edges begin if horzIsOpen and IsMaxima(horzEdge) and not IsOpenEnd(horzEdge) then begin maxVertex := GetCurrYMaximaVertex(horzEdge); if Assigned(maxVertex) then maxPair := GetHorzMaximaPair(horzEdge, maxVertex); end; if isLeftToRight then e := horzEdge.nextInAEL else e := horzEdge.prevInAEL; while assigned(e) do begin if (e = maxPair) then begin if IsHotEdge(horzEdge) then begin while horzEdge.vertTop <> e.vertTop do begin AddOutPt(horzEdge, horzEdge.top); UpdateEdgeIntoAEL(horzEdge); end; op := AddLocalMaxPoly(e, horzEdge, horzEdge.top); if Assigned(op) and not IsOpen(horzEdge) and PointsEqual(op.pt, horzEdge.top) then AddTrialHorzJoin(op); end; // remove horzEdge's maxPair from AEL DeleteFromAEL(e); DeleteFromAEL(horzEdge); Exit; end; // if horzEdge is a maxima, keep going until we reach // its maxima pair, otherwise check for Break conditions if (maxVertex <> horzEdge.vertTop) or IsOpenEnd(horzEdge) then begin // otherwise stop when 'e' is beyond the end of the horizontal line if (isLeftToRight and (e.currX > horzRight)) or (not isLeftToRight and (e.currX < horzLeft)) then Break; if (e.currX = horzEdge.top.X) and not IsHorizontal(e) then begin pt := NextVertex(horzEdge).pt; // to maximize the possibility of putting open edges into // solutions, we'll only break if it's past HorzEdge's end if IsOpen(E) and not IsSamePolyType(E, horzEdge) and not IsHotEdge(e) then begin if (isLeftToRight and (TopX(E, pt.Y) > pt.X)) or (not isLeftToRight and (TopX(E, pt.Y) < pt.X)) then Break; end // otherwise for edges at horzEdge's end, only stop when horzEdge's // outslope is greater than e's slope when heading right or when // horzEdge's outslope is less than e's slope when heading left. else if (isLeftToRight and (TopX(E, pt.Y) >= pt.X)) or (not isLeftToRight and (TopX(E, pt.Y) <= pt.X)) then Break; end; end; pt := Point64(e.currX, Y); if (isLeftToRight) then begin op := IntersectEdges(horzEdge, e, pt); //nb: Op.outrec will differ from horzEdge.outrec when IsOpen(e) SwapPositionsInAEL(horzEdge, e); if IsHotEdge(horzEdge) and Assigned(op) and not IsOpen(horzEdge) and PointsEqual(op.pt, pt) then AddTrialHorzJoin(op); if not IsHorizontal(e) and TestJoinWithPrev1(e) then begin op := AddOutPt(e.prevInAEL, pt); op2 := AddOutPt(e, pt); AddJoin(op, op2); end; horzEdge.currX := e.currX; e := horzEdge.nextInAEL; end else begin op := IntersectEdges(e, horzEdge, pt); //nb: Op.outrec will differ from horzEdge.outrec when IsOpen(e) SwapPositionsInAEL(e, horzEdge); if IsHotEdge(horzEdge) and Assigned(op) and not IsOpen(horzEdge) and PointsEqual(op.pt, pt) then AddTrialHorzJoin(op); if not IsHorizontal(e) and TestJoinWithNext1(e) then begin op := AddOutPt(e, pt); op2 := AddOutPt(e.nextInAEL, pt); AddJoin(op, op2); end; horzEdge.currX := e.currX; e := horzEdge.prevInAEL; end; end; // we've reached the end of this horizontal // check if we've finished looping through consecutive horizontals if horzIsOpen and IsOpenEnd(horzEdge) then begin if IsHotEdge(horzEdge) then begin AddOutPt(horzEdge, horzEdge.top); if IsFront(horzEdge) then horzEdge.outrec.frontE := nil else horzEdge.outrec.backE := nil; horzEdge.outrec := nil; end; DeleteFromAEL(horzEdge); // ie open at top Exit; end else if (NextVertex(horzEdge).pt.Y <> horzEdge.top.Y) then Break; // there must be a following (consecutive) horizontal if IsHotEdge(horzEdge) then AddOutPt(horzEdge, horzEdge.top); UpdateEdgeIntoAEL(horzEdge); if PreserveCollinear and not horzIsOpen and HorzIsSpike(horzEdge) then TrimHorz(horzEdge, true); isLeftToRight := ResetHorzDirection; end; // end while horizontal if IsHotEdge(horzEdge) then begin op := AddOutPt(horzEdge, horzEdge.top); if not IsOpen(horzEdge) then AddTrialHorzJoin(op); end else op := nil; if (horzIsOpen and not IsOpenEnd(horzEdge)) or (not horzIsOpen and (maxVertex <> horzEdge.vertTop)) then begin UpdateEdgeIntoAEL(horzEdge); // this is the end of an intermediate horiz. if IsOpen(horzEdge) then Exit; if isLeftToRight and TestJoinWithNext1(horzEdge) then begin op2 := AddOutPt(horzEdge.nextInAEL, horzEdge.bot); AddJoin(op, op2); end else if not isLeftToRight and TestJoinWithPrev1(horzEdge) then begin op2 := AddOutPt(horzEdge.prevInAEL, horzEdge.bot); AddJoin(op2, op); end; end else if IsHotEdge(horzEdge) then AddLocalMaxPoly(horzEdge, maxPair, horzEdge.top) else begin DeleteFromAEL(maxPair); DeleteFromAEL(horzEdge); end; end; //------------------------------------------------------------------------------ procedure TClipperBase.DoTopOfScanbeam(Y: Int64); var e: PActive; begin // FSel is reused to flag horizontals (see PushHorz below) FSel := nil; e := FActives; while Assigned(e) do begin // nb: 'e' will never be horizontal here if (e.top.Y = Y) then begin e.currX := e.top.X; if IsMaxima(e) then begin e := DoMaxima(e); // TOP OF BOUND (MAXIMA) Continue; end else begin // INTERMEDIATE VERTEX ... if IsHotEdge(e) then AddOutPt(e, e.top); UpdateEdgeIntoAEL(e); if IsHorizontal(e) then PushHorz(e); end; end else e.currX := TopX(e, Y); e := e.nextInAEL; end; end; //------------------------------------------------------------------------------ function TClipperBase.DoMaxima(e: PActive): PActive; var eNext, ePrev, eMaxPair: PActive; begin ePrev := e.prevInAEL; eNext := e.nextInAEL; Result := eNext; if IsOpenEnd(e) then begin if IsHotEdge(e) then AddOutPt(e, e.top); if not IsHorizontal(e) then begin if IsHotEdge(e) then begin if IsFront(e) then e.outrec.frontE := nil else e.outrec.backE := nil; e.outrec := nil; end; DeleteFromAEL(e); end; Exit; end else begin eMaxPair := GetMaximaPair(e); if not assigned(eMaxPair) then Exit; // EMaxPair is a horizontal ... end; // only non-horizontal maxima here. // process any edges between maxima pair ... while (eNext <> eMaxPair) do begin IntersectEdges(e, eNext, e.top); SwapPositionsInAEL(e, eNext); eNext := e.nextInAEL; end; if IsOpen(e) then begin // must be in the middle of an open path if IsHotEdge(e) then AddLocalMaxPoly(e, eMaxPair, e.top); DeleteFromAEL(eMaxPair); DeleteFromAEL(e); if assigned(ePrev) then Result := ePrev.nextInAEL else Result := FActives; end else begin // here E.NextInAEL == ENext == EMaxPair ... if IsHotEdge(e) then AddLocalMaxPoly(e, eMaxPair, e.top); DeleteFromAEL(e); DeleteFromAEL(eMaxPair); if assigned(ePrev) then Result := ePrev.nextInAEL else Result := FActives; end; end; //------------------------------------------------------------------------------ function TClipperBase.BuildPaths(out closedPaths, openPaths: TPaths64): Boolean; var i, cntClosed, cntOpen: Integer; outRec: POutRec; begin try cntClosed := 0; cntOpen := 0; SetLength(closedPaths, FOutRecList.Count); if FHasOpenPaths then SetLength(openPaths, FOutRecList.Count); for i := 0 to FOutRecList.Count -1 do begin outRec := UnsafeGet(FOutRecList, i); if not assigned(outRec.pts) then Continue; if outRec.isOpen then begin if BuildPath(outRec.pts, FReverseSolution, true, openPaths[cntOpen]) then inc(cntOpen); end else begin // closed paths should always return a Positive orientation // except when ReverseSolution == true if BuildPath(outRec.pts, FReverseSolution, false, closedPaths[cntClosed]) then inc(cntClosed); end; end; SetLength(closedPaths, cntClosed); SetLength(openPaths, cntOpen); result := true; except result := false; end; end; //------------------------------------------------------------------------------ function Path1InsidePath2(const or1, or2: POutRec): Boolean; var op: POutPt; pipResult: TPointInPolygonResult; begin op := or1.pts; repeat pipResult := PointInPolygon(op.pt, or2.path); if pipResult <> pipOn then Break; op := op.next; until op = or1.pts; if (pipResult = pipOn) then begin Result := Area(op) < Area(or2.pts); end else Result := pipResult = pipInside; end; //------------------------------------------------------------------------------ function GetBounds(const path: TPath64): TRect64; var i: integer; pX, pY: PInt64; begin if Length(path) = 0 then begin Result := NullRect64; Exit; end; result := Rect64(MaxInt64, MaxInt64, -MaxInt64, -MaxInt64); pX := @path[0].X; pY := @path[0].Y; for i := 0 to High(path) do begin if (pX^ < result.left) then result.left := pX^; if (pX^ > result.right) then result.right := pX^; if (pY^ < result.top) then result.top := pY^; if (pY^ > result.bottom) then result.bottom := pY^; inc(pX, 2); inc(pY, 2); end; end; //------------------------------------------------------------------------------ function TClipperBase.DeepCheckOwner(outrec, owner: POutRec): Boolean; var i: integer; split: POutRec; isInsideOwnerBounds: Boolean; begin if (owner.bounds.IsEmpty) then owner.bounds := Clipper.Engine.GetBounds(owner.path); isInsideOwnerBounds := owner.bounds.Contains(outrec.bounds); // while looking for the correct owner, check the owner's // splits **before** checking the owner itself because // splits can occur internally, and checking the owner // first would miss the inner split's true ownership result := false; for i := 0 to High(owner.splits) do begin split :=GetRealOutRec(owner.splits[i]); if not Assigned(split) or (split.idx <= owner.idx) or (split = outrec) then Continue; if Assigned(split.splits) and DeepCheckOwner(outrec, split) then begin Result := true; Exit; end; if Length(split.path) = 0 then BuildPath(split.pts, FReverseSolution, false, split.path); if split.bounds.IsEmpty then split.bounds := Clipper.Engine.GetBounds(split.path); if split.bounds.Contains(OutRec.bounds) and Path1InsidePath2(OutRec, split) then begin outRec.owner := split; Result := true; Exit; end; end; // only continue when not inside recursion if (owner <> outrec.owner) then Exit; while true do begin if isInsideOwnerBounds and Path1InsidePath2(outrec, outrec.owner) then begin Result := true; Exit; end; outrec.owner := outrec.owner.owner; if not assigned(outrec.owner) then Exit; isInsideOwnerBounds := outrec.owner.bounds.Contains(outrec.bounds); end; end; //------------------------------------------------------------------------------ procedure TClipperBase.BuildTree(polytree: TPolyPathBase; out openPaths: TPaths64); var i,j : Integer; cntOpen : Integer; outRec : POutRec; openPath : TPath64; ownerPP : TPolyPathBase; begin try polytree.Clear; if FHasOpenPaths then setLength(openPaths, FOutRecList.Count); cntOpen := 0; for i := 0 to FOutRecList.Count -1 do begin outRec := UnsafeGet(FOutRecList, i); if not assigned(outRec.pts) then Continue; if outRec.isOpen then begin if BuildPath(outRec.pts, FReverseSolution, true, openPath) then begin openPaths[cntOpen] := openPath; inc(cntOpen); end; Continue; end; if not BuildPath(outRec.pts, FReverseSolution, false, outRec.path) then Continue; if outrec.bounds.IsEmpty then outrec.bounds := Clipper.Engine.GetBounds(outrec.path); outrec.owner := GetRealOutRec(outrec.owner); if assigned(outRec.owner) then DeepCheckOwner(outRec, outRec.owner); // swap the order when a child preceeds its owner // (because owners must preceed children in polytrees) if assigned(outRec.owner) and (outRec.owner.idx > outRec.idx) then begin j := outRec.owner.idx; outRec.idx := j; FOutRecList[i] := UnsafeGet(FOutRecList, j); FOutRecList[j] := outRec; outRec := UnsafeGet(FOutRecList, i); outRec.idx := i; outRec.owner := GetRealOutRec(outRec.owner); BuildPath(outRec.pts, FReverseSolution, false, outRec.path); if (outRec.bounds.IsEmpty) then outRec.bounds := Clipper.Engine.GetBounds(outRec.path); if Assigned(outRec.owner) then DeepCheckOwner(outRec, outRec.owner); end; if assigned(outRec.owner) and assigned(outRec.owner.polypath) then ownerPP := outRec.owner.polypath else ownerPP := polytree; outRec.polypath := ownerPP.AddChild(outRec.path); end; setLength(openPaths, cntOpen); except end; end; //------------------------------------------------------------------------------ function TClipperBase.GetBounds: TRect64; var i: Integer; v, vStart: PVertex; begin Result := Rect64(MaxInt64, MaxInt64, -MaxInt64, -MaxInt64); for i := 0 to FVertexArrayList.Count -1 do begin vStart := UnsafeGet(FVertexArrayList, i); v := vStart; repeat if v.pt.X < Result.Left then Result.Left := v.pt.X else if v.pt.X > Result.Right then Result.Right := v.pt.X; if v.pt.Y < Result.Top then Result.Top := v.pt.Y else if v.pt.Y > Result.Bottom then Result.Bottom := v.pt.Y; v := v.next; until v = vStart; end; if Result.Left > Result.Right then Result := NullRect64; end; //------------------------------------------------------------------------------ // TClipper methods //------------------------------------------------------------------------------ procedure TClipper64.AddSubject(const subject: TPath64); begin AddPath(subject, ptSubject, false); end; //------------------------------------------------------------------------------ procedure TClipper64.AddSubject(const subjects: TPaths64); begin AddPaths(subjects, ptSubject, false); end; //------------------------------------------------------------------------------ procedure TClipper64.AddOpenSubject(const subject: TPath64); begin AddPath(subject, ptSubject, true); end; //------------------------------------------------------------------------------ procedure TClipper64.AddOpenSubject(const subjects: TPaths64); begin AddPaths(subjects, ptSubject, true); end; //------------------------------------------------------------------------------ procedure TClipper64.AddClip(const clip: TPath64); begin AddPath(clip, ptClip, false); end; //------------------------------------------------------------------------------ procedure TClipper64.AddClip(const clips: TPaths64); begin AddPaths(clips, ptClip, false); end; //------------------------------------------------------------------------------ function TClipper64.Execute(clipType: TClipType; fillRule: TFillRule; out closedSolutions: TPaths64): Boolean; var dummy: TPaths64; begin FUsingPolytree := false; closedSolutions := nil; try try ExecuteInternal(clipType, fillRule, false); BuildPaths(closedSolutions, dummy); Result := Succeeded; except Result := false; end; finally ClearSolution; end; end; //------------------------------------------------------------------------------ function TClipper64.Execute(clipType: TClipType; fillRule: TFillRule; out closedSolutions, openSolutions: TPaths64): Boolean; begin closedSolutions := nil; openSolutions := nil; FUsingPolytree := false; try try ExecuteInternal(clipType, fillRule, false); BuildPaths(closedSolutions, openSolutions); Result := Succeeded; except Result := false; end; finally ClearSolution; end; end; //------------------------------------------------------------------------------ function TClipper64.Execute(clipType: TClipType; fillRule: TFillRule; var solutionTree: TPolyTree64; out openSolutions: TPaths64): Boolean; begin if not assigned(solutionTree) then Raise EClipperLibException(rsClipper_PolyTreeErr); solutionTree.Clear; FUsingPolytree := true; openSolutions := nil; try try ExecuteInternal(clipType, fillRule, true); BuildTree(solutionTree, openSolutions); Result := Succeeded; except Result := false; end; finally ClearSolution; end; end; //------------------------------------------------------------------------------ // TPolyPathBase methods //------------------------------------------------------------------------------ constructor TPolyPathBase.Create; begin FChildList := TList.Create; end; //------------------------------------------------------------------------------ destructor TPolyPathBase.Destroy; begin Clear; FChildList.Free; inherited Destroy; end; //------------------------------------------------------------------------------ type PPolyPathBase = ^TPolyPathBase; procedure TPolyPathBase.Clear; var i: integer; ppb: PPolyPathBase; begin if FChildList.Count = 0 then Exit; ppb := @FChildList.List[0]; for i := 0 to FChildList.Count -1 do begin ppb^.Free; inc(ppb); end; FChildList.Clear; end; //------------------------------------------------------------------------------ function TPolyPathBase.GetChild(index: Integer): TPolyPathBase; begin if (index < 0) or (index >= FChildList.Count) then Result := nil else Result := FChildList[index]; end; //------------------------------------------------------------------------------ function TPolyPathBase.GetIsHole: Boolean; var pp: TPolyPathBase; begin pp := FParent; result := assigned(pp); if not Result then Exit; while assigned(pp) do begin result := not result; pp := pp.FParent; end; end; //------------------------------------------------------------------------------ function TPolyPathBase.GetChildCnt: Integer; begin Result := FChildList.Count; end; //------------------------------------------------------------------------------ //TPolyPath method //------------------------------------------------------------------------------ function TPolyPath64.AddChild(const path: TPath64): TPolyPathBase; begin Result := TPolyPath64.Create; Result.Parent := self; TPolyPath64(Result).FPath := path;; ChildList.Add(Result); end; //------------------------------------------------------------------------------ function TPolyPath64.GetChild64(index: Integer): TPolyPath64; begin Result := TPolyPath64(GetChild(index)); end; //------------------------------------------------------------------------------ // TClipperD methods //------------------------------------------------------------------------------ constructor TClipperD.Create(precision: integer); begin inherited Create; CheckPrecisionRange(precision); FScale := Math.Power(10, precision); FInvScale := 1/FScale; end; //------------------------------------------------------------------------------ {$IFDEF USINGZ} procedure TClipperD.CheckCallback; begin // only when the user defined ZCallback function has been assigned // do we assign the proxy callback ZCB to ClipperBase if Assigned(ZCallback) then inherited ZCallback := ZCB else inherited ZCallback := nil; end; //------------------------------------------------------------------------------ procedure TClipperD.ZCB(const bot1, top1, bot2, top2: TPoint64; var intersectPt: TPoint64); var tmp: TPointD; begin if not assigned(fZCallback) then Exit; // de-scale (x & y) // temporarily convert integers to their initial float values // this will slow clipping marginally but will make it much easier // to understand the coordinates passed to the callback function tmp := ScalePoint(intersectPt, FInvScale); //do the callback fZCallback( ScalePoint(bot1, FInvScale), ScalePoint(top1, FInvScale), ScalePoint(bot2, FInvScale), ScalePoint(top2, FInvScale), tmp); intersectPt.Z := tmp.Z; end; //------------------------------------------------------------------------------ {$ENDIF} procedure TClipperD.AddSubject(const pathD: TPathD); var p: TPath64; begin if FScale = 0 then FScale := DefaultClipperDScale; p := ScalePath(pathD, FScale); AddPath(p, ptSubject, false); end; //------------------------------------------------------------------------------ procedure TClipperD.AddSubject(const pathsD: TPathsD); var pp: TPaths64; begin if FScale = 0 then FScale := DefaultClipperDScale; pp := ScalePaths(pathsD, FScale); AddPaths(pp, ptSubject, false); end; //------------------------------------------------------------------------------ procedure TClipperD.AddOpenSubject(const pathD: TPathD); var p: TPath64; begin if FScale = 0 then FScale := DefaultClipperDScale; p := ScalePath(pathD, FScale); AddPath(p, ptSubject, true); end; //------------------------------------------------------------------------------ procedure TClipperD.AddOpenSubject(const pathsD: TPathsD); var pp: TPaths64; begin if FScale = 0 then FScale := DefaultClipperDScale; pp := ScalePaths(pathsD, FScale); AddPaths(pp, ptSubject, true); end; //------------------------------------------------------------------------------ procedure TClipperD.AddClip(const pathD: TPathD); var p: TPath64; begin if FScale = 0 then FScale := DefaultClipperDScale; p := ScalePath(pathD, FScale); AddPath(p, ptClip, false); end; //------------------------------------------------------------------------------ procedure TClipperD.AddClip(const pathsD: TPathsD); var pp: TPaths64; begin if FScale = 0 then FScale := DefaultClipperDScale; pp := ScalePaths(pathsD, FScale); AddPaths(pp, ptClip, false); end; //------------------------------------------------------------------------------ function TClipperD.Execute(clipType: TClipType; fillRule: TFillRule; out closedSolutions: TPathsD): Boolean; var dummy: TPathsD; begin Result := Execute(clipType, fillRule, closedSolutions, dummy); end; //------------------------------------------------------------------------------ function TClipperD.Execute(clipType: TClipType; fillRule: TFillRule; out closedSolutions, openSolutions: TPathsD): Boolean; var solClosed, solOpen: TPaths64; begin {$IFDEF USINGZ} CheckCallback; {$ENDIF} closedSolutions := nil; openSolutions := nil; try try ExecuteInternal(clipType, fillRule, false); Result := BuildPaths(solClosed, solOpen); if not Result then Exit; closedSolutions := ScalePathsD(solClosed, FInvScale); openSolutions := ScalePathsD(solOpen, FInvScale); except Result := false; end; finally ClearSolution; end; end; //------------------------------------------------------------------------------ function TClipperD.Execute(clipType: TClipType; fillRule: TFillRule; var solutionsTree: TPolyTreeD; out openSolutions: TPathsD): Boolean; var open_Paths: TPaths64; begin if not assigned(solutionsTree) then Raise EClipperLibException(rsClipper_PolyTreeErr); {$IFDEF USINGZ} CheckCallback; {$ENDIF} solutionsTree.Clear; FUsingPolytree := true; solutionsTree.SetScale(fScale); openSolutions := nil; try try ExecuteInternal(clipType, fillRule, true); BuildTree(solutionsTree, open_Paths); openSolutions := ScalePathsD(open_Paths, FInvScale); Result := true; except Result := false; end; finally ClearSolution; end; end; //------------------------------------------------------------------------------ // TPolyPathD methods //------------------------------------------------------------------------------ function TPolyPathD.AddChild(const path: TPath64): TPolyPathBase; begin Result := TPolyPathD.Create; Result.Parent := self; TPolyPathD(Result).fScale := fScale; TPolyPathD(Result).FPath := ScalePathD(path, 1/FScale); ChildList.Add(Result); end; //------------------------------------------------------------------------------ function TPolyPathD.GetChildD(index: Integer): TPolyPathD; begin Result := TPolyPathD(GetChild(index)); end; //------------------------------------------------------------------------------ // TPolyTreeD //------------------------------------------------------------------------------ procedure TPolyTreeD.SetScale(value: double); begin FScale := value; end; //------------------------------------------------------------------------------ end.