(*

 * Hedgewars, a free turn based strategy game

 * Copyright (c) 2004-2014 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 uLandGraphics;

interface

uses uFloat, uConsts, uTypes;

type

    fillType = (nullPixel, backgroundPixel, ebcPixel, icePixel, setNotCurrentMask, changePixelSetNotCurrent, setCurrentHog, changePixelNotSetNotCurrent);

type TRangeArray = array[0..31] of record

                                   Left, Right: LongInt;

                                   end;

     PRangeArray = ^TRangeArray;

TLandCircleProcedure = procedure (landX, landY, pixelX, pixelY: Longint);

function  addBgColor(OldColor, NewColor: LongWord): LongWord;

function  SweepDirty: boolean;

function  Despeckle(X, Y: LongInt): Boolean;

procedure Smooth(X, Y: LongInt);

function  CheckLandValue(X, Y: LongInt; LandFlag: Word): boolean;

function  DrawExplosion(X, Y, Radius: LongInt): Longword;

procedure DrawHLinesExplosions(ar: PRangeArray; Radius: LongInt; y, dY: LongInt; Count: Byte);

procedure DrawTunnel(X, Y, dX, dY: hwFloat; ticks, HalfWidth: LongInt);

function FillRoundInLand(X, Y, Radius: LongInt; Value: Longword): Longword;

function FillRoundInLandFT(X, Y, Radius: LongInt; fill: fillType): Longword;

procedure ChangeRoundInLand(X, Y, Radius: LongInt; doSet, isCurrent: boolean);

function  LandBackPixel(x, y: LongInt): LongWord;

procedure DrawLine(X1, Y1, X2, Y2: LongInt; Color: Longword);

function  DrawThickLine(X1, Y1, X2, Y2, radius: LongInt; color: Longword): Longword;

procedure DumpLandToLog(x, y, r: LongInt);

procedure DrawIceBreak(x, y, iceRadius, iceHeight: Longint);

function TryPlaceOnLandSimple(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, indestructible: boolean): boolean; inline;

function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace: boolean; LandFlags: Word): boolean; inline;

function ForcePlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; LandFlags: Word): boolean; inline;

function TryPlaceOnLand(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt; doPlace, outOfMap, force: boolean; LandFlags: Word): boolean;

function GetPlaceCollisionTex(cpX, cpY: LongInt; Obj: TSprite; Frame: LongInt): PTexture;

implementation

procedure calculatePixelsCoordinates(landX, landY: Longint; var pixelX, pixelY: Longint); inline;

begin

if (cReducedQuality and rqBlurryLand) = 0 then

    begin

    pixelX := landX;

    pixelY := landY;

    end

else

    begin

    pixelX := LandX div 2;

    pixelY := LandY div 2;

    end;

end;

function drawPixelBG(landX, landY, pixelX, pixelY: Longint): Longword; inline;

begin

drawPixelBG := 0;

if (Land[LandY, landX] and lfIndestructible) = 0 then

    begin

        if ((Land[landY, landX] and lfBasic) <> 0) and (((LandPixels[pixelY, pixelX] and AMask) shr AShift) = 255) and (not disableLandBack) then

        begin

            LandPixels[pixelY, pixelX]:= LandBackPixel(landX, landY);

            inc(drawPixelBG);

        end

        else if ((Land[landY, landX] and lfObject) <> 0) or (((LandPixels[pixelY, pixelX] and AMask) shr AShift) < 255) then

            LandPixels[pixelY, pixelX]:= LandPixels[pixelY, pixelX] and (not AMASK)

    end;

end;

procedure drawPixelEBC(landX, landY, pixelX, pixelY: Longint); inline;

begin

if ((Land[landY, landX] and lfBasic) <> 0) or ((Land[landY, landX] and lfObject) <> 0) then

    begin

    LandPixels[pixelY, pixelX]:= ExplosionBorderColor;

    Land[landY, landX]:= (Land[landY, landX] or lfDamaged) and (not lfIce);

    LandDirty[landY div 32, landX div 32]:= 1;

    end;

end;

function isLandscapeEdge(weight:Longint):boolean; inline;

begin

isLandscapeEdge := (weight < 8) and (weight >= 2);

