GLScene/Sourcex/GXS.RandomHDS.pas

//
// The graphics engine GXScene https://github.com/glscene
//
unit GXS.RandomHDS;

(*
  This unit provides tools and objects to generate random Height Data Sources
  that can be used with TgxTerrainRenderer. General properties are defined in
  TgxBaseRandomHDS, but the main object is TgxCustomRandomHDS,
  which defines all the basic functionalities; however, it is an abstract class.
  So far, it has only one descendent, TgxFractalHDS, which implements the fractal
  middle-point displacement algorithm (aka plasma, aka diamond-square).
  The actual algorithms are independent functions called by the objects so they
  can also be used in other contexts. Basically, only the BuildHeightField
  method has to be overriden, and properties
  particular to the algorithm added (see TgxFractalHDS implementation). The
  BuildHeightField should contain a call to the algorithm function (or the algorithm
  itself, and MUST set the following fields: fSize, fMinHeight, fMaxHeight and
  fRangeHeight.

  Landscape generation consists in the following steps:
  1° Generate height field
  2° Modify it through erosion, sea surface, etc.
  3° Compute light and shadows
  4° Build the texture and assign it to a material created for this purpose

  The above classes generate isolated landscapes. They can be tiled in an
  infinite landscape through TgxTiledRndLandscape. The function of this class
  is to maintain a list of landscapes (called thereafter "landtiles"), to build
  and free them when needed.
  The TgxFractalArchipelago is an example of such a landscape generating an
  infinite landscape made of fractal islands.

  Although this structure may appear complex, the programmer just need to
  instanciate a TgxFractalArchipelago and to set its properties to get it running
  transparently. See the FractalLandscape and FractalArchipelago demos to see
  how to use these objects and what the various properties mean.

  Additional comments can be found in the code in the particular procedures.
  These components can be freely used. So far, you have to declare and
  create this component manually in your code and link it to a TgxTerrainRenderer.
  If you know how to make a registered component, please do it.
*)

interface

uses
  Winapi.Windows,
  System.Classes,
  System.Math,
  System.SysUtils,
  System.UITypes,
  System.UIConsts,
  System.Contnrs,

  Fmx.Graphics,
///  Fmx.Imaging.jpeg,
  Fmx.Forms,

  Stage.OpenGL4,
  GXS.Scene,
  Stage.VectorTypes,
  Stage.VectorGeometry,
  GXS.HeightData,
  GXS.TerrainRenderer,
  GXS.Texture,
  GXS.Color,
  GXS.Coordinates,
  GXS.RenderContextInfo,
  GXS.Material,
  GXS.Context;

type
  TSeaErosion = record
    Enabled: boolean;
    BeachHeight: single;
  end;

  TRainErosion = record
    Enabled: boolean;
    ErosionRate: single;
    DepositRate: single;
  end;

  TLifeErosion = record
    Enabled: boolean;
    Robustness: single;
  end;

  TFractionErosion = record
    Enabled: boolean;
    Slope: single;
  end;

  TLandTileInfo = record
    x, z: integer; // Coordinates of the landtile. Used to generate the seed
    State: TgxHeightDataState; // Preparation status of the landtile
  end;

  TSteps = record
    Enabled: boolean;
    Count: integer;
  end;

  TMapOfSingle = array of array of single;
  TMapOfVector = array of array of TVector4f;

  TgxBaseRandomHDS = class;

  // Function type to use for topography-based texture
  TOnDrawTexture = function(const Sender: TgxBaseRandomHDS; x, y: integer; z: double; Normal: TVector4f): TgxColorVector of object;

  TSingleClamp = procedure(var x, y: single) of object;
  TIntegerClamp = procedure(var x, y: integer) of object;

  (* This class introduces all the basic properties of random landscape. No method
    implemented though. It is used as a descendant for
    - TgxCustomRandomLandscape: one tile landscape (cyclic or not)
    - TgxTiledRndLandscape: "infinite" landscapes (grids of TgxCustomRandomLandscape) *)
  TgxBaseRandomHDS = class(TgxHeightDataSource)
  private
    FSteps: TSteps;
    FLandCover: boolean;
    procedure SetOnDrawTexture(const Value: TOnDrawTexture);
    procedure SetSteps(const Value: TSteps);
    procedure SetLandCover(const Value: boolean);
  protected
    FSeed: integer;
    FSize: integer;
    FMaterialName: string;
    FLighting: boolean;
    FLightDirection: TVector4f;
    FTerrainRenderer: TgxTerrainRenderer;
    FLightColor: TgxColorVector;
    FShadows: boolean;
    FSea: boolean;
    FSeaLevel: single;
    FAmbientLight: single;
    FTaskProgress: integer;
    FTextureScale: integer;
    FErosionByFraction: TFractionErosion;
    FLightSmoothing: boolean;
    FCyclic: boolean;
    FSeaTransparency: single;
    FPrimerLandscape: boolean;
    FLandTileInfo: TLandTileInfo;
    FOnDrawTexture: TOnDrawTexture;
    function OnDrawTextureDefault(const Sender: TgxBaseRandomHDS; x, y: integer; z: double; Normal: TVector4f): TgxColorVector;
    procedure SetSeed(const Value: integer);
    procedure SetMaterialName(const Value: string);
    procedure SetLighting(const Value: boolean);
    procedure SetLightDirection(const Value: TVector4f);
    procedure SetTerrainRenderer(const Value: TgxTerrainRenderer); virtual; abstract;
    procedure SetLightColor(const Value: TgxColorVector);
    procedure SetShadows(const Value: boolean);
    procedure SetSea(const Value: boolean);
    procedure SetSeaLevel(const Value: single);
    procedure SetAmbientLight(const Value: single);
    procedure SetErosionByRain(const Value: TRainErosion);
    function GetErosionByRain: TRainErosion;
    procedure SetErosionBySea(const Value: TSeaErosion);
    procedure SetTextureScale(const Value: integer);
    procedure SetErosionByLife(const Value: TLifeErosion);
    procedure SetErosionByFraction(const Value: TFractionErosion);
    procedure SetLightSmoothing(const Value: boolean);
    procedure SetSeaTransparency(const Value: single);
    procedure SetPrimerLandscape(const Value: boolean);
    function GetSeaLevel: single;
    function GetSeaTransparency: single;
    procedure SetLandTileInfo(const Value: TLandTileInfo);
    function GetLandTileInfo: TLandTileInfo;
    procedure SetCyclic(const Value: boolean); virtual; abstract;
  public
    FErosionByRain: TRainErosion;
    FErosionBySea: TSeaErosion;
    FErosionByLife: TLifeErosion;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    // Usually white, but you can generate e.g.sunset ambiance by setting it to red
    property LightColor: TgxColorVector read FLightColor write SetLightColor;
    // Light is parallel (sun light)
    property LightDirection: TVector4f read FLightDirection write SetLightDirection;
    (* This function must be supplied by the user. Here he/she can define which
      colour to use depending on coordinates, elevation and normal. This provides
      a great flexibility. If no function is supplied (OnDrawTexture=nil), a default
      texture function is used (very basic, just blue and green). *)
    property OnDrawTexture: TOnDrawTexture read FOnDrawTexture write SetOnDrawTexture;
  published
    property AmbientLight: single read FAmbientLight write SetAmbientLight;
    (* If true, the landscape can be tiled to itself seamlessly.
      If false, the landscape is an isolated square. *)
    property Cyclic: boolean read FCyclic write SetCyclic;
    // Erosion parameters. See associated record types
    property ErosionByFraction: TFractionErosion read FErosionByFraction write SetErosionByFraction;
    property ErosionByLife: TLifeErosion read FErosionByLife write SetErosionByLife;
    property ErosionByRain: TRainErosion read FErosionByRain write SetErosionByRain;
    property ErosionBySea: TSeaErosion read FErosionBySea write SetErosionBySea;
    property LandCover: boolean read FLandCover write SetLandCover;
    // Enable or disable all lighting effects
    property Lighting: boolean read FLighting write SetLighting;
    // True by default. You can gain a little speed by disabling it.
    property LightSmoothing: boolean read FLightSmoothing write SetLightSmoothing;
    (* Not used *)
    property MaterialName: string read FMaterialName write SetMaterialName;
    (*
      If true, the height-field will not be emptied and generation will take the
      existing heights to shape the new landscape
    *)
    property PrimerLandscape: boolean read FPrimerLandscape write SetPrimerLandscape;
    // Enable the sea surface truncation
    property Sea: boolean read FSea write SetSea;
    // Sea level
    property SeaLevel: single read GetSeaLevel write SetSeaLevel;
    // Depth at which the sea bottom becomes invisible. See DoSea for more information
    property SeaTransparency: single read GetSeaTransparency write SetSeaTransparency;
    (* Seed used by the random generator. Each seed generate a different
      reproductible landscape. *)
    property Seed: integer read FSeed write SetSeed;
    // Enable shadow casting. May take some time for large Depth.
    property Shadows: boolean read FShadows write SetShadows;
    property Steps: TSteps read FSteps write SetSteps;
    // TerrainRenderer used to render the HDS.
    property TerrainRenderer: TgxTerrainRenderer read FTerrainRenderer write SetTerrainRenderer;
    (* Defines how many texture pixels are drawn per height-field cell. The larger
      this number the better the quality of the resulting image, but it takes a
      more time to compute. Good results are got between 1 and 5. *)
    property TextureScale: integer read FTextureScale write SetTextureScale;
  end;

  (* Base structure for all random landscape objects. It can't be used directly
    since its BuildHeightField procedure is abstract. Use one of its descendants instead. *)
  TgxCustomRandomHDS = class(TgxBaseRandomHDS)
  private
    FSlave: boolean;
    FMaxHeight: single;
    FMinHeight: single;
    FRangeHeight: single;
    FTask: string;
    FSingleConstrain: TSingleClamp;
    FIntegerConstrain: TIntegerClamp;
    FKeepNormals: boolean;
    function GetHeight(x, y: integer): single;
    procedure SetHeight(x, y: integer; const Value: single);
    procedure SetKeepNormals(const Value: boolean);
  protected
    procedure SetTerrainRenderer(const Value: TgxTerrainRenderer); override;
    procedure SetCyclic(const Value: boolean); override;
    procedure BoundaryClamp(var x, y: single); overload;
    procedure BoundaryClamp(var x, y: integer); overload;
    procedure CyclicClamp(var x, y: single); overload;
    procedure CyclicClamp(var x, y: integer); overload;
    // TgxTerrainRenderer event handler
    procedure GetTerrainBounds(var l, t, r, b: single);
    // This procedure MUST be called by the descendent of TgxBaseRandomHDS
    procedure SetSize(const aSize: integer);
  public
    FHeight: TMapOfSingle;
    FLightMap: TMapOfSingle;
    FNormal: TMapOfVector;
    // Upper bounds of the tile
    function BoundaryX: integer;
    function BoundaryZ: integer;
    // Generate the heightfield array, based on the topographical properties
    procedure BuildHeightField; overload; virtual; abstract;
    (* Provide an automated way to build a landscape. However, a greater control can
      be achieved by calling the various procedures manually (they are public methods)
      as one gets a sligthly different result depending on the sequence of erosion
      and sea steps. *)
    procedure BuildLandscape;
    (* - Compute the light effects
      - Compute the casted shadows
      - Perform a basic smoothing if TextureScale>1 *)
    procedure BuildLightMap; overload;
    procedure BuildLightMap(const aLightDirection: TVector4f); overload;
    // Normals are needed for lighting and slope-based textures
    procedure BuildNormals;
    (* For every pixel of the texture, computes slope and interpolated height and
      sends these information to a user-supplied function (OnDrawTexture), whose
      result is a TgxColorVector. If no OnDrawTexture is supplied, a basic default
      texture will be used. *)
    procedure BuildTexture;
    // Fill the heightfield with "Empty" values (-999)
    procedure ClearHeightField;
    // Fill the light map with 1
    procedure ClearLightMap;
    (* Constrain x,y to be in the boundaries of the height field array. This is
      done in two way depending on the kind of landscape:
      Cyclic landscapes: 		mod
      Non-cyclic landscape:	clamp *)
    procedure ConstrainCoordinates(var x, y: single); overload;
    procedure ConstrainCoordinates(var x, y: integer); overload;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    // Enforces an identical height on the opposing edges of the landscape
    procedure DoCyclicBoundaries;
    (* Not yet implemented *)
    procedure DoErosionByFraction;
    (* Just a smoothing. Should be done last as it improves the look of other
      erosion effects. Too much biological erosion can ruin erase their results
      though. Some tweaking may be needed *)
    procedure DoErosionByLife;
    (* Create sharp valleys and canyons. If DepositRate>0, it will also fill the
      low pools, producing flat "lakes" and "ponds" *)
    procedure DoErosionByRain;
    // Create a beach and a cliff around the islands
    procedure DoErosionBySea;
    (* Cut all elevations lower than sea level. If Transparency>0, the sea surface
      will not be flat, but a slight elevation change (unperceptible in 3D view)
      allow to fake transparency in the OnDrawTexture. *)
    procedure DoSea;
    // Discretise the heigthfield in a chosen number of steps
    procedure DoSteps;
    (* x and y are range-checked and constrained into the array. This slows down
      computation. If you don't need to range-check (this is mainly useful in
      cyclic landscapes when you need a seamless joint), call fHeigth instead
      (this is a protected field, therefore only accessible from TgxFractalHDS
      descendents. *)
    property Heights[x, y: integer]: single read GetHeight write SetHeight;
    // Range checked
    (* A specific implementation of THeightDataSource.InterpolatedHeight *)
    function Interpolate(x, y: single): single;
    // Keep the array of normals for future use
    property KeepNormals: boolean read FKeepNormals write SetKeepNormals;
    (* Property used by TgxTiledRndLandscape to know where the landtile is located
      and other parameters. See tLandTileInfo *)
    property LandTileInfo: TLandTileInfo read GetLandTileInfo write SetLandTileInfo;
    // Range checking
    function PointInMap(const x, y: single): boolean; overload;
    function PointInMap(const x, y: integer): boolean; overload;
    // Store the minimum and maximum elevations
    property MaxHeight: single read FMaxHeight;
    property MinHeight: single read FMinHeight;
    // Vector normal to the terrain at the position
    function Normal(const Position: TVector4f): TVector4f;
    // Max height - min height
    property RangeHeight: single read FRangeHeight;
    (* Scale of the Terrain Renderer. They are set so as giving a identical
      vertical/horitontal ratio with any size. Therefore, Scale.X=Scale.Y=1 and
      only Scale.Z varies. If you want to increase the landscape scale, the best way
      would be to place the Terrain Renderer in a DummyCube and rescale it. *)
    function Scale: TgxCoordinates;
    (* Size of the square height array. With the middle-point algorithm, it is always
      Size = 2^N+1. In a cyclic landscape, the last row and columns are identical
      to the first. *)
    property Size: integer read FSize;
    // A height rescaled between 0 and 1000 for
    function StandardisedHeight(const x, y: integer): single;
    (* When long computations are running, this property contains the operation
      beeing processed. *)
    property Task: string read FTask;
    // A value between 0 and 100 indicating the percentage of completion
    property TaskProgress: integer read FTaskProgress;
    // Use these boundaries with non-cyclic landscapes to constrain camera movements.
    function XMoveBoundary: single;
    function ZMoveBoundary: single;
    // tTerrainRender event handler
    procedure StartPreparingData(heightData: TgxHeightData); override;
  published
    property Cyclic: boolean read FCyclic write SetCyclic;
  end;

  // Random landscape based on the middle-point displacement algorithm
  TgxFractalHDS = class(TgxCustomRandomHDS)
  private
    FAmplitude: integer;
    FDepth: integer;
    FRoughness: single;
    procedure SetAmplitude(const Value: integer);
    procedure SetDepth(const Value: integer);
    procedure SetRoughness(const Value: single);
  public
    procedure BuildHeightField; overload; override;
    procedure BuildHeightField(const aDepth, aSeed, aAmplitude: integer); overload;
    constructor Create(AOwner: TComponent); override;
  published
    // Proportional to the difference between highest and lowest altitude.
    property Amplitude: integer read fAmplitude write SetAmplitude;
    (* Number of levels in the fractal process. Depth defines the size of the
      landscape: Size = 2^Depth+1 . Good results are got with Depth>=6. Above 10
      the landscape takes a lot of time to be generated. *)
    property Depth: integer read fDepth write SetDepth;
    // The lower this parameter, the smoother the landscape. Takes value between 0 and 1
    property Roughness: single read fRoughness write SetRoughness;
  end;

  (* TMapOfLandscapes	:array of array of TgxBaseRandomHDS; *)

  TLandTile = TgxCustomRandomHDS;

  TRelativeCoordinate = record
    DX, DZ: integer
  end;

  TOnCreateLandTile = procedure(x, z, Seed: integer; var aLandscape: TLandTile) of object;
  TIsDefaultTile = function(x, z: integer): boolean of object;

  // Random Lansdscape with tiles
  TgxTiledRndLandscape = class(TgxBaseRandomHDS)
  private
    FLandTileComputing: boolean; // Is a landtile being computed?
    FExtentX: integer;
    FExtentZ: integer;
    FExtentXhalf: integer;
    FExtentZhalf: integer;
    fLandTileSize: integer;
    FSingleConstrain: TSingleClamp;
    FIntegerConstrain: TIntegerClamp;
    FTerrainRenderer: TgxTerrainRenderer;
    FCamera: TgxCamera;
    fOnCreateLandTile: TOnCreateLandTile;
    fOnCreateDefaultTile: TStartPreparingDataEvent;
    FIsDefaultTile: TIsDefaultTile;
    FSeed: integer;
    fBaseSeed: integer;
    fComputedLandTile: TLandTile;
    FLandTileCapacity: integer;
    FGenerationRadius: integer;
    FLandTileDensity: single;
    procedure fDefaultOnCreateDefaultTile(HeightData: TgxHeightData);
    function fDefaultIsDefaultTile(x, z: integer): boolean;
    procedure SetExtentX(const Value: integer);
    procedure SetExtentZ(const Value: integer);
    procedure SetOnCreateLandTile(const Value: TOnCreateLandTile);
    procedure SetCamera(const Value: TgxCamera);
    procedure SetIsDefaultTile(const Value: TIsDefaultTile);
    procedure SetSeed(const Value: integer);
    procedure SetOnCreateDefaultTile(const Value: TStartPreparingDataEvent);
    function GetTask: string;
    function GetTaskProgress: integer;
    procedure SetLandTileCapacity(const Value: integer);
    procedure SetGenerationRadius(const Value: integer);
    procedure SetLandTileDensity(const Value: single);
  protected
    FGenRadius: array of TRelativeCoordinate;
    FOldCamX: integer;
    FOldCamZ: integer;
    FMapUpdating: boolean;
    FLandTiles: tComponentList;
    procedure BoundaryClamp(var x, z: single); overload;
    procedure BoundaryClamp(var x, z: integer); overload;
    procedure ComputeLandTile(const aX, aZ: integer;
      var NewLandTile: TLandTile); virtual;
    procedure CyclicClamp(var x, z: single); overload;
    procedure CyclicClamp(var x, z: integer); overload;
    // tTerrainRenderer event handler
    procedure GetTerrainBounds(var l, t, r, b: single);
    function LandTileSeed(x, z: integer): integer;
    property OnCreateDefaultTile: TStartPreparingDataEvent
      read fOnCreateDefaultTile write SetOnCreateDefaultTile;
    procedure SetCyclic(const Value: boolean); override;
    // This procedure MUST be called by the descendent of TgxRandomArchipelago
    procedure SetSize(const aSize: integer);
    function fSortLandscapes(Item1, Item2: Pointer): integer;
    // procedure PrepareLandTileData(HeightData:tHeightData; LandTile:tLandTile);
    (* tTerrainRender event handler *)
    procedure SetTerrainRenderer(const Value: TgxTerrainRenderer); override;
  public
    procedure ApplyLighting(var aLandTile: TLandTile);
    procedure ApplyTexture(var aLandTile: TLandTile);
    procedure ApplyTopography(var aLandTile: TLandTile);
    procedure CameraPosition(var TileX, TileZ: integer);
    procedure CleanUp;
    (* Constrain x,y to be in the boundaries of the height field array. This is
      done in two way depending on the kind of landscape:
      Cyclic landscapes: 		mod
      Non-cyclic landscape:	clamp *)
    procedure ConstrainCoordinates(var x, z: single); overload;
    procedure ConstrainCoordinates(var x, z: integer); overload;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    // Compute the landtile containing (x,z)
    procedure FindLandTile(const x, z: single; var TileX, TileZ: integer);
    // Build the first landtile and position the camera. Must be called first.
    procedure Initialize(const aX, aZ: single); virtual;
    (* User-supplied function determining if this landtile will be built by the
      OnCreateDefaultTile or if a landscape will be generated. *)
    property IsDefaultTile: TIsDefaultTile read FIsDefaultTile
      write SetIsDefaultTile;
    // Number of landtile in memory
    function LandtileCount: integer;
    // Size of a landtile. Must be a power of two
    property LandTileSize: integer read fLandTileSize;
    // User-specified event handler containing the particular code for tile generation
    property OnCreateLandTile: TOnCreateLandTile read fOnCreateLandTile
      write SetOnCreateLandTile;
    (* When long computations are running, this property contains the operation
      beeing processed. *)
    property Task: string read GetTask;
    // A value between 0 and 100 indicating the percentage of completion
    property TaskProgress: integer read GetTaskProgress;
    // Distance between two landtiles
    function TileDistance(const x1, z1, x2, z2: integer): single;
    (* Square of distance between two landtiles. Use this function to compare
      two distances. *)
    function TileDistanceSquared(const x1, z1, x2, z2: integer): integer;
    (* This procedure check which landtiles must be generated or destroyed as a
      function of camera position. This is let to the descendent classes. *)
    procedure Update;
    property MapUpdating: boolean read FMapUpdating;
    // Use these boundaries with non-cyclic landscapes to constrain camera movements.
    function XMoveBoundary: single;
    function ZMoveBoundary: single;
    procedure StartPreparingData(HeightData: TgxHeightData); override;
  published
    property Camera: TgxCamera read FCamera write SetCamera;
    property Cyclic: boolean read FCyclic write SetCyclic;
    (* Dimensions of the "infinite" landscape. Can be set very high. These parameters
      have neither memory nor speed consequence. They are mainly used to compute
      a unique seed for each landtile *)
    property ExtentX: integer read FExtentX write SetExtentX;
    property ExtentZ: integer read FExtentZ write SetExtentZ;
    (* Distance at which a new landtile begin to be built. Increasing this value
      allows for a higher camera speed but it will also increase the memory requirements. *)
    property GenerationRadius: integer read FGenerationRadius
      write SetGenerationRadius;
    // Number of landtile to keep in memory. Should not be modified.
    property LandTileCapacity: integer read FLandTileCapacity
      write SetLandTileCapacity;
    // Probability that a given landtile is non-default
    property LandTileDensity: single read FLandTileDensity
      write SetLandTileDensity;
    // Base seed for the entire archipelago
    property Seed: integer read FSeed write SetSeed;
    // Terrain renderer linked to the HDS. Must be set just after creation.
    property TerrainRenderer: TgxTerrainRenderer read FTerrainRenderer
      write SetTerrainRenderer;
  end;

  TgxFractalArchipelago = class(TgxTiledRndLandscape)
  private
    FDepth: integer;
    FRoughnessMax: single;
    FRoughnessMin: single;
    FAmplitudeMin: integer;
    FAmplitudeMax: integer;
    FSeaDynamic: boolean;
    FSeaMaterialName: string;
    FWaveAmplitude: single;
    FWaveSpeed: single;
    function GetIslandDensity: single;
    (* PostRender event handler drawing a static water plane between islands
      Code borrowed from Eric's Archipelago GLScene advanced demo *)
    procedure FPostRenderSeaStatic(var rci: TgxRenderContextInfo; var HeightDatas: TList);
    (* Sea with waves.
      Borrowed from Eric's Archipelago GLScene advanced demo *)
    procedure FPostRenderSeaDynamic(var rci: TgxRenderContextInfo; var HeightDatas: TList);
    procedure SetIslandDensity(const Value: single);
    procedure SetDepth(const Value: integer);
    procedure SetRoughnessMax(const Value: single);
    procedure SetRoughnessMin(const Value: single);
    procedure SetAmplitudeMax(const Value: integer);
    procedure SetAmplitudeMin(const Value: integer);
    procedure SetSeaDynamic(const Value: boolean);
    procedure SetSeaMaterialName(const Value: string);
    procedure SetWaveAmplitude(const Value: single);
    procedure SetWaveSpeed(const Value: single);
  protected
    procedure SetTerrainRenderer(const Value: TgxTerrainRenderer); override;
    procedure fOnCreateLandTile(aX, aZ, aSeed: integer; var aLandscape: TLandTile);
    procedure fOnCreateDefaultTile(heightData: TgxHeightData);
  public
    procedure ComputeLandTile(const aX, aZ: integer; var NewLandTile: TLandTile); override;
    constructor Create(AOwner: TComponent); override;
  published
    // Ranges for the amplitude parameter in the fractal algorithm
    property AmplitudeMax: integer read FAmplitudeMax write SetAmplitudeMax;
    property AmplitudeMin: integer read FAmplitudeMin write SetAmplitudeMin;
    // Depth of the fractal algorithm
    property Depth: integer read fDepth write SetDepth;
    (* A wrapper for LandtileDensity. This is the probabilty for a landtile to
      contain an island. *)
    property IslandDensity: single read GetIslandDensity write SetIslandDensity;
    // Ranges for the roughness parameter in the fractal algorithm
    property RoughnessMax: single read FRoughnessMax write SetRoughnessMax;
    property RoughnessMin: single read FRoughnessMin write SetRoughnessMin;
    // If true, the sea will show dynamic waves. Slow.
    property SeaDynamic: boolean read FSeaDynamic write SetSeaDynamic;
    (* Reference to a material in the TerrainRenderer's material library. This
      material will be used to drape the water plane. *)
    property SeaMaterialName: string read FSeaMaterialName write SetSeaMaterialName;
    // Size of the waves
    property WaveAmplitude: single read FWaveAmplitude write SetWaveAmplitude;
    property WaveSpeed: single read FWaveSpeed write SetWaveSpeed;
  end;

(* Texture functions *)
///function LoadJPGtexture(const JpgName: string): tBitmap;
function NoisyColor(const Color: TColor; const Noise: single = 0.05): TgxColorVector;
function TextureGreen(const x, y: integer): TgxColorVector;
function TextureBlue(const x, y: integer): TgxColorVector;
function TextureSand(const x, y: integer): TgxColorVector;
function TextureBrownSoil(const x, y: integer): TgxColorVector;
function TextureDarkGreen(const x, y: integer): TgxColorVector;
function TextureDarkGray(const x, y: integer): TgxColorVector;
function TextureWhite(const x, y: integer): TgxColorVector;

(* Random HDS functions *)
procedure FractalMiddlePointHDS(const aDepth, aSeed, aAmplitude: integer; const aRoughness: single; aCyclic: boolean;
  var z: TMapOfSingle; var MinZ, MaxZ: single);
procedure InitializeRandomGenerator(const Seed: integer);

(* Landscape primers *)
procedure PrimerNull(var z: TMapOfSingle);
procedure PrimerIsland(LowZ, HighZ: single; var z: TMapOfSingle);

const
  VerticalScalingFactor = 128;

implementation //-------------------------------------------------------------

const // Neighbourhood vectors and weight
  NeighX: array [0 .. 8] of integer = (-1, 0, 1, 1, 1, 0, -1, -1, 0);
  NeighY: array [0 .. 8] of integer = (-1, -1, -1, 0, 1, 1, 1, 0, 0);
  NeighW: array [0 .. 8] of single = (1 / 1.4142, 1, 1 / 1.4142, 1, 1 / 1.4142, 1, 1 / 1.4142, 1, 2);
  SumWeights = 4 / 1.4142 + 4 + 2;
  Empty: single = -999;
  VSF = VerticalScalingFactor;

var
  rhdsStartTime: cardinal;
  rhdsLandscapeCounter: cardinal = 0;
  //Counter	:tTickCounter;

(*
function LoadJPGtexture(const JpgName: string): TBitmap;
var
  Jpg: TJPEGImage;
begin
  Result := tBitmap.Create;
  Jpg := TJPEGImage.Create;
  Jpg.LoadFromFile(JpgName);
  Result.Assign(Jpg);
  Jpg.Free;
end;
*)

function NoisyColor(const Color: TColor; const Noise: single = 0.05): TgxColorVector;
var
  r: single;
begin
  Result := ConvertWinColor(Color);
  r := random * Noise;
  AddVector(Result, r);
end;

function TextureSand(const x, y: integer): TgxColorVector;
begin
  Result := NoisyColor($0071D8FF);
end;

function TextureBrownSoil(const x, y: integer): TgxColorVector;
begin
  Result := NoisyColor($00008BBF);
end;

function TextureDarkGreen(const x, y: integer): TgxColorVector;
begin
  Result := NoisyColor($00004000);
end;

function TextureDarkGray(const x, y: integer): TgxColorVector;
begin
  Result := NoisyColor(claDarkGray);
end;

function TextureWhite(const x, y: integer): TgxColorVector;
begin
  Result := NoisyColor(claWhite);
end;

function TextureBlue(const x, y: integer): TgxColorVector;
begin
  Result := NoisyColor(claBlue);
end;

function TextureGreen(const x, y: integer): TgxColorVector;
begin
  Result := NoisyColor(claGreen);
end;

procedure InitializeRandomGenerator(const Seed: integer);
var
  i: integer;
begin
  RandSeed := Seed;
  for i := 1 to 50 do
    random; // Pre-heat the generator
end;

//
// TgxBaseRandomHDS
//
constructor TgxBaseRandomHDS.Create(AOwner: TComponent);
begin
  inherited;
  Inc(rhdsLandscapeCounter);
  Name := Format('RandomLandscape%d', [rhdsLandscapeCounter]);
  FLightColor := VectorMake(1, 1, 1);
  FLightDirection := VectorMake(-1, 0, -1);
  FAmbientLight := 0.5;
  FTextureScale := 1;
  FMaterialName := '';
  FLighting := True;
  FLightSmoothing := True;
  Cyclic := True;
  FSeed := RandSeed;
  FSeaLevel := 0.0;
  FErosionBySea.BeachHeight := 0.01;
  FErosionBySea.Enabled := False;
  FErosionByRain.Enabled := True;
  FErosionByRain.ErosionRate := 0.5;
  FErosionByRain.DepositRate := FErosionByRain.ErosionRate;
  FErosionByLife.Enabled := True;
  FErosionByLife.Robustness := 1;
  FLandTileInfo.State := hdsNone;
end;

destructor TgxBaseRandomHDS.Destroy;
begin
  inherited;
end;

function TgxBaseRandomHDS.GetSeaLevel: single;
begin
  Result := FSeaLevel / VSF; // factor used in tTerrainRender
end;

function TgxBaseRandomHDS.GetSeaTransparency: single;
begin
  Result := FSeaTransparency / VSF; // factor used in tTerrainRender
end;

function TgxBaseRandomHDS.GetErosionByRain: TRainErosion;
begin
  Result := FErosionByRain;
end;

function TgxBaseRandomHDS.GetLandTileInfo: TLandTileInfo;
begin
  Result := FLandTileInfo;
end;

function TgxBaseRandomHDS.OnDrawTextureDefault(const Sender: TgxBaseRandomHDS; x, y: integer; z: double; Normal: TVector4f)
  : TgxColorVector;
begin
  if z > Sender.SeaLevel * VSF then
    Result := TextureGreen(x, y)
  else
    Result := TextureBlue(x, y);
end;

procedure TgxBaseRandomHDS.SetAmbientLight(const Value: single);
begin
  FAmbientLight := Value;
end;

procedure TgxBaseRandomHDS.SetErosionByFraction(const Value: TFractionErosion);
begin
  FErosionByFraction := Value;
end;

procedure TgxBaseRandomHDS.SetErosionByLife(const Value: TLifeErosion);
begin
  FErosionByLife := Value;
end;

procedure TgxBaseRandomHDS.SetErosionByRain(const Value: TRainErosion);
begin
  FErosionByRain := Value;
end;

procedure TgxBaseRandomHDS.SetErosionBySea(const Value: TSeaErosion);
begin
  FErosionBySea := Value;
end;

procedure TgxBaseRandomHDS.SetLandCover(const Value: boolean);
begin
  FLandCover := Value;
end;

procedure TgxBaseRandomHDS.SetLandTileInfo(const Value: TLandTileInfo);
begin
  FLandTileInfo := Value;
end;

procedure TgxBaseRandomHDS.SetLightColor(const Value: TgxColorVector);
begin
  FLightColor := Value;
end;

procedure TgxBaseRandomHDS.SetLightDirection(const Value: TVector4f);
var
  v: TVector4f;
begin
  v := Value;
  NormalizeVector(v);
  FLightDirection := Value;
end;

procedure TgxBaseRandomHDS.SetLighting(const Value: boolean);
begin
  FLighting := Value;
end;

procedure TgxBaseRandomHDS.SetLightSmoothing(const Value: boolean);
begin
  FLightSmoothing := Value;
end;

procedure TgxBaseRandomHDS.SetMaterialName(const Value: string);
begin
  FMaterialName := Value;
end;

procedure TgxBaseRandomHDS.SetOnDrawTexture(const Value: TOnDrawTexture);
begin
  if @Value <> nil then
    FOnDrawTexture := Value
  else
    FOnDrawTexture := OnDrawTextureDefault; // Basic texture event
end;

procedure TgxBaseRandomHDS.SetPrimerLandscape(const Value: boolean);
begin
  FPrimerLandscape := Value;
end;

procedure TgxBaseRandomHDS.SetSea(const Value: boolean);
begin
  FSea := Value;
end;

procedure TgxBaseRandomHDS.SetSeaLevel(const Value: single);
begin
  FSeaLevel := Value * VSF; // factor used in tTerrainRender
end;

procedure TgxBaseRandomHDS.SetSeaTransparency(const Value: single);
begin
  FSeaTransparency := Value * VSF; // factor used in tTerrainRender
end;

procedure TgxBaseRandomHDS.SetSeed(const Value: integer);
begin
  FSeed := Value;
end;

procedure TgxBaseRandomHDS.SetShadows(const Value: boolean);
begin
  FShadows := Value;
end;

procedure TgxBaseRandomHDS.SetSteps(const Value: TSteps);
begin
  FSteps := Value;
end;

procedure TgxBaseRandomHDS.SetTextureScale(const Value: integer);
begin
  FTextureScale := Value;
end;

//
// TgxCustomRandomHDS
//
procedure TgxCustomRandomHDS.BoundaryClamp(var x, y: single);
begin
  ClampValue(x, 0, FSize);
  ClampValue(y, 0, FSize);
end;

procedure TgxCustomRandomHDS.BoundaryClamp(var x, y: integer);
begin
  if x < 0 then
    x := 0
  else if x > FSize then
    x := FSize;
  if y < 0 then
    y := 0
  else if y > FSize then
    y := FSize;
end;

function TgxCustomRandomHDS.BoundaryX: integer;
begin
  Result := Round(FSize * Scale.x);
end;

function TgxCustomRandomHDS.BoundaryZ: integer;
begin
  Result := Round(FSize * Scale.z);
end;

procedure TgxCustomRandomHDS.BuildLandscape;
begin
  FTask := 'Landscape generation';
  FTaskProgress := 0;

  { Empty all height-field cells }
  if not FPrimerLandscape then
    ClearHeightField;

  { Build the basic fractal height field. It is mandatory and must always be
    called first. }
  BuildHeightField;

  { Various operations that reshape the height field. These procedures may be
    called in any order, although the one proposed here is the most natural.
    These procedures are optional }
  if FErosionByRain.Enabled then
    DoErosionByRain;
  if FErosionByLife.Enabled then
    DoErosionByLife;
  if FErosionBySea.Enabled then
    DoErosionBySea;
  if FSteps.Enabled then
    DoSteps;

  { Doing sea first would speeds up the following processes
    but the result would be slightly less realistic. In
    particular with transparency, you can have a nice effect
    of submarine valleys prolungating land canyons.
    This procedure is optional }
  if FSea then
    DoSea;

  if FCyclic then
    DoCyclicBoundaries; // Ensures a seamless fit

  { Compute a normal for each vertex. Used by BuildLightMap and BuildTexture }
  if FLandCover then
    BuildNormals;

  { Add light effects. Either BuildLightMap or ClearLigthMap must be called.
    Used by BuildTexture. }
  if FLighting and LandCover then
    BuildLightMap
  else
    ClearLightMap;

  { Builds the actual texture. If it is not used, the terrain will be textured
    with its Material, if defined. }
  if FLandCover then
    BuildTexture;

  { Free memory. If you need often to recompute texture, you may want to keep
    one or both maps, providing the heightfield or the light source have not changed. }
  if not FKeepNormals then
    FNormal := nil;
  FLightMap := nil;

  FTask := ' Updating terrain renderer';
  FTaskProgress := 0;
  Application.ProcessMessages;

  MarkDirty;
  // Tells the HDS that changes have been made (don't forget it or you'll get strange things)
end;

procedure TgxCustomRandomHDS.BuildLightMap;
var
  i, j, k, m, n: integer;
  x, y: single;
  t: single;
  v1, v2: TVector4f;
  l: TVector4f;
  Shade: single;
begin
  if FSize = 0 then
    exit;
  FTask := 'Light-map computation';
  FTaskProgress := 0;
  SetLength(FLightMap, (FSize + 1) * TextureScale, (FSize + 1) * TextureScale);
  l := FLightDirection;
  NormalizeVector(l);
  NegateVector(l);

  { Compute lighting }
  for i := 0 to FSize do
  begin
    FTaskProgress := Round(i / FSize * 100);
    for j := 0 to FSize do
    begin
      Application.ProcessMessages;
      Shade := abs(VectorDotProduct(FNormal[i, j], l));
      ClampValue(Shade, 0);
      for k := i * TextureScale to (i + 1) * TextureScale - 1 do
        for n := j * TextureScale to (j + 1) * TextureScale - 1 do
          FLightMap[k, n] := Shade;
    end; // for
  end; // for i

  { Shadows }
  if FShadows then
  begin
    FTask := 'Shadow casting';
    FTaskProgress := 0;
    l.x := l.x * Scale.x;
    l.y := l.y * VSF / Scale.y;
    l.z := l.z * Scale.z;
    for j := 0 to FSize do
    begin
      FTaskProgress := Round(j / FSize * 100);
      for i := 0 to FSize do
      begin
        if FLightMap[i * TextureScale, j * TextureScale] > 0 then
        begin // Don't look for shadow if the point is already shadowed
          v1 := VectorMake(i, FHeight[i, j], j); // Starting point
          for k := 2 to Round(FSize * 1.4) do
          begin // Quick and dirty ray-casting
            v2 := VectorCombine(v1, l, 1, k);
            // Casts a ray in direction of the sun
            x := Round(v2.x);
            y := Round(v2.z);
            if Interpolate(x, y) > v2.y then
            begin
              Application.ProcessMessages;
              for m := i * TextureScale to (i + 1) * TextureScale - 1 do
                for n := j * TextureScale to (j + 1) * TextureScale - 1 do
                  FLightMap[m, n] := 0;
              break; // Shadow caster found. No need to continue
            end; // if
          end; // for k
        end; // if
      end; // for j
    end; // for i
  end; // if

  { Smoothing }
  if FLightSmoothing then
  begin
    FTask := 'Light-map smoothing';
    FTaskProgress := 0;
    for m := 1 to TextureScale - 1 do
    begin
      FTaskProgress := Round(m / TextureScale * 100);
      for j := 1 to High(FLightMap) - 1 do
      begin
        for i := 1 to High(FLightMap) - 1 do
        begin
          Application.ProcessMessages;
          t := 0;
          for k := 0 to 8 do
          begin
            t := t + FLightMap[i + NeighX[k], j + NeighY[k]] * NeighW[k];
          end; // for k
          FLightMap[i, j] := t / SumWeights;
        end; // for j
      end; // for i
    end; // for m
  end; // if
end;

procedure TgxCustomRandomHDS.BuildLightMap(const aLightDirection: TVector4f);
begin
  FLightDirection := aLightDirection;
  BuildLightMap;
end;

procedure TgxCustomRandomHDS.BuildNormals;
var
  i, j: integer;
  z0: single;
  v1, v2: TVector4f;
  n1: TVector4f;
  Normal: TVector4f;
begin
  FTask := 'Normal computation';

  for i := 0 to FSize do
  begin
    FTaskProgress := Round(i / FSize * 100);
    for j := 0 to FSize do
    begin
      Application.ProcessMessages;
      z0 := FHeight[i, j];
      Normal := NullHmgVector;
      MakeVector(v1, Scale.x, (Heights[i + 1, j] - z0) * Scale.y / VSF, 0);
      MakeVector(v2, 0, (Heights[i, j + 1] - z0) * Scale.y / VSF, Scale.z);
      Normal := VectorCrossProduct(v2, v1);
      NormalizeVector(Normal);
      MakeVector(v1, -Scale.x, (Heights[i - 1, j] - z0) * Scale.y / VSF, 0);
      MakeVector(v2, 0, (Heights[i, j + 1] - z0) * Scale.y / VSF, Scale.z);
      n1 := VectorCrossProduct(v1, v2);
      NormalizeVector(n1);
      Normal := VectorAdd(Normal, n1);
      MakeVector(v1, -Scale.x, (Heights[i - 1, j] - z0) * Scale.y / VSF, 0);
      MakeVector(v2, 0, (Heights[i, j - 1] - z0) * Scale.y / VSF, -Scale.z);
      n1 := VectorCrossProduct(v2, v1);
      NormalizeVector(n1);
      Normal := VectorAdd(Normal, n1);
      MakeVector(v1, Scale.x, (Heights[i + 1, j] - z0) * Scale.y / VSF, 0);
      MakeVector(v2, 0, (Heights[i, j - 1] - z0) * Scale.y / VSF, -Scale.z);
      n1 := VectorCrossProduct(v1, v2);
      NormalizeVector(n1);
      Normal := VectorAdd(Normal, n1);
      FNormal[i, j] := VectorScale(Normal, 0.25);
      // Average of the 4 adjacent normals
    end; // for j
  end; // for i
end;

procedure TgxCustomRandomHDS.BuildTexture;
type
  pRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array [word] of TRGBTriple;

var
  Bmp: array of array of tBitmap;
  x0, y0: integer;
  xx, yy: integer;
  x, y: integer;
  nbTiles: integer;
  Side: integer;
  meancol: tColor;
  Line: pRGBTripleArray;

  function MeanColor(color1, color2: tColor): tColor;
  var
    r1, g1, b1: Byte;
    r2, g2, b2: Byte;
  begin
    r1 := (color1 and $000000FF);
    g1 := ((color1 and $0000FF00) shr 8);
    b1 := ((color1 and $00FF0000) shr 16);
    r2 := (color2 and $000000FF);
    g2 := ((color2 and $0000FF00) shr 8);
    b2 := ((color2 and $00FF0000) shr 16);
    Result := RGB((r1 + r2) div 2, (g1 + g2) div 2, (b1 + b2) div 2);
  end;

  procedure MakeRGBTriple(const Color: TgxColorVector; var RGBTriple: TRGBTriple);
  begin
    with RGBTriple do
    begin
      rgbtRed := Round(Color.x * 255);
      rgbtGreen := Round(Color.y * 255);
      rgbtBlue := Round(Color.z * 255);
    end; // with
  end;

  function ComputePixel(const x, y: integer): TRGBTriple;
  var
    i, j: integer;
    Shade: TgxColorVector;
    Cover: TgxColorVector;
    z: double;
  begin
    i := (x0 + x) div TextureScale;
    j := (y0 + y) div TextureScale;
    z := Interpolate((x0 + x) / TextureScale, (y0 + y) / TextureScale);
    Application.ProcessMessages;
    { Cover:=OnDrawTexture(Self,FLandTileInfo.x*fSize+x0+x,
      FLandTileInfo.z*fSize+y0+y,z,fNormal[i,j]); }
    Cover := OnDrawTexture(Self, x0 + x, y0 + y, z, FNormal[i, j]);
    Application.ProcessMessages;
    Shade := VectorScale(FLightColor, FLightMap[x0 + x, y0 + y]);
    Application.ProcessMessages;
    ScaleVector(Shade, Cover);
    Application.ProcessMessages;
    AddVector(Shade, VectorScale(Cover, FAmbientLight));
    Application.ProcessMessages;
    if Shade.x > 1 then
      Shade.x := 1;
    if Shade.y > 1 then
      Shade.y := 1;
    if Shade.z > 1 then
      Shade.z := 1;
    // if x=Side-1 then begin Shade[0]:=1; Shade[1]:=0; Shade[2]:=0; end;
    MakeRGBTriple(Shade, Result);
  end;

begin
  nbTiles := FSize div FTerrainRenderer.TileSize;
  SetLength(Bmp, nbTiles, nbTiles);
  Side := FTerrainRenderer.TileSize * TextureScale;
  FTask := 'Texture creation';
  FTaskProgress := 0;

  // Draw bitmap
  try
    for yy := 0 to (nbTiles) - 1 do
    begin
      FTaskProgress := Round(yy / nbTiles * 100);
      Application.ProcessMessages;
      y0 := yy * Side;
      for xx := 0 to (nbTiles) - 1 do
      begin
        x0 := xx * Side;
        Bmp[xx, yy] := TBitmap.Create;
        with Bmp[xx, yy] do
        begin
          //Cannot assign to a read-only property
          //PixelFormat := pf24bit;   //in VCL
          Width := Side;
          Height := Side;
          for y := 0 to Side - 1 do
          begin
            //Line := ScanLine[y];    // in VCL
            for x := 0 to Side - 1 do
            begin
              Line[x] := ComputePixel(x, y);
            end; // for x
          end; // for y
        end; // with
      end; // for xx
    end; // for yy

    // Smoothes tile seams
    for yy := 0 to nbTiles - 2 do
    begin
      for xx := 0 to nbTiles - 2 do
      begin
        for x := 0 to Side - 1 do
        begin
        { the next code is working in VCL
          MeanCol := MeanColor(Bmp[xx, yy].Canvas.Pixels[Side - 1, x], Bmp[xx + 1, yy].Canvas.Pixels[0, x]);

          Bmp[xx, yy].Canvas.Pixels[Side - 1, x] := Meancol;
          Bmp[xx + 1, yy].Canvas.Pixels[0, x] := Meancol;
          meancol := MeanColor(Bmp[xx, yy].Canvas.Pixels[x, Side - 1], Bmp[xx, yy + 1].Canvas.Pixels[x, 0]);

          Bmp[xx, yy].Canvas.Pixels[x, Side - 1] := Meancol;
          Bmp[xx, yy + 1].Canvas.Pixels[x, 0] := Meancol;
         }
        end; // for x
      end; // for xx
    end; // for yy

    // Upload into material library
    for yy := 0 to nbTiles - 1 do
    begin
      for xx := 0 to nbTiles - 1 do
      begin
        with FTerrainRenderer.MaterialLibrary.AddTextureMaterial(Format('%s%d%d', [Self.Name, xx, yy]), Bmp[xx, yy]) do
        begin
          // Material.Texture.MinFilter:=miNearest;
          Material.Texture.TextureWrap := twNone;
          Material.MaterialOptions := [moNoLighting];
          // Needed for correct look when lighting is enabled
        end; // with
        // Bmp[xx,yy].SaveToFile(Format('%s%d%d.bmp',[Self.Name,xx,yy]));
      end; // for xx
    end; // for yy
  finally
    for yy := 0 to nbTiles - 2 do
    begin
      for xx := 0 to nbTiles - 2 do
      begin
        Bmp[xx, yy].Free;
      end; // for xx
    end; // for yy
    Bmp := nil;
  end; // finally
end; // *)

(* procedure TgxCustomRandomHDS.BuildTexture2;
var
  Bmp	:tBitmap;
  Mat	:TgxLibMaterial;
  x,y	:integer;
  i,j	:integer;
  Shade	:TgxColorVector;
  Cover	:TgxColorVector;
  z		:double;
  begin
    if not fTextureCreated then CreateTexture;
    Mat:=FTerrainRenderer.MaterialLibrary.LibMaterialByName(MaterialName);
    Bmp:=TBitmap.Create;
    fTask:='Texture creation';
    fTaskProgress:=0;

  {Draw bitmap}
  try
  with Bmp do begin
  PixelFormat:=pf24bit;
  Width:=fSize*TextureScale;
  Height:=fSize*TextureScale;
  with Canvas do begin
  for y:=0 to fSize*TextureScale-1 do begin
  fTaskProgress:=Round(y/(fSize*TextureScale)*100);
  Application.ProcessMessages;
  for x:=0 to fSize*TextureScale-1 do begin
  i:=x div TextureScale;
  j:=y div TextureScale;
  z:=Interpolate(x/TextureScale,y/TextureScale);
  Cover:=OnDrawTexture(Self,x,y,z,fNormal[i,j]);
  Shade:=VectorScale(fLightColor.Color,fLightMap[x,y]);
  ScaleVector(Shade,Cover);
  AddVector(Shade,VectorScale(Cover,fAmbientLight));

  if Shade[0]>1 then Shade[0]:=1;
  if Shade[1]>1 then Shade[1]:=1;
  if Shade[2]>1 then Shade[2]:=1;
  Pixels[x,y]:=ConvertColorVector(Shade);
  end;//for x
  end;//for y
  end;//with
  end;//with
  //Bmp.SaveToFile('test.bmp');

  {Use it as texture}
  with Mat.Material.Texture do
  begin
    Image.Assign(Bmp);
    Image.NotifyChange(Self);
    Enabled:=true;
    //MagFilter:=maNearest;
    //MinFilter:=miNearest;
  end;//with }
  Mat.NotifyUsersOfTexMapChange;
  finally
    Bmp.Free;
  end;//finally
end;// *)

procedure TgxCustomRandomHDS.ClearHeightField;
begin
  PrimerNull(FHeight);
end;

procedure TgxCustomRandomHDS.ClearLightMap;
var
  x, y: integer;
begin
  SetLength(FLightMap, (FSize + 1) * TextureScale, (FSize + 1) * TextureScale);
  for y := 0 to High(FLightMap) do
  begin
    for x := 0 to High(FLightMap) do
    begin
      FLightMap[x, y] := 1;
    end; // for
  end; // for
end;

procedure TgxCustomRandomHDS.ConstrainCoordinates(var x, y: integer);
begin
  FIntegerConstrain(x, y);
end;

procedure TgxCustomRandomHDS.ConstrainCoordinates(var x, y: single);
begin
  FSingleConstrain(x, y);
end;

constructor TgxCustomRandomHDS.Create(AOwner: TComponent);
begin
  inherited;
  FLandCover := True;
  FOnDrawTexture := OnDrawTextureDefault;
end;

procedure TgxCustomRandomHDS.CyclicClamp(var x, y: single);
var
  ix, iy: integer;
  sx, sy: single;
begin
  ix := Trunc(x);
  sx := Frac(x);
  iy := Trunc(y);
  sy := Frac(y);
  x := (FSize + ix) mod FSize + sx;
  y := (FSize + iy) mod FSize + sy;
end;

procedure TgxCustomRandomHDS.CyclicClamp(var x, y: integer);
begin
  x := (FSize + x) mod FSize;
  y := (FSize + y) mod FSize;
end;

destructor TgxCustomRandomHDS.Destroy;
var
  x, y: integer;
  Mat: TgxLibMaterial;
begin
  FLandTileInfo.State := hdsNone;
  FHeight := nil;
  FLightMap := nil;
  FNormal := nil;
  try
    for y := 0 to (FSize div FTerrainRenderer.TileSize) - 1 do
    begin
      for x := 0 to (FSize div FTerrainRenderer.TileSize) - 1 do
      begin
        Mat := FTerrainRenderer.MaterialLibrary.LibMaterialByName(Format('%s%d%d', [Self.Name, x, y]));
        if Mat <> nil then
          Mat.Material.DestroyHandles;
      end; // for x
    end; // for y
  except
  end;
  if (FSlave) and (Owner <> nil) then
    with LandTileInfo do
      TgxTiledRndLandscape(Owner).MarkDirty(x * FSize, z * FSize, (x + 1) * FSize - 1, (z + 1) * FSize - 1);
  inherited;
end;

procedure TgxCustomRandomHDS.DoCyclicBoundaries;
var
  i: integer;
begin
  for i := 0 to FSize do
  begin
    FHeight[i, FSize] := FHeight[i, 0];
    FHeight[FSize, i] := FHeight[0, i];
  end; // for
end;

procedure TgxCustomRandomHDS.DoErosionByFraction;
begin

end;

procedure TgxCustomRandomHDS.DoErosionByLife;
var
  x, y, i: integer;
  z, z1: single;
begin
  { Smoothing by a 3-by-3 mean filter }
  FTask := 'Erosion by life';
  FTaskProgress := 0;
  for y := 0 to FSize do
  begin
    FTaskProgress := Round(y / (FSize) * 100);
    for x := 0 to FSize do
    begin
      Application.ProcessMessages;
      z := FHeight[x, y] * FErosionByLife.Robustness;
      z1 := FErosionByLife.Robustness;
      for i := 0 to 7 do
      begin
        z := z + Heights[x + NeighX[i], y + NeighY[i]] * NeighW[i];
        z1 := z1 + NeighW[i];
      end; // for i
      FHeight[x, y] := z / z1;
    end; // for x
  end; // for y
end;

procedure TgxCustomRandomHDS.DoErosionByRain;
{ Drop some rain on every cell of the landscape and let it run downward, taking soil
  on its way. When it arrives into a pool, let it deposit all that has been eroded. }
const
  Ks = 0.001; // Soil solubility
var
  j: integer;
  x0, y0: integer;
  x, y: integer;
  x1, y1: integer;
  minx, miny: integer;
  z, z1: single;
  MinZ: single;
  dz, mindz: single;
  Charge: double;
  From, Next: integer;
begin
  FTask := 'Rain erosion simulation';
  FTaskProgress := 0;
  minx := 0;
  miny := 0;
  MinZ := 0;
  Next := 0;

  { Rain }
  for y0 := 0 to FSize do
  begin
    FTaskProgress := Round(y0 / (FSize) * 100);
    for x0 := 0 to FSize do
    begin
      Application.ProcessMessages;
      x := x0;
      y := y0;
      z := StandardisedHeight(x, y);
      Charge := 0;
      From := -1;
      while (FHeight[x, y] > FSeaLevel) // Not in the sea
        do
      begin
        mindz := MaxInt;
        for j := 0 to 7 do
        begin // Look for the largest slope
          if j = From then
            continue; // Never go backward
          x1 := (FSize + x + NeighX[j]) mod FSize; // Cyclic landscape
          y1 := (FSize + y + NeighY[j]) mod FSize;
          z1 := StandardisedHeight(x1, y1);
          dz := (z1 - z) * NeighW[j];
          if dz < mindz then
          begin
            minx := x1;
            miny := y1;
            MinZ := z1;
            mindz := dz;
            Next := j;
          end; // if
        end; // for j
        if (StandardisedHeight(minx, miny) <= SeaLevel) then
          break; // In the sea or out of map
        if MinZ < z then
        begin
          FHeight[x, y] := FHeight[x, y] - FErosionByRain.ErosionRate * Ks * FRangeHeight; // Erosion
          x := minx;
          y := miny;
          z := MinZ;
          From := (Next + 4) mod 8; // Opposite direction
          Charge := Charge + 1;
        end // if
        else
        begin // Fallen into a pool? Deposit the charge
          FHeight[x, y] := FHeight[x, y] + MinFloat(MinZ - z, FErosionByRain.DepositRate * Ks * FRangeHeight * Charge);
          break; // Go to next rain drop
        end; // else
      end; // while
    end; // for x0
  end; // for y0
end; // *)

(*
  Variants:

  procedure TgxBaseRandomHDS.DoErosionByRain(const Intensity: single);
  const
  NeighX	:array[0..7] of integer=(-1, 0, 1, 1, 1, 0,-1,-1);
  NeighY	:array[0..7] of integer=(-1,-1,-1, 0, 1, 1, 1, 0);
  NeighW   :array[0..7] of single=(1/1.4142,1,1/1.4142,1,1/1.4142,1,1/1.4142,1);
  type
  tFlow=record
  NextX,NextY	:integer;
  Slope		:single;
  Erosion		:integer;
  end;
  var
  Flow		:array of array of tFlow;
  i,j,jj,swap	:integer;
  x0,y0		:integer;
  x,y		:integer;
  x1,y1		:integer;
  minx,miny	:integer;
  z,z1,minz	:single;
  Charge		:integer;
  N			:integer;
  From,Next	:integer;
  Sig		:integer;
  c			:double;
  OldSlope	:single;
  dz,mindz	:single;
  begin
  c:=1/VSF/sqrt(sqr(Scale.X)+sqr(Scale.Z));
  {Water flow map computation}
  SetLength(Flow,fSize+1,fSize+1);
  for y:=0 to fSize do begin
  for x:=0 to fSize do begin
  mindz:=MaxInt;
  Sig:=Sign(random*2-1);
  z:=fHeight[x,y];
  for jj:=0 to 7 do begin // Look for the largest slope
  j:=(8+Sig*jj) mod 8;
  x1:=x+NeighX[j];
  y1:=y+NeighY[j];
  try z1:=Height[x1,y1];
  dz:=(z1-z)*NeighW[j];
  if dz+random*0.03*fRangeHeight<mindz then begin
  minx:=x1;
  miny:=y1;
  minz:=z1;
  mindz:=dz;
  Next:=j;
  end;//if
  except // Out of the map? Then go to next rain drop
  Flow[x,y].NextX:=-99;
  Break;
  end;
  with Flow[x,y] do begin
  Slope:=ArcTan((minz-z)*c);
  if Slope>0 then NextX:=-99
  else begin
  NextX:=minx;
  NextY:=miny;
  Erosion:=0;
  end;//if
  end;//with
  end;//for j
  end;//for
  end;//for
  From:=0;

  {Rain}
  for y0:=0 to fSize do begin
  for x0:=0 to fSize do begin
  x:=x0;
  y:=y0;
  OldSlope:=0;
  while (x<>-99)and(fCover[x,y]>0) do begin // Not in the sea
  with Flow[x,y] do begin
  if (Slope*2<OldSlope) then begin
  Dec(Erosion);
  x:=NextX;
  y:=NextY;
  OldSlope:=Slope;
  end//if
  else begin
  //Inc(Erosion);
  Break;
  end;//else
  end;//with
  end;//while
  end;//for x0
  end;//for y0

  {Apply erosion}
  for y:=0 to fSize do begin
  for x:=0 to fSize do begin
  //fHeight[x,y]:=fHeight[x,y]+Flow[x,y].Erosion*0.002*Intensity*fRangeHeight;
  fHeight[x,y]:=(Flow[x,y].Erosion)*100+50;
  end;//for
  end;//for

  Flow:=nil;
  end; // *)

(* procedure TgxBaseRandomHDS.DoErosionByRain(const Intensity: single);
  const
  NeighX:array[0..7] of integer=(-1, 0, 1, 1, 1, 0,-1,-1);
  NeighY:array[0..7] of integer=(-1,-1,-1, 0, 1, 1, 1, 0);
  var
  Erosion	:array of array of single;
  Flow		:array[0..7] of single;
  FlowSum	:single;
  j			:integer;
  x,y		:integer;
  x1,y1		:integer;
  z,z1		:single;
  c			:single;
  begin
  c:=1/VSF; // Vertical scale factor
  SetLength(Erosion,fSize+2,fSize+2);
  for y:=0 to fSize+1 do for x:=0 to fSize+1 do Erosion[x,y]:=0;

  {Erosion computation}
  for y:=0 to fSize+1 do begin
  for x:=0 to fSize+1 do begin
  z:=fHeight[x,y];
  FlowSum:=0;
  for j:=0 to 7 do begin // Flow to adjacent cells
  x1:=x+NeighX[j];
  y1:=y+NeighY[j];
  try
  z1:=Height[x1,y1]+random*0;
  if z1<z then begin
  Flow[j]:=ArcTan((z-z1)*c);
  FlowSum:=FlowSum+Flow[j];
  end//if
  else Flow[j]:=0;
  except
  Flow[j]:=0;
  end;//except
  end;//for j

  if FlowSum>0 then begin // Erosion and deposition
  Erosion[x,y]:=Erosion[x,y]-1; // Erosion
  for j:=0 to 7 do begin
  if Flow[j]>1e-3 then begin
  x1:=x+NeighX[j];
  y1:=y+NeighY[j];
  Erosion[x1,y1]:=Erosion[x1,y1]+Flow[j]/FlowSum; // Partial deposition
  end;//if
  end;//for
  end;//if

  end;//for x
  end;//for y

  {Apply erosion to each cell}
  for y:=0 to fSize do begin
  for x:=0 to fSize do begin
  fHeight[x,y]:=fHeight[x,y]+Erosion[x,y]*0.005*Intensity*fRangeHeight;
  //fHeight[x,y]:=(Erosion[x,y])*100+50;
  end;//for
  end;//for

  Erosion:=nil;
  end; // *)

(* procedure TgxBaseRandomHDS.DoErosionByRain(const Intensity: single);
  const
  NeighX:array[0..7] of integer=(-1, 0, 1, 1, 1, 0,-1,-1);
  NeighY:array[0..7] of integer=(-1,-1,-1, 0, 1, 1, 1, 0);
  var
  Erosion	:array of array of single;
  i,j,jj		:integer;
  x,y		:integer;
  x1,y1		:integer;
  x2,y2		:integer;
  z,z1,z2,dz	:single;
  begin
  SetLength(Erosion,fSize+2,fSize+2);

  for i:=1 to 1 do begin
  //for y:=0 to fSize+1 do for x:=0 to fSize+1 do Erosion[x,y]:=0;

  {Erosion computation}
  for y:=5 to fSize-4 do begin
  for x:=5 to fSize-4 do begin
  z:=fHeight[x,y];
  dz:=1;
  for jj:=1 to 2 do begin // Flow to adjacent cells
  j:=jj*2;
  x1:=x+NeighX[j]*5;
  y1:=y+NeighY[j]*5;
  x2:=x+NeighX[j+4]*5;
  y2:=y+NeighY[j+4]*5;
  try
  z1:=Height[x1,y1]+random*0;
  z2:=Height[x2,y2]+random*0;
  dz:=dz*Sign(z-(z1+z2)/2);
  except
  end;//except
  end;//for j
  Erosion[x,y]:=dz;
  end;//for x
  end;//for y

  {Apply erosion to each cell}
  for y:=0 to fSize do begin
  for x:=0 to fSize do begin
  fHeight[x,y]:=fHeight[x,y]+Erosion[x,y]*100*Intensity;
  //fHeight[x,y]:=(Erosion[x,y])*1+50;
  end;//for
  end;//for

  end;//for i

  Erosion:=nil;
  end; // *)

procedure TgxCustomRandomHDS.DoErosionBySea;
var
  i, j: integer;
begin
  for i := 0 to FSize do
  begin
    for j := 0 to FSize do
    begin
      Application.ProcessMessages;
      if abs(FHeight[i, j] - FSeaLevel) < FErosionBySea.BeachHeight * VSF then
      begin
        FHeight[i, j] := FSeaLevel + (FHeight[i, j] - FSeaLevel) * 0.3;
      end; // if
    end; // for
  end; // for
end;

procedure TgxCustomRandomHDS.DoSea;
var
  i, j: integer;
begin
  for i := 0 to FSize do
  begin
    for j := 0 to FSize do
    begin
      // if fHeight[i,j]<Lvl then fHeight[i,j]:=Lvl-random*wave;
      if FHeight[i, j] < FSeaLevel - FSeaTransparency then
        FHeight[i, j] := FSeaLevel - 1 // Lvl-c-random*wave
      else if FHeight[i, j] < FSeaLevel then
        FHeight[i, j] := FSeaLevel - (FSeaLevel - FHeight[i, j]) / FSeaTransparency;
    end; // for
  end; // for
end;

procedure TgxCustomRandomHDS.DoSteps;
var
  i, j: integer;
  Stp: single;
begin
  Stp := (FMaxHeight - FSeaLevel) / FSteps.Count; // Step height
  for i := 0 to FSize do
  begin
    for j := 0 to FSize do
    begin
      FHeight[i, j] := Round(FHeight[i, j] / Stp) * Stp;
    end; // for
  end; // for
end;

function TgxCustomRandomHDS.GetHeight(x, y: integer): single;
begin
  FIntegerConstrain(x, y);
  Result := FHeight[x, y];
end;

procedure TgxCustomRandomHDS.GetTerrainBounds(var l, t, r, b: single);
begin
  l := 0;
  b := 0;
  t := FSize;
  r := FSize;
end;

function TgxCustomRandomHDS.Interpolate(x, y: single): single;
{ Copied from GLHeightData.InterpolatedHeight }
var
  ix, iy: integer;
  h1, h2, h3: single;
begin
  ix := Trunc(x);
  x := Frac(x);
  iy := Trunc(y);
  y := Frac(y);
  if x > y then
  begin
    // top-right triangle
    h1 := Heights[ix + 1, iy];
    h2 := Heights[ix, iy];
    h3 := Heights[ix + 1, iy + 1];
    Result := h1 + (h2 - h1) * (1 - x) + (h3 - h1) * y;
  end
  else
  begin
    // bottom-left triangle
    h1 := Heights[ix, iy + 1];
    h2 := Heights[ix + 1, iy + 1];
    h3 := Heights[ix, iy];
    Result := h1 + (h2 - h1) * (x) + (h3 - h1) * (1 - y);
  end;
end;

function TgxCustomRandomHDS.PointInMap(const x, y: single): boolean;
begin
  Result := (x >= 0) and (x <= FSize) and (y >= 0) and (y <= FSize);
end;

function TgxCustomRandomHDS.Normal(const Position: TVector4f): TVector4f;
var
  x, y: integer;
begin
  if (FNormal <> nil) then
  begin
    Result := FTerrainRenderer.AbsoluteToLocal(Position);
    x := Round(Result.x);
    y := Round(Result.y);
    FIntegerConstrain(x, y);
    Result := FNormal[x, y];
  end // if
  else
    raise EAccessViolation.Create('No normal array computed.');
end;

function TgxCustomRandomHDS.PointInMap(const x, y: integer): boolean;
begin
  Result := (x >= 0) and (x <= FSize) and (y >= 0) and (y <= FSize);
end;

function TgxCustomRandomHDS.Scale: TgxCoordinates;
begin
  try
    Result := FTerrainRenderer.Scale;
  except
    raise EAccessViolation.Create('No TerrainRenderer defined');
  end;
end;

procedure TgxCustomRandomHDS.SetCyclic(const Value: boolean);
begin
  FCyclic := Value;
  if FCyclic then
  begin
    FIntegerConstrain := CyclicClamp;
    FSingleConstrain := CyclicClamp;
    if FTerrainRenderer <> nil then
      FTerrainRenderer.OnGetTerrainBounds := nil;
  end
  else
  begin
    FIntegerConstrain := BoundaryClamp;
    FSingleConstrain := BoundaryClamp;
    if FTerrainRenderer <> nil then
      FTerrainRenderer.OnGetTerrainBounds := GetTerrainBounds;
  end; // else
end;

procedure TgxCustomRandomHDS.SetHeight(x, y: integer; const Value: single);
begin
  FIntegerConstrain(x, y);
  FHeight[x, y] := Value;
end;

procedure TgxCustomRandomHDS.SetSize(const aSize: integer);
var
  Tile: integer;
begin
  FSize := aSize;
  if FSize > 32 then
    Tile := 32
  else
    Tile := Round(IntPower(2, Trunc(ln(FSize - 1) / ln(2))));
  SetLength(FHeight, FSize + 1, FSize + 1);
  SetLength(FNormal, FSize + 1, FSize + 1);
  MaxPoolSize := sqr(FSize) * SizeOf(smallint);
  if FTerrainRenderer <> nil then
  begin
    FTerrainRenderer.TileSize := Tile;
    FTerrainRenderer.TilesPerTexture := FSize div FTerrainRenderer.TileSize;
  end; // if
end;

procedure TgxCustomRandomHDS.SetTerrainRenderer(const Value: TgxTerrainRenderer);
begin
  FTerrainRenderer := Value;
  if not FSlave then
  begin
    FTerrainRenderer.OnGetTerrainBounds := GetTerrainBounds;
    FTerrainRenderer.HeightDataSource := Self;
  end; // if
end;

function TgxCustomRandomHDS.StandardisedHeight(const x, y: integer): single;
begin
  Result := (Heights[x, y] - FMinHeight) / FRangeHeight * 1000;
end;

procedure TgxCustomRandomHDS.StartPreparingData(heightData: TgxHeightData);
var
  x, y, x0, y0: integer;
  rasterLine: PSmallIntArray;
  oldType: TgxHeightDataType;
begin
  with heightData do
  begin
    DataState := hdsPreparing;
    oldType := DataType;
    Allocate(hdtSmallInt);

    if XLeft >= 0 then
      x0 := XLeft mod (FSize)
    else
      x0 := (FSize + (XLeft mod (FSize))) mod (FSize);
    if YTop >= 0 then
      y0 := YTop mod (FSize)
    else
      y0 := (FSize + (YTop mod (FSize))) mod (FSize);
    if FLandCover then
    begin
      MaterialName := Format('%s%d%d', [Self.Name, x0 div (heightData.Size - 1), y0 div (heightData.Size - 1)]);
      TextureCoordinatesMode := tcmLocal;
      TextureCoordinatesScale := TexPointMake((Self.FSize) / (heightData.Size - 1), (Self.FSize) / (heightData.Size - 1));
    end // if
    else
    begin
      MaterialName := Self.FMaterialName;
      TextureCoordinatesMode := tcmLocal;
      TextureCoordinatesScale := TexPointMake(FTextureScale, FTextureScale);
    end; // else
    for y := y0 to y0 + heightData.Size - 1 do
    begin
      rasterLine := smallintRaster[y - y0];
      for x := x0 to x0 + heightData.Size - 1 do
      begin
        rasterLine[x - x0] := Round(FHeight[x, y]);
      end; // for
    end; // for
    HeightMin := MinHeight;
    HeightMax := MaxHeight;

    DataState := hdsReady;
    if oldType <> hdtSmallInt then
      DataType := oldType;
  end; // with
  // inherited;
end; // *)

function TgxCustomRandomHDS.XMoveBoundary: single;
begin
  Result := FSize * Scale.x * 0.95;
end;

function TgxCustomRandomHDS.ZMoveBoundary: single;
begin
  Result := FSize * Scale.y * 0.95;
end;

procedure TgxCustomRandomHDS.SetKeepNormals(const Value: boolean);
begin
  FKeepNormals := Value;
end;

{ TgxFractalHDS }

procedure TgxFractalHDS.BuildHeightField(const aDepth, aSeed, aAmplitude: integer);
begin
  fDepth := aDepth;
  FSeed := aSeed;
  fAmplitude := aAmplitude;
  BuildHeightField;
end;

procedure TgxFractalHDS.BuildHeightField;
begin
  FractalMiddlePointHDS(fDepth, FSeed, fAmplitude, fRoughness, FCyclic, FHeight, FMinHeight, FMaxHeight);
  FRangeHeight := FMaxHeight - FMinHeight;
  Scale.x := 1;
  Scale.y := 1;
  Scale.z := FSize / VSF;
end;

constructor TgxFractalHDS.Create(AOwner: TComponent);
begin
  inherited;
  Depth := 4;
  FSea := True;
  Amplitude := 50;
  fRoughness := 0.4;
end;

procedure TgxFractalHDS.SetAmplitude(const Value: integer);
begin
  fAmplitude := Value;
  FMinHeight := -fAmplitude / 2 * VSF;
  FMaxHeight := -FMinHeight;
  FRangeHeight := fAmplitude * VSF;
end;

procedure TgxFractalHDS.SetDepth(const Value: integer);
begin
  fDepth := Value;
  SetSize(Round(IntPower(2, fDepth)));
end;

procedure TgxFractalHDS.SetRoughness(const Value: single);
begin
  fRoughness := Value;
end;

{ TgxRandomLandscape }

procedure TgxTiledRndLandscape.ApplyLighting(var aLandTile: TLandTile);
begin
  with aLandTile do
  begin
    Lighting := Self.FLighting;
    LightColor := Self.FLightColor;
    LightDirection := Self.FLightDirection;
    LightSmoothing := Self.FLightSmoothing;
    Shadows := Self.Shadows;
  end; // with
end;

procedure TgxTiledRndLandscape.ApplyTexture(var aLandTile: TLandTile);
begin
  with aLandTile do
  begin
    LandCover := Self.LandCover;
    MaterialName := Self.FMaterialName;
    TextureScale := Self.FTextureScale;
    if Assigned(Self.OnDrawTexture) then
      FOnDrawTexture := Self.OnDrawTexture;
  end; // with
end;

procedure TgxTiledRndLandscape.ApplyTopography(var aLandTile: TLandTile);
begin
  with aLandTile do
  begin
    ErosionByFraction := Self.FErosionByFraction;
    ErosionByLife := Self.FErosionByLife;
    ErosionByRain := Self.FErosionByRain;
    ErosionBySea := Self.FErosionBySea;
    FSea := Self.FSea;
    FSeaLevel := Self.FSeaLevel;
    FSeaTransparency := Self.FSeaTransparency;
  end; // with
end;

procedure TgxTiledRndLandscape.BoundaryClamp(var x, z: single);
begin
  ClampValue(x, 0, FExtentX * fLandTileSize);
  ClampValue(z, 0, FExtentZ * fLandTileSize);
end;

procedure TgxTiledRndLandscape.BoundaryClamp(var x, z: integer);
begin
  if x < 0 then
    x := 0
  else if x > FExtentX * fLandTileSize then
    x := FExtentX * fLandTileSize;
  if z < 0 then
    z := 0
  else if z > ExtentZ * fLandTileSize then
    z := FExtentZ * fLandTileSize;
end;

procedure TgxTiledRndLandscape.CameraPosition(var TileX, TileZ: integer);
begin
  FindLandTile(-Camera.Position.x, Camera.Position.z, TileX, TileZ);
end;

procedure TgxTiledRndLandscape.CleanUp;
var
  i: integer;
begin
  for i := fLandTiles.Count - 1 downto 0 do
  begin
    if TLandTile(fLandTiles.Items[i]).LandTileInfo.State = hdsNone then
    begin
      fLandTiles.Delete(i); // Free the landtile and remove it from the list
      // FTerrainRenderer.MaterialLibrary.Materials.DeleteUnusedMaterials;
    end; // if
  end; // for
end;

procedure TgxTiledRndLandscape.ComputeLandTile(const aX, aZ: integer; var NewLandTile: TLandTile);
var
  sx, sz: string;
begin
  FLandTileComputing := True;

  FLandTileInfo.x := aX;
  FLandTileInfo.z := aZ;
  FLandTileInfo.State := hdsPreparing;

  with NewLandTile do
  begin
    Cyclic := False;
    TerrainRenderer := Self.FTerrainRenderer;
    if aX >= 0 then
      sx := 'p'
    else
      sx := 'n';
    if aZ >= 0 then
      sz := 'p'
    else
      sz := 'n';
    Seed := LandTileSeed(aX, aZ);
    Name := Format('Land_%s%d%s%d_', [sx, abs(aX), sz, abs(aZ)]);
    // Generate a unique name
  end; // with
  fComputedLandTile := NewLandTile;
  OnCreateLandTile(aX, aZ, NewLandTile.Seed, NewLandTile);
  with NewLandTile.LandTileInfo do
    FLandTileInfo.State := hdsReady;
  MarkDirty(aX * fLandTileSize, aZ * fLandTileSize, (aX + 1) * fLandTileSize - 1, (aZ + 1) * fLandTileSize - 1);
  fComputedLandTile := nil;
  FLandTileComputing := False;
  fLandTiles.Add(NewLandTile);
  Application.ProcessMessages;
end;

procedure TgxTiledRndLandscape.ConstrainCoordinates(var x, z: single);
begin
  FSingleConstrain(x, z);
end;

procedure TgxTiledRndLandscape.ConstrainCoordinates(var x, z: integer);
begin
  FIntegerConstrain(x, z);
end;

constructor TgxTiledRndLandscape.Create(AOwner: TComponent);
begin
  inherited;
  fLandTiles := tComponentList.Create;
  IsDefaultTile := fDefaultIsDefaultTile;
  OnCreateDefaultTile := fDefaultOnCreateDefaultTile;
  FExtentX := 10000;
  FExtentZ := 10000;
  GenerationRadius := 2;
  FLandTileDensity := 1;
  FLandCover := True;
end;

procedure TgxTiledRndLandscape.CyclicClamp(var x, z: integer);
begin
  exit;
  x := (x + ExtentX) mod ExtentX;
  z := (z + ExtentZ) mod ExtentZ;
end;

procedure TgxTiledRndLandscape.CyclicClamp(var x, z: single);
var
  ix, iz: integer;
  sx, sz: single;
begin
  exit;
  ix := Trunc(ExtentX + x);
  sx := Frac(x);
  iz := Trunc(ExtentZ + z);
  sz := Frac(z);
  x := (ExtentX * fLandTileSize + ix) mod ExtentX * fLandTileSize + sx;
  z := (ExtentZ * fLandTileSize + iz) mod ExtentZ * fLandTileSize + sz;
end;

destructor TgxTiledRndLandscape.Destroy;
begin
  fLandTiles.Free;
  inherited;
end;

function TgxTiledRndLandscape.fDefaultIsDefaultTile(x, z: integer): boolean;
begin
  InitializeRandomGenerator(LandTileSeed(x, z));
  Result := (random >= FLandTileDensity);
end;

procedure TgxTiledRndLandscape.fDefaultOnCreateDefaultTile(heightData: TgxHeightData);
begin
  heightData.DataState := hdsNone;
  // raise EAccessViolation.Create('No DefaultStartPreparingDefaultTile procedure supplied.');
end;

procedure TgxTiledRndLandscape.FindLandTile(const x, z: single; var TileX, TileZ: integer);
begin
  TileX := Floor(x / fLandTileSize);
  TileZ := Floor(z / fLandTileSize);
  FIntegerConstrain(TileX, TileZ);
end;

function TgxTiledRndLandscape.fSortLandscapes(Item1, Item2: Pointer): integer;
{ Sort landtiles from the closest to the farthest }
var
  x, z: integer;
  d1, d2: single;
begin
  CameraPosition(x, z);
  d1 := sqr(x - TLandTile(Item1^).LandTileInfo.x) + sqr(z - TLandTile(Item1^).LandTileInfo.z);
  d2 := sqr(x - TLandTile(Item2^).LandTileInfo.x) + sqr(z - TLandTile(Item2^).LandTileInfo.z);
  Result := Round(d1 - d2);
end;

function TgxTiledRndLandscape.GetTask: string;
begin
  if fComputedLandTile <> nil then
    Result := fComputedLandTile.Task
  else
    Result := 'Idle';
end;

function TgxTiledRndLandscape.GetTaskProgress: integer;
begin
  if fComputedLandTile <> nil then
    Result := fComputedLandTile.TaskProgress
  else
    Result := 0;
end;

procedure TgxTiledRndLandscape.GetTerrainBounds(var l, t, r, b: single);
begin
  l := 0;
  b := 0;
  t := ExtentZ * LandTileSize;
  r := ExtentX * LandTileSize;
end;

procedure TgxTiledRndLandscape.Initialize(const aX, aZ: single);
var
  cx, cz: integer;
  NewLandTile: TLandTile;
  x, z, dx, dz: integer;
begin
  fOldCamX := -99999;
  fOldCamZ := -99999;
  with Camera.Position do
  begin
    x := aX;
    z := aZ;
  end; // with
  CameraPosition(cx, cz);
  ComputeLandTile(cx, cz, NewLandTile);
  TerrainRenderer.Scale := NewLandTile.Scale;
  with Camera.Position do
  begin
    x := x * NewLandTile.Scale.x;
    z := z * NewLandTile.Scale.z;
  end; // with

  for z := 0 to FGenerationRadius + 1 do
  begin
    for x := 1 to FGenerationRadius + 1 do
    begin
      if Trunc(sqrt(sqr(x) + sqr(z))) <= FGenerationRadius then
      begin
        dx := x;
        dz := z;
        if not IsDefaultTile(cx + dx, cz + dz) then
          ComputeLandTile(cx + dx, cz + dz, NewLandTile);
        dx := -z;
        dz := x;
        if not IsDefaultTile(cx + dx, cz + dz) then
          ComputeLandTile(cx + dx, cz + dz, NewLandTile);
        dx := -x;
        dz := -z;
        if not IsDefaultTile(cx + dx, cz + dz) then
          ComputeLandTile(cx + dx, cz + dz, NewLandTile);
        dx := z;
        dz := -x;
        if not IsDefaultTile(cx + dx, cz + dz) then
          ComputeLandTile(cx + dx, cz + dz, NewLandTile);
      end; // if
    end; // for
  end; // for
end;

function TgxTiledRndLandscape.LandTileSeed(x, z: integer): integer;
{ Generates a unique seed from the tile coordinates }
begin
  Result := fBaseSeed + z * ExtentX + x;
end;

function TgxTiledRndLandscape.LandtileCount: integer;
begin
  Result := fLandTiles.Count;
end;

{ procedure TgxTiledRndLandscape.PrepareLandTileData(HeightData: tHeightData;
  LandTile: tLandTile);
  var
  x,y,x0,y0	:integer;
  rasterLine	:GLHeightData.PSingleArray;
  oldType 	:THeightDataType;
  begin
  with HeightData do begin
  DataState:=hdsPreparing;
  oldType:=DataType;
  Allocate(hdtSingle);

  if XLeft>=0 then x0:=XLeft mod (fLandTileSize) else x0:=(fLandTileSize+(XLeft mod (fLandTileSize)))mod (fLandTileSize);
  if YTop>=0 then y0:=YTop mod (fLandTileSize) else y0:=(fLandTileSize+(YTop mod (fLandTileSize)))mod (fLandTileSize);

  MaterialName:=Format('%s%d%d',[LandTile.Name,x0 div fTerrainRenderer.TileSize,
  y0 div fTerrainRenderer.TileSize]);
  TextureCoordinatesMode:=tcmLocal;
  TextureCoordinatesScale:=TexPointMake((fLandTileSize)/(Size),
  (fLandTileSize)/(Size));
  for y:=y0 to y0+heightData.Size-1 do begin
  rasterLine:=singleRaster[y-y0];
  for x:=x0 to x0+heightData.Size-1 do begin
  rasterLine[x-x0]:=LandTile.fHeight[x,y];
  end;//for
  end;//for

  DataState:=hdsReady;
  if oldType<>hdtSingle then DataType:=oldType;
  end;//with
  end; }

procedure TgxTiledRndLandscape.SetCamera(const Value: TgxCamera);
begin
  FCamera := Value;
end;

procedure TgxTiledRndLandscape.SetCyclic(const Value: boolean);
begin
  FCyclic := Value;
  if FCyclic then
  begin
    FIntegerConstrain := CyclicClamp;
    FSingleConstrain := CyclicClamp;
    if FTerrainRenderer <> nil then
      FTerrainRenderer.OnGetTerrainBounds := nil;
  end
  else
  begin
    FIntegerConstrain := BoundaryClamp;
    FSingleConstrain := BoundaryClamp;
    if FTerrainRenderer <> nil then
      FTerrainRenderer.OnGetTerrainBounds := GetTerrainBounds;
  end; // else
end;

procedure TgxTiledRndLandscape.SetExtentX(const Value: integer);
begin
  FExtentX := Value;
  FExtentXhalf := FExtentX div 2;
end;

procedure TgxTiledRndLandscape.SetExtentZ(const Value: integer);
begin
  FExtentZ := Value;
  FExtentZhalf := FExtentZ div 2;
end;

procedure TgxTiledRndLandscape.SetGenerationRadius(const Value: integer);
var
  x, z, i: integer;
begin
  FGenerationRadius := Value;
  SetLength(fGenRadius, sqr(FGenerationRadius * 2 + 1));
  i := 0;
  for z := 0 to FGenerationRadius do
  begin
    for x := 1 to FGenerationRadius do
    begin
      if Trunc(sqrt(sqr(x) + sqr(z))) <= FGenerationRadius then
      begin
        fGenRadius[i].dx := x;
        fGenRadius[i].dz := z;
        fGenRadius[i + 1].dx := -z;
        fGenRadius[i + 1].dz := x;
        fGenRadius[i + 2].dx := -x;
        fGenRadius[i + 2].dz := -z;
        fGenRadius[i + 3].dx := z;
        fGenRadius[i + 3].dz := -x;
        Inc(i, 4);
      end; // if
    end; // for
  end; // for
  SetLength(fGenRadius, i - 3);
  fLandTiles.Capacity := (i - 3) * 2;
end;

procedure TgxTiledRndLandscape.SetIsDefaultTile(const Value: TIsDefaultTile);
begin
  FIsDefaultTile := Value;
end;

procedure TgxTiledRndLandscape.SetLandTileCapacity(const Value: integer);
begin
  FLandTileCapacity := Value;
end;

procedure TgxTiledRndLandscape.SetLandTileDensity(const Value: single);
begin
  FLandTileDensity := Value;
end;

procedure TgxTiledRndLandscape.SetOnCreateDefaultTile(const Value: TStartPreparingDataEvent);
begin
  fOnCreateDefaultTile := Value;
end;

procedure TgxTiledRndLandscape.SetOnCreateLandTile(const Value: TOnCreateLandTile);
begin
  fOnCreateLandTile := Value;
end;

procedure TgxTiledRndLandscape.SetSeed(const Value: integer);
begin
  FSeed := Value;
  InitializeRandomGenerator(FSeed);
end;

procedure TgxTiledRndLandscape.SetSize(const aSize: integer);
begin
  fLandTileSize := aSize;
end;

procedure TgxTiledRndLandscape.SetTerrainRenderer(const Value: TgxTerrainRenderer);
begin
  FTerrainRenderer := Value;
  FTerrainRenderer.HeightDataSource := Self;
end;

procedure TgxTiledRndLandscape.StartPreparingData(heightData: TgxHeightData);
var
  i: integer;
  tx, tz: integer;
begin
  with heightData do
  begin
    DataState := hdsPreparing;

    if (System.abs(XLeft) mod (heightData.Size - 1) = 0) and (System.abs(YTop) mod (heightData.Size - 1) = 0) then
    begin
      FindLandTile(XLeft, YTop, tx, tz);

      if IsDefaultTile(tx, tz) then
      begin
        OnCreateDefaultTile(heightData);
        exit;
      end; // if

      { Look if the landtile has already been computed }
      for i := 0 to fLandTiles.Count - 1 do
      begin
        with TLandTile(fLandTiles.Items[i]).LandTileInfo do
        begin
          if (x = tx) and (z = tz) then
          begin
            if (State = hdsReady) then
            begin
              TLandTile(fLandTiles.Items[i]).StartPreparingData(heightData);
              exit;
            end
            else
              break;
          end; // if
        end; // with
      end; // for
    end; // if

    DataState := hdsNone;
  end; // with
end;

function TgxTiledRndLandscape.TileDistance(const x1, z1, x2, z2: integer): single;
begin
  Result := sqrt(sqr(FExtentXhalf - abs(abs(x1 - x2) - FExtentXhalf)) + sqr(FExtentZhalf - abs(abs(z1 - z2) - FExtentZhalf)));
end;

function TgxTiledRndLandscape.TileDistanceSquared(const x1, z1, x2, z2: integer): integer;
begin
  Result := sqr(FExtentXhalf - abs(abs(x1 - x2) - FExtentXhalf)) + sqr(FExtentZhalf - abs(abs(z1 - z2) - FExtentZhalf));
end;

procedure TgxTiledRndLandscape.Update;
var
  i, j, maxi: integer;
  maxd, d: integer;
  cx, cz: integer;
  cx0, cz0: integer;
  Found: boolean;
  NewLandTile: TLandTile;
begin
  CameraPosition(cx0, cz0);
  if fMapUpdating or (fOldCamX = cx0) and (fOldCamZ = cz0) then
    exit;

  for j := 0 to High(fGenRadius) do
  begin
    fMapUpdating := True;
    cx := cx0 + fGenRadius[j].dx;
    cz := cz0 + fGenRadius[j].dz;
    FIntegerConstrain(cx, cz);
    if IsDefaultTile(cx, cz) then
      continue;

    { Look if the landtile has already been computed }
    Found := False;
    for i := 0 to fLandTiles.Count - 1 do
    begin
      with TLandTile(fLandTiles.Items[i]).LandTileInfo do
      begin
        if (x = cx) and (z = cz) and (State = hdsReady) then
        begin
          Found := True;
          break;
        end; // if
      end; // with
    end; // for

    { If not, compute it }
    if not Found and not FLandTileComputing then
    begin
      if fLandTiles.Count >= FLandTileCapacity then
      begin // If the tile buffer is full...
        maxd := -1; // ...replace the farthest tile
        maxi := -1;
        for i := 0 to fLandTiles.Count - 1 do
          with TLandTile(fLandTiles.Items[i]) do
          begin
            d := sqr(cx0 - LandTileInfo.x) + sqr(cz0 - LandTileInfo.z);
            if d > maxd then
            begin
              maxd := d;
              maxi := i;
            end; // if
          end; // for i
        if sqrt(maxd) > FGenerationRadius + 1 then
        begin
          TLandTile(fLandTiles.Items[maxi]).Free;
        end; // if
      end; // if
      ComputeLandTile(cx, cz, NewLandTile);
      fMapUpdating := False;
      exit; // Don't explore further. Let it for the next time step
    end; // if
  end; // for j
  fMapUpdating := False;
  fOldCamX := cx0; // Surrounding completely updated, we can stop checking
  fOldCamZ := cz0;
  fLandTiles.Pack;
end;

function TgxTiledRndLandscape.XMoveBoundary: single;
begin
  Result := ExtentX * LandTileSize * 0.95;
end;

function TgxTiledRndLandscape.ZMoveBoundary: single;
begin
  Result := ExtentZ * LandTileSize * 0.95;
end;

//
// TgxFractalArchipelago
//
procedure TgxFractalArchipelago.ComputeLandTile(const aX, aZ: integer; var NewLandTile: TLandTile);
begin
  NewLandTile := TgxFractalHDS.Create(Self);
  NewLandTile.FSlave := True;
  inherited ComputeLandTile(aX, aZ, NewLandTile);
end;

constructor TgxFractalArchipelago.Create(AOwner: TComponent);
begin
  inherited;
  OnCreateLandTile := fOnCreateLandTile;
  IsDefaultTile := FIsDefaultTile;
  IslandDensity := 0.4;
  FWaveAmplitude := 2;
  FWaveSpeed := 20;
  Sea := False; // Sea is drawn by the PostRender event
end;

procedure TgxFractalArchipelago.fOnCreateDefaultTile(heightData: TgxHeightData);
var
  x, y: integer;
  rasterLine: PSingleArray;
  oldType: TgxHeightDataType;
begin
  with heightData do
  begin
    DataState := hdsPreparing;
    oldType := DataType;
    Allocate(hdtSingle);
    MaterialName := FMaterialName;

    for y := 0 to heightData.Size - 1 do
    begin
      rasterLine := singleRaster[y];
      for x := 0 to heightData.Size - 1 do
      begin
        rasterLine[x] := FSeaLevel;
      end; // for
    end; // for

    if oldType <> hdtSingle then
      DataType := oldType;
  end; // with
end;

procedure TgxFractalArchipelago.fOnCreateLandTile(aX, aZ, aSeed: integer; var aLandscape: TLandTile);
begin
  InitializeRandomGenerator(aSeed);
  with TgxFractalHDS(aLandscape) do
  begin
    { Initialize the tile }
    Seed := random(MaxInt);
    Depth := Self.fDepth;
    Amplitude := random(FAmplitudeMax - FAmplitudeMin) + FAmplitudeMin;
    Roughness := random * (FRoughnessMax - FRoughnessMin) + FRoughnessMin;
    ApplyLighting(aLandscape);
    ApplyTexture(aLandscape);
    ApplyTopography(aLandscape);
    Cyclic := True;
    PrimerLandscape := True;

    { Generate the landscape }
    PrimerIsland(SeaLevel - SeaTransparency, random * Amplitude / 2, FHeight);
    // Pre-generate an island
    BuildHeightField;
    if ErosionByRain.Enabled then
      DoErosionByRain;
    if ErosionByLife.Enabled then
      DoErosionByLife;
    if ErosionBySea.Enabled then
      DoErosionBySea;
    if Sea then
      DoSea;
    BuildNormals;
    if Lighting then
      BuildLightMap
    else
      ClearLightMap;
    BuildTexture;
    FNormal := nil;
    FLightMap := nil;
  end; // with
end;

procedure TgxFractalArchipelago.FPostRenderSeaDynamic(var rci: TgxRenderContextInfo; var HeightDatas: TList);
// Code borrowed from Eric's Archipelago GLScene advanced demo
var
  i, x, y, s, s2: integer;
  t: single;
  hd: TgxHeightData;
const
  r = 0.75;
  g = 0.75;
  b = 1;

  function WaterPhase(const px, py: single): single;
  begin
    Result := t * 1 + px * 0.16 + py * 0.09;
  end;

  procedure IssuePoint(rx, ry: integer);
  var
    px, py: single;
    alpha, colorRatio, ca, sa: single;
  begin
    px := x + rx + s2;
    py := y + ry + s2;
    if hd.DataState = hdsNone then
    begin
      alpha := 1;
    end
    else
    begin
      alpha := (FSeaLevel - hd.SmallIntHeight(rx, ry)) * (1 / FSeaTransparency);
      alpha := ClampValue(alpha, 0.5, 1);
    end;
    SinCos(WaterPhase(px, py) * FWaveSpeed, sa, ca);
    colorRatio := 1 - alpha * 0.1;
    glColor4f(r * colorRatio, g * colorRatio, b, alpha);
    glTexCoord2f(px * 0.01 + 0.002 * sa, py * 0.01 + 0.0022 * ca - t * 0.01);
    glVertex3f(px, py, FSeaLevel + FWaveAmplitude * sa * VSF);
  end;

begin
  // if not WaterPlane then Exit;
  t := ((GetTickCount - rhdsStartTime) / 10000);
  FTerrainRenderer.MaterialLibrary.ApplyMaterial(FSeaMaterialName, rci);
  repeat
    // if not WasAboveWater then InverTgxFrontFace;
    glPushAttrib(GL_ENABLE_BIT);

    glDisable(GL_LIGHTING);
    glDisable(GL_NORMALIZE);

    glStencilFunc(GL_ALWAYS, 1, 255);
    glStencilMask(255);
    glStencilOp(GL_KEEP, GL_KEEP, GL_REPLACE);
    glEnable(GL_STENCIL_TEST);
    glNormal3f(0, 0, 1);

    for i := 0 to HeightDatas.Count - 1 do
    begin
      hd := TgxHeightData(HeightDatas.List[i]);
      if (hd.DataState = hdsReady) and (hd.HeightMin > FSeaLevel) then
        continue;
      x := hd.XLeft;
      y := hd.YTop;
      s := hd.Size - 1;
      s2 := s div 2;
      glBegin(GL_TRIANGLE_FAN);
      IssuePoint(s2, s2);
      IssuePoint(0, 0);
      IssuePoint(s2, 0);
      IssuePoint(s, 0);
      IssuePoint(s, s2);
      IssuePoint(s, s);
      IssuePoint(s2, s);
      IssuePoint(0, s);
      IssuePoint(0, s2);
      IssuePoint(0, 0);
      glEnd;
    end;
    glStencilOp(GL_KEEP, GL_KEEP, GL_KEEP);
    glPopAttrib;
    // if not WasAboveWater then InverTgxFrontFace;
    // WaterPolyCount:=heightDatas.Count*8;
  until not FTerrainRenderer.MaterialLibrary.UnApplyMaterial(rci);
end;

procedure TgxFractalArchipelago.FPostRenderSeaStatic(var rci: TgxRenderContextInfo; var HeightDatas: TList);
var
  i, x, y, s, s2: integer;
  hd: TgxHeightData;
  t: single;
const
  r = 0.75;
  g = 0.75;
  b = 1;

  procedure IssuePoint(rx, ry: integer);
  var
    px, py: single;
    alpha, colorRatio: single;
  begin
    px := x + rx + s2;
    py := y + ry + s2;
    if hd.DataState = hdsNone then
    begin
      alpha := 1;
    end
    else
    begin
      alpha := (FSeaLevel - hd.SmallIntHeight(rx, ry)) * (1 / FSeaTransparency);
      alpha := ClampValue(alpha, 0.5, 1);
    end;
    colorRatio := 1 - alpha * 0.1;
    glColor4f(r * colorRatio, g * colorRatio, b, alpha);
    glTexCoord2f(px * 0.01, py * 0.01 + t);
    glVertex3f(px, py, FSeaLevel);
  end;

begin
  t := Frac(GetTickCount / 1000);

  FTerrainRenderer.MaterialLibrary.ApplyMaterial(FSeaMaterialName, rci);
  repeat
    // if not WasAboveWater then InverTgxFrontFace;
    glPushAttrib(GL_ENABLE_BIT);

    glDisable(GL_LIGHTING);
    glDisable(GL_NORMALIZE);

    glStencilFunc(GL_ALWAYS, 1, 255);
    glStencilMask(255);
    glStencilOp(GL_KEEP, GL_KEEP, GL_REPLACE);
    glEnable(GL_STENCIL_TEST);
    glNormal3f(0, 0, 1);

    for i := 0 to HeightDatas.Count - 1 do
    begin
      hd := TgxHeightData(HeightDatas.List[i]);
      if (hd.DataState = hdsReady) and (hd.HeightMin > FSeaLevel) then
        continue;
      x := hd.XLeft;
      y := hd.YTop;
      s := hd.Size - 1;
      s2 := s div 2;
      glBegin(GL_TRIANGLE_FAN);
      IssuePoint(s2, s2);
      IssuePoint(0, 0);
      IssuePoint(s2, 0);
      IssuePoint(s, 0);
      IssuePoint(s, s2);
      IssuePoint(s, s);
      IssuePoint(s2, s);
      IssuePoint(0, s);
      IssuePoint(0, s2);
      IssuePoint(0, 0);
      glEnd;
    end;
    glStencilOp(GL_KEEP, GL_KEEP, GL_KEEP);
    glPopAttrib;
    // if not WasAboveWater then InverTgxFrontFace;
    // WaterPolyCount:=heightDatas.Count*8;
  until not FTerrainRenderer.MaterialLibrary.UnApplyMaterial(rci);
end;

function TgxFractalArchipelago.GetIslandDensity: single;
begin
  Result := FLandTileDensity;
end;

procedure TgxFractalArchipelago.SetAmplitudeMax(const Value: integer);
begin
  FAmplitudeMax := Value;
end;

procedure TgxFractalArchipelago.SetAmplitudeMin(const Value: integer);
begin
  FAmplitudeMin := Value;
end;

procedure TgxFractalArchipelago.SetDepth(const Value: integer);
begin
  fDepth := Value;
  SetSize(Round(IntPower(2, fDepth)));
end;

procedure TgxFractalArchipelago.SetIslandDensity(const Value: single);
begin
  LandTileDensity := Value;
end;

procedure TgxFractalArchipelago.SetRoughnessMax(const Value: single);
begin
  FRoughnessMax := Value;
end;

procedure TgxFractalArchipelago.SetRoughnessMin(const Value: single);
begin
  FRoughnessMin := Value;
end;

procedure TgxFractalArchipelago.SetSeaDynamic(const Value: boolean);
begin
  FSeaDynamic := Value;
  if FSeaDynamic then
    FTerrainRenderer.OnHeightDataPostRender := FPostRenderSeaDynamic
  else
    FTerrainRenderer.OnHeightDataPostRender := FPostRenderSeaStatic;
end;

procedure TgxFractalArchipelago.SetSeaMaterialName(const Value: string);
begin
  FSeaMaterialName := Value;
end;

procedure TgxFractalArchipelago.SetTerrainRenderer(const Value: TgxTerrainRenderer);
begin
  inherited;
  SeaDynamic := FSeaDynamic; // Called to hook the PostRender event handler
end;

procedure TgxFractalArchipelago.SetWaveAmplitude(const Value: single);
begin
  FWaveAmplitude := Value;
end;

procedure TgxFractalArchipelago.SetWaveSpeed(const Value: single);
begin
  FWaveSpeed := Value;
end;

{ *************************************************************** }
{ *******              RANDOM HDS ALGORITHMS             ******** }
{ *************************************************************** }

procedure FractalMiddlePointHDS(const aDepth, aSeed, aAmplitude: integer; const aRoughness: single; aCyclic: boolean;
  var z: TMapOfSingle; var MinZ, MaxZ: single);
{ Fractal algorithm based on the middle-point displacement method. It is built in
  a way that it can be juxtaposed seamlessly to itself (cyclic boundaries) }
var
  iter, Stp, stp2: integer;
  i, j: integer;
  dz: single;
  Size: integer;

  procedure Let(var z: single; const Value: single);
  { Fill variables only if they have not been predefined }
  begin
    if z = Empty then
      z := Value;
  end;

  function Get(const x, y: integer; var Value: single): boolean;
  { Fill variables only if they have not been predefined }
  begin
    Value := z[x, y];
    Result := (Value = Empty);
  end;

  function Centre(const x, y, Stp: integer): single;
  begin
    Result := z[x - Stp, y - Stp];
    Result := Result + z[x - Stp, y + Stp];
    Result := Result + z[x + Stp, y - Stp];
    Result := Result + z[x + Stp, y + Stp];
    Result := Result * 0.25;
    if MinZ > Result then
      MinZ := Result;
    if MaxZ < Result then
      MaxZ := Result;
  end;

  function Side(const x, y, Stp: integer): single;
  var
    n: integer;
  begin
    n := 0;
    Result := 0;
    if y - Stp >= 0 then
    begin
      Result := Result + z[x, y - Stp];
      Inc(n);
    end;
    if y + Stp <= Size then
    begin
      Result := Result + z[x, y + Stp];
      Inc(n);
    end;
    if x - Stp >= 0 then
    begin
      Result := Result + z[x - Stp, y];
      Inc(n);
    end;
    if x + Stp <= Size then
    begin
      Result := Result + z[x + Stp, y];
      Inc(n);
    end;
    Result := Result / n;
    if MinZ > Result then
      MinZ := Result;
    if MaxZ < Result then
      MaxZ := Result;
  end;

begin
  InitializeRandomGenerator(aSeed);
  Size := High(z);
  dz := aAmplitude * VSF;
  MinZ := 1E38;
  MaxZ := -1E38;

  if aCyclic then
  begin
    Let(z[0, 0], 0);
    Let(z[0, Size], z[0, 0]);
    Let(z[Size, 0], z[0, 0]);
    Let(z[Size, Size], z[0, 0]);

    { Build Height field }
    FOR iter := 1 TO aDepth do
    begin // iterations
      Stp := Round(Size / IntPower(2, (iter - 1))); // step
      stp2 := Stp div 2; // half step
      dz := dz * aRoughness;
      i := stp2;
      repeat
        j := stp2;
        repeat // Centre
          if z[i, j] = Empty then
          begin
            z[i, j] := Centre(i, j, stp2);
            z[i, j] := z[i, j] + (random * dz * 2 - dz) * 1.4;
          end; // if
          Inc(j, Stp);
        until j > Size - stp2 + 1;
        Inc(i, Stp);
      until i > Size - stp2 + 1;
      i := stp2;
      repeat
        j := 0;
        repeat // Sides
          if z[i, j] = Empty then
          begin
            z[i, j] := Side(i, j, stp2);
            z[i, j] := z[i, j] + random * dz * 2 - dz;
          end; // if
          if z[j, i] = Empty then
          begin
            z[j, i] := Side(j, i, stp2);
            z[j, i] := z[j, i] + random * dz * 2 - dz;
          end; // if
          Inc(j, Stp);
        until j >= Size;
        Let(z[Size, i], z[0, i]);
        Let(z[i, Size], z[i, 0]);
        Inc(i, Stp);
      until i > Size - stp2 + 1;
    end; // for iter
  end // if Cyclic

  else
  begin // Non-cyclic landscape
    Let(z[0, 0], random * dz * 2 - dz);
    Let(z[0, Size], random * dz * 2 - dz);
    Let(z[Size, 0], random * dz * 2 - dz);
    Let(z[Size, Size], random * dz * 2 - dz);

    { Build Height field }
    for iter := 1 to aDepth do
    begin // iterations
      Stp := Round(Size / IntPower(2, (iter - 1))); // step
      stp2 := Stp div 2; // half step
      dz := dz * aRoughness;
      i := stp2;
      repeat
        j := stp2;
        repeat // Centre
          if z[i, j] = Empty then
          begin
            z[i, j] := Centre(i, j, stp2);
            z[i, j] := z[i, j] + (random * dz * 2 - dz) * 1.4;
          end;
          Inc(j, Stp);
        until j > Size - stp2 + 1;
        Inc(i, Stp);
      until i > Size - stp2 + 1;
      i := stp2;
      repeat
        j := 0;
        repeat // Sides
          if z[i, j] = Empty then
          begin
            z[i, j] := Side(i, j, stp2);
            z[i, j] := z[i, j] + random * dz * 2 - dz;
          end; // if
          if z[j, i] = Empty then
          begin
            z[j, i] := Side(j, i, stp2);
            z[j, i] := z[j, i] + random * dz * 2 - dz;
          end; // if
          Inc(j, Stp);
        until j > Size;
        Inc(i, Stp);
      until i > Size - stp2 + 1;
    end; // for iter
  end; // else Cyclic
end;

{ *************************************************************** }
{ *******              PREDEFINED HEIGHT-FIELD           ******** }
{ *************************************************************** }

procedure PrimerNull(var z: TMapOfSingle);
{ Empty field }
var
  x, y: integer;
  Size: integer;
begin
  Size := High(z);
  for y := 0 to Size do
  begin
    for x := 0 to Size do
    begin
      z[x, y] := Empty;
    end; // for
  end; // for
end;

procedure PrimerIsland(LowZ, HighZ: single; var z: TMapOfSingle);
{ Ensure that the border of the tile is low (below sea level) and the middle
  is high. }
var
  i: integer;
  Size: integer;
begin
  Size := High(z);
  PrimerNull(z);
  HighZ := HighZ * VSF;
  LowZ := LowZ * VSF;
  z[Size div 2, Size div 2] := HighZ;
  for i := 0 to Size do
  begin
    z[i, 0] := LowZ;
    z[0, i] := LowZ;
    z[Size, i] := LowZ;
    z[i, Size] := LowZ;
  end; // for i
end;

initialization //-------------------------------------------------------------

rhdsStartTime := GetTickCount;

end.