LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
  Functions for generating perlin noise.
6

7
   History :  
8
   20/05/10 - Yar - Fixes for Linux x64
9
   30/03/07 - DaStr - Added $I GLScene.inc
10
   28/03/07 - DaStr - Cosmetic fixes for FPC compatibility.
11
   29/01/03 - JaJ - Submitted to GLScene.
12
   
13
}
14
unit GLPerlinBase;
15

16
interface
17

18
{$I GLScene.inc}
19

20
type
21
  T1DPerlinArray = array of Double;
22
  T2DPerlinArray = array of T1DPerlinArray;
23

24
  // Useless for final output! Usefull for after interpolation, as its FAST!
25
function Linear_Interpolate(const a, b, x: Double): Double;
26
// does a cubic interpolation
27
function Cubic_Interpolate(v0, v1, v2, v3, x: Double): Double;
28
// does a cosine interpolation
29
function Cosine_Interpolate(const a, b, x: Double): Double;
30
// just a random controlled by X
31
function Perlin_Random1(x: Integer): Double;
32
// just a random controlled by X,Y
33
function Perlin_Random2(Const x, Y: Integer): Double;
34
// generates a random strip
35
procedure Perlin_Random1DStrip(x, Width, Step: Integer; Amp: Double;
36
  Res: T1DPerlinArray);
37
// cubic interpolate 4 strips into one...
38
procedure Cubic_Interpolate_Strip(B1, B2, B3, B4, Res: T1DPerlinArray;
39
  Width: Integer);
40
// smooth interpolate 3 strips into one...
41
procedure Smooth_Interpolate_Strip(B1, B2, B3, Res: T1DPerlinArray;
42
  Width: Integer);
43

44
// a function returning some integer based on the root^exponant concept,
45
// result is crap and is only for "random" usage... eg perlin.
46
function ExponateCrap(root, exponant: Integer): Integer;
47

48
implementation
49

50
uses
51
  GLCrossPlatform;
52

53
function ExponateCrap(root, exponant: Integer): Integer;
54
var
55
  D: Extended;
56
begin
57
  if root <= 0 then
58
    Result := 0
59
  else
60
  begin
61
    D := exp(ln(root) * exponant);
62
    If D >= 1E30 then // = Infinity then
63
      D := root * exponant;
64
    // if you got a better(faster) way of carving some integer value out of a double let me know!
65
    if D > maxInt then
66
      Result := maxInt
67
    else
68
      Result := Round(D);
69
  end;
70
end;
71

72
function Perlin_Random1(x: Integer): Double;
73
begin
74
  x := ExponateCrap((x shl 13) + (x shr 9), x);
75
  // mess up the number real good!
76

77
  // X        X          X       those three number can be played with, primes are incouraged!
78
  x := ((x * (x * x * 15731 + 789221) + 1376312589) And $7FFFFFFF);
79

80
  Result := 1.0 - x / 1073741824.0 // make it a [-1;1] affair!
81
end;
82

83
function Perlin_Random2(const x, Y: Integer): Double;
84
begin
85
  // it works! I guess any prime will do!
86
  Result := Perlin_Random1(x + Y * 57);
87
end;
88

89
procedure Perlin_Random1DStrip(x, Width, Step: Integer; Amp: Double;
90
  Res: T1DPerlinArray);
91
var
92
  Posi: PDouble;
93
  XC: Integer;
94
begin
95
  Posi := @Res[0];
96
  For XC := 0 to Width - 1 do
97
  begin
98
    Posi^ := Perlin_Random1(x) * Amp;
99
    inc(Posi);
100
    inc(x, Step);
101
  end;
102
end;
103

104
procedure Smooth_Interpolate_Strip(B1, B2, B3, Res: T1DPerlinArray;
105
  Width: Integer);
106
var
107
  Posi: PDouble;
108
  T1: PDouble;
109
  T2: PDouble;
110
  T3: PDouble;
111

112
  C1: PDouble;
113
  C2: PDouble;
114
  C3: PDouble;
115

116
  L1: PDouble;
117
  L2: PDouble;
