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