unit CevoMap;

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

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

Definition of main Map class

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



interface uses Classes, MapTiles, Textures;

const
    MaxMap = lxmax * lyMax; // maximum width * height

type
    tTerrainArray = array [low(tTerrain)..High(tTerrain)] of Integer;

    tResource = (Nothing, EarlyBonus, LateBonus);
    tSpecial  = (NoSpecial, DeadLands, Cobalt, Uranium, Mercury);

    tCTile =
        record
        Wid:   Integer;
        Hgt:   Integer;
        Score: Integer;
        Tile:  tTerrain;
        DeadLand,
        Cull:  Boolean;
    end;
    tTileptr = ^tCTile;

    tcellptr = ^tcell;
    tcell    =
        record
        Wid: Integer;
        Hgt: Integer;
        Alt: Integer;
    end;

    dataclass = (altitude, rainfall, temperature, adjalt, adjrain, adjtemp);

    tMapSquare =
    packed record
        tex:      array [altitude..adjtemp] of Integer;
        Water:    Integer;
        Terrain:  tTerrain;
        Resource: tResource;
        Special:  tSpecial;
        River, Swamp, InnerCoast, OuterCoast, StartPos: Boolean;
    end;

    tMapTiles   = array [1..LxMax, 1..LyMax] of tMapSquare;

    tMap = class
        Tiles:     tMapTiles;

    private
    type
        tTexStat = array [0..4] of Integer;

    private
        fBiasE:    array [altitude..temperature] of Integer;
        fBiasP:    array [altitude..temperature] of Integer;
        fgain:     array [altitude..temperature] of Integer;
        fHeight,
        fWidth,
        fLandPercent,
        fSeaLevel,
        fSeaTiles,
        fMountainPercent,
        fMountainLevel: Integer;
        ftexstats: array [altitude..temperature] of tTexstat;
        flist:     TList;

    protected
        procedure ClearCityList;
        function GetCityIndex (C : integer) : integer;
        function ReRange(Val, NewMax, NewMin: Integer): Integer;
        procedure SetTexture(tex: Ttexture; dclass: dataclass);
        function BuildTile(W, H: Integer): tterrain;

        // Resources
        procedure SetResource(W, H, Q: Integer);
        procedure AllocateResources  (Q: Integer);

        // Coastal.pp
        procedure GetNeighbour(Ww, Hh, N: Integer; out W, H: Integer);
        function Isolated(W, H: Integer): Boolean;
        function CoastTarget(W, H: Integer; C: Boolean): Boolean;
        procedure CheckNearest(Ww, Hh: Integer; C: Boolean);
        procedure DoInnerCoast;
        procedure DoOuterCoast;

        // TileResource
        procedure TileResource(const W, H: Integer; out F, P, Tr: Integer; out PosDeadLands: Boolean);

        // DeadLands
        function CheckDeadLand(const C: tTileptr; T: tTerrain; out DLW, DLH: Integer): Boolean;
        procedure SetDeadTile(D, W, H: Integer);
        procedure SetDeadLand(const C: tTileptr; Cn, D: Integer);
        procedure AllocateDeadLands;

        // StartPositions.pp
        procedure DumpCity(W, H: Integer);
        function CoastalCity(const W, H: Integer): Boolean;
        procedure AddCity(W, H, S: Integer; T: tTerrain; DL: Boolean);
        function Dist(W1, H1, W2, H2: Integer): Integer;
        procedure CullCitySites;

    public
        constructor Create(Wid, Hgt, Sea, Mount: Integer);
        destructor Destroy; override;

        function MapIndex(W, H: Integer): Integer;
        function WrapCheck(W: Integer): Integer;
        function GetStats(var Rivers: Integer): tterrainArray;
        procedure ClearStats;
        procedure AltitudeSort;
        procedure AdjustSeaLevel;
        procedure AdjustMountainLevel;
        procedure PlaceStartPositions;
        procedure MakeTerrain (ResourceLevel : Integer);
        procedure GenMap(dclass: dataclass; Wave, Dim, Lac: Double;
            BiasE, BiasP, Gain: Integer; ResetNoise: Boolean);
        function GetVal(dclass: dataclass; W, H: Integer): Integer;
        procedure SetVal(dclass: dataclass; W, H: Integer; Value: Integer);
        function GetTerrain(W, H: Integer): tTerrain;
        procedure SetTerrain(W, H: Integer; T: tTerrain; R: Boolean);
        procedure ClearLakeRiver(W, H: Integer);

        procedure CullSingleTileIslands;
        procedure GetCityNeighbour(W, H, N: Integer; out Wt, Ht: Integer);
        procedure SetNeighbour(W, H, N: Integer; out NW, NH: Integer);

        // Resources
        function GetBonus(W, H: Integer): tResource;
        function GetSpecial(W, H: Integer): tSpecial;
        procedure SetBonus(W, H: Integer; R: tResource);
        procedure SetSpecial(W, H: Integer; S: tSpecial);

        // StartPositions
        function StartScore (W,H : Integer; out DeadLand : Boolean) : Integer;
        function CitySquares: Integer;
        function StartPosition(W, H: Integer): Boolean;
        procedure SetStartPosition(W, H: Integer);
        procedure GetCitySites;

        property Width: Integer read fwidth write fwidth;
        property Height: Integer read fheight write fheight;
        property SeaLevel: Integer read fSeaLevel;
        property MountainLevel: Integer read fMountainLevel;
    end;

