LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   A plane simulating animated water
6

7
	 History :  
8
       10/11/12 - PW - Added CPP compatibility: changed vector arrays to records
9
       23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
10
       30/03/07 - DaStr - Added $I GLScene.inc
11
       22/09/04 - R.Cao - Added AxisAlignedDimensionsUnscaled to fix visibility culling
12
       02/04/03 - EG - More optimizations, mask support
13
       01/04/03 - EG - Cleanup and optimizations
14
       14/11/03 - Mrqzzz - Tried "CreateRippleAtWorldPos" to work at any position/rotation, but need expert's help.. :(
15
       13/11/03 - Mrqzzz - Tried to add timing indipendence (quite not precise yet)
16
       12/11/03 - Mrqzzz - Added some properties & small optims added
17
       01/01/03 - Sternas Stefanos - Original code
18
    
19

20
   The Original Code is part of Cosmos4D 
21
   http://users.hol.gr/~sternas/ 
22
   Sternas Stefanos 2003
23
}
24
unit GLWaterPlane;
25

26
interface
27

28
{$I GLScene.inc}
29

30
uses
31
  Classes,
32
  GLVectorGeometry, GLScene, OpenGLTokens, GLVectorLists,
33
  GLCrossPlatform, GLPersistentClasses, GLBaseClasses,
34
  GLContext, GLRenderContextInfo, GLVectorTypes;
35

36
type
37

38
   // TGLWaterPlaneOption
39
   //
40
   TGLWaterPlaneOption = (wpoTextured);
41
   TGLWaterPlaneOptions = set of TGLWaterPlaneOption;
42

43
const
44
   cDefaultWaterPlaneOptions = [wpoTextured];
45

46
type
47

48
   // TGLWaterPlane
49
   //
50
   TGLWaterPlane = class (TGLSceneObject)
51
		private
52
          
53
         FLocks : packed array of ByteBool;
54
         FPositions, FVelocity : packed array of Single;
55
         FPlaneQuadIndices : TPersistentObjectList;
56
         FPlaneQuadTexCoords : TTexPointList;
57
         FPlaneQuadVertices : TAffineVectorList;
58
         FPlaneQuadNormals : TAffineVectorList;
59
         FActive : Boolean;
60
         FRainTimeInterval : Integer;
61
         FRainForce : Single;
62
         FViscosity : Single;
63
         FElastic : Single;
64
         FResolution : Integer;
65
         FSimulationFrequency, FTimeToNextUpdate : Single;
66
         FTimeToNextRainDrop : Single;
67
         FMaximumCatchupIterations : Integer;
68
         FLastIterationStepTime : Single;
69
         FMask : TGLPicture;
70
         FOptions : TGLWaterPlaneOptions;
71

72
      protected
73
          
74
         procedure SetElastic(const value : Single);
75
         procedure SetResolution(const value : Integer);
76
         procedure SetRainTimeInterval(const val : Integer);
77
         procedure SetViscosity(const val : Single);
78
         procedure SetRainForce(const val : Single);
79
         procedure SetSimulationFrequency(const val : Single);
80
         procedure SetMask(val : TGLPicture);
81
         procedure SetOptions(const val : TGLWaterPlaneOptions);
82

83
         procedure DoMaskChanged(Sender : TObject);
84
         procedure InitResolution;
85

86
         procedure IterComputeVelocity;
87
         procedure IterComputePositions;
88
         procedure IterComputeNormals;
89
         procedure Iterate;
90

91
      public
92
          
93
         constructor Create(AOwner : TComponent); override;
94
         destructor Destroy; override;
95

96
         procedure DoProgress(const progressTime : TProgressTimes); override;
97
         procedure BuildList(var rci : TGLRenderContextInfo); override;
98
         procedure Assign(Source: TPersistent); override;
99
         function AxisAlignedDimensionsUnscaled : TVector; override;
100

101
         
102
         procedure CreateRippleAtGridPos(X,Y:integer);
103
         procedure CreateRippleAtWorldPos(const x, y, z : Single); overload;
104
         procedure CreateRippleAtWorldPos(const pos : TVector); overload;
105
         procedure CreateRippleRandom;
106
         procedure Reset;
107

108
         { CPU time (in seconds) taken by the last iteration step. }
109
         property LastIterationStepTime : Single read FLastIterationStepTime;
110

111
      published
112
          
113
         
114
         property Active : Boolean read FActive write FActive default True;
115

116
         { Delay between raindrops in milliseconds (0 = no rain) }
117
         property RainTimeInterval : Integer read FRainTimeInterval write SetRainTimeInterval default 500;
