(*

 * 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 uLandObjects;

interface

uses SDLh;

procedure AddObjects();

procedure FreeLandObjects();

procedure LoadThemeConfig;

procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface); inline;

procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface; LandFlags: Word); inline;

procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface; LandFlags: Word; Flip: boolean);

procedure BlitImageUsingMask(cpX, cpY: Longword;  Image, Mask: PSDL_Surface);

procedure AddOnLandObjects(Surface: PSDL_Surface);

procedure SetLand(var LandWord: Word; Pixel: LongWord); inline;

implementation

uses uStore, uConsts, uConsole, uRandom, uSound

     , uTypes, uVariables, uUtils, uDebug, SysUtils

     , uPhysFSLayer;

const MaxRects = 512;

      MAXOBJECTRECTS = 16;

      MAXTHEMEOBJECTS = 32;

      cThemeCFGFilename = 'theme.cfg';

type TRectsArray = array[0..MaxRects] of TSDL_Rect;

     PRectArray = ^TRectsArray;

     TThemeObject = record

                     Surf, Mask: PSDL_Surface;

                     inland: TSDL_Rect;

                     outland: array[0..Pred(MAXOBJECTRECTS)] of TSDL_Rect;

                     rectcnt: Longword;

                     Width, Height: Longword;

                     Maxcnt: Longword;

                     end;

     TThemeObjects = record

                     Count: LongInt;

                     objs: array[0..Pred(MAXTHEMEOBJECTS)] of TThemeObject;

                     end;

     TSprayObject = record

                     Surf: PSDL_Surface;

                     Width, Height: Longword;

                     Maxcnt: Longword;

                     end;

     TSprayObjects = record

                     Count: LongInt;

                     objs: array[0..Pred(MAXTHEMEOBJECTS)] of TSprayObject

                     end;

var Rects: PRectArray;

    RectCount: Longword;

    ThemeObjects: TThemeObjects;

    SprayObjects: TSprayObjects;

procedure SetLand(var LandWord: Word; Pixel: LongWord); inline;

begin

    // this an if instead of masking colours to avoid confusing map creators

    if ((AMask and Pixel) = 0) then

        LandWord:= 0

    else if Pixel = $FFFFFFFF then                  // white

        LandWord:= lfObject

    else if Pixel = AMask then                      // black

        begin

        LandWord:= lfBasic;

        disableLandBack:= false

        end

    else if Pixel = (AMask or RMask) then           // red

        LandWord:= lfIndestructible

    else if Pixel = (AMask or BMask) then           // blue

        LandWord:= lfObject or lfIce

    else if Pixel = (AMask or GMask) then           // green

        LandWord:= lfObject or lfBouncy

end;

procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface); inline;

begin

    BlitImageAndGenerateCollisionInfo(cpX, cpY, Width, Image, 0, false);

end;

procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface; LandFlags: Word); inline;

begin

    BlitImageAndGenerateCollisionInfo(cpX, cpY, Width, Image, LandFlags, false);

end;

procedure BlitImageAndGenerateCollisionInfo(cpX, cpY, Width: Longword; Image: PSDL_Surface; LandFlags: Word; Flip: boolean);

var p: PLongwordArray;

    px, x, y: Longword;

    bpp: LongInt;

begin

WriteToConsole('Generating collision info... ');

if SDL_MustLock(Image) then

    SDLTry(SDL_LockSurface(Image) >= 0, true);

bpp:= Image^.format^.BytesPerPixel;

TryDo(bpp = 4, 'Land object should be 32bit', true);

if Width = 0 then

    Width:= Image^.w;

p:= Image^.pixels;