118
  L3: PDouble;
119

120
  XC: Integer;
121
begin
122
  Posi := @Res[0];
123
  T1 := @B1[0];
124
  C1 := @B2[0];
125
  L1 := @B3[0];
126

127
  T2 := Pointer(PtrUInt(T1) + SizeOf(Double));
128
  C2 := Pointer(PtrUInt(C1) + SizeOf(Double));
129
  L2 := Pointer(PtrUInt(L1) + SizeOf(Double));
130

131
  T3 := Pointer(PtrUInt(T2) + SizeOf(Double));
132
  C3 := Pointer(PtrUInt(C2) + SizeOf(Double));
133
  L3 := Pointer(PtrUInt(L2) + SizeOf(Double));
134

135
  for XC := 0 to Width - 1 do
136
  begin
137
    Posi^ := (T1^ + T3^ + L1^ + L3^) / 16 + (T2^ + C1^ + C3^ + L2^) / 8
138
      + C2^ / 4;
139
    inc(Posi);
140

141
    T1 := T2;
142
    C1 := C2;
143
    L1 := L2;
144

145
    T2 := T3;
146
    C2 := C3;
147
    L2 := L3;
148

149
    inc(T3);
150
    inc(C3);
151
    inc(L3);
152
  end;
153
end;
154

155
procedure Cubic_Interpolate_Strip(B1, B2, B3, B4, Res: T1DPerlinArray;
156
  Width: Integer);
157
var
158
  Posi: PDouble;
159
  v1: PDouble;
160
  v2: PDouble;
161
  v3: PDouble;
162
  V4: PDouble;
163

164
  H1: PDouble;
165
  H2: PDouble;
166
  H3: PDouble;
167
  H4: PDouble;
168

169
  XC: Integer;
170
begin
171
  Posi := @Res[0];
172
  v1 := @B1[1];
173
  v2 := @B2[1];
174
  v3 := @B3[1];
175
  V4 := @B4[1];
176

177
  H1 := @B2[0];
178
  H2 := @B2[1];
179
  H3 := @B2[2];
180
  H4 := @B2[3];
181

182
  for XC := 0 to Width - 1 do
183
  begin
184
    Posi^ := Cubic_Interpolate(v1^, v2^, v3^, V4^, 0.5) / 2 +
185
      Cubic_Interpolate(H1^, H2^, H3^, H4^, 0.5) / 2;
186
    inc(Posi);
187

188
    H1 := H2;
189
    H2 := H3;
190
    H3 := H4;
191
    inc(H4);
192

193
    inc(v1);
194
    inc(v2);
195
    inc(v3);
196
    inc(V4);
197
  end;
198
end;
199

200
function Linear_Interpolate(const a, b, x: Double): Double;
201
begin
202
  Result := a * (1 - x) + b * x
203
end;
204

205
function Cosine_Interpolate(const a, b, x: Double): Double;
206
var
207
  ft: Double;
208
  f: Double;
209

210
begin
211
  ft := x * pi;
212
  f := (1 - cos(ft)) * 0.5;
213

214
  Result := a * (1 - f) + b * f;
215
end;
216

217
function Cubic_Interpolate(v0, v1, v2, v3, x: Double): Double;
218
var
219
  P, Q, R, S: Double;
220

221
begin
222
  { Result := Cosine_Interpolate(v1,v2,x);
223
    Exit;
224
    v0 := -0.5;
225
    v1 := 0;
226
    v2 := 0;
227
    v3 := -0.5; }
228
  P := (v3 - v2) - (v0 - v1);
229
  Q := (v0 - v1) - P;
230
  R := v2 - v0;
231
  S := v1;
232

233
  Result := (P * x * x * x + Q * x * x + R * x + S);
234
  // If (Abs(Result) > 1) then
235
  // Raise exception.create('Cubic_Interpolate result to high, '+FloatToStr(Result)+' values ['+FloatToStr(v0)+';'+FloatToStr(v1)+';'+FloatToStr(v2)+';'+FloatToStr(v3)+']');{}
236
end;
237

238
end.
239