118
         property RainForce : Single read FRainForce write SetRainForce;
119

120
         property Viscosity : Single read FViscosity write SetViscosity ;
121
         property Elastic : Single read FElastic write SetElastic;
122
         property Resolution : Integer read FResolution write SetResolution default 64;
123
         property Options : TGLWaterPlaneOptions read FOptions write SetOptions default cDefaultWaterPlaneOptions;
124

125
         { A picture whose pixels determine what part of the waterplane is active.
126
            Pixels with a green/gray component beyond 128 are active, the others
127
            are not (in short, white = active, black = inactive).
128
            The picture will automatically be stretched to match the resolution. }
129
         property Mask : TGLPicture read FMask write SetMask;
130

131
         { Maximum frequency (in Hz) at which simulation iterations happen. }
132
         property SimulationFrequency : Single read FSimulationFrequency write SetSimulationFrequency;
133
         { Maximum number of simulation iterations during catchups.
134
            Catchups happen when for a reason or another, the DoProgress doesn't
135
            happen as fast SimulationFrequency. }
136
         property MaximumCatchupIterations : Integer read FMaximumCatchupIterations write FMaximumCatchupIterations default 1;
137
   end;
138

139
//-------------------------------------------------------------
140
//-------------------------------------------------------------
141
//-------------------------------------------------------------
142
implementation
143
//-------------------------------------------------------------
144
//-------------------------------------------------------------
145
//-------------------------------------------------------------
146

147
// Create
148
//
149
constructor TGLWaterPlane.Create(AOwner : TComponent);
150
begin
151
   inherited Create(AOwner);
152
   ObjectStyle:=ObjectStyle+[osDirectDraw];
153

154
   FElastic:=10;
155
   FActive:=True;
156
   FRainTimeInterval:=500;
157
   FRainForce:=5000;
158
   FViscosity:=0.99;
159
   FSimulationFrequency:=100; // 100 Hz
160
   FMaximumCatchupIterations:=1;
161
   FOptions:=cDefaultWaterPlaneOptions;
162

163
   FPlaneQuadIndices:=TPersistentObjectList.Create;
164
   FPlaneQuadTexCoords:=TTexPointList.Create;
165
   FPlaneQuadVertices:=TAffineVectorList.Create;
166
   FPlaneQuadNormals:=TAffineVectorList.Create;
167
   FMask:=TGLPicture.Create;
168
   FMask.OnChange:=DoMaskChanged;
169

170
   SetResolution(64);
171
end;
172

173
// Destroy
174
//
175
destructor TGLWaterPlane.Destroy;
176
begin
177
   FMask.Free;
178
   FPlaneQuadNormals.Free;
179
   FPlaneQuadVertices.Free;
180
   FPlaneQuadTexCoords.Free;
181
   FPlaneQuadIndices.CleanFree;
182
   inherited;
183
end;
184

185
// DoProgress
186
//
187
procedure TGLWaterPlane.DoProgress(const progressTime : TProgressTimes);
188
var
189
   i : Integer;
190
begin
191
   inherited;
192
   if Active and Visible then begin
193
      // new raindrops
194
      if FRainTimeInterval>0 then begin
195
         FTimeToNextRainDrop:=FTimeToNextRainDrop-progressTime.deltaTime;
196
         i:=FMaximumCatchupIterations;
197
         while FTimeToNextRainDrop<=0 do begin
198
            CreateRippleRandom;
199
            FTimeToNextRainDrop:=FTimeToNextRainDrop+FRainTimeInterval*0.001;
200
            Dec(i);
201
            if i<0 then begin
202
               if FTimeToNextRainDrop<0 then FTimeToNextRainDrop:=FRainTimeInterval*0.001;
203
               Break;
204
            end;
205
         end;
206
      end;
207
      // iterate simulation
208
      FTimeToNextUpdate:=FTimeToNextUpdate-progressTime.deltaTime;
209
      if FTimeToNextUpdate<=0 then begin
210
         i:=FMaximumCatchupIterations;
211
         while FTimeToNextUpdate<=0 do begin
212
            Iterate;
213
            FTimeToNextUpdate:=FTimeToNextUpdate+1/FSimulationFrequency;
214
            Dec(i);
215
            if i<0 then begin
216
               if FTimeToNextUpdate<0 then FTimeToNextUpdate:=1/FSimulationFrequency;
217
               Break;
218
            end;
219
         end;
220
         StructureChanged;
221
      end;
222
   end;
223
end;
224

225
// CreateRippleAtGridPos
226
//
227
procedure TGLWaterPlane.CreateRippleAtGridPos(x, y : Integer);
228
begin
229
   if (x>0) and (y>0) and (x<Resolution-1) and (y<Resolution-1) then
