(*

 * Hedgewars, a free turn based strategy game

 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>

 *

 * This program is free software; you can redistribute it and/or modify

 * it under the terms of the GNU General Public License as published by

 * the Free Software Foundation; version 2 of the License

 *

 * This program is distributed in the hope that it will be useful,

 * but WITHOUT ANY WARRANTY; without even the implied warranty of

 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 * GNU General Public License for more details.

 *

 * You should have received a copy of the GNU General Public License

 * along with this program; if not, write to the Free Software

 * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

 *)

{$INCLUDE "options.inc"}

unit uCollisions;

interface

uses uFloat, uTypes, uUtils;

const cMaxGearArrayInd = 1023;

const cMaxGearHitOrderInd = 1023;

const cMaxGearProximityCacheInd = 1023;

type PGearArray = ^TGearArray;

    TGearArray = record

        ar: array[0..cMaxGearArrayInd] of PGear;

        cX: array[0..cMaxGearArrayInd] of LongInt;

        cY: array[0..cMaxGearArrayInd] of LongInt;

        Count: Longword

        end;

type PGearHitOrder = ^TGearHitOrder;

    TGearHitOrder = record

        ar: array[0..cMaxGearHitOrderInd] of PGear;

        order: array[0..cMaxGearHitOrderInd] of LongInt;

        Count: Longword

        end;

type PGearProximityCache = ^TGearProximityCache;

    TGearProximityCache = record

        ar: array[0..cMaxGearProximityCacheInd] of PGear;

        Count: Longword

        end;

type TLineCollision = record

        hasCollision: Boolean;

        cX, cY: LongInt; //for visual effects only

        end;

type TKickTest = record

        kick: Boolean;

        collisionMask: Word;

    end;

procedure initModule;

procedure freeModule;

procedure AddCI(Gear: PGear);

procedure DeleteCI(Gear: PGear);

function  CheckGearsCollision(Gear: PGear): PGearArray;

function  CheckAllGearsCollision(SourceGear: PGear): PGearArray;

function  CheckCacheCollision(SourceGear: PGear): PGearArray;

function  CheckGearsLineCollision(Gear: PGear; oX, oY, tX, tY: hwFloat): PGearArray;

function  CheckAllGearsLineCollision(SourceGear: PGear; oX, oY, tX, tY: hwFloat): PGearArray;

procedure ClearHitOrder();

procedure RefillProximityCache(SourceGear: PGear; radius: LongInt);

procedure RemoveFromProximityCache(Gear: PGear);

procedure ClearProximityCache();

function  TestCollisionXImpl(centerX, centerY, radius, direction: LongInt; collisionMask: Word): Word;

function  TestCollisionYImpl(centerX, centerY, radius, direction: LongInt; collisionMask: Word): Word;

function  TestCollisionXKickImpl(centerX, centerY, radius, direction: LongInt; collisionMask, kickMask: Word): TKickTest;

function  TestCollisionYKickImpl(centerX, centerY, radius, direction: LongInt; collisionMask, kickMask: Word): TKickTest;

function  TestCollisionXKick(Gear: PGear; Dir: LongInt): Word;

function  TestCollisionYKick(Gear: PGear; Dir: LongInt): Word;

function  TestRectangleForObstacle(x1, y1, x2, y2: LongInt; landOnly: boolean): boolean;

// returns: negative sign if going downhill to left, value is steepness (noslope/error = _0, 45 = _0_5)

function  CalcSlopeBelowGear(Gear: PGear): hwFloat;

function  CalcSlopeNearGear(Gear: PGear; dirX, dirY: LongInt): hwFloat;

function  CalcSlopeTangent(Gear: PGear; collisionX, collisionY: LongInt; var outDeltaX, outDeltaY: LongInt; TestWord: LongWord): boolean;

function CheckGearsUnderSprite(Sprite: TSprite; sprX, sprY, Frame: LongInt): boolean;

implementation

type TCollisionEntry = record

    X, Y, Radius: LongInt;

    cGear: PGear;

    end;

const MAXRECTSINDEX = 1023;

