-
Notifications
You must be signed in to change notification settings - Fork 9
/
GBETerrain.pas
258 lines (216 loc) · 8.26 KB
/
GBETerrain.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
unit GBETerrain;
interface
uses
System.SysUtils, System.Classes, System.Types, FMX.Types, FMX.Controls3D, FMX.Objects3D, FMX.Graphics, Math,
System.Math.Vectors, uGBEUtils3D;
type
TGBETerrain = class(TMesh)
private
{ Déclarations privées }
fAmplitude, fRoughness, fScalling : single;
fOctaves, fSubdivX, fSubdivZ : integer;
fSeed, fXOffset, fZOffset: integer;
FUseRamp : boolean;
function getInterpolatedNoise(x, z: single): single;
function interpolate(a, b, blend: single): single;
function noise(x, z: integer): single;
function smoothNoise(x, z: integer): single;
procedure setUseRamp(const Value: boolean);
function generateHeight(x, z: integer): single;
protected
{ Déclarations protégées }
public
{ Déclarations publiques }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure clean;
procedure generateTerrain;
function GetHeight(P: TPoint3d): single;
published
{ Déclarations publiées }
property Amplitude : single read fAmplitude write fAmplitude;
property Roughness : single read fRoughness write fRoughness;
property Octaves : integer read fOctaves write fOctaves;
property XOffset : integer read fXOffset write fXOffset;
property ZOffset : integer read fZOffset write fZOffset;
property Seed : integer read fSeed write fSeed;
property SubdivX : integer read fSubdivX write fSubdivX;
property SubdivZ : integer read fSubdivZ write fSubdivZ;
property UseRamp : boolean read FUseRamp write setUseRamp;
end;
procedure Register;
implementation
{ TGBETerrain }
function TGBETerrain.generateHeight(x, z: integer): single;
begin
var total := 0.0;
var d := Math.Power(2, fOctaves - 1);
for var i := 0 to fOctaves - 1 do begin
var freq := Math.Power(2, i) / d;
var amp := Math.Power(fRoughness, i) * fAmplitude;
total := total + getInterpolatedNoise((x + fXOffset) * freq, (z + fZOffset) * freq) * amp;
end;
result := total;
end;
{ getInterpolatedNoise return an interpolate value for the height of a position at x and z coordinates }
function TGBETerrain.getInterpolatedNoise(x, z: single): single;
begin
var intX: integer := trunc(x);
var intZ: integer := trunc(z);
var fracX := x - intX;
var fracZ := z - intZ;
{ use the near neighbours points v1, v2, v3, v4 }
var v1 := smoothNoise(intX, intZ);
var v2 := smoothNoise(intX + 1, intZ);
var v3 := smoothNoise(intX, intZ + 1);
var v4 := smoothNoise(intX + 1, intZ + 1);
{ X is the point with x,z coordinates
v1--------i1---v2
| . |
| X |
| . |
| . |
| . |
v3--------i2---v4
}
var i1 := interpolate(v1, v2, fracX);
var i2 := interpolate(v3, v4, fracX);
{ result interpolate i1 and i2 }
result := interpolate(i1, i2, fracZ);
end;
{ Cosine interpolation to be more natural
return an interpolate value between 2 values a and b }
function TGBETerrain.interpolate(a, b, blend: single): single;
begin
var theta := blend * PI;
var f := (1.0 - cos(theta)) * 0.5;
result := a * (1.0 - f) + b * f;
end;
{ smoothNoise use the noise function and the neighbours vertices from a specific vertex }
function TGBETerrain.smoothNoise(x, z: integer): single;
begin
var corners := (noise(x - 1, z - 1) + noise(x + 1, z - 1) + noise(x - 1, z + 1) + noise(x + 1, z + 1)) * 0.125;
var sides := (noise(x - 1, z) + noise(x + 1, z) + noise(x, z - 1) + noise(x, z + 1)) * 0.25;
var center := noise(x, z) * 0.5;
result := corners + sides + center;
end;
{ Nose function is a pure function to return a random number between -1 and 1 }
function TGBETerrain.noise(x, z: integer): single;
begin
randSeed := x * 9158 + z * 41765 + fSeed; // seed value for random
result := random * 2.0 - 1.0; // random return a number between 0 and 1 and we want a number between -1 and 1
end;
procedure TGBETerrain.clean;
begin
data.Clear;
end;
constructor TGBETerrain.Create(AOwner: TComponent);
begin
inherited;
fSeed := random(9999999);
fXOffset := 0;
fZOffset := 0;
UseRamp := false;
HitTest := false;
end;
destructor TGBETerrain.Destroy;
begin
inherited;
end;
{ generate procedural terrain }
procedure TGBETerrain.generateTerrain;
begin
var NP := 0;
var NI := 0;
var yMin := 0.0;
var yMax := 0.0;
var vertexArray : TArray<TPoint3D>;;
fOctaves := octaves;
fAmplitude := amplitude;
fRoughness := roughness;
try
Data.VertexBuffer.Length := Round(subdivX * subdivZ * 4);
setLength(vertexArray, Data.VertexBuffer.Length);
Data.IndexBuffer.Length := Round(subdivX * subdivZ * 6);
// Initialize vertexArray and compute Y for each vertex
var v := 0.0;
while v < subdivZ do begin
var u := 0.0;
while u < subdivX do begin
vertexArray[NP + 0].x := u;
vertexArray[NP + 0].z := v;
vertexArray[NP + 0].Y := generateHeight(trunc(vertexArray[NP + 0].x + fXOffset), trunc(vertexArray[NP + 0].z + fZOffset));
if vertexArray[NP + 0].Y < yMin then yMin := vertexArray[NP + 0].Y;
if vertexArray[NP + 0].Y > yMax then yMax := vertexArray[NP + 0].Y;
vertexArray[NP + 1].x := u + 1;
vertexArray[NP + 1].z := v;
vertexArray[NP + 1].Y := generateHeight(trunc(vertexArray[NP + 1].x + fXOffset), trunc(vertexArray[NP + 1].z + fZOffset));
if vertexArray[NP + 1].Y < yMin then yMin := vertexArray[NP + 1].Y;
if vertexArray[NP + 1].Y > yMax then yMax := vertexArray[NP + 1].Y;
vertexArray[NP + 2].x := u + 1;
vertexArray[NP + 2].z := v + 1;
vertexArray[NP + 2].Y := generateHeight(trunc(vertexArray[NP + 2].x + fXOffset), trunc(vertexArray[NP + 2].z + fZOffset));
if vertexArray[NP + 2].Y < yMin then yMin := vertexArray[NP + 2].Y;
if vertexArray[NP + 2].Y > yMax then yMax := vertexArray[NP + 2].Y;
vertexArray[NP + 3].x := u;
vertexArray[NP + 3].z := v + 1;
vertexArray[NP + 3].Y := generateHeight(trunc(vertexArray[NP + 3].x + fXOffset), trunc(vertexArray[NP + 3].z + fZOffset));
if vertexArray[NP + 3].Y < yMin then yMin := vertexArray[NP + 3].Y;
if vertexArray[NP + 3].Y > yMax then yMax := vertexArray[NP + 3].Y;
NP := NP + 4;
u := u + 1;
end;
v := v +1;
end;
if yMax-yMin > 0 then fScalling := self.Height / (yMax - yMin)
else fScalling := 1;
var heightToColor := 255/(abs(yMin) + abs(yMax))/255;
var i := 0;
NP := 0;
while i < length(vertexArray) -3 do begin
with Data do begin
with VertexBuffer do begin
Vertices[NP + 0] := vertexArray[i+0];
Vertices[NP + 1] := vertexArray[i+1];
Vertices[NP + 2] := vertexArray[i+2];
Vertices[NP + 3] := vertexArray[i+3];
if useRamp then begin
TexCoord0[NP + 0] := PointF((vertexArray[i+0].Y + abs(yMin)) * heightToColor, 0);
TexCoord0[NP + 1] := PointF((vertexArray[i+1].Y + abs(yMin)) * heightToColor, 0);
TexCoord0[NP + 2] := PointF((vertexArray[i+2].Y + abs(yMin)) * heightToColor, 0);
TexCoord0[NP + 3] := PointF((vertexArray[i+3].Y + abs(yMin)) * heightToColor, 0);
end else begin
TexCoord0[NP + 0] := PointF((vertexArray[i+0].x) / subdivX, (vertexArray[i+0].z) / subdivZ);
TexCoord0[NP + 1] := PointF((vertexArray[i+1].x) / subdivX, (vertexArray[i+1].z) / subdivZ);
TexCoord0[NP + 2] := PointF((vertexArray[i+2].x) / subdivX, (vertexArray[i+2].z) / subdivZ);
TexCoord0[NP + 3] := PointF((vertexArray[i+3].x) / subdivX, (vertexArray[i+3].z) / subdivZ);
end;
end;
IndexBuffer[NI + 0] := NP + 0;
IndexBuffer[NI + 1] := NP + 1;
IndexBuffer[NI + 2] := NP + 3;
IndexBuffer[NI + 3] := NP + 3;
IndexBuffer[NI + 4] := NP + 1;
IndexBuffer[NI + 5] := NP + 2;
end;
NP := NP + 4;
NI := NI + 6;
inc(i,4);
end;
Data.CalcTangentBinormals;
finally
end;
end;
procedure TGBETerrain.setUseRamp(const Value: boolean);
begin
if Value <> FUseRamp then FUseRamp := Value;
end;
function TGBETerrain.GetHeight(P: TPoint3d): single;
begin
result := CalculerHauteur(self, P, fScalling, fSubdivX, fSubDivZ);
end;
procedure Register;
begin
RegisterComponents('GBE3D', [TGBETerrain]);
end;
end.