230
      FVelocity[x+y*Resolution]:=FRainForce;
231
end;
232

233
// CreateRippleAtWorldPos
234
//
235
procedure TGLWaterPlane.CreateRippleAtWorldPos(const x, y, z : Single);
236
var
237
   vv : TVector;
238
begin
239
   vv:=AbsoluteToLocal(PointMake(x, y, z));
240
   CreateRippleAtGridPos(Round((vv.V[0]+0.5)*Resolution),
241
                         Round((vv.V[2]+0.5)*Resolution));
242
end;
243

244
// CreateRippleAtWorldPos
245
//
246
procedure TGLWaterPlane.CreateRippleAtWorldPos(const pos : TVector);
247
var
248
   vv : TVector;
249
begin
250
   vv:=AbsoluteToLocal(PointMake(pos));
251
   CreateRippleAtGridPos(Round((vv.V[0]+0.5)*Resolution),
252
                         Round((vv.V[2]+0.5)*Resolution));
253
end;
254

255
// CreateRippleRandom
256
//
257
procedure TGLWaterPlane.CreateRippleRandom;
258
begin
259
   CreateRippleAtGridPos(Random(Resolution-3)+2, Random(Resolution-3)+2);
260
end;
261

262
// InitResolution
263
//
264
procedure TGLWaterPlane.InitResolution;
265
var
266
   i, j : Integer;
267
   v : TAffineVector;
268
   resSqr : Integer;
269
   invResol : Single;
270
begin
271
   resSqr:=FResolution*FResolution;
272
   FPlaneQuadIndices.Capacity:=resSqr*2;
273
   FPlaneQuadTexCoords.Clear;
274
   FPlaneQuadTexCoords.Capacity:=resSqr;
275
   FPlaneQuadVertices.Clear;
276
   FPlaneQuadVertices.Capacity:=resSqr;
277

278
   invResol:=1/Resolution;
279
   for j:=0 to Resolution-1 do begin
280
      for i:=0 to Resolution-1 do begin
281
         FPlaneQuadTexCoords.Add(i*invResol, j*invResol);
282
         FPlaneQuadVertices.Add((i-Resolution*0.5)*invResol,
283
                                0,
284
                                (j-Resolution*0.5)*invResol);
285
      end;
286
   end;
287

288
   FPlaneQuadNormals.Count:=resSqr;
289
   v.V[0]:=0;
290
   v.V[1]:=2048;
291
   v.V[2]:=0;
292
   for i:=0 to FPlaneQuadNormals.Count-1 do
293
      FPlaneQuadNormals.List[i]:=v;
294

295
   SetLength(FPositions, resSqr);
296
   SetLength(FVelocity, resSqr);
297
   SetLength(FLocks, resSqr);
298

299
   Reset;
300
   Iterate;
301

302
   StructureChanged;
303
end;
304

305
// Reset
306
//
307
procedure TGLWaterPlane.Reset;
308
var
309
   i, j, ij, resSqr : Integer;
310
   maskBmp : TGLBitmap;
311
   scanLine : PIntegerArray;
312
   il : TIntegerList;
313
   locked : Boolean;
314
begin
315
   resSqr:=FResolution*FResolution;
316
   for i:=0 to resSqr-1 do begin
317
      FPositions[i]:=0;
318
      FVelocity[i]:=0;
319
      FLocks[i]:=False;
320
   end;
321
   if FMask.Width>0 then begin
322
      maskBmp:=TGLBitmap.Create;
323
      try
324
         maskBmp.PixelFormat:=glpf32bit;
325
         maskBmp.Width:=Resolution;
326
         maskBmp.Height:=Resolution;
327
         maskBmp.Canvas.StretchDraw(Rect(0, 0, Resolution, Resolution), FMask.Graphic);
328
         for j:=0 to Resolution-1 do begin
329
            scanLine:=BitmapScanLine(maskBmp, Resolution-1-j); //maskBmp.ScanLine[Resolution-1-j];
330
            for i:=0 to Resolution-1 do
331
               FLocks[i+j*Resolution]:=(((scanLine[i] shr 8) and $FF)<128);
332
         end;
333
      finally
334
         maskBmp.Free;
335
      end;
336
   end;
337

338
   FPlaneQuadIndices.Clean;
339
   for j:=0 to Resolution-2 do begin
340
      il:=TIntegerList.Create;
341
      for i:=0 to Resolution-1 do begin
342
         ij:=i+j*Resolution;
343
         if (il.Count and 2)<>0 then
344
            locked:=False
