(*

 * Hedgewars, a free turn based strategy game

 * Copyright (c) 2004-2013 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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);

procedure FillRoundInLand(X, Y, Radius: LongInt; Value: 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);

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

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

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

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

implementation

uses SDLh, uLandTexture, uVariables, uUtils, uDebug;

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]:= 0

    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

    // 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 FillLandCircleLine(y, fromPix, toPix: LongInt; fill : fillType): Longword;

var px, py, i: LongInt;

begin

//get rid of compiler warning

    px := 0;

    py := 0;

    FillLandCircleLine := 0;

    case fill of

    backgroundPixel:

    for i:= fromPix to toPix do

        begin

        calculatePixelsCoordinates(i, y, px, py);

        inc(FillLandCircleLine, 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]:= 0

        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] and lfNotObjMask) or ((Land[y, i] and lfObjMask) - 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] and lfNotObjMask) or ((Land[y, i] and lfObjMask) + 1)

        end;

    end;

end;

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

begin

    FillLandCircleSegment := 0;

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

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

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

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

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

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

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

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

end;

begin

dx:= 0;

dy:= Radius;

d:= 3 - 2 * Radius;

while (dx < dy) do

    begin

    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

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;

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

var i: LongInt;

begin

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

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

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

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

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

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

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

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

end;

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

var dx, dy, d: LongInt;

begin

dx:= 0;

dy:= Radius;

d:= 3 - 2 * Radius;

while (dx < dy) do

    begin

    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

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

end;

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

begin

if not doSet and isCurrent then

else if not doSet and (not IsCurrent) then

else if doSet and IsCurrent then

else if doSet and (not IsCurrent) then

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;

            fillPixelFromIceSprite(i, j);

            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

    if Radius > 20 then

    FillRoundInLand(X, Y, Radius, 0);

    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]:= 0

                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

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

        if despeckle then

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

        if (cReducedQuality and rqBlurryLand) = 0 then

            LandPixels[ty, tx]:= ExplosionBorderColor

        else

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

        end

    end;

end;

//

//  - (dX, dY) - direction, vector of length = 0.5

//

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

var nx, ny, dX8, dY8: hwFloat;

    i, t, tx, ty, by, bx, stX, stY, ddy, ddx: Longint;

    despeckle : Boolean;

begin  // (-dY, dX) is (dX, dY) rotated by PI/2

stY:= hwRound(Y);

stX:= hwRound(X);