unit Rivers;

{***********************************************************

Project:    C-evo External Map Generator
Copyright:  1999-2023 P Blackman
License:    GPLv3+

Unit to support the generation of rivers (erosion model).

***********************************************************}


interface uses MapTiles, CevoMap, Classes;

type
    tRivers = class
    private type
        tcellptr = ^tcell;
        tcell    =
        record
            Wid: Integer;
            Hgt: Integer;
            Alt: Integer;
        end;

        tneighbors = array [1..4] of tcell;

    private
        fRiverGenCycles,
        friverlevel,
        fWideRiverCount : Integer;
        flist           : TList;
        fMap            : tMap;

        procedure AltitudeSort;
        procedure Process_Tile(ptr: tCellptr);
        function LowestNeighbor(W, H, MyHgt: Integer; out NW, NH: Integer): Boolean;
        function GetNeigbors(W, H: Integer): Tneighbors;
        function OutOfRange(N: tcell): Boolean;

    public
        procedure Loaddata(Map: tMap);
        procedure Generate;

        procedure Free;
        constructor Create(riverlevel, WaveLen: Integer);
    end;


implementation uses SysUtils;


function SortMe(Item1, Item2: Pointer): Integer;
begin
    Result := tcellptr(Item2)^.Alt - tcellptr(Item1)^.Alt;
end;

constructor tRivers.Create(riverlevel, WaveLen: Integer);
begin
    inherited Create;

    flist           := TList.Create;
    friverlevel     := riverlevel;
    fWideRiverCount := 0;

    { More cycles for large terrain clumps }
    fRiverGenCycles := 10 + Round(Sqrt(WaveLen)); // Somewhat arbitrary
end;

procedure tRivers.Free;
var B: Integer;
    ptr: tcellptr;

begin
    { Fix memory leak, need to do explicit dispose }
    for B := 0 to (fList.Count - 1) do
    begin
        ptr := fList.Items[B];
        Dispose(ptr);
    end;

    flist.Free;
    inherited Free;
end;

procedure tRivers.AltitudeSort;
begin
    flist.sort(@Sortme);
end;

procedure tRivers.Loaddata(Map: tMap);
var W, H, Alt: Integer;
    ptr: tcellptr;
begin
    fMap := Map;

    flist.capacity := Map.Width * Map.Height;
    for W := 1 to Map.Width do
        for H := 1 to Map.Height do
        begin
            Alt := Map.GetVal(Altitude, W, H);
            if Alt < Map.SeaLevel then
                { No rivers in the sea! }
            else
            begin
                New(ptr);
                ptr^.wid := W;
                ptr^.hgt := H;
                ptr^.Alt := Alt;
                flist.add(ptr);
            end;
        end;
end;


{ Note, some neigbors will be out of range }
{ Need to wrap width in round world }
function tRivers.GetNeigbors(W, H: Integer): Tneighbors;
var mybors: Tneighbors;

begin
    if Odd(H) then
    begin
        mybors[1].wid := fmap.WrapCheck(Pred(W));
        mybors[2].wid := W;
        mybors[3].wid := W;
        mybors[4].wid := fmap.WrapCheck(Pred(W));
    end
    else
    begin
        mybors[1].wid := W;
        mybors[2].wid := fmap.WrapCheck(Succ(W));
        mybors[3].wid := fmap.WrapCheck(Succ(W));
        mybors[4].wid := W;
    end;

    mybors[1].hgt := H - 1;
    mybors[2].hgt := H - 1;
    mybors[3].hgt := H + 1;
    mybors[4].hgt := H + 1;

    Result := mybors;
end;

function tRivers.OutOfRange(N: tcell): Boolean;
begin
    Result := (N.wid < 1) OR (N.wid > fMap.Width)
        OR (N.hgt < 1) OR (N.hgt > fMap.Height);
end;


{ Return true if a neighbor square is lower
  If so, return the address of the lowest }
function tRivers.LowestNeighbor(W, H, Myhgt: Integer; out NW, NH: Integer): Boolean;
var
    mybors: tneighbors;
    N, nbhgt: Integer;

begin
    Result := False;
    mybors := GetNeigbors(W, H);

    for N := 1 to 4 do
        if outofrange(mybors[N]) then
            {Skip it}
        else
        begin
            nbhgt := fMap.GetVal(Altitude, mybors[N].Wid, mybors[N].Hgt);
            if MyHgt > nbhgt then
            begin
                { Found a lower neighbour }
                Result := True;
                NW     := mybors[N].Wid;
                NH     := mybors[N].Hgt;
                myhgt  := nbhgt;
            end;
        end;
end;


procedure tRivers.Process_Tile(ptr: tCellptr);
var rainWater, Riverwater, MountainWater,
    NA, OldFall, NewFall,
    Alt, Water, W, H, NW, NH: Integer;
begin
    W   := ptr^.Wid;
    H   := ptr^.Hgt;
    Alt := ptr^.Alt;

    with fMap do
    begin
        if Alt < SeaLevel then
             { Skip underwater rivers }
        else
        begin
            ClearlakeRiver(W, H);
            RiverWater    := fMap.Tiles[W,H].Water;
            RainWater     := GetVal(Rainfall, W, H);
            MountainWater := Alt;
            water         := RiverWater + RainWater + MountainWater;

            if LowestNeighbor(W, H, Alt, NW, NH) then
            begin
                { River can flow to next sqaure }
                fMap.Tiles[NW, NH].Water := Water;

                { Erode current square by one }
                SetVal(Altitude, W, H, Alt-1);
                Dec(ptr^.Alt);

                { Store waterfall level in case silt up needed later }
                NA      := GetVal(Altitude, NW, NH);
                NewFall := Alt - NA;
                OldFall := fmap.Tiles[NW, NH].WaterFall;
                if (oldfall = -1) OR (NewFall < OldFall) then
                    fmap.Tiles[NW, NH].WaterFall := NewFall;
            end
            { Stagnant water }
            else
            if Water > friverlevel then
            begin
                { Silt up to level of lowest incoming river }
                if Alt < High(Byte) -1 then
                begin
                    OldFall := fmap.Tiles[W,H].WaterFall;
                    Assert(OldFall >= 0, 'Fault in Waterfall levels');
                    SetVal(Altitude, W, H, OldFall + Alt);
                    ptr^.Alt := Alt + OldFall;
                end;
            end;

            if ptr^.Alt < SeaLevel then
               { skip underwater river }
            else
            if Water > 1.5 * friverlevel then
            begin
                fMap.Tiles[W, H].WideRiver := True;
                Inc (fWideRiverCount);
            end
            else
            if Water > friverlevel then
            begin
                fMap.Tiles[W, H].River := True;
                
                if fMap.Tiles[W, H].Terrain = Mountain then
					// Rivers not allowed in mountain tiles
					fMap.Tiles[W, H].Terrain := Hills;
            end;
        end;
    end;
end;


procedure tRivers.Generate;
var W, H, I, C: Integer;
    ptr: tcellptr;

begin
    For C := 1 to fRiverGenCycles do
    begin
        AltitudeSort;

        with flist do
            for I := 1 to Count do
            begin
                ptr := items[I - 1];
                Process_Tile(ptr);
            end;
    end;
end;

end.
