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
32 TBodyProxy
= class(TObject
)
34 mX
, mY
, mWidth
, mHeight
: Integer; // aabb
35 mQueryMark
: DWord
; // was this object visited at this query?
39 prevLink
: TBodyProxy
; // only for used
40 nextLink
: TBodyProxy
; // either used or free
43 procedure setup (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
46 constructor Create (aGrid
: TBodyGrid
; aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
47 destructor Destroy (); override;
49 property x
: Integer read mX
;
50 property y
: Integer read mY
;
51 property width
: Integer read mWidth
;
52 property height
: Integer read mHeight
;
53 property obj
: TObject read mObj
;
54 property tag
: Integer read mTag
;
55 property grid
: TBodyGrid read mGrid
;
58 PGridCell
= ^TGridCell
;
61 next
: Integer; // in this cell; index in mCells
64 GridInternalCB
= function (grida
: Integer): Boolean is nested
; // return `true` to stop
66 TBodyGrid
= class(TObject
)
69 mMinX
, mMinY
: Integer; // so grids can start at any origin
70 mWidth
, mHeight
: Integer; // in tiles
71 mGrid
: array of Integer; // mWidth*mHeight, index in mCells
72 mCells
: array of TGridCell
; // cell pool
73 mFreeCell
: Integer; // first free cell index or -1
76 mProxyFree
: TBodyProxy
; // free
77 mProxyList
: TBodyProxy
; // used
78 mProxyCount
: Integer; // total allocated
81 function allocCell
: Integer;
82 procedure freeCell (idx
: Integer); // `next` is simply overwritten
84 function allocProxy (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer): TBodyProxy
;
85 procedure freeProxy (body
: TBodyProxy
);
87 procedure insert (body
: TBodyProxy
);
88 procedure remove (body
: TBodyProxy
);
90 function forGridRect (x
, y
, w
, h
: Integer; cb
: GridInternalCB
): Boolean;
93 constructor Create (aMinPixX
, aMinPixY
, aPixWidth
, aPixHeight
: Integer; aTileSize
: Integer=GridDefaultTileSize
);
94 destructor Destroy (); override;
96 function insertBody (aObj
: TObject
; ax
, ay
, aWidth
, aHeight
: Integer; aTag
: Integer=0): TBodyProxy
;
97 procedure removeBody (aObj
: TBodyProxy
); // WARNING! this will NOT destroy proxy!
99 procedure moveBody (body
: TBodyProxy
; dx
, dy
: Integer);
100 procedure resizeBody (body
: TBodyProxy
; sx
, sy
: Integer);
101 procedure moveResizeBody (body
: TBodyProxy
; dx
, dy
, sx
, sy
: Integer);
103 function forEachInAABB (x
, y
, w
, h
: Integer; cb
: GridQueryCB
): Boolean;
105 function getProxyForBody (aObj
: TObject
; x
, y
, w
, h
: Integer): TBodyProxy
;
107 procedure dumpStats ();
112 TBinaryHeapLessFn
= function (a
, b
: TObject
): Boolean;
114 TBinaryHeapObj
= class(TObject
)
116 elem
: array of TObject
;
118 lessfn
: TBinaryHeapLessFn
;
121 procedure heapify (root
: Integer);
124 constructor Create (alessfn
: TBinaryHeapLessFn
);
125 destructor Destroy (); override;
129 procedure insert (val
: TObject
);
131 function front (): TObject
;
132 procedure popFront ();
134 property count
: Integer read elemUsed
;
144 // ////////////////////////////////////////////////////////////////////////// //
145 constructor TBodyProxy
.Create (aGrid
: TBodyGrid
; aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
148 setup(aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
152 destructor TBodyProxy
.Destroy ();
158 procedure TBodyProxy
.setup (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
172 // ////////////////////////////////////////////////////////////////////////// //
173 constructor TBodyGrid
.Create (aMinPixX
, aMinPixY
, aPixWidth
, aPixHeight
: Integer; aTileSize
: Integer=GridDefaultTileSize
);
177 if aTileSize
< 1 then aTileSize
:= 1;
178 if aTileSize
> 8192 then aTileSize
:= 8192; // arbitrary limit
179 if aPixWidth
< aTileSize
then aPixWidth
:= aTileSize
;
180 if aPixHeight
< aTileSize
then aPixHeight
:= aTileSize
;
181 mTileSize
:= aTileSize
;
184 mWidth
:= (aPixWidth
+aTileSize
-1) div aTileSize
;
185 mHeight
:= (aPixHeight
+aTileSize
-1) div aTileSize
;
186 SetLength(mGrid
, mWidth
*mHeight
);
187 SetLength(mCells
, mWidth
*mHeight
);
190 for idx
:= 0 to High(mCells
) do
192 mCells
[idx
].body
:= nil;
193 mCells
[idx
].next
:= idx
+1;
195 mCells
[High(mCells
)].next
:= -1; // last cell
197 for idx
:= 0 to High(mGrid
) do mGrid
[idx
] := -1;
203 e_WriteLog(Format('created grid with size: %dx%d (tile size: %d); pix: %dx%d', [mWidth
, mHeight
, mTileSize
, mWidth
*mTileSize
, mHeight
*mTileSize
]), MSG_NOTIFY
);
207 destructor TBodyGrid
.Destroy ();
211 // free all owned proxies
212 while mProxyFree
<> nil do
215 mProxyFree
:= px
.nextLink
;
219 while mProxyList
<> nil do
222 mProxyList
:= px
.nextLink
;
232 procedure TBodyGrid
.dumpStats ();
234 idx
, mcb
, cidx
, cnt
: Integer;
237 for idx
:= 0 to High(mGrid
) do
244 cidx
:= mCells
[cidx
].next
;
246 if (mcb
< cnt
) then mcb
:= cnt
;
248 e_WriteLog(Format('grid size: %dx%d (tile size: %d); pix: %dx%d; used cells: %d; max bodies in cell: %d; proxies allocated: %d', [mWidth
, mHeight
, mTileSize
, mWidth
*mTileSize
, mHeight
*mTileSize
, mUsedCells
, mcb
, mProxyCount
]), MSG_NOTIFY
);
252 function TBodyGrid
.allocCell
: Integer;
256 if (mFreeCell
< 0) then
258 // no free cells, want more
259 mFreeCell
:= Length(mCells
);
260 SetLength(mCells
, mFreeCell
+32768); // arbitrary number
261 for idx
:= mFreeCell
to High(mCells
) do
263 mCells
[idx
].body
:= nil;
264 mCells
[idx
].next
:= idx
+1;
266 mCells
[High(mCells
)].next
:= -1; // last cell
269 mFreeCell
:= mCells
[result
].next
;
270 mCells
[result
].next
:= -1;
272 //e_WriteLog(Format('grid: allocated new cell #%d (total: %d)', [result, mUsedCells]), MSG_NOTIFY);
276 procedure TBodyGrid
.freeCell (idx
: Integer);
278 if (idx
>= 0) and (idx
< High(mCells
)) then
280 if mCells
[idx
].body
= nil then exit
; // the thing that should not be
281 mCells
[idx
].body
:= nil;
282 mCells
[idx
].next
:= mFreeCell
;
289 function TBodyGrid
.allocProxy (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer): TBodyProxy
;
291 if (mProxyFree
= nil) then
293 // no free proxies, create new
294 result
:= TBodyProxy
.Create(self
, aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
300 result
:= mProxyFree
;
301 mProxyFree
:= result
.nextLink
;
302 result
.setup(aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
305 result
.nextLink
:= mProxyList
;
306 if (mProxyList
<> nil) then mProxyList
.prevLink
:= result
;
307 mProxyList
:= result
;
310 procedure TBodyGrid
.freeProxy (body
: TBodyProxy
);
312 if body
= nil then exit
; // just in case
313 // remove from used list
314 if (body
.prevLink
= nil) then
317 if (body
<> mProxyList
) then raise Exception
.Create('wutafuuuuu in grid?');
318 mProxyList
:= body
.nextLink
;
322 body
.prevLink
.nextLink
:= body
.nextLink
;
324 if (body
.nextLink
<> nil) then body
.nextLink
.prevLink
:= body
.prevLink
;
326 //body.mObj := nil; //WARNING! DON'T DO THIS! `removeBody()` depends on valid mObj
327 body
.prevLink
:= nil;
328 body
.nextLink
:= mProxyFree
;
333 function TBodyGrid
.forGridRect (x
, y
, w
, h
: Integer; cb
: GridInternalCB
): Boolean;
338 if (w
< 1) or (h
< 1) or not assigned(cb
) then exit
;
343 if (x
+w
<= 0) or (y
+h
<= 0) then exit
;
344 if (x
>= mWidth
*mTileSize
) or (y
>= mHeight
*mTileSize
) then exit
;
345 for gy
:= y
div mTileSize
to (y
+h
-1) div mTileSize
do
347 if (gy
< 0) then continue
;
348 if (gy
>= mHeight
) then break
;
349 for gx
:= x
div mTileSize
to (x
+w
-1) div mTileSize
do
351 if (gx
< 0) then continue
;
352 if (gx
>= mWidth
) then break
;
353 if (cb(gy
*mWidth
+gx
)) then begin result
:= true; exit
; end;
359 procedure TBodyGrid
.insert (body
: TBodyProxy
);
361 function inserter (grida
: Integer): Boolean;
365 result
:= false; // never stop
366 // add body to the given grid cell
368 //e_WriteLog(Format(' 01: allocated cell for grid coords (%d,%d), body coords:(%d,%d): #%d', [gx, gy, dx, dy, cidx]), MSG_NOTIFY);
369 mCells
[cidx
].body
:= body
;
370 mCells
[cidx
].next
:= mGrid
[grida
];
371 mGrid
[grida
] := cidx
;
375 if body
= nil then exit
;
376 forGridRect(body
.mX
, body
.mY
, body
.mWidth
, body
.mHeight
, inserter
);
380 // absolutely not tested
381 procedure TBodyGrid
.remove (body
: TBodyProxy
);
383 function remover (grida
: Integer): Boolean;
385 pidx
, idx
, tmp
: Integer;
387 result
:= false; // never stop
388 // find and remove cell
393 tmp
:= mCells
[idx
].next
;
394 if (mCells
[idx
].body
= body
) then
396 if (pidx
= -1) then mGrid
[grida
] := tmp
else mCells
[pidx
].next
:= tmp
;
398 break
; // assume that we cannot have one object added to bucket twice
409 if body
= nil then exit
;
410 forGridRect(body
.mX
, body
.mY
, body
.mWidth
, body
.mHeight
, remover
);
414 function TBodyGrid
.insertBody (aObj
: TObject
; aX
, aY
, aWidth
, aHeight
: Integer; aTag
: Integer=0): TBodyProxy
;
416 result
:= allocProxy(aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
421 // WARNING! this will NOT destroy proxy!
422 procedure TBodyGrid
.removeBody (aObj
: TBodyProxy
);
424 if aObj
= nil then exit
;
425 if (aObj
.mGrid
<> self
) then raise Exception
.Create('trying to remove alien proxy from grid');
429 if (mProxyFree
<> aObj
) then raise Exception
.Create('grid deletion invariant fucked');
430 mProxyFree
:= aObj
.nextLink
;
431 aObj
.nextLink
:= nil;
435 procedure TBodyGrid
.moveResizeBody (body
: TBodyProxy
; dx
, dy
, sx
, sy
: Integer);
437 if (body
= nil) or ((dx
= 0) and (dy
= 0) and (sx
= 0) and (sy
= 0)) then exit
;
441 Inc(body
.mWidth
, sx
);
442 Inc(body
.mHeight
, sy
);
446 procedure TBodyGrid
.moveBody (body
: TBodyProxy
; dx
, dy
: Integer);
448 moveResizeBody(body
, dx
, dy
, 0, 0);
451 procedure TBodyGrid
.resizeBody (body
: TBodyProxy
; sx
, sy
: Integer);
453 moveResizeBody(body
, 0, 0, sx
, sy
);
457 function TBodyGrid
.forEachInAABB (x
, y
, w
, h
: Integer; cb
: GridQueryCB
): Boolean;
458 function iterator (grida
: Integer): Boolean;
466 if (mCells
[idx
].body
<> nil) and (mCells
[idx
].body
.mQueryMark
<> mLastQuery
) then
468 //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);
469 mCells
[idx
].body
.mQueryMark
:= mLastQuery
;
470 if (cb(mCells
[idx
].body
.mObj
, mCells
[idx
].body
.mTag
)) then begin result
:= true; exit
; end;
472 idx
:= mCells
[idx
].next
;
480 if not assigned(cb
) then exit
;
482 // increase query counter
484 if (mLastQuery
= 0) then
486 // just in case of overflow
488 for idx
:= 0 to High(mCells
) do if (mCells
[idx
].body
<> nil) then mCells
[idx
].body
.mQueryMark
:= 0;
490 //e_WriteLog(Format('grid: query #%d: (%d,%d)-(%dx%d)', [mLastQuery, minx, miny, maxx, maxy]), MSG_NOTIFY);
492 result
:= forGridRect(x
, y
, w
, h
, iterator
);
496 function TBodyGrid
.getProxyForBody (aObj
: TObject
; x
, y
, w
, h
: Integer): TBodyProxy
;
498 res
: TBodyProxy
= nil;
500 function iterator (grida
: Integer): Boolean;
508 if (mCells
[idx
].body
<> nil) and (mCells
[idx
].body
= aObj
) then
511 res
:= mCells
[idx
].body
;
514 idx
:= mCells
[idx
].next
;
520 if (aObj
= nil) then exit
;
521 forGridRect(x
, y
, w
, h
, iterator
);
526 // ////////////////////////////////////////////////////////////////////////// //
527 constructor TBinaryHeapObj
.Create (alessfn
: TBinaryHeapLessFn
);
529 if not assigned(alessfn
) then raise Exception
.Create('wutafuck?!');
531 SetLength(elem
, 8192); // 'cause why not?
536 destructor TBinaryHeapObj
.Destroy ();
542 procedure TBinaryHeapObj
.clear ();
548 procedure TBinaryHeapObj
.heapify (root
: Integer);
550 smallest
, right
: Integer;
555 smallest
:= 2*root
+1; // left child
556 if (smallest
>= elemUsed
) then break
; // anyway
557 right
:= smallest
+1; // right child
558 if not lessfn(elem
[smallest
], elem
[root
]) then smallest
:= root
;
559 if (right
< elemUsed
) and (lessfn(elem
[right
], elem
[smallest
])) then smallest
:= right
;
560 if (smallest
= root
) then break
;
563 elem
[root
] := elem
[smallest
];
564 elem
[smallest
] := tmp
;
570 procedure TBinaryHeapObj
.insert (val
: TObject
);
574 if (val
= nil) then exit
;
576 if (i
= Length(elem
)) then SetLength(elem
, Length(elem
)+16384); // arbitrary number
580 par
:= (i
-1) div 2; // parent
581 if not lessfn(val
, elem
[par
]) then break
;
582 elem
[i
] := elem
[par
];
588 function TBinaryHeapObj
.front (): TObject
;
590 if elemUsed
> 0 then result
:= elem
[0] else result
:= nil;
594 procedure TBinaryHeapObj
.popFront ();
596 if (elemUsed
> 0) then
599 elem
[0] := elem
[elemUsed
];