end;

function getPixelWeight(x, y:Longint): Longint;

var

    i, j, r: Longint;

begin

r := 0;

for i := x - 1 to x + 1 do

    for j := y - 1 to y + 1 do

    begin

    if (i < 0) or

       (i > LAND_WIDTH - 1) or

       (j < 0) or

       (j > LAND_HEIGHT -1) then

       exit(9);

    if Land[j, i] and lfLandMask and (not lfIce) = 0 then

       inc(r)

    end;

    getPixelWeight:= r

end;

procedure fillPixelFromIceSprite(pixelX, pixelY:Longint); inline;

var

    iceSurface: PSDL_Surface;

    icePixels: PLongwordArray;

    w: LongWord;

begin

    if cOnlyStats then exit;

    // So. 3 parameters here. Ice colour, Ice opacity, and a bias on the greyscaled pixel towards lightness

    iceSurface:= SpritesData[sprIceTexture].Surface;

    icePixels := iceSurface^.pixels;

    w:= LandPixels[pixelY, pixelX];

    if w > 0 then

        begin

        w:= round(((w shr RShift and $FF) * RGB_LUMINANCE_RED +

              (w shr BShift and $FF) * RGB_LUMINANCE_GREEN +

              (w shr GShift and $FF) * RGB_LUMINANCE_BLUE));

        if w < 128 then w:= w+128;

        if w > 255 then w:= 255;

        w:= (w shl RShift) or (w shl BShift) or (w shl GShift) or (LandPixels[pixelY, pixelX] and AMask);

        LandPixels[pixelY, pixelX]:= addBgColor(w, IceColor);

        LandPixels[pixelY, pixelX]:= addBgColor(LandPixels[pixelY, pixelX], icePixels^[iceSurface^.w * (pixelY mod iceSurface^.h) + (pixelX mod iceSurface^.w)])

        end

    else

        begin

        LandPixels[pixelY, pixelX]:= IceColor and (not AMask) or $E8 shl AShift;

        LandPixels[pixelY, pixelX]:= addBgColor(LandPixels[pixelY, pixelX], icePixels^[iceSurface^.w * (pixelY mod iceSurface^.h) + (pixelX mod iceSurface^.w)]);

        // silly workaround to avoid having to make background erasure a tadb it smarter about sea ice

        if LandPixels[pixelY, pixelX] and AMask shr AShift = 255 then

            LandPixels[pixelY, pixelX]:= LandPixels[pixelY, pixelX] and (not AMask) or 254 shl AShift;

        end;

end;

procedure DrawPixelIce(landX, landY, pixelX, pixelY: Longint); inline;

begin

if ((Land[landY, landX] and lfIce) <> 0) then exit;

if isLandscapeEdge(getPixelWeight(landX, landY)) then

    begin

    if (LandPixels[pixelY, pixelX] and AMask < 255) and (LandPixels[pixelY, pixelX] and AMask > 0) then

        LandPixels[pixelY, pixelX] := (IceEdgeColor and (not AMask)) or (LandPixels[pixelY, pixelX] and AMask)

    else if (LandPixels[pixelY, pixelX] and AMask < 255) or (Land[landY, landX] > 255) then

        LandPixels[pixelY, pixelX] := IceEdgeColor

    end

else if Land[landY, landX] > 255 then

    begin

        fillPixelFromIceSprite(pixelX, pixelY);

    end;

if Land[landY, landX] > 255 then Land[landY, landX] := Land[landY, landX] or lfIce and (not lfDamaged);

end;

function FillLandCircleLineFT(y, fromPix, toPix: LongInt; fill : fillType): Longword;

var px, py, i: LongInt;

begin