for y:= 0 to Pred(Image^.h) do

    begin

    for x:= 0 to Pred(Width) do

        begin

        // map image pixels per line backwards if in flip mode

        if Flip then

            px:= Pred(Image^.w) - x

        else

            px:= x;

        if (p^[px] and AMask) <> 0 then

            begin

            if (cReducedQuality and rqBlurryLand) = 0 then

                begin

                if (LandPixels[cpY + y, cpX + x] = 0)

                or (((p^[px] and AMask) <> 0) and (((LandPixels[cpY + y, cpX + x] and AMask) shr AShift) < 255)) then

                    LandPixels[cpY + y, cpX + x]:= p^[px];

                end

            else

                if LandPixels[(cpY + y) div 2, (cpX + x) div 2] = 0 then

                    LandPixels[(cpY + y) div 2, (cpX + x) div 2]:= p^[px];

            if (Land[cpY + y, cpX + x] <= lfAllObjMask) and ((p^[px] and AMask) <> 0) then

                Land[cpY + y, cpX + x]:= lfObject or LandFlags

            end;

        end;

    p:= PLongwordArray(@(p^[Image^.pitch shr 2]))

    end;

if SDL_MustLock(Image) then

    SDL_UnlockSurface(Image);

WriteLnToConsole(msgOK)

end;

procedure BlitImageUsingMask(cpX, cpY: Longword;  Image, Mask: PSDL_Surface);

var p, mp: PLongwordArray;

    x, y: Longword;

    bpp: LongInt;

begin

WriteToConsole('Generating collision info... ');

if SDL_MustLock(Image) then

    SDLTry(SDL_LockSurface(Image) >= 0, true);

bpp:= Image^.format^.BytesPerPixel;

TryDo(bpp = 4, 'Land object should be 32bit', true);

p:= Image^.pixels;

mp:= Mask^.pixels;

for y:= 0 to Pred(Image^.h) do

    begin

    for x:= 0 to Pred(Image^.w) do

        begin

        if (cReducedQuality and rqBlurryLand) = 0 then

            begin

            if (LandPixels[cpY + y, cpX + x] = 0)

            or (((p^[x] and AMask) <> 0) and (((LandPixels[cpY + y, cpX + x] and AMask) shr AShift) < 255)) then

                LandPixels[cpY + y, cpX + x]:= p^[x];

            end

        else

            if LandPixels[(cpY + y) div 2, (cpX + x) div 2] = 0 then

                LandPixels[(cpY + y) div 2, (cpX + x) div 2]:= p^[x];

        if (Land[cpY + y, cpX + x] <= lfAllObjMask) or (Land[cpY + y, cpX + x] and lfObject <> 0)  then

            SetLand(Land[cpY + y, cpX + x], mp^[x]);

        end;

    p:= PLongwordArray(@(p^[Image^.pitch shr 2]));

    mp:= PLongwordArray(@(mp^[Mask^.pitch shr 2]))

    end;

if SDL_MustLock(Image) then

    SDL_UnlockSurface(Image);

WriteLnToConsole(msgOK)

end;

procedure AddRect(x1, y1, w1, h1: LongInt);

begin

with Rects^[RectCount] do

    begin

    x:= x1;

    y:= y1;

    w:= w1;

    h:= h1

    end;

inc(RectCount);

TryDo(RectCount < MaxRects, 'AddRect: overflow', true)

end;

procedure InitRects;

begin

RectCount:= 0;

New(Rects)

end;

procedure FreeRects;

begin

    Dispose(rects)

end;

function CheckIntersect(x1, y1, w1, h1: LongInt): boolean;

var i: Longword;

    res: boolean = false;

begin

i:= 0;

if RectCount > 0 then

    repeat

    with Rects^[i] do

        res:= (x < x1 + w1) and (x1 < x + w) and (y < y1 + h1) and (y1 < y + h);

    inc(i)

    until (i = RectCount) or (res);

CheckIntersect:= res;

end;

function CountNonZeroz(x, y, h: LongInt): Longword;

var i: LongInt;

    lRes: Longword;

begin

    lRes:= 0;

    for i:= y to Pred(y + h) do

        if Land[i, x] <> 0 then

            inc(lRes);

    CountNonZeroz:= lRes;

end;

function AddGirder(gX: LongInt; var girSurf: PSDL_Surface): boolean;

var x1, x2, y, k, i, girderHeight: LongInt;

    rr: TSDL_Rect;

    bRes: boolean;

begin

if girSurf = nil then

    girSurf:= LoadDataImageAltPath(ptCurrTheme, ptGraphics, 'Girder', ifCritical or ifTransparent or ifIgnoreCaps);

girderHeight:= girSurf^.h;

