src/shared/geom.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, version 3 of the License ONLY.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  14  *)
  15 {$INCLUDE a_modes.inc}
  16 // some geometry utilities
  17 unit geom;
  18
  19 interface
  20
  21
  22 // do line clipping; returns `false` if line is outside of the box
  23 function clipLine (var x0, y0, x1, y1: Single; xmin, ymin, xmax, ymax: Single): Boolean;
  24
  25 // returns `true` if there is an intersection (if starting point is inside the box, it counts as intersection)
  26 function lineAABBIntersects (x0, y0, x1, y1: Integer; bx, by, bw, bh: Integer): Boolean;
  27
  28 // you are not supposed to understand this
  29 // returns `true` if there is an intersection, and enter coords
  30 // enter coords will be equal to (x0, y0) if starting point is inside the box
  31 // if result is `false`, `inx` and `iny` are undefined
  32 function lineAABBIntersects (x0, y0, x1, y1: Integer; bx, by, bw, bh: Integer; out inx, iny: Integer): Boolean;
  33
  34 type
  35   TSweepEdge = (None, Top, Right, Bottom, Left);
  36   PSweepEdge = ^TSweepEdge;
  37
  38 // sweep two AABB's to see if and when they are overlapping
  39 // returns `true` if collision was detected (but boxes aren't overlap)
  40 // `u1` and `u1` has no sense if no collision was detected (`hitx` and `hity` either)
  41 // u0 = normalized time of first collision (i.e. collision starts at myMove*u0)
  42 // u1 = normalized time of second collision (i.e. collision stops after myMove*u1)
  43 // hitedge for `it`: it will probably be `None` if no collision was detected, but it is not guaranteed
  44 // enter/exit coords will form non-intersecting configuration (i.e. will be before/after the actual collision)
  45 // but beware of floating point inexactness; `sweepAABB()` will try to (crudely) compensate for it
  46 // while calculating `hitx` and `hity`.
  47 function sweepAABB (mex0, mey0, mew, meh: Integer; medx, medy: Integer; itx0, ity0, itw, ith: Integer;
  48                     u0: PSingle=nil; hitedge: PSweepEdge=nil; u1: PSingle=nil;
  49                     hitx: PInteger=nil; hity: PInteger=nil): Boolean;
  50
  51 function distanceSq (x0, y0, x1, y1: Integer): Integer; inline;
  52
  53
  54 implementation
  55
  56
  57 // ////////////////////////////////////////////////////////////////////////// //
  58 function distanceSq (x0, y0, x1, y1: Integer): Integer; inline; begin result := (x1-x0)*(x1-x0)+(y1-y0)*(y1-y0); end;
  59
  60
  61 // ////////////////////////////////////////////////////////////////////////// //
  62 function clipLine (var x0, y0, x1, y1: Single; xmin, ymin, xmax, ymax: Single): Boolean;
  63 const
  64   Inside = 0;
  65   Left = 1;
  66   Right = 2;
  67   Bottom = 4;
  68   Top = 8;
  69
  70   function xcode (x, y: Single): Byte; inline;
  71   begin
  72     result := Inside;
  73     if (x < xmin) then result := result or Left else if (x > xmax) then result := result or Right;
  74     if (y < ymin) then result := result or Bottom else if (y > ymax) then result := result or Top;
  75   end;
  76
  77 var
  78   outcode0, outcode1, outcodeOut: Byte;
  79   x: Single = 0;
  80   y: Single = 0;
  81 begin
  82   result := false; // accept
  83   outcode0 := xcode(x0, y0);
  84   outcode1 := xcode(x1, y1);
  85   while true do
  86   begin
  87     if ((outcode0 or outcode1) = 0) then begin result := true; exit; end; // accept
  88     if ((outcode0 and outcode1) <> 0) then exit; // reject
  89     outcodeOut := outcode0;
  90     if (outcodeOut = 0) then outcodeOut := outcode1;
  91     if ((outcodeOut and Top) <> 0) then
  92     begin
  93       x := x0+(x1-x0)*(ymax-y0)/(y1-y0);
  94       y := ymax;
  95     end
  96     else if ((outcodeOut and Bottom) <> 0) then
  97     begin
  98       x := x0+(x1-x0)*(ymin-y0)/(y1-y0);
  99       y := ymin;
 100     end
 101     else if ((outcodeOut and Right) <> 0) then
 102     begin
 103       y := y0+(y1-y0)*(xmax-x0)/(x1-x0);
 104       x := xmax;
 105     end
 106     else if ((outcodeOut and Left) <> 0) then
 107     begin
 108       y := y0+(y1-y0)*(xmin-x0)/(x1-x0);
 109       x := xmin;
 110     end;
 111     if (outcodeOut = outcode0) then
 112     begin
 113       x0 := x;
 114       y0 := y;
 115       outcode0 := xcode(x0, y0);
 116     end
 117     else
 118     begin
 119       x1 := x;
 120       y1 := y;
 121       outcode1 := xcode(x1, y1);
 122     end;
 123   end;
 124 end;
 125
 126
 127 // returns `true` if there is an intersection (if starting point is inside the box, it counts as intersection)
 128 function lineAABBIntersects (x0, y0, x1, y1: Integer; bx, by, bw, bh: Integer): Boolean;
 129 var
 130   sx0, sy0, sx1, sy1: Single;
 131 begin
 132   result := false;
 133   if (bw < 1) or (bh < 1) then exit;
 134   if (x0 >= bx) and (y0 >= by) and (x0 < bx+bw) and (y0 < by+bh) then begin result := true; exit; end;
 135   sx0 := x0; sy0 := y0;
 136   sx1 := x1; sy1 := y1;
 137   result := clipLine(sx0, sy0, sx1, sy1, bx, by, bx+bw-1, by+bh-1);
 138 end;
 139
 140
 141 // returns `true` if there is an intersection, and enter coords
 142 // enter coords will be equal to (x0, y0) if starting point is inside the box
 143 // if result is `false`, `inx` and `iny` are undefined
 144 function lineAABBIntersects (x0, y0, x1, y1: Integer; bx, by, bw, bh: Integer; out inx, iny: Integer): Boolean;
 145 var
 146   sx0, sy0, sx1, sy1: Single;
 147 begin
 148   inx := x0;
 149   iny := y0;
 150   result := false;
 151   if (bw < 1) or (bh < 1) then exit;
 152   if (x0 >= bx) and (y0 >= by) and (x0 < bx+bw) and (y0 < by+bh) then begin result := true; exit; end;
 153   sx0 := x0; sy0 := y0;
 154   sx1 := x1; sy1 := y1;
 155   result := clipLine(sx0, sy0, sx1, sy1, bx, by, bx+bw-1, by+bh-1);
 156   if result then
 157   begin
 158     inx := trunc(sx0);
 159     iny := trunc(sy0);
 160     // hack!
 161     if (inx = bx) then Dec(inx) else if (inx = bx+bw-1) then Inc(inx);
 162     if (iny = by) then Dec(iny) else if (iny = by+bh-1) then Inc(iny);
 163   end
 164   else
 165   begin
 166     inx := x1;
 167     iny := y1;
 168   end;
 169 end;
 170
 171
 172 // ////////////////////////////////////////////////////////////////////////// //
 173 function sweepAABB (mex0, mey0, mew, meh: Integer; medx, medy: Integer; itx0, ity0, itw, ith: Integer;
 174                     u0: PSingle=nil; hitedge: PSweepEdge=nil; u1: PSingle=nil;
 175                     hitx: PInteger=nil; hity: PInteger=nil): Boolean;
 176 var
 177   tin, tout: Single;
 178
 179   function axisOverlap (me0, me1, it0, it1, d: Integer; he0, he1: TSweepEdge): Boolean; inline;
 180   var
 181     t: Single;
 182   begin
 183     result := false;
 184
 185     if (me1 < it0) then
 186     begin
 187       if (d >= 0) then exit; // oops, no hit
 188       t := (me1-it0+1)/d;
 189       if (t > tin) then begin tin := t; hitedge^ := he1; end;
 190     end
 191     else if (it1 < me0) then
 192     begin
 193       if (d <= 0) then exit; // oops, no hit
 194       t := (me0-it1-1)/d;
 195       if (t > tin) then begin tin := t; hitedge^ := he0; end;
 196     end;
 197
 198     if (d < 0) and (it1 > me0) then
 199     begin
 200       t := (me0-it1-1)/d;
 201       if (t < tout) then tout := t;
 202     end
 203     else if (d > 0) and (me1 > it0) then
 204     begin
 205       t := (me1-it0+1)/d;
 206       if (t < tout) then tout := t;
 207     end;
 208
 209     result := true;
 210   end;
 211
 212 var
 213   mex1, mey1, itx1, ity1, vx, vy, ex, ey: Integer;
 214   htt: TSweepEdge = TSweepEdge.None; // has no sense, who cares
 215 begin
 216   result := false;
 217   if (u0 <> nil) then u0^ := -1.0;
 218   if (u1 <> nil) then u1^ := -1.0;
 219   if (hitx <> nil) then hitx^ := mex0;
 220   if (hity <> nil) then hity^ := mey0;
 221   if (hitedge = nil) then hitedge := @htt else hitedge^ := TSweepEdge.None;
 222
 223   if (mew < 1) or (meh < 1) or (itw < 1) or (ith < 1) then exit;
 224
 225   mex1 := mex0+mew-1;
 226   mey1 := mey0+meh-1;
 227   itx1 := itx0+itw-1;
 228   ity1 := ity0+ith-1;
 229
 230   // check if they are overlapping right now (SAT)
 231   //if (mex1 >= itx0) and (mex0 <= itx1) and (mey1 >= ity0) and (mey0 <= ity1) then begin result := true; exit; end;
 232
 233   if (medx = 0) and (medy = 0) then exit; // both boxes are sationary
 234
 235   // treat b as stationary, so invert v to get relative velocity
 236   vx := -medx;
 237   vy := -medy;
 238
 239   tin := -100000000.0;
 240   tout := 100000000.0;
 241
 242   if not axisOverlap(mex0, mex1, itx0, itx1, vx, TSweepEdge.Right, TSweepEdge.Left) then exit;
 243   if not axisOverlap(mey0, mey1, ity0, ity1, vy, TSweepEdge.Bottom, TSweepEdge.Top) then exit;
 244
 245   if (u0 <> nil) then u0^ := tin;
 246   if (u1 <> nil) then u1^ := tout;
 247
 248   if (tin <= tout) and (tin >= 0.0) and (tin <= 1.0) then
 249   begin
 250     result := true;
 251     if (hitx <> nil) or (hity <> nil) then
 252     begin
 253       ex := mex0+round(medx*tin);
 254       ey := mey0+round(medy*tin);
 255       // just in case, compensate for floating point inexactness
 256       if (ex >= itx0) and (ey >= ity0) and (ex < itx0+itw) and (ey < ity0+ith) then
 257       begin
 258         ex := mex0+trunc(medx*tin);
 259         ey := mey0+trunc(medy*tin);
 260       end;
 261       if (hitx <> nil) then hitx^ := ex;
 262       if (hity <> nil) then hity^ := ey;
 263     end;
 264   end;
 265 end;
 266
 267
 268 end.