//get rid of compiler warning

    px := 0;

    py := 0;

    FillLandCircleLineFT := 0;

    case fill of

    backgroundPixel:

        for i:= fromPix to toPix do

            begin

            calculatePixelsCoordinates(i, y, px, py);

            inc(FillLandCircleLineFT, drawPixelBG(i, y, px, py));

            end;

    ebcPixel:

        for i:= fromPix to toPix do

            begin

            calculatePixelsCoordinates(i, y, px, py);

            drawPixelEBC(i, y, px, py);

            end;

    nullPixel:

        for i:= fromPix to toPix do

            begin

            calculatePixelsCoordinates(i, y, px, py);

            if ((Land[y, i] and lfIndestructible) = 0) and (not disableLandBack or (Land[y, i] > 255))  then

                LandPixels[py, px]:= LandPixels[py, px] and (not AMASK);

            end;

    icePixel:

        for i:= fromPix to toPix do

            begin

            calculatePixelsCoordinates(i, y, px, py);

            DrawPixelIce(i, y, px, py);

            end;

    setNotCurrentMask:

        for i:= fromPix to toPix do

            begin

            Land[y, i]:= Land[y, i] and lfNotCurrentMask;

            end;

    changePixelSetNotCurrent:

        for i:= fromPix to toPix do

            begin

            if Land[y, i] and lfObjMask > 0 then

                Land[y, i]:= Land[y, i] - 1;

            end;

    setCurrentHog:

        for i:= fromPix to toPix do

            begin

            Land[y, i]:= Land[y, i] or lfCurrentHog

            end;

    changePixelNotSetNotCurrent:

        for i:= fromPix to toPix do

            begin

            if Land[y, i] and lfObjMask < lfObjMask then

                Land[y, i]:= Land[y, i] + 1

            end;

    end;

end;

function FillLandCircleSegmentFT(x, y, dx, dy: LongInt; fill : fillType): Longword; inline;

begin

    FillLandCircleSegmentFT := 0;

if ((y + dy) and LAND_HEIGHT_MASK) = 0 then

    inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y + dy, Max(x - dx, 0), Min(x + dx, LAND_WIDTH - 1), fill));

if ((y - dy) and LAND_HEIGHT_MASK) = 0 then

    inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y - dy, Max(x - dx, 0), Min(x + dx, LAND_WIDTH - 1), fill));

if ((y + dx) and LAND_HEIGHT_MASK) = 0 then

    inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y + dx, Max(x - dy, 0), Min(x + dy, LAND_WIDTH - 1), fill));

if ((y - dx) and LAND_HEIGHT_MASK) = 0 then

    inc(FillLandCircleSegmentFT, FillLandCircleLineFT(y - dx, Max(x - dy, 0), Min(x + dy, LAND_WIDTH - 1), fill));

end;

function FillRoundInLandFT(X, Y, Radius: LongInt; fill: fillType): Longword; inline;

var dx, dy, d: LongInt;

begin

dx:= 0;

dy:= Radius;

d:= 3 - 2 * Radius;

FillRoundInLandFT := 0;

while (dx < dy) do

    begin

    inc(FillRoundInLandFT, FillLandCircleSegmentFT(x, y, dx, dy, fill));

    if (d < 0) then

        d:= d + 4 * dx + 6

    else

        begin

        d:= d + 4 * (dx - dy) + 10;

        dec(dy)

        end;

    inc(dx)

    end;

if (dx = dy) then

    inc (FillRoundInLandFT, FillLandCircleSegmentFT(x, y, dx, dy, fill));

end;

function addBgColor(OldColor, NewColor: LongWord): LongWord;

// Factor ranges from 0 to 100% NewColor

var

    oRed, oBlue, oGreen, oAlpha, nRed, nBlue, nGreen, nAlpha: byte;

begin

    oAlpha := (OldColor shr AShift);

    nAlpha := (NewColor shr AShift);

    // shortcircuit

    if (oAlpha = 0) or (nAlpha = $FF) then

        begin

        addBgColor:= NewColor;

        exit

        end;

    // Get colors

    oRed   := (OldColor shr RShift);

    oGreen := (OldColor shr GShift);

    oBlue  := (OldColor shr BShift);

    nRed   := (NewColor shr RShift);

    nGreen := (NewColor shr GShift);

    nBlue  := (NewColor shr BShift);

    // Mix colors

    nRed   := min(255,((nRed*nAlpha) div 255) + ((oRed*oAlpha*byte(255-nAlpha)) div 65025));

    nGreen := min(255,((nGreen*nAlpha) div 255) + ((oGreen*oAlpha*byte(255-nAlpha)) div 65025));

    nBlue  := min(255,((nBlue*nAlpha) div 255) + ((oBlue*oAlpha*byte(255-nAlpha)) div 65025));

    nAlpha := min(255, oAlpha + nAlpha);

    addBgColor := (nAlpha shl AShift) or (nRed shl RShift) or (nGreen shl GShift) or (nBlue shl BShift);

