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