// // The graphics engine GLXEngine. The unit of GXScene for Delphi // 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*fRangeHeight0 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*20 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] 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.