var
   MinCityDist, MinCityScore, NumStartPos, NumDeadLands : integer;


implementation uses SysUtils, Math, Utils, SortTiles, Message;

var
    Citylist: TList; // Possible City sites


function CitySort(Item1: Pointer; Item2: Pointer): Longint;
begin
    Result := tTileptr(Item2)^.Score - tTileptr(Item1)^.Score;
end;

constructor tMap.Create(Wid, Hgt, Sea, Mount: Integer);
begin
    inherited Create;
    fWidth         := Wid;
    fHeight        := Hgt;
    fLandPercent   := Sea;
    fMountainPercent := Mount;
    fSeaLevel      := -1;
    fMountainLevel := -1;

    Tiles       := default (tMapTiles);

    Citylist := TList.Create;
end;

procedure tMap.ClearCityList;
var B: Integer;
    TPtr: tTilePtr;
begin
    for B := 0 to (CityList.Count - 1) do
    begin
        Tptr := CityList.Items[B];
        Dispose(Tptr);
    end;
    CityList.Clear;
end;

destructor tMap.Destroy;
var B: Integer;
    Cptr: tCellptr;

begin
    If fList = nil then
        // Not created yet
    else
        for B := 0 to (fList.Count - 1) do
        begin
            Cptr := fList.Items[B];
            Dispose(Cptr);
        end;

    ClearCityList;
    Citylist.Free;
    fList.Free;
    inherited;
end;

function TMap.MapIndex(W, H: Integer): Integer;
begin
    Result := W + (H - 1) * Width; // Index starts from 1 (Map editor starts from 0)
end;


// Allow width to wrap around in round world
function tMap.WrapCheck(W: Integer): Integer;
begin
    if W < 1 then
        Result := W + Width
    else
    if W > Width then
        Result := W - Width
    else
        Result := W;
end;

procedure tmap.SetNeighbour(W, H, N: Integer; out NW, NH: Integer);
begin
    NH := 0;
    NW := 0;

    case N of
        1: begin
            NH := H - 2;
            NW := W;
        end;
        2: begin
            NH := H - 1;
            NW := W;
        end;
        3: begin
            NH := H + 1;
            NW := W;
        end;
        4: begin
            NH := H + 2;
            NW := W;
        end;
        5: begin
            NH := H - 1;

            if NOT Odd(H) then
                NW := WrapCheck(W + 1)
            else
                NW := WrapCheck(W - 1);
        end;
        6: begin
            NH := H;
            if NOT Odd(H) then
                NW := WrapCheck(W + 1)
            else
                NW := WrapCheck(W - 1);
        end;
        7: begin
            NH := H + 1;
            if NOT Odd(H) then
                NW := WrapCheck(W + 1)
            else
                NW := WrapCheck(W - 1);
        end;
        8: begin
            NH := H;
            if NOT Odd(H) then
                NW := WrapCheck(W - 1)
            else
                NW := WrapCheck(W + 1);
        end;
    end;

    if NH > Height then
        NH := Height
    else
    if NH < 1 then
        NH := 1;

    if NW > Width then // FIXME  Wrapcheck should do this!
        NW := Width
    else
    if NW < 1 then
        NW := 1;