345
         else begin
346
            locked:=FLocks[ij] and FLocks[ij+Resolution];
347
            if locked and (i<Resolution-1) then
348
               locked:=FLocks[ij+1] and FLocks[ij+Resolution+1];
349
         end;
350
         if not locked then
351
            il.Add(ij, ij+Resolution)
352
         else if il.Count>0 then begin
353
            FPlaneQuadIndices.Add(il);
354
            il:=TIntegerList.Create;
355
         end;
356
      end;
357
      if il.Count>0 then
358
         FPlaneQuadIndices.Add(il)
359
      else il.Free;
360
   end;
361
end;
362

363
// IterComputeVelocity
364
//
365
procedure TGLWaterPlane.IterComputeVelocity;
366
var
367
   i, j, ij : Integer;
368
   f1, f2 : Single;
369
   posList, velList : PSingleArray;
370
   lockList : PByteArray;
371
begin
372
   f1:=0.05;
373
   f2:=0.01*FElastic;
374

375
   posList:=@FPositions[0];
376
   velList:=@FVelocity[0];
377
   lockList:=@FLocks[0];
378
   for i:=1 to Resolution-2 do begin
379
      ij:=i*Resolution;
380
      for j:=1 to Resolution-2 do begin
381
         Inc(ij);
382
         if lockList[ij]<>0 then continue;
383
         velList[ij]:= velList[ij]
384
                      +f2*( posList[ij]
385
                           -f1*( 4*( posList[ij-1]         +posList[ij+1]
386
                                    +posList[ij-Resolution]+posList[ij+Resolution])
387
                                +posList[ij-1-Resolution]+posList[ij+1-Resolution]
388
                                +posList[ij-1+Resolution]+posList[ij+1+Resolution]));
389
      end;
390
   end;
391
end;
392

393
// IterComputePositions
394
//
395
procedure TGLWaterPlane.IterComputePositions;
396
const
397
   cVelocityIntegrationCoeff : Single = 0.02;
398
   cHeightFactor : Single = 1e-4;
399
var
400
   ij : Integer;
401
   f  : Single;
402
   coeff : Single;
403
   posList, velList : PSingleArray;
404
   lockList : PByteArray;
405
begin
406
   // Calculate the new ripple positions and update vertex coordinates
407
   coeff:=cVelocityIntegrationCoeff*Resolution;
408
   f:=cHeightFactor/Resolution;
409
   posList:=@FPositions[0];
410
   velList:=@FVelocity[0];
411
   lockList:=@FLocks[0];
412
   for ij:=0 to Resolution*Resolution-1 do begin
413
      if lockList[ij]=0 then begin
414
         posList[ij]:=posList[ij]-coeff*velList[ij];
415
         velList[ij]:=velList[ij]*FViscosity;
416
         FPlaneQuadVertices.List[ij].V[1]:=posList[ij]*f;
417
      end;
418
   end;
419
end;
420

421
// IterComputeNormals
422
//
423
procedure TGLWaterPlane.IterComputeNormals;
424
var
425
   i, j, ij : Integer;
426
   pv : PAffineVector;
427
   posList : PSingleArray;
428
   normList : PAffineVectorArray;
429
begin
430
   // Calculate the new vertex normals (not normalized, the hardware will handle that)
431
   posList:=@FPositions[0];
432
   normList:=FPlaneQuadNormals.List;
433
   for i:=1 to Resolution-2 do begin
434
      ij:=i*Resolution;
435
      for j:=1 to Resolution-2 do begin
436
         Inc(ij);
437
         pv:=@normList[ij];
438
         pv.V[0]:=posList[ij+1]-posList[ij-1];
439
         pv.V[2]:=posList[ij+Resolution]-posList[ij-Resolution];
440
      end;
441
   end;
442
end;
443

444
// Iterate
445
//
446
procedure TGLWaterPlane.Iterate;
447
var
448
   t : Int64;
449
begin
450
   if Visible then begin
451
      t:=StartPrecisionTimer;
452

453
      IterComputeVelocity;
454
      IterComputePositions;
455
      IterComputeNormals;
456

457
      FLastIterationStepTime:=StopPrecisionTimer(t);
458
   end;
459
end;
460

461
// BuildList
462
//
463
procedure TGLWaterPlane.BuildList(var rci : TGLRenderContextInfo);
464
var
465
   i : Integer;
466
   il : TIntegerList;
467
begin
468
   GL.PushClientAttrib(GL_CLIENT_VERTEX_ARRAY_BIT);
469

470
   GL.EnableClientState(GL_VERTEX_ARRAY);
