DEADSOFTWARE

turned on typeinfo (preparing for text-mode maps magic)
[d2df-sdl.git] / 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 // universal spatial grid
17 {$INCLUDE ../shared/a_modes.inc}
18 {$IF DEFINED(D2F_DEBUG)}
19 {.$DEFINE D2F_DEBUG_RAYTRACE}
20 {.$DEFINE D2F_DEBUG_XXQ}
21 {.$DEFINE D2F_DEBUG_MOVER}
22 {$ENDIF}
23 {.$DEFINE GRID_USE_ORTHO_ACCEL}
24 unit g_grid;
26 interface
29 type
30 TBodyProxyId = Integer;
32 generic TBodyGridBase<ITP> = class(TObject)
33 public
34 type TGridQueryCB = function (obj: ITP; tag: Integer): Boolean is nested; // return `true` to stop
35 type TGridRayQueryCB = function (obj: ITP; tag: Integer; x, y, prevx, prevy: Integer): Boolean is nested; // return `true` to stop
36 type TGridAlongQueryCB = function (obj: ITP; tag: Integer): Boolean is nested; // return `true` to stop
38 type TCellQueryCB = procedure (x, y: Integer) is nested; // top-left cell corner coords
40 const TagDisabled = $40000000;
41 const TagFullMask = $3fffffff;
43 private
44 const
45 GridDefaultTileSize = 32; // must be power of two!
46 GridCellBucketSize = 8; // WARNING! can't be less than 2!
48 private
49 type
50 PBodyProxyRec = ^TBodyProxyRec;
51 TBodyProxyRec = record
52 private
53 mX, mY, mWidth, mHeight: Integer; // aabb
54 mQueryMark: LongWord; // was this object visited at this query?
55 mObj: ITP;
56 mTag: Integer; // `TagDisabled` set: disabled ;-)
57 nextLink: TBodyProxyId; // next free or nothing
59 private
60 procedure setup (aX, aY, aWidth, aHeight: Integer; aObj: ITP; aTag: Integer);
61 end;
63 PGridCell = ^TGridCell;
64 TGridCell = record
65 bodies: array [0..GridCellBucketSize-1] of Integer; // -1: end of list
66 next: Integer; // in this cell; index in mCells
67 end;
69 TGridInternalCB = function (grida: Integer; bodyId: TBodyProxyId): Boolean of object; // return `true` to stop
71 private
72 //mTileSize: Integer;
73 const mTileSize = GridDefaultTileSize;
75 public
76 const tileSize = mTileSize;
78 private
79 mMinX, mMinY: Integer; // so grids can start at any origin
80 mWidth, mHeight: Integer; // in tiles
81 mGrid: array of Integer; // mWidth*mHeight, index in mCells
82 mCells: array of TGridCell; // cell pool
83 mFreeCell: Integer; // first free cell index or -1
84 mLastQuery: LongWord;
85 mUsedCells: Integer;
86 mProxies: array of TBodyProxyRec;
87 mProxyFree: TBodyProxyId; // free
88 mProxyCount: Integer; // currently used
89 mProxyMaxCount: Integer;
91 public
92 dbgShowTraceLog: Boolean;
93 {$IF DEFINED(D2F_DEBUG)}
94 dbgRayTraceTileHitCB: TCellQueryCB;
95 {$ENDIF}
97 private
98 function allocCell (): Integer;
99 procedure freeCell (idx: Integer); // `next` is simply overwritten
101 function allocProxy (aX, aY, aWidth, aHeight: Integer; aObj: ITP; aTag: Integer): TBodyProxyId;
102 procedure freeProxy (body: TBodyProxyId);
104 procedure insertInternal (body: TBodyProxyId);
105 procedure removeInternal (body: TBodyProxyId);
107 function forGridRect (x, y, w, h: Integer; cb: TGridInternalCB; bodyId: TBodyProxyId): Boolean;
109 function inserter (grida: Integer; bodyId: TBodyProxyId): Boolean;
110 function remover (grida: Integer; bodyId: TBodyProxyId): Boolean;
112 function getProxyEnabled (pid: TBodyProxyId): Boolean; inline;
113 procedure setProxyEnabled (pid: TBodyProxyId; val: Boolean); inline;
115 function getGridWidthPx (): Integer; inline;
116 function getGridHeightPx (): Integer; inline;
118 public
119 constructor Create (aMinPixX, aMinPixY, aPixWidth, aPixHeight: Integer{; aTileSize: Integer=GridDefaultTileSize});
120 destructor Destroy (); override;
122 function insertBody (aObj: ITP; ax, ay, aWidth, aHeight: Integer; aTag: Integer=-1): TBodyProxyId;
123 procedure removeBody (body: TBodyProxyId); // WARNING! this WILL destroy proxy!
125 procedure moveBody (body: TBodyProxyId; nx, ny: Integer);
126 procedure resizeBody (body: TBodyProxyId; nw, nh: Integer);
127 procedure moveResizeBody (body: TBodyProxyId; nx, ny, nw, nh: Integer);
129 function insideGrid (x, y: Integer): Boolean; inline;
131 // `false` if `body` is surely invalid
132 function getBodyXY (body: TBodyProxyId; out rx, ry: Integer): Boolean; inline;
133 function getBodyWH (body: TBodyProxyId; out rw, rh: Integer): Boolean; inline;
134 function getBodyDims (body: TBodyProxyId; out rx, ry, rw, rh: Integer): Boolean; inline;
136 //WARNING: don't modify grid while any query is in progress (no checks are made!)
137 // you can set enabled/disabled flag, tho (but iterator can still return objects disabled inside it)
138 // no callback: return `true` on the first hit
139 function forEachInAABB (x, y, w, h: Integer; cb: TGridQueryCB; tagmask: Integer=-1; allowDisabled: Boolean=false): ITP;
141 //WARNING: don't modify grid while any query is in progress (no checks are made!)
142 // you can set enabled/disabled flag, tho (but iterator can still return objects disabled inside it)
143 // no callback: return object on the first hit or nil
144 function forEachAtPoint (x, y: Integer; cb: TGridQueryCB; tagmask: Integer=-1; exittag: PInteger=nil): ITP;
146 //WARNING: don't modify grid while any query is in progress (no checks are made!)
147 // you can set enabled/disabled flag, tho (but iterator can still return objects disabled inside it)
148 // cb with `(nil)` will be called before processing new tile
149 // no callback: return object of the nearest hit or nil
150 // if `inverted` is true, trace will register bodies *exluding* tagmask
151 //WARNING: don't change tags in callbacks here!
152 function traceRay (const x0, y0, x1, y1: Integer; cb: TGridRayQueryCB; tagmask: Integer=-1): ITP; overload;
153 function traceRay (out ex, ey: Integer; const ax0, ay0, ax1, ay1: Integer; cb: TGridRayQueryCB; tagmask: Integer=-1): ITP;
155 //function traceOrthoRayWhileIn (const x0, y0, x1, y1: Integer; tagmask: Integer=-1): ITP; overload;
156 //function traceOrthoRayWhileIn (out ex, ey: Integer; const ax0, ay0, ax1, ay1: Integer; tagmask: Integer=-1): ITP;
158 //WARNING: don't modify grid while any query is in progress (no checks are made!)
159 // you can set enabled/disabled flag, tho (but iterator can still return objects disabled inside it)
160 // trace line along the grid, calling `cb` for all objects in passed cells, in no particular order
161 //WARNING: don't change tags in callbacks here!
162 function forEachAlongLine (const x0, y0, x1, y1: Integer; cb: TGridAlongQueryCB; tagmask: Integer=-1; log: Boolean=false): ITP;
164 // debug
165 procedure forEachBodyCell (body: TBodyProxyId; cb: TCellQueryCB);
166 function forEachInCell (x, y: Integer; cb: TGridQueryCB): ITP;
167 procedure dumpStats ();
169 //WARNING! no sanity checks!
170 property proxyEnabled[pid: TBodyProxyId]: Boolean read getProxyEnabled write setProxyEnabled;
172 property gridX0: Integer read mMinX;
173 property gridY0: Integer read mMinY;
174 property gridWidth: Integer read getGridWidthPx; // in pixels
175 property gridHeight: Integer read getGridHeightPx; // in pixels
176 end;
179 // you are not supposed to understand this
180 // returns `true` if there is an intersection, and enter coords
181 // enter coords will be equal to (x0, y0) if starting point is inside the box
182 // if result is `false`, `inx` and `iny` are undefined
183 function lineAABBIntersects (x0, y0, x1, y1: Integer; bx, by, bw, bh: Integer; out inx, iny: Integer): Boolean;
185 function distanceSq (x0, y0, x1, y1: Integer): Integer; inline;
187 procedure swapInt (var a: Integer; var b: Integer); inline;
188 function minInt (a, b: Integer): Integer; inline;
189 function maxInt (a, b: Integer): Integer; inline;
192 implementation
194 uses
195 SysUtils, e_log;
198 // ////////////////////////////////////////////////////////////////////////// //
199 procedure swapInt (var a: Integer; var b: Integer); inline; var t: Integer; begin t := a; a := b; b := t; end;
200 function minInt (a, b: Integer): Integer; inline; begin if (a < b) then result := a else result := b; end;
201 function maxInt (a, b: Integer): Integer; inline; begin if (a > b) then result := a else result := b; end;
203 function distanceSq (x0, y0, x1, y1: Integer): Integer; inline; begin result := (x1-x0)*(x1-x0)+(y1-y0)*(y1-y0); end;
206 // ////////////////////////////////////////////////////////////////////////// //
207 // you are not supposed to understand this
208 // returns `true` if there is an intersection, and enter coords
209 // enter coords will be equal to (x0, y0) if starting point is inside the box
210 // if result is `false`, `inx` and `iny` are undefined
211 function lineAABBIntersects (x0, y0, x1, y1: Integer; bx, by, bw, bh: Integer; out inx, iny: Integer): Boolean;
212 var
213 wx0, wy0, wx1, wy1: Integer; // window coordinates
214 stx, sty: Integer; // "steps" for x and y axes
215 dsx, dsy: Integer; // "lengthes" for x and y axes
216 dx2, dy2: Integer; // "double lengthes" for x and y axes
217 xd, yd: Integer; // current coord
218 e: Integer; // "error" (as in bresenham algo)
219 rem: Integer;
220 //!term: Integer;
221 d0, d1: PInteger;
222 xfixed: Boolean;
223 temp: Integer;
224 begin
225 result := false;
226 // why not
227 inx := x0;
228 iny := y0;
229 if (bw < 1) or (bh < 1) then exit; // impossible box
231 if (x0 = x1) and (y0 = y1) then
232 begin
233 // check this point
234 result := (x0 >= bx) and (y0 >= by) and (x0 < bx+bw) and (y0 < by+bh);
235 exit;
236 end;
238 // check if staring point is inside the box
239 if (x0 >= bx) and (y0 >= by) and (x0 < bx+bw) and (y0 < by+bh) then begin result := true; exit; end;
241 // clip rectange
242 wx0 := bx;
243 wy0 := by;
244 wx1 := bx+bw-1;
245 wy1 := by+bh-1;
247 // horizontal setup
248 if (x0 < x1) then
249 begin
250 // from left to right
251 if (x0 > wx1) or (x1 < wx0) then exit; // out of screen
252 stx := 1; // going right
253 end
254 else
255 begin
256 // from right to left
257 if (x1 > wx1) or (x0 < wx0) then exit; // out of screen
258 stx := -1; // going left
259 x0 := -x0;
260 x1 := -x1;
261 wx0 := -wx0;
262 wx1 := -wx1;
263 swapInt(wx0, wx1);
264 end;
266 // vertical setup
267 if (y0 < y1) then
268 begin
269 // from top to bottom
270 if (y0 > wy1) or (y1 < wy0) then exit; // out of screen
271 sty := 1; // going down
272 end
273 else
274 begin
275 // from bottom to top
276 if (y1 > wy1) or (y0 < wy0) then exit; // out of screen
277 sty := -1; // going up
278 y0 := -y0;
279 y1 := -y1;
280 wy0 := -wy0;
281 wy1 := -wy1;
282 swapInt(wy0, wy1);
283 end;
285 dsx := x1-x0;
286 dsy := y1-y0;
288 if (dsx < dsy) then
289 begin
290 d0 := @yd;
291 d1 := @xd;
292 swapInt(x0, y0);
293 swapInt(x1, y1);
294 swapInt(dsx, dsy);
295 swapInt(wx0, wy0);
296 swapInt(wx1, wy1);
297 swapInt(stx, sty);
298 end
299 else
300 begin
301 d0 := @xd;
302 d1 := @yd;
303 end;
305 dx2 := 2*dsx;
306 dy2 := 2*dsy;
307 xd := x0;
308 yd := y0;
309 e := 2*dsy-dsx;
310 //!term := x1;
312 xfixed := false;
313 if (y0 < wy0) then
314 begin
315 // clip at top
316 temp := dx2*(wy0-y0)-dsx;
317 xd += temp div dy2;
318 rem := temp mod dy2;
319 if (xd > wx1) then exit; // x is moved out of clipping rect, nothing to do
320 if (xd+1 >= wx0) then
321 begin
322 yd := wy0;
323 e -= rem+dsx;
324 if (rem > 0) then begin Inc(xd); e += dy2; end;
325 xfixed := true;
326 end;
327 end;
329 if (not xfixed) and (x0 < wx0) then
330 begin
331 // clip at left
332 temp := dy2*(wx0-x0);
333 yd += temp div dx2;
334 rem := temp mod dx2;
335 if (yd > wy1) or (yd = wy1) and (rem >= dsx) then exit;
336 xd := wx0;
337 e += rem;
338 if (rem >= dsx) then begin Inc(yd); e -= dx2; end;
339 end;
341 (*
342 if (y1 > wy1) then
343 begin
344 // clip at bottom
345 temp := dx2*(wy1-y0)+dsx;
346 term := x0+temp div dy2;
347 rem := temp mod dy2;
348 if (rem = 0) then Dec(term);
349 end;
351 if (term > wx1) then term := wx1; // clip at right
353 Inc(term); // draw last point
354 //if (term = xd) then exit; // this is the only point, get out of here
355 *)
357 if (sty = -1) then yd := -yd;
358 if (stx = -1) then begin xd := -xd; {!term := -term;} end;
359 //!dx2 -= dy2;
361 inx := d0^;
362 iny := d1^;
363 result := true;
364 end;
367 // ////////////////////////////////////////////////////////////////////////// //
368 procedure TBodyGridBase.TBodyProxyRec.setup (aX, aY, aWidth, aHeight: Integer; aObj: ITP; aTag: Integer);
369 begin
370 mX := aX;
371 mY := aY;
372 mWidth := aWidth;
373 mHeight := aHeight;
374 mQueryMark := 0;
375 mObj := aObj;
376 mTag := aTag;
377 nextLink := -1;
378 end;
381 // ////////////////////////////////////////////////////////////////////////// //
382 constructor TBodyGridBase.Create (aMinPixX, aMinPixY, aPixWidth, aPixHeight: Integer{; aTileSize: Integer=GridDefaultTileSize});
383 var
384 idx: Integer;
385 begin
386 dbgShowTraceLog := false;
387 {$IF DEFINED(D2F_DEBUG)}
388 dbgRayTraceTileHitCB := nil;
389 {$ENDIF}
391 if aTileSize < 1 then aTileSize := 1;
392 if aTileSize > 8192 then aTileSize := 8192; // arbitrary limit
393 mTileSize := aTileSize;
395 if (aPixWidth < mTileSize) then aPixWidth := mTileSize;
396 if (aPixHeight < mTileSize) then aPixHeight := mTileSize;
397 mMinX := aMinPixX;
398 mMinY := aMinPixY;
399 mWidth := (aPixWidth+mTileSize-1) div mTileSize;
400 mHeight := (aPixHeight+mTileSize-1) div mTileSize;
401 SetLength(mGrid, mWidth*mHeight);
402 SetLength(mCells, mWidth*mHeight);
403 SetLength(mProxies, 8192);
404 mFreeCell := 0;
405 // init free list
406 for idx := 0 to High(mCells) do
407 begin
408 mCells[idx].bodies[0] := -1;
409 mCells[idx].bodies[GridCellBucketSize-1] := -1; // "has free room" flag
410 mCells[idx].next := idx+1;
411 end;
412 mCells[High(mCells)].next := -1; // last cell
413 // init grid
414 for idx := 0 to High(mGrid) do mGrid[idx] := -1;
415 // init proxies
416 for idx := 0 to High(mProxies) do mProxies[idx].nextLink := idx+1;
417 mProxies[High(mProxies)].nextLink := -1;
418 mLastQuery := 0;
419 mUsedCells := 0;
420 mProxyFree := 0;
421 mProxyCount := 0;
422 mProxyMaxCount := 0;
423 e_WriteLog(Format('created grid with size: %dx%d (tile size: %d); pix: %dx%d', [mWidth, mHeight, mTileSize, mWidth*mTileSize, mHeight*mTileSize]), MSG_NOTIFY);
424 end;
427 destructor TBodyGridBase.Destroy ();
428 begin
429 mCells := nil;
430 mGrid := nil;
431 mProxies := nil;
432 inherited;
433 end;
436 // ////////////////////////////////////////////////////////////////////////// //
437 procedure TBodyGridBase.dumpStats ();
438 var
439 idx, mcb, cidx, cnt: Integer;
440 begin
441 mcb := 0;
442 for idx := 0 to High(mGrid) do
443 begin
444 cidx := mGrid[idx];
445 cnt := 0;
446 while cidx >= 0 do
447 begin
448 Inc(cnt);
449 cidx := mCells[cidx].next;
450 end;
451 if (mcb < cnt) then mcb := cnt;
452 end;
453 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);
454 end;
457 procedure TBodyGridBase.forEachBodyCell (body: TBodyProxyId; cb: TCellQueryCB);
458 var
459 g, f, cidx: Integer;
460 cc: PGridCell;
461 begin
462 if (body < 0) or (body > High(mProxies)) or not assigned(cb) then exit;
463 for g := 0 to High(mGrid) do
464 begin
465 cidx := mGrid[g];
466 while (cidx <> -1) do
467 begin
468 cc := @mCells[cidx];
469 for f := 0 to GridCellBucketSize-1 do
470 begin
471 if (cc.bodies[f] = -1) then break;
472 if (cc.bodies[f] = body) then cb((g mod mWidth)*mTileSize+mMinX, (g div mWidth)*mTileSize+mMinY);
473 end;
474 // next cell
475 cidx := cc.next;
476 end;
477 end;
478 end;
481 function TBodyGridBase.forEachInCell (x, y: Integer; cb: TGridQueryCB): ITP;
482 var
483 f, cidx: Integer;
484 cc: PGridCell;
485 begin
486 result := Default(ITP);
487 if not assigned(cb) then exit;
488 Dec(x, mMinX);
489 Dec(y, mMinY);
490 if (x < 0) or (y < 0) or (x >= mWidth*mTileSize) or (y > mHeight*mTileSize) then exit;
491 cidx := mGrid[(y div mTileSize)*mWidth+(x div mTileSize)];
492 while (cidx <> -1) do
493 begin
494 cc := @mCells[cidx];
495 for f := 0 to GridCellBucketSize-1 do
496 begin
497 if (cc.bodies[f] = -1) then break;
498 if cb(mProxies[cc.bodies[f]].mObj, mProxies[cc.bodies[f]].mTag) then begin result := mProxies[cc.bodies[f]].mObj; exit; end;
499 end;
500 // next cell
501 cidx := cc.next;
502 end;
503 end;
506 // ////////////////////////////////////////////////////////////////////////// //
507 function TBodyGridBase.getGridWidthPx (): Integer; inline; begin result := mWidth*mTileSize; end;
508 function TBodyGridBase.getGridHeightPx (): Integer; inline; begin result := mHeight*mTileSize; end;
511 function TBodyGridBase.insideGrid (x, y: Integer): Boolean; inline;
512 begin
513 // fix coords
514 Dec(x, mMinX);
515 Dec(y, mMinY);
516 result := (x >= 0) and (y >= 0) and (x < mWidth*mTileSize) and (y < mHeight*mTileSize);
517 end;
520 function TBodyGridBase.getBodyXY (body: TBodyProxyId; out rx, ry: Integer): Boolean; inline;
521 begin
522 if (body >= 0) and (body < Length(mProxies)) then
523 begin
524 with mProxies[body] do begin rx := mX; ry := mY; end;
525 result := true;
526 end
527 else
528 begin
529 rx := 0;
530 ry := 0;
531 result := false;
532 end;
533 end;
536 function TBodyGridBase.getBodyWH (body: TBodyProxyId; out rw, rh: Integer): Boolean; inline;
537 begin
538 if (body >= 0) and (body < Length(mProxies)) then
539 begin
540 with mProxies[body] do begin rw := mWidth; rh := mHeight; end;
541 result := true;
542 end
543 else
544 begin
545 rw := 0;
546 rh := 0;
547 result := false;
548 end;
549 end;
552 function TBodyGridBase.getBodyDims (body: TBodyProxyId; out rx, ry, rw, rh: Integer): Boolean; inline;
553 begin
554 if (body >= 0) and (body < Length(mProxies)) then
555 begin
556 with mProxies[body] do begin rx := mX; ry := mY; rw := mWidth; rh := mHeight; end;
557 result := true;
558 end
559 else
560 begin
561 rx := 0;
562 ry := 0;
563 rw := 0;
564 rh := 0;
565 result := false;
566 end;
567 end;
571 // ////////////////////////////////////////////////////////////////////////// //
572 function TBodyGridBase.getProxyEnabled (pid: TBodyProxyId): Boolean; inline;
573 begin
574 if (pid >= 0) then result := ((mProxies[pid].mTag and TagDisabled) = 0) else result := false;
575 end;
578 procedure TBodyGridBase.setProxyEnabled (pid: TBodyProxyId; val: Boolean); inline;
579 begin
580 if (pid >= 0) then
581 begin
582 if val then
583 begin
584 mProxies[pid].mTag := mProxies[pid].mTag and not TagDisabled;
585 end
586 else
587 begin
588 mProxies[pid].mTag := mProxies[pid].mTag or TagDisabled;
589 end;
590 end;
591 end;
594 // ////////////////////////////////////////////////////////////////////////// //
595 function TBodyGridBase.allocCell (): Integer;
596 var
597 idx: Integer;
598 pc: PGridCell;
599 begin
600 if (mFreeCell < 0) then
601 begin
602 // no free cells, want more
603 mFreeCell := Length(mCells);
604 SetLength(mCells, mFreeCell+32768); // arbitrary number
605 for idx := mFreeCell to High(mCells) do
606 begin
607 mCells[idx].bodies[0] := -1;
608 mCells[idx].bodies[GridCellBucketSize-1] := -1; // 'has free room' flag
609 mCells[idx].next := idx+1;
610 end;
611 mCells[High(mCells)].next := -1; // last cell
612 end;
613 result := mFreeCell;
614 pc := @mCells[result];
615 mFreeCell := pc.next;
616 pc.next := -1;
617 Inc(mUsedCells);
618 //e_WriteLog(Format('grid: allocated new cell #%d (total: %d)', [result, mUsedCells]), MSG_NOTIFY);
619 end;
622 procedure TBodyGridBase.freeCell (idx: Integer);
623 begin
624 if (idx >= 0) and (idx < Length(mCells)) then
625 begin
626 with mCells[idx] do
627 begin
628 bodies[0] := -1;
629 bodies[GridCellBucketSize-1] := -1; // 'has free room' flag
630 next := mFreeCell;
631 end;
632 mFreeCell := idx;
633 Dec(mUsedCells);
634 end;
635 end;
638 // ////////////////////////////////////////////////////////////////////////// //
639 function TBodyGridBase.allocProxy (aX, aY, aWidth, aHeight: Integer; aObj: ITP; aTag: Integer): TBodyProxyId;
640 var
641 olen, idx: Integer;
642 px: PBodyProxyRec;
643 begin
644 if (mProxyFree = -1) then
645 begin
646 // no free proxies, resize list
647 olen := Length(mProxies);
648 SetLength(mProxies, olen+8192); // arbitrary number
649 for idx := olen to High(mProxies) do mProxies[idx].nextLink := idx+1;
650 mProxies[High(mProxies)].nextLink := -1;
651 mProxyFree := olen;
652 end;
653 // get one from list
654 result := mProxyFree;
655 px := @mProxies[result];
656 mProxyFree := px.nextLink;
657 px.setup(aX, aY, aWidth, aHeight, aObj, aTag);
658 // add to used list
659 px.nextLink := -1;
660 // statistics
661 Inc(mProxyCount);
662 if (mProxyMaxCount < mProxyCount) then mProxyMaxCount := mProxyCount;
663 end;
665 procedure TBodyGridBase.freeProxy (body: TBodyProxyId);
666 begin
667 if (body < 0) or (body > High(mProxies)) then exit; // just in case
668 if (mProxyCount = 0) then raise Exception.Create('wutafuuuuu in grid (no allocated proxies, what i should free now?)');
669 // add to free list
670 mProxies[body].mObj := nil;
671 mProxies[body].nextLink := mProxyFree;
672 mProxyFree := body;
673 Dec(mProxyCount);
674 end;
677 // ////////////////////////////////////////////////////////////////////////// //
678 function TBodyGridBase.forGridRect (x, y, w, h: Integer; cb: TGridInternalCB; bodyId: TBodyProxyId): Boolean;
679 const
680 tsize = mTileSize;
681 var
682 gx, gy: Integer;
683 gw, gh: Integer;
684 begin
685 result := false;
686 if (w < 1) or (h < 1) or not assigned(cb) then exit;
687 // fix coords
688 Dec(x, mMinX);
689 Dec(y, mMinY);
690 // go on
691 if (x+w <= 0) or (y+h <= 0) then exit;
692 gw := mWidth;
693 gh := mHeight;
694 //tsize := mTileSize;
695 if (x >= gw*tsize) or (y >= gh*tsize) then exit;
696 for gy := y div tsize to (y+h-1) div tsize do
697 begin
698 if (gy < 0) then continue;
699 if (gy >= gh) then break;
700 for gx := x div tsize to (x+w-1) div tsize do
701 begin
702 if (gx < 0) then continue;
703 if (gx >= gw) then break;
704 result := cb(gy*gw+gx, bodyId);
705 if result then exit;
706 end;
707 end;
708 end;
711 // ////////////////////////////////////////////////////////////////////////// //
712 function TBodyGridBase.inserter (grida: Integer; bodyId: TBodyProxyId): Boolean;
713 var
714 cidx: Integer;
715 pc: Integer;
716 pi: PGridCell;
717 f: Integer;
718 begin
719 result := false; // never stop
720 // add body to the given grid cell
721 pc := mGrid[grida];
722 if (pc <> -1) then
723 begin
724 {$IF DEFINED(D2F_DEBUG)}
725 cidx := pc;
726 while (cidx <> -1) do
727 begin
728 pi := @mCells[cidx];
729 for f := 0 to GridCellBucketSize-1 do
730 begin
731 if (pi.bodies[f] = -1) then break;
732 if (pi.bodies[f] = bodyId) then raise Exception.Create('trying to insert already inserted proxy');
733 end;
734 cidx := pi.next;
735 end;
736 {$ENDIF}
737 cidx := pc;
738 while (cidx <> -1) do
739 begin
740 pi := @mCells[cidx];
741 // check "has room" flag
742 if (pi.bodies[GridCellBucketSize-1] = -1) then
743 begin
744 // can add here
745 for f := 0 to GridCellBucketSize-1 do
746 begin
747 if (pi.bodies[f] = -1) then
748 begin
749 pi.bodies[f] := bodyId;
750 if (f+1 < GridCellBucketSize) then pi.bodies[f+1] := -1;
751 exit;
752 end;
753 end;
754 raise Exception.Create('internal error in grid inserter');
755 end;
756 // no room, go to next cell in list (if there is any)
757 cidx := pi.next;
758 end;
759 // no room in cells, add new cell to list
760 end;
761 // either no room, or no cell at all
762 cidx := allocCell();
763 pi := @mCells[cidx];
764 pi.bodies[0] := bodyId;
765 pi.bodies[1] := -1;
766 pi.next := pc;
767 mGrid[grida] := cidx;
768 end;
770 procedure TBodyGridBase.insertInternal (body: TBodyProxyId);
771 var
772 px: PBodyProxyRec;
773 begin
774 if (body < 0) or (body > High(mProxies)) then exit; // just in case
775 px := @mProxies[body];
776 forGridRect(px.mX, px.mY, px.mWidth, px.mHeight, inserter, body);
777 end;
780 // assume that we cannot have one object added to bucket twice
781 function TBodyGridBase.remover (grida: Integer; bodyId: TBodyProxyId): Boolean;
782 var
783 f, c: Integer;
784 pidx, cidx: Integer;
785 pc: PGridCell;
786 begin
787 result := false; // never stop
788 // find and remove cell
789 pidx := -1; // previous cell index
790 cidx := mGrid[grida]; // current cell index
791 while (cidx <> -1) do
792 begin
793 pc := @mCells[cidx];
794 for f := 0 to GridCellBucketSize-1 do
795 begin
796 if (pc.bodies[f] = bodyId) then
797 begin
798 // i found her!
799 if (f = 0) and (pc.bodies[1] = -1) then
800 begin
801 // this cell contains no elements, remove it
802 if (pidx = -1) then mGrid[grida] := pc.next else mCells[pidx].next := pc.next;
803 freeCell(cidx);
804 exit;
805 end;
806 // remove element from bucket
807 for c := f to GridCellBucketSize-2 do
808 begin
809 pc.bodies[c] := pc.bodies[c+1];
810 if (pc.bodies[c] = -1) then break;
811 end;
812 pc.bodies[GridCellBucketSize-1] := -1; // "has free room" flag
813 exit;
814 end;
815 end;
816 pidx := cidx;
817 cidx := pc.next;
818 end;
819 end;
821 procedure TBodyGridBase.removeInternal (body: TBodyProxyId);
822 var
823 px: PBodyProxyRec;
824 begin
825 if (body < 0) or (body > High(mProxies)) then exit; // just in case
826 px := @mProxies[body];
827 forGridRect(px.mX, px.mY, px.mWidth, px.mHeight, remover, body);
828 end;
831 // ////////////////////////////////////////////////////////////////////////// //
832 function TBodyGridBase.insertBody (aObj: ITP; aX, aY, aWidth, aHeight: Integer; aTag: Integer=-1): TBodyProxyId;
833 begin
834 aTag := aTag and TagFullMask;
835 result := allocProxy(aX, aY, aWidth, aHeight, aObj, aTag);
836 insertInternal(result);
837 end;
840 procedure TBodyGridBase.removeBody (body: TBodyProxyId);
841 begin
842 if (body < 0) or (body > High(mProxies)) then exit; // just in case
843 removeInternal(body);
844 freeProxy(body);
845 end;
848 // ////////////////////////////////////////////////////////////////////////// //
849 procedure TBodyGridBase.moveResizeBody (body: TBodyProxyId; nx, ny, nw, nh: Integer);
850 var
851 px: PBodyProxyRec;
852 x0, y0, w, h: Integer;
853 begin
854 if (body < 0) or (body > High(mProxies)) then exit; // just in case
855 px := @mProxies[body];
856 x0 := px.mX;
857 y0 := px.mY;
858 w := px.mWidth;
859 h := px.mHeight;
860 {$IF DEFINED(D2F_DEBUG_MOVER)}
861 e_WriteLog(Format('proxy #%d: MOVERESIZE: xg=%d;yg=%d;w=%d;h=%d;nx=%d;ny=%d;nw=%d;nh=%d', [body, x0-mMinX, y0-mMinY, w, h, nx-mMinX, ny-mMinY, nw, nh]), MSG_NOTIFY);
862 {$ENDIF}
863 if (nx = x0) and (ny = y0) and (nw = w) and (nh = h) then exit;
864 // map -> grid
865 Dec(x0, mMinX);
866 Dec(y0, mMinY);
867 Dec(nx, mMinX);
868 Dec(ny, mMinY);
869 // did any corner crossed tile boundary?
870 if (x0 div mTileSize <> nx div mTileSize) or
871 (y0 div mTileSize <> ny div mTileSize) or
872 ((x0+w) div mTileSize <> (nx+nw) div mTileSize) or
873 ((y0+h) div mTileSize <> (ny+nh) div mTileSize) then
874 begin
875 removeInternal(body);
876 px.mX := nx+mMinX;
877 px.mY := ny+mMinY;
878 px.mWidth := nw;
879 px.mHeight := nh;
880 insertInternal(body);
881 end
882 else
883 begin
884 px.mX := nx+mMinX;
885 px.mY := ny+mMinY;
886 px.mWidth := nw;
887 px.mHeight := nh;
888 end;
889 end;
891 //TODO: optimize for horizontal/vertical moves
892 procedure TBodyGridBase.moveBody (body: TBodyProxyId; nx, ny: Integer);
893 var
894 px: PBodyProxyRec;
895 x0, y0: Integer;
896 ogx0, ogx1, ogy0, ogy1: Integer; // old grid rect
897 ngx0, ngx1, ngy0, ngy1: Integer; // new grid rect
898 gx, gy: Integer;
899 gw, gh: Integer;
900 pw, ph: Integer;
901 begin
902 if (body < 0) or (body > High(mProxies)) then exit; // just in case
903 // check if tile coords was changed
904 px := @mProxies[body];
905 x0 := px.mX;
906 y0 := px.mY;
907 if (nx = x0) and (ny = y0) then exit;
908 // map -> grid
909 Dec(x0, mMinX);
910 Dec(y0, mMinY);
911 Dec(nx, mMinX);
912 Dec(ny, mMinY);
913 // check for heavy work
914 pw := px.mWidth;
915 ph := px.mHeight;
916 ogx0 := x0 div mTileSize;
917 ogy0 := y0 div mTileSize;
918 ngx0 := nx div mTileSize;
919 ngy0 := ny div mTileSize;
920 ogx1 := (x0+pw-1) div mTileSize;
921 ogy1 := (y0+ph-1) div mTileSize;
922 ngx1 := (nx+pw-1) div mTileSize;
923 ngy1 := (ny+ph-1) div mTileSize;
924 {$IF DEFINED(D2F_DEBUG_MOVER)}
925 e_WriteLog(Format('proxy #%d: checkmove: xg=%d;yg=%d;w=%d;h=%d;nx=%d;ny=%d og:(%d,%d)-(%d,%d); ng:(%d,%d)-(%d,%d)', [body, x0, y0, pw, ph, nx, ny, ogx0, ogy0, ogx1, ogy1, ngx0, ngy0, ngx1, ngy1]), MSG_NOTIFY);
926 {$ENDIF}
927 if (ogx0 <> ngx0) or (ogy0 <> ngy0) or (ogx1 <> ngx1) or (ogy1 <> ngy1) then
928 begin
929 // crossed tile boundary, do heavy work
930 gw := mWidth;
931 gh := mHeight;
932 // cycle with old rect, remove body where it is necessary
933 // optimized for horizontal moves
934 {$IF DEFINED(D2F_DEBUG_MOVER)}
935 e_WriteLog(Format('proxy #%d: xg=%d;yg=%d;w=%d;h=%d;nx=%d;ny=%d og:(%d,%d)-(%d,%d); ng:(%d,%d)-(%d,%d)', [body, x0, y0, pw, ph, nx, ny, ogx0, ogy0, ogx1, ogy1, ngx0, ngy0, ngx1, ngy1]), MSG_NOTIFY);
936 {$ENDIF}
937 // remove stale marks
938 if not ((ogy0 >= gh) or (ogy1 < 0)) and
939 not ((ogx0 >= gw) or (ogx1 < 0)) then
940 begin
941 if (ogx0 < 0) then ogx0 := 0;
942 if (ogy0 < 0) then ogy0 := 0;
943 if (ogx1 > gw-1) then ogx1 := gw-1;
944 if (ogy1 > gh-1) then ogy1 := gh-1;
945 {$IF DEFINED(D2F_DEBUG_MOVER)}
946 e_WriteLog(Format(' norm og:(%d,%d)-(%d,%d)', [ogx0, ogy0, ogx1, ogy1]), MSG_NOTIFY);
947 {$ENDIF}
948 for gx := ogx0 to ogx1 do
949 begin
950 if (gx < ngx0) or (gx > ngx1) then
951 begin
952 // this column is completely outside of new rect
953 for gy := ogy0 to ogy1 do
954 begin
955 {$IF DEFINED(D2F_DEBUG_MOVER)}
956 e_WriteLog(Format(' remove0:(%d,%d)', [gx, gy]), MSG_NOTIFY);
957 {$ENDIF}
958 remover(gy*gw+gx, body);
959 end;
960 end
961 else
962 begin
963 // heavy checks
964 for gy := ogy0 to ogy1 do
965 begin
966 if (gy < ngy0) or (gy > ngy1) then
967 begin
968 {$IF DEFINED(D2F_DEBUG_MOVER)}
969 e_WriteLog(Format(' remove1:(%d,%d)', [gx, gy]), MSG_NOTIFY);
970 {$ENDIF}
971 remover(gy*gw+gx, body);
972 end;
973 end;
974 end;
975 end;
976 end;
977 // cycle with new rect, add body where it is necessary
978 if not ((ngy0 >= gh) or (ngy1 < 0)) and
979 not ((ngx0 >= gw) or (ngx1 < 0)) then
980 begin
981 if (ngx0 < 0) then ngx0 := 0;
982 if (ngy0 < 0) then ngy0 := 0;
983 if (ngx1 > gw-1) then ngx1 := gw-1;
984 if (ngy1 > gh-1) then ngy1 := gh-1;
985 {$IF DEFINED(D2F_DEBUG_MOVER)}
986 e_WriteLog(Format(' norm ng:(%d,%d)-(%d,%d)', [ngx0, ngy0, ngx1, ngy1]), MSG_NOTIFY);
987 {$ENDIF}
988 for gx := ngx0 to ngx1 do
989 begin
990 if (gx < ogx0) or (gx > ogx1) then
991 begin
992 // this column is completely outside of old rect
993 for gy := ngy0 to ngy1 do
994 begin
995 {$IF DEFINED(D2F_DEBUG_MOVER)}
996 e_WriteLog(Format(' insert0:(%d,%d)', [gx, gy]), MSG_NOTIFY);
997 {$ENDIF}
998 inserter(gy*gw+gx, body);
999 end;
1000 end
1001 else
1002 begin
1003 // heavy checks
1004 for gy := ngy0 to ngy1 do
1005 begin
1006 if (gy < ogy0) or (gy > ogy1) then
1007 begin
1008 {$IF DEFINED(D2F_DEBUG_MOVER)}
1009 e_WriteLog(Format(' insert1:(%d,%d)', [gx, gy]), MSG_NOTIFY);
1010 {$ENDIF}
1011 inserter(gy*gw+gx, body);
1012 end;
1013 end;
1014 end;
1015 end;
1016 end;
1017 // done
1018 end
1019 else
1020 begin
1021 {$IF DEFINED(D2F_DEBUG_MOVER)}
1022 e_WriteLog(Format('proxy #%d: GRID OK: xg=%d;yg=%d;w=%d;h=%d;nx=%d;ny=%d og:(%d,%d)-(%d,%d); ng:(%d,%d)-(%d,%d)', [body, x0, y0, pw, ph, nx, ny, ogx0, ogy0, ogx1, ogy1, ngx0, ngy0, ngx1, ngy1]), MSG_NOTIFY);
1023 {$ENDIF}
1024 end;
1025 // update coordinates
1026 px.mX := nx+mMinX;
1027 px.mY := ny+mMinY;
1028 end;
1030 procedure TBodyGridBase.resizeBody (body: TBodyProxyId; nw, nh: Integer);
1031 var
1032 px: PBodyProxyRec;
1033 x0, y0, w, h: Integer;
1034 begin
1035 if (body < 0) or (body > High(mProxies)) then exit; // just in case
1036 // check if tile coords was changed
1037 px := @mProxies[body];
1038 x0 := px.mX-mMinX;
1039 y0 := px.mY-mMinY;
1040 w := px.mWidth;
1041 h := px.mHeight;
1042 {$IF DEFINED(D2F_DEBUG_MOVER)}
1043 e_WriteLog(Format('proxy #%d: RESIZE: xg=%d;yg=%d;w=%d;h=%d;nw=%d;nh=%d', [body, x0, y0, w, h, nw, nh]), MSG_NOTIFY);
1044 {$ENDIF}
1045 if ((x0+w) div mTileSize <> (x0+nw) div mTileSize) or
1046 ((y0+h) div mTileSize <> (y0+nh) div mTileSize) then
1047 begin
1048 // crossed tile boundary, do heavy work
1049 removeInternal(body);
1050 px.mWidth := nw;
1051 px.mHeight := nh;
1052 insertInternal(body);
1053 end
1054 else
1055 begin
1056 // nothing to do with the grid, just fix size
1057 px.mWidth := nw;
1058 px.mHeight := nh;
1059 end;
1060 end;
1063 // ////////////////////////////////////////////////////////////////////////// //
1064 // no callback: return `true` on the first hit
1065 function TBodyGridBase.forEachAtPoint (x, y: Integer; cb: TGridQueryCB; tagmask: Integer=-1; exittag: PInteger=nil): ITP;
1066 var
1067 f: Integer;
1068 idx, curci: Integer;
1069 cc: PGridCell = nil;
1070 px: PBodyProxyRec;
1071 lq: LongWord;
1072 ptag: Integer;
1073 begin
1074 result := Default(ITP);
1075 if (exittag <> nil) then exittag^ := 0;
1076 tagmask := tagmask and TagFullMask;
1077 if (tagmask = 0) then exit;
1079 {$IF DEFINED(D2F_DEBUG_XXQ)}
1080 if (assigned(cb)) then e_WriteLog(Format('0: grid pointquery: (%d,%d)', [x, y]), MSG_NOTIFY);
1081 {$ENDIF}
1083 // make coords (0,0)-based
1084 Dec(x, mMinX);
1085 Dec(y, mMinY);
1086 if (x < 0) or (y < 0) or (x >= mWidth*mTileSize) or (y >= mHeight*mTileSize) then exit;
1088 curci := mGrid[(y div mTileSize)*mWidth+(x div mTileSize)];
1090 {$IF DEFINED(D2F_DEBUG_XXQ)}
1091 if (assigned(cb)) then e_WriteLog(Format('1: grid pointquery: (%d,%d) (%d,%d) %d', [x, y, (x div mTileSize), (y div mTileSize), curci]), MSG_NOTIFY);
1092 {$ENDIF}
1094 // restore coords
1095 Inc(x, mMinX);
1096 Inc(y, mMinY);
1098 // increase query counter
1099 Inc(mLastQuery);
1100 if (mLastQuery = 0) then
1101 begin
1102 // just in case of overflow
1103 mLastQuery := 1;
1104 for idx := 0 to High(mProxies) do mProxies[idx].mQueryMark := 0;
1105 end;
1106 lq := mLastQuery;
1108 {$IF DEFINED(D2F_DEBUG_XXQ)}
1109 if (assigned(cb)) then e_WriteLog(Format('2: grid pointquery: (%d,%d); lq=%u', [x, y, lq]), MSG_NOTIFY);
1110 {$ENDIF}
1112 while (curci <> -1) do
1113 begin
1114 {$IF DEFINED(D2F_DEBUG_XXQ)}
1115 if (assigned(cb)) then e_WriteLog(Format(' cell #%d', [curci]), MSG_NOTIFY);
1116 {$ENDIF}
1117 cc := @mCells[curci];
1118 for f := 0 to GridCellBucketSize-1 do
1119 begin
1120 if (cc.bodies[f] = -1) then break;
1121 px := @mProxies[cc.bodies[f]];
1122 {$IF DEFINED(D2F_DEBUG_XXQ)}
1123 if (assigned(cb)) then e_WriteLog(Format(' proxy #%d; qm:%u; tag:%08x; tagflag:%d %u', [cc.bodies[f], px.mQueryMark, px.mTag, (px.mTag and tagmask), LongWord(px.mObj)]), MSG_NOTIFY);
1124 {$ENDIF}
1125 // shit. has to do it this way, so i can change tag in callback
1126 if (px.mQueryMark <> lq) then
1127 begin
1128 px.mQueryMark := lq;
1129 ptag := px.mTag;
1130 if ((ptag and TagDisabled) = 0) and ((ptag and tagmask) <> 0) and
1131 (x >= px.mX) and (y >= px.mY) and (x < px.mX+px.mWidth) and (y < px.mY+px.mHeight) then
1132 begin
1133 if assigned(cb) then
1134 begin
1135 if cb(px.mObj, ptag) then
1136 begin
1137 result := px.mObj;
1138 if (exittag <> nil) then exittag^ := ptag;
1139 exit;
1140 end;
1141 end
1142 else
1143 begin
1144 result := px.mObj;
1145 if (exittag <> nil) then exittag^ := ptag;
1146 exit;
1147 end;
1148 end;
1149 end;
1150 end;
1151 curci := cc.next;
1152 end;
1153 end;
1156 // ////////////////////////////////////////////////////////////////////////// //
1157 // no callback: return `true` on the first hit
1158 function TBodyGridBase.forEachInAABB (x, y, w, h: Integer; cb: TGridQueryCB; tagmask: Integer=-1; allowDisabled: Boolean=false): ITP;
1159 const
1160 tsize = mTileSize;
1161 var
1162 idx: Integer;
1163 gx, gy: Integer;
1164 curci: Integer;
1165 f: Integer;
1166 cc: PGridCell = nil;
1167 px: PBodyProxyRec;
1168 lq: LongWord;
1169 gw: Integer;
1170 x0, y0: Integer;
1171 ptag: Integer;
1172 begin
1173 result := Default(ITP);
1174 if (w < 1) or (h < 1) then exit;
1175 tagmask := tagmask and TagFullMask;
1176 if (tagmask = 0) then exit;
1178 x0 := x;
1179 y0 := y;
1181 // fix coords
1182 Dec(x, mMinX);
1183 Dec(y, mMinY);
1185 gw := mWidth;
1186 //tsize := mTileSize;
1188 if (x+w <= 0) or (y+h <= 0) then exit;
1189 if (x >= gw*tsize) or (y >= mHeight*tsize) then exit;
1191 // increase query counter
1192 Inc(mLastQuery);
1193 if (mLastQuery = 0) then
1194 begin
1195 // just in case of overflow
1196 mLastQuery := 1;
1197 for idx := 0 to High(mProxies) do mProxies[idx].mQueryMark := 0;
1198 end;
1199 //e_WriteLog(Format('grid: query #%d: (%d,%d)-(%dx%d)', [mLastQuery, minx, miny, maxx, maxy]), MSG_NOTIFY);
1200 lq := mLastQuery;
1202 // go on
1203 for gy := y div tsize to (y+h-1) div tsize do
1204 begin
1205 if (gy < 0) then continue;
1206 if (gy >= mHeight) then break;
1207 for gx := x div tsize to (x+w-1) div tsize do
1208 begin
1209 if (gx < 0) then continue;
1210 if (gx >= gw) then break;
1211 // process cells
1212 curci := mGrid[gy*gw+gx];
1213 while (curci <> -1) do
1214 begin
1215 cc := @mCells[curci];
1216 for f := 0 to GridCellBucketSize-1 do
1217 begin
1218 if (cc.bodies[f] = -1) then break;
1219 px := @mProxies[cc.bodies[f]];
1220 // shit. has to do it this way, so i can change tag in callback
1221 if (px.mQueryMark = lq) then continue;
1222 px.mQueryMark := lq;
1223 ptag := px.mTag;
1224 if (not allowDisabled) and ((ptag and TagDisabled) <> 0) then continue;
1225 if ((ptag and tagmask) = 0) then continue;
1226 if (x0 >= px.mX+px.mWidth) or (y0 >= px.mY+px.mHeight) then continue;
1227 if (x0+w <= px.mX) or (y0+h <= px.mY) then continue;
1228 if assigned(cb) then
1229 begin
1230 if cb(px.mObj, ptag) then begin result := px.mObj; exit; end;
1231 end
1232 else
1233 begin
1234 result := px.mObj;
1235 exit;
1236 end;
1237 end;
1238 curci := cc.next;
1239 end;
1240 end;
1241 end;
1242 end;
1245 // ////////////////////////////////////////////////////////////////////////// //
1246 // no callback: return `true` on the nearest hit
1247 function TBodyGridBase.traceRay (const x0, y0, x1, y1: Integer; cb: TGridRayQueryCB; tagmask: Integer=-1): ITP;
1248 var
1249 ex, ey: Integer;
1250 begin
1251 result := traceRay(ex, ey, x0, y0, x1, y1, cb, tagmask);
1252 end;
1255 // no callback: return `true` on the nearest hit
1256 // you are not supposed to understand this
1257 function TBodyGridBase.traceRay (out ex, ey: Integer; const ax0, ay0, ax1, ay1: Integer; cb: TGridRayQueryCB; tagmask: Integer=-1): ITP;
1258 const
1259 tsize = mTileSize;
1260 var
1261 wx0, wy0, wx1, wy1: Integer; // window coordinates
1262 stx, sty: Integer; // "steps" for x and y axes
1263 dsx, dsy: Integer; // "lengthes" for x and y axes
1264 dx2, dy2: Integer; // "double lengthes" for x and y axes
1265 xd, yd: Integer; // current coord
1266 e: Integer; // "error" (as in bresenham algo)
1267 rem: Integer;
1268 term: Integer;
1269 xptr, yptr: PInteger;
1270 xfixed: Boolean;
1271 temp: Integer;
1272 prevx, prevy: Integer;
1273 lastDistSq: Integer;
1274 ccidx, curci: Integer;
1275 hasUntried: Boolean;
1276 lastGA: Integer = -1;
1277 ga, x, y: Integer;
1278 lastObj: ITP;
1279 wasHit: Boolean = false;
1280 gw, gh, minx, miny, maxx, maxy: Integer;
1281 cc: PGridCell;
1282 px: PBodyProxyRec;
1283 lq: LongWord;
1284 f, ptag, distSq: Integer;
1285 x0, y0, x1, y1: Integer;
1286 // horizontal walker
1287 {$IFDEF GRID_USE_ORTHO_ACCEL}
1288 wklen, wkstep: Integer;
1289 hopt: Boolean;
1290 {$ENDIF}
1291 begin
1292 result := Default(ITP);
1293 lastObj := Default(ITP);
1294 tagmask := tagmask and TagFullMask;
1295 ex := ax1; // why not?
1296 ey := ay1; // why not?
1297 if (tagmask = 0) then exit;
1299 if (ax0 = ax1) and (ay0 = ay1) then
1300 begin
1301 result := forEachAtPoint(ax0, ay0, nil, tagmask, @ptag);
1302 if (result <> nil) then
1303 begin
1304 if assigned(cb) and not cb(result, ptag, ax0, ay0, ax0, ay0) then result := Default(ITP);
1305 end;
1306 exit;
1307 end;
1309 lastDistSq := distanceSq(ax0, ay0, ax1, ay1)+1;
1311 gw := mWidth;
1312 gh := mHeight;
1313 minx := mMinX;
1314 miny := mMinY;
1315 maxx := gw*tsize-1;
1316 maxy := gh*tsize-1;
1318 {$IF DEFINED(D2F_DEBUG_RAYTRACE)}
1319 if assigned(dbgRayTraceTileHitCB) then e_WriteLog(Format('TRACING: (%d,%d)-(%d,%d) [(%d,%d)-(%d,%d)]; maxdistsq=%d', [ax0, ay0, ax1, ay1, minx, miny, maxx, maxy, lastDistSq]), MSG_NOTIFY);
1320 {$ENDIF}
1322 x0 := ax0;
1323 y0 := ay0;
1324 x1 := ax1;
1325 y1 := ay1;
1327 // offset query coords to (0,0)-based
1328 Dec(x0, minx);
1329 Dec(y0, miny);
1330 Dec(x1, minx);
1331 Dec(y1, miny);
1333 // clip rectange
1334 wx0 := 0;
1335 wy0 := 0;
1336 wx1 := maxx;
1337 wy1 := maxy;
1339 // horizontal setup
1340 if (x0 < x1) then
1341 begin
1342 // from left to right
1343 if (x0 > wx1) or (x1 < wx0) then exit; // out of screen
1344 stx := 1; // going right
1345 end
1346 else
1347 begin
1348 // from right to left
1349 if (x1 > wx1) or (x0 < wx0) then exit; // out of screen
1350 stx := -1; // going left
1351 x0 := -x0;
1352 x1 := -x1;
1353 wx0 := -wx0;
1354 wx1 := -wx1;
1355 swapInt(wx0, wx1);
1356 end;
1358 // vertical setup
1359 if (y0 < y1) then
1360 begin
1361 // from top to bottom
1362 if (y0 > wy1) or (y1 < wy0) then exit; // out of screen
1363 sty := 1; // going down
1364 end
1365 else
1366 begin
1367 // from bottom to top
1368 if (y1 > wy1) or (y0 < wy0) then exit; // out of screen
1369 sty := -1; // going up
1370 y0 := -y0;
1371 y1 := -y1;
1372 wy0 := -wy0;
1373 wy1 := -wy1;
1374 swapInt(wy0, wy1);
1375 end;
1377 dsx := x1-x0;
1378 dsy := y1-y0;
1380 if (dsx < dsy) then
1381 begin
1382 xptr := @yd;
1383 yptr := @xd;
1384 swapInt(x0, y0);
1385 swapInt(x1, y1);
1386 swapInt(dsx, dsy);
1387 swapInt(wx0, wy0);
1388 swapInt(wx1, wy1);
1389 swapInt(stx, sty);
1390 end
1391 else
1392 begin
1393 xptr := @xd;
1394 yptr := @yd;
1395 end;
1397 dx2 := 2*dsx;
1398 dy2 := 2*dsy;
1399 xd := x0;
1400 yd := y0;
1401 e := 2*dsy-dsx;
1402 term := x1;
1404 xfixed := false;
1405 if (y0 < wy0) then
1406 begin
1407 // clip at top
1408 temp := dx2*(wy0-y0)-dsx;
1409 xd += temp div dy2;
1410 rem := temp mod dy2;
1411 if (xd > wx1) then exit; // x is moved out of clipping rect, nothing to do
1412 if (xd+1 >= wx0) then
1413 begin
1414 yd := wy0;
1415 e -= rem+dsx;
1416 if (rem > 0) then begin Inc(xd); e += dy2; end;
1417 xfixed := true;
1418 end;
1419 end;
1421 if (not xfixed) and (x0 < wx0) then
1422 begin
1423 // clip at left
1424 temp := dy2*(wx0-x0);
1425 yd += temp div dx2;
1426 rem := temp mod dx2;
1427 if (yd > wy1) or (yd = wy1) and (rem >= dsx) then exit;
1428 xd := wx0;
1429 e += rem;
1430 if (rem >= dsx) then begin Inc(yd); e -= dx2; end;
1431 end;
1433 if (y1 > wy1) then
1434 begin
1435 // clip at bottom
1436 temp := dx2*(wy1-y0)+dsx;
1437 term := x0+temp div dy2;
1438 rem := temp mod dy2;
1439 if (rem = 0) then Dec(term);
1440 end;
1442 if (term > wx1) then term := wx1; // clip at right
1444 Inc(term); // draw last point
1445 //if (term = xd) then exit; // this is the only point, get out of here
1447 if (sty = -1) then yd := -yd;
1448 if (stx = -1) then begin xd := -xd; term := -term; end;
1449 dx2 -= dy2;
1451 // first move, to skip starting point
1452 // DON'T DO THIS! loop will take care of that
1453 if (xd = term) then
1454 begin
1455 result := forEachAtPoint(ax0, ay0, nil, tagmask, @ptag);
1456 if (result <> nil) then
1457 begin
1458 if assigned(cb) then
1459 begin
1460 if cb(result, ptag, ax0, ay0, ax0, ay0) then
1461 begin
1462 ex := ax0;
1463 ey := ay0;
1464 end
1465 else
1466 begin
1467 result := nil;
1468 end;
1469 end
1470 else
1471 begin
1472 ex := ax0;
1473 ey := ay0;
1474 end;
1475 end;
1476 exit;
1477 end;
1479 prevx := xptr^+minx;
1480 prevy := yptr^+miny;
1481 (*
1482 // move coords
1483 if (e >= 0) then begin yd += sty; e -= dx2; end else e += dy2;
1484 xd += stx;
1485 // done?
1486 if (xd = term) then exit;
1487 *)
1489 {$IF DEFINED(D2F_DEBUG)}
1490 if (xptr^ < 0) or (yptr^ < 0) or (xptr^ >= gw*tsize) and (yptr^ >= gh*tsize) then raise Exception.Create('raycaster internal error (0)');
1491 {$ENDIF}
1492 // DON'T DO THIS! loop will take care of that
1493 //lastGA := (yptr^ div tsize)*gw+(xptr^ div tsize);
1494 //ccidx := mGrid[lastGA];
1496 {$IF DEFINED(D2F_DEBUG_RAYTRACE)}
1497 //if assigned(dbgRayTraceTileHitCB) then e_WriteLog('1:TRACING!', MSG_NOTIFY);
1498 {$ENDIF}
1500 //if (dbgShowTraceLog) then e_WriteLog(Format('raycast start: (%d,%d)-(%d,%d); xptr^=%d; yptr^=%d', [ax0, ay0, ax1, ay1, xptr^, yptr^]), MSG_NOTIFY);
1502 // increase query counter
1503 Inc(mLastQuery);
1504 if (mLastQuery = 0) then
1505 begin
1506 // just in case of overflow
1507 mLastQuery := 1;
1508 for f := 0 to High(mProxies) do mProxies[f].mQueryMark := 0;
1509 end;
1510 lq := mLastQuery;
1512 {$IFDEF GRID_USE_ORTHO_ACCEL}
1513 // if this is strict horizontal trace, use optimized codepath
1514 if (ax0 = ax1) or (ay0 = ay1) then
1515 begin
1516 // horizontal trace: walk the whole tiles, calculating mindist once for each proxy in cell
1517 // stx < 0: going left, otherwise `stx` is > 0, and we're going right
1518 // vertical trace: walk the whole tiles, calculating mindist once for each proxy in cell
1519 // stx < 0: going up, otherwise `stx` is > 0, and we're going down
1520 hopt := (ay0 = ay1); // horizontal?
1521 if (stx < 0) then wklen := -(term-xd) else wklen := term-xd;
1522 {$IF DEFINED(D2F_DEBUG)}
1523 if dbgShowTraceLog then e_LogWritefln('optimized htrace; wklen=%d', [wklen]);
1524 {$ENDIF}
1525 ga := (yptr^ div tsize)*gw+(xptr^ div tsize);
1526 // one of those will never change
1527 x := xptr^+minx;
1528 y := yptr^+miny;
1529 {$IF DEFINED(D2F_DEBUG)}
1530 if hopt then
1531 begin
1532 if (y <> ay0) then raise Exception.Create('htrace fatal internal error');
1533 end
1534 else
1535 begin
1536 if (x <> ax0) then raise Exception.Create('vtrace fatal internal error');
1537 end;
1538 {$ENDIF}
1539 while (wklen > 0) do
1540 begin
1541 {$IF DEFINED(D2F_DEBUG)}
1542 if dbgShowTraceLog then e_LogWritefln(' htrace; ga=%d; x=%d, y=%d; y=%d; y=%d', [ga, xptr^+minx, yptr^+miny, y, ay0]);
1543 {$ENDIF}
1544 // new tile?
1545 if (ga <> lastGA) then
1546 begin
1547 lastGA := ga;
1548 ccidx := mGrid[lastGA];
1549 // convert coords to map (to avoid ajdusting coords inside the loop)
1550 if hopt then x := xptr^+minx else y := yptr^+miny;
1551 while (ccidx <> -1) do
1552 begin
1553 cc := @mCells[ccidx];
1554 for f := 0 to GridCellBucketSize-1 do
1555 begin
1556 if (cc.bodies[f] = -1) then break;
1557 px := @mProxies[cc.bodies[f]];
1558 ptag := px.mTag;
1559 if ((ptag and TagDisabled) = 0) and ((ptag and tagmask) <> 0) and (px.mQueryMark <> lq) and
1560 // constant coord should be inside
1561 ((hopt and (y >= px.mY) and (y < px.mY+px.mHeight)) or
1562 ((not hopt) and (x >= px.mX) and (x < px.mX+px.mWidth))) then
1563 begin
1564 px.mQueryMark := lq; // mark as processed
1565 // inside the proxy?
1566 if (hopt and (x > px.mX) and (x < px.mX+px.mWidth-1)) or
1567 ((not hopt) and (y > px.mY) and (y < px.mY+px.mHeight-1)) then
1568 begin
1569 if assigned(cb) then
1570 begin
1571 if cb(px.mObj, ptag, x, y, x, y) then
1572 begin
1573 result := lastObj;
1574 ex := prevx;
1575 ey := prevy;
1576 exit;
1577 end;
1578 x := xptr^+minx;
1579 end
1580 else
1581 begin
1582 distSq := distanceSq(ax0, ay0, x, y);
1583 {$IF DEFINED(D2F_DEBUG)}
1584 if dbgShowTraceLog then e_LogWritefln(' EMBEDDED hhit(%d): a=(%d,%d), h=(%d,%d), distsq=%d; lastsq=%d', [cc.bodies[f], ax0, ay0, x, y, distSq, lastDistSq]);
1585 {$ENDIF}
1586 if (distSq < lastDistSq) then
1587 begin
1588 ex := x;
1589 ey := y;
1590 result := px.mObj;
1591 exit;
1592 end;
1593 end;
1594 continue;
1595 end;
1596 // remember this hitpoint if it is nearer than an old one
1597 if hopt then
1598 begin
1599 prevy := y;
1600 if (stx < 0) then
1601 begin
1602 // going left
1603 if (x < px.mX) then continue;
1604 prevx := px.mX+px.mWidth;
1605 end
1606 else
1607 begin
1608 // going right
1609 if (x > px.mX{+px.mWidth}) then continue;
1610 prevx := px.mX-1;
1611 end;
1612 end
1613 else
1614 begin
1615 prevx := x;
1616 if (stx < 0) then
1617 begin
1618 // going up
1619 if (y < px.mY) then continue;
1620 prevy := px.mY+px.mHeight;
1621 end
1622 else
1623 begin
1624 // going down
1625 if (y > px.mY{+px.mHeight}) then continue;
1626 prevy := px.mY-1;
1627 end;
1628 end;
1629 if assigned(cb) then
1630 begin
1631 if (stx < 0) then
1632 begin
1633 if hopt then x := prevx-1 else y := prevy-1;
1634 end
1635 else
1636 begin
1637 if hopt then x := prevx+1 else y := prevy+1;
1638 end;
1639 if cb(px.mObj, ptag, x, y, prevx, prevy) then
1640 begin
1641 result := lastObj;
1642 ex := prevx;
1643 ey := prevy;
1644 exit;
1645 end;
1646 x := xptr^+minx;
1647 y := yptr^+miny;
1648 end
1649 else
1650 begin
1651 distSq := distanceSq(ax0, ay0, prevx, prevy);
1652 {$IF DEFINED(D2F_DEBUG)}
1653 if dbgShowTraceLog then e_LogWritefln(' hhit(%d): a=(%d,%d), h=(%d,%d), p=(%d,%d), distsq=%d; lastsq=%d', [cc.bodies[f], ax0, ay0, x, y, prevx, prevy, distSq, lastDistSq]);
1654 {$ENDIF}
1655 if (distSq < lastDistSq) then
1656 begin
1657 wasHit := true;
1658 lastDistSq := distSq;
1659 ex := prevx;
1660 ey := prevy;
1661 lastObj := px.mObj;
1662 end;
1663 end;
1664 end;
1665 end;
1666 // next cell
1667 ccidx := cc.next;
1668 end;
1669 if wasHit and not assigned(cb) then begin result := lastObj; exit; end;
1670 end;
1671 // skip to next tile
1672 if hopt then
1673 begin
1674 if (stx > 0) then
1675 begin
1676 // to the right
1677 wkstep := ((xptr^ or (mTileSize-1))+1)-xptr^;
1678 {$IF DEFINED(D2F_DEBUG)}
1679 if dbgShowTraceLog then e_LogWritefln(' right step: wklen=%d; wkstep=%d', [wklen, wkstep]);
1680 {$ENDIF}
1681 if (wkstep >= wklen) then break;
1682 Inc(xptr^, wkstep);
1683 Inc(ga);
1684 end
1685 else
1686 begin
1687 // to the left
1688 wkstep := xptr^-((xptr^ and (not (mTileSize-1)))-1);
1689 {$IF DEFINED(D2F_DEBUG)}
1690 if dbgShowTraceLog then e_LogWritefln(' left step: wklen=%d; wkstep=%d', [wklen, wkstep]);
1691 {$ENDIF}
1692 if (wkstep >= wklen) then break;
1693 Dec(xptr^, wkstep);
1694 Dec(ga);
1695 end;
1696 end
1697 else
1698 begin
1699 if (stx > 0) then
1700 begin
1701 // to the down
1702 wkstep := ((yptr^ or (mTileSize-1))+1)-yptr^;
1703 {$IF DEFINED(D2F_DEBUG)}
1704 if dbgShowTraceLog then e_LogWritefln(' down step: wklen=%d; wkstep=%d', [wklen, wkstep]);
1705 {$ENDIF}
1706 if (wkstep >= wklen) then break;
1707 Inc(yptr^, wkstep);
1708 Inc(ga, mHeight);
1709 end
1710 else
1711 begin
1712 // to the up
1713 wkstep := yptr^-((yptr^ and (not (mTileSize-1)))-1);
1714 {$IF DEFINED(D2F_DEBUG)}
1715 if dbgShowTraceLog then e_LogWritefln(' up step: wklen=%d; wkstep=%d', [wklen, wkstep]);
1716 {$ENDIF}
1717 if (wkstep >= wklen) then break;
1718 Dec(yptr^, wkstep);
1719 Dec(ga, mHeight);
1720 end;
1721 end;
1722 Dec(wklen, wkstep);
1723 end;
1724 // we can travel less than one cell
1725 if wasHit and not assigned(cb) then result := lastObj else begin ex := ax1; ey := ay1; end;
1726 exit;
1727 end;
1728 {$ENDIF}
1730 {$IF DEFINED(D2F_DEBUG_RAYTRACE)}
1731 if assigned(dbgRayTraceTileHitCB) then dbgRayTraceTileHitCB((xptr^ div tsize*tsize)+minx, (yptr^ div tsize*tsize)+miny);
1732 {$ENDIF}
1734 ccidx := -1;
1735 // can omit checks
1736 while (xd <> term) do
1737 begin
1738 // check cell(s)
1739 {$IF DEFINED(D2F_DEBUG)}
1740 if (xptr^ < 0) or (yptr^ < 0) or (xptr^ >= gw*tsize) and (yptr^ >= gh*tsize) then raise Exception.Create('raycaster internal error (0)');
1741 {$ENDIF}
1742 // new tile?
1743 ga := (yptr^ div tsize)*gw+(xptr^ div tsize);
1744 {$IF DEFINED(D2F_DEBUG_RAYTRACE)}
1745 if assigned(dbgRayTraceTileHitCB) then e_WriteLog(Format(' xd=%d; term=%d; gx=%d; gy=%d; ga=%d; lastga=%d', [xd, term, xptr^, yptr^, ga, lastGA]), MSG_NOTIFY);
1746 {$ENDIF}
1747 if (ga <> lastGA) then
1748 begin
1749 // yes
1750 {$IF DEFINED(D2F_DEBUG)}
1751 if assigned(dbgRayTraceTileHitCB) then dbgRayTraceTileHitCB((xptr^ div tsize*tsize)+minx, (yptr^ div tsize*tsize)+miny);
1752 {$ENDIF}
1753 if (ccidx <> -1) then
1754 begin
1755 // signal cell completion
1756 if assigned(cb) then
1757 begin
1758 if cb(nil, 0, xptr^+minx, yptr^+miny, prevx, prevy) then begin result := lastObj; exit; end;
1759 end
1760 else if wasHit then
1761 begin
1762 result := lastObj;
1763 exit;
1764 end;
1765 end;
1766 lastGA := ga;
1767 ccidx := mGrid[lastGA];
1768 end;
1769 // has something to process in this tile?
1770 if (ccidx <> -1) then
1771 begin
1772 // process cell
1773 curci := ccidx;
1774 hasUntried := false; // this will be set to `true` if we have some proxies we still want to process at the next step
1775 // convert coords to map (to avoid ajdusting coords inside the loop)
1776 x := xptr^+minx;
1777 y := yptr^+miny;
1778 // process cell list
1779 while (curci <> -1) do
1780 begin
1781 cc := @mCells[curci];
1782 for f := 0 to GridCellBucketSize-1 do
1783 begin
1784 if (cc.bodies[f] = -1) then break;
1785 px := @mProxies[cc.bodies[f]];
1786 ptag := px.mTag;
1787 if ((ptag and TagDisabled) = 0) and ((ptag and tagmask) <> 0) and (px.mQueryMark <> lq) then
1788 begin
1789 // can we process this proxy?
1790 if (x >= px.mX) and (y >= px.mY) and (x < px.mX+px.mWidth) and (y < px.mY+px.mHeight) then
1791 begin
1792 px.mQueryMark := lq; // mark as processed
1793 if assigned(cb) then
1794 begin
1795 if cb(px.mObj, ptag, x, y, prevx, prevy) then
1796 begin
1797 result := lastObj;
1798 ex := prevx;
1799 ey := prevy;
1800 exit;
1801 end;
1802 (*
1803 {$IF DEFINED(D2F_DEBUG_RAYTRACE)}
1804 distSq := distanceSq(ax0, ay0, prevx, prevy);
1805 if assigned(dbgRayTraceTileHitCB) then e_WriteLog(Format(' hit(%d): a=(%d,%d), h=(%d,%d), p=(%d,%d); distsq=%d; lastsq=%d', [cc.bodies[f], ax0, ay0, x, y, prevx, prevy, distSq, lastDistSq]), MSG_NOTIFY);
1806 if (distSq < lastDistSq) then
1807 begin
1808 wasHit := true;
1809 lastDistSq := distSq;
1810 ex := prevx;
1811 ey := prevy;
1812 lastObj := px.mObj;
1813 end;
1814 {$ENDIF}
1815 *)
1816 end
1817 else
1818 begin
1819 // remember this hitpoint if it is nearer than an old one
1820 distSq := distanceSq(ax0, ay0, prevx, prevy);
1821 {$IF DEFINED(D2F_DEBUG_RAYTRACE)}
1822 if assigned(dbgRayTraceTileHitCB) then e_WriteLog(Format(' hit(%d): a=(%d,%d), h=(%d,%d), p=(%d,%d); distsq=%d; lastsq=%d', [cc.bodies[f], ax0, ay0, x, y, prevx, prevy, distSq, lastDistSq]), MSG_NOTIFY);
1823 {$ENDIF}
1824 if (distSq < lastDistSq) then
1825 begin
1826 wasHit := true;
1827 lastDistSq := distSq;
1828 ex := prevx;
1829 ey := prevy;
1830 lastObj := px.mObj;
1831 end;
1832 end;
1833 end
1834 else
1835 begin
1836 // this is possibly interesting proxy, set "has more to check" flag
1837 hasUntried := true;
1838 end;
1839 end;
1840 end;
1841 // next cell
1842 curci := cc.next;
1843 end;
1844 // still has something interesting in this cell?
1845 if not hasUntried then
1846 begin
1847 // nope, don't process this cell anymore; signal cell completion
1848 ccidx := -1;
1849 if assigned(cb) then
1850 begin
1851 if cb(nil, 0, x, y, prevx, prevy) then begin result := lastObj; exit; end;
1852 end
1853 else if wasHit then
1854 begin
1855 result := lastObj;
1856 exit;
1857 end;
1858 end;
1859 end;
1860 //putPixel(xptr^, yptr^);
1861 // move coords
1862 prevx := xptr^+minx;
1863 prevy := yptr^+miny;
1864 if (e >= 0) then begin yd += sty; e -= dx2; end else e += dy2;
1865 xd += stx;
1866 end;
1867 // we can travel less than one cell
1868 if wasHit and not assigned(cb) then
1869 begin
1870 result := lastObj;
1871 end
1872 else
1873 begin
1874 ex := ax1; // why not?
1875 ey := ay1; // why not?
1876 end;
1877 end;
1880 // ////////////////////////////////////////////////////////////////////////// //
1881 //FIXME! optimize this with real tile walking
1882 function TBodyGridBase.forEachAlongLine (const x0, y0, x1, y1: Integer; cb: TGridAlongQueryCB; tagmask: Integer=-1; log: Boolean=false): ITP;
1883 const
1884 tsize = mTileSize;
1885 var
1886 i: Integer;
1887 dx, dy, d: Integer;
1888 xerr, yerr: Integer;
1889 incx, incy: Integer;
1890 stepx, stepy: Integer;
1891 x, y: Integer;
1892 maxx, maxy: Integer;
1893 gw, gh: Integer;
1894 ccidx: Integer;
1895 curci: Integer;
1896 cc: PGridCell;
1897 px: PBodyProxyRec;
1898 lq: LongWord;
1899 minx, miny: Integer;
1900 ptag: Integer;
1901 lastWasInGrid: Boolean;
1902 tbcross: Boolean;
1903 f: Integer;
1904 //tedist: Integer;
1905 begin
1906 log := false;
1907 result := Default(ITP);
1908 tagmask := tagmask and TagFullMask;
1909 if (tagmask = 0) or not assigned(cb) then exit;
1911 minx := mMinX;
1912 miny := mMinY;
1914 dx := x1-x0;
1915 dy := y1-y0;
1917 if (dx > 0) then incx := 1 else if (dx < 0) then incx := -1 else incx := 0;
1918 if (dy > 0) then incy := 1 else if (dy < 0) then incy := -1 else incy := 0;
1920 if (incx = 0) and (incy = 0) then exit; // just incase
1922 dx := abs(dx);
1923 dy := abs(dy);
1925 if (dx > dy) then d := dx else d := dy;
1927 // `x` and `y` will be in grid coords
1928 x := x0-minx;
1929 y := y0-miny;
1931 // increase query counter
1932 Inc(mLastQuery);
1933 if (mLastQuery = 0) then
1934 begin
1935 // just in case of overflow
1936 mLastQuery := 1;
1937 for i := 0 to High(mProxies) do mProxies[i].mQueryMark := 0;
1938 end;
1939 lq := mLastQuery;
1941 // cache various things
1942 //tsize := mTileSize;
1943 gw := mWidth;
1944 gh := mHeight;
1945 maxx := gw*tsize-1;
1946 maxy := gh*tsize-1;
1948 // setup distance and flags
1949 lastWasInGrid := (x >= 0) and (y >= 0) and (x <= maxx) and (y <= maxy);
1951 // setup starting tile ('cause we'll adjust tile vars only on tile edge crossing)
1952 if lastWasInGrid then ccidx := mGrid[(y div tsize)*gw+(x div tsize)] else ccidx := -1;
1954 // it is slightly faster this way
1955 xerr := -d;
1956 yerr := -d;
1958 if (log) then e_WriteLog(Format('tracing: (%d,%d)-(%d,%d)', [x, y, x1-minx, y1-miny]), MSG_NOTIFY);
1960 // now trace
1961 i := 0;
1962 while (i < d) do
1963 begin
1964 Inc(i);
1965 // do one step
1966 xerr += dx;
1967 yerr += dy;
1968 // invariant: one of those always changed
1969 {$IF DEFINED(D2F_DEBUG)}
1970 if (xerr < 0) and (yerr < 0) then raise Exception.Create('internal bug in grid raycaster (0)');
1971 {$ENDIF}
1972 if (xerr >= 0) then begin xerr -= d; x += incx; stepx := incx; end else stepx := 0;
1973 if (yerr >= 0) then begin yerr -= d; y += incy; stepy := incy; end else stepy := 0;
1974 // invariant: we always doing a step
1975 {$IF DEFINED(D2F_DEBUG)}
1976 if ((stepx or stepy) = 0) then raise Exception.Create('internal bug in grid raycaster (1)');
1977 {$ENDIF}
1978 begin
1979 // check for crossing tile/grid boundary
1980 if (x >= 0) and (y >= 0) and (x <= maxx) and (y <= maxy) then
1981 begin
1982 // we're still in grid
1983 lastWasInGrid := true;
1984 // check for tile edge crossing
1985 if (stepx < 0) and ((x mod tsize) = tsize-1) then tbcross := true
1986 else if (stepx > 0) and ((x mod tsize) = 0) then tbcross := true
1987 else if (stepy < 0) and ((y mod tsize) = tsize-1) then tbcross := true
1988 else if (stepy > 0) and ((y mod tsize) = 0) then tbcross := true
1989 else tbcross := false;
1990 // crossed tile edge?
1991 if tbcross then
1992 begin
1993 // setup new cell index
1994 ccidx := mGrid[(y div tsize)*gw+(x div tsize)];
1995 if (log) then e_WriteLog(Format(' stepped to new tile (%d,%d) -- (%d,%d)', [(x div tsize), (y div tsize), x, y]), MSG_NOTIFY);
1996 end
1997 else
1998 if (ccidx = -1) then
1999 begin
2000 // we have nothing interesting here anymore, jump directly to tile edge
2001 (*
2002 if (incx = 0) then
2003 begin
2004 // vertical line
2005 if (incy < 0) then tedist := y-(y and (not tsize)) else tedist := (y or (tsize-1))-y;
2006 if (tedist > 1) then
2007 begin
2008 if (log) then e_WriteLog(Format(' doing vertical jump from tile (%d,%d) - (%d,%d) by %d steps', [(x div tsize), (y div tsize), x, y, tedist]), MSG_NOTIFY);
2009 y += incy*tedist;
2010 Inc(i, tedist);
2011 if (log) then e_WriteLog(Format(' jumped to tile (%d,%d) - (%d,%d) by %d steps', [(x div tsize), (y div tsize), x, y, tedist]), MSG_NOTIFY);
2012 end;
2013 end
2014 else if (incy = 0) then
2015 begin
2016 // horizontal line
2017 if (incx < 0) then tedist := x-(x and (not tsize)) else tedist := (x or (tsize-1))-x;
2018 if (tedist > 1) then
2019 begin
2020 if (log) then e_WriteLog(Format(' doing horizontal jump from tile (%d,%d) - (%d,%d) by %d steps', [(x div tsize), (y div tsize), x, y, tedist]), MSG_NOTIFY);
2021 x += incx*tedist;
2022 Inc(i, tedist);
2023 if (log) then e_WriteLog(Format(' jumped to tile (%d,%d) - (%d,%d) by %d steps', [(x div tsize), (y div tsize), x, y, tedist]), MSG_NOTIFY);
2024 end;
2025 end;
2026 *)
2027 (*
2028 else if (
2029 // get minimal distance to tile edges
2030 if (incx < 0) then tedist := x-(x and (not tsize)) else if (incx > 0) then tedist := (x or (tsize+1))-x else tedist := 0;
2031 {$IF DEFINED(D2F_DEBUG)}
2032 if (tedist < 0) then raise Exception.Create('internal bug in grid raycaster (2.x)');
2033 {$ENDIF}
2034 if (incy < 0) then f := y-(y and (not tsize)) else if (incy > 0) then f := (y or (tsize+1))-y else f := 0;
2035 {$IF DEFINED(D2F_DEBUG)}
2036 if (f < 0) then raise Exception.Create('internal bug in grid raycaster (2.y)');
2037 {$ENDIF}
2038 if (tedist = 0) then tedist := f else if (f <> 0) then tedist := minInt(tedist, f);
2039 // do jump
2040 if (tedist > 1) then
2041 begin
2042 if (log) then e_WriteLog(Format(' doing jump from tile (%d,%d) - (%d,%d) by %d steps', [(x div tsize), (y div tsize), x, y, tedist]), MSG_NOTIFY);
2043 xerr += dx*tedist;
2044 yerr += dy*tedist;
2045 if (xerr >= 0) then begin x += incx*((xerr div d)+1); xerr := (xerr mod d)-d; end;
2046 if (yerr >= 0) then begin y += incy*((yerr div d)+1); yerr := (yerr mod d)-d; end;
2047 Inc(i, tedist);
2048 if (log) then e_WriteLog(Format(' jumped to tile (%d,%d) - (%d,%d) by %d steps', [(x div tsize), (y div tsize), x, y, tedist]), MSG_NOTIFY);
2049 end;
2050 *)
2051 end;
2052 end
2053 else
2054 begin
2055 // out of grid
2056 if lastWasInGrid then exit; // oops, stepped out of the grid -- there is no way to return
2057 end;
2058 end;
2060 // has something to process in the current cell?
2061 if (ccidx <> -1) then
2062 begin
2063 // process cell
2064 curci := ccidx;
2065 // convert coords to map (to avoid ajdusting coords inside the loop)
2066 //Inc(x, minx);
2067 //Inc(y, miny);
2068 // process cell list
2069 while (curci <> -1) do
2070 begin
2071 cc := @mCells[curci];
2072 for f := 0 to GridCellBucketSize-1 do
2073 begin
2074 if (cc.bodies[f] = -1) then break;
2075 px := @mProxies[cc.bodies[f]];
2076 ptag := px.mTag;
2077 if ((ptag and TagDisabled) = 0) and ((ptag and tagmask) <> 0) and (px.mQueryMark <> lq) then
2078 begin
2079 px.mQueryMark := lq; // mark as processed
2080 if cb(px.mObj, ptag) then begin result := px.mObj; exit; end;
2081 end;
2082 end;
2083 // next cell
2084 curci := cc.next;
2085 end;
2086 ccidx := -1; // don't process this anymore
2087 // convert coords to grid
2088 //Dec(x, minx);
2089 //Dec(y, miny);
2090 end;
2091 end;
2092 end;
2095 end.