end;


function tMap.GetStats(var Rivers: Integer): tterrainArray;
var Stats: TTerrainArray;
    S: Double;
    W, H: Integer;
    T: tTerrain;
begin
    for T := Low(tTerrain) to High(tTerrain) do
        Stats[T] := 0;

    for W := 1 to Width do
        for H := 1 to Height do
        begin
            Inc(Stats[GetTerrain(W, H)]);
            if Tiles[W, H].River then
                Inc(Rivers);
        end;

    // Reduce to a percentage
    for T := Low(tTerrain) to High(tTerrain) do
    begin
        S        := 100 * Stats[T] / (Width * Height);
        Stats[T] := MyRound(S);
    end;

    S      := 100 * Rivers / (Width * Height);
    Rivers := MyRound(S);

    Result := Stats;
end;


function Tmap.ReRange(Val, NewMax, NewMin: Integer): Integer;
var Max: Integer;
begin
    Max := Height;
    // Round world values peak at equator
    if Val > Height DIV 2 then
        Val := Height - Val;
    Max     := max DIV 2;

    Result := Round(NewMin + (NewMax - NewMin) * JumpStep(1, Max, Val));
end;


procedure TMap.ClearLakeRiver(W, H: Integer);
begin
    with Tiles[W, H] do
    begin
        River     := False;
        Swamp     := False;
    end;
end;

function TMap.GetVal(dclass: dataclass; W, H: Integer): Integer;
begin
    Result := Tiles[W, H].tex[dclass];
end;

procedure TMap.SetVal(dclass: dataclass; W, H: Integer; Value: Integer);
begin
    Tiles[W, H].tex[dclass] := Value;
end;

function TMap.GetTerrain(W, H: Integer): tterrain;
begin
    if (Tiles[W, H].Terrain = Coast) then
        Result := Coast
    else
    if Tiles[W, H].Swamp then
    begin
        // Swamp etc may have been generated here by river process
        if GetVal(Temperature, W, H) > 40 then
            Result := Swamp
        else
            // Freezes if realy cold
            Result := Glacier;
    end
    else
        Result := tterrain(Tiles[W, H].Terrain);
end;

procedure TMap.SetTerrain(W, H: Integer; T: tTerrain; R: Boolean);
begin
    // mask out non terain resouirce info beyond $F Hex
    Tiles[W, H].Terrain := tTerrain(Byte(T) AND $F);

    Tiles[W, H].Swamp      := False;
    Tiles[W, H].River      := R;
    Tiles[W, H].Resource   := Nothing;
    Tiles[W, H].Special    := NoSpecial;
    Tiles[W, H].InnerCoast := False;
    Tiles[W, H].OuterCoast := False;
    Tiles[W, H].StartPos   := False;
end;

procedure tMap.SetTexture(tex: Ttexture; dclass: dataclass);
var H, W: Integer;
    bias,
    test: Integer;
begin
    for H := 1 to Height do
        for W := 1 to Width do
        begin
            test := tex.Scale(W, H);
            bias := ReRange(H, fBiasE[dclass], fBiasP[dclass]);
            test := GainBias(test, fGain[dclass], bias);
            Tiles[W, H].tex[dclass] := test;
        end;
end;

procedure tMap.GenMap(dclass: dataclass; Wave, Dim, Lac: Double;
    BiasE, BiasP, Gain: Integer; ResetNoise: Boolean);
var tex: ttexture;
    Oct: Double;
