900a3661d90c49ccec2363d6e9e6814b71164b75
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/>.
17 {$modeswitch nestedprocvars}
25 GridDefaultTileSize
= 32;
28 GridQueryCB
= function (obj
: TObject
; tag
: Integer): Boolean is nested
; // return `true` to stop
33 TBodyProxy
= class(TObject
)
35 mX
, mY
, mWidth
, mHeight
: Integer; // aabb
36 mQueryMark
: DWord
; // was this object visited at this query?
40 prevLink
: TBodyProxy
; // only for used
41 nextLink
: TBodyProxy
; // either used or free
44 procedure setup (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
47 constructor Create (aGrid
: TBodyGrid
; aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
48 destructor Destroy (); override;
50 property x
: Integer read mX
;
51 property y
: Integer read mY
;
52 property width
: Integer read mWidth
;
53 property height
: Integer read mHeight
;
54 property obj
: TObject read mObj
;
55 property tag
: Integer read mTag
;
56 property grid
: TBodyGrid read mGrid
;
59 PGridCell
= ^TGridCell
;
62 next
: Integer; // in this cell; index in mCells
65 TBodyGrid
= class(TObject
)
68 mWidth
, mHeight
: Integer; // in tiles
69 mGrid
: array of Integer; // mWidth*mHeight, index in mCells
70 mCells
: array of TGridCell
; // cell pool
71 mFreeCell
: Integer; // first free cell index or -1
74 mProxyFree
: TBodyProxy
; // free
75 mProxyList
: TBodyProxy
; // used
76 mProxyCount
: Integer; // total allocated
79 function allocCell
: Integer;
80 procedure freeCell (idx
: Integer); // `next` is simply overwritten
82 function allocProxy (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer): TBodyProxy
;
83 procedure freeProxy (body
: TBodyProxy
);
85 procedure insert (body
: TBodyProxy
);
86 procedure remove (body
: TBodyProxy
);
89 constructor Create (aPixWidth
, aPixHeight
: Integer; aTileSize
: Integer=GridDefaultTileSize
);
90 destructor Destroy (); override;
92 function insertBody (aObj
: TObject
; ax
, ay
, aWidth
, aHeight
: Integer; aTag
: Integer=0): TBodyProxy
;
93 procedure removeBody (aObj
: TBodyProxy
); // WARNING! this will NOT destroy proxy!
95 procedure moveBody (body
: TBodyProxy
; dx
, dy
: Integer);
96 procedure resizeBody (body
: TBodyProxy
; sx
, sy
: Integer);
97 procedure moveResizeBody (body
: TBodyProxy
; dx
, dy
, sx
, sy
: Integer);
99 function forEachInAABB (x
, y
, w
, h
: Integer; cb
: GridQueryCB
): Boolean;
101 function getProxyForBody (aObj
: TObject
; x
, y
, w
, h
: Integer): TBodyProxy
;
103 procedure dumpStats ();
108 TBinaryHeapLessFn
= function (a
, b
: TObject
): Boolean;
110 TBinaryHeapObj
= class(TObject
)
112 elem
: array of TObject
;
114 lessfn
: TBinaryHeapLessFn
;
117 procedure heapify (root
: Integer);
120 constructor Create (alessfn
: TBinaryHeapLessFn
);
121 destructor Destroy (); override;
125 procedure insert (val
: TObject
);
127 function front (): TObject
;
128 procedure popFront ();
130 property count
: Integer read elemUsed
;
140 // ////////////////////////////////////////////////////////////////////////// //
141 constructor TBodyProxy
.Create (aGrid
: TBodyGrid
; aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
144 setup(aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
148 destructor TBodyProxy
.Destroy ();
154 procedure TBodyProxy
.setup (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer);
168 // ////////////////////////////////////////////////////////////////////////// //
169 constructor TBodyGrid
.Create (aPixWidth
, aPixHeight
: Integer; aTileSize
: Integer=GridDefaultTileSize
);
173 if aTileSize
< 1 then aTileSize
:= 1;
174 if aTileSize
> 8192 then aTileSize
:= 8192; // arbitrary limit
175 if aPixWidth
< aTileSize
then aPixWidth
:= aTileSize
;
176 if aPixHeight
< aTileSize
then aPixHeight
:= aTileSize
;
177 mTileSize
:= aTileSize
;
178 mWidth
:= (aPixWidth
+aTileSize
-1) div aTileSize
;
179 mHeight
:= (aPixHeight
+aTileSize
-1) div aTileSize
;
180 SetLength(mGrid
, mWidth
*mHeight
);
181 SetLength(mCells
, mWidth
*mHeight
);
184 for idx
:= 0 to High(mCells
) do
186 mCells
[idx
].body
:= nil;
187 mCells
[idx
].next
:= idx
+1;
189 mCells
[High(mCells
)].next
:= -1; // last cell
191 for idx
:= 0 to High(mGrid
) do mGrid
[idx
] := -1;
197 e_WriteLog(Format('created grid with size: %dx%d (tile size: %d); pix: %dx%d', [mWidth
, mHeight
, mTileSize
, mWidth
*mTileSize
, mHeight
*mTileSize
]), MSG_NOTIFY
);
201 destructor TBodyGrid
.Destroy ();
205 // free all owned proxies
206 while mProxyFree
<> nil do
209 mProxyFree
:= px
.nextLink
;
213 while mProxyList
<> nil do
216 mProxyList
:= px
.nextLink
;
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; proxies allocated: %d', [mWidth
, mHeight
, mTileSize
, mWidth
*mTileSize
, mHeight
*mTileSize
, mUsedCells
, mcb
, 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
:= nil;
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
= nil then exit
; // the thing that should not be
275 mCells
[idx
].body
:= nil;
276 mCells
[idx
].next
:= mFreeCell
;
283 function TBodyGrid
.allocProxy (aX
, aY
, aWidth
, aHeight
: Integer; aObj
: TObject
; aTag
: Integer): TBodyProxy
;
285 if (mProxyFree
= nil) then
287 // no free proxies, create new
288 result
:= TBodyProxy
.Create(self
, aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
294 result
:= mProxyFree
;
295 mProxyFree
:= result
.nextLink
;
296 result
.setup(aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
299 result
.nextLink
:= mProxyList
;
300 if (mProxyList
<> nil) then mProxyList
.prevLink
:= result
;
301 mProxyList
:= result
;
304 procedure TBodyGrid
.freeProxy (body
: TBodyProxy
);
306 if body
= nil then exit
; // just in case
307 // remove from used list
308 if (body
.prevLink
= nil) then
311 if (body
<> mProxyList
) then raise Exception
.Create('wutafuuuuu in grid?');
312 mProxyList
:= body
.nextLink
;
316 body
.prevLink
.nextLink
:= body
.nextLink
;
318 if (body
.nextLink
<> nil) then body
.nextLink
.prevLink
:= body
.prevLink
;
320 //body.mObj := nil; //WARNING! DON'T DO THIS! `removeBody()` depends on valid mObj
321 body
.prevLink
:= nil;
322 body
.nextLink
:= mProxyFree
;
327 procedure TBodyGrid
.insert (body
: TBodyProxy
);
329 dx
, dy
, gx
, gy
, cidx
: Integer;
331 if body
= nil then exit
;
332 if (body
.mWidth
< 1) or (body
.mHeight
< 1) then exit
;
334 if (body
.mX
+body
.mWidth
<= 0) or (body
.mY
+body
.mHeight
<= 0) then exit
;
335 if (body
.mX
>= mWidth
*mTileSize
) or (body
.mY
>= mHeight
*mTileSize
) then exit
;
336 //e_WriteLog(Format('grid: inserting body: (%d,%d)-(%dx%d)', [body.mX, body.mY, body.mWidth, body.mHeight]), MSG_NOTIFY);
337 gy
:= body
.mY
div mTileSize
;
339 while (dy
< body
.mHeight
) do
341 if (gy
>= 0) and (gy
< mHeight
) then
344 gx
:= body
.mX
div mTileSize
;
345 while (dx
< body
.mWidth
) do
347 if (gx
>= 0) and (gx
< mWidth
) then
349 //e_WriteLog(Format(' 00: allocating cell for grid coords (%d,%d), body coords:(%d,%d)', [gx, gy, dx, dy]), MSG_NOTIFY);
351 //e_WriteLog(Format(' 01: allocated cell for grid coords (%d,%d), body coords:(%d,%d): #%d', [gx, gy, dx, dy, cidx]), MSG_NOTIFY);
352 mCells
[cidx
].body
:= body
;
353 mCells
[cidx
].next
:= mGrid
[gy
*mWidth
+gx
];
354 mGrid
[gy
*mWidth
+gx
] := cidx
;
355 //e_WriteLog(Format(' 02: put cell for grid coords (%d,%d), body coords:(%d,%d): #%d', [gx, gy, dx, dy, cidx]), MSG_NOTIFY);
367 // absolutely not tested
368 procedure TBodyGrid
.remove (body
: TBodyProxy
);
370 dx
, dy
, gx
, gy
, idx
, pidx
, tmp
: Integer;
372 if body
= nil then exit
;
373 if (body
.mWidth
< 1) or (body
.mHeight
< 1) then exit
;
375 if (body
.mX
+body
.mWidth
<= 0) or (body
.mY
+body
.mHeight
<= 0) then exit
;
376 if (body
.mX
>= mWidth
*mTileSize
) or (body
.mY
>= mHeight
*mTileSize
) then exit
;
377 gy
:= body
.mY
div mTileSize
;
380 while (dy
< body
.mHeight
) do
382 if (gy
>= 0) and (gy
< mHeight
) then
385 gx
:= body
.mX
div mTileSize
;
386 while (dx
< body
.mWidth
) do
388 if (gx
>= 0) and (gx
< mWidth
) then
390 // find and remove cell
392 idx
:= mGrid
[gy
*mWidth
+gx
];
395 tmp
:= mCells
[idx
].next
;
396 if mCells
[idx
].body
= body
then
398 if pidx
= -1 then mGrid
[gy
*mWidth
+gx
] := tmp
else mCells
[pidx
].next
:= tmp
;
418 function TBodyGrid
.insertBody (aObj
: TObject
; aX
, aY
, aWidth
, aHeight
: Integer; aTag
: Integer=0): TBodyProxy
;
420 result
:= allocProxy(aX
, aY
, aWidth
, aHeight
, aObj
, aTag
);
425 // WARNING! this will NOT destroy proxy!
426 procedure TBodyGrid
.removeBody (aObj
: TBodyProxy
);
428 if aObj
= nil then exit
;
429 if (aObj
.mGrid
<> self
) then raise Exception
.Create('trying to remove alien proxy from grid');
433 if (mProxyFree
<> aObj
) then raise Exception
.Create('grid deletion invariant fucked');
434 mProxyFree
:= aObj
.nextLink
;
435 aObj
.nextLink
:= nil;
439 procedure TBodyGrid
.moveResizeBody (body
: TBodyProxy
; dx
, dy
, sx
, sy
: Integer);
441 if (body
= nil) or ((dx
= 0) and (dy
= 0) and (sx
= 0) and (sy
= 0)) then exit
;
445 Inc(body
.mWidth
, sx
);
446 Inc(body
.mHeight
, sy
);
450 procedure TBodyGrid
.moveBody (body
: TBodyProxy
; dx
, dy
: Integer);
452 moveResizeBody(body
, dx
, dy
, 0, 0);
455 procedure TBodyGrid
.resizeBody (body
: TBodyProxy
; sx
, sy
: Integer);
457 moveResizeBody(body
, 0, 0, sx
, sy
);
461 function TBodyGrid
.forEachInAABB (x
, y
, w
, h
: Integer; cb
: GridQueryCB
): Boolean;
463 gx
, gy
, idx
: Integer;
464 minx
, miny
, maxx
, maxy
: Integer;
467 if not assigned(cb
) then exit
;
468 if (w
< 1) or (h
< 1) then exit
;
473 if (minx
> maxx
) or (miny
> maxy
) then exit
;
474 if (maxx
< 0) or (maxy
< 0) then exit
;
475 if (minx
>= mWidth
*mTileSize
) or (miny
>= mHeight
*mTileSize
) then exit
;
476 // increase query counter
478 if (mLastQuery
= 0) then
480 // just in case of overflow
482 for idx
:= 0 to High(mCells
) do if (mCells
[idx
].body
<> nil) then mCells
[idx
].body
.mQueryMark
:= 0;
484 //e_WriteLog(Format('grid: query #%d: (%d,%d)-(%dx%d)', [mLastQuery, minx, miny, maxx, maxy]), MSG_NOTIFY);
486 for gy
:= miny
div mTileSize
to maxy
div mTileSize
do
488 if (gy
< 0) then continue
;
489 if (gy
>= mHeight
) then break
;
490 for gx
:= minx
div mTileSize
to maxx
div mTileSize
do
492 if (gx
< 0) then continue
;
493 if (gx
>= mWidth
) then break
;
494 idx
:= mGrid
[gy
*mWidth
+gx
];
497 if (mCells
[idx
].body
<> nil) and (mCells
[idx
].body
.mQueryMark
<> mLastQuery
) then
499 //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);
500 mCells
[idx
].body
.mQueryMark
:= mLastQuery
;
501 if (cb(mCells
[idx
].body
.mObj
, mCells
[idx
].body
.mTag
)) then begin result
:= true; exit
; end;
503 idx
:= mCells
[idx
].next
;
510 function TBodyGrid
.getProxyForBody (aObj
: TObject
; x
, y
, w
, h
: Integer): TBodyProxy
;
512 function qq (obj
: TObject
; tag
: Integer): Boolean;
514 result
:= (obj
= aObj
);
519 forEachInAABB(x
, y
, w
, h
, qq
);
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
];