1 (*
2 * Hedgewars, a free turn based strategy game
3 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
4 *
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; version 2 of the License
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
17 *)
18
19 {$INCLUDE "options.inc"}
20
21 unit uCollisions;
22 interface
23 uses uFloat, uTypes, uUtils;
24
25 const cMaxGearArrayInd = 1023;
26 const cMaxGearHitOrderInd = 1023;
27 const cMaxGearProximityCacheInd = 1023;
28
29 type PGearArray = ^TGearArray;
30 TGearArray = record
31 ar: array[0..cMaxGearArrayInd] of PGear;
32 cX: array[0..cMaxGearArrayInd] of LongInt;
33 cY: array[0..cMaxGearArrayInd] of LongInt;
34 Count: Longword
35 end;
36
37 type PGearHitOrder = ^TGearHitOrder;
38 TGearHitOrder = record
39 ar: array[0..cMaxGearHitOrderInd] of PGear;
40 order: array[0..cMaxGearHitOrderInd] of LongInt;
41 Count: Longword
42 end;
43
44 type PGearProximityCache = ^TGearProximityCache;
45 TGearProximityCache = record
46 ar: array[0..cMaxGearProximityCacheInd] of PGear;
47 Count: Longword
48 end;
49
50 type TLineCollision = record
51 hasCollision: Boolean;
52 cX, cY: LongInt; //for visual effects only
53 end;
54
55 procedure initModule;
56 procedure freeModule;
57
58 procedure AddCI(Gear: PGear);
59 procedure DeleteCI(Gear: PGear);
60
CheckGearsCollisionnull61 function CheckGearsCollision(Gear: PGear): PGearArray;
CheckAllGearsCollisionnull62 function CheckAllGearsCollision(SourceGear: PGear): PGearArray;
CheckCacheCollisionnull63 function CheckCacheCollision(SourceGear: PGear): PGearArray;
64
CheckGearsLineCollisionnull65 function CheckGearsLineCollision(Gear: PGear; oX, oY, tX, tY: hwFloat): PGearArray;
CheckAllGearsLineCollisionnull66 function CheckAllGearsLineCollision(SourceGear: PGear; oX, oY, tX, tY: hwFloat): PGearArray;
67
UpdateHitOrdernull68 function UpdateHitOrder(Gear: PGear; Order: LongInt): boolean;
69 procedure ClearHitOrderLeq(MinOrder: LongInt);
70 procedure ClearHitOrder();
71
72 procedure RefillProximityCache(SourceGear: PGear; radius: LongInt);
73 procedure RemoveFromProximityCache(Gear: PGear);
74 procedure ClearProximityCache();
75
TestCollisionXwithGearnull76 function TestCollisionXwithGear(Gear: PGear; Dir: LongInt): Word;
TestCollisionYwithGearnull77 function TestCollisionYwithGear(Gear: PGear; Dir: LongInt): Word;
78
TestCollisionXKicknull79 function TestCollisionXKick(Gear: PGear; Dir: LongInt): Word;
TestCollisionYKicknull80 function TestCollisionYKick(Gear: PGear; Dir: LongInt): Word;
81
TestCollisionXnull82 function TestCollisionX(Gear: PGear; Dir: LongInt): Word;
TestCollisionYnull83 function TestCollisionY(Gear: PGear; Dir: LongInt): Word;
84
TestCollisionXwithXYShiftnull85 function TestCollisionXwithXYShift(Gear: PGear; ShiftX: hwFloat; ShiftY: LongInt; Dir: LongInt): Word; inline;
TestCollisionXwithXYShiftnull86 function TestCollisionXwithXYShift(Gear: PGear; ShiftX: hwFloat; ShiftY: LongInt; Dir: LongInt; withGear: boolean): Word;
TestCollisionYwithXYShiftnull87 function TestCollisionYwithXYShift(Gear: PGear; ShiftX, ShiftY: LongInt; Dir: LongInt): Word; inline;
TestCollisionYwithXYShiftnull88 function TestCollisionYwithXYShift(Gear: PGear; ShiftX, ShiftY: LongInt; Dir: LongInt; withGear: boolean): Word;
89
TestRectangleForObstaclenull90 function TestRectangleForObstacle(x1, y1, x2, y2: LongInt; landOnly: boolean): boolean;
91
CheckCoordInWaternull92 function CheckCoordInWater(X, Y: LongInt): boolean; inline;
93
94 // returns: negative sign if going downhill to left, value is steepness (noslope/error = _0, 45 = _0_5)
CalcSlopeBelowGearnull95 function CalcSlopeBelowGear(Gear: PGear): hwFloat;
CalcSlopeNearGearnull96 function CalcSlopeNearGear(Gear: PGear; dirX, dirY: LongInt): hwFloat;
CalcSlopeTangentnull97 function CalcSlopeTangent(Gear: PGear; collisionX, collisionY: LongInt; var outDeltaX, outDeltaY: LongInt; TestWord: LongWord): boolean;
98
CheckGearsUnderSpritenull99 function CheckGearsUnderSprite(Sprite: TSprite; sprX, sprY, Frame: LongInt): boolean;
100
101 implementation
102 uses uConsts, uLandGraphics, uVariables, SDLh, uLandTexture, uDebug;
103
104 type TCollisionEntry = record
105 X, Y, Radius: LongInt;
106 cGear: PGear;
107 end;
108
109 const MAXRECTSINDEX = 1023;
110 var Count: Longword;
111 cinfos: array[0..MAXRECTSINDEX] of TCollisionEntry;
112 ga: TGearArray;
113 ordera: TGearHitOrder;
114 proximitya: TGearProximityCache;
115
116 procedure AddCI(Gear: PGear);
117 begin
118 if (Gear^.CollisionIndex >= 0) or (Count > MAXRECTSINDEX) or
119 ((Count > MAXRECTSINDEX-200) and ((Gear^.Kind = gtMine) or (Gear^.Kind = gtSMine) or (Gear^.Kind = gtKnife))) then
120 exit;
121
122 with cinfos[Count] do
123 begin
124 X:= hwRound(Gear^.X);
125 Y:= hwRound(Gear^.Y);
126 Radius:= Gear^.Radius;
127 ChangeRoundInLand(X, Y, Radius - 1, true, ((CurrentHedgehog <> nil) and (Gear = CurrentHedgehog^.Gear)) or ((Gear^.Kind = gtCase) and (Gear^.State and gstFrozen = 0)), Gear^.Kind = gtHedgehog);
128 cGear:= Gear
129 end;
130 Gear^.CollisionIndex:= Count;
131 inc(Count);
132 end;
133
134 procedure DeleteCI(Gear: PGear);
135 begin
136 if Gear^.CollisionIndex >= 0 then
137 begin
138 with cinfos[Gear^.CollisionIndex] do
139 ChangeRoundInLand(X, Y, Radius - 1, false, ((CurrentHedgehog <> nil) and (Gear = CurrentHedgehog^.Gear)) or ((Gear^.Kind = gtCase) and (Gear^.State and gstFrozen = 0)), Gear^.Kind = gtHedgehog);
140 cinfos[Gear^.CollisionIndex]:= cinfos[Pred(Count)];
141 cinfos[Gear^.CollisionIndex].cGear^.CollisionIndex:= Gear^.CollisionIndex;
142 Gear^.CollisionIndex:= -1;
143 dec(Count)
144 end;
145 end;
146
CheckCoordInWaternull147 function CheckCoordInWater(X, Y: LongInt): boolean; inline;
148 begin
149 CheckCoordInWater:= (Y > cWaterLine)
150 or ((WorldEdge = weSea) and ((X < leftX) or (X > rightX)));
151 end;
152
CheckGearsCollisionnull153 function CheckGearsCollision(Gear: PGear): PGearArray;
154 var mx, my, tr: LongInt;
155 i: Longword;
156 begin
157 CheckGearsCollision:= @ga;
158 ga.Count:= 0;
159 if Count = 0 then
160 exit;
161 mx:= hwRound(Gear^.X);
162 my:= hwRound(Gear^.Y);
163
164 tr:= Gear^.Radius + 2;
165
166 for i:= 0 to Pred(Count) do
167 with cinfos[i] do
168 if (Gear <> cGear) and
169 (sqr(mx - x) + sqr(my - y) <= sqr(Radius + tr)) then
170 begin
171 ga.ar[ga.Count]:= cinfos[i].cGear;
172 ga.cX[ga.Count]:= hwround(Gear^.X);
173 ga.cY[ga.Count]:= hwround(Gear^.Y);
174 inc(ga.Count)
175 end
176 end;
177
CheckAllGearsCollisionnull178 function CheckAllGearsCollision(SourceGear: PGear): PGearArray;
179 var mx, my, tr: LongInt;
180 Gear: PGear;
181 begin
182 CheckAllGearsCollision:= @ga;
183 ga.Count:= 0;
184
185 mx:= hwRound(SourceGear^.X);
186 my:= hwRound(SourceGear^.Y);
187
188 tr:= SourceGear^.Radius + 2;
189
190 Gear:= GearsList;
191
192 while Gear <> nil do
193 begin
194 if (Gear <> SourceGear) and
195 (sqr(mx - hwRound(Gear^.x)) + sqr(my - hwRound(Gear^.y)) <= sqr(Gear^.Radius + tr))then
196 begin
197 ga.ar[ga.Count]:= Gear;
198 ga.cX[ga.Count]:= mx;
199 ga.cY[ga.Count]:= my;
200 inc(ga.Count)
201 end;
202
203 Gear := Gear^.NextGear
204 end;
205 end;
206
LineCollisionTestnull207 function LineCollisionTest(oX, oY, dirX, dirY, dirNormSqr, dirNormBound: hwFloat;
208 width: LongInt; Gear: PGear):
209 TLineCollision; inline;
210 var toCenterX, toCenterY, r,
211 b, bSqr, c, desc, t: hwFloat;
212 realT: extended;
213 begin
214 LineCollisionTest.hasCollision:= false;
215 toCenterX:= (oX - Gear^.X);
216 toCenterY:= (oY - Gear^.Y);
217 r:= int2hwFloat(Gear^.Radius + width + 2);
218 // Early cull to avoid multiplying large numbers
219 if hwAbs(toCenterX) + hwAbs(toCenterY) > dirNormBound + r then
220 exit;
221 b:= dirX * toCenterX + dirY * toCenterY;
222 c:= hwSqr(toCenterX) + hwSqr(toCenterY) - hwSqr(r);
223 if (b > _0) and (c > _0) then
224 exit;
225 bSqr:= hwSqr(b);
226 desc:= bSqr - dirNormSqr * c;
227 if desc.isNegative then exit;
228
229 t:= -b - hwSqrt(desc);
230 if t.isNegative then t:= _0;
231 if t < dirNormSqr then
232 with LineCollisionTest do
233 begin
234 hasCollision:= true;
235 realT := hwFloat2Float(t) / hwFloat2Float(dirNormSqr);
236 cX:= round(hwFloat2Float(oX) + realT * hwFloat2Float(dirX));
237 cY:= round(hwFloat2Float(oY) + realT * hwFloat2Float(dirY));
238 end;
239 end;
240
CheckGearsLineCollisionnull241 function CheckGearsLineCollision(Gear: PGear; oX, oY, tX, tY: hwFloat): PGearArray;
242 var dirX, dirY, dirNormSqr, dirNormBound: hwFloat;
243 test: TLineCollision;
244 i: Longword;
245 begin
246 CheckGearsLineCollision:= @ga;
247 ga.Count:= 0;
248 if Count = 0 then
249 exit;
250 dirX:= (tX - oX);
251 dirY:= (tY - oY);
252 dirNormBound:= _1_5 * (hwAbs(dirX) + hwAbs(dirY));
253 dirNormSqr:= hwSqr(dirX) + hwSqr(dirY);
254 if dirNormSqr.isNegative then
255 exit;
256
257 for i:= 0 to Pred(Count) do
258 with cinfos[i] do if Gear <> cGear then
259 begin
260 test:= LineCollisionTest(
261 oX, oY, dirX, dirY, dirNormSqr, dirNormBound, Gear^.Radius, cGear);
262 if test.hasCollision then
263 begin
264 ga.ar[ga.Count] := cGear;
265 ga.cX[ga.Count] := test.cX;
266 ga.cY[ga.Count] := test.cY;
267 inc(ga.Count)
268 end
269 end
270 end;
271
CheckAllGearsLineCollisionnull272 function CheckAllGearsLineCollision(SourceGear: PGear; oX, oY, tX, tY: hwFloat): PGearArray;
273 var dirX, dirY, dirNormSqr, dirNormBound: hwFloat;
274 test: TLineCollision;
275 Gear: PGear;
276 begin
277 CheckAllGearsLineCollision:= @ga;
278 ga.Count:= 0;
279 dirX:= (tX - oX);
280 dirY:= (tY - oY);
281 dirNormBound:= _1_5 * (hwAbs(dirX) + hwAbs(dirY));
282 dirNormSqr:= hwSqr(dirX) + hwSqr(dirY);
283 if dirNormSqr.isNegative then
284 exit;
285
286 Gear:= GearsList;
287 while Gear <> nil do
288 begin
289 if SourceGear <> Gear then
290 begin
291 test:= LineCollisionTest(
292 oX, oY, dirX, dirY, dirNormSqr, dirNormBound, SourceGear^.Radius, Gear);
293 if test.hasCollision then
294 begin
295 ga.ar[ga.Count] := Gear;
296 ga.cX[ga.Count] := test.cX;
297 ga.cY[ga.Count] := test.cY;
298 inc(ga.Count)
299 end
300 end;
301 Gear := Gear^.NextGear
302 end;
303 end;
304
CheckCacheCollisionnull305 function CheckCacheCollision(SourceGear: PGear): PGearArray;
306 var mx, my, tr, i: LongInt;
307 Gear: PGear;
308 begin
309 CheckCacheCollision:= @ga;
310 ga.Count:= 0;
311
312 mx:= hwRound(SourceGear^.X);
313 my:= hwRound(SourceGear^.Y);
314
315 tr:= SourceGear^.Radius + 2;
316
317 for i:= 0 to proximitya.Count - 1 do
318 begin
319 Gear:= proximitya.ar[i];
320 // Assuming the cache has been filled correctly, it will not contain SourceGear
321 // and other gears won't be far enough for sqr overflow
322 if (sqr(mx - hwRound(Gear^.X)) + sqr(my - hwRound(Gear^.Y)) <= sqr(Gear^.Radius + tr)) then
323 begin
324 ga.ar[ga.Count]:= Gear;
325 ga.cX[ga.Count]:= mx;
326 ga.cY[ga.Count]:= my;
327 inc(ga.Count)
328 end;
329 end;
330 end;
331
332 function UpdateHitOrder(Gear: PGear; Order: LongInt): boolean;
333 var i: LongInt;
334 begin
335 UpdateHitOrder:= true;
336 for i:= 0 to ordera.Count - 1 do
337 if ordera.ar[i] = Gear then
338 begin
339 if Order <= ordera.order[i] then UpdateHitOrder:= false;
340 ordera.order[i]:= Max(ordera.order[i], order);
341 exit;
342 end;
343
344 if ordera.Count > cMaxGearHitOrderInd then
345 UpdateHitOrder:= false
346 else
347 begin
348 ordera.ar[ordera.Count]:= Gear;
349 ordera.order[ordera.Count]:= Order;
350 Inc(ordera.Count);
351 end
352 end;
353
354 procedure ClearHitOrderLeq(MinOrder: LongInt);
355 var i, freeIndex: LongInt;
356 begin;
357 freeIndex:= 0;
358 i:= 0;
359
360 while i < ordera.Count do
361 begin
362 if ordera.order[i] <= MinOrder then
363 Dec(ordera.Count)
364 else
365 begin
366 if freeIndex < i then
367 begin
368 ordera.ar[freeIndex]:= ordera.ar[i];
369 ordera.order[freeIndex]:= ordera.order[i];
370 end;
371 Inc(freeIndex);
372 end;
373 Inc(i)
374 end
375 end;
376
377 procedure ClearHitOrder();
378 begin
379 ordera.Count:= 0;
380 end;
381
382 procedure RefillProximityCache(SourceGear: PGear; radius: LongInt);
383 var cx, cy, dx, dy, r: LongInt;
384 Gear: PGear;
385 begin
386 proximitya.Count:= 0;
387 cx:= hwRound(SourceGear^.X);
388 cy:= hwRound(SourceGear^.Y);
389 Gear:= GearsList;
390
391 while (Gear <> nil) and (proximitya.Count <= cMaxGearProximityCacheInd) do
392 begin
393 dx:= abs(hwRound(Gear^.X) - cx);
394 dy:= abs(hwRound(Gear^.Y) - cy);
395 r:= radius + Gear^.radius + 2;
396 if (Gear <> SourceGear) and (max(dx, dy) <= r) and (sqr(dx) + sqr(dy) <= sqr(r)) then
397 begin
398 proximitya.ar[proximitya.Count]:= Gear;
399 inc(proximitya.Count)
400 end;
401 Gear := Gear^.NextGear
402 end;
403 end;
404
405 procedure RemoveFromProximityCache(Gear: PGear);
406 var i: LongInt;
407 begin
408 i := 0;
409 while i < proximitya.Count do
410 begin
411 if proximitya.ar[i] = Gear then
412 begin
413 proximitya.ar[i]:= proximitya.ar[proximitya.Count - 1];
414 dec(proximitya.Count);
415 end
416 else
417 inc(i);
418 end;
419 end;
420
421 procedure ClearProximityCache();
422 begin
423 proximitya.Count:= 0;
424 end;
425
426 function TestCollisionXwithGear(Gear: PGear; Dir: LongInt): Word;
427 var x, y, i: LongInt;
428 begin
429 // Special case to emulate the old intersect gear clearing, but with a bit of slop for pixel overlap
430 if (Gear^.CollisionMask = lfNotCurHogCrate) and (Gear^.Kind <> gtHedgehog) and (Gear^.Hedgehog <> nil) and (Gear^.Hedgehog^.Gear <> nil) and
431 ((hwRound(Gear^.Hedgehog^.Gear^.X) + Gear^.Hedgehog^.Gear^.Radius + 16 < hwRound(Gear^.X) - Gear^.Radius) or
432 (hwRound(Gear^.Hedgehog^.Gear^.X) - Gear^.Hedgehog^.Gear^.Radius - 16 > hwRound(Gear^.X) + Gear^.Radius)) then
433 Gear^.CollisionMask:= lfAll;
434
435 x:= hwRound(Gear^.X);
436 if Dir < 0 then
437 x:= x - Gear^.Radius
438 else
439 x:= x + Gear^.Radius;
440
441 if (x and LAND_WIDTH_MASK) = 0 then
442 begin
443 y:= hwRound(Gear^.Y) - Gear^.Radius + 1;
444 i:= y + Gear^.Radius * 2 - 2;
445 repeat
446 if (y and LAND_HEIGHT_MASK) = 0 then
447 if Land[y, x] and Gear^.CollisionMask <> 0 then
448 exit(Land[y, x] and Gear^.CollisionMask);
449 inc(y)
450 until (y > i);
451 end;
452 TestCollisionXwithGear:= 0
453 end;
454
455 function TestCollisionYwithGear(Gear: PGear; Dir: LongInt): Word;
456 var x, y, i: LongInt;
457 begin
458 // Special case to emulate the old intersect gear clearing, but with a bit of slop for pixel overlap
459 if (Gear^.CollisionMask = lfNotCurHogCrate) and (Gear^.Kind <> gtHedgehog) and (Gear^.Hedgehog <> nil) and (Gear^.Hedgehog^.Gear <> nil) and
460 ((hwRound(Gear^.Hedgehog^.Gear^.Y) + Gear^.Hedgehog^.Gear^.Radius + 16 < hwRound(Gear^.Y) - Gear^.Radius) or
461 (hwRound(Gear^.Hedgehog^.Gear^.Y) - Gear^.Hedgehog^.Gear^.Radius - 16 > hwRound(Gear^.Y) + Gear^.Radius)) then
462 Gear^.CollisionMask:= lfAll;
463
464 y:= hwRound(Gear^.Y);
465 if Dir < 0 then
466 y:= y - Gear^.Radius
467 else
468 y:= y + Gear^.Radius;
469
470 if (y and LAND_HEIGHT_MASK) = 0 then
471 begin
472 x:= hwRound(Gear^.X) - Gear^.Radius + 1;
473 i:= x + Gear^.Radius * 2 - 2;
474 repeat
475 if (x and LAND_WIDTH_MASK) = 0 then
476 if Land[y, x] and Gear^.CollisionMask <> 0 then
477 begin
478 exit(Land[y, x] and Gear^.CollisionMask)
479 end;
480 inc(x)
481 until (x > i);
482 end;
483 TestCollisionYwithGear:= 0
484 end;
485
486 function TestCollisionXKick(Gear: PGear; Dir: LongInt): Word;
487 var x, y, mx, my, i: LongInt;
488 pixel: Word;
489 begin
490 pixel:= 0;
491 x:= hwRound(Gear^.X);
492 if Dir < 0 then
493 x:= x - Gear^.Radius
494 else
495 x:= x + Gear^.Radius;
496
497 if (x and LAND_WIDTH_MASK) = 0 then
498 begin
499 y:= hwRound(Gear^.Y) - Gear^.Radius + 1;
500 i:= y + Gear^.Radius * 2 - 2;
501 repeat
502 if (y and LAND_HEIGHT_MASK) = 0 then
503 begin
504 if Land[y, x] and Gear^.CollisionMask <> 0 then
505 begin
506 if ((Land[y, x] and Gear^.CollisionMask) and lfLandMask) <> 0 then
507 exit(Land[y, x] and Gear^.CollisionMask)
508 else
509 pixel:= Land[y, x] and Gear^.CollisionMask;
510 end;
511 end;
512 inc(y)
513 until (y > i);
514 end;
515 TestCollisionXKick:= pixel;
516
517 if pixel <> 0 then
518 begin
519 if hwAbs(Gear^.dX) < cHHKick then
520 exit;
521 if (Gear^.State and gstHHJumping <> 0)
522 and (hwAbs(Gear^.dX) < _0_4) then
523 exit;
524
525 mx:= hwRound(Gear^.X);
526 my:= hwRound(Gear^.Y);
527
528 for i:= 0 to Pred(Count) do
529 with cinfos[i] do
530 if (Gear <> cGear) and
531 ((mx > x) xor (Dir > 0)) and
532 (
533 ((cGear^.Kind in [gtHedgehog, gtMine, gtKnife]) and ((Gear^.State and gstNotKickable) = 0)) or
534 // only apply X kick if the barrel is knocked over
535 ((cGear^.Kind = gtExplosives) and ((cGear^.State and gsttmpflag) <> 0))
536 ) and
537 (sqr(mx - x) + sqr(my - y) <= sqr(Radius + Gear^.Radius + 2)) then
538 begin
539 with cGear^ do
540 begin
541 dX:= Gear^.dX;
542 dY:= Gear^.dY * _0_5;
543 State:= State or gstMoving;
544 if Kind = gtKnife then State:= State and (not gstCollision);
545 Active:= true
546 end;
547 DeleteCI(cGear);
548 exit(0);
549 end
550 end
551 end;
552
553 function TestCollisionYKick(Gear: PGear; Dir: LongInt): Word;
554 var x, y, mx, my, myr, i: LongInt;
555 pixel: Word;
556 begin
557 pixel:= 0;
558 y:= hwRound(Gear^.Y);
559 if Dir < 0 then
560 y:= y - Gear^.Radius
561 else
562 y:= y + Gear^.Radius;
563
564 if (y and LAND_HEIGHT_MASK) = 0 then
565 begin
566 x:= hwRound(Gear^.X) - Gear^.Radius + 1;
567 i:= x + Gear^.Radius * 2 - 2;
568 repeat
569 if (x and LAND_WIDTH_MASK) = 0 then
570 if Land[y, x] > 0 then
571 begin
572 if ((Land[y, x] and Gear^.CollisionMask) and lfLandMask) <> 0 then
573 exit(Land[y, x] and Gear^.CollisionMask)
574 else // if Land[y, x] <> 0 then
575 pixel:= Land[y, x] and Gear^.CollisionMask;
576 end;
577 inc(x)
578 until (x > i);
579 end;
580 TestCollisionYKick:= pixel;
581
582 if pixel <> 0 then
583 begin
584 if hwAbs(Gear^.dY) < cHHKick then
585 exit;
586 if (Gear^.State and gstHHJumping <> 0) and (not Gear^.dY.isNegative) and (Gear^.dY < _0_4) then
587 exit;
588
589 mx:= hwRound(Gear^.X);
590 my:= hwRound(Gear^.Y);
591 myr:= my+Gear^.Radius;
592
593 for i:= 0 to Pred(Count) do
594 with cinfos[i] do
595 if (Gear <> cGear) and
596 ((myr > y) xor (Dir > 0)) and
597 (Gear^.State and gstNotKickable = 0) and
598 (cGear^.Kind in [gtHedgehog, gtMine, gtKnife, gtExplosives]) and
599 (sqr(mx - x) + sqr(my - y) <= sqr(Radius + Gear^.Radius + 2)) then
600 begin
601 with cGear^ do
602 begin
603 if (Kind <> gtExplosives) or ((State and gsttmpflag) <> 0) then
604 dX:= Gear^.dX * _0_5;
605 dY:= Gear^.dY;
606 State:= State or gstMoving;
607 if Kind = gtKnife then State:= State and (not gstCollision);
608 Active:= true
609 end;
610 DeleteCI(cGear);
611 exit(0)
612 end
613 end
614 end;
615
616 function TestCollisionXwithXYShift(Gear: PGear; ShiftX: hwFloat; ShiftY: LongInt; Dir: LongInt): Word; inline;
617 begin
618 TestCollisionXwithXYShift:= TestCollisionXwithXYShift(Gear, ShiftX, ShiftY, Dir, true);
619 end;
620
621 function TestCollisionXwithXYShift(Gear: PGear; ShiftX: hwFloat; ShiftY: LongInt; Dir: LongInt; withGear: boolean): Word;
622 begin
623 Gear^.X:= Gear^.X + ShiftX;
624 Gear^.Y:= Gear^.Y + int2hwFloat(ShiftY);
625 if withGear then
626 TestCollisionXwithXYShift:= TestCollisionXwithGear(Gear, Dir)
627 else TestCollisionXwithXYShift:= TestCollisionX(Gear, Dir);
628 Gear^.X:= Gear^.X - ShiftX;
629 Gear^.Y:= Gear^.Y - int2hwFloat(ShiftY)
630 end;
631
632 function TestCollisionX(Gear: PGear; Dir: LongInt): Word;
633 var x, y, i: LongInt;
634 begin
635 x:= hwRound(Gear^.X);
636 if Dir < 0 then
637 x:= x - Gear^.Radius
638 else
639 x:= x + Gear^.Radius;
640
641 if (x and LAND_WIDTH_MASK) = 0 then
642 begin
643 y:= hwRound(Gear^.Y) - Gear^.Radius + 1;
644 i:= y + Gear^.Radius * 2 - 2;
645 repeat
646 if (y and LAND_HEIGHT_MASK) = 0 then
647 if ((Land[y, x] and Gear^.CollisionMask) and lfLandMask) <> 0 then
648 exit(Land[y, x] and Gear^.CollisionMask);
649 inc(y)
650 until (y > i);
651 end;
652 TestCollisionX:= 0
653 end;
654
655 function TestCollisionY(Gear: PGear; Dir: LongInt): Word;
656 var x, y, i: LongInt;
657 begin
658 y:= hwRound(Gear^.Y);
659 if Dir < 0 then
660 y:= y - Gear^.Radius
661 else
662 y:= y + Gear^.Radius;
663
664 if (y and LAND_HEIGHT_MASK) = 0 then
665 begin
666 x:= hwRound(Gear^.X) - Gear^.Radius + 1;
667 i:= x + Gear^.Radius * 2 - 2;
668 repeat
669 if (x and LAND_WIDTH_MASK) = 0 then
670 if ((Land[y, x] and Gear^.CollisionMask) and lfLandMask) <> 0 then
671 exit(Land[y, x] and Gear^.CollisionMask);
672 inc(x)
673 until (x > i);
674 end;
675 TestCollisionY:= 0
676 end;
677
678 function TestCollisionYwithXYShift(Gear: PGear; ShiftX, ShiftY: LongInt; Dir: LongInt): Word; inline;
679 begin
680 TestCollisionYwithXYShift:= TestCollisionYwithXYShift(Gear, ShiftX, ShiftY, Dir, true);
681 end;
682
683 function TestCollisionYwithXYShift(Gear: PGear; ShiftX, ShiftY: LongInt; Dir: LongInt; withGear: boolean): Word;
684 begin
685 Gear^.X:= Gear^.X + int2hwFloat(ShiftX);
686 Gear^.Y:= Gear^.Y + int2hwFloat(ShiftY);
687
688 if withGear then
689 TestCollisionYwithXYShift:= TestCollisionYwithGear(Gear, Dir)
690 else
691 TestCollisionYwithXYShift:= TestCollisionY(Gear, Dir);
692
693 Gear^.X:= Gear^.X - int2hwFloat(ShiftX);
694 Gear^.Y:= Gear^.Y - int2hwFloat(ShiftY)
695 end;
696
697 function TestRectangleForObstacle(x1, y1, x2, y2: LongInt; landOnly: boolean): boolean;
698 var x, y: LongInt;
699 TestWord: LongWord;
700 begin
701 TestRectangleForObstacle:= true;
702
703 if landOnly then
704 TestWord:= 255
705 else
706 TestWord:= 0;
707
708 if x1 > x2 then
709 begin
710 x := x1;
711 x1 := x2;
712 x2 := x;
713 end;
714
715 if y1 > y2 then
716 begin
717 y := y1;
718 y1 := y2;
719 y2 := y;
720 end;
721
722 if (hasBorder and ((y1 < 0) or (x1 < 0) or (x2 > LAND_WIDTH))) then
723 exit;
724
725 for y := y1 to y2 do
726 for x := x1 to x2 do
727 if ((y and LAND_HEIGHT_MASK) = 0) and ((x and LAND_WIDTH_MASK) = 0) and (Land[y, x] > TestWord) then
728 exit;
729
730 TestRectangleForObstacle:= false
731 end;
732
733 function CalcSlopeTangent(Gear: PGear; collisionX, collisionY: LongInt; var outDeltaX, outDeltaY: LongInt; TestWord: LongWord): boolean;
734 var ldx, ldy, rdx, rdy: LongInt;
735 i, j, k, mx, my, li, ri, jfr, jto, tmpo : ShortInt;
736 tmpx, tmpy: LongWord;
737 dx, dy, s: hwFloat;
738 offset: array[0..7,0..1] of ShortInt;
739 isColl: Boolean;
740
741 begin
742 CalcSlopeTangent:= false;
743
744 dx:= Gear^.dX;
745 dy:= Gear^.dY;
746
747 // we start searching from the direction the gear came from
748 if (dx.QWordValue > _0_995.QWordValue )
749 or (dy.QWordValue > _0_995.QWordValue ) then
750 begin // scale
751 s := _0_995 / Distance(dx,dy);
752 dx := s * dx;
753 dy := s * dy;
754 end;
755
756 mx:= hwRound(Gear^.X-dx) - hwRound(Gear^.X);
757 my:= hwRound(Gear^.Y-dy) - hwRound(Gear^.Y);
758
759 li:= -1;
760 ri:= -1;
761
762 // go around collision pixel, checking for first/last collisions
763 // this will determinate what angles will be tried to crawl along
764 for i:= 0 to 7 do
765 begin
766 offset[i,0]:= mx;
767 offset[i,1]:= my;
768
769 // multiplicator k tries to skip small pixels/gaps when possible
770 for k:= 4 downto 1 do
771 begin
772 tmpx:= collisionX + k * mx;
773 tmpy:= collisionY + k * my;
774
775 if (((tmpy) and LAND_HEIGHT_MASK) = 0) and (((tmpx) and LAND_WIDTH_MASK) = 0) then
776 if (Land[tmpy,tmpx] > TestWord) then
777 begin
778 // remember the index belonging to the first and last collision (if in 1st half)
779 if (i <> 0) then
780 begin
781 if (ri = -1) then
782 ri:= i
783 else
784 li:= i;
785 end;
786 end;
787 end;
788
789 if i = 7 then
790 break;
791
792 // prepare offset for next check (clockwise)
793 if (mx = -1) and (my <> -1) then
794 my:= my - 1
795 else if (my = -1) and (mx <> 1) then
796 mx:= mx + 1
797 else if (mx = 1) and (my <> 1) then
798 my:= my + 1
799 else
800 mx:= mx - 1;
801
802 end;
803
804 ldx:= collisionX;
805 ldy:= collisionY;
806 rdx:= collisionX;
807 rdy:= collisionY;
808
809 // edge-crawl
810 for i:= 0 to 8 do
811 begin
812 // using mx,my as temporary value buffer here
813
814 jfr:= 8+li+1;
815 jto:= 8+li-1;
816
817 isColl:= false;
818 for j:= jfr downto jto do
819 begin
820 tmpo:= j mod 8;
821 // multiplicator k tries to skip small pixels/gaps when possible
822 for k:= 3 downto 1 do
823 begin
824 tmpx:= ldx + k * offset[tmpo,0];
825 tmpy:= ldy + k * offset[tmpo,1];
826 if (((tmpy) and LAND_HEIGHT_MASK) = 0) and (((tmpx) and LAND_WIDTH_MASK) = 0)
827 and (Land[tmpy,tmpx] > TestWord) then
828 begin
829 ldx:= tmpx;
830 ldy:= tmpy;
831 isColl:= true;
832 break;
833 end;
834 end;
835 if isColl then
836 break;
837 end;
838
839 jfr:= 8+ri-1;
840 jto:= 8+ri+1;
841
842 isColl:= false;
843 for j:= jfr to jto do
844 begin
845 tmpo:= j mod 8;
846 for k:= 3 downto 1 do
847 begin
848 tmpx:= rdx + k * offset[tmpo,0];
849 tmpy:= rdy + k * offset[tmpo,1];
850 if (((tmpy) and LAND_HEIGHT_MASK) = 0) and (((tmpx) and LAND_WIDTH_MASK) = 0)
851 and (Land[tmpy,tmpx] > TestWord) then
852 begin
853 rdx:= tmpx;
854 rdy:= tmpy;
855 isColl:= true;
856 break;
857 end;
858 end;
859 if isColl then
860 break;
861 end;
862 end;
863
864 ldx:= rdx - ldx;
865 ldy:= rdy - ldy;
866
867 if ((ldx = 0) and (ldy = 0)) then
868 exit;
869
870 outDeltaX:= ldx;
871 outDeltaY:= ldy;
872 CalcSlopeTangent:= true;
873 end;
874
875 function CalcSlopeNearGear(Gear: PGear; dirX, dirY: LongInt): hwFloat;
876 var dx, dy: hwFloat;
877 collX, collY, i, y, x, gx, gy, sdx, sdy: LongInt;
878 isColl, bSucc: Boolean;
879 begin
880
881 if dirY <> 0 then
882 begin
883 y:= hwRound(Gear^.Y) + Gear^.Radius * dirY;
884 gx:= hwRound(Gear^.X);
885 collX := gx;
886 isColl:= false;
887
888 if (y and LAND_HEIGHT_MASK) = 0 then
889 begin
890 x:= hwRound(Gear^.X) - Gear^.Radius + 1;
891 i:= x + Gear^.Radius * 2 - 2;
892 repeat
893 if (x and LAND_WIDTH_MASK) = 0 then
894 if Land[y, x] <> 0 then
895 if (not isColl) or (abs(x-gx) < abs(collX-gx)) then
896 begin
897 isColl:= true;
898 collX := x;
899 end;
900 inc(x)
901 until (x > i);
902 end;
903 end
904 else
905 begin
906 x:= hwRound(Gear^.X) + Gear^.Radius * dirX;
907 gy:= hwRound(Gear^.Y);
908 collY := gy;
909 isColl:= false;
910
911 if (x and LAND_WIDTH_MASK) = 0 then
912 begin
913 y:= hwRound(Gear^.Y) - Gear^.Radius + 1;
914 i:= y + Gear^.Radius * 2 - 2;
915 repeat
916 if (y and LAND_HEIGHT_MASK) = 0 then
917 if Land[y, x] <> 0 then
918 if (not isColl) or (abs(y-gy) < abs(collY-gy)) then
919 begin
920 isColl:= true;
921 collY := y;
922 end;
923 inc(y)
924 until (y > i);
925 end;
926 end;
927
928 if isColl then
929 begin
930 // save original dx/dy
931 dx := Gear^.dX;
932 dy := Gear^.dY;
933
934 if dirY <> 0 then
935 begin
936 Gear^.dX.QWordValue:= 0;
937 Gear^.dX.isNegative:= (collX >= gx);
938 Gear^.dY:= _1*dirY
939 end
940 else
941 begin
942 Gear^.dY.QWordValue:= 0;
943 Gear^.dY.isNegative:= (collY >= gy);
944 Gear^.dX:= _1*dirX
945 end;
946
947 sdx:= 0;
948 sdy:= 0;
949 if dirY <> 0 then
950 bSucc := CalcSlopeTangent(Gear, collX, y, sdx, sdy, 0)
951 else bSucc := CalcSlopeTangent(Gear, x, collY, sdx, sdy, 0);
952
953 // restore original dx/dy
954 Gear^.dX := dx;
955 Gear^.dY := dy;
956
957 if bSucc and ((sdx <> 0) or (sdy <> 0)) then
958 begin
959 dx := int2hwFloat(sdy) / (abs(sdx) + abs(sdy));
960 dx.isNegative := (sdx * sdy) < 0;
961 exit (dx);
962 end
963 end;
964
965 CalcSlopeNearGear := _0;
966 end;
967
968 function CalcSlopeBelowGear(Gear: PGear): hwFloat;
969 var dx, dy: hwFloat;
970 collX, i, y, x, gx, sdx, sdy: LongInt;
971 isColl, bSucc: Boolean;
972 begin
973
974
975 y:= hwRound(Gear^.Y) + Gear^.Radius;
976 gx:= hwRound(Gear^.X);
977 collX := gx;
978 isColl:= false;
979
980 if (y and LAND_HEIGHT_MASK) = 0 then
981 begin
982 x:= hwRound(Gear^.X) - Gear^.Radius + 1;
983 i:= x + Gear^.Radius * 2 - 2;
984 repeat
985 if (x and LAND_WIDTH_MASK) = 0 then
986 if (Land[y, x] and lfLandMask) <> 0 then
987 if (not isColl) or (abs(x-gx) < abs(collX-gx)) then
988 begin
989 isColl:= true;
990 collX := x;
991 end;
992 inc(x)
993 until (x > i);
994 end;
995
996 if isColl then
997 begin
998 // save original dx/dy
999 dx := Gear^.dX;
1000 dy := Gear^.dY;
1001
1002 Gear^.dX.QWordValue:= 0;
1003 Gear^.dX.isNegative:= (collX >= gx);
1004 Gear^.dY:= _1;
1005
1006 sdx:= 0;
1007 sdy:= 0;
1008 bSucc := CalcSlopeTangent(Gear, collX, y, sdx, sdy, 255);
1009
1010 // restore original dx/dy
1011 Gear^.dX := dx;
1012 Gear^.dY := dy;
1013
1014 if bSucc and (sdx <> 0) and (sdy <> 0) then
1015 begin
1016 dx := int2hwFloat(sdy) / (abs(sdx) + abs(sdy));
1017 dx.isNegative := (sdx * sdy) < 0;
1018 exit (dx);
1019 end;
1020 end;
1021
1022 CalcSlopeBelowGear := _0;
1023 end;
1024
1025 function CheckGearsUnderSprite(Sprite: TSprite; sprX, sprY, Frame: LongInt): boolean;
1026 var x, y, bpp, h, w, row, col, gx, gy, r, numFramesFirstCol: LongInt;
1027 p: PByteArray;
1028 Image: PSDL_Surface;
1029 Gear: PGear;
1030 begin
1031 CheckGearsUnderSprite := false;
1032 if checkFails(SpritesData[Sprite].Surface <> nil, 'Assert SpritesData[Sprite].Surface failed', true) then exit;
1033
1034 numFramesFirstCol:= SpritesData[Sprite].imageHeight div SpritesData[Sprite].Height;
1035 Image:= SpritesData[Sprite].Surface;
1036
1037 if SDL_MustLock(Image) then
1038 if SDLCheck(SDL_LockSurface(Image) >= 0, 'CheckGearsUnderSprite', true) then exit;
1039
1040 bpp:= Image^.format^.BytesPerPixel;
1041
1042 if checkFails(bpp = 4, 'It should be 32 bpp sprite', true) then
1043 begin
1044 if SDL_MustLock(Image) then
1045 SDL_UnlockSurface(Image);
1046 exit
1047 end;
1048
1049 w:= SpritesData[Sprite].Width;
1050 h:= SpritesData[Sprite].Height;
1051
1052 row:= Frame mod numFramesFirstCol;
1053 col:= Frame div numFramesFirstCol;
1054 p:= PByteArray(@(PByteArray(Image^.pixels)^[ Image^.pitch * row * h + col * w * 4 ]));
1055 Gear:= GearsList;
1056
1057 while Gear <> nil do
1058 begin
1059 if (Gear^.Kind = gtAirMine) or
1060 ((Gear^.Kind in [gtCase, gtExplosives, gtTarget, gtKnife, gtMine, gtHedgehog, gtSMine]) and (Gear^.CollisionIndex = -1)) then
1061 begin
1062 gx:= hwRound(Gear^.X);
1063 gy:= hwRound(Gear^.Y);
1064 r:= Gear^.Radius + 1;
1065 if (gx + r >= sprX) and (gx - r < sprX + w) and (gy + r >= sprY) and (gy - r < sprY + h) then
1066 for y := gy - r to gy + r do
1067 for x := gx - r to gx + r do
1068 begin
1069 if (x >= sprX) and (x < sprX + w) and (y >= sprY) and (y < sprY + h)
1070 and (Sqr(x - gx) + Sqr(y - gy) <= Sqr(r))
1071 and (((PLongword(@(p^[Image^.pitch * (y - sprY) + (x - sprX) * 4]))^) and AMask) <> 0) then
1072 begin
1073 CheckGearsUnderSprite := true;
1074 if SDL_MustLock(Image) then
1075 SDL_UnlockSurface(Image);
1076 exit
1077 end
1078 end
1079 end;
1080
1081 Gear := Gear^.NextGear
1082 end;
1083 end;
1084
1085 procedure initModule;
1086 begin
1087 Count:= 0;
1088 end;
1089
1090 procedure freeModule;
1091 begin
1092
1093 end;
1094
1095 end.
1096