SRL Archive - SRL Snippets

function FindColoredAreaMulti(): array of TPointArray


Runaway

2012-05-28 11:00:02

This is an idea I had when I was trying to make a script that handled doors. The gist behind the function is that it will search for multiple colors, and then sort the points into a partitioned box; with each color having it's own partition. This is really confusing to explain with words, so here's a picture (with relative variables) to help explain:


Colors := [11111, 22222, 33333];
Size := [5, 10, 5];
Width := 20;
Height := 10;
Vertical := False;

Arr := FindColoredAreaMulti(Colors, Size, MinCount, Tol, Width, Height, Vertical, True, FilterArr, TrimArr, SortFrom, Area[0], Area[1], Area[2], Area[3]);


Width
|=====|==========|=====|
| | | |
| | | | Height
| | | |
|=====|==========|=====|
Size[0] Size[1] Size[2]
Color[0] Color[1] Color[2]
Result[0] Result[1] Result[2]

^ The function will search for a scenario in which the colors and sizes match up like so. Since Vertical is false, the partitions (Size[0..2]) are aligned horizontally. The MinCount specifies how many points of the corresponding color must be found in each partition. The result array stores the TPA of each partition as it's corresponding color/size.

I have posted this function here because it works occasionally, but for the most part it doesn't work as well as I wish it could. I am abandoning this project because I can no longer debug this without getting frustrated. To work to it's full potential it needs alot of time, and that is it's downfall. It can take up to 5000 ms to procure a proper result, and that isn't worth it in my opinion.

Descripton:

(*
FindColoredAreaMulti
~~~~~~~

.. code-block:: pascal

function FindColoredAreaMulti(Colors, Size: TIntegerArray; MinCount, Tol, w, h: Integer; Vertical, Strict: Boolean; Filter, Trim: Integer; SortFrom: TPoint; x1, y1, x2, y2: Integer): array of TPointArray;

Results an array of TPointArray which holds a TPA of the partitioned, specified colors
in each TPointArray. It can search for an unlimited number of colors in x1, y1, x2, y2.
* Colors: The colors to be searched for; must be in the same order as size.
* Size: The respective width/height of each box partition.
* MinCount: The least number of points in each box partition.
* Tol: The tolerance on each color.
* w, h: The total width/height of the box to find.
* Vertical: True to align the box partitions vertically; False for horizontally.
* Strict: True to exit the function if not all of the specified colors are found.
* Filter: The maximum distance between SortFrom and each TPoint. -1 to not use.
* Trim: The maximum length of each TPointArray. -1 to not use.
* SortFrom: The point to sort each TPoint from.

.. note::

by Runaway

Example:

.. code-block:: pascal

Colors := [16514558, 5062187, 4664874];
Size := [5, 10, 5];
Width := 20;
Height := 10;
Vertical := False;

Arr := FindColoredAreaMulti(Colors, Size, MinCount, Tol, Width, Height, Vertical, True, FilterArr, TrimArr, SortFrom, Area[0], Area[1], Area[2], Area[3]);
for i := 0 to High(Arr) do
begin
x := MiddleTPA(Arr[i]).x;
y := MiddleTPA(Arr[i]).y;
Mouse(x, y, 3, 3, mouse_left);
if DidClick(True, 1000) then
Break;
end;
*)

Function:

function FindColoredAreaMulti(Colors, Size: TIntegerArray; MinCount, Tol, w, h: Integer; Vertical, Strict: Boolean; Filter, Trim: Integer; SortFrom: TPoint; x1, y1, x2, y2: Integer): array of TPointArray;
var
TPA, Found, Temp: TPointArray;
aPoints: array of TPointArray;
Matched, iZero: TBooleanArray;
hColors, hMatched, hPoints, hiPoints, hTemp, lResult: Integer;
Error, Len, Res, MaxRes, MaxDist, Match, Count, Time: Integer;
t, x, y, c, i, ii: Integer;
Width, Height: Integer;
Dist, Prev: TPoint;
iRes: Boolean;
begin
MarkTime(t);
Time := Length(Colors);
SetLength(aPoints, Length(Colors));
Error := 0;
hColors := High(Colors);
Freeze;
for c := 0 to hColors do
begin
if (FindColorsTolerance(TPA, Colors[c], x1, y1, x2, y2, Tol)) then
begin
SortTPAFrom(TPA, SortFrom);
if (Filter <> -1) then
FilterPointsDist(TPA, 0, Filter, SortFrom.x, SortFrom.y);
if (Trim <> -1) and (Length(TPA) > Trim) then
SetLength(TPA, Trim);
aPoints[c - Error] := TPA;
end else
begin
if Strict then
begin
Writeln('Error: not enough colors found!');
Exit;
end;
Len := Length(aPoints) - 1;
SetLength(aPoints, Len);
Inc(Error);
end;
if (Error >= hColors) then
begin
Writeln('Error: not enough colors found!');
Exit;
end;
end;
UnFreeze;
SetLength(Result, Length(aPoints));
SetLength(Matched, Length(aPoints));
SetLength(iZero, 3);
Prev := Point(0, 0);
iRes := False;
Res := 0;
hMatched := High(Matched);
hPoints := High(aPoints);
repeat
i := 0;
repeat
if Matched[i] then
begin
Matched[i] := False;
Inc(i);
end;
Matched[i] := False;
if (i < 1) then
begin
iZero[0] := True;
iZero[1] := False;
Count := 1;
end else
begin
iZero[0] := False;
iZero[1] := True;
Count := 0;
end;
if iZero[0] then
Prev := Point(0, 0);
Height := h;
Width := w;
if Vertical then
begin
Height := Size[i];
if iZero[1] then
Prev := Point(Prev.x, Prev.y + Size[i - 1]);
end else
begin
Width := Size[i];
if iZero[1] then
Prev := Point(Prev.x + Size[i - 1], Prev.y);
end;
repeat
SetLength(Found, MinCount);
Temp := [];
AppendTPA(Temp, aPoints[i]);
if (Width > Height) then
MaxDist := Width + 20
else
MaxDist := Height + 20;
FilterPointsDist(Temp, 0, MaxDist, (aPoints[0][Res].x + Prev.x), (aPoints[0][Res].y + Prev.y));
hTemp := High(Temp);
if iRes then
begin
Inc(Res);
iRes := False;
end;
iZero[2] := True;
Match := 0;
hiPoints := High(aPoints[i]);
for ii := 0 to hiPoints do
begin
if (hTemp < 0) then
Break;
if (ii >= hTemp) then
Break;
if (iZero[0] and iZero[2]) then
begin
iZero[2] := False;
ii := Res;
Continue;
end;
Dist := Point(Temp[ii].x - aPoints[0][Res].x, Temp[ii].y - aPoints[0][Res].y);
x := (Dist.x + Prev.x);
y := (Dist.y + Prev.y);
if ((x >= Prev.x) and (x <= (Width + Prev.x)) and (y >= Prev.y) and (y <= (Height + Prev.y))) then
begin
if ((Match + Count) >= MinCount) then
begin
Matched[i] := True;
Result[i] := Found;
Found := [];
Break;
end;
if iZero[0] then
begin
Found[0] := Point(aPoints[0][Res].x, aPoints[0][Res].y);
Inc(Match);
Found[Match] := Point(aPoints[i][ii].x, aPoints[i][ii].y);
end else
begin
Found[Match] := Point(aPoints[i][ii].x, aPoints[i][ii].y);
Inc(Match);
end;
end;
end;
MaxRes := (hTemp - 1);
if Matched[i] then
begin
Break;
end else
begin
if iZero[0] then
iRes := True;
end;
if (iZero[1] and (not Matched[i])) then
begin
iRes := True;
Break;
end;
if (MaxRes < MinCount) then
Break;
until(((Res >= MaxRes) and iZero[0]) or (TimeFromMark(t) > Time * 1000));
if ((Res >= MaxRes) and iZero[0]) then
begin
Writeln('Error: not enough points for color[0] to meet mincount!');
Break;
end;
if (iZero[1] and (not Matched[i])) then
Break;
until((i >= hPoints) or (TimeFromMark(t) > Time * 1000));
if Matched[hMatched] then
Break;
until(((Res >= MaxRes) and iZero[0]) or (TimeFromMark(t) > Time * 1000));
lResult := 0;
for i := 0 to hPoints do
begin
if (Length(Result[i]) > 0) then
Inc(lResult);
end;
Writeln('Took: '+IntToStr(TimeFromMark(t))+' ms, found '+IntToStr(lResult)+' of '+IntToStr(Length(Result))+' boxes');
end;

I've attached a version with debug/paint if you want to have a go at this yourself.