CynicRus
2013-02-27 02:17:15
Hello everyone! Today Wizzup sent me a BoxPlugin source code. I converted it to Lazarus+FPC+MufasaBitmap and as Simba script. Here I put both versions, I hope you can find a use for this code.
As script:
As unit:
As script:
//BoxPlugin.dpr
//Converted to Simba and Lazarus by Cynic
const
W = 179;
H = 179;
var
a, c: array[0..W] of array [0..H] of Integer;
b: array[0..W] of array [0..H] of Boolean;
xs, ys, xe, ye: integer;
area: integer;
color, newcolor: integer;
dx: array[0..7] of ShortInt;
dy: array[0..7] of ShortInt;
procedure dfs1(x, y: Integer);
var
d: Integer;
begin
inc(area);
b[x][y] := True;
for d := 0 to 7 do
if (x + dx[d] >= 0) and (y + dy[d] >= 0) and (x + dx[d] <= W) and (y + dy[d] <= H) then
if (a[x + dx[d]][ y + dy[d]] = color) and (not b[x + dx[d]][ y + dy[d]]) then
dfs1(x + dx[d], y + dy[d]);
a[x][y] := newcolor;
end;
procedure dfs(x, y: Integer);
var
d: Integer;
begin
inc(area);
b[x][y] := True;
for d := 0 to 3 do
if (x + dx[d] >= 0) and (y + dy[d] >= 0) and (x + dx[d] <= W) and (y + dy[d] <= H) then
if (a[x + dx[d]][ y + dy[d]] = color) and (not b[x + dx[d]][ y + dy[d]]) then
dfs(x + dx[d], y + dy[d]);
a[x][y] := newcolor;
end;
function GoodColor(col: integer): boolean;
begin
if ((col > 12000000) and (col < 13000000)) or ((col > 16000000) and (col < 17000000)) then
result := true
else
result := false;
end;
function Simplify: boolean;
var
i, j: integer;
x, y: integer;
max, col: integer;
begin
max := 0;
area := 0;
c := a;
for i := 0 to W do
for j := 0 to H do begin
if (not b[i][j]) and GoodColor(a[i][j]) then begin
area := 0;
color := a[i][j];
newcolor := color;
dfs(i, j);
end;
if (area > max) then begin
max := area;
col := color;
x := i;
y := j;
end;
end;
result := false;
if max < 40 then exit;
result := true;
// FillChar(b, SizeOf(b), 0);
color := a[x][y];
newcolor := clRed;
dfs(x, y);
newcolor := 0;
for i := 0 to W do
for j := 0 to H do
if not b[i][j] then begin
color := a[i][j];
dfs(i, j);
end;
color := 0;
// FillChar(b, SizeOf(b), 0);
dfs(0, 0);
area := max;
for i := 0 to W do
for j := 0 to H do
if not b[i][j] then begin
if a[i][j] = 0 then
inc(area);
a[i][j] := clred;
if c[i][j] <> col then
c[i][j] := clred
else
c[i][j] := 0;
end
else
c[i][j] := 0;
xs := W; ys := H; ye := 0; xe := 0;
for i := 0 to W do
for j := 0 to H do
if not b[i][j] then begin
if xs > i then xs := i;
if ys > j then ys := j;
if xe < i then xe := i;
if ye < j then ye := j;
end;
decex(xs, 1); decex(ys, 1); incex(xe, 1); incex(ye, 1);
end;
function GetShape: string;
var
i, j, ii, jj, d: integer;
more, less: integer;
max, min: integer;
d1, d2: extended;
x, y: integer;
vertexes: integer;
begin
// FillChar(b, SizeOf(b), 0);
//Getting the center of the shape
x := 0;
y := 0;
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clred then begin
x := x + i;
y := y + j;
end;
x := x div area;
y := y div area;
a[x][y] := clGreen;
//Painting the border in white
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clred then
for d := 0 to 3 do
if a[i + dx[d]][ j + dy[d]] = 0 then
a[i][j] := clwhite;
d := 30;
max := 0;
min := 1000000;
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clwhite then begin
more := 0;
less := 0;
//For each point of the border, checking how many points of the border
//in a circle with radius d are closer to center and how much are
//further
d1 := sqrt(sqr(i - x) + sqr(j - y));
for ii := -d to d do
for jj := -d to d do
if (ii * ii + jj * jj < d * d) and (a[i+ii][j+jj]=clwhite) then begin
d2 := sqrt(sqr(ii + i - x) + sqr(jj + j - y));
if d1 - d2 > 3 then
inc(less)
else if d1 - d2 < -3 then
inc(more);
end;
if more - less > max then
max := more - less;
if more - less < min then
min := more - less;
end;
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clwhite then begin
more := 0;
less := 0;
d1 := sqrt(sqr(i - x) + sqr(j - y));
for ii := -d to d do
for jj := -d to d do
if (ii * ii + jj * jj < d * d) and (a[i+ii][j+jj] = clwhite) then begin
d2 := sqrt(sqr(ii + i - x) + sqr(jj + j - y));
if d1 - d2 > 3 then
inc(less)
else if d1 - d2 < -3 then
inc(more)
end;
if more - less < -10 then
a[i][j] := clpurple;
end;
// fillchar(b,sizeof(b),0);
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clpurple then
for d := 0 to 7 do
b[i + dx[d]][j + dy[d]] := true;
for i := xs to xe do
for j := ys to ye do
if b[i][j] then
a[i][j] := clpurple;
if max > 80 then begin
result := 'Star';
exit;
end;
if min > -20 then begin
result := 'Circle';
exit;
end;
//Counting how much vertexes we have...
// fillchar(b, sizeof(b), 0);
color := clpurple;
newcolor := clpurple;
vertexes := 0;
for i := xs to xe do
for j := ys to ye do
if (a[i][j] = clpurple) and (not b[i][j]) then begin
area := 0;
dfs1(i, j);
if area > 36 then
inc(vertexes);
end;
case vertexes of
3: result := 'Triangle';
4: result := 'Square';
5: result := 'Pentagon'
else
result := 'Circle';
end;
end;
procedure count(var inside, outside: integer; x1, y1, x2, y2: integer);
var
x, y, dx, dy, d, d1: extended;
begin
inside := 0;
outside := 0;
// fillchar(b, sizeof(b), 0);
d := sqrt(sqr(x1 - x2) + sqr(y1 - y2));
dx := (x2 - x1)/d;
dy := (y2 - y1)/d;
x := x1;
y := y1;
x2 := round(x);
y2 := round(y);
repeat
if not b[x2][y2] then begin
b[x2][y2] := true;
if a[x2][y2] = 0 then
inc(outside)
else
inc(inside);
end;
x := x + dx;
y := y + dy;
// a[x2, y2] := clwhite;
x2 := round(x);
y2 := round(y);
d1 := sqrt(sqr(x - x1) + sqr(y - y1));
until d1 > d;
end;
procedure dfs2(x, y, xs, ys, dist: Integer);
var
d: Integer;
begin
if sqrt(sqr(x - xs) + sqr(y - ys)) > dist then begin
b[x][y] := True;
exit;
end;
inc(area);
b[x][ y] := True;
for d := 0 to 3 do
if (x + dx[d] >= 0) and (y + dy[d] >= 0) and (x + dx[d] <= W) and (y + dy[d] <= H) then
if ((a[x + dx[d]][y + dy[d]] = color) or (a[x + dx[d]][y + dy[d]] = clwhite)) and (not b[x + dx[d]][y + dy[d]]) then
dfs2(x + dx[d], y + dy[d], xs, ys, dist);
end;
procedure dfs3(x, y, xs, ys, dist: Integer);
var
d: Integer;
begin
if sqrt(sqr(x - xs) + sqr(y - ys)) > dist then begin
b[x][ y] := True;
exit;
end;
inc(area);
b[x][y] := True;
for d := 0 to 3 do
if (x + dx[d] >= 0) and (y + dy[d] >= 0) and (x + dx[d] <= W) and (y + dy[d] <= H) then
if not b[x + dx[d]][ y + dy[d]] then
dfs3(x + dx[d], y + dy[d], xs, ys, dist);
end;
function GetNumber: integer;
var
i, j, parts, d, holes: integer;
i1, j1: integer;
x, y, xp, yp, xh, yh: integer;
inside, outside: integer;
max: extended;
_1or7: boolean;
begin
a := c;
// fillchar(b, sizeof(b), 0);
color := clred;
newcolor := clred;
parts := 0;
for i := xs to xe do
for j := ys to ye do
if (a[i][j] = clred) and (not b[i][j]) then begin
area := 0;
dfs(i, j);
if area < 4 then
c[i][j] := 1
else begin
if area > 40 then begin
x := i;
y := j;
end
else begin
xp := i;
yp := j;
end;
inc(parts);
end;
end;
if parts = 0 then begin
result := -1;
exit;
end;
//fillchar(b, sizeof(b), 0);
newcolor := 0;
for i := xs to xe do
for j := ys to ye do
if c[i][j] = 1 then
dfs(i, j);
xs := W; ys := H; ye := 0; xe := 0;
for i := 0 to W do
for j := 0 to H do
if a[i][j] = clred then begin
if xs > i then xs := i;
if ys > j then ys := j;
if xe < i then xe := i;
if ye < j then ye := j;
end;
decex(xs, 3); decex(ys, 3); incex(xe, 3); incex(ye, 3);
// fillchar(b,sizeof(b), 0);
newcolor := 0;
if parts > 1 then begin
area := 0;
dfs(xp, yp);
xp := 0; yp := 0;
for i := xs to xe do
for j := ys to ye do
if b[i][j] then begin
incex(xp, i);
incex(yp, j);
b[i][j] := false;
end;
xp := xp div area;
yp := yp div area;
a[xp][yp] := clgreen;
end;
// fillchar(c, sizeof(c), 0);
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clred then begin
c[i][j] := clred;
for d := 0 to 3 do
c[i + dx[d]][j + dy[d]] := clred;
end;
a := c;
// fillchar(c, sizeof(c), 0);
if parts > 1 then
a[xp][ yp] := clgreen;
color := 0;
newcolor := 0;
dfs(0, 0);
holes := 0;
for i := xs to xe do
for j := ys to ye do
if (a[i][j] = 0) and (not b[i][j]) then begin
area := 0;
dfs1(i, j);
if area > 1 then begin
inc(holes);
xh := i;
yh := j;
end
else
c[i][j] := 1;
end;
result := -1;
if holes >= 2 then begin
result := 8;
exit;
end;
//0, 4, 6 or 9
if holes = 1 then begin
// fillchar(b, sizeof(b), 0);
area := 0;
dfs1(xh, yh);
xh := 0; yh := 0;
for i := xs to xe do
for j := ys to ye do
if b[i][j] then begin
incex(xh, i);
incex(yh, j);
b[i][j] := false;
end;
xh := xh div area;
yh := yh div area;
a[xh][yh] := clgreen;
if parts > 1 then begin //6 or 9
max := 0;
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clred then
if max < sqrt(sqr(xp - i) + sqr(yp - j)) then
max := sqrt(sqr(xp - i) + sqr(yp - j));
if sqrt(sqr(xh - xp) + sqr(yh - yp)) < max/2 then
result := 6
else
result := 9;
exit;
end;
//now 0 or 4
if area > 10 then
result := 0
else
result := 4;
exit;
end;
if parts > 1 then begin
result := 9;
exit;
end;
//here goes 1, 2, 3, 5, 7
//separating 1 and 7 from other numbers
max := 0;
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clred then
for i1 := xs to xe do
for j1 := ys to ye do
if a[i1][j1] = clred then
if sqrt(sqr(i1 - i) + sqr(j1 - j)) > max then begin
max := sqrt(sqr(i1 - i) + sqr(j1 - j));
x := i;
y := j;
xp := i1;
yp := j1;
end;
count(inside, outside, x, y, xp, yp);
if outside = 0 then
_1or7 := true
else
_1or7 := false;
for i := xs to xe do
for j := ys to ye do
if a[i][j] = 0 then
for d := 0 to 3 do
if a[i + dx[d]][ j + dy[d]] = clred then begin
a[i][j] := clwhite;
break;
end;
d := 10;
color := 0;
// fillchar(c, sizeof(c), 0);
for i := xs to xe do
for j := ys to ye do
if a[i][j] = clwhite then begin
for i1 := i - d - 1 to i + d + 1 do
for j1 := j - d - 1 to j + d + 1 do
b[i][j] := false;
dfs2(i, j, i, j, d);
area := 0;
dfs3(i, j, i, j, d);
if area < 100 then
c[i][j] := clpurple
end;
// fillchar(b,sizeof(b),0);
for i := xs to xe do
for j := ys to ye do
if c[i][j] = clpurple then begin
a[i][j] := clpurple;
for d := 0 to 7 do
b[i + dx[d]][ j + dy[d]] := true;
end;
for i := xs to xe do
for j := ys to ye do
if b[i][j] then
a[i][j] := clpurple;
// fillchar(b, sizeof(b), 0);
parts := 0;
outside := 0;
color := clpurple;
newcolor := clpurple;
for i := xs to xe do
for j := ys to ye do
if (a[i][j] = clpurple) and (not b[i][j]) then begin
area := 0;
dfs1(i, j);
inc(outside);
if area > 15 then
inc(parts);
end;
if _1or7 then
if parts <= 2 then
result := 1
else
result := 7
else
if outside >= 5 then
result := 5
else if parts = 3 then
result := 2
else if parts = 2 then
result := 3;
{ result := parts + 1000*outside;}
end;
procedure initVars();
begin
dx:= [0,-1, 0, 1, -1, 1, 1, -1];
dy:= [-1, 0, 1, 0, 1, -1, 1, -1];
end;
procedure ProcessPicture(var BMP:TMufasaBitmap; var shape: string; var number: Integer; debug: Integer);
var
i, j : Integer;
begin
initVars;
for i := 0 to W do
for j := 0 to H do
a[i][j] := BMP.FastGetPixel(i,j);
//First, lets find the largest area of one color, thats close to white
//this should be our shape to recognize
//we will also fill the spaces inside the shape
if not Simplify then begin
shape := 'unknown';
number := -1;
exit;
end;
//Now, recognizing the shape :)
shape := GetShape;
if (debug = 1) or (debug = 3) then
for i := 0 to W do
for j := 0 to H do
BMP.FastSetPixel(i,j,a[i][j]);
number := GetNumber;
if debug = 2 then
for i := 0 to W do
for j := 0 to H do
BMP.FastSetPixel(i,j,a[i][j]);
if debug = 3 then
for i := 0 to W do
for j := 0 to H do
if a[i][ j] <> 0 then
BMP.FastSetPixel(i,j,not a[i][j]);
end;
begin
end.
As unit:
unit boxplugin;
{$mode objfpc}{$H+}
{$macro on}
{$define callconv:=
{$IFDEF WINDOWS}{$IFDEF CPU32}cdecl;{$ELSE}{$ENDIF}{$ENDIF}
{$IFDEF LINUX}{$IFDEF CPU32}cdecl;{$ELSE}{$ENDIF}{$ENDIF}
}
interface
uses
Classes, SysUtils,Graphics,Math,Bitmaps,MufasaTypes;
const
dx: array[0..7] of ShortInt = (0, -1, 0, 1, -1, 1, 1, -1);
dy: array[0..7] of ShortInt = (-1, 0, 1, 0, 1, -1, 1, -1);
W = 179;
H = 179;
var
a, c: array[0..W, 0..H] of Integer;
b: array[0..W, 0..H] of Boolean;
xs, ys, xe, ye: integer;
area: integer;
color, newcolor: integer;
procedure ProcessPicture(var BMP:TMufasaBitmap; var shape: string; var number: Integer; debug: Integer); callconv
implementation
procedure dfs1(x, y: Integer);
var
d: Integer;
begin
inc(area);
b[x, y] := True;
for d := 0 to 7 do
if (x + dx[d] >= 0) and (y + dy[d] >= 0) and (x + dx[d] <= W) and (y + dy[d] <= H) then
if (a[x + dx[d], y + dy[d]] = color) and (not b[x + dx[d], y + dy[d]]) then
dfs1(x + dx[d], y + dy[d]);
a[x, y] := newcolor;
end;
procedure dfs(x, y: Integer);
var
d: Integer;
begin
inc(area);
b[x, y] := True;
for d := 0 to 3 do
if (x + dx[d] >= 0) and (y + dy[d] >= 0) and (x + dx[d] <= W) and (y + dy[d] <= H) then
if (a[x + dx[d], y + dy[d]] = color) and (not b[x + dx[d], y + dy[d]]) then
dfs(x + dx[d], y + dy[d]);
a[x, y] := newcolor;
end;
function GoodColor(col: integer): boolean;
begin
if ((col > 12000000) and (col < 13000000)) or ((col > 16000000) and (col < 17000000)) then
result := true
else
result := false;
end;
function Simplify: boolean;
var
i, j: integer;
x, y: integer;
max, col: integer;
begin
max := 0;
area := 0;
c := a;
for i := 0 to W do
for j := 0 to H do begin
if (not b[i, j]) and GoodColor(a[i, j]) then begin
area := 0;
color := a[i, j];
newcolor := color;
dfs(i, j);
end;
if (area > max) then begin
max := area;
col := color;
x := i;
y := j;
end;
end;
result := false;
if max < 40 then exit;
result := true;
FillChar(b, SizeOf(b), 0);
color := a[x, y];
newcolor := clRed;
dfs(x, y);
newcolor := 0;
for i := 0 to W do
for j := 0 to H do
if not b[i, j] then begin
color := a[i, j];
dfs(i, j);
end;
color := 0;
FillChar(b, SizeOf(b), 0);
dfs(0, 0);
area := max;
for i := 0 to W do
for j := 0 to H do
if not b[i, j] then begin
if a[i, j] = 0 then
inc(area);
a[i, j] := clred;
if c[i, j] <> col then
c[i, j] := clred
else
c[i, j] := 0;
end
else
c[i, j] := 0;
xs := W; ys := H; ye := 0; xe := 0;
for i := 0 to W do
for j := 0 to H do
if not b[i, j] then begin
if xs > i then xs := i;
if ys > j then ys := j;
if xe < i then xe := i;
if ye < j then ye := j;
end;
dec(xs, 1); dec(ys, 1); inc(xe, 1); inc(ye, 1);
end;
function GetShape: string;
var
i, j, ii, jj, d: integer;
more, less: integer;
max, min: integer;
d1, d2: extended;
x, y: integer;
vertexes: integer;
begin
FillChar(b, SizeOf(b), 0);
//Getting the center of the shape
x := 0;
y := 0;
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clred then begin
x := x + i;
y := y + j;
end;
x := x div area;
y := y div area;
a[x, y] := clGreen;
//Painting the border in white
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clred then
for d := 0 to 3 do
if a[i + dx[d], j + dy[d]] = 0 then
a[i, j] := clwhite;
d := 30;
max := 0;
min := 1000000;
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clwhite then begin
more := 0;
less := 0;
//For each point of the border, checking how many points of the border
//in a circle with radius d are closer to center and how much are
//further
d1 := sqrt(sqr(i - x) + sqr(j - y));
for ii := -d to d do
for jj := -d to d do
if (ii * ii + jj * jj < d * d) and (a[i+ii,j+jj]=clwhite) then begin
d2 := sqrt(sqr(ii + i - x) + sqr(jj + j - y));
if d1 - d2 > 3 then
inc(less)
else if d1 - d2 < -3 then
inc(more);
end;
if more - less > max then
max := more - less;
if more - less < min then
min := more - less;
end;
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clwhite then begin
more := 0;
less := 0;
d1 := sqrt(sqr(i - x) + sqr(j - y));
for ii := -d to d do
for jj := -d to d do
if (ii * ii + jj * jj < d * d) and (a[i+ii, j+jj] = clwhite) then begin
d2 := sqrt(sqr(ii + i - x) + sqr(jj + j - y));
if d1 - d2 > 3 then
inc(less)
else if d1 - d2 < -3 then
inc(more)
end;
if more - less < -10 then
a[i, j] := clpurple;
end;
fillchar(b,sizeof(b),0);
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clpurple then
for d := 0 to 7 do
b[i + dx[d], j + dy[d]] := true;
for i := xs to xe do
for j := ys to ye do
if b[i, j] then
a[i, j] := clpurple;
if max > 80 then begin
result := 'Star';
exit;
end;
if min > -20 then begin
result := 'Circle';
exit;
end;
//Counting how much vertexes we have...
fillchar(b, sizeof(b), 0);
color := clpurple;
newcolor := clpurple;
vertexes := 0;
for i := xs to xe do
for j := ys to ye do
if (a[i, j] = clpurple) and (not b[i, j]) then begin
area := 0;
dfs1(i, j);
if area > 36 then
inc(vertexes);
end;
case vertexes of
3: result := 'Triangle';
4: result := 'Square';
5: result := 'Pentagon'
else
result := 'Circle';
end;
end;
procedure count(var inside, outside: integer; x1, y1, x2, y2: integer);
var
x, y, dx, dy, d, d1: extended;
begin
inside := 0;
outside := 0;
fillchar(b, sizeof(b), 0);
d := sqrt(sqr(x1 - x2) + sqr(y1 - y2));
dx := (x2 - x1)/d;
dy := (y2 - y1)/d;
x := x1;
y := y1;
x2 := round(x);
y2 := round(y);
repeat
if not b[x2, y2] then begin
b[x2, y2] := true;
if a[x2, y2] = 0 then
inc(outside)
else
inc(inside);
end;
x := x + dx;
y := y + dy;
// a[x2, y2] := clwhite;
x2 := round(x);
y2 := round(y);
d1 := sqrt(sqr(x - x1) + sqr(y - y1));
until d1 > d;
end;
procedure dfs2(x, y, xs, ys, dist: Integer);
var
d: Integer;
begin
if sqrt(sqr(x - xs) + sqr(y - ys)) > dist then begin
b[x, y] := True;
exit;
end;
inc(area);
b[x, y] := True;
for d := 0 to 3 do
if (x + dx[d] >= 0) and (y + dy[d] >= 0) and (x + dx[d] <= W) and (y + dy[d] <= H) then
if ((a[x + dx[d], y + dy[d]] = color) or (a[x + dx[d], y + dy[d]] = clwhite)) and (not b[x + dx[d], y + dy[d]]) then
dfs2(x + dx[d], y + dy[d], xs, ys, dist);
end;
procedure dfs3(x, y, xs, ys, dist: Integer);
var
d: Integer;
begin
if sqrt(sqr(x - xs) + sqr(y - ys)) > dist then begin
b[x, y] := True;
exit;
end;
inc(area);
b[x, y] := True;
for d := 0 to 3 do
if (x + dx[d] >= 0) and (y + dy[d] >= 0) and (x + dx[d] <= W) and (y + dy[d] <= H) then
if not b[x + dx[d], y + dy[d]] then
dfs3(x + dx[d], y + dy[d], xs, ys, dist);
end;
function GetNumber: integer;
var
i, j, parts, d, holes: integer;
i1, j1: integer;
x, y, xp, yp, xh, yh: integer;
inside, outside: integer;
cur: integer;
max: extended;
_1or7: boolean;
begin
a := c;
fillchar(b, sizeof(b), 0);
color := clred;
newcolor := clred;
parts := 0;
for i := xs to xe do
for j := ys to ye do
if (a[i, j] = clred) and (not b[i, j]) then begin
area := 0;
dfs(i, j);
if area < 4 then
c[i, j] := 1
else begin
if area > 40 then begin
x := i;
y := j;
end
else begin
xp := i;
yp := j;
end;
inc(parts);
end;
end;
if parts = 0 then begin
result := -1;
exit;
end;
fillchar(b, sizeof(b), 0);
newcolor := 0;
for i := xs to xe do
for j := ys to ye do
if c[i, j] = 1 then
dfs(i, j);
xs := W; ys := H; ye := 0; xe := 0;
for i := 0 to W do
for j := 0 to H do
if a[i, j] = clred then begin
if xs > i then xs := i;
if ys > j then ys := j;
if xe < i then xe := i;
if ye < j then ye := j;
end;
dec(xs, 3); dec(ys, 3); inc(xe, 3); inc(ye, 3);
fillchar(b,sizeof(b), 0);
newcolor := 0;
if parts > 1 then begin
area := 0;
dfs(xp, yp);
xp := 0; yp := 0;
for i := xs to xe do
for j := ys to ye do
if b[i, j] then begin
inc(xp, i);
inc(yp, j);
b[i, j] := false;
end;
xp := xp div area;
yp := yp div area;
a[xp, yp] := clgreen;
end;
fillchar(c, sizeof(c), 0);
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clred then begin
c[i, j] := clred;
for d := 0 to 3 do
c[i + dx[d], j + dy[d]] := clred;
end;
a := c;
fillchar(c, sizeof(c), 0);
if parts > 1 then
a[xp, yp] := clgreen;
color := 0;
newcolor := 0;
dfs(0, 0);
holes := 0;
for i := xs to xe do
for j := ys to ye do
if (a[i, j] = 0) and (not b[i, j]) then begin
area := 0;
dfs1(i, j);
if area > 1 then begin
inc(holes);
xh := i;
yh := j;
end
else
c[i, j] := 1;
end;
result := -1;
if holes >= 2 then begin
result := 8;
exit;
end;
//0, 4, 6 or 9
if holes = 1 then begin
fillchar(b, sizeof(b), 0);
area := 0;
dfs1(xh, yh);
xh := 0; yh := 0;
for i := xs to xe do
for j := ys to ye do
if b[i, j] then begin
inc(xh, i);
inc(yh, j);
b[i, j] := false;
end;
xh := xh div area;
yh := yh div area;
a[xh, yh] := clgreen;
if parts > 1 then begin //6 or 9
max := 0;
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clred then
if max < sqrt(sqr(xp - i) + sqr(yp - j)) then
max := sqrt(sqr(xp - i) + sqr(yp - j));
if sqrt(sqr(xh - xp) + sqr(yh - yp)) < max/2 then
result := 6
else
result := 9;
exit;
end;
//now 0 or 4
if area > 10 then
result := 0
else
result := 4;
exit;
end;
if parts > 1 then begin
result := 9;
exit;
end;
//here goes 1, 2, 3, 5, 7
//separating 1 and 7 from other numbers
max := 0;
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clred then
for i1 := xs to xe do
for j1 := ys to ye do
if a[i1, j1] = clred then
if sqrt(sqr(i1 - i) + sqr(j1 - j)) > max then begin
max := sqrt(sqr(i1 - i) + sqr(j1 - j));
x := i;
y := j;
xp := i1;
yp := j1;
end;
count(inside, outside, x, y, xp, yp);
if outside = 0 then
_1or7 := true
else
_1or7 := false;
for i := xs to xe do
for j := ys to ye do
if a[i, j] = 0 then
for d := 0 to 3 do
if a[i + dx[d], j + dy[d]] = clred then begin
a[i, j] := clwhite;
break;
end;
d := 10;
color := 0;
fillchar(c, sizeof(c), 0);
for i := xs to xe do
for j := ys to ye do
if a[i, j] = clwhite then begin
for i1 := i - d - 1 to i + d + 1 do
for j1 := j - d - 1 to j + d + 1 do
b[i1, j1] := false;
dfs2(i, j, i, j, d);
area := 0;
dfs3(i, j, i, j, d);
if area < 100 then
c[i, j] := clpurple
end;
fillchar(b,sizeof(b),0);
for i := xs to xe do
for j := ys to ye do
if c[i, j] = clpurple then begin
a[i, j] := clpurple;
for d := 0 to 7 do
b[i + dx[d], j + dy[d]] := true;
end;
for i := xs to xe do
for j := ys to ye do
if b[i, j] then
a[i, j] := clpurple;
fillchar(b, sizeof(b), 0);
parts := 0;
outside := 0;
color := clpurple;
newcolor := clpurple;
for i := xs to xe do
for j := ys to ye do
if (a[i, j] = clpurple) and (not b[i, j]) then begin
area := 0;
dfs1(i, j);
inc(outside);
if area > 15 then
inc(parts);
end;
if _1or7 then
if parts <= 2 then
result := 1
else
result := 7
else
if outside >= 5 then
result := 5
else if parts = 3 then
result := 2
else if parts = 2 then
result := 3;
{ result := parts + 1000*outside;}
end;
procedure ProcessPicture(var BMP:TMufasaBitmap; var shape: string; var number: Integer; debug: Integer); callconv
var
i, j : Integer;
begin
FillChar(b, SizeOf(b), 0);
for i := 0 to W do
for j := 0 to H do
a[i, j] := BMP.FastGetPixel(i,j);
//First, lets find the largest area of one color, thats close to white
//this should be our shape to recognize
//we will also fill the spaces inside the shape
if not Simplify then begin
shape := 'unknown';
number := -1;
exit;
end;
//Now, recognizing the shape :)
shape := GetShape;
if (debug = 1) or (debug = 3) then
for i := 0 to W do
for j := 0 to H do
BMP.FastSetPixel(i,j,a[i, j]);
number := GetNumber;
if debug = 2 then
for i := 0 to W do
for j := 0 to H do
BMP.FastSetPixel(i,j,a[i, j]);
if debug = 3 then
for i := 0 to W do
for j := 0 to H do
if a[i, j] <> 0 then
BMP.FastSetPixel(i,j,not a[i, j]);
end;
end.