src/game/g_grid.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   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.
   7  *
   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.
  12  *
  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/>.
  15  *)
  16 {$INCLUDE ../shared/a_modes.inc}
  17 unit g_grid;
  18
  19 interface
  20
  21 uses e_log;
  22
  23 const
  24   GridDefaultTileSize = 32;
  25
  26 type
  27   GridQueryCB = function (obj: TObject; tag: Integer): Boolean is nested; // return `true` to stop
  28
  29 type
  30   TBodyGrid = class;
  31
  32   TBodyProxy = Integer;
  33
  34   PBodyProxyRec = ^TBodyProxyRec;
  35   TBodyProxyRec = record
  36   private
  37     mX, mY, mWidth, mHeight: Integer; // aabb
  38     mQueryMark: DWord; // was this object visited at this query?
  39     mObj: TObject;
  40     //mGrid: TBodyGrid;
  41     mTag: Integer;
  42     nextLink: TBodyProxy; // next free or nothing
  43
  44   private
  45     procedure setup (aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer);
  46
  47   public
  48     //constructor Create (aGrid: TBodyGrid; aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer);
  49     //destructor Destroy (); override;
  50
  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;
  58   end;
  59
  60   PGridCell = ^TGridCell;
  61   TGridCell = record
  62     body: Integer;
  63     next: Integer; // in this cell; index in mCells
  64   end;
  65
  66   GridInternalCB = function (grida: Integer): Boolean is nested; // return `true` to stop
  67
  68   TBodyGrid = class(TObject)
  69   private
  70     mTileSize: Integer;
  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
  76     mLastQuery: Integer;
  77     mUsedCells: Integer;
  78     mProxies: array of TBodyProxyRec;
  79     mProxyFree: TBodyProxy; // free
  80     mProxyCount: Integer; // currently used
  81     mProxyMaxCount: Integer;
  82
  83   private
  84     function allocCell: Integer;
  85     procedure freeCell (idx: Integer); // `next` is simply overwritten
  86
  87     function allocProxy (aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer): TBodyProxy;
  88     procedure freeProxy (body: TBodyProxy);
  89
  90     procedure insert (body: TBodyProxy);
  91     procedure remove (body: TBodyProxy);
  92
  93     function forGridRect (x, y, w, h: Integer; cb: GridInternalCB): Boolean;
  94
  95   public
  96     constructor Create (aMinPixX, aMinPixY, aPixWidth, aPixHeight: Integer; aTileSize: Integer=GridDefaultTileSize);
  97     destructor Destroy (); override;
  98
  99     function insertBody (aObj: TObject; ax, ay, aWidth, aHeight: Integer; aTag: Integer=0): TBodyProxy;
 100     procedure removeBody (aObj: TBodyProxy); // WARNING! this WILL destroy proxy!
 101
 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);
 105
 106     function forEachInAABB (x, y, w, h: Integer; cb: GridQueryCB): Boolean;
 107
 108     function getProxyForBody (aObj: TObject; x, y, w, h: Integer): TBodyProxy;
 109
 110     procedure dumpStats ();
 111   end;
 112
 113
 114 type
 115   TBinaryHeapLessFn = function (a, b: TObject): Boolean;
 116
 117   TBinaryHeapObj = class(TObject)
 118   private
 119     elem: array of TObject;
 120     elemUsed: Integer;
 121     lessfn: TBinaryHeapLessFn;
 122
 123   private
 124     procedure heapify (root: Integer);
 125
 126   public
 127     constructor Create (alessfn: TBinaryHeapLessFn);
 128     destructor Destroy (); override;
 129
 130     procedure clear ();
 131
 132     procedure insert (val: TObject);
 133
 134     function front (): TObject;
 135     procedure popFront ();
 136
 137     property count: Integer read elemUsed;
 138   end;
 139
 140
 141 implementation
 142
 143 uses
 144   SysUtils;
 145
 146
 147 // ////////////////////////////////////////////////////////////////////////// //
 148 (*
 149 constructor TBodyProxy.Create (aGrid: TBodyGrid; aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer);
 150 begin
 151   mGrid := aGrid;
 152   setup(aX, aY, aWidth, aHeight, aObj, aTag);
 153 end;
 154
 155
 156 destructor TBodyProxy.Destroy ();
 157 begin
 158   inherited;
 159 end;
 160 *)
 161
 162
 163 procedure TBodyProxyRec.setup (aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer);
 164 begin
 165   mX := aX;
 166   mY := aY;
 167   mWidth := aWidth;
 168   mHeight := aHeight;
 169   mQueryMark := 0;
 170   mObj := aObj;
 171   mTag := aTag;
 172   nextLink := -1;
 173 end;
 174
 175
 176 // ////////////////////////////////////////////////////////////////////////// //
 177 constructor TBodyGrid.Create (aMinPixX, aMinPixY, aPixWidth, aPixHeight: Integer; aTileSize: Integer=GridDefaultTileSize);
 178 var
 179   idx: Integer;
 180 begin
 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;
 186   mMinX := aMinPixX;
 187   mMinY := aMinPixY;
 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);
 193   mFreeCell := 0;
 194   // init free list
 195   for idx := 0 to High(mCells) do
 196   begin
 197     mCells[idx].body := -1;
 198     mCells[idx].next := idx+1;
 199   end;
 200   mCells[High(mCells)].next := -1; // last cell
 201   // init grid
 202   for idx := 0 to High(mGrid) do mGrid[idx] := -1;
 203   // init proxies
 204   for idx := 0 to High(mProxies) do mProxies[idx].nextLink := idx+1;
 205   mProxies[High(mProxies)].nextLink := -1;
 206   mLastQuery := 0;
 207   mUsedCells := 0;
 208   mProxyFree := 0;
 209   mProxyCount := 0;
 210   mProxyMaxCount := 0;
 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);
 212 end;
 213
 214
 215 destructor TBodyGrid.Destroy ();
 216 var
 217   px: TBodyProxy;
 218 begin
 219   mCells := nil;
 220   mGrid := nil;
 221   mProxies := nil;
 222   inherited;
 223 end;
 224
 225
 226 procedure TBodyGrid.dumpStats ();
 227 var
 228   idx, mcb, cidx, cnt: Integer;
 229 begin
 230   mcb := 0;
 231   for idx := 0 to High(mGrid) do
 232   begin
 233     cidx := mGrid[idx];
 234     cnt := 0;
 235     while cidx >= 0 do
 236     begin
 237       Inc(cnt);
 238       cidx := mCells[cidx].next;
 239     end;
 240     if (mcb < cnt) then mcb := cnt;
 241   end;
 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);
 243 end;
 244
 245
 246 function TBodyGrid.allocCell: Integer;
 247 var
 248   idx: Integer;
 249 begin
 250   if (mFreeCell < 0) then
 251   begin
 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
 256     begin
 257       mCells[idx].body := -1;
 258       mCells[idx].next := idx+1;
 259     end;
 260     mCells[High(mCells)].next := -1; // last cell
 261   end;
 262   result := mFreeCell;
 263   mFreeCell := mCells[result].next;
 264   mCells[result].next := -1;
 265   Inc(mUsedCells);
 266   //e_WriteLog(Format('grid: allocated new cell #%d (total: %d)', [result, mUsedCells]), MSG_NOTIFY);
 267 end;
 268
 269
 270 procedure TBodyGrid.freeCell (idx: Integer);
 271 begin
 272   if (idx >= 0) and (idx < High(mCells)) then
 273   begin
 274     if mCells[idx].body = -1 then exit; // the thing that should not be
 275     mCells[idx].body := -1;
 276     mCells[idx].next := mFreeCell;
 277     mFreeCell := idx;
 278     Dec(mUsedCells);
 279   end;
 280 end;
 281
 282
 283 function TBodyGrid.allocProxy (aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer): TBodyProxy;
 284 var
 285   olen, idx: Integer;
 286   px: PBodyProxyRec;
 287 begin
 288   if (mProxyFree = -1) then
 289   begin
 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;
 295     mProxyFree := olen;
 296   end;
 297   // get one from list
 298   result := mProxyFree;
 299   px := @mProxies[result];
 300   mProxyFree := px.nextLink;
 301   px.setup(aX, aY, aWidth, aHeight, aObj, aTag);
 302   // add to used list
 303   px.nextLink := -1;
 304   // statistics
 305   Inc(mProxyCount);
 306   if (mProxyMaxCount < mProxyCount) then mProxyMaxCount := mProxyCount;
 307 end;
 308
 309 procedure TBodyGrid.freeProxy (body: TBodyProxy);
 310 begin
 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?)');
 313   // add to free list
 314   mProxies[body].mObj := nil;
 315   mProxies[body].nextLink := mProxyFree;
 316   mProxyFree := body;
 317   Dec(mProxyCount);
 318 end;
 319
 320
 321 function TBodyGrid.forGridRect (x, y, w, h: Integer; cb: GridInternalCB): Boolean;
 322 var
 323   gx, gy: Integer;
 324 begin
 325   result := false;
 326   if (w < 1) or (h < 1) or not assigned(cb) then exit;
 327   // fix coords
 328   Dec(x, mMinX);
 329   Dec(y, mMinY);
 330   // go on
 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
 334   begin
 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
 338     begin
 339       if (gx < 0) then continue;
 340       if (gx >= mWidth) then break;
 341       if (cb(gy*mWidth+gx)) then begin result := true; exit; end;
 342     end;
 343   end;
 344 end;
 345
 346
 347 procedure TBodyGrid.insert (body: TBodyProxy);
 348
 349   function inserter (grida: Integer): Boolean;
 350   var
 351     cidx: Integer;
 352   begin
 353     result := false; // never stop
 354     // add body to the given grid cell
 355     cidx := allocCell();
 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;
 360   end;
 361
 362 var
 363   px: PBodyProxyRec;
 364 begin
 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);
 368 end;
 369
 370
 371 // absolutely not tested
 372 procedure TBodyGrid.remove (body: TBodyProxy);
 373
 374   function remover (grida: Integer): Boolean;
 375   var
 376     pidx, idx, tmp: Integer;
 377   begin
 378     result := false; // never stop
 379     // find and remove cell
 380     pidx := -1;
 381     idx := mGrid[grida];
 382     while idx >= 0 do
 383     begin
 384       tmp := mCells[idx].next;
 385       if (mCells[idx].body = body) then
 386       begin
 387         if (pidx = -1) then mGrid[grida] := tmp else mCells[pidx].next := tmp;
 388         freeCell(idx);
 389         break; // assume that we cannot have one object added to bucket twice
 390       end
 391       else
 392       begin
 393         pidx := idx;
 394       end;
 395       idx := tmp;
 396     end;
 397   end;
 398
 399 var
 400   px: PBodyProxyRec;
 401 begin
 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);
 405 end;
 406
 407
 408 function TBodyGrid.insertBody (aObj: TObject; aX, aY, aWidth, aHeight: Integer; aTag: Integer=0): TBodyProxy;
 409 begin
 410   result := allocProxy(aX, aY, aWidth, aHeight, aObj, aTag);
 411   insert(result);
 412 end;
 413
 414
 415 procedure TBodyGrid.removeBody (aObj: TBodyProxy);
 416 begin
 417   if (aObj < 0) or (aObj > High(mProxies)) then exit; // just in case
 418   removeBody(aObj);
 419   freeProxy(aObj);
 420 end;
 421
 422
 423 procedure TBodyGrid.moveResizeBody (body: TBodyProxy; dx, dy, sx, sy: Integer);
 424 var
 425   px: PBodyProxyRec;
 426 begin
 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;
 429   remove(body);
 430   px := @mProxies[body];
 431   Inc(px.mX, dx);
 432   Inc(px.mY, dy);
 433   Inc(px.mWidth, sx);
 434   Inc(px.mHeight, sy);
 435   insert(body);
 436 end;
 437
 438 procedure TBodyGrid.moveBody (body: TBodyProxy; dx, dy: Integer);
 439 begin
 440   moveResizeBody(body, dx, dy, 0, 0);
 441 end;
 442
 443 procedure TBodyGrid.resizeBody (body: TBodyProxy; sx, sy: Integer);
 444 begin
 445   moveResizeBody(body, 0, 0, sx, sy);
 446 end;
 447
 448
 449 function TBodyGrid.forEachInAABB (x, y, w, h: Integer; cb: GridQueryCB): Boolean;
 450   function iterator (grida: Integer): Boolean;
 451   var
 452     idx: Integer;
 453     px: PBodyProxyRec;
 454   begin
 455     result := false;
 456     idx := mGrid[grida];
 457     while (idx >= 0) do
 458     begin
 459       if (mCells[idx].body <> -1) then
 460       begin
 461         px := @mProxies[mCells[idx].body];
 462         if (px.mQueryMark <> mLastQuery) then
 463         begin
 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;
 467         end;
 468       end;
 469       idx := mCells[idx].next;
 470     end;
 471   end;
 472
 473 var
 474   idx: Integer;
 475 begin
 476   result := false;
 477   if not assigned(cb) then exit;
 478
 479   // increase query counter
 480   Inc(mLastQuery);
 481   if (mLastQuery = 0) then
 482   begin
 483     // just in case of overflow
 484     mLastQuery := 1;
 485     for idx := 0 to High(mProxies) do mProxies[idx].mQueryMark := 0;
 486   end;
 487   //e_WriteLog(Format('grid: query #%d: (%d,%d)-(%dx%d)', [mLastQuery, minx, miny, maxx, maxy]), MSG_NOTIFY);
 488
 489   result := forGridRect(x, y, w, h, iterator);
 490 end;
 491
 492
 493 function TBodyGrid.getProxyForBody (aObj: TObject; x, y, w, h: Integer): TBodyProxy;
 494 var
 495   res: TBodyProxy = -1;
 496
 497   function iterator (grida: Integer): Boolean;
 498   var
 499     idx: Integer;
 500   begin
 501     result := false;
 502     idx := mGrid[grida];
 503     while idx >= 0 do
 504     begin
 505       if (mCells[idx].body <> -1) and (mProxies[mCells[idx].body].mObj = aObj) then
 506       begin
 507         result := true;
 508         res := mCells[idx].body;
 509         exit;
 510       end;
 511       idx := mCells[idx].next;
 512     end;
 513   end;
 514
 515 begin
 516   result := -1;
 517   if (aObj = nil) then exit;
 518   forGridRect(x, y, w, h, iterator);
 519   result := res;
 520 end;
 521
 522
 523 // ////////////////////////////////////////////////////////////////////////// //
 524 constructor TBinaryHeapObj.Create (alessfn: TBinaryHeapLessFn);
 525 begin
 526   if not assigned(alessfn) then raise Exception.Create('wutafuck?!');
 527   lessfn := alessfn;
 528   SetLength(elem, 8192); // 'cause why not?
 529   elemUsed := 0;
 530 end;
 531
 532
 533 destructor TBinaryHeapObj.Destroy ();
 534 begin
 535   inherited;
 536 end;
 537
 538
 539 procedure TBinaryHeapObj.clear ();
 540 begin
 541   elemUsed := 0;
 542 end;
 543
 544
 545 procedure TBinaryHeapObj.heapify (root: Integer);
 546 var
 547   smallest, right: Integer;
 548   tmp: TObject;
 549 begin
 550   while true do
 551   begin
 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;
 558     // swap
 559     tmp := elem[root];
 560     elem[root] := elem[smallest];
 561     elem[smallest] := tmp;
 562     root := smallest;
 563   end;
 564 end;
 565
 566
 567 procedure TBinaryHeapObj.insert (val: TObject);
 568 var
 569   i, par: Integer;
 570 begin
 571   if (val = nil) then exit;
 572   i := elemUsed;
 573   if (i = Length(elem)) then SetLength(elem, Length(elem)+16384); // arbitrary number
 574   Inc(elemUsed);
 575   while (i <> 0) do
 576   begin
 577     par := (i-1) div 2; // parent
 578     if not lessfn(val, elem[par]) then break;
 579     elem[i] := elem[par];
 580     i := par;
 581   end;
 582   elem[i] := val;
 583 end;
 584
 585 function TBinaryHeapObj.front (): TObject;
 586 begin
 587   if elemUsed > 0 then result := elem[0] else result := nil;
 588 end;
 589
 590
 591 procedure TBinaryHeapObj.popFront ();
 592 begin
 593   if (elemUsed > 0) then
 594   begin
 595     Dec(elemUsed);
 596     elem[0] := elem[elemUsed];
 597     heapify(0);
 598   end;
 599 end;
 600
 601
 602 end.