1 (* Copyright (C) DooM 2D:Forever Developers
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, either version 3 of the License, or
6 * (at your option) any later version.
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
16 {$INCLUDE ../shared/a_modes.inc}
24 GridDefaultTileSize
= 32;
27 GridQueryCB
= function (obj
: TObject
; tag
: Integer): Boolean is nested
; // return `true` to stop
34 PBodyProxyRec
= ^TBodyProxyRec
;
35 TBodyProxyRec
= record
37 mX
, mY
, mWidth
, mHeight
: Integer; // aabb
38 mQueryMark
: DWord
; // was this object visited at this query?
42 nextLink
: TBodyProxy
; // next free or nothing
45 procedure setup (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
48 //constructor Create (aGrid: TBodyGrid; aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer);
49 //destructor Destroy (); override;
51 property x
: Integer read mX
;
52 property y
: Integer read mY
;
53 property width
: Integer read mWidth
;
54 property height
: Integer read mHeight
;
55 property obj
: TObject read mObj
;
56 property tag
: Integer read mTag
;
57 //property grid: TBodyGrid read mGrid;
60 PGridCell
= ^TGridCell
;
63 next
: Integer; // in this cell; index in mCells
66 GridInternalCB
= function (grida
: Integer): Boolean is nested
; // return `true` to stop
68 TBodyGrid
= class(TObject
)
71 mMinX
, mMinY
: Integer; // so grids can start at any origin
72 mWidth
, mHeight
: Integer; // in tiles
73 mGrid
: array of Integer; // mWidth*mHeight, index in mCells
74 mCells
: array of TGridCell
; // cell pool
75 mFreeCell
: Integer; // first free cell index or -1
78 mProxies
: array of TBodyProxyRec
;
79 mProxyFree
: TBodyProxy
; // free
80 mProxyCount
: Integer; // currently used
81 mProxyMaxCount
: Integer;
84 function allocCell
: Integer;
85 procedure freeCell (idx
: Integer); // `next` is simply overwritten
87 function allocProxy (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer): TBodyProxy
;
88 procedure freeProxy (body
: TBodyProxy
);
90 procedure insert (body
: TBodyProxy
);
91 procedure remove (body
: TBodyProxy
);
93 function forGridRect (x
, y
, w
, h
: Integer; cb
: GridInternalCB
): Boolean;
96 constructor Create (aMinPixX
, aMinPixY
, aPixWidth
, aPixHeight
: Integer; aTileSize
: Integer=GridDefaultTileSize
);
97 destructor Destroy (); override;
99 function insertBody (aObj
: TObject
; ax
, ay
, aWidth
, aHeight
: Integer; aTag
: Integer=0): TBodyProxy
;
100 procedure removeBody (aObj
: TBodyProxy
); // WARNING! this WILL destroy proxy!
102 procedure moveBody (body
: TBodyProxy
; dx
, dy
: Integer);
103 procedure resizeBody (body
: TBodyProxy
; sx
, sy
: Integer);
104 procedure moveResizeBody (body
: TBodyProxy
; dx
, dy
, sx
, sy
: Integer);
106 function forEachInAABB (x
, y
, w
, h
: Integer; cb
: GridQueryCB
): Boolean;
108 function getProxyForBody (aObj
: TObject
; x
, y
, w
, h
: Integer): TBodyProxy
;
110 procedure dumpStats ();
115 TBinaryHeapLessFn
= function (a
, b
: TObject
): Boolean;
117 TBinaryHeapObj
= class(TObject
)
119 elem
: array of TObject
;
121 lessfn
: TBinaryHeapLessFn
;
124 procedure heapify (root
: Integer);
127 constructor Create (alessfn
: TBinaryHeapLessFn
);
128 destructor Destroy (); override;
132 procedure insert (val
: TObject
);
134 function front (): TObject
;
135 procedure popFront ();
137 property count
: Integer read elemUsed
;
147 // ////////////////////////////////////////////////////////////////////////// //
149 constructor TBodyProxy.Create (aGrid: TBodyGrid; aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer);
152 setup(aX, aY, aWidth, aHeight, aObj, aTag);
156 destructor TBodyProxy.Destroy ();
163 procedure TBodyProxyRec
.setup (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
176 // ////////////////////////////////////////////////////////////////////////// //
177 constructor TBodyGrid
.Create (aMinPixX
, aMinPixY
, aPixWidth
, aPixHeight
: Integer; aTileSize
: Integer=GridDefaultTileSize
);
181 if aTileSize
< 1 then aTileSize
:= 1;
182 if aTileSize
> 8192 then aTileSize
:= 8192; // arbitrary limit
183 if aPixWidth
< aTileSize
then aPixWidth
:= aTileSize
;
184 if aPixHeight
< aTileSize
then aPixHeight
:= aTileSize
;
185 mTileSize
:= aTileSize
;
188 mWidth
:= (aPixWidth
+aTileSize
-1) div aTileSize
;
189 mHeight
:= (aPixHeight
+aTileSize
-1) div aTileSize
;
190 SetLength(mGrid
, mWidth
*mHeight
);
191 SetLength(mCells
, mWidth
*mHeight
);
192 SetLength(mProxies
, 8192);
195 for idx
:= 0 to High(mCells
) do
197 mCells
[idx
].body
:= -1;
198 mCells
[idx
].next
:= idx
+1;
200 mCells
[High(mCells
)].next
:= -1; // last cell
202 for idx
:= 0 to High(mGrid
) do mGrid
[idx
] := -1;
204 for idx
:= 0 to High(mProxies
) do mProxies
[idx
].nextLink
:= idx
+1;
205 mProxies
[High(mProxies
)].nextLink
:= -1;
211 e_WriteLog(Format('created grid with size: %dx%d (tile size: %d); pix: %dx%d', [mWidth
, mHeight
, mTileSize
, mWidth
*mTileSize
, mHeight
*mTileSize
]), MSG_NOTIFY
);
215 destructor TBodyGrid
.Destroy ();
226 procedure TBodyGrid
.dumpStats ();
228 idx
, mcb
, cidx
, cnt
: Integer;
231 for idx
:= 0 to High(mGrid
) do
238 cidx
:= mCells
[cidx
].next
;
240 if (mcb
< cnt
) then mcb
:= cnt
;
242 e_WriteLog(Format('grid size: %dx%d (tile size: %d); pix: %dx%d; used cells: %d; max bodies in cell: %d; max proxies allocated: %d; proxies used: %d', [mWidth
, mHeight
, mTileSize
, mWidth
*mTileSize
, mHeight
*mTileSize
, mUsedCells
, mcb
, mProxyMaxCount
, mProxyCount
]), MSG_NOTIFY
);
246 function TBodyGrid
.allocCell
: Integer;
250 if (mFreeCell
< 0) then
252 // no free cells, want more
253 mFreeCell
:= Length(mCells
);
254 SetLength(mCells
, mFreeCell
+32768); // arbitrary number
255 for idx
:= mFreeCell
to High(mCells
) do
257 mCells
[idx
].body
:= -1;
258 mCells
[idx
].next
:= idx
+1;
260 mCells
[High(mCells
)].next
:= -1; // last cell
263 mFreeCell
:= mCells
[result
].next
;
264 mCells
[result
].next
:= -1;
266 //e_WriteLog(Format('grid: allocated new cell #%d (total: %d)', [result, mUsedCells]), MSG_NOTIFY);
270 procedure TBodyGrid
.freeCell (idx
: Integer);
272 if (idx
>= 0) and (idx
< High(mCells
)) then
274 if mCells
[idx
].body
= -1 then exit
; // the thing that should not be
275 mCells
[idx
].body
:= -1;
276 mCells
[idx
].next
:= mFreeCell
;
283 function TBodyGrid
.allocProxy (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer): TBodyProxy
;
288 if (mProxyFree
= -1) then
290 // no free proxies, resize list
291 olen
:= Length(mProxies
);
292 SetLength(mProxies
, olen
+8192); // arbitrary number
293 for idx
:= olen
to High(mProxies
) do mProxies
[idx
].nextLink
:= idx
+1;
294 mProxies
[High(mProxies
)].nextLink
:= -1;
298 result
:= mProxyFree
;
299 px
:= @mProxies
[result
];
300 mProxyFree
:= px
.nextLink
;
301 px
.setup(aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
306 if (mProxyMaxCount
< mProxyCount
) then mProxyMaxCount
:= mProxyCount
;
309 procedure TBodyGrid
.freeProxy (body
: TBodyProxy
);
311 if (body
< 0) or (body
> High(mProxies
)) then exit
; // just in case
312 if (mProxyCount
= 0) then raise Exception
.Create('wutafuuuuu in grid (no allocated proxies, what i should free now?)');
314 mProxies
[body
].mObj
:= nil;
315 mProxies
[body
].nextLink
:= mProxyFree
;
321 function TBodyGrid
.forGridRect (x
, y
, w
, h
: Integer; cb
: GridInternalCB
): Boolean;
326 if (w
< 1) or (h
< 1) or not assigned(cb
) then exit
;
331 if (x
+w
<= 0) or (y
+h
<= 0) then exit
;
332 if (x
>= mWidth
*mTileSize
) or (y
>= mHeight
*mTileSize
) then exit
;
333 for gy
:= y
div mTileSize
to (y
+h
-1) div mTileSize
do
335 if (gy
< 0) then continue
;
336 if (gy
>= mHeight
) then break
;
337 for gx
:= x
div mTileSize
to (x
+w
-1) div mTileSize
do
339 if (gx
< 0) then continue
;
340 if (gx
>= mWidth
) then break
;
341 if (cb(gy
*mWidth
+gx
)) then begin result
:= true; exit
; end;
347 procedure TBodyGrid
.insert (body
: TBodyProxy
);
349 function inserter (grida
: Integer): Boolean;
353 result
:= false; // never stop
354 // add body to the given grid cell
356 //e_WriteLog(Format(' 01: allocated cell for grid coords (%d,%d), body coords:(%d,%d): #%d', [gx, gy, dx, dy, cidx]), MSG_NOTIFY);
357 mCells
[cidx
].body
:= body
;
358 mCells
[cidx
].next
:= mGrid
[grida
];
359 mGrid
[grida
] := cidx
;
365 if (body
< 0) or (body
> High(mProxies
)) then exit
; // just in case
366 px
:= @mProxies
[body
];
367 forGridRect(px
.mX
, px
.mY
, px
.mWidth
, px
.mHeight
, inserter
);
371 // absolutely not tested
372 procedure TBodyGrid
.remove (body
: TBodyProxy
);
374 function remover (grida
: Integer): Boolean;
376 pidx
, idx
, tmp
: Integer;
378 result
:= false; // never stop
379 // find and remove cell
384 tmp
:= mCells
[idx
].next
;
385 if (mCells
[idx
].body
= body
) then
387 if (pidx
= -1) then mGrid
[grida
] := tmp
else mCells
[pidx
].next
:= tmp
;
389 break
; // assume that we cannot have one object added to bucket twice
402 if (body
< 0) or (body
> High(mProxies
)) then exit
; // just in case
403 px
:= @mProxies
[body
];
404 forGridRect(px
.mX
, px
.mY
, px
.mWidth
, px
.mHeight
, remover
);
408 function TBodyGrid
.insertBody (aObj
: TObject
; aX
, aY
, aWidth
, aHeight
: Integer; aTag
: Integer=0): TBodyProxy
;
410 result
:= allocProxy(aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
415 procedure TBodyGrid
.removeBody (aObj
: TBodyProxy
);
417 if (aObj
< 0) or (aObj
> High(mProxies
)) then exit
; // just in case
423 procedure TBodyGrid
.moveResizeBody (body
: TBodyProxy
; dx
, dy
, sx
, sy
: Integer);
427 if (body
< 0) or (body
> High(mProxies
)) then exit
; // just in case
428 if ((dx
= 0) and (dy
= 0) and (sx
= 0) and (sy
= 0)) then exit
;
430 px
:= @mProxies
[body
];
438 procedure TBodyGrid
.moveBody (body
: TBodyProxy
; dx
, dy
: Integer);
440 moveResizeBody(body
, dx
, dy
, 0, 0);
443 procedure TBodyGrid
.resizeBody (body
: TBodyProxy
; sx
, sy
: Integer);
445 moveResizeBody(body
, 0, 0, sx
, sy
);
449 function TBodyGrid
.forEachInAABB (x
, y
, w
, h
: Integer; cb
: GridQueryCB
): Boolean;
450 function iterator (grida
: Integer): Boolean;
459 if (mCells
[idx
].body
<> -1) then
461 px
:= @mProxies
[mCells
[idx
].body
];
462 if (px
.mQueryMark
<> mLastQuery
) then
464 //e_WriteLog(Format(' query #%d body hit: (%d,%d)-(%dx%d) tag:%d', [mLastQuery, mCells[idx].body.mX, mCells[idx].body.mY, mCells[idx].body.mWidth, mCells[idx].body.mHeight, mCells[idx].body.mTag]), MSG_NOTIFY);
465 px
.mQueryMark
:= mLastQuery
;
466 if (cb(px
.mObj
, px
.mTag
)) then begin result
:= true; exit
; end;
469 idx
:= mCells
[idx
].next
;
477 if not assigned(cb
) then exit
;
479 // increase query counter
481 if (mLastQuery
= 0) then
483 // just in case of overflow
485 for idx
:= 0 to High(mProxies
) do mProxies
[idx
].mQueryMark
:= 0;
487 //e_WriteLog(Format('grid: query #%d: (%d,%d)-(%dx%d)', [mLastQuery, minx, miny, maxx, maxy]), MSG_NOTIFY);
489 result
:= forGridRect(x
, y
, w
, h
, iterator
);
493 function TBodyGrid
.getProxyForBody (aObj
: TObject
; x
, y
, w
, h
: Integer): TBodyProxy
;
495 res
: TBodyProxy
= -1;
497 function iterator (grida
: Integer): Boolean;
505 if (mCells
[idx
].body
<> -1) and (mProxies
[mCells
[idx
].body
].mObj
= aObj
) then
508 res
:= mCells
[idx
].body
;
511 idx
:= mCells
[idx
].next
;
517 if (aObj
= nil) then exit
;
518 forGridRect(x
, y
, w
, h
, iterator
);
523 // ////////////////////////////////////////////////////////////////////////// //
524 constructor TBinaryHeapObj
.Create (alessfn
: TBinaryHeapLessFn
);
526 if not assigned(alessfn
) then raise Exception
.Create('wutafuck?!');
528 SetLength(elem
, 8192); // 'cause why not?
533 destructor TBinaryHeapObj
.Destroy ();
539 procedure TBinaryHeapObj
.clear ();
545 procedure TBinaryHeapObj
.heapify (root
: Integer);
547 smallest
, right
: Integer;
552 smallest
:= 2*root
+1; // left child
553 if (smallest
>= elemUsed
) then break
; // anyway
554 right
:= smallest
+1; // right child
555 if not lessfn(elem
[smallest
], elem
[root
]) then smallest
:= root
;
556 if (right
< elemUsed
) and (lessfn(elem
[right
], elem
[smallest
])) then smallest
:= right
;
557 if (smallest
= root
) then break
;
560 elem
[root
] := elem
[smallest
];
561 elem
[smallest
] := tmp
;
567 procedure TBinaryHeapObj
.insert (val
: TObject
);
571 if (val
= nil) then exit
;
573 if (i
= Length(elem
)) then SetLength(elem
, Length(elem
)+16384); // arbitrary number
577 par
:= (i
-1) div 2; // parent
578 if not lessfn(val
, elem
[par
]) then break
;
579 elem
[i
] := elem
[par
];
585 function TBinaryHeapObj
.front (): TObject
;
587 if elemUsed
> 0 then result
:= elem
[0] else result
:= nil;
591 procedure TBinaryHeapObj
.popFront ();
593 if (elemUsed
> 0) then
596 elem
[0] := elem
[elemUsed
];