moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-28 12:02:15 -05:00
Code Issues Releases Wiki Activity
18968899ba
Simba/Units/MMLCore/tpa.pas
Niels 4ba71fb94f Fixed InvertTIA
2010-06-21 20:46:08 +02:00

2135 lines
53 KiB
ObjectPascal
Raw Blame History

{
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 <http://www.gnu.org/licenses/>.
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 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,mmath;
{/\
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,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;
PointsToFill[TempTPA[i].x][TempTPA[i].y] := false;
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 := Copy(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.
Reference in New Issue View Git Blame Copy Permalink