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   TBodyGrid = class(TObject)
  66   private
  67     mTileSize: Integer;
  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
  72     mLastQuery: Integer;
  73     mUsedCells: Integer;
  74     mProxyFree: TBodyProxy; // free
  75     mProxyList: TBodyProxy; // used
  76     mProxyCount: Integer; // total allocated
  77
  78   private
  79     function allocCell: Integer;
  80     procedure freeCell (idx: Integer); // `next` is simply overwritten
  81
  82     function allocProxy (aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer): TBodyProxy;
  83     procedure freeProxy (body: TBodyProxy);
  84
  85     procedure insert (body: TBodyProxy);
  86     procedure remove (body: TBodyProxy);
  87
  88   public
  89     constructor Create (aPixWidth, aPixHeight: Integer; aTileSize: Integer=GridDefaultTileSize);
  90     destructor Destroy (); override;
  91
  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!
  94
  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);
  98
  99     function forEachInAABB (x, y, w, h: Integer; cb: GridQueryCB): Boolean;
 100
 101     function getProxyForBody (aObj: TObject; x, y, w, h: Integer): TBodyProxy;
 102
 103     procedure dumpStats ();
 104   end;
 105
 106
 107 type
 108   TBinaryHeapLessFn = function (a, b: TObject): Boolean;
 109
 110   TBinaryHeapObj = class(TObject)
 111   private
 112     elem: array of TObject;
 113     elemUsed: Integer;
 114     lessfn: TBinaryHeapLessFn;
 115
 116   private
 117     procedure heapify (root: Integer);
 118
 119   public
 120     constructor Create (alessfn: TBinaryHeapLessFn);
 121     destructor Destroy (); override;
 122
 123     procedure clear ();
 124
 125     procedure insert (val: TObject);
 126
 127     function front (): TObject;
 128     procedure popFront ();
 129
 130     property count: Integer read elemUsed;
 131   end;
 132
 133
 134 implementation
 135
 136 uses
 137   SysUtils;
 138
 139
 140 // ////////////////////////////////////////////////////////////////////////// //
 141 constructor TBodyProxy.Create (aGrid: TBodyGrid; aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer);
 142 begin
 143   mGrid := aGrid;
 144   setup(aX, aY, aWidth, aHeight, aObj, aTag);
 145 end;
 146
 147
 148 destructor TBodyProxy.Destroy ();
 149 begin
 150   inherited;
 151 end;
 152
 153
 154 procedure TBodyProxy.setup (aX, aY, aWidth, aHeight: Integer; aObj: TObject; aTag: Integer);
 155 begin
 156   mX := aX;
 157   mY := aY;
 158   mWidth := aWidth;
 159   mHeight := aHeight;
 160   mQueryMark := 0;
 161   mObj := aObj;
 162   mTag := aTag;
 163   prevLink := nil;
 164   nextLink := nil;
 165 end;
 166
 167
 168 // ////////////////////////////////////////////////////////////////////////// //
 169 constructor TBodyGrid.Create (aPixWidth, aPixHeight: Integer; aTileSize: Integer=GridDefaultTileSize);
 170 var
 171   idx: Integer;
 172 begin
 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);
 182   mFreeCell := 0;
 183   // init free list
 184   for idx := 0 to High(mCells) do
 185   begin
 186     mCells[idx].body := nil;
 187     mCells[idx].next := idx+1;
 188   end;
 189   mCells[High(mCells)].next := -1; // last cell
 190   // init grid
 191   for idx := 0 to High(mGrid) do mGrid[idx] := -1;
 192   mLastQuery := 0;
 193   mUsedCells := 0;
 194   mProxyFree := nil;
 195   mProxyList := nil;
 196   mProxyCount := 0;
 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);
 198 end;
 199
 200
 201 destructor TBodyGrid.Destroy ();
 202 var
 203   px: TBodyProxy;
 204 begin
 205   // free all owned proxies
 206   while mProxyFree <> nil do
 207   begin
 208     px := mProxyFree;
 209     mProxyFree := px.nextLink;
 210     px.Free();
 211   end;
 212
 213   while mProxyList <> nil do
 214   begin
 215     px := mProxyList;
 216     mProxyList := px.nextLink;
 217     px.Free();
 218   end;
 219
 220   mCells := nil;
 221   mGrid := 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; proxies allocated: %d', [mWidth, mHeight, mTileSize, mWidth*mTileSize, mHeight*mTileSize, mUsedCells, mcb, 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 := nil;
 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 = nil then exit; // the thing that should not be
 275     mCells[idx].body := nil;
 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 begin
 285   if (mProxyFree = nil) then
 286   begin
 287     // no free proxies, create new
 288     result := TBodyProxy.Create(self, aX, aY, aWidth, aHeight, aObj, aTag);
 289     Inc(mProxyCount);
 290   end
 291   else
 292   begin
 293     // get one from list
 294     result := mProxyFree;
 295     mProxyFree := result.nextLink;
 296     result.setup(aX, aY, aWidth, aHeight, aObj, aTag);
 297   end;
 298   // add to used list
 299   result.nextLink := mProxyList;
 300   if (mProxyList <> nil) then mProxyList.prevLink := result;
 301   mProxyList := result;
 302 end;
 303
 304 procedure TBodyGrid.freeProxy (body: TBodyProxy);
 305 begin
 306   if body = nil then exit; // just in case
 307   // remove from used list
 308   if (body.prevLink = nil) then
 309   begin
 310     // this must be head
 311     if (body <> mProxyList) then raise Exception.Create('wutafuuuuu in grid?');
 312     mProxyList := body.nextLink;
 313   end
 314   else
 315   begin
 316     body.prevLink.nextLink := body.nextLink;
 317   end;
 318   if (body.nextLink <> nil) then body.nextLink.prevLink := body.prevLink;
 319   // add to free list
 320   //body.mObj := nil; //WARNING! DON'T DO THIS! `removeBody()` depends on valid mObj
 321   body.prevLink := nil;
 322   body.nextLink := mProxyFree;
 323   mProxyFree := body;
 324 end;
 325
 326
 327 procedure TBodyGrid.insert (body: TBodyProxy);
 328 var
 329   dx, dy, gx, gy, cidx: Integer;
 330 begin
 331   if body = nil then exit;
 332   if (body.mWidth < 1) or (body.mHeight < 1) then exit;
 333   // out of grid?
 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;
 338   dy := 0;
 339   while (dy < body.mHeight) do
 340   begin
 341     if (gy >= 0) and (gy < mHeight) then
 342     begin
 343       dx := 0;
 344       gx := body.mX div mTileSize;
 345       while (dx < body.mWidth) do
 346       begin
 347         if (gx >= 0) and (gx < mWidth) then
 348         begin
 349           //e_WriteLog(Format('  00: allocating cell for grid coords (%d,%d), body coords:(%d,%d)', [gx, gy, dx, dy]), MSG_NOTIFY);
 350           cidx := allocCell();
 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);
 356         end;
 357         Inc(dx, mTileSize);
 358         Inc(gx);
 359       end;
 360     end;
 361     Inc(dy, mTileSize);
 362     Inc(gy);
 363   end;
 364 end;
 365
 366
 367 // absolutely not tested
 368 procedure TBodyGrid.remove (body: TBodyProxy);
 369 var
 370   dx, dy, gx, gy, idx, pidx, tmp: Integer;
 371 begin
 372   if body = nil then exit;
 373   if (body.mWidth < 1) or (body.mHeight < 1) then exit;
 374   // out of grid?
 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;
 378   dy := 0;
 379   pidx := -1;
 380   while (dy < body.mHeight) do
 381   begin
 382     if (gy >= 0) and (gy < mHeight) then
 383     begin
 384       dx := 0;
 385       gx := body.mX div mTileSize;
 386       while (dx < body.mWidth) do
 387       begin
 388         if (gx >= 0) and (gx < mWidth) then
 389         begin
 390           // find and remove cell
 391           pidx := -1;
 392           idx := mGrid[gy*mWidth+gx];
 393           while idx >= 0 do
 394           begin
 395             tmp := mCells[idx].next;
 396             if mCells[idx].body = body then
 397             begin
 398               if pidx = -1 then mGrid[gy*mWidth+gx] := tmp else mCells[pidx].next := tmp;
 399               freeCell(idx);
 400             end
 401             else
 402             begin
 403               pidx := idx;
 404             end;
 405             idx := tmp;
 406           end;
 407         end;
 408         Inc(dx, mTileSize);
 409         Inc(gx);
 410       end;
 411     end;
 412     Inc(dy, mTileSize);
 413     Inc(gy);
 414   end;
 415 end;
 416
 417
 418 function TBodyGrid.insertBody (aObj: TObject; aX, aY, aWidth, aHeight: Integer; aTag: Integer=0): TBodyProxy;
 419 begin
 420   result := allocProxy(aX, aY, aWidth, aHeight, aObj, aTag);
 421   insert(result);
 422 end;
 423
 424
 425 // WARNING! this will NOT destroy proxy!
 426 procedure TBodyGrid.removeBody (aObj: TBodyProxy);
 427 begin
 428   if aObj = nil then exit;
 429   if (aObj.mGrid <> self) then raise Exception.Create('trying to remove alien proxy from grid');
 430   removeBody(aObj);
 431   //HACK!
 432   freeProxy(aObj);
 433   if (mProxyFree <> aObj) then raise Exception.Create('grid deletion invariant fucked');
 434   mProxyFree := aObj.nextLink;
 435   aObj.nextLink := nil;
 436 end;
 437
 438
 439 procedure TBodyGrid.moveResizeBody (body: TBodyProxy; dx, dy, sx, sy: Integer);
 440 begin
 441   if (body = nil) or ((dx = 0) and (dy = 0) and (sx = 0) and (sy = 0)) then exit;
 442   remove(body);
 443   Inc(body.mX, dx);
 444   Inc(body.mY, dy);
 445   Inc(body.mWidth, sx);
 446   Inc(body.mHeight, sy);
 447   insert(body);
 448 end;
 449
 450 procedure TBodyGrid.moveBody (body: TBodyProxy; dx, dy: Integer);
 451 begin
 452   moveResizeBody(body, dx, dy, 0, 0);
 453 end;
 454
 455 procedure TBodyGrid.resizeBody (body: TBodyProxy; sx, sy: Integer);
 456 begin
 457   moveResizeBody(body, 0, 0, sx, sy);
 458 end;
 459
 460
 461 function TBodyGrid.forEachInAABB (x, y, w, h: Integer; cb: GridQueryCB): Boolean;
 462 var
 463   gx, gy, idx: Integer;
 464   minx, miny, maxx, maxy: Integer;
 465 begin
 466   result := false;
 467   if not assigned(cb) then exit;
 468   if (w < 1) or (h < 1) then exit;
 469   minx := x;
 470   miny := y;
 471   maxx := x+w-1;
 472   maxy := y+h-1;
 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
 477   Inc(mLastQuery);
 478   if (mLastQuery = 0) then
 479   begin
 480     // just in case of overflow
 481     mLastQuery := 1;
 482     for idx := 0 to High(mCells) do if (mCells[idx].body <> nil) then mCells[idx].body.mQueryMark := 0;
 483   end;
 484   //e_WriteLog(Format('grid: query #%d: (%d,%d)-(%dx%d)', [mLastQuery, minx, miny, maxx, maxy]), MSG_NOTIFY);
 485   // process grid
 486   for gy := miny div mTileSize to maxy div mTileSize do
 487   begin
 488     if (gy < 0) then continue;
 489     if (gy >= mHeight) then break;
 490     for gx := minx div mTileSize to maxx div mTileSize do
 491     begin
 492       if (gx < 0) then continue;
 493       if (gx >= mWidth) then break;
 494       idx := mGrid[gy*mWidth+gx];
 495       while idx >= 0 do
 496       begin
 497         if (mCells[idx].body <> nil) and (mCells[idx].body.mQueryMark <> mLastQuery) then
 498         begin
 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;
 502         end;
 503         idx := mCells[idx].next;
 504       end;
 505     end;
 506   end;
 507 end;
 508
 509
 510 function TBodyGrid.getProxyForBody (aObj: TObject; x, y, w, h: Integer): TBodyProxy;
 511
 512   function qq (obj: TObject; tag: Integer): Boolean;
 513   begin
 514     result := (obj = aObj);
 515   end;
 516
 517 begin
 518   result := nil;
 519   forEachInAABB(x, y, w, h, qq);
 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.