unit Rivers;

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

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

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

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

interface

uses MapTiles, CevoMap, Classes;

type
    tRivers = class
    private

    type
        tNeighbours = array [1..4] of tCell;

        tRData =
            record
            AltReal: integer;
            River: boolean;
        end;

        tMyTiles = array [1..LxMax, 1..LyMax] of tRData;

    private
        fMap: tMap;
        fRMap: tMyTiles;

        fPercentage: integer;

        fWidthSlots  : array of integer;
        fHeightSlots : array of integer;

    protected
        function RiverNeighbours (W, H: integer): integer;
        function NextRiverTile (W, H: integer; out NW, NH: integer): boolean;
        function GetNeighbours (W, H: integer): tNeighbours;
        function OutOfRange (N: tcell): boolean;

        function GetCoastalTiles (W, H: integer): integer;
        function RunRiver (SW, SH: integer): integer;
        function NearToRiver (W, H: integer): boolean;
        function Estuary (W, H: integer): boolean;
        function SeaTiles (W, H: integer): integer;
        function BestStart (out SW, SH: integer): boolean;
        function Getland : integer;

        procedure RandomSequence (var MyArray : array of integer);
    public
        procedure Generate;
        procedure Loaddata (Map: tMap);

        procedure Free;
        constructor Create (Percentage: integer);
    end;


implementation

uses SysUtils;

constructor tRivers.Create (Percentage: integer);
begin
    inherited Create;
    fPercentage := Percentage;

    fRMap := default (tMyTiles);
end;

procedure tRivers.Free;
begin
    SetLength (fWidthSlots,  0);
    SetLength (fHeightSlots, 0);

    inherited Free;
end;


{ Note, some neighbours will be out of height range }
{ Need to wrap width in round world }
function tRivers.GetNeighbours (W, H: integer): tNeighbours;
var MyBors: tNeighbours;
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;

function tRivers.RiverNeighbours (W, H: integer): integer;
var MyBors: tNeighbours;
    N  : Integer;
begin
    MyBors := Getneighbours (W, H);
    Result := 0;
    for N := 1 to 4 do
        if OutOfRange (MyBors[N]) then
        {Skip it}
        else
        if fRMap[MyBors[N].Wid, MyBors[N].Hgt].River then
            inc (Result);
end;

function tRivers.NextRiverTile (W, H: integer; out NW, NH: integer): boolean;
const Fudge  = 7; // Fudge factor to help avoid local maximums when running rivers.
var MyBors: tNeighbours;
    N,Myhgt,nbhgt,lwhgt: integer;
begin
    result := False;
    lwhgt := 1000; // Arbitrary large number;
    NW := 0;
    NH := 0;
    Myhgt := fRMap[W, H].AltReal;
    MyBors := Getneighbours (W, H);

    for N := 1 to 4 do
        if OutOfRange (MyBors[N]) then
        {Skip it}
        else
        if fRMap[MyBors[N].Wid, MyBors[N].Hgt].River then
        // Already a river tile
        else
        begin
            nbhgt := fRMap[MyBors[N].Wid, MyBors[N].Hgt].Altreal;
            if (MyHgt <= nbhgt + Fudge) and (nbhgt < lwhgt)
            and (SeaTiles (MyBors[N].Wid, MyBors[N].Hgt) = 0)
            and (RiverNeighbours (MyBors[N].Wid, MyBors[N].Hgt) < 2) then
            begin
                { Found a lowest higher or equal neighbour, that is not on the coast }
                result := True;
                NW := MyBors[N].Wid;
                NH := MyBors[N].Hgt;
                lwhgt := nbhgt;
            end;
        end;
end;

function tRivers.GetCoastalTiles (W, H: integer): integer;
var N,NW,NH: integer;
begin
    result := 0;
    for N := 1 to 8 do
    begin
        fMap.SetNeighbour (W, H, N, NW, NH);

        if fRMap[NW, NH].AltReal = -1 then
            Inc (result);
    end;
end;

function tRivers.NearToRiver (W, H: integer): boolean;
var N,NW,NH: integer;
begin
    result := False;
    for N := 0 to 20 do
    begin
        // Nothing to do with  cities, but convenient to use this function
        fMap.GetCityNeighbour (W, H, N, NW, NH);

        if (NH > 0) and (NH <= fMap.Height) then
            if fRMap[NW, NH].River then
                result := True;
    end;
end;

function tRivers.SeaTiles (W, H: integer): integer;
var N: integer;
    MyBors: tNeighbours;
begin
    result := 0;
    MyBors := GetNeighbours (W, H);

    for N := 1 to 4 do
        if OutofRange (MyBors[N]) then
        // skip
        else
        if fRMap[MyBors[N].Wid, MyBors[N].hgt].ALtReal < 0 then
            Inc (result);
end;

function tRivers.Estuary (W, H: integer): boolean;
var C : Integer;
begin
    if SeaTiles (W,H) = 1 then
        C := GetCoastalTiles (W, H)
    else
        C := 0;

    Estuary := C in [1,2,3];
end;

function tRivers.BestStart (out SW, SH: integer): boolean;
const MinRain = 80;
var GCT,CS,W,H,WS,HS: integer;
begin
    result := False;
    SW := 0;
    SH := 0;
    CS := 9; // Impossible result

    // slots indexed from 0, Map indexed from 1
    for W := 0 to fMap.Width-1 do
    begin
        WS := fWidthSlots[W] +1;
        for H := 0 to fMap.Height-1 do
        begin
            HS := fHeightSlots[H] +1;

            if NearToRiver (WS, HS) then
                // Space out River starts
            else
            if Estuary (WS, HS)
            and (fMap.GetVal (RainFall, WS, HS) > MinRain) then // Terrain types not set yet!
            begin
                GCT := GetCoastalTiles (WS, HS);
                if (GCT > 0) and (GCT < CS) then
                    if (GCT = 1) then
                        // Avoid starting river from a puddle
                    else
                    begin
                        // Best so far
                        SW := WS;
                        SH := HS;
                        CS := GCT;
                        result := True;
                    end;
            end;
        end;
    end;
end;

function tRivers.RunRiver (SW, SH: integer): integer;
var NW,NH: integer;
begin
    fRMap[SW, SH].River := True;
    fMap.Tiles[SW, SH].River := True;
    result := 1;
    while NextRiverTile (SW, SH, NW, NH) do
    begin
        SW := NW;
        SH := NH;
        fRMap[SW, SH].River := True;
        fMap.Tiles[SW, SH].River := True;
        Inc (result);
    end;

    //Writeln ('Run River ', result);
end;

function tRivers.Getland : integer;
var W,H: integer;
begin
    result := 0;
    for W := 1 to fMap.Width do
      for H := 1 to fMap.Height do
        if fRMap[W, H].AltReal >= 0 then
            Inc (result);
end;

procedure tRivers.Generate;
var SW,SH,Target: integer;
begin
    Target := (GetLand * fPercentage) div 100;

    while Target > 0 do
        if BestStart (SW, SH) then
            Target := Target - RunRiver (SW, SH)
        else
            Target := 0 // Terminate loop
end;


procedure tRivers.RandomSequence (var MyArray : array of integer);
var I,J,tmp : integer;
begin
    for I := low (MyArray) to high (MyArray) do
        MyArray[I] := I;

    // Shuffle by swaping each element with a random one
    for I := low (MyArray) to high (MyArray) do
    begin
        tmp         := MyArray[I];
        J           := Random (high (MyArray)+1);
        MyArray[I]  := MyArray[J];
        MyArray[J]  := tmp;
    end;
end;

procedure tRivers.LoadData (Map: tMap);
var W,H: integer;
begin
    fMap := Map;

    for W := 1 to fMap.Width do
      for H := 1 to fMap.Height do
        if fMap.GetVal (Altitude, W, H) < fMap.SeaLevel then
            { Ocean tile }
            fRMap[W, H].AltReal := -1
        else
            fRMap[W, H].AltReal := fMap.GetVal (Altitude, W, H) - fMap.SeaLevel;

    SetLength (fWidthSlots,  fMap.Width);
    SetLength (fHeightSlots, fMap.Height);

    RandomSequence (fWidthSlots);
    RandomSequence (fHeightSlots);
end;

end.