y:= topY+150;

repeat

    inc(y, 24);

    x1:= gX;

    x2:= gX;

    while (x1 > Longint(leftX)+150) and (CountNonZeroz(x1, y, girderHeight) = 0) do

        dec(x1, 2);

    i:= x1 - 12;

    repeat

        k:= CountNonZeroz(x1, y, girderHeight);

        dec(x1, 2)

    until (x1 < Longint(leftX) + 100) or (k = 0) or (k = girderHeight) or (x1 < i);

    inc(x1, 2);

    if k = girderHeight then

        begin

        while (x2 < (LongInt(rightX) - 100)) and (CountNonZeroz(x2, y, girderHeight) = 0) do

            inc(x2, 2);

        i:= x2 + 12;

        repeat

        inc(x2, 2);

        k:= CountNonZeroz(x2, y, girderHeight)

        until (x2 >= (LongInt(rightX)-150)) or (k = 0) or (k = girderHeight) or (x2 > i) or (x2 - x1 >= 900);

        if (x2 < (LongInt(rightX) - 100)) and (k = girderHeight) and (x2 - x1 > 200) and (x2 - x1 < 900)

        and (not CheckIntersect(x1 - 32, y - 64, x2 - x1 + 64, 144)) then

                break;

        end;

x1:= 0;

until y > (LAND_HEIGHT-125);

if x1 > 0 then

begin

    bRes:= true;

    rr.x:= x1;

    while rr.x < x2 do

        begin

        if cIce then

            BlitImageAndGenerateCollisionInfo(rr.x, y, min(x2 - rr.x, girSurf^.w), girSurf, lfIce)

        else

            BlitImageAndGenerateCollisionInfo(rr.x, y, min(x2 - rr.x, girSurf^.w), girSurf);

        inc(rr.x, girSurf^.w);

        end;

    AddRect(x1 - 8, y - 32, x2 - x1 + 16, 80);

end

else bRes:= false;

AddGirder:= bRes;

end;

function CheckLand(rect: TSDL_Rect; dX, dY, Color: Longword): boolean;

var tmpx, tmpx2, tmpy, tmpy2, bx, by: LongInt;

    bRes: boolean = true;

begin

inc(rect.x, dX);

inc(rect.y, dY);

bx:= rect.x + rect.w;

by:= rect.y + rect.h;

{$WARNINGS OFF}

tmpx:= rect.x;

tmpx2:= bx;

while (tmpx <= bx - rect.w div 2 - 1) and bRes do

    begin

    bRes:= ((rect.y and LAND_HEIGHT_MASK) = 0) and ((by and LAND_HEIGHT_MASK) = 0)

    and ((tmpx and LAND_WIDTH_MASK) = 0) and ((tmpx2 and LAND_WIDTH_MASK) = 0)

    and (Land[rect.y, tmpx] = Color) and (Land[by, tmpx] = Color)

    and (Land[rect.y, tmpx2] = Color) and (Land[by, tmpx2] = Color);

    inc(tmpx);

    dec(tmpx2)

    end;

tmpy:= rect.y+1;

tmpy2:= by-1;

while (tmpy <= by - rect.h div 2 - 1) and bRes do

    begin

    bRes:= ((tmpy and LAND_HEIGHT_MASK) = 0) and ((tmpy2 and LAND_HEIGHT_MASK) = 0)

    and ((rect.x and LAND_WIDTH_MASK) = 0) and ((bx and LAND_WIDTH_MASK) = 0)

    and (Land[tmpy, rect.x] = Color) and (Land[tmpy, bx] = Color)

    and (Land[tmpy2, rect.x] = Color) and (Land[tmpy2, bx] = Color);

    inc(tmpy);

    dec(tmpy2)

    end;

{$WARNINGS ON}

CheckLand:= bRes;

end;

function CheckCanPlace(x, y: Longword; var Obj: TThemeObject): boolean;

var i: Longword;

    bRes: boolean;

begin

with Obj do

    if CheckLand(inland, x, y, lfBasic) then

        begin

        bRes:= true;

        i:= 1;

        while bRes and (i <= rectcnt) do

            begin

            bRes:= CheckLand(outland[i], x, y, 0);

            inc(i)

            end;

        if bRes then

            bRes:= not CheckIntersect(x, y, Width, Height)

        end

    else

        bRes:= false;