var Count: Longword;

    cinfos: array[0..MAXRECTSINDEX] of TCollisionEntry;

    ga: TGearArray;

    ordera: TGearHitOrder;

    globalordera: TGearHitOrder;

    proximitya: TGearProximityCache;

procedure AddCI(Gear: PGear);

begin

if (Gear^.CollisionIndex >= 0) or (Count > MAXRECTSINDEX) or

    ((Count > MAXRECTSINDEX-200) and ((Gear^.Kind = gtMine) or (Gear^.Kind = gtSMine) or (Gear^.Kind = gtKnife))) then

    exit;

with cinfos[Count] do

    begin

    X:= hwRound(Gear^.X);

    Y:= hwRound(Gear^.Y);

    Radius:= Gear^.Radius;

    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);

    cGear:= Gear

    end;

Gear^.CollisionIndex:= Count;

inc(Count);

end;

procedure DeleteCI(Gear: PGear);

begin

if Gear^.CollisionIndex >= 0 then

    begin

    with cinfos[Gear^.CollisionIndex] do

        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);

    cinfos[Gear^.CollisionIndex]:= cinfos[Pred(Count)];

    cinfos[Gear^.CollisionIndex].cGear^.CollisionIndex:= Gear^.CollisionIndex;

    Gear^.CollisionIndex:= -1;

    dec(Count)

    end;

end;

begin

    CheckCoordInWater:= (Y > cWaterLine)

        or ((WorldEdge = weSea) and ((X < leftX) or (X > rightX)));

end;

function CheckGearsCollision(Gear: PGear): PGearArray;

var mx, my, tr: LongInt;

    i: Longword;

begin

CheckGearsCollision:= @ga;

ga.Count:= 0;

if Count = 0 then

    exit;

mx:= hwRound(Gear^.X);

my:= hwRound(Gear^.Y);

tr:= Gear^.Radius + 2;

for i:= 0 to Pred(Count) do

    with cinfos[i] do

        if (Gear <> cGear) and

            (sqr(mx - x) + sqr(my - y) <= sqr(Radius + tr)) then

                begin

                ga.ar[ga.Count]:= cinfos[i].cGear;

                ga.cX[ga.Count]:= hwround(Gear^.X);

                ga.cY[ga.Count]:= hwround(Gear^.Y);

                inc(ga.Count)

                end

end;

function CheckAllGearsCollision(SourceGear: PGear): PGearArray;

var mx, my, tr: LongInt;

    Gear: PGear;

begin

    CheckAllGearsCollision:= @ga;

    ga.Count:= 0;

    mx:= hwRound(SourceGear^.X);

    my:= hwRound(SourceGear^.Y);

    tr:= SourceGear^.Radius + 2;

    Gear:= GearsList;

    while Gear <> nil do

        begin

            if (Gear <> SourceGear) and

               (sqr(mx - hwRound(Gear^.x)) + sqr(my - hwRound(Gear^.y)) <= sqr(Gear^.Radius + tr))then

            begin

                ga.ar[ga.Count]:= Gear;

                ga.cX[ga.Count]:= mx;

                ga.cY[ga.Count]:= my;

                inc(ga.Count)

            end;

            Gear := Gear^.NextGear

        end;

end;

function LineCollisionTest(oX, oY, dirX, dirY, dirNormSqr, dirNormBound: hwFloat;

        width: LongInt; Gear: PGear):

var toCenterX, toCenterY, r,

    b, bSqr, c, desc, t: hwFloat;

    realT: extended;