end;

function FillCircleLines(x, y, dx, dy: LongInt; Value: Longword): Longword;

var i: LongInt;

begin

    FillCircleLines:= 0;

    if ((y + dy) and LAND_HEIGHT_MASK) = 0 then

        for i:= Max(x - dx, 0) to Min(x + dx, LAND_WIDTH - 1) do

            if (Land[y + dy, i] and lfIndestructible) = 0 then

            begin

                if Land[y + dy, i] <> Value then inc(FillCircleLines);

                Land[y + dy, i]:= Value;

            end;

    if ((y - dy) and LAND_HEIGHT_MASK) = 0 then

        for i:= Max(x - dx, 0) to Min(x + dx, LAND_WIDTH - 1) do

            if (Land[y - dy, i] and lfIndestructible) = 0 then

            begin

                if Land[y - dy, i] <> Value then inc(FillCircleLines);

                Land[y - dy, i]:= Value;

            end;

    if ((y + dx) and LAND_HEIGHT_MASK) = 0 then

        for i:= Max(x - dy, 0) to Min(x + dy, LAND_WIDTH - 1) do

            if (Land[y + dx, i] and lfIndestructible) = 0 then

            begin

                if Land[y + dx, i] <> Value then inc(FillCircleLines);

                Land[y + dx, i]:= Value;

            end;

    if ((y - dx) and LAND_HEIGHT_MASK) = 0 then

        for i:= Max(x - dy, 0) to Min(x + dy, LAND_WIDTH - 1) do

            if (Land[y - dx, i] and lfIndestructible) = 0 then

            begin

                if Land[y - dx, i] <> Value then inc(FillCircleLines);

                Land[y - dx, i]:= Value;

            end;

end;

function FillRoundInLand(X, Y, Radius: LongInt; Value: Longword): Longword;

var dx, dy, d: LongInt;

begin

FillRoundInLand:= 0;

dx:= 0;

dy:= Radius;

d:= 3 - 2 * Radius;

while (dx < dy) do

    begin

    inc(FillRoundInLand, FillCircleLines(x, y, dx, dy, Value));

    if (d < 0) then

        d:= d + 4 * dx + 6

    else

        begin

        d:= d + 4 * (dx - dy) + 10;

        dec(dy)

        end;

    inc(dx)

    end;

if (dx = dy) then

    inc(FillRoundInLand, FillCircleLines(x, y, dx, dy, Value));

end;

procedure ChangeRoundInLand(X, Y, Radius: LongInt; doSet, isCurrent: boolean);

begin

if not doSet and isCurrent then

    FillRoundInLandFT(X, Y, Radius, setNotCurrentMask)

else if not doSet and (not IsCurrent) then

    FillRoundInLandFT(X, Y, Radius, changePixelSetNotCurrent)

else if doSet and IsCurrent then

    FillRoundInLandFT(X, Y, Radius, setCurrentHog)

else if doSet and (not IsCurrent) then

    FillRoundInLandFT(X, Y, Radius, changePixelNotSetNotCurrent);

end;

procedure DrawIceBreak(x, y, iceRadius, iceHeight: Longint);

var

    i, j: integer;

    landRect: TSDL_Rect;

begin

for i := min(max(x - iceRadius, 0), LAND_WIDTH - 1) to min(max(x + iceRadius, 0), LAND_WIDTH - 1) do

    begin

    for j := min(max(y, 0), LAND_HEIGHT - 1) to min(max(y + iceHeight, 0), LAND_HEIGHT - 1) do

        begin

        if Land[j, i] = 0 then

            begin

            Land[j, i] := lfIce;

            if (cReducedQuality and rqBlurryLand) = 0 then

                fillPixelFromIceSprite(i, j)

            else

                fillPixelFromIceSprite(i div 2, j div 2);

            end;

        end;

    end;