471
   GL.VertexPointer(3, GL_FLOAT, 0, FPlaneQuadVertices.List);
472
   GL.EnableClientState(GL_NORMAL_ARRAY);
473
   GL.NormalPointer(GL_FLOAT, 0, FPlaneQuadNormals.List);
474
   if wpoTextured in Options then begin
475
      GL.EnableClientState(GL_TEXTURE_COORD_ARRAY);
476
      GL.TexCoordPointer(2, GL_FLOAT, 0, FPlaneQuadTexCoords.List);
477
   end else GL.DisableClientState(GL_TEXTURE_COORD_ARRAY);
478

479
   if GL.EXT_compiled_vertex_array then
480
      GL.LockArrays(0, FPlaneQuadVertices.Count);
481

482
   for i:=0 to FPlaneQuadIndices.Count-1 do begin
483
      il:=TIntegerList(FPlaneQuadIndices[i]);
484
      GL.DrawElements(GL_QUAD_STRIP, il.Count, GL_UNSIGNED_INT, il.List);
485
   end;
486

487
   if GL.EXT_compiled_vertex_array then
488
      GL.UnLockArrays;
489

490
   GL.PopClientAttrib;
491
end;
492

493
 
494
//
495
procedure TGLWaterPlane.Assign(Source: TPersistent);
496
begin
497
   if Assigned(Source) and (Source is TGLWaterPlane) then begin
498
      Active:=TGLWaterPlane(Source).Active;
499
      RainTimeInterval:=TGLWaterPlane(Source).RainTimeInterval;
500
      RainForce:=TGLWaterPlane(Source).RainForce;
501
      Viscosity:=TGLWaterPlane(Source).Viscosity;
502
   end;
503
   inherited Assign(Source);
504
end;
505

506
// AxisAlignedDimensionsUnscaled
507
//
508
function TGLWaterPlane.AxisAlignedDimensionsUnscaled : TVector;
509
begin
510
  Result.V[0]:=0.5*Abs(Resolution);
511
  Result.V[1]:=0;
512
  Result.V[2]:=0.5*Abs(FResolution);
513
end;
514

515

516
// SetElastic
517
//
518
procedure TGLWaterPlane.SetElastic(const Value: single);
519
begin
520
   FElastic:=Value;
521
end;
522

523
// SetResolution
524
//
525
procedure TGLWaterPlane.SetResolution(const value : Integer);
526
begin
527
   if value<>FResolution then begin
528
      FResolution:=Value;
529
      if FResolution<16 then FResolution:=16;
530
      InitResolution;
531
   end;
532
end;
533

534
// SetRainTimeInterval
535
//
536
procedure TGLWaterPlane.SetRainTimeInterval(Const val:integer);
537
begin
538
   if (val>=0) and (Val<=1000000) then
539
      fRainTimeInterval:=val;
540
end;
541

542
// SetViscosity
543
//
544
Procedure TGLWaterPlane.SetViscosity(const val : Single);
545
begin
546
   if (val>=0) and (val<=1) then
547
      FViscosity:=val;
548
end;
549

550
// SetRainForce
551
//
552
procedure TGLWaterPlane.SetRainForce(const val : Single);
553
begin
554
   if (val>=0) and (val<=1000000) then
555
      FRainForce:=val;
556
end;
557

558
// SetSimulationFrequency
559
//
560
procedure TGLWaterPlane.SetSimulationFrequency(const val : Single);
561
begin
562
   if FSimulationFrequency<>val then begin
563
      FSimulationFrequency:=val;
564
      if FSimulationFrequency<1 then FSimulationFrequency:=1;
565
      FTimeToNextUpdate:=0;
566
   end;
567
end;
568

569
// SetMask
570
//
571
procedure TGLWaterPlane.SetMask(val : TGLPicture);
572
begin
573
   FMask.Assign(val);
574
end;
575

576
// DoMaskChanged
577
//
578
procedure TGLWaterPlane.DoMaskChanged(Sender : TObject);
579
begin
580
   Reset;
581
   StructureChanged;
582
end;
583

584
// SetOptions
585
//
586
procedure TGLWaterPlane.SetOptions(const val : TGLWaterPlaneOptions);
587
begin
588
   if FOptions<>val then begin
589
      FOptions:=val;
590
      StructureChanged;
591
   end;
592
end;
593

594
//-------------------------------------------------------------
595
//-------------------------------------------------------------
596
//-------------------------------------------------------------
597

598
initialization
599
//-------------------------------------------------------------
600
//-------------------------------------------------------------
601
//-------------------------------------------------------------
602

603
   RegisterClasses([TGLWaterPlane]);
604

605
end.
606