begin

    LineCollisionTest.hasCollision:= false;

    toCenterX:= (oX - Gear^.X);

    toCenterY:= (oY - Gear^.Y);

    r:= int2hwFloat(Gear^.Radius + width + 2);

    // Early cull to avoid multiplying large numbers

    if hwAbs(toCenterX) + hwAbs(toCenterY) > dirNormBound + r then

        exit;

    b:= dirX * toCenterX + dirY * toCenterY;

    c:= hwSqr(toCenterX) + hwSqr(toCenterY) - hwSqr(r);

    if (b > _0) and (c > _0) then

        exit;

    bSqr:= hwSqr(b);

    desc:= bSqr - dirNormSqr * c;

    if desc.isNegative then exit;

    t:= -b - hwSqrt(desc);

    if t.isNegative then t:= _0;

    if t < dirNormSqr then

        with LineCollisionTest do

            begin

            hasCollision:= true;

            realT := hwFloat2Float(t) / hwFloat2Float(dirNormSqr);

            cX:= round(hwFloat2Float(oX) + realT * hwFloat2Float(dirX));

            cY:= round(hwFloat2Float(oY) + realT * hwFloat2Float(dirY));

            end;

end;

function CheckGearsLineCollision(Gear: PGear; oX, oY, tX, tY: hwFloat): PGearArray;

var dirX, dirY, dirNormSqr, dirNormBound: hwFloat;

    test: TLineCollision;

    i: Longword;

begin

    CheckGearsLineCollision:= @ga;

    ga.Count:= 0;

    if Count = 0 then

        exit;

    dirX:= (tX - oX);

    dirY:= (tY - oY);

    dirNormBound:= _1_5 * (hwAbs(dirX) + hwAbs(dirY));

    dirNormSqr:= hwSqr(dirX) + hwSqr(dirY);

    if dirNormSqr.isNegative then

        exit;

    for i:= 0 to Pred(Count) do

        with cinfos[i] do if Gear <> cGear then

            begin

            test:= LineCollisionTest(

                oX, oY, dirX, dirY, dirNormSqr, dirNormBound, Gear^.Radius, cGear);

            if test.hasCollision then

                begin

                ga.ar[ga.Count] := cGear;

                ga.cX[ga.Count] := test.cX;

                ga.cY[ga.Count] := test.cY;

                inc(ga.Count)

                end

            end

end;

function CheckAllGearsLineCollision(SourceGear: PGear; oX, oY, tX, tY: hwFloat): PGearArray;

var dirX, dirY, dirNormSqr, dirNormBound: hwFloat;

    test: TLineCollision;

    Gear: PGear;

begin

    CheckAllGearsLineCollision:= @ga;

    ga.Count:= 0;

    dirX:= (tX - oX);

    dirY:= (tY - oY);

    dirNormBound:= _1_5 * (hwAbs(dirX) + hwAbs(dirY));

    dirNormSqr:= hwSqr(dirX) + hwSqr(dirY);

    if dirNormSqr.isNegative then

        exit;

    Gear:= GearsList;

    while Gear <> nil do

    begin

        if SourceGear <> Gear then

            begin

            test:= LineCollisionTest(

                oX, oY, dirX, dirY, dirNormSqr, dirNormBound, SourceGear^.Radius, Gear);

            if test.hasCollision then

                begin

                ga.ar[ga.Count] := Gear;

                ga.cX[ga.Count] := test.cX;

                ga.cY[ga.Count] := test.cY;

                inc(ga.Count)

                end

            end;

        Gear := Gear^.NextGear

    end;

end;

function CheckCacheCollision(SourceGear: PGear): PGearArray;

var mx, my, tr, i: LongInt;

    Gear: PGear;

begin

    CheckCacheCollision:= @ga;

    ga.Count:= 0;

    mx:= hwRound(SourceGear^.X);

    my:= hwRound(SourceGear^.Y);

    tr:= SourceGear^.Radius + 2;

    for i:= 0 to proximitya.Count - 1 do

    begin

        Gear:= proximitya.ar[i];

        // Assuming the cache has been filled correctly, it will not contain SourceGear

        // and other gears won't be far enough for sqr overflow

        if (sqr(mx - hwRound(Gear^.X)) + sqr(my - hwRound(Gear^.Y)) <= sqr(Gear^.Radius + tr)) then

        begin

            ga.ar[ga.Count]:= Gear;

            ga.cX[ga.Count]:= mx;

            ga.cY[ga.Count]:= my;

            inc(ga.Count)

        end;

    end;

end;

