1:
2:
3:
4:

type myPixel = record
  matter, marked : Boolean;

myArray: [1 .. 800, 1 .. 600] of myPixel;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:

procedure TForm1.Button1Click(Sender: TObject);
  type arr = array [1 .. 800, 1 .. 600] of Boolean;

  procedure mark(var myArray: arr; x, y : Cardinal);
  begin
    if ((x <= 800) and (x >= 1)) and ((y >= 1) and (y <= 600)) then
      if not myArray[x, y] then
      begin
        myArray[x, y] := true;
        mark(myArray, x+1,y+1);
        mark(myArray, x+0,y+1);
        mark(myArray, x+1,y+0);
        mark(myArray, x+0,y+0);
      end;
  end;

  var a : arr;
  var x, y : Integer;
  ticks : Cardinal;
begin

  ticks := GetTickCount;

  for x := 1 to 800 do
    for y := 1 to 600 do
      a[x,y] := False;

  Label1.Caption := 'Initialisieren in: ' + IntToStr(GetTickCount - ticks) + 'ms';
  ticks := GetTickCount;

  mark(a, 1, 1);
  Label2.Caption := 'Markiert in: ' + IntToStr(GetTickCount - ticks) + 'ms';
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:

{
* This program is licensed under the GNU General Public License Version 2
* You should have recieved a copy of the license with this file.
* If not, see http://www.gnu.org/licenses/gpl.txt for more informations
*
* Project: 2D Bounding Boxes
* Author:  Andreas Stoeckel
* File: CollisionRects.pas
* Comment: With this unit you are able to create 2D Boundng boxes on a 2D landscape
}

unit CollisionRects;

interface

uses Windows, SysUtils, Classes, Graphics, Dialogs;

type TRects = array of TRect;

type
  TRGBTripleArray = array[0..32768] of TRGBTriple;
  pRGBTripleArray = ^TRGBTripleArray;

//Create Bounding Boxes on a 2D Landscape
procedure MakeRects(img:TBitmap;TransCol:TColor;var rects:TRects);

//Procedure for connecting rects
procedure ConnectRects(var rects:TRects);

const
  RectSize = 10;
  MaxPixelDif = 9;

implementation


//Get the count of pixels in a specifc area of a bitmap
function PixelCount(area:TRect;img:TBitmap):integer;
var x,y:integer;
    p:pRGBTripleArray;
    t:TRGBTriple;
    w,h:integer;
begin
  Result := 0;

  //Look whether the area is in the image's bounds
  w := area.Right;
  if w > img.Width-1 then w := img.Width-1;
  h := area.Bottom;
  if h > img.Height-1 then h := img.Height-1;

  for y := area.Top to h do
  begin
    p := img.ScanLine[y];
    for x := area.Left to w do
    begin
      //If the current pixel is not whitce incrase result
      if p[x].rgbtBlue <> 255 then Result := Result + 1;
    end;
  end;

end;

procedure MakeRects(img:TBitmap;TransCol:TColor;var rects:TRects);
var x,y:integer;
    mask:TBitmap;
    r:TRect;
begin
  //Free the memory of "rects"
  finalize(rects);

  //Create a temporary bitmap
  mask := TBitmap.Create;
  mask.Assign(img);
  mask.Mask(TransCol); //Create a black/white map of the bitmap
  mask.PixelFormat := pf24Bit;  //Set the pixelformat to 24 Bit for Scanline
  //Divide the image into sectors and look whether there is something
  //in the sectors. If there is some land create a new rect.
  for x := 0 to img.Width div RectSize do
  begin
    for y :=  0 to img.Height div RectSize do
    begin
      r := rect(x*RectSize,y*RectSize,(x+1)*RectSize,(y+1)*RectSize);
      if PixelCount(r,mask) >= Sqr(RectSize)-Sqr(MaxPixelDif)+1 then
      begin
        SetLength(Rects,length(rects)+1);
        Rects[high(rects)] := r;
      end;
    end;
  end;

  //Connect the serval rects
  //Vertical
  ConnectRects(Rects);
  //Horizontal
  ConnectRects(Rects);

  mask.Free;
end;

//Procedure which removes a specific element from an dynamic array
procedure DeleteArrayElement(var Rects: TRects; const index: integer);
var i: integer;
begin
  if index < high(Rects) then
  begin
    for i:=index to high(Rects)-1 do
    begin
      Rects[i]:=Rects[i+1];
    end;
  end;
  SetLength(Rects, length(Rects)-1);
end;

//Connect the rects to one big rectangle
procedure ConnectRects(var Rects:TRects);
var i,j,c:integer;
begin
  c := high(rects);
  i := 0;
  while i <= c do
  begin
    j := 0;
    while j <= c do
    begin

      if (rects[j].Left = rects[i].Left) and (rects[j].Right = rects[i].Right) and
         ((rects[i].Top = rects[j].Bottom) or (rects[i].Bottom = rects[j].Top)) then
      begin
        if (rects[i].Top = rects[j].Bottom) then
        begin
          rects[i].Top := rects[j].Top;
        end
        else
        begin
          rects[i].Bottom := rects[j].Bottom;
        end;
        DeleteArrayElement(Rects,j);
        j := j - 1;
      end;

      if (rects[j].Top = rects[i].Top) and (rects[j].Bottom = rects[i].Bottom) and
         ((rects[i].Right = rects[j].Left) or (rects[i].Left = rects[j].Right)) then
      begin
        if (rects[i].Right = rects[j].Left) then
        begin
          rects[i].Right := rects[j].Right;
        end
        else
        begin
          rects[i].Left := rects[j].Left;
        end;
        DeleteArrayElement(Rects,j);
        j := j - 1;
      end;

      j := j + 1;
      c := high(rects);
    end;
    i := i + 1;
    c := high(rects);
  end;
end;



end.