{ This file is part of the Mufasa Macro Library (MML) Copyright (c) 2009 by Raymond van Venetiƫ and Merlijn Wajer MML is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. MML is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with MML. If not, see . See the file COPYING, included in this distribution, for details about the copyright. TPA functions for the Mufasa Macro Library } unit tpa; {$mode objfpc}{$H+} interface uses Classes, SysUtils, mufasatypes; function FastTPASort(const TPA: TPointArray;const Dists: TIntegerArray; maxDist: Integer; CloseFirst: Boolean): TPointArray; procedure QuickSort(var A: TIntegerArray; iLo, iHi: Integer); //Start Wizzyplugin procedure tSwap(var a, b: TPoint); procedure tpaSwap(var a, b: TPointArray); procedure SwapE(var a, b: Extended); procedure RAaSTPAEx(var a: TPointArray; const w, h: Integer); procedure RAaSTPA(var a: TPointArray; const Dist: Integer); function NearbyPointInArrayEx(const P: TPoint; w, h:Integer; a: TPointArray): Boolean; function NearbyPointInArray(const P: TPoint; Dist:Integer; a: TPointArray): Boolean; function ReArrangeandShortenArrayEx(const a: TPointArray; w, h: Integer): TPointArray; function ReArrangeandShortenArray(const a: TPointArray; Dist: Integer): TPointArray; function TPAtoATPAEx(const TPA: TPointArray; w, h: Integer): T2DPointArray; function TPAtoATPA(const TPA: TPointArray; Dist: Integer): T2DPointArray; procedure QuickTPASort(var A: TIntegerArray; var B: TPointArray; iLo, iHi: Integer; SortUp: Boolean); procedure QuickATPASort(var A: TIntegerArray; var B: T2DPointArray; iLo, iHi: Integer; SortUp: Boolean); procedure SortTPAFrom(var a: TPointArray; const From: TPoint); procedure SortATPAFrom(var a: T2DPointArray; const From: TPoint); procedure SortATPAFromFirstPoint(var a: T2DPointArray; const From: TPoint); procedure InvertTPA(var a: TPointArray); procedure InvertATPA(var a: T2DPointArray); function MiddleTPAEx(const TPA: TPointArray; var x, y: Integer): Boolean; function MiddleTPA(const tpa: TPointArray): TPoint; procedure SortATPASize(var a: T2DPointArray; const BigFirst: Boolean); procedure SortATPAFromSize(var a: T2DPointArray; const Size: Integer; CloseFirst: Boolean); function CombineTPA(const Ar1, Ar2: TPointArray): TPointArray; function CombineIntArray(const Ar1, Ar2: TIntegerArray): TIntegerArray; function InIntArrayEx(const a: TIntegerArray; var Where: Integer; const Number: Integer): Boolean; function InIntArray(const a: TIntegerArray; Number: Integer): Boolean; procedure ClearSameIntegers(var a: TIntegerArray); procedure ClearSameIntegersAndTPA(var a: TIntegerArray; var p: TPointArray); function SplitTPAEx(const arr: TPointArray; w, h: Integer): T2DPointArray; function SplitTPA(const arr: TPointArray; Dist: Integer): T2DPointArray; function FloodFillTPA(const TPA : TPointArray) : T2DPointArray; procedure FilterPointsPie(var Points: TPointArray; const SD, ED, MinR, MaxR: Extended; Mx, My: Integer); procedure FilterPointsDist(var Points: TPointArray; const MinDist,MaxDist: Extended; Mx, My: Integer); procedure FilterPointsLine(var Points: TPointArray; Radial: Extended; Radius, MX, MY: Integer); function RemoveDistTPointArray(x, y, dist: Integer;const ThePoints: TPointArray; RemoveHigher: Boolean): TPointArray; function GetATPABounds(const ATPA: T2DPointArray): TBox; function GetTPABounds(const TPA: TPointArray): TBox; function FindTPAinTPA(SearchTPA: TPointArray; const TotalTPA: TPointArray; var Matches: TPointArray): Boolean; function FindTextTPAinTPA(Height : integer;const SearchTPA, TotalTPA: TPointArray; var Matches: TPointArray): Boolean; function GetSamePointsATPA(const ATPA : T2DPointArray; var Matches : TPointArray) : boolean; function FindGapsTPA(const TPA: TPointArray; MinPixels: Integer): T2DPointArray; procedure SortCircleWise(var tpa: TPointArray; const cx, cy, StartDegree: Integer; SortUp, ClockWise: Boolean); procedure LinearSort(var tpa: TPointArray; cx, cy, sd: Integer; SortUp: Boolean); function MergeATPA(const ATPA : T2DPointArray) : TPointArray; procedure AppendTPA(var TPA : TPointArray; const ToAppend : TPointArray); function TPAFromBox(const Box : TBox) : TPointArray; Function RotatePoints(Const P: TPointArray; A, cx, cy: Extended): TPointArray ; Function RotatePoint(Const p: TPoint; angle, mx, my: Extended): TPoint; inline; function FindTPAEdges(const p: TPointArray): TPointArray; function PointInTPA(const p: TPoint;const arP: TPointArray): Boolean; function ClearTPAFromTPA(const arP, ClearPoints: TPointArray): TPointArray; procedure ClearDoubleTPA(var TPA: TPointArray); Function ReturnPointsNotInTPA(Const TotalTPA: TPointArray; const Box: TBox): TPointArray; Procedure TPACountSort(Var TPA: TPointArray;const max: TPoint;Const SortOnX : Boolean); Procedure TPACountSortBase(Var TPA: TPointArray;const maxx, base: TPoint; const SortOnX : Boolean); procedure InvertTIA(var tI: TIntegerArray); function SumIntegerArray(const Ints : TIntegerArray): Integer; function AverageTIA(const tI: TIntegerArray): Integer; function AverageExtended(const tE: TExtendedArray): Extended; function SameTPA(const aTPA, bTPA: TPointArray): Boolean; function TPAInATPA(const TPA: TPointArray;const InATPA: T2DPointArray; var Index: LongInt): Boolean; procedure OffsetTPA(var TPA : TPointArray; const Offset : TPoint); procedure OffsetATPA(var ATPA : T2DPointArray; const Offset : TPoint); implementation uses math; {/\ Very Fast TPA Sort, uses an adepted CountSort algorithm. /\} Function FastTPASort(const TPA: TPointArray;const Dists: TIntegerArray; maxDist: Integer; CloseFirst: Boolean): TPointArray; { If you want to understand this algorithm, it might be helpful to read about CountSort. This algorithm is quite similar to CountSort. } Var Oc, D: TIntegerArray; I, H, J: Integer; ind: array of array of integer; Begin SetLength(Oc, maxDist + 1); // Oc stores the occurances of each distance. H := High(Dists); // The amount of values in the given Array of Points... // We store it instead of calling High(Dists) each time. // Get the occurance of each distance, and store it in Oc. // We need the occurances of each distance, so we can later on set the 2d Array // to it's proper length. For I := 0 To H Do Oc[Dists[I]] := Oc[Dists[I]] + 1; // What we are basically going to do now is the following: // Sort the points by their distances using countsort. // But because (-2, -2) and (2, 2) have the same distance from (0, 0), we also // store the index in the array 'TPA', which contains the actual points. // This way we can retreive the actuals points. // D nothing but a counter. It contains the amount of points (indices) stored // for EACH distance, so it's length is equal to the amount of Distances. // ind is the array that has as first index the Distance. The second depth of // the array is the index which is used to retreive the original point. SetLength(D, maxDist + 1); SetLength(ind, maxDist + 1); For I := 0 To maxDist Do // set the ind length of each ind[distance] to Oc[distance] SetLength(ind[i], Oc[i] + 1); For I := 0 To H Do // Performs the actual index sorting Begin // put an index (of Dists AND TPA) into a distance array. ind[Dists[I]][D[Dists[I]]] := I; // inc by one, so we won't override previous indexes. D[Dists[i]] := D[Dists[i]] + 1; End; // Here we are back to the CountSort style of writing back. // Now we are going to write back to the Result. // The Result's length is obviously of the same length as 'TPA'. SetLength(Result, H + 1); H := 0; // CloseFirst just means: Start writing from dist 0 to maxDist, or // start writing from maxDist to dist 0. The first one places the closest points // at the start of the result. The higher the index, the more far away the point. // Not Closefirst means put the most far away point in Result first. If CloseFirst Then Begin For I := 0 To maxDist Do // Put back to result For J := 0 To oC[I] - 1 Do Begin Result[H] := TPA[ind[I][J]]; H := H + 1; End; End Else For I := maxDist Downto 0 Do // Put back to result For J := 0 To oC[I] - 1 Do Begin Result[H] := TPA[ind[I][J]]; H := H + 1; End; // Voila! End; procedure QuickSort(var A: TIntegerArray; iLo, iHi: Integer) ; var Lo, Hi, Pivot, T: Integer; begin Lo := iLo; Hi := iHi; Pivot := A[(Lo + Hi) div 2]; repeat while A[Lo] < Pivot do Inc(Lo) ; while A[Hi] > Pivot do Dec(Hi) ; if Lo <= Hi then begin T := A[Lo]; A[Lo] := A[Hi]; A[Hi] := T; Inc(Lo) ; Dec(Hi) ; end; until Lo > Hi; if Hi > iLo then QuickSort(A, iLo, Hi) ; if Lo < iHi then QuickSort(A, Lo, iHi) ; end; const flnC=545947; fsqrtA:single=0.5; {{$ASMMODE INTEL} function fsqrt(x: Single): Single; begin asm sub dword ptr x, ($3F800000-flnC) fild dword ptr x fmul fsqrtA fistp dword ptr x add dword ptr x,($3F800000-flnC) fld x end; end; } procedure tSwap(var a, b: TPoint); var c: TPoint; begin c := a; a := b; b := c; end; procedure tpaSwap(var a, b: TPointArray); var c: TPointArray; begin c := a; a := b; b := c; end; procedure SwapE(var a, b: Extended); var c: extended; begin c := a; a := b; b := c; end; {/\ Leaves one point per box with side lengths W and H to the TPA. /\} procedure RAaSTPAEx(var a: TPointArray; const w, h: Integer); var i, c, NoTP, l: Integer; t: TPoint; Found : boolean; begin NoTP := 0; l := High(a); for i := 0 to l do begin Found := false; for c := 0 to NoTP - 1 do if (Abs(a[i].x - a[c].x) <= w) and (Abs(a[i].y - a[c].y) <= h) then begin Found := true; Break; end; if not Found then // if (c >= NoTP) then begin t := a[i]; a[i] := a[NoTP]; a[NoTP] := t; Inc(NoTP); end; end; SetLength(a, NoTP); end; {/\ Leaves one point per box with the side length Dist. /\} procedure RAaSTPA(var a: TPointArray; const Dist: Integer); var i, c, NoTP, l: Integer; t: TPoint; Found : boolean; begin NoTP := 0; l := High(a); for i := 0 to l do begin Found := false; for c := 0 to NoTP - 1 do if (Round(sqrt(Sqr(a[i].x - a[c].x) + Sqr(a[i].y - a[c].y))) <= Dist) then begin Found := True; Break; end; if not Found then // if (c >= NoTP) then begin t := a[i]; a[i] := a[NoTP]; a[NoTP] := t; Inc(NoTP); end; end; SetLength(a, NoTP); end; {/\ Returns true if the point P is near a point in the TPA a with the max X and Y distances W and H. /\} function NearbyPointInArrayEx(const P: TPoint; w, h:Integer; a: TPointArray): Boolean; var i, l: Integer; begin Result := False; l := High(a); for i := 0 to l do if (Abs(P.x - a[i].x) <= w) and (Abs(P.y - a[i].y) <= h) then begin Result := True; Exit; end; end; {/\ Returns true if the point P is near a point in the TPA a with the max distance Dist. /\} function NearbyPointInArray(const P: TPoint; Dist:Integer; a: TPointArray): Boolean; var i, l: Integer; begin Result := False; l := High(a); for i := 0 to l do if (Round(sqrt(Sqr(P.x - a[i].x) + Sqr(P.y - a[i].y))) <= Dist) then begin Result := True; Exit; end; end; {/\ Results the TPointArray a with one point per box with side lengths W and H left. /\} function ReArrangeandShortenArrayEx(const a: TPointArray; w, h: Integer): TPointArray; var i, t, c, l: Integer; Found: Boolean; begin l := High(a); c := 0; SetLength(Result, l + 1); for i := 0 to l do begin Found := False; for t := 0 to c -1 do if (Abs(Result[t].x - a[i].x) <= w) and (Abs(Result[t].y - a[i].y) <= h) then begin; Found := True; Break; end; if not Found then // if (t >= c) then begin Result[c] := a[i]; Inc(c); end; end; SetLength(Result, c); end; {/\ Results the TPointArray a with one point per box with side length Dist left. /\} function ReArrangeandShortenArray(const a: TPointArray; Dist: Integer): TPointArray; var i, t, c, l: Integer; Found: Boolean; begin l := High(a); c := 0; SetLength(Result, l + 1); for i := 0 to l do begin Found := False; for t := 0 to c -1 do if (Round(sqrt(Sqr(Result[t].x - a[i].x) + Sqr(Result[t].y - a[i].y))) <= Dist) then begin Found := True; Break; end; if not found then // if (t >= c) then begin Result[c] := a[i]; Inc(c); end; end; SetLength(Result, c); end; {/\ Splits the TPA to boxes with sidelengths W and H and results them as a T2DPointArray. /\} function TPAtoATPAEx(const TPA: TPointArray; w, h: Integer): T2DPointArray; var a, b, c, l: LongInt; Found: Boolean; begin SetLength(Result, 0); l := High(TPA); c := 0; for a := 0 to l do begin Found := false; for b := 0 to c -1 do if (Abs(TPA[a].X - Result[b][0].X) <= w) and (Abs(TPA[a].Y - Result[b][0].Y) <= h) then begin Found := True; Break; end; if Found then // if (b < c) then begin SetLength(Result[b], Length(Result[b]) + 1); Result[b][High(Result[b])] := TPA[a]; end else begin SetLength(Result, c + 1); SetLength(Result[c], 1); Result[c][0] := TPA[a]; Inc(c); end; end; end; {/\ Splits the TPA to boxes with sidelength Dist and results them as a T2DPointArray. /\} function TPAtoATPA(const TPA: TPointArray; Dist: Integer): T2DPointArray; var a, b, c, l: LongInt; Found: Boolean; begin SetLength(Result, 0); l := High(tpa); c := 0; for a := 0 to l do begin Found := false; for b := 0 to c -1 do if (Round(sqrt(Sqr(TPA[a].X - Result[b][0].X) + Sqr(TPA[a].Y - Result[b][0].Y))) <= Dist) then begin Found := True; Break; end; if Found then // if (b < c) then begin SetLength(Result[b], Length(Result[b]) + 1); Result[b][High(Result[b])] := TPA[a]; end else begin SetLength(Result, c + 1); SetLength(Result[c], 1); Result[c][0] := TPA[a]; Inc(c); end; end; end; {/\ Sorts the given TPointArray. /\} procedure QuickTPASort(var A: TIntegerArray; var B: TPointArray; iLo, iHi: Integer; SortUp: Boolean); var Lo, Hi, Mid, T: Integer; TP: TPoint; begin if (Length(A) <> Length(B)) then Exit; Lo := iLo; Hi := iHi; Mid := A[(Lo + Hi) shr 1]; repeat if SortUp then begin while (A[Lo] < Mid) do Inc(Lo); while (A[Hi] > Mid) do Dec(Hi); end else begin while (A[Lo] > Mid) do Inc(Lo); while (A[Hi] < Mid) do Dec(Hi); end; if (Lo <= Hi) then begin T := A[Lo]; A[Lo] := A[Hi]; A[Hi] := T; TP := B[Lo]; B[Lo] := B[Hi]; B[Hi] := TP; Inc(Lo); Dec(Hi); end; until Lo > Hi; if (Hi > iLo) then QuickTPASort(A, B, iLo, Hi, SortUp); if (Lo < iHi) then QuickTPASort(A, B, Lo, iHi, SortUp); end; {/\ Sorts the given T2DPointArray. /\} procedure QuickATPASort(var A: TIntegerArray; var B: T2DPointArray; iLo, iHi: Integer; SortUp: Boolean); var Lo, Hi, Mid, T: Integer; TP: TPointArray; begin if (Length(A) <> Length(B)) then Exit; Lo := iLo; Hi := iHi; Mid := A[(Lo + Hi) shr 1]; repeat if SortUp then begin while (A[Lo] < Mid) do Inc(Lo); while (A[Hi] > Mid) do Dec(Hi); end else begin while (A[Lo] > Mid) do Inc(Lo); while (A[Hi] < Mid) do Dec(Hi); end; if (Lo <= Hi) then begin T := A[Lo]; A[Lo] := A[Hi]; A[Hi] := T; TP := B[Lo]; B[Lo] := B[Hi]; B[Hi] := TP; Inc(Lo); Dec(Hi); end; until Lo > Hi; if (Hi > iLo) then QuickATPASort(A, B, iLo, Hi, SortUp); if (Lo < iHi) then QuickATPASort(A, B, Lo, iHi, SortUp); end; {/\ Sorts the TPointArray a from the point From. Closest one to the point is [0], second closest is [1] etc. /\} procedure SortTPAFrom(var a: TPointArray; const From: TPoint); var i, l: Integer; DistArr: TIntegerArray; begin l := High(a); if (l < 0) then Exit; SetLength(DistArr, l + 1); for i := 0 to l do DistArr[i] := Round(Sqr(From.x - a[i].x) + Sqr(From.y - a[i].y)); QuickTPASort(DistArr, a, 0, l, True); end; {/\ Sorts the T2DPointArray a from the point From. /\} procedure SortATPAFrom(var a: T2DPointArray; const From: TPoint); var i, l: Integer; begin l := High(a); if (l < 0) then Exit; for i := 0 to l do SortTPAFrom(a[i], From); end; {/\ Sorts the T2DPointArray a from the point From. /\} procedure SortATPAFromFirstPoint(var a: T2DPointArray; const From: TPoint); var i, l: Integer; DistArr: TIntegerArray; begin l := High(a); if (l < 0) then Exit; SetLength(DistArr, l + 1); for i := 0 to l do DistArr[i] := Round(Sqr(From.x - a[i][0].x) + Sqr(From.y - a[i][0].y)); QuickATPASort(DistArr, a, 0, l, True); end; {/\ Inverts / Reverses the TPointArray a. /\} procedure InvertTPA(var a: TPointArray); var i, l: Integer; b: tpointarray; begin l := High(a); if (l < 0) then Exit; b := Copy(a); for i := l downto 0 Do a[l - i] := b[i]; end; {/\ Inverts / Reverts the T2DPointArray a. /\} procedure InvertATPA(var a: T2DPointArray); var i, l: Integer; b: T2DPointArray; begin l := High(a); if (l < 0) then Exit; b := Copy(a); for i := l downto 0 do a[l - i] := b[i]; end; {/\ Stores the coordinates of the middle of the TPointArray a to X and Y. /\} function MiddleTPAEx(const TPA: TPointArray; var x, y: Integer): Boolean; var i, l: Integer; begin Result := False; l := High(tpa); if (l < 0) then Exit; x := 0; y := 0; for i := 0 to l do begin x := x + tpa[i].x; y := y + tpa[i].y; end; x := x div (l + 1); y := y div (l + 1); Result := True; end; {/\ Returns the middle of the TPointArray tpa. /\} function MiddleTPA(const tpa: TPointArray): TPoint; var i, l: Integer; begin FillChar(result,sizeof(TPoint),0); l := High(tpa); if (l < 0) then Exit; Result.x := 0; Result.y := 0; for i := 0 to l do begin Result.x := Result.x + tpa[i].x; Result.y := Result.y + tpa[i].y; end; Result.x := Result.x div (l + 1); Result.y := Result.y div (l + 1); end; {/\ Sorts the T2DPointArray a from either largest or smallest, by the amount of points in the TPAs. /\} procedure SortATPASize(var a: T2DPointArray; const BigFirst: Boolean); var i, l: Integer; SizeArr: TIntegerArray; begin l := High(a); if (l < 0) then Exit; SetLength(SizeArr, l + 1); for i := 0 to l do SizeArr[i] := Length(a[i]); QuickATPASort(SizeArr, a, 0, l, not BigFirst); end; {/\ Combines the TPointArrays Ar1 and Ar2, and results the combination. /\} procedure SortATPAFromSize(var a: T2DPointArray; const Size: Integer; CloseFirst: Boolean); var i, l: Integer; SizeArr: TIntegerArray; begin l := High(a); if (l < 0) then Exit; SetLength(SizeArr, l + 1); for i := 0 to l do SizeArr[i] := Abs(Length(a[i]) - Size); QuickATPASort(SizeArr, a, 0, l, CloseFirst); end; {/\ Combines the TPointArrays Ar1 and Ar2, and results the combination. /\} function CombineTPA(const Ar1, Ar2: TPointArray): TPointArray; var i, l1, l2: Integer; begin Result := Copy(Ar1); l1 := Length(Result); l2 := Length(Ar2); SetLength(Result, l1 + l2); for i := 0 to l2 -1 do Result[i + l1] := Ar2[i]; end; {/\ Combines the TIntegerArrays Ar1 and Ar2, and results the combination. /\} function CombineIntArray(const Ar1, Ar2: TIntegerArray): TIntegerArray; var i, l1, l2: Integer; begin Result := Copy(Ar1); l1 := Length(Result); l2 := Length(Ar2); SetLength(Result, l1 + l2); for i := 0 to l2 -1 do Result[i + l1] := Ar2[i]; end; {/\ Returns true if the integer Number was found in the integer array a, and stores the index to Where. /\} function InIntArrayEx(const a: TIntegerArray; var Where: Integer; const Number: Integer): Boolean; var i, l: Integer; begin Result := False; l := High(a); for i := 0 to l do if (a[i] = Number) then begin Where := i; Result := True; Exit; end; end; {/\ Returns true if the integer Number was found in the integer array a. /\} function InIntArray(const a: TIntegerArray; Number: Integer): Boolean; var i, l: Integer; begin Result := False; l := High(a); for i := 0 to l do if (a[i] = Number) then begin Result := True; Exit; end; end; {/\ Clears the duplicates in the integer array a. /\} procedure ClearSameIntegers(var a: TIntegerArray); var i, t, c, l: Integer; b: TIntegerArray; Found: Boolean; begin b := Copy(a); l := High(b); c := 0; for i := 0 to l do begin Found := False; for t := 0 to c -1 do if (b[i] = a[t]) then begin Found := True; Break; end; if not Found then // if (t >= c) then begin a[c] := b[i]; Inc(c); end; end; SetLength(a, c); end; {/\ Clears the duplicates in the integer array a and the TPointArray p. /\} procedure ClearSameIntegersAndTPA(var a: TIntegerArray; var p: TPointArray); var i, t, c, l: Integer; b: TIntegerArray; Found: Boolean; begin b := Copy(a); l := High(b); c := 0; for i := 0 to l do begin Found := false; for t := 0 to c -1 do if (b[i] = a[t]) then begin Found := true; Break; end; if not Found then // if (t >= c) then begin SetLength(a, c +1); a[c] := b[i]; p[c] := p[i]; Inc(c); end; end; SetLength(p, c); SetLength(a, c); end; {/\ Splits the points with max X and Y distances W and H to their own TPointArrays. /\} function SplitTPAEx(const arr: TPointArray; w, h: Integer): T2DPointArray; var t1, t2, c, ec, tc, l: Integer; tpa: TPointArray; begin tpa := Copy(arr); l := High(tpa); if (l < 0) then Exit; SetLength(Result, l + 1); c := 0; ec := 0; while ((l - ec) >= 0) do begin SetLength(Result[c], 1); Result[c][0] := tpa[0]; tpa[0] := tpa[l - ec]; Inc(ec); tc := 1; t1 := 0; while (t1 < tc) do begin t2 := 0; while (t2 <= (l - ec)) do begin if (Abs(Result[c][t1].x - tpa[t2].x) <= w) and (Abs(Result[c][t1].y - tpa[t2].y) <= h) then begin SetLength(Result[c], tc +1); Result[c][tc] := tpa[t2]; tpa[t2] := tpa[l - ec]; Inc(ec); Inc(tc); Dec(t2); end; Inc(t2); end; Inc(t1); end; Inc(c); end; SetLength(Result, c); end; {/\ Splits the points with max distance Dist to their own TPointArrays. Dist 1 puts the points that are next to eachother to their own arrays. /\} function SplitTPA(const arr: TPointArray; Dist: Integer): T2DPointArray; var t1, t2, c, ec, tc, l: Integer; tpa: TPointArray; begin tpa := Copy(arr); l := High(tpa); if (l < 0) then Exit; SetLength(Result, l + 1); c := 0; ec := 0; while ((l - ec) >= 0) do begin SetLength(Result[c], 1); Result[c][0] := tpa[0]; tpa[0] := tpa[l - ec]; Inc(ec); tc := 1; t1 := 0; while (t1 < tc) do begin t2 := 0; while (t2 <= (l - ec)) do begin if (Round(sqrt(Sqr(Result[c][t1].x - tpa[t2].x) + Sqr(Result[c][t1].y - tpa[t2].y))) <= Dist) then begin SetLength(Result[c], tc +1); Result[c][tc] := tpa[t2]; tpa[t2] := tpa[l - ec]; Inc(ec); Inc(tc); Dec(t2); end; Inc(t2); end; Inc(t1); end; Inc(c); end; SetLength(Result, c); end; function FloodFillTPA(const TPA : TPointArray) : T2DPointArray; var x,y,i,CurrentArray, LengthTPA,CurrentStack : integer; TempBox : TBox; PointsToFill : T2DBoolArray; Lengths : TIntegerArray; TempTPA : TPointArray; Stack : TPointArray; fx,fy : integer; begin; LengthTPA := High(TPA); if LengthTPA < 1 then begin; if LengthTPA = 0 then begin; SetLength(Result,1,1); Result[0][0] := TPA[0]; end else SetLength(Result,0); exit; end; TempBox := GetTPABounds(TPA); SetLength(PointsToFill,TempBox.x2 - TempBox.x1+3,TempBox.y2 - TempBox.y1+3); //W + 2, H + 2 so that we can check the borders fy := TempBox.y2 - TempBox.y1+3; fx := TempBox.x2 - TempBox.x1+2; for i := 0 to fx do FillChar(PointsToFill[i][0],fy*sizeof(boolean),0); x := TempBox.x1 - 1; y := TempBox.y1 - 1; CurrentArray := -1; SetLength(Stack , LengthTPA + 1); SetLength(Lengths , LengthTPA + 1); SetLength(TempTPA , LengthTPA + 1); For I := 0 to LengthTPA do begin; TempTPA[I].x := TPA[I].x - x; TempTPA[I].y := TPA[I].y - y; end; For I := 0 to LengthTPA do PointsToFill[TempTPA[I].x][TempTPA[I].y] := True; For I := 0 to LengthTPA do if PointsToFill[TempTPA[I].x][TempTPA[I].y] then begin; inc(CurrentArray); SetLength(Result,CurrentArray + 1); SetLength(Result[CurrentArray],LengthTPA - I + 1); Lengths[CurrentArray] := 0; CurrentStack := 0; Stack[0].x := TempTPA[I].x; Stack[0].y := TempTPA[I].y; While CurrentStack > -1 do begin; fx := stack[CurrentStack].x; fy := stack[CurrentStack].y; dec(CurrentStack); Result[CurrentArray][Lengths[CurrentArray]].x := fx + x; Result[CurrentArray][Lengths[CurrentArray]].y := fy + y; inc(Lengths[CurrentArray]); if PointsToFill[fx+1][fy] then begin inc(CurrentStack);Stack[CurrentStack].x := fx+1;Stack[Currentstack].y := fy;PointsToFill[fx+1][fy] := false; end; if PointsToFill[fx][fy+1] then begin inc(CurrentStack);Stack[CurrentStack].x := fx;Stack[Currentstack].y := fy+1;PointsToFill[fx][fy+1] := false; end; if PointsToFill[fx-1][fy] then begin inc(CurrentStack);Stack[CurrentStack].x := fx-1;Stack[Currentstack].y := fy;PointsToFill[fx-1][fy] := false; end; if PointsToFill[fx][fy-1] then begin inc(CurrentStack);Stack[CurrentStack].x := fx;Stack[Currentstack].y := fy-1;PointsToFill[fx][fy-1] := false; end; if PointsToFill[fx+1][fy+1] then begin inc(CurrentStack);Stack[CurrentStack].x := fx+1;Stack[Currentstack].y := fy+1;PointsToFill[fx+1][fy+1] := false; end; if PointsToFill[fx-1][fy-1] then begin inc(CurrentStack);Stack[CurrentStack].x := fx-1;Stack[Currentstack].y := fy-1;PointsToFill[fx-1][fy-1] := false; end; if PointsToFill[fx-1][fy+1] then begin inc(CurrentStack);Stack[CurrentStack].x := fx-1;Stack[Currentstack].y := fy+1;PointsToFill[fx-1][fy+1] := false; end; if PointsToFill[fx+1][fy-1] then begin inc(CurrentStack);Stack[CurrentStack].x := fx+1;Stack[Currentstack].y := fy-1;PointsToFill[fx+1][fy-1] := false; end; end; SetLength(Result[CurrentArray],Lengths[CurrentArray]); end; SetLength(Stack,0); SetLength(TempTPA,0); SetLength(Lengths,0); end; {/\ Removes the points in the TPointArray Points that are not within the degrees \\ SD (StartDegree) and ED (EndDegree) and the distances MinR (MinRadius) and \\ MaxR (MaxRadius) from the origin (Mx, My). /\} procedure FilterPointsPie(var Points: TPointArray; const SD, ED, MinR, MaxR: Extended; Mx, My: Integer); const i180Pi = 57.29577951; var G: TPointArray; I, L, T: Integer; D, StartD, EndD: Extended; cWise: Boolean; begin T := High(Points); if (T < 0) then Exit; SetLength(G, T + 1); L := 0; StartD := SD; EndD := ED; cWise := StartD > EndD; while StartD > 360.0 do StartD := StartD - 360.0; while EndD > 360.0 do EndD := EndD - 360.0; while StartD < 0.0 do StartD := StartD + 360.0; while EndD < 0.0 do EndD := EndD + 360.0; if StartD > EndD then SwapE(StartD, EndD); for I := 0 to T do begin D := sqrt(Sqr(Points[I].X - Mx) + Sqr(Points[I].Y - My)); if( D <= MinR) or (D >= MaxR) then Continue; D := (ArcTan2(Points[I].Y - My, Points[I].X - Mx) * i180Pi) + 90; if D < 0.0 then D := D + 360.0; if (not ((StartD <= D) and (EndD >= D))) xor CWise then Continue; G[L] := Points[I]; Inc(L); end; SetLength(G, L); Points := G; end; {/\ Removes the points that don't have a dist between mindist/maxdist with (mx,my) /\} procedure FilterPointsDist(var Points: TPointArray; const MinDist, MaxDist: Extended; Mx, My: Integer); var c,i,l : integer; d : extended; mind,maxd : extended; begin l := high(points); c := 0; mind := sqr(mindist); maxd := sqr(maxdist); for i := 0 to l do begin d := sqr(Points[i].x - mx) + sqr(points[i].y - my); if (d >= mind) and (d <= maxd) then begin points[c] := points[i]; inc(c); end; end; setlength(points,c); end; {/\ Removes the points in the TPointArray Points that are not on the line defined by angle, radius and center. /\} procedure FilterPointsLine(var Points: TPointArray; Radial: Extended; Radius, MX, MY: Integer); var I, Hi, Ind, y: Integer; P: TPointArray; Box: TBox; B: T2DBoolArray; SinAngle,CosAngle : Extended; begin Ind := 0; Box:= GetTPABounds(Points); SinAngle := sin(Radial); CosAngle := cos(Radial); SetLength(B, max(Box.x2, Round(SinAngle * Radius + MX)) + 1); y:= max(Box.x2, -Round(CosAngle * Radius) + MY); for I:= 0 to High(B) do begin; SetLength(B[I], y + 1); FillChar(B[i][0],y+1,0); end; Hi:= High(Points); for I:= 0 to Hi do B[Points[I].x][Points[I].y]:= True; SetLength(P, Hi + 1); for I:= 0 to Radius do begin if(B[Round(SinAngle * I) + MX][-Round(CosAngle * I) + MY])then begin P[Ind].X := Round(SinAngle * I) + MX; P[Ind].Y := -Round(CosAngle * I) + MY; inc(Ind); end; end; SetLength(P, Ind); Points:= P; end; {/\ Removes the points that are inside or outside the distance Dist from the point (x, y) from the TPointArray ThePoints. /\} function RemoveDistTPointArray(x, y, dist: Integer;const ThePoints: TPointArray; RemoveHigher: Boolean): TPointArray; var I, L, LL: integer; begin; L := 0; LL := Length(ThePoints) -1; SetLength(Result, LL + 1); if RemoveHigher then begin; for I := 0 to LL do if not (Round(sqrt(sqr(ThePoints[i].x - x)+sqr(ThePoints[i].y - y))) > Dist) then begin; Result[L] := ThePoints[i]; L := L + 1; end; end else begin; for I := 0 to LL do if not (Round(sqrt(sqr(ThePoints[i].x - x)+sqr(ThePoints[i].y - y))) < Dist) then begin; Result[L] := ThePoints[i]; L := L + 1; end; end; SetLength(Result,L); end; {/\ Returns the boundaries of the ATPA as a TBox. /\} function GetATPABounds(const ATPA: T2DPointArray): TBox; var I,II,L2,L : Integer; begin; FillChar(result,sizeof(TBox),0); L := High(ATPA); if (l < 0) then Exit; For I := 0 to L do if Length(ATPA[I]) > 0 then begin; Result.x1 := ATPA[I][0].x; Result.y1 := ATPA[I][0].y; Result.x2 := ATPA[I][0].x; Result.y2 := ATPA[I][0].y; end; for I := 0 to L do begin; L2 := High(ATPA[I]); for II := 0 to L2 do begin; if ATPA[i][II].x > Result.x2 then Result.x2 := ATPA[i][II].x else if ATPA[i][II].x < Result.x1 then Result.x1 := ATPA[i][II].x; if ATPA[i][II].y > Result.y2 then Result.y2 := ATPA[i][II].y else if ATPA[i][II].y < Result.y1 then Result.y1 := ATPA[i][II].y; end; end; end; {/\ Returns the boundaries of the TPA as a TBox. /\} function GetTPABounds(const TPA: TPointArray): TBox; var I,L : Integer; begin; FillChar(result,sizeof(TBox),0); L := High(TPA); if (l < 0) then Exit; Result.x1 := TPA[0].x; Result.y1 := TPA[0].y; Result.x2 := TPA[0].x; Result.y2 := TPA[0].y; for I:= 1 to L do begin; if TPA[i].x > Result.x2 then Result.x2 := TPA[i].x else if TPA[i].x < Result.x1 then Result.x1 := TPA[i].x; if TPA[i].y > Result.y2 then Result.y2 := TPA[i].y else if TPA[i].y < Result.y1 then Result.y1 := TPA[i].y; end; end; {/\ Looks for the TPA SearchTPA in the TPA TotalTPA and returns the matched points \\ to the TPA Matches. Returns true if there were atleast one match(es). /\} function FindTPAinTPA(SearchTPA : TPointArray; const TotalTPA: TPointArray; var Matches: TPointArray): Boolean; var Len, I,II,LenSearch,xOff,yOff : integer; tx,ty,MatchCount : integer; Screen : T2DBoolArray; ScreenBox,SearchBox : TBox; Found: Boolean; begin; Result := False; Len := High(TotalTPA); LenSearch := High(SearchTPA); if LenSearch < 0 then Exit; if Len < LenSearch then Exit; MatchCount := 0; ScreenBox := GetTPABounds(TotalTPA); SearchBox := GetTPABounds(SearchTPA); try SetLength(Screen,ScreenBox.x2 + 1,ScreenBox.y2 + 1); for i := ScreenBox.x2 downto 0 do FillChar(Screen[i][0],screenbox.y2+1,0); except Exit; end; if (SearchBox.x1 > 0) or (SearchBox.y1 > 0) then begin; for I := 0 to LenSearch do begin; SearchTPA[I].x := SearchTPA[I].x - SearchBox.x1; SearchTPA[I].y := SearchTPA[I].y - SearchBox.y1; end; SearchBox.x2 := SearchBox.x2 - SearchBox.x1; SearchBox.y2 := SearchBox.y2 - SearchBox.y1; SearchBox.x1 := 0; SearchBox.y1 := 0; end; xOff := SearchBox.x2; yOff := SearchBox.y2; for I := 0 to LenSearch do begin; if (SearchTPA[I].x = 0) and (SearchTPA[I].y < yOff) then yOff := SearchTPA[I].y; if (SearchTPA[I].y = 0) and (SearchTPA[I].x < xOff) then xOff := SearchTPA[I].x; end; for I := 0 to Len do Screen[TotalTPA[I].x][TotalTPA[I].y] := True; for I := 0 to Len do begin; tx := TotalTPA[I].x - xOff; ty := TotalTPA[I].y;// - yOff; if tx > 0 then if ty > 0 then if ((SearchBox.x2 + tx) <= ScreenBox.x2) and ((SearchBox.y2 + ty) <= ScreenBox.y2) then begin; Found := false; For II := 0 to LenSearch do if Screen[tx + SearchTPA[II].x ][ty + SearchTPA[II].y] = False then begin Found := True; Break; end; if not found then // if II > LenSearch then begin; MatchCount := MatchCount + 1; SetLength(Matches,MatchCount); Matches[MatchCount - 1].x := TotalTPA[I].x; Matches[MatchCount - 1].y := TotalTPA[I].y; end; end; end; if (MatchCount > 0) then Result := True; end; {/\ Read the description of FindTPAinTPA. Additional Height parameter. /\} function FindTextTPAinTPA(Height : integer;const SearchTPA, TotalTPA: TPointArray; var Matches: TPointArray): Boolean; var Len, I,II,LenSearch,LenTPA,xOff,yOff,x,y: integer; tx,ty,MatchCount : integer; Found : boolean; Screen : T2DBoolArray; ScreenBox,SearchBox : TBox; InversedTPA : TPointArray; begin; Result := False; Len := High(TotalTPA); LenSearch := High(SearchTPA); if LenSearch < 0 then Exit; if Len < LenSearch then Exit; MatchCount := 0; xOff := -5; yOff := 0; ScreenBox := GetTPABounds(TotalTPA); SearchBox := GetTPABounds(SearchTPA); if height > SearchBox.y2 then Screenbox.y2 := Screenbox.y2 + (height - SearchBox.y2); SearchBox.y2 := Height; SetLength(Screen, SearchBox.x2 + 1,SearchBox.y2 + 1); for i := SearchBox.x2 downto 0 do FillChar(screen[i][0],SearchBox.y2+1,0); SetLength(InversedTPA,(SearchBox.x2 + 1) * (Searchbox.y2 + 1)); for I := 0 to LenSearch do Screen[ SearchTPA[I].x,SearchTPA[I].y] := True; LenTPA := -1; for y := 0 to SearchBox.y2 do for x := 0 to SearchBox.x2 do if Screen[X][Y] = False then begin; LenTPA := LenTPA + 1; InversedTPA[LenTPA].x := x; InversedTPA[LenTPA].y := y; end; for x := 0 to SearchBox.x2 do begin; for y := 0 to SearchBox.y2 do if Screen[x][y] = True then begin; xOff := x; yOff := y; Break; end; if xOff >= 0 then Break; end; try SetLength(Screen,0); SetLength(Screen,ScreenBox.x2 + 1,ScreenBox.y2 + 1); for i := ScreenBox.x2 downto 0 do FillChar(screen[i][0],screenbox.y2+1,0); except Exit; end; for I := 0 to Len do Screen[TotalTPA[I].x][TotalTPA[I].y] := True; for I := 0 to Len do begin; tx := TotalTPA[I].x - xOff; ty := TotalTPA[I].y - yOff; if tx > 0 then if ty > 0 then if ((SearchBox.x2 + tx) <= ScreenBox.x2) and ((SearchBox.y2 + ty) <= ScreenBox.y2) then begin; Found := false; For II := 0 to LenSearch do if Screen[tx + SearchTPA[II].x ][ty + SearchTPA[II].y] = False then begin Found := true; Break; end; if (not Found) then begin; Found := false; For II := 0 to LenTPA do if Screen[tx + InversedTPA[II].x ][ty + InversedTPA[II].y] = True then begin Found := true; Break; end; if (not Found) then begin; MatchCount := MatchCount + 1; SetLength(Matches,MatchCount); Matches[MatchCount - 1].x := TotalTPA[I].x; Matches[MatchCount - 1].y := TotalTPA[I].y; end; end; end; end; if (MatchCount > 0) then Result := True; end; {/\ Finds the points that exist in all TPA's in the ATPA. /\} function GetSamePointsATPA(const ATPA : T2DPointArray; var Matches : TPointArray) : boolean; var I,ii,Len,MatchesC : integer; MinBox,TempBox : TBox; Grid : Array of Array of LongWord; CompareValue : Longword; W,H,x,y: integer; begin; len := high(ATPA); result := false; if len >= 31 then begin; Writeln('You cannot have more than 32 TPA''s in your ATPA for this function'); exit; end; if len <= 0 then begin; Writeln('You''d need more than 1 TPA for this function'); exit; end; MinBox.x1 := 0; MinBox.y1 := 0; MinBox.x2 := MaxInt; MinBox.y2 := MaxInt; for i := 0 to len do if Length(ATPA[i]) = 0 then Exit else begin TempBox := GetTPABounds(ATPA[i]); MinBox.x1 := Max(MinBox.x1,TempBox.x1); MinBox.y1 := Max(MinBox.y1,TempBox.y1); MinBox.x2 := Min(MinBox.x2,TempBox.x2); MinBox.y2 := Min(MinBox.y2,TempBox.y2); end; w := MinBox.x2-minbox.x1; h := minbox.y2 - minbox.y1; Writeln(format('(%d,%d,%d,%d)',[minbox.x1,minbox.y1,minbox.x2,minbox.y2])); SetLength(Grid,w + 1); for i := (W) downto 0 do begin; setlength(grid[i],H + 1); FillChar(grid[i][0],SizeOf(LongWord) * (H + 1),0); end; for i := 0 to len do for ii := high(ATPA[i]) downto 0 do if (ATPA[i][ii].x >= MinBox.x1) and (ATPA[i][ii].x <= MinBox.x2) and (ATPA[i][ii].y >= MinBox.y1) and (ATPA[i][ii].y <= MinBox.y2) then Grid[ATPA[i][ii].x-MinBox.x1][ATPA[i][ii].y-MinBox.y1] := Grid[ATPA[i][ii].x-MinBox.x1][ATPA[i][ii].y-MinBox.y1] or (1 shl i);//Set that this TPA has this point.. CompareValue := 0; for i := 0 to len do CompareValue := CompareValue or (1 shl i); SetLength(matches, (W+1) * (H+ 1)); MatchesC := 0; for y := 0 to H do for x := 0 to W do if Grid[x][y] = CompareValue then begin; Matches[MatchesC].x := x + minbox.x1; Matches[MatchesC].y := y + minbox.y1; inc(MatchesC); end; result := (MatchesC <> 0); setlength(matches,MatchesC); end; {/\ Finds the possible gaps in the TPointArray TPA and results the gaps as a T2DPointArray. \\ Considers as a gap if the gap length is >= MinPixels. \\ Only horizontal, sorry folks. /\} function FindGapsTPA(const TPA: TPointArray; MinPixels: Integer): T2DPointArray; var Len,TotalLen,LenRes,I,II,III : integer; Screen : T2DBoolArray; Height,Width : Integer; Box : TBox; begin; Len := High(TPA); if Len < 0 then exit; Box := GetTPABounds(TPA); Height := Box.y2 - Box.y1; Width := Box.x2 - Box.x1; LenRes := 0; III := 0; try SetLength(Screen,Width + 1,Height + 1); for i := 0 to Width do FillChar(Screen[i][0],(Height+1),0); except Exit; end; For I := 0 to Len do Screen[TPA[I].x - Box.x1][TPA[I].y - Box.y1] := True; SetLength(result,1); SetLength(Result[0],Len+1); TotalLen := 0; for I := 0 to Width do begin; for II := 0 to Height do if Screen[I][II]=True then begin; Result[TotalLen][LenRes].x := I + Box.x1; Result[TotalLen][LenRes].y := II + Box.y1; LenRes := LenRes + 1; III := I; end; if LenRes = 0 then III := I else if (I - III) > MinPixels then begin; III := I; SetLength(Result[TotalLen],LenRes); LenRes := 0; TotalLen := TotalLen + 1; SetLength(Result,TotalLen + 1); SetLength(Result[TotalLen],Len + 1); end; end; SetLength(Result[TotalLen],LenRes); end; {/\ Sorts all points in tpa by distance from degree (Deg) and distance from mx and my. \\ Sortup will return closest distance to mx and my first. \\ Distance will be sorted first (RadialWalk style). /\} procedure SortCircleWise(var tpa: TPointArray; const cx, cy, StartDegree: Integer; SortUp, ClockWise: Boolean); const i180Pi = 57.29577951; var i, l, td, sd: Integer; Dist, Deg: TIntegerArray; begin l := Length(tpa); if (l = 0) then Exit; sd := StartDegree; while (sd > 360) do sd := (sd - 360); sd := (360 - sd); SetLength(Dist, l); SetLength(Deg, l); for i := 0 to l -1 do Dist[i] := Round(Hypot(tpa[i].x - cx, tpa[i].y - cy)); QuickTPASort(Dist, tpa, 0, l -1, SortUp); if (l = 1) then Exit; for i := 0 to l -1 do begin td := Round(ArcTan2(tpa[i].y - cy, tpa[i].x - cx) * i180Pi) + 90; if (td < 0) then td := td + 360; if ClockWise then Deg[i] := Round(sd + td) mod 360 else Deg[i] := 360 - Round(sd + td) mod 360; end; i := 1; td := 0; Dec(l); while (i < l) do begin while (i < l) and (Abs(Dist[td] - Dist[i]) <= 1) do Inc(i); QuickTPASort(Deg, tpa, td, i, False); Inc(i); td := i; end; if (td < l) then QuickTPASort(Deg, tpa, td, l, False); end; {/\ Sorts all points in tpa by distance from degree (Deg) and distance from mx and my. \\ Sortup will return closest distance to mx and my first. \\ Degree will be sorted first (LinearWalk style). /\} procedure LinearSort(var tpa: TPointArray; cx, cy, sd: Integer; SortUp: Boolean); const i180Pi = 57.29577951; var i, l, td: Integer; Dist, Deg: TIntegerArray; begin l := Length(tpa); if (l = 0) then Exit; while (sd > 360) do sd := (sd - 360); SetLength(Dist, l); SetLength(Deg, l); for i := 0 to l -1 do begin td := Round(ArcTan2(tpa[i].y - cy, tpa[i].x - cx) * i180Pi) + 90; if (td < 0) then td := td + 360; Deg[i] := Min(Abs(sd - td), Min(Abs(sd - (td + 360)), Abs((sd + 360) - td))) end; QuickTPASort(Deg, tpa, 0, l -1, True); if (l = 1) then Exit; for i := 0 to l -1 do Dist[i] := Round(Hypot(tpa[i].x - cx, tpa[i].y - cy)); i := 1; td := 0; Dec(l); while (i < l) do begin while (i < l) and (Abs(Deg[td] - Deg[i]) <= 3) do Inc(i); QuickTPASort(Dist, tpa, td, i, SortUp); Inc(i); td := i; end; if (td < l) then QuickTPASort(Dist, tpa, td, l, SortUp); end; {/\ Merges the TPointArrays of the T2DPointArray ATPA in to one TPA. /\} Function MergeATPA(const ATPA: T2DPointArray): TPointArray; var I, II, Len, TempL, CurrentL: integer; begin; Len := High(ATPA); if Len < 0 then begin SetLength(Result, 0); Exit; end; CurrentL := 0; For I:= 0 to Len do begin; TempL := High(ATPA[I]); if TempL < 0 then Continue; TempL := Templ + CurrentL + 1; Setlength(Result, TempL+1); For II := CurrentL to TempL do Result[II] := ATPA[I][II - CurrentL]; CurrentL := TempL; end; SetLength(Result,CurrentL); end; procedure AppendTPA(var TPA: TPointArray; const ToAppend: TPointArray); var l,lo,i : integer; begin l := high(ToAppend); lo := length(TPA); setlength(TPA,lo + l + 1); for i := 0 to l do TPA[i + lo] := ToAppend[i]; end; {/\ Returns a TPointArray of a the full given Box. /\} function TPAFromBox(const Box : TBox) : TPointArray; var x, y: integer; l : integer; begin; SetLength(Result, (Box.x2 - Box.x1 + 1) * (Box.y2 - Box.y1 + 1)); l := 0; For x := box.x1 to Box.x2 do for y := box.y1 to box.y2 do begin; Result[l].x := x; Result[l].y := y; inc(l); end; end; {/\ Rotate the given TPA with A radians. /\} Function RotatePoints(Const P: TPointArray; A, cx, cy: Extended): TPointArray ; Var I, L: Integer; CosA,SinA : extended; Begin L := High(P); SetLength(Result, L + 1); CosA := Cos(a); SinA := Sin(a); For I := 0 To L Do Begin Result[I].X := Trunc(cx + CosA * (p[i].x - cx) - SinA * (p[i].y - cy)); Result[I].Y := Trunc(cy + SinA * (p[i].x - cx) + CosA * (p[i].y - cy)); End; // I recon it's faster than Point(). End; {/\ Rotate the given Point with A radians. /\} Function RotatePoint(Const p: TPoint; angle, mx, my: Extended): TPoint; Begin Result.X := Trunc(mx + cos(angle) * (p.x - mx) - sin(angle) * (p.y - my)); Result.Y := Trunc(my + sin(angle) * (p.x - mx) + cos(angle) * (p.y- my)); End; {/\ Returns the edges of the given TPA. /\} function FindTPAEdges(const p: TPointArray): TPointArray; var b: T2DBoolArray; i, x, y, l, c: Integer; Box: TBox; begin SetLength(Result, 0); l := Length(p); if (l = 0) then Exit; Box := GetTPABounds(p); x := (Box.x2 - Box.x1) + 3; y := (Box.y2 - Box.y1) + 3; SetLength(b, x); for i := 0 to x -1 do begin SetLength(b[i], y); FillChar(b[i][0],y,0); end; for i := 0 to l -1 do b[p[i].x +1 - Box.x1][p[i].y +1 - Box.y1] := True; SetLength(Result, l); c := 0; for i := 0 to l -1 do begin x := -1; while (x <= 1) do begin for y := -1 to 1 do try if not b[p[i].x + 1 + x - Box.x1][p[i].y + 1 + y - Box.y1] then begin Result[c] := p[i]; Inc(c); x := 2; Break; end; except end; Inc(x); end; end; SetLength(Result, c); end; {/\ Results true if a point is in a TPointArray. Notes: In actuallys means IN the array, not in the box shaped by the array. /\} function PointInTPA(const p: TPoint;const arP: TPointArray): Boolean; var i, l: Integer; begin l := High(arP); if l < 0 then Exit(false); Result := True; for i := 0 to l do if (arP[i].x = p.x) and (arP[i].y = p.y) then Exit; Result := False; end; {/\ Removes the given ClearPoints from arP. /\} function ClearTPAFromTPA(const arP, ClearPoints: TPointArray): TPointArray; var i, j, l, l2: Integer; Found: Boolean; begin Setlength(result,0); l := High(arP); l2 := High(ClearPoints); for i := 0 to l do begin Found := false; for j := 0 to l2 do if (arP[i].x = ClearPoints[j].x) and (arP[i].y = ClearPoints[j].y) then begin Found := True; Break; end; if not found then // if (j = l2 + 1) then begin SetLength(Result, Length(Result) + 1); Result[High(Result)] := arP[i]; end; end; end; {/\ Removes all the doubles point from a TPA. /\} procedure ClearDoubleTPA(var TPA: TPointArray); var I, II, L: Integer; Swappie: TPoint; begin L := High(TPA); for I := 0 To L Do for II := I + 1 To L Do if ((TPA[I].X = TPA[II].X) And (TPA[I].Y = TPA[II].Y)) then begin Swappie := TPA[L]; TPA[L] := TPA[II]; TPA[II] := Swappie; L := L - 1; end; SetLength(TPA, L + 1); end; {/\ Uses Box to define an area around TotalTPA. Every point that is not in TotalTPA, but is in Box, is added to the Result. \\ This can be very handy if you want for example, can get all the colors of the background, but not of the actual object. \\ If you pass this all the colors of the background, it will returns the points of the object. /\} Function ReturnPointsNotInTPA(Const TotalTPA: TPointArray; const Box: TBox): TPointArray; var x, y, w, h, i, l: integer; B: T2DBoolArray; begin; w := Box.x2 - Box.x1; h := Box.y2 - Box.y1; if (w = 0) and (h = 0) then Exit; SetLength(b, w + 1, h + 1); for i := w downto 0 do FillChar(b[i][0],h+1,0); l := High(TotalTPA); x := 0; for i := 0 to l do if ((TotalTPA[i].x >= Box.x1) and (TotalTPA[i].x <= Box.x2) and (TotalTPA[i].y >= Box.y1) and (TotalTPA[i].y <= Box.y2)) then begin; Inc(x); B[TotalTPA[i].x-Box.x1][TotalTPA[i].y-Box.y1] := True; end; if x = 0 then Exit; SetLength(result,(w + 1) * (h + 1) - x); i := 0; for x := 0 to w do for y := 0 to h do if not B[x][y] then try Result[i].x := x + Box.x1; Result[i].y := y + Box.y1; Inc(i); except end; SetLength(b, 0); SetLength(Result, i); end; {/\ Sorts a TPointArray by either X or Y. You have to define the max Point as well. /\} Procedure TPACountSort(Var TPA: TPointArray;const max: TPoint;Const SortOnX : Boolean); Var c: T2DIntegerArray; I, II, III, hTPA, cc: Integer; Begin hTPA := High(TPA); if hTPA < 1 then Exit; SetLength(c, max.X + 1,max.Y + 1); for i := max.x downto 0 do FillChar(c[i][0],(max.y+1)*sizeof(Integer),0); For I := 0 To hTPA Do c[TPA[I].x][TPA[I].y] := c[TPA[i].x][TPA[i].y] + 1; cc := 0; if SortOnX then begin For I := 0 To max.X Do For II := 0 To max.Y Do Begin For III := 0 To c[I][II] - 1 Do Begin TPA[cc].x := I; TPA[cc].y := II; cc := cc + 1; End; End; end else begin; For II := 0 To max.Y Do For I := 0 To max.X Do Begin For III := 0 To c[I][II] - 1 Do Begin TPA[cc].x := I; TPA[cc].y := II; cc := cc + 1; End; End; end; End; {/\ Sorts a TPointArray by either X or Y. Allows one to pass a Base. /\} Procedure TPACountSortBase(Var TPA: TPointArray;const maxx, base: TPoint; const SortOnX : Boolean); Var c: T2DIntegerArray; I, II, III, hTPA, cc: Integer; Max : TPoint; Begin hTPA := High(TPA); if hTPA < 1 then Exit; max.X := maxx.X - base.X; max.Y := maxx.Y - base.Y; SetLength(c, max.X + 1,max.Y + 1); for i := max.x downto 0 do FillChar(c[i][0],(max.y+1)*sizeof(integer),0); hTPA := High(TPA); For I := 0 To hTPA Do c[TPA[I].x - base.X][TPA[I].y - base.Y] := c[TPA[i].x- base.X][TPA[i].y- base.Y] + 1; cc := 0; if SortOnX then begin For I := 0 To max.X Do For II := 0 To max.Y Do Begin For III := 0 To c[I][II] - 1 Do Begin TPA[cc].x := I + base.X; TPA[cc].y := II + base.Y; cc := cc + 1; End; End; end else begin; For II := 0 To max.Y Do For I := 0 To max.X Do Begin For III := 0 To c[I][II] - 1 Do Begin TPA[cc].x := I + base.X; TPA[cc].y := II + base.Y; cc := cc + 1; End; End; end; End; {/\ Returns the sum of all integers in the array /\} function SumIntegerArray(const Ints : TIntegerArray): Integer; var I, H: Integer; begin Result := 0; H := High(Ints); for I := 0 to H do Result := Result + Ints[I]; end; {/\ Inverts the IntegerArray, last becomes first etc.. /\} procedure InvertTIA(var tI: TIntegerArray); var Temp: TIntegerArray; i, h: Integer; begin h := High(tI); Temp := tI; for i := 0 to h do tI[i] := Temp[h - i]; end; {/\ Results the Average of an IntegerArray /\} function AverageTIA(const tI: TIntegerArray): Integer; begin try Result := (SumIntegerArray(tI) div Length(tI)); except Result := 0; end; end; {/\ Results the Average of an ExtendedArray /\} function AverageExtended(const tE: TExtendedArray): Extended; var i, h: Integer; begin Result := 1; try h := High(tE); for i := 0 to h do Result := (Result * tE[i]); Result := Power(Result, 1/(h + 1)); except Result := 0.0; end; end; {/\ Returns true if the two inputed TPA's are exactly the same (so the order matters) /\} function SameTPA(const aTPA, bTPA: TPointArray): Boolean; var I: LongInt; h : integer; begin Result := False; if (Length(aTPA) <> Length(bTPA)) then Exit; h := high(ATPA); for I := Low(aTPA) to h do if ((aTPA[I].X <> bTPA[I].X) or (aTPA[I].Y <> bTPA[I].Y)) then Exit; Result := True; end; {/\ Returns true if the TPA is found as one of ATPA's sub-TPA's.. And again, order matters /\} function TPAInATPA(const TPA: TPointArray;const InATPA: T2DPointArray; var Index: LongInt): Boolean; var I: LongInt; h : integer; begin Result := True; h := high(inATPA); for I := Low(InATPA) to h do if (SameTPA(TPA, InATPA[I])) then begin Index := I; Exit; end; Result := False; end; procedure OffsetTPA(var TPA: TPointArray; const Offset: TPoint); var i : integer; begin for i := high(TPA) downto 0 do begin; inc(TPA[i].x,offset.x); inc(TPA[i].y,offset.y); end; end; procedure OffsetATPA(var ATPA: T2DPointArray; const Offset: TPoint); var i : integer; begin for i := high(ATPA) downto 0 do OffsetTPA(ATPA[i],Offset); end; end.