CheckCanPlace:= bRes;

end;

function TryPut(var Obj: TThemeObject): boolean; overload;

const MaxPointsIndex = 2047;

var x, y: Longword;

    ar: array[0..MaxPointsIndex] of TPoint;

    cnt, i: Longword;

    bRes: boolean;

begin

TryPut:= false;

cnt:= 0;

with Obj do

    begin

    if Maxcnt = 0 then

        exit;

    x:= 0;

    repeat

        y:= topY+32; // leave room for a hedgie to teleport in

        repeat

            if CheckCanPlace(x, y, Obj) then

                begin

                ar[cnt].x:= x;

                ar[cnt].y:= y;

                inc(cnt);

                if cnt > MaxPointsIndex then // buffer is full, do not check the rest land

                    begin

                    y:= LAND_HEIGHT;

                    x:= LAND_WIDTH;

                    end

                end;

            inc(y, 3);

        until y >= LAND_HEIGHT - Height;

        inc(x, getrandom(6) + 3)

    until x >= LAND_WIDTH - Width;

    bRes:= cnt <> 0;

    if bRes then

        begin

        i:= getrandom(cnt);

        if Obj.Mask <> nil then

             BlitImageUsingMask(ar[i].x, ar[i].y, Obj.Surf, Obj.Mask)

        else BlitImageAndGenerateCollisionInfo(ar[i].x, ar[i].y, 0, Obj.Surf);

        AddRect(ar[i].x, ar[i].y, Width, Height);

        dec(Maxcnt)

        end

    else Maxcnt:= 0

    end;

TryPut:= bRes;

end;

function TryPut(var Obj: TSprayObject; Surface: PSDL_Surface): boolean; overload;

const MaxPointsIndex = 8095;

var x, y: Longword;

    ar: array[0..MaxPointsIndex] of TPoint;

    cnt, i: Longword;

    r: TSDL_Rect;

    bRes: boolean;

begin

TryPut:= false;

cnt:= 0;

with Obj do

    begin

    if Maxcnt = 0 then

        exit;

    x:= 0;

    r.x:= 0;

    r.y:= 0;

    r.w:= Width;

    r.h:= Height + 16;

    repeat

        y:= 8;

        repeat

            if CheckLand(r, x, y - 8, lfBasic)

            and (not CheckIntersect(x, y, Width, Height)) then

                begin

                ar[cnt].x:= x;

                ar[cnt].y:= y;

                inc(cnt);

                if cnt > MaxPointsIndex then // buffer is full, do not check the rest land

                    begin

                    y:= 5000;

                    x:= 5000;

                    end

                end;

            inc(y, 12);

        until y >= LAND_HEIGHT - Height - 8;

        inc(x, getrandom(12) + 12)

    until x >= LAND_WIDTH - Width;

    bRes:= cnt <> 0;

    if bRes then

        begin

        i:= getrandom(cnt);

        r.x:= ar[i].X;

        r.y:= ar[i].Y;

        r.w:= Width;

        r.h:= Height;

        SDL_UpperBlit(Obj.Surf, nil, Surface, @r);

        AddRect(ar[i].x - 32, ar[i].y - 32, Width + 64, Height + 64);

        dec(Maxcnt)

        end

    else Maxcnt:= 0

    end;

TryPut:= bRes;

end;

procedure CheckRect(Width, Height, x, y, w, h: LongWord);

begin

    if (x + w > Width) then

        OutError('Object''s rectangle exceeds image: x + w (' + inttostr(x) + ' + ' + inttostr(w) + ') > Width (' + inttostr(Width) + ')', true);

    if (y + h > Height) then

        OutError('Object''s rectangle exceeds image: y + h (' + inttostr(y) + ' + ' + inttostr(h) + ') > Height (' + inttostr(Height) + ')', true);

end;

procedure ReadThemeInfo(var ThemeObjects: TThemeObjects; var SprayObjects: TSprayObjects);

var s, key: shortstring;

    f: PFSFile;