perlin noise delphi source code?

[noeska]

Is there a good perlin noise unit availeable for delphi? Possible capeable of generating 3d textures?

Following the 'orange book' a 3d perlin noise texture should be generated beforehand on the cpu. Now i could convert all related source code, but i am feeling lazy and hope that there is some ready to use delphi sourcecode for that.

As always thanks in advance ...

[Traveler]

Iirc we have had several posts about Perlin noise in the past. I did a quick search and several posts came up, like this one for example.

[vgo]

Here's some of my old code referenced in the thread that Traveler posted...

[pascal]
unit mvNoise;
{**<
@author(Jani Alanen <http://www.projectminiverse.com>)
@created(2007-09-06)
@lastmod(2007-09-15)

Noise functions
}
{
History

Created:
06.09.2007 (JA)

Modified:
15.09.2007 (JA)
+ Added TImprovedPerlinNoise and TFastPerliNoise

}

interface

uses
Math, mvMath;

const
_B = $100;
_BM = $FF;
_N = $1000;
_NP = 12; // 2^N
_NM = $FFF;

ImprovedPerlinNoisePermutation: array [0..255] of TInt = ( 151,160,137,91,90,15,
131,13,201,95,96,53,194,233,7,225,140,36,103,30,69 ,142,8,99,37,240,21,10,23,
190, 6,148,247,120,234,75,0,26,197,62,94,252,219,203,11 7,35,11,32,57,177,33,
88,237,149,56,87,174,20,125,136,171,168, 68,175,74,165,71,134,139,48,27,166,
77,146,158,231,83,111,229,122,60,211,133,230,220,1 05,92,41,55,46,245,40,244,
102,143,54, 65,25,63,161, 1,216,80,73,209,76,132,187,208, 89,18,169,200,196,
135,130,116,188,159,86,164,100,109,198,173,186, 3,64,52,217,226,250,124,123,
5,202,38,147,118,126,255,82,85,212,207,206,59,227, 47,16,58,17,182,189,28,42,
223,183,170,213,119,248,152, 2,44,154,163, 70,221,153,101,155,167, 43,172,9,
129,22,39,253, 19,98,108,110,79,113,224,232,178,185, 112,104,218,246,97,228,
251,34,242,193,238,210,144,12,191,179,162,241, 81,51,145,235,249,14,239,107,
49,192,214, 31,181,199,106,157,184, 84,204,176,115,121,50,45,127, 4,150,254,
138,236,205,93,222,114,67,29,24,72,243,141,128,195 ,78,66,215,61,156,180
);

type
TNoiseGeneratorType = (ngtDefault, ngtPerlin, ngtImprovedPerlin);

TNoiseGenerator = class(TObject)
private
protected
Seed: LongWord;
public
constructor Create;
destructor Destroy; override;
procedure Init(const Seed: LongWord); virtual;
function Noise1(const a: TDouble): TDouble; virtual;
function Noise2(const v1: TVector2d): TDouble; virtual;
function Noise3(const v1: TVector3d): TDouble; virtual;
function VecNoise(const v1: TVector3d): TVector3d; virtual;
function DistNoise(const v1: TVector3d; const Distortion: TDouble): TDouble; virtual;
function Turbulence(const v1: TVector3d; const Frequency: TDouble): TDouble; virtual;
function PerlinNoise3d(const v: TVector3d;
const Persistence: TDouble = 0.25;
const Frequency: TDouble = 1;
const Octaves: TDouble = 4): TDouble;
published
end;

TSimpleNoise = class(TNoiseGenerator)
private
protected
public
procedure Init(const Seed: LongWord); override;
function Noise3(const v1: TVector3d): TDouble; override;
published
end;

TPerlinNoise = class(TNoiseGenerator)
private
protected
Gradients1: array of TDouble;
Gradients2: array of TVector2d;
Gradients3: array of TVector3d;
Permutations: array of TInt;
public
constructor Create;
destructor Destroy; override;
procedure Init(const Seed: LongWord); override;
function Noise1(const a: TDouble): TDouble; override;
function Noise2(const v1: TVector2d): TDouble; override;
function Noise3(const v1: TVector3d): TDouble; override;
published
end;

TImprovedPerlinNoise = class(TNoiseGenerator)
private
protected
p: array [0..511] of TInt;
function _Fade(const t: TDouble): TDouble;
function _Lerp(const t, a, b: TDouble): TDouble;
function _Grad(const hash: TInt; const x, y, z: TDouble): TDouble;
public
procedure Init(const Seed: LongWord); override;
function Noise3(const v1: TVector3d): TDouble; override;
published
end;

TFastPerlinNoise = class(TNoiseGenerator)
private
protected
ms_grad4: array [0..511] of TDouble;
kkf: array [0..255] of TDouble;
p: array [0..511] of TInt;
procedure SetupFPU;
function _Floor(const t: TDouble): TInt;
function _Fade(const t: TDouble): TDouble;
function _Lerp(const t, a, b: TDouble): TDouble;
function _Grad(const hash: TInt; const x, y, z: TDouble): TDouble;
public
procedure Init(const Seed: LongWord); override;
function Noise3(const v1: TVector3d): TDouble; override;
published
end;

implementation

var
fpu_control_word, fpu_control_word2: Word;

{* TNoiseGenerator *}

constructor TNoiseGenerator.Create;
begin
inherited;
end;

destructor TNoiseGenerator.Destroy;
begin
inherited;
end;

procedure TNoiseGenerator.Init(const Seed: LongWord);
begin
if Seed <> 0 then
begin
Self.Seed := Seed;
RandSeed := Seed;
end
else
begin
Randomize();
Self.Seed := RandSeed;
end;
end;

function TNoiseGenerator.Noise1(const a: TDouble): TDouble;
begin
// Dummy
end;

function TNoiseGenerator.Noise2(const v1: TVector2d): TDouble;
begin
// Dummy
end;

function TNoiseGenerator.Noise3(const v1: TVector3d): TDouble;
begin
// Dummy
end;

function TNoiseGenerator.VecNoise(const v1: TVector3d): TVector3d;
begin
Result.x := Noise1( v1.x );
Result.y := Noise1( v1.x + 3.33 );
Result.z := Noise1( v1.x + 7.77 );
end;

function TNoiseGenerator.Turbulence(const v1: TVector3d; const Frequency: TDouble): TDouble;
var
t: TDouble;
vec: TVector3d;
f: TDouble;
begin
f := Frequency;
t := 0;
while f >= 1.0 do
begin
f := f / 2;
vec.x := f * v1.x;
vec.y := f * v1.y;
vec.z := f * v1.z;
t := t + Abs(Noise3(vec)) / f;
end;
Result := t;
end;

function TNoiseGenerator.DistNoise(const v1: TVector3d; const Distortion: TDouble): TDouble;
var
Point: TVector3d;
Offset: TVector3d;
n: TDouble;
begin
Point := v1;
offset := VectorAdd(point, _Vector3d(0.5, 0.5, 0.5)); // misregister domain for distortion */
Offset := VecNoise(Offset); // get a random vector */
VectorScale(Offset, Distortion); // scale the distortion
// “point” is the domain; distort domain by adding “offset” */
Point := VectorAdd(Point, Offset);
Result := Noise3( point ); // distorted domain noise */
end;

function TNoiseGenerator.PerlinNoise3d(const v: TVector3d;
const Persistence: TDouble = 0.25;
const Frequency: TDouble = 1;
const Octaves: TDouble = 4): TDouble;
var
i: TInt;
p, s: TDouble;
begin
Result := 0;
s := Frequency;
p := 1;
for i := 0 to Trunc(Octaves) - 1 Do
begin
Result := Result + p * Noise3(VectorScaled(v, s));
s := s * 2;
p := p * Persistence;
end;
end;

{* TSimpleNoise *}

procedure TSimpleNoise.Init(const Seed: LongWord);
begin
if Seed <> 0 then
begin
Self.Seed := Seed;
RandSeed := Seed;
end
else
begin
Randomize();
Self.Seed := RandSeed;
end;
end;

function TSimpleNoise.Noise3(const v1: TVector3d): TDouble;
const X_NOISE_GEN = 1619;
const Y_NOISE_GEN = 31337;
const Z_NOISE_GEN = 6971;
const SEED_NOISE_GEN = 1013;
var n: Integer;
begin
n := Round(X_NOISE_GEN * v1.x + Y_NOISE_GEN * v1.y + Z_NOISE_GEN * v1.z+ SEED_NOISE_GEN * seed) and $7fffffff;
n := (n shr 13) xor n;
Result := 1.0 - (((n * (n * n * 60493 + 19990303) + 1376312589) and $7fffffff) / 1073741824.0);
end;

{* TPerlinNoise *}

constructor TPerlinNoise.Create;
begin
inherited;
end;

destructor TPerlinNoise.Destroy;
begin
inherited;
end;

procedure TPerlinNoise.Init(const Seed: LongWord);
var
i, j, k: Integer;
b: Byte;
begin
if Seed <> 0 then
begin
Self.Seed := Seed;
RandSeed := Seed;
end
else
Randomize();
SetLength(Permutations, _B + 2);
SetLength(Gradients1, _B + _B + 2);
SetLength(Gradients2, _B + _B + 2);
SetLength(Gradients3, _B + _B + 2);

for i := 0 to _B - 1 do
begin
Permutations[i] := i;

Gradients1[i] := ((Random(High(Integer)) mod (_B + _B)) - _B) / _B;

Gradients2[i].x := ((Random(High(Integer)) mod (_B + _B)) - _B) / _B;
Gradients2[i].y := ((Random(High(Integer)) mod (_B + _B)) - _B) / _B;
VectorNormalize(Gradients2[i]);

Gradients3[i].x := ((Random(High(Integer)) mod (_B + _B)) - _B) / _B;
Gradients3[i].y := ((Random(High(Integer)) mod (_B + _B)) - _B) / _B;
Gradients3[i].z := ((Random(High(Integer)) mod (_B + _B)) - _B) / _B;
VectorNormalize(Gradients3[i]);
end;

i := _B - 1;
while (i > 0) do
begin
k := Permutations[i];
j := Random(High(Integer)) mod _B;
Permutations[i] := Permutations[j];
Permutations[j] := k;
Dec(i);
end;

i := 0;
b := _B - 1;
for i := 0 to _B + 1 do
//while i < _B + 2 do
begin
b := _B + i;
Permutations[b] := Permutations[i];
Gradients1[b] := Gradients1[i];
Gradients2[b] := Gradients2[i];
Gradients3[b] := Gradients3[i];
//Inc(i);
end;
end;

function TPerlinNoise.Noise1(const a: TDouble): TDouble;
var
bx0, bx1: TInt;
rx0, rx1, sx, t, u, v: TDouble;
b: Integer;
begin
t := a + _N;
bx0 := (Floor(t) and _BM);
bx1 := (bx0 + 1) and _BM;
rx0 := t - Floor(t);
rx1 := rx0 - 1.0;

sx := SCurve(rx0);

u := rx0 * Gradients1[ Permutations[ bx0 mod 256 ] ];
v := rx1 * Gradients1[ Permutations[ bx1 mod 256 ] ];

Result := Lerp(u, v, sx);
end;

function TPerlinNoise.Noise2(const v1: TVector2d): TDouble;
var
bx0, bx1, by0, by1, b00, b10, b01, b11: TInt;
rx0, rx1, ry0, ry1, sx, sy, a, b, t, u, v: TDouble;
q: PVector2d;
i, j: Integer;

function at2(const rx, ry: TDouble): TDouble;
begin
Result := rx * q.x + ry * q.y;
end;

begin
t := v1.x + _N;
bx0 := (Floor(t) and _BM);
bx1 := (bx0 + 1) and _BM;
rx0 := t - Floor(t);
rx1 := rx0 - 1.0;

t := v1.y + _N;
by0 := (Floor(t) and _BM);
by1 := (by0 + 1) and _BM;
ry0 := t - Floor(t);
ry1 := ry0 - 1.0;

i := Permutations[ bx0 mod 256 ];
j := Permutations[ bx1 mod 256 ];

b00 := Permutations[ (i + by0) mod 256 ];
b10 := Permutations[ (j + by0) mod 256 ];
b01 := Permutations[ (i + by1) mod 256 ];
b11 := Permutations[ (j + by1) mod 256 ];

sx := SCurve(rx0);
sy := SCurve(ry0);

q := @Gradients2[ b00 mod 256 ]; u := at2(rx0,ry0);
q := @Gradients2[ b10 mod 256 ]; v := at2(rx1,ry0);
a := Lerp(u, v, sx);

q := @Gradients2[ b01 mod 256 ]; u := at2(rx0,ry1);
q := @Gradients2[ b11 mod 256 ]; v := at2(rx1,ry1);
b := Lerp(u, v, sx);

Result := Lerp(a, b, sy);
end;

function TPerlinNoise.Noise3(const v1: TVector3d): TDouble;
var
bx0, bx1, by0, by1, bz0, bz1, b00, b10, b01, b11: TInt;
rx0, rx1, ry0, ry1, rz0, rz1, sy, sz, a, b, c, d, t, u, v: TDouble;
q: PVector3d;
i, j, ByteRef: Byte;

function at3(const rx, ry, rz: TDouble): TDouble;
begin
Result := rx * q.x + ry * q.y + rz * q.z;
end;
begin
t := v1.x + _N;
bx0 := (Floor(t) and _BM);
bx1 := (bx0 + 1) and _BM;
rx0 := t - Floor(t);
rx1 := rx0 - 1.0;

t := v1.y + _N;
by0 := (Floor(t) and _BM);
by1 := (by0 + 1) and _BM;
ry0 := t - Floor(t);
ry1 := ry0 - 1.0;

t := v1.z + _N;
bz0 := (Floor(t) and _BM);
bz1 := (bz0 + 1) and _BM;
rz0 := t - Floor(t);
rz1 := rz0 - 1.0;

i := Permutations[ bx0 mod 256 ];
j := Permutations[ bx1 mod 256 ];

b00 := Permutations[ (i + by0) mod 256 ];
b10 := Permutations[ (j + by0) mod 256 ];
b01 := Permutations[ (i + by1) mod 256 ];
b11 := Permutations[ (j + by1) mod 256 ];

t := SCurve(rx0);
sy := SCurve(ry0);
sz := SCurve(rz0);

q := @Gradients3[ (b00 + bz0) mod 256 ]; u := at3(rx0,ry0,rz0);
q := @Gradients3[ (b10 + bz0) mod 256 ]; v := at3(rx1,ry0,rz0);
a := Lerp(u, v, t);

q := @Gradients3[ (b01 + bz0) mod 256 ]; u := at3(rx0,ry1,rz0);
q := @Gradients3[ (b11 + bz0) mod 256 ]; v := at3(rx1,ry1,rz0);
b := Lerp(u, v, t);

c := Lerp(a, b, sy);

q := @Gradients3[ (b00 + bz1) mod 256 ]; u := at3(rx0,ry0,rz1);
q := @Gradients3[ (b10 + bz1) mod 256 ]; v := at3(rx1,ry0,rz1);
a := Lerp(u, v, t);

q := @Gradients3[ (b01 + bz1) mod 256 ]; u := at3(rx0,ry1,rz1);
q := @Gradients3[ (b11 + bz1) mod 256 ]; v := at3(rx1,ry1,rz1);
b := Lerp(u, v, t);
d := Lerp(a, b, sy);

Result := Lerp(c, d, sz);
end;

{* TImprovedPerlinNoise *}

function TImprovedPerlinNoise._Fade(const t: TDouble): TDouble;
begin
Result := t * t * t * (t * (t * 6 - 15) + 10);
end;

function TImprovedPerlinNoise._Lerp(const t, a, b: TDouble): TDouble;
begin
Result := a + t * (b - a);
end;

function TImprovedPerlinNoise._Grad(const hash: TInt; const x, y, z: TDouble): TDouble;
var
h: TInt;
u, v: TDouble;
begin
h := hash and 15;
if h < 8 then
u := x
else
u := y;
if h < 4 then
v := y
else
if (h = 12) or (h = 14) then
v := x
else
v := z;
if (h and 1) = 0 then
Result := u
else
Result := -u;
if (h and 2) = 0 then
Result := Result + v
else
Result := Result - v;
end;

procedure TImprovedPerlinNoise.Init(const Seed: LongWord);
var
i: Integer;
begin
inherited;
for i := 0 to 255 do
begin
p[256 + i] := p[i];
p[i] := ImprovedPerlinNoisePermutation[i];
end;
end;

function TImprovedPerlinNoise.Noise3(const v1: TVector3d): TDouble;
var
xi, yi, zi: TInt;
xd, yd, zd: TDouble;
u, v, w: TDouble;
A, B, AA, AB, BA, BB: TInt;
begin
xi := Floor(v1.x) and 255;
yi := Floor(v1.y) and 255;
zi := Floor(v1.z) and 255;
xd := v1.x - Floor(v1.x);
yd := v1.y - Floor(v1.y);
zd := v1.z - Floor(v1.z);
u := _Fade(xd);
v := _Fade(yd);
w := _Fade(zd);
A := p[xi ] + yi;
AA := p[A] + zi;
AB := p[A+1] + zi;
B := p[xi+1] + yi;
BA := p[B] + zi;
BB := p[B+1] + zi;

Result := _Lerp(w, _Lerp(v, _Lerp(u, _Grad(p[AA ], xd , yd , zd ),
_Grad(p[BA ], xd-1, yd , zd )),
_Lerp(u, _Grad(p[AB ], xd , yd-1, zd ),
_Grad(p[BB ], xd-1, yd-1, zd ))),
_Lerp(v, _Lerp(u, _Grad(p[AA+1], xd , yd , zd-1 ),
_Grad(p[BA+1], xd-1, yd , zd-1 )),
_Lerp(u, _Grad(p[AB+1], xd , yd-1, zd-1 ),
_Grad(p[BB+1], xd-1, yd-1, zd-1 ))));
end;

{* TFastPerlinNoise *}

procedure TFastPerlinNoise.SetupFPU; register;
asm
fstcw fpu_control_word // store fpu control word
mov dx, word ptr [fpu_control_word]
or dx, $0400 // round towards -inf
and dx, $F7FF
mov fpu_control_word2, dx
fldcw fpu_control_word2 // load modfied control word
end;

function TFastPerlinNoise._Floor(const t: TDouble): TInt; register;
asm
fld [t]
fistp [Result]
end;

function TFastPerlinNoise._Fade(const t: TDouble): TDouble;
begin
Result := t * t * t * (t * (t * 6 - 15) + 10);
end;

function TFastPerlinNoise._Lerp(const t, a, b: TDouble): TDouble;
begin
Result := a + t * (b - a);
end;

function TFastPerlinNoise._Grad(const hash: TInt; const x, y, z: TDouble): TDouble;
var
h: TInt;
u, v: TDouble;
begin
h := hash and 15;
if h < 8 then
u := x
else
u := y;
if h < 4 then
v := y
else
if (h = 12) or (h = 14) then
v := x
else
v := z;
if (h and 1) = 0 then
Result := u
else
Result := -u;
if (h and 2) = 0 then
Result := Result + v
else
Result := Result - v;
end;

procedure TFastPerlinNoise.Init(const Seed: LongWord);
var
i: Integer;
begin
inherited;
SetupFPU;
for i := 0 to 255 do
begin
p[256 + i] := p[i];
p[i] := ImprovedPerlinNoisePermutation[i];
end;

for i := 0 to 255 do
kkf[i] := FloatRand(-1.0, 1.0);

for i := 0 to 511 do
ms_grad4[i] := kkf[p[i]] * 0.7;
end;

function TFastPerlinNoise.Noise3(const v1: TVector3d): TDouble;
var
xi, yi, zi: TInt;
xd, yd, zd: TDouble;
u, v, w: TDouble;
A, B, AA, AB, BA, BB: TInt;
begin
xi := _Floor(v1.x) and 255;
yi := _Floor(v1.y) and 255;
zi := _Floor(v1.z) and 255;
xd := v1.x - _Floor(v1.x);
yd := v1.y - _Floor(v1.y);
zd := v1.z - _Floor(v1.z);
u := _Fade(xd);
v := _Fade(yd);
w := _Fade(zd);
A := p[xi ] + yi;
AA := p[A] + zi;
AB := p[A+1] + zi;
B := p[xi+1] + yi;
BA := p[B] + zi;
BB := p[B+1] + zi;

Result := (_Lerp(w, _Lerp(v, _Lerp(u, ms_grad4[AA], ms_grad4[BA]),
_Lerp(u, ms_grad4[AB], ms_grad4[BB])),
_Lerp(v, _Lerp(u, ms_grad4[AA + 1], ms_grad4[BA + 1]),
_Lerp(u, ms_grad4[AB + 1], ms_grad4[BB + 1]))));

end;

end.
[/pascal]

[vgo]

And this one goes with it...

[pascal]
unit mvFractal;
{**<
@author(Jani Alanen <http://www.projectminiverse.com>)
@created(2007-09-12)
@lastmod(2007-09-12)

Fractal functions
}
{
History

Created:
12.09.2007 (JA)

}

interface

uses
mvMath, mvNoise;

type
TFractalType = (ftNoise, ftTurbulence, ftDistordedNoise, ftfBm, ftMultifractal,
ftHeteroTerrain, ftHybridMultifractal, ftRidgedMultifractal);

TFractalGenerator = class(TObject)
private
protected
FNoiseGenerator: TNoiseGenerator;
fbmExponent: array of TDouble;
exponent_array: array of TDouble;
public
constructor Create;
destructor Destroy; override;
procedure fBmInit(const H, Lacunarity, Octaves: TDouble );
function fBm( const v1: TVector3d; H, Lacunarity, Octaves: TDouble ): TDouble;
function Multifractal( const v1: TVector3d; const H, lacunarity, offset: TDouble; const octaves: TInt ): TDouble;
procedure HeteroTerrainInit(const H, lacunarity, octaves: TDouble );
function HeteroTerrain(const v1: TVector3d; const H, lacunarity, octaves, offset: TDouble ): TDouble;
procedure HybridMultifractalInit(const H, lacunarity, octaves: TDouble);
function HybridMultifractal(const v1: TVector3d; const H, lacunarity, octaves, offset: TDouble): TDouble;
procedure RidgedMultifractalInit(const H, lacunarity, octaves: TDouble);
function RidgedMultifractal(const v1: TVector3d; const H, lacunarity, octaves, offset, gain: TDouble): TDouble;
published
property NoiseGenerator: TNoiseGenerator read FNoiseGenerator write FNoiseGenerator;
end;

implementation

uses
Math, SysUtils;

{* TFractalGenerator *}

constructor TFractalGenerator.Create;
begin
inherited;
end;

destructor TFractalGenerator.Destroy;
begin
if Assigned(FNoiseGenerator) then
FreeAndNil(FNoiseGenerator);
inherited;
end;

{*
* Procedural fBm evaluated at “point”.
*
* Parameters:
* “H” is the fractal increment parameter
* “lacunarity” is the gap between successive frequencies
* “octaves” is the number of frequencies in the fBm
*}

procedure TFractalGenerator.fBmInit(const H, Lacunarity, Octaves: TDouble );
var
i: Integer;
begin
SetLength(fbmExponent, Round(Octaves) + 2);
for i := 0 to Trunc(Octaves) - 1 do
fBmExponent[i] := Power( lacunarity, -H*i);
end;

function TFractalGenerator.fBm( const v1: TVector3d; H, Lacunarity, Octaves: TDouble ): TDouble;
var
value, remainder: Extended;
Point: TVector3d;
i: Integer;
begin
value := 0.0;
Point := v1;
// inner loop of fractal construction
for i := 0 to Trunc(Octaves) - 1 do
begin
//value := value + FNoiseGenerator.Noise3(point) * Power( lacunarity, -H*i );
value := value + FNoiseGenerator.Noise3(point) * fBmExponent[i];
//point *= lacunarity;
VectorScale(Point, Lacunarity);
end;
Remainder := octaves - Trunc(octaves);
if ( Remainder > 0 ) then
// add in “octaves” remainder
// ‘i’ and spatial freq. are preset in loop above
//value := Value + remainder * FNoiseGenerator.Noise3( point ) * Power( lacunarity, -H*i );
value := Value + remainder * FNoiseGenerator.Noise3( point ) * fBmExponent[i];
Result := value;
end;

{*
* Procedural multifractal evaluated at “point.”
*
* Parameters:
* “H” determines the highest fractal dimension
* “lacunarity” is gap between successive frequencies
* “octaves” is the number of frequencies in the fBm
* “offset” is the zero offset, which determines multifractality
*}
function TFractalGenerator.Multifractal( const v1: TVector3d; const H, lacunarity, offset: TDouble; const octaves: TInt ): TDouble;
var
value: TDouble;
i: Integer;
Point: TVector3d;
begin
value := 1.0;
Point := v1;
for i := 0 to octaves - 1 do
begin
value := Value * (FNoiseGenerator.Noise3( point ) + offset) * Power( lacunarity, -H*i );
//point *= lacunarity;
VectorScale(Point, Lacunarity);
end;
Result := value;
end;


{*
* Heterogeneous procedural terrain function: stats by altitude method.
* Evaluated at “point”; returns value stored in “value”.
*
* Parameters:
* “H” determines the fractal dimension of the roughest areas
* “lacunarity” is the gap between successive frequencies
* “octaves” is the number of frequencies in the fBm
* “offset” raises the terrain from “sea level”
*}

procedure TFractalGenerator.HeteroTerrainInit(const H, lacunarity, octaves: TDouble );
var
Frequency: TDouble;
i: Integer;
begin
// precompute and store spectral weights, for efficiency
// seize required memory for exponent_array
SetLength(exponent_array, Round(Octaves + 2));
frequency := 1.0;
for i := 0 to Trunc(octaves) do
begin
// compute weight for each frequency
exponent_array[i] := Power( frequency, -H );
frequency := Frequency * lacunarity;
end;
end;

function TFractalGenerator.HeteroTerrain(const v1: TVector3d; const H, lacunarity, octaves, offset: TDouble ): TDouble;
var
value, increment, frequency, remainder: TDouble;
i: Integer;
first: Boolean;
Point: TVector3d;
begin
First := TRUE;
Point := v1;
// first unscaled octave of function; later octaves are scaled */
value := offset + FNoiseGenerator.Noise3( point );

VectorScale(Point, Lacunarity);
i := 1;

// spectral construction inner loop, where the fractal is built */

if i < Octaves then
begin
// obtain displaced noise value */
increment := FNoiseGenerator.Noise3( point ) + offset;
// scale amplitude appropriately for this frequency */
increment := increment * exponent_array[i];
// scale increment by current “altitude” of function */
increment := increment * value;
// add increment to “value” */
value := value + increment;
// raise spatial frequency */
VectorScale(Point, Lacunarity);
Inc(i);
end; // for */
// take care of remainder in “octaves” */
remainder := octaves - Trunc(octaves);
if ( remainder > 0) then
begin
// “i” and spatial freq. are preset in loop above */
// note that the main loop code is made shorter here */
// you may want to make that loop more like this */
increment := (FNoiseGenerator.Noise3( point ) + offset) * exponent_array[i];
value := value + remainder * increment * value;
end;
Result := Value;

end;

{* Hybrid additive/multiplicative multifractal terrain model. *
* Some good parameter values to start with:
*
* H: 0.25
* offset: 0.7
*}
procedure TFractalGenerator.HybridMultifractalInit(const H, lacunarity, octaves: TDouble);
var
Frequency: TDouble;
i: Integer;
begin
// precompute and store spectral weights
// seize required memory for exponent_array
SetLength(exponent_array, Round(Octaves + 1));
frequency := 1.0;
for i := 0 to Trunc(Octaves) do
begin
// compute weight for each frequency
exponent_array[i] := Power( frequency, -H);
frequency := Frequency * lacunarity;
end;
end;

function TFractalGenerator.HybridMultifractal(const v1: TVector3d; const H, lacunarity, octaves, offset: TDouble): TDouble;
var
frequency, signal, weight, remainder: TDouble;
i: Integer;
Point: TVector3d;
begin
Point := v1;
// get first octave of function */
Result := ( FNoiseGenerator.Noise3( point ) + offset ) * exponent_array[0];
weight := result;
// increase frequency */
VectorScale(Point, Lacunarity);
i := 1;
// spectral construction inner loop, where the fractal is built */
while (i < Octaves) and (Weight > 0.001) do
begin
// prevent divergence */
if ( weight > 1.0 ) then
weight := 1.0;
// get next higher frequency */
signal := ( FNoiseGenerator.Noise3( point ) + offset ) * exponent_array[i];
// add it in, weighted by previous freq’s local value */
result := Result + weight * signal;
// update the (monotonically decreasing) weighting value */
// (this is why H must specify a high fractal dimension) */
weight := Weight * signal;
// increase frequency */
VectorScale(Point, Lacunarity);
Inc(i);
end; // for */
// take care of remainder in “octaves” */
remainder := octaves - Trunc(octaves);
if ( remainder > 0 ) then
begin
// “i” and spatial freq. are preset in loop above */
result := Result + (remainder * FNoiseGenerator.Noise3( point ) * exponent_array[i]);
end
end;

{** Ridged multifractal terrain model.

Some good parameter values to start with:

H: 1.0
offset: 1.0
gain: 2.0 }
procedure TFractalGenerator.RidgedMultifractalInit(const H, lacunarity, octaves: TDouble);
var
Frequency: TDouble;
i: Integer;
begin
// precompute and store spectral weights
// seize required memory for exponent_array
SetLength(exponent_array, Round(octaves+1));
frequency := 1.0;
for i := 0 to Trunc(octaves) do
begin
// compute weight for each frequency
exponent_array[i] := Power( frequency, -H );
frequency := Frequency * lacunarity;
end;
end;

function TFractalGenerator.RidgedMultifractal(const v1: TVector3d; const H, lacunarity, octaves, offset, gain: TDouble): TDouble;
var
frequency, signal, weight: TDouble;
i: Integer;
Point: TVector3d;
begin
Point := v1;
// get first octave
signal := FNoiseGenerator.Noise3( point );
// get absolute value of signal (this creates the ridges)
if ( signal < 0.0 ) then
signal := -signal;
// invert and translate (note that offset should be = 1.0)
signal := offset - signal;
// square the signal, to increase sharpness of ridges
signal := signal * Signal;
// assign initial values
result := signal;
weight := 1.0;

i := 1;
while (i < octaves) and (weight > 0.001) do
begin
// increase the frequency */
VectorScale(Point, Lacunarity);
// weight successive contributions by previous signal
weight := signal * gain;
if ( weight > 1.0 ) then
weight := 1.0;
if ( weight < 0.0 ) then
weight := 0.0;
signal := FNoiseGenerator.Noise3( point );
if ( signal < 0.0 ) then
signal := -signal;
signal := offset - signal;
signal := signal * signal;
// weight the contribution
signal := signal * weight;
result := result + (signal * exponent_array[i]);
Inc(i);
end;
end;

end.
[/pascal]

TVector3d is made of 3 double components, single won't work here...

[noeska]

Oh nice ... thank you ... i will give it a go this weekend ...