function UpdateHitOrderImpl(HitOrder: PGearHitOrder; Gear: PGear; Order: LongInt): boolean;

var i: LongInt;

begin

    UpdateHitOrderImpl:= true;

    for i := 0 to HitOrder^.Count - 1 do

        if HitOrder^.ar[i] = Gear then

        begin

            if Order <= HitOrder^.order[i] then

                UpdateHitOrderImpl := false;

            HitOrder^.order[i] := Max(HitOrder^.order[i], Order);

            exit;

        end;

    if HitOrder^.Count > cMaxGearHitOrderInd then

        UpdateHitOrderImpl := false

    else

    begin

        HitOrder^.ar[HitOrder^.Count] := Gear;

        HitOrder^.order[HitOrder^.Count] := Order;

        Inc(HitOrder^.Count);

    end

end;

begin

    UpdateHitOrder := UpdateHitOrderImpl(@ordera, Gear, Order);

end;

begin

    if Global then

        UpdateHitOrder := UpdateHitOrderImpl(@globalordera, Gear, Order)

    else

        UpdateHitOrder := UpdateHitOrderImpl(@ordera, Gear, Order)

end;

begin

    UpdateGlobalHitOrder := UpdateHitOrderImpl(@globalordera, Gear, Order);

end;

procedure ClearHitOrderLeqImpl(HitOrder: PGearHitOrder; MinOrder: LongInt);

var i, freeIndex: LongInt;

begin;

    freeIndex:= 0;

    i:= 0;

    while i < HitOrder^.Count do

    begin

        if HitOrder^.order[i] <= MinOrder then

            Dec(HitOrder^.Count)

        else

        begin

            if freeIndex < i then

            begin

                HitOrder^.ar[freeIndex]:= HitOrder^.ar[i];

                HitOrder^.order[freeIndex]:= HitOrder^.order[i];

            end;

            Inc(freeIndex);

        end;

        Inc(i)

    end

end;

begin

    ClearHitOrderLeqImpl(@ordera, MinOrder);

end;

begin

    ClearHitOrderLeqImpl(@globalordera, MinOrder);

end;

procedure ClearHitOrder();

begin

    ordera.Count:= 0;

end;

procedure RefillProximityCache(SourceGear: PGear; radius: LongInt);

var cx, cy, dx, dy, r: LongInt;

    Gear: PGear;

begin

    proximitya.Count:= 0;

    cx:= hwRound(SourceGear^.X);

    cy:= hwRound(SourceGear^.Y);

    Gear:= GearsList;

    while (Gear <> nil) and (proximitya.Count <= cMaxGearProximityCacheInd) do

    begin

        dx:= abs(hwRound(Gear^.X) - cx);

        dy:= abs(hwRound(Gear^.Y) - cy);

        r:= radius + Gear^.radius + 2;

        if (Gear <> SourceGear) and (max(dx, dy) <= r) and (sqr(dx) + sqr(dy) <= sqr(r)) then

        begin

            proximitya.ar[proximitya.Count]:= Gear;

            inc(proximitya.Count)

        end;

        Gear := Gear^.NextGear

    end;

end;

procedure RemoveFromProximityCache(Gear: PGear);

var i: LongInt;

begin

    i := 0;

    while i < proximitya.Count do

        begin

        if proximitya.ar[i] = Gear then

            begin

                proximitya.ar[i]:= proximitya.ar[proximitya.Count - 1];

                dec(proximitya.Count);

            end

        else

            inc(i);

        end;

end;

procedure ClearProximityCache();

begin

    proximitya.Count:= 0;

end;

function TestCollisionXImpl(centerX, centerY, radius, direction: LongInt; collisionMask: Word): Word;

var x, y, minY, maxY: LongInt;

begin

    if direction < 0 then

        x := centerX - radius

    else

        x := centerX + radius;

    if (x and LAND_WIDTH_MASK) = 0 then

    begin

        minY := max(centerY - radius + 1, 0);

        maxY := min(centerY + radius - 1, LAND_HEIGHT - 1);

        for y := minY to maxY do

    end;