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