begin
    tex := ttexture.Create(Width, Height);
    oct := Round(10 * LOG2(Wave)) / 10;

    fbiasE[dclass] := biasE;
    fbiasP[dclass] := biasP;
    fgain[dclass]  := gain;

    // These params should move to the texture create
    tex.Gendata(wave, Dim, Lac, Oct, ResetNoise);
    SetTexture(tex, dclass);
    tex.Free;
end;


function tMap.BuildTile(W, H: Integer): tterrain;

Const NoGrass : Boolean = False; // For AI testing

var Elevation, Rain, Temp, Alt : Integer;
    rainx, tempx: Double;
begin
    Rain := GetVal(Rainfall, W, H);;
    Elevation := GetVal(Altitude, W, H);

    if Elevation < SeaLevel then
        Result := Ocean
    else
    begin
        Rainx := Rain  / 64;
        Tempx := GetVal(Temperature, W, H) / 64;
        Rain  := BlendRound(Rainx);
        Temp  := BlendRound(Tempx);

        if Elevation > MountainLevel then
        begin
            Alt    := 3;
            Result := Mountain;
        end
        else
        begin
            // Split into landmass relative height bands
            if (MountainLevel - SeaLevel) <=0 then
                Alt := 3  // Guard against divide by zero
            else
                Alt := BlendRound(3.2 * (Elevation - SeaLevel) / (MountainLevel - SeaLevel));

            case Alt of
                0: Result    := Lowlands (Rain, Temp);
                1: Result    := Steppe   (Rain, Temp);
                2, 3: Result := Highlands(Rain, Temp);
            else
                Result := Mountain;
            end;

            if NoGrass and (Result = Grass) then
            begin
                if temp < 2 then
                    Result := Tundra
                else
                    Result := Prairie;
            end;
        end;

        Inc(fTexStats[Altitude, Alt]);
        Inc(fTexStats[RainFall, Rain]);
        Inc(fTexStats[Temperature, Temp]);
    end;
end;


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

procedure tMap.AltitudeSort;
var W, H, Alt: Integer;
    ptr: tcellptr;
begin
    flist          := TList.Create;
    flist.capacity := Width * Height;

    for W := 1 to Width do
        for H := 1 to Height do
        begin
            Alt := GetVal(Altitude, W, H);

            New(ptr);
            ptr^.wid := W;
            ptr^.hgt := H;
            ptr^.Alt := Alt;
            flist.add(ptr);
        end;

    flist.sort(@Sortme);
end;


procedure tMap.AdjustSeaLevel;
var I: Integer;
    T: tcellptr;
begin
    I         := Round((flist.Capacity-1) * (100 - fLandPercent) / 100);
    T         := flist.Items[I];
    fSeaLevel := T^.Alt;
    fSeaTiles := I;
end;


procedure tMap.AdjustMountainLevel;
var I,
    LandTiles,
    MountainTiles: Integer;
    T: tcellptr;
begin
    LandTiles := flist.Capacity - fSeaTiles;
    MountainTiles := Round((LandTiles * fMountainPercent) / 100);
    I := flist.Capacity - MountainTiles -1;
    T := flist.Items[I];
    fMountainLevel := T^.Alt;
end;


procedure tMap.ClearStats;
var I: Integer;
    D: dataclass;

begin
    for D := altitude to temperature do
        for I := 0 to 4 do
            fTexStats[D, I] := 0;
end;


procedure tMap.MakeTerrain (ResourceLevel : Integer);
var W, H : Integer;

begin
{$IFDEF DEBUG}
    // Make consistent between runs
    RandSeed := 5;
{$ENDIF}

    for H := 1 to Height do
        for W := 1 to Width do
            Tiles[W, H].Terrain := BuildTile(W, H);

    // Coastal
    DoInnerCoast;
    DoOuterCoast;

    // StartPositions
    AllocateResources (ResourceLevel);
    PlaceStartPositions;
end;

{$INCLUDE Resources}
{$INCLUDE Coastal}
{$INCLUDE TileResource}
{$INCLUDE DeadLands}
{$INCLUDE StartPositions}

initialization
   // Default values
    MinCityDist  := 5;
    MinCityScore := 7;
    NumStartPos  := 20;
    NumDeadLands := 15;
end.