landRect.x := min(max(x - iceRadius, 0), LAND_WIDTH - 1);

landRect.y := min(max(y, 0), LAND_HEIGHT - 1);

landRect.w := min(2*iceRadius, LAND_WIDTH - landRect.x - 1);

landRect.h := min(iceHeight, LAND_HEIGHT - landRect.y - 1);

UpdateLandTexture(landRect.x, landRect.w, landRect.y, landRect.h, true);

end;

function DrawExplosion(X, Y, Radius: LongInt): Longword;

var

    tx, ty, dx, dy: Longint;

begin

    DrawExplosion := FillRoundInLandFT(x, y, Radius, backgroundPixel);

    if Radius > 20 then

        FillRoundInLandFT(x, y, Radius - 15, nullPixel);

    FillRoundInLand(X, Y, Radius, 0);

    FillRoundInLandFT(x, y, Radius + 4, ebcPixel);

    tx:= Max(X - Radius - 5, 0);

    dx:= Min(X + Radius + 5, LAND_WIDTH) - tx;

    ty:= Max(Y - Radius - 5, 0);

    dy:= Min(Y + Radius + 5, LAND_HEIGHT) - ty;

    UpdateLandTexture(tx, dx, ty, dy, false);

end;

procedure DrawHLinesExplosions(ar: PRangeArray; Radius: LongInt; y, dY: LongInt; Count: Byte);

var tx, ty, by, bx,  i: LongInt;

begin

for i:= 0 to Pred(Count) do

    begin

    for ty:= Max(y - Radius, 0) to Min(y + Radius, LAND_HEIGHT) do

        for tx:= Max(0, ar^[i].Left - Radius) to Min(LAND_WIDTH, ar^[i].Right + Radius) do

            begin

            if (Land[ty, tx] and lfIndestructible) = 0 then

                begin

                if (cReducedQuality and rqBlurryLand) = 0 then

                    begin

                    by:= ty; bx:= tx;

                    end

                else

                    begin

                    by:= ty div 2; bx:= tx div 2;

                    end;

                if ((Land[ty, tx] and lfBasic) <> 0) and (((LandPixels[by,bx] and AMask) shr AShift) = 255) and (not disableLandBack) then

                    LandPixels[by, bx]:= LandBackPixel(tx, ty)

                else if ((Land[ty, tx] and lfObject) <> 0) or (((LandPixels[by,bx] and AMask) shr AShift) < 255) then

                    LandPixels[by, bx]:= LandPixels[by, bx] and (not AMASK)

                end

            end;

    inc(y, dY)

    end;

inc(Radius, 4);

dec(y, Count * dY);

for i:= 0 to Pred(Count) do

    begin

    for ty:= Max(y - Radius, 0) to Min(y + Radius, LAND_HEIGHT) do

        for tx:= Max(0, ar^[i].Left - Radius) to Min(LAND_WIDTH, ar^[i].Right + Radius) do

            if ((Land[ty, tx] and lfBasic) <> 0) or ((Land[ty, tx] and lfObject) <> 0) then

                begin

                 if (cReducedQuality and rqBlurryLand) = 0 then

                    LandPixels[ty, tx]:= ExplosionBorderColor

                else

                    LandPixels[ty div 2, tx div 2]:= ExplosionBorderColor;

                Land[ty, tx]:= (Land[ty, tx] or lfDamaged) and (not lfIce);

                LandDirty[ty div 32, tx div 32]:= 1;

                end;

    inc(y, dY)

    end;

UpdateLandTexture(0, LAND_WIDTH, 0, LAND_HEIGHT, false)

end;

procedure DrawExplosionBorder(X, Y, dx, dy:hwFloat;  despeckle : Boolean);

var

    t, tx, ty :Longint;

begin

for t:= 0 to 7 do

    begin

    X:= X + dX;

    Y:= Y + dY;

    tx:= hwRound(X);

    ty:= hwRound(Y);

    if ((ty and LAND_HEIGHT_MASK) = 0) and ((tx and LAND_WIDTH_MASK) = 0) and (((Land[ty, tx] and lfBasic) <> 0)

    or ((Land[ty, tx] and lfObject) <> 0)) then

        begin