LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   Implements basic shadow volumes support.
6

7
   Be aware that only objects that support silhouette determination have a chance
8
   to cast correct shadows. Transparent/blended/shader objects among the receivers
9
   or the casters will be rendered incorrectly.
10

11
  History :  
12
       23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
13
       31/05/10 - Yar - Fixes forLinux x64
14
       01/05/10 - Yar - Moved ignoreBlendingRequests and ignoreDepthRequests behind RenderChildren
15
       22/04/10 - Yar - Fixes after GLState revision
16
       05/03/10 - DanB - More state added to TGLStateCache
17
       31/03/07 - DaStr - Fixed issue with invalid typecasting
18
                            (thanks Burkhard Carstens) (Bugtracker ID = 1692016)
19
       30/03/07 - DaStr - Added $I GLScene.inc
20
       28/03/07 - DaStr - Renamed parameters in some methods
21
                             (thanks Burkhard Carstens) (Bugtracker ID = 1678658)
22
       08/12/04 - DB - Fixed bug in TGLShadowVolumeCaster.SetCaster
23
       02/12/04 - MF - Added some documentation
24
       23/03/04 - EG - Added Active property
25
       29/11/03 - MF - Removed a "feature" that would draw the shadow of
26
                          (hierarchially) invisible objects
27
       27/11/03 - MF - TGLShadowVolumeCaster now registers with the FCaster
28
                          for delete notification
29
       11/06/03 - EG - Added silhouette cache
30
       04/06/03 - EG - Creation (based on code from Mattias Fagerlund)
31
   
32
}
33
unit GLShadowVolume;
34

35
interface
36

37
{$I GLScene.inc}
38

39
uses
40
  Classes,
41
  GLScene, GLVectorGeometry, OpenGLTokens, GLContext, GLSilhouette,
42
  GLCrossPlatform, GLPersistentClasses, GLGeometryBB, GLColor,
43
  GLRenderContextInfo;
44

45
type
46

47
  TGLShadowVolume = class;
48

49
  { Determines when a shadow volume should generate a cap at the beginning and
50
   end of the volume. This is ONLY necessary when there's a chance that the
51
   camera could end up inside the shadow _or_ between the light source and
52
   the camera. If those two situations can't occur then not using capping is
53
   the best option. 
54
   Note that if you use the capping, you must either set the depth of view of
55
   your camera to something very large (f.i. 1e9), or you could use the infinite
56
   mode (csInfinitePerspective) of your camera.
57
    
58
      svcDefault : Default behaviour
59
      svcAlways : Always generates caps
60
      svcNever : Never generates caps
61
    
62
   }
63
  TGLShadowVolumeCapping = (svcDefault, svcAlways, svcNever);
64

65
  { Determines when a caster should actually produce a shadow;
66
   
67
    scmAlways : Caster always produces a shadow, ignoring visibility
68
    scmVisible : Caster casts shadow if the object has visible=true
69
    scmRecursivelyVisible : Caster casts shadow if ancestors up the hierarchy
70
     all have visible=true
71
    scmParentVisible : Caster produces shadow if parent has visible=true
72
    scmParentRecursivelyVisible : Caster casts shadow if ancestors up the hierarchy
73
     all have visible=true, starting from the parent (ignoring own visible setting)
74
    }
75

76
  TGLShadowCastingMode = (scmAlways, scmVisible, scmRecursivelyVisible,
77
    scmParentVisible, scmParentRecursivelyVisible);
78

79
  // TGLShadowVolumeCaster
80
  //
81
  { Specifies an individual shadow caster.
82
     Can be a light or an opaque object. }
83
  TGLShadowVolumeCaster = class(TCollectionItem)
84
  private
85
     
86
    FCaster: TGLBaseSceneObject;
87
    FEffectiveRadius: Single;
88
    FCapping: TGLShadowVolumeCapping;
89
    FCastingMode: TGLShadowCastingMode;
90

91
  protected
92
     
93
    procedure SetCaster(const val: TGLBaseSceneObject);
94
    function GetGLShadowVolume: TGLShadowVolume;
95

96
    procedure RemoveNotification(aComponent: TComponent);
97
    function GetDisplayName: string; override;
98

99
  public
100
     
101
    constructor Create(ACollection: TCollection); override;
102
    destructor Destroy; override;
103

104
    procedure Assign(Source: TPersistent); override;
105

106
    { Shadow casting object.
107
       Can be an opaque object or a lightsource. }
108
    property Caster: TGLBaseSceneObject read FCaster write SetCaster;
109

110
    property GLShadowVolume: TGLShadowVolume read GetGLShadowVolume;
111

112
  published
113
     
114

115
          { Radius beyond which the caster can be ignored.
116
             Zero (default value) means the caster can never be ignored. }
117
    property EffectiveRadius: Single read FEffectiveRadius write
118
      FEffectiveRadius;
119
    { Specifies if the shadow volume should be capped.
120
       Capping helps solve shadowing artefacts, at the cost of performance. }
121
    property Capping: TGLShadowVolumeCapping read FCapping write FCapping default
122
      svcDefault;
123
    { Determines when an object should cast a shadow or not. Typically, objects
124
    should only cast shadows when recursively visible. But if you're using
125
    dummy shadow casters which are less complex than their parent objects,
126
    you should use scmParentRecursivelyVisible.}
127
    property CastingMode: TGLShadowCastingMode read FCastingMode write
128
      FCastingMode default scmRecursivelyVisible;
129
  end;
130

131
  // TGLShadowVolumeOccluder
132
  //
133
  { Specifies an individual shadow casting occluder. }
134
  TGLShadowVolumeOccluder = class(TGLShadowVolumeCaster)
135
  published
136
     
137
    property Caster;
138
  end;
139

140
  // TGLShadowVolumeLight
141
  //
142
  { Specifies an individual shadow casting light. }
143
  TGLShadowVolumeLight = class(TGLShadowVolumeCaster)
144
  private
145
     
146
    FSilhouettes: TPersistentObjectList;
147

148
  protected
149
     
150
    function GetLightSource: TGLLightSource;
151
    procedure SetLightSource(const ls: TGLLightSource);
152

153
    function GetCachedSilhouette(AIndex: Integer): TGLSilhouette;
154
    procedure StoreCachedSilhouette(AIndex: Integer; ASil: TGLSilhouette);
155

156
    { Compute and setup scissor clipping rect for the light.
157
       Returns true if a scissor rect was setup }
158
    function SetupScissorRect(worldAABB: PAABB; var rci: TGLRenderContextInfo):
159
      Boolean;
160

161
  public
162
     
163
    constructor Create(ACollection: TCollection); override;
164
    destructor Destroy; override;
165

166
    procedure FlushSilhouetteCache;
167

168
  published
169
     
170
          { Shadow casting lightsource. }
171
    property LightSource: TGLLightSource read GetLightSource write
172
      SetLightSource;
173

174
  end;
175

176
  // TGLShadowVolumeCasters
177
  //
178
  { Collection of TGLShadowVolumeCaster. }
179
  TGLShadowVolumeCasters = class(TOwnedCollection)
180
  private
181
     
182

183
  protected
184
     
185
    function GetItems(index: Integer): TGLShadowVolumeCaster;
186
    procedure RemoveNotification(aComponent: TComponent);
187

188
  public
189
     
190
    function AddCaster(obj: TGLBaseSceneObject; effectiveRadius: Single = 0;
191
      CastingMode: TGLShadowCastingMode = scmRecursivelyVisible):
192
      TGLShadowVolumeCaster;
193
    procedure RemoveCaster(obj: TGLBaseSceneObject);
194
    function IndexOfCaster(obj: TGLBaseSceneObject): Integer;
195

196
    property Items[index: Integer]: TGLShadowVolumeCaster read GetItems;
197
    default;
198
  end;
199

200
  // TGLShadowVolumeOption
201
  //
202
  { Shadow volume rendering options/optimizations.
203
      
204
      svoShowVolumes : make the shadow volumes visible
205
      svoDesignVisible : the shadow are visible at design-time
206
      svoCacheSilhouettes : cache shadow volume silhouettes, beneficial when
207
        some objects are static relatively to their light(s)
208
      svoScissorClips : use scissor clipping per light, beneficial when
209
        lights are attenuated and don't illuminate the whole scene
210
      svoWorldScissorClip : use scissor clipping for the world, beneficial
211
        when shadow receivers don't cover the whole viewer surface
212
       }
213
  TGLShadowVolumeOption = (svoShowVolumes, svoCacheSilhouettes, svoScissorClips,
214
    svoWorldScissorClip, svoDesignVisible);
215
  TGLShadowVolumeOptions = set of TGLShadowVolumeOption;
216

217
  // TGLShadowVolumeMode
218
  //
219
  { Shadow rendering modes.
220
      
221
      svmAccurate : will render the scene with ambient lighting only, then
222
        for each light will make a diffuse+specular pass
223
      svmDarkening : renders the scene with lighting on as usual, then darkens
224
        shadowed areas (i.e. inaccurate lighting, but will "shadow" objects
225
        that don't honour to diffuse or specular lighting)
226
      svmOff : no shadowing will take place
227
       }
228
  TGLShadowVolumeMode = (svmAccurate, svmDarkening, svmOff);
229

230
  // TGLShadowVolume
231
  //
232
  { Simple shadow volumes.
233
     Shadow receiving objects are the ShadowVolume's children, shadow casters
234
     (opaque objects or lights) must be explicitly specified in the Casters
235
     collection.
236
     Shadow volumes require that the buffer allows stencil buffers,
237
     GLSceneViewer.Buffer.ContextOptions contain roStencinBuffer. Without stencil
238
     buffers, shadow volumes will not work properly.
239
     Another issue to look out for is the fact that shadow volume capping requires
240
     that the camera depth of view is either very high (fi 1e9) or that the
241
     camera style is csInfinitePerspective.
242
      }
243
  TGLShadowVolume = class(TGLImmaterialSceneObject)
244
  private
245
     
246
    FActive: Boolean;
247
    FRendering: Boolean;
248
    FLights: TGLShadowVolumeCasters;
249
    FOccluders: TGLShadowVolumeCasters;
250
    FCapping: TGLShadowVolumeCapping;
251
    FOptions: TGLShadowVolumeOptions;
252
    FMode: TGLShadowVolumeMode;
253
    FDarkeningColor: TGLColor;
254

255
  protected
256
     
257
    procedure Notification(AComponent: TComponent; Operation: TOperation);
258
      override;
259

260
    procedure SetActive(const val: Boolean);
261
    procedure SetLights(const val: TGLShadowVolumeCasters);
262
    procedure SetOccluders(const val: TGLShadowVolumeCasters);
263
    procedure SetOptions(const val: TGLShadowVolumeOptions);
264
    procedure SetMode(const val: TGLShadowVolumeMode);
265
    procedure SetDarkeningColor(const val: TGLColor);
266

267
  public
268
     
269
    constructor Create(AOwner: TComponent); override;
270
    destructor Destroy; override;
271

272
    procedure DoRender(var ARci: TGLRenderContextInfo;
273
      ARenderSelf, ARenderChildren: Boolean); override;
274

275
    procedure Assign(Source: TPersistent); override;
276

277
    procedure FlushSilhouetteCache;
278

279
  published
280
     
281
          { Determines if shadow volume rendering is active.
282
             When set to false, children will be rendered without any shadowing
283
             or multipass lighting. }
284
    property Active: Boolean read FActive write SetActive default True;
285
    { Lights that cast shadow volumes. }
286
    property Lights: TGLShadowVolumeCasters read FLights write SetLights;
287
    { Occluders that cast shadow volumes. }
288
    property Occluders: TGLShadowVolumeCasters read FOccluders write
289
      SetOccluders;
290

291
    { Specifies if the shadow volume should be capped.
292
       Capping helps solve shadowing artefacts, at the cost of performance. }
293
    property Capping: TGLShadowVolumeCapping read FCapping write FCapping default
294
      svcAlways;
295
    { Shadow volume rendering options. }
296
    property Options: TGLShadowVolumeOptions read FOptions write SetOptions
297
      default [svoCacheSilhouettes, svoScissorClips];
298
    { Shadow rendering mode. }
299
    property Mode: TGLShadowVolumeMode read FMode write SetMode default
300
      svmAccurate;
301
    { Darkening color used in svmDarkening mode. }
302
    property DarkeningColor: TGLColor read FDarkeningColor write
303
      SetDarkeningColor;
304
  end;
305

306
  //-------------------------------------------------------------
307
  //-------------------------------------------------------------
308
  //-------------------------------------------------------------
309
implementation
310
//-------------------------------------------------------------
311
//-------------------------------------------------------------
312
//-------------------------------------------------------------
313

314
uses
315
  SysUtils,
316
  GLVectorLists,
317
  GLState
318
  , GLVectorTypes;
319

320
// ------------------
321
// ------------------ TGLShadowVolumeCaster ------------------
322
// ------------------
323

324
// Create
325
//
326

327
constructor TGLShadowVolumeCaster.Create(ACollection: TCollection);
328
begin
329
  inherited Create(ACollection);
330
  FCapping := svcDefault;
331
  FCastingMode := scmRecursivelyVisible;
332
end;
333

334
type
335
  // Required for Delphi 5 support.
336
  THackOwnedCollection = class(TOwnedCollection);
337

338
  // GetGLShadowVolume
339
  //
340

341
function TGLShadowVolumeCaster.GetGLShadowVolume: TGLShadowVolume;
342
begin
343
  Result := TGLShadowVolume(THackOwnedCollection(Collection).GetOwner);
344
end;
345

346
// Destroy
347
//
348

349
destructor TGLShadowVolumeCaster.Destroy;
350
begin
351
  if Assigned(FCaster) then
352
    FCaster.RemoveFreeNotification(GLShadowVolume);
353
  inherited;
354
end;
355

356
 
357
//
358

359
procedure TGLShadowVolumeCaster.Assign(Source: TPersistent);
360
begin
361
  if Source is TGLShadowVolumeCaster then
362
  begin
363
    FCaster := TGLShadowVolumeCaster(Source).FCaster;
364
    FEffectiveRadius := TGLShadowVolumeCaster(Source).FEffectiveRadius;
365
    FCapping := TGLShadowVolumeCaster(Source).FCapping;
366
    GetGLShadowVolume.StructureChanged;
367
  end;
368
  inherited;
369
end;
370

371
// SetCaster
372
//
373

374
procedure TGLShadowVolumeCaster.SetCaster(const val: TGLBaseSceneObject);
375
begin
376
  if FCaster <> val then
377
  begin
378
    if FCaster <> nil then
379
      FCaster.RemoveFreeNotification(GLShadowVolume);
380
    FCaster := val;
381
    if FCaster <> nil then
382
      FCaster.FreeNotification(GLShadowVolume);
383
    GetGLShadowVolume.StructureChanged;
384
  end;
385
end;
386

387
// RemoveNotification
388
//
389

390
procedure TGLShadowVolumeCaster.RemoveNotification(aComponent: TComponent);
391
begin
392
  if aComponent = FCaster then
393
  begin
394
    // No point in keeping the TGLShadowVolumeCaster once the FCaster has been
395
    // destroyed.
396
    FCaster := nil;
397
    Free;
398
  end;
399
end;
400

401
// GetDisplayName
402
//
403

404
function TGLShadowVolumeCaster.GetDisplayName: string;
405
begin
406
  if Assigned(FCaster) then
407
  begin
408
    if FCaster is TGLLightSource then
409
      Result := '[Light]'
410
    else
411
      Result := '[Object]';
412
    Result := Result + ' ' + FCaster.Name;
413
    if EffectiveRadius > 0 then
414
      Result := Result + Format(' (%.1f)', [EffectiveRadius]);
415
  end
416
  else
417
    Result := 'nil';
418
end;
419

420
// ------------------
421
// ------------------ TGLShadowVolumeLight ------------------
422
// ------------------
423

424
// Create
425
//
426

427
constructor TGLShadowVolumeLight.Create(ACollection: TCollection);
428
begin
429
  inherited Create(ACollection);
430
  FSilhouettes := TPersistentObjectList.Create;
431
end;
432

433
// Destroy
434
//
435

436
destructor TGLShadowVolumeLight.Destroy;
437
begin
438
  FlushSilhouetteCache;
439
  FSilhouettes.Free;
440
  inherited;
441
end;
442

443
// FlushSilhouetteCache
444
//
445

446
procedure TGLShadowVolumeLight.FlushSilhouetteCache;
447
begin
448
  FSilhouettes.Clean;
449
end;
450

451
// Create
452
//
453

454
function TGLShadowVolumeLight.GetLightSource: TGLLightSource;
455
begin
456
  Result := TGLLightSource(Caster);
457
end;
458

459
// SetLightSource
460
//
461

462
procedure TGLShadowVolumeLight.SetLightSource(const ls: TGLLightSource);
463
begin
464
  SetCaster(ls);
465
end;
466

467
// GetCachedSilhouette
468
//
469

470
function TGLShadowVolumeLight.GetCachedSilhouette(AIndex: Integer):
471
  TGLSilhouette;
472
begin
473
  if AIndex < FSilhouettes.Count then
474
    Result := TGLSilhouette(FSilhouettes[AIndex])
475
  else
476
    Result := nil;
477
end;
478

479
// StoreCachedSilhouette
480
//
481

482
procedure TGLShadowVolumeLight.StoreCachedSilhouette(AIndex: Integer; ASil:
483
  TGLSilhouette);
484
begin
485
  while AIndex >= FSilhouettes.Count do
486
    FSilhouettes.Add(nil);
487
  if ASil <> FSilhouettes[AIndex] then
488
  begin
489
    if assigned(FSilhouettes[AIndex]) then
490
      FSilhouettes[AIndex].Free;
491
    FSilhouettes[AIndex] := ASil;
492
  end;
493
end;
494

495
// TGLShadowVolumeLight
496
//
497

498
function TGLShadowVolumeLight.SetupScissorRect(worldAABB: PAABB; var rci:
499
  TGLRenderContextInfo): Boolean;
500
var
501
  mvp: TMatrix;
502
  ls: TGLLightSource;
503
  aabb: TAABB;
504
  clipRect: TClipRect;
505
begin
506
  ls := LightSource;
507
  if (EffectiveRadius <= 0) or (not ls.Attenuated) then
508
  begin
509
    // non attenuated lights can't be clipped
510
    if not Assigned(worldAABB) then
511
    begin
512
      Result := False;
513
      Exit;
514
    end
515
    else
516
      aabb := worldAABB^;
517
  end
518
  else
519
  begin
520
    aabb := BSphereToAABB(ls.AbsolutePosition, EffectiveRadius);
521
    if Assigned(worldAABB) then
522
      aabb := AABBIntersection(aabb, worldAABB^);
523
  end;
524

525
  if PointInAABB(rci.cameraPosition, aabb) then
526
  begin
527
    // camera inside light volume radius, can't clip
528
    Result := False;
529
    Exit;
530
  end;
531

532
  // Calculate the window-space bounds of the light's bounding box.
533
  mvp := rci.PipelineTransformation.ViewProjectionMatrix;
534

535
  clipRect := AABBToClipRect(aabb, mvp, rci.viewPortSize.cx,
536
    rci.viewPortSize.cy);
537

538
  if (clipRect.Right < 0) or (clipRect.Left > rci.viewPortSize.cx)
539
    or (clipRect.Top < 0) or (clipRect.Bottom > rci.viewPortSize.cy) then
540
  begin
541
    Result := False;
542
    Exit;
543
  end;
544

545
  with clipRect do
546
    GL.Scissor(Round(Left), Round(Top), Round(Right - Left), Round(Bottom -
547
      Top));
548
  Result := True;
549
end;
550

551
// ------------------
552
// ------------------ TGLShadowVolumeCasters ------------------
553
// ------------------
554

555
// RemoveNotification
556
//
557

558
procedure TGLShadowVolumeCasters.RemoveNotification(aComponent: TComponent);
559
var
560
  i: Integer;
561
begin
562
  for i := Count - 1 downto 0 do
563
    Items[i].RemoveNotification(aComponent);
564
end;
565

566
// GetItems
567
//
568

569
function TGLShadowVolumeCasters.GetItems(index: Integer): TGLShadowVolumeCaster;
570
begin
571
  Result := TGLShadowVolumeCaster(inherited Items[index]);
572
end;
573

574
// AddCaster
575
//
576

577
function TGLShadowVolumeCasters.AddCaster(obj: TGLBaseSceneObject;
578
  effectiveRadius: Single = 0;
579
  CastingMode: TGLShadowCastingMode = scmRecursivelyVisible):
580
  TGLShadowVolumeCaster;
581
var
582
  newCaster: TGLShadowVolumeCaster;
583
begin
584
  newCaster := TGLShadowVolumeCaster(Add);
585
  newCaster.Caster := obj;
586
  newCaster.EffectiveRadius := effectiveRadius;
587
  newCaster.CastingMode := CastingMode;
588

589
  result := newCaster;
590
end;
591

592
// RemoveCaster
593
//
594

595
procedure TGLShadowVolumeCasters.RemoveCaster(obj: TGLBaseSceneObject);
596
var
597
  i: Integer;
598
begin
599
  i := IndexOfCaster(obj);
600
  if i >= 0 then
601
    Delete(i);
602
end;
603

604
// IndexOfCaster
605
//
606

607
function TGLShadowVolumeCasters.IndexOfCaster(obj: TGLBaseSceneObject): Integer;
608
var
609
  i: Integer;
610
begin
611
  for i := 0 to Count - 1 do
612
  begin
613
    if Items[i].Caster = obj then
614
    begin
615
      Result := i;
616
      Exit;
617
    end;
618
  end;
619
  Result := -1;
620
end;
621

622
// ------------------
623
// ------------------ TGLShadowVolume ------------------
624
// ------------------
625

626
// Create
627
//
628

629
constructor TGLShadowVolume.Create(AOwner: Tcomponent);
630
begin
631
  inherited Create(AOwner);
632
  ObjectStyle := ObjectStyle - [osDirectDraw] + [osNoVisibilityCulling];
633
  FActive := True;
634
  FLights := TGLShadowVolumeCasters.Create(self, TGLShadowVolumeLight);
635
  FOccluders := TGLShadowVolumeCasters.Create(self, TGLShadowVolumeOccluder);
636
  FCapping := svcAlways;
637
  FMode := svmAccurate;
638
  FOptions := [svoCacheSilhouettes, svoScissorClips];
639
  FDarkeningColor := TGLColor.CreateInitialized(Self, VectorMake(0, 0, 0, 0.5));
640
end;
641

642
// Destroy
643
//
644

645
destructor TGLShadowVolume.Destroy;
646
begin
647
  inherited;
648
  FDarkeningColor.Free;
649
  FLights.Free;
650
  FOccluders.Free;
651
end;
652

653
// Notification
654
//
655

656
procedure TGLShadowVolume.Notification(AComponent: TComponent; Operation:
657
  TOperation);
658
begin
659
  if Operation = opRemove then
660
  begin
661
    FLights.RemoveNotification(AComponent);
662
    FOccluders.RemoveNotification(AComponent);
663
  end;
664
  inherited;
665
end;
666

667
 
668
//
669

670
procedure TGLShadowVolume.Assign(Source: TPersistent);
671
begin
672
  if Assigned(Source) and (Source is TGLShadowVolume) then
673
  begin
674
    FLights.Assign(TGLShadowVolume(Source).Lights);
675
    FOccluders.Assign(TGLShadowVolume(Source).Occluders);
676
    FCapping := TGLShadowVolume(Source).FCapping;
677
    StructureChanged;
678
  end;
679
  inherited Assign(Source);
680
end;
681

682
// FlushSilhouetteCache
683
//
684

685
procedure TGLShadowVolume.FlushSilhouetteCache;
686
var
687
  i: Integer;
688
begin
689
  for i := 0 to Lights.Count - 1 do
690
    (Lights[i] as TGLShadowVolumeLight).FlushSilhouetteCache;
691
end;
692

693
// SetActive
694
//
695

696
procedure TGLShadowVolume.SetActive(const val: Boolean);
697
begin
698
  if FActive <> val then
699
  begin
700
    FActive := val;
701
    StructureChanged;
702
  end;
703
end;
704

705
// SetLights
706
//
707

708
procedure TGLShadowVolume.SetLights(const val: TGLShadowVolumeCasters);
709
begin
710
  Assert(val.ItemClass = TGLShadowVolumeLight);
711
  FLights.Assign(val);
712
  StructureChanged;
713
end;
714

715
// SetOccluders
716
//
717

718
procedure TGLShadowVolume.SetOccluders(const val: TGLShadowVolumeCasters);
719
begin
720
  Assert(val.ItemClass = TGLShadowVolumeOccluder);
721
  FOccluders.Assign(val);
722
  StructureChanged;
723
end;
724

725
// SetOptions
726
//
727

728
procedure TGLShadowVolume.SetOptions(const val: TGLShadowVolumeOptions);
729
begin
730
  if FOptions <> val then
731
  begin
732
    FOptions := val;
733
    if not (svoCacheSilhouettes in FOptions) then
734
      FlushSilhouetteCache;
735
    StructureChanged;
736
  end;
737
end;
738

739
// SetMode
740
//
741

742
procedure TGLShadowVolume.SetMode(const val: TGLShadowVolumeMode);
743
begin
744
  if FMode <> val then
745
  begin
746
    FMode := val;
747
    StructureChanged;
748
  end;
749
end;
750

751
// SetDarkeningColor
752
//
753

754
procedure TGLShadowVolume.SetDarkeningColor(const val: TGLColor);
755
begin
756
  FDarkeningColor.Assign(val);
757
end;
758

759
// DoRender
760
//
761

762
procedure TGLShadowVolume.DoRender(var ARci: TGLRenderContextInfo;
763
  ARenderSelf, ARenderChildren: Boolean);
764

765
// Function that determines if an object is "recursively visible". It halts when
766
// * it finds an invisible ancestor (=> invisible)
767
// * it finds the root (=> visible)
768
// * it finds the shadow volume as an ancestor (=> visible)
769
//
770
// This does _not_ mean that the object is actually visible on the screen
771

772
function DirectHierarchicalVisibility(obj: TGLBaseSceneObject): boolean;
773
  var
774
    p: TGLBaseSceneObject;
775
  begin
776
    if not Assigned(obj) then
777
    begin
778
      Result := True;
779
      exit;
780
    end;
781
    if not obj.Visible then
782
    begin
783
      Result := False;
784
      Exit;
785
    end;
786
    p := obj.Parent;
787
    while Assigned(p) and (p <> obj) and (p <> Self) do
788
    begin
789
      if not p.Visible then
790
      begin
791
        Result := False;
792
        Exit;
793
      end;
794
      p := p.Parent;
795
    end;
796
    Result := True;
797
  end;
798

799
var
800
  i, k: Integer;
801
  lightSource: TGLLightSource;
802
  lightCaster: TGLShadowVolumeLight;
803
  sil: TGLSilhouette;
804
  lightID: Cardinal;
805
  obj: TGLBaseSceneObject;
806
  caster: TGLShadowVolumeCaster;
807
  opaques, opaqueCapping: TList;
808
  silParams: TGLSilhouetteParameters;
809
  worldAABB: TAABB;
810
  pWorldAABB: PAABB;
811
  PM: TMatrix;
812
begin
813
  if not Active then
814
  begin
815
    inherited;
816
    Exit;
817
  end;
818
  if FRendering then
819
    Exit;
820
  if not (ARenderSelf or ARenderChildren) then
821
    Exit;
822
  ClearStructureChanged;
823
  if ((csDesigning in ComponentState) and not (svoDesignVisible in Options))
824
    or (Mode = svmOff)
825
    or (ARci.drawState = dsPicking) then
826
  begin
827
    inherited;
828
    Exit;
829
  end;
830
  if svoWorldScissorClip in Options then
831
  begin
832
    // compute shadow receiving world AABB in absolute coordinates
833
    worldAABB := Self.AxisAlignedBoundingBox;
834
    AABBTransform(worldAABB, AbsoluteMatrix);
835
    pWorldAABB := @worldAABB;
836
  end
837
  else
838
    pWorldAABB := nil;
839
  opaques := TList.Create;
840
  opaqueCapping := TList.Create;
841
  FRendering := True;
842
  try
843
    // collect visible casters
844
    for i := 0 to Occluders.Count - 1 do
845
    begin
846
      caster := Occluders[i];
847
      obj := caster.Caster;
848
      if Assigned(obj)
849
        and
850
        // Determine when to render this object or not
851
      (
852
        (Caster.CastingMode = scmAlways) or
853
        ((Caster.CastingMode = scmVisible) and obj.Visible) or
854
        ((Caster.CastingMode = scmRecursivelyVisible) and
855
        DirectHierarchicalVisibility(obj)) or
856
        ((Caster.CastingMode = scmParentRecursivelyVisible) and
857
        DirectHierarchicalVisibility(obj.Parent)) or
858
        ((Caster.CastingMode = scmParentVisible) and (not Assigned(obj.Parent)
859
          or
860
        obj.Parent.Visible))
861
        )
862
        and ((caster.EffectiveRadius <= 0)
863
        or (obj.DistanceTo(ARci.cameraPosition) < caster.EffectiveRadius)) then
864
      begin
865
        opaques.Add(obj);
866
        opaqueCapping.Add(Pointer(PtrUInt(ord((caster.Capping = svcAlways)
867
          or ((caster.Capping = svcDefault)
868
          and (Capping = svcAlways))))));
869
      end
870
      else
871
      begin
872
        opaques.Add(nil);
873
        opaqueCapping.Add(nil);
874
      end;
875
    end;
876

877
    // render the shadow volumes
878
    with ARci.GLStates do
879
    begin
880

881
      if Mode = svmAccurate then
882
      begin
883
        // first turn off all the shadow casting lights diffuse and specular
884
        for i := 0 to Lights.Count - 1 do
885
        begin
886
          lightCaster := TGLShadowVolumeLight(Lights[i]);
887
          lightSource := lightCaster.LightSource;
888
          if Assigned(lightSource) and (lightSource.Shining) then
889
          begin
890
            lightID := lightSource.LightID;
891
            LightDiffuse[lightID] := NullHmgVector;
892
            LightSpecular[lightID] := NullHmgVector;
893
          end;
894
        end;
895
      end;
896
      // render shadow receivers with ambient lighting
897

898
      // DanB - not sure why this doesn't render properly with these statements
899
      // where they were originally (after the RenderChildren call).
900

901
      Self.RenderChildren(0, Count - 1, ARci);
902

903
      ARci.ignoreBlendingRequests := True;
904
      ARci.ignoreDepthRequests := True;
905
      DepthWriteMask := False;
906
      Enable(stDepthTest);
907
      SetBlendFunc(bfSrcAlpha, bfOne);
908
      Disable(stAlphaTest);
909
      Enable(stStencilTest);
910

911
      // Disable all client states
912
      if GL.ARB_vertex_buffer_object then
913
      begin
914
        VertexArrayBinding := 0;
915
        ArrayBufferBinding := 0;
916
        ElementBufferBinding := 0;
917
      end;
918

919
      // turn off *all* lights
920
      for i := 0 to TGLScene(ARci.scene).Lights.Count - 1 do
921
      begin
922
        lightSource := (TGLScene(ARci.scene).Lights.Items[i]) as TGLLightSource;
923
        if Assigned(lightSource) and lightSource.Shining then
924
          LightEnabling[lightSource.LightID] := False;
925
      end;
926

927
      GL.LightModelfv(GL_LIGHT_MODEL_AMBIENT, @NullHmgPoint);
928
      ARci.PipelineTransformation.Push;
929

930
      // render contribution of all shadow casting lights
931
      for i := 0 to Lights.Count - 1 do
932
      begin
933
        lightCaster := TGLShadowVolumeLight(lights[i]);
934
        lightSource := lightCaster.LightSource;
935

936
        if (not Assigned(lightSource)) or (not lightSource.Shining) then
937
          Continue;
938

939
        lightID := lightSource.LightID;
940

941
        SetVector(silParams.LightDirection,
942
          lightSource.SpotDirection.DirectVector);
943
        case lightSource.LightStyle of
944
          lsParallel: silParams.Style := ssParallel
945
        else
946
          silParams.Style := ssOmni;
947
        end;
948
        silParams.CappingRequired := True;
949

950
        if Assigned(pWorldAABB) or (svoScissorClips in Options) then
951
        begin
952
          if lightCaster.SetupScissorRect(pWorldAABB, ARci) then
953
            Enable(stScissorTest)
954
          else
955
            Disable(stScissorTest);
956
        end;
957

958
        // clear the stencil and prepare for shadow volume pass
959
        GL.Clear(GL_STENCIL_BUFFER_BIT);
960
        SetStencilFunc(cfAlways, 0, 255);
961
        DepthFunc := cfLess;
962

963
        if svoShowVolumes in Options then
964
        begin
965
          GL.Color3f(0.05 * i, 0.1, 0);
966
          Enable(stBlend);
967
        end
968
        else
969
        begin
970
          SetGLColorWriting(False);
971
          Disable(stBlend);
972
        end;
973
        Enable(stCullFace);
974

975
        Disable(stLighting);
976
        GL.EnableClientState(GL_VERTEX_ARRAY);
977
        SetPolygonOffset(1, 1);
978

979
        // for all opaque shadow casters
980
        for k := 0 to opaques.Count - 1 do
981
        begin
982
          obj := TGLBaseSceneObject(opaques[k]);
983
          if obj = nil then
984
            Continue;
985

986
          SetVector(silParams.SeenFrom,
987
            obj.AbsoluteToLocal(lightSource.AbsolutePosition));
988

989
          sil := lightCaster.GetCachedSilhouette(k);
990
          if (not Assigned(sil)) or (not CompareMem(@sil.Parameters, @silParams,
991
            SizeOf(silParams))) then
992
          begin
993
            sil := obj.GenerateSilhouette(silParams);
994
            sil.Parameters := silParams;
995
            // extrude vertices to infinity
996
            sil.ExtrudeVerticesToInfinity(silParams.SeenFrom);
997
          end;
998
          if Assigned(sil) then
999
            try
1000
              // render the silhouette
1001
              ARci.PipelineTransformation.ModelMatrix := obj.AbsoluteMatrix;
1002
              GL.VertexPointer(4, GL_FLOAT, 0, sil.Vertices.List);
1003

1004
              if Boolean(PtrUInt(opaqueCapping[k])) then
1005
              begin
1006
                // z-fail
1007
                if GL.EXT_compiled_vertex_array then
1008
                  GL.LockArrays(0, sil.Vertices.Count);
1009

1010
                CullFaceMode := cmFront;
1011
                SetStencilOp(soKeep, soIncr, soKeep);
1012

1013
                with sil do
1014
                begin
1015
                  GL.DrawElements(GL_QUADS, Indices.Count, GL_UNSIGNED_INT,
1016
                    Indices.List);
1017
                  Enable(stPolygonOffsetFill);
1018
                  GL.DrawElements(GL_TRIANGLES, CapIndices.Count,
1019
                    GL_UNSIGNED_INT,
1020
                    CapIndices.List);
1021
                  Disable(stPolygonOffsetFill);
1022
                end;
1023

1024
                CullFaceMode := cmBack;
1025
                SetStencilOp(soKeep, soDecr, soKeep);
1026

1027
                with sil do
1028
                begin
1029
                  GL.DrawElements(GL_QUADS, Indices.Count, GL_UNSIGNED_INT,
1030
                    Indices.List);
1031
                  Enable(stPolygonOffsetFill);
1032
                  GL.DrawElements(GL_TRIANGLES, CapIndices.Count,
1033
                    GL_UNSIGNED_INT,
1034
                    CapIndices.List);
1035
                  Disable(stPolygonOffsetFill);
1036
                end;
1037

1038
                if GL.EXT_compiled_vertex_array then
1039
                  GL.UnlockArrays;
1040
              end
1041
              else
1042
              begin
1043
                // z-pass
1044
                CullFaceMode := cmBack;
1045
                SetStencilOp(soKeep, soKeep, soIncr);
1046

1047
                GL.DrawElements(GL_QUADS, sil.Indices.Count, GL_UNSIGNED_INT,
1048
                  sil.Indices.List);
1049

1050
                CullFaceMode := cmFront;
1051
                SetStencilOp(soKeep, soKeep, soDecr);
1052

1053
                GL.DrawElements(GL_QUADS, sil.Indices.Count, GL_UNSIGNED_INT,
1054
                  sil.Indices.List);
1055
              end;
1056

1057
            finally
1058
              if (svoCacheSilhouettes in Options) and (not (osDirectDraw in
1059
                ObjectStyle)) then
1060
                lightCaster.StoreCachedSilhouette(k, sil)
1061
              else
1062
                sil.Free;
1063
            end;
1064
        end;
1065

1066
        GL.DisableClientState(GL_VERTEX_ARRAY);
1067

1068
        // re-enable light's diffuse and specular, but no ambient
1069
        LightEnabling[LightID] := True;
1070
        LightAmbient[LightID] := NullHmgVector;
1071
        LightDiffuse[LightID] := lightSource.Diffuse.Color;
1072
        LightSpecular[LightID] := lightSource.Specular.Color;
1073

1074
        SetGLColorWriting(True);
1075
        SetStencilOp(soKeep, soKeep, soKeep);
1076

1077
        Enable(stBlend);
1078

1079
        CullFaceMode := cmBack;
1080

1081
        if Mode = svmAccurate then
1082
        begin
1083
          SetStencilFunc(cfEqual, 0, 255);
1084
          DepthFunc := cfEqual;
1085
          Self.RenderChildren(0, Count - 1, ARci);
1086
        end
1087
        else
1088
        begin
1089
          SetStencilFunc(cfNotEqual, 0, 255);
1090

1091
          DepthFunc := cfAlways;
1092
          SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha);
1093

1094
          GL.PushMatrix;
1095
          GL.LoadIdentity;
1096
          GL.MatrixMode(GL_PROJECTION);
1097
          GL.PushMatrix;
1098
          PM := CreateOrthoMatrix(0, 1, 1, 0, -1, 1);
1099
          GL.LoadMatrixf(PGLFloat(@PM));
1100

1101
          GL.Color4fv(FDarkeningColor.AsAddress);
1102
          GL.Begin_(GL_QUADS);
1103
          GL.Vertex2f(0, 0);
1104
          GL.Vertex2f(0, 1);
1105
          GL.Vertex2f(1, 1);
1106
          GL.Vertex2f(1, 0);
1107
          GL.End_;
1108

1109
          GL.PopMatrix;
1110
          GL.MatrixMode(GL_MODELVIEW);
1111
          GL.PopMatrix;
1112

1113
          SetBlendFunc(bfSrcAlpha, bfOne);
1114
        end;
1115

1116
        // disable light, but restore its ambient component
1117
        LightEnabling[lightID] := False;
1118
        LightAmbient[lightID] := lightSource.Ambient.Color;
1119
      end; // for i
1120
      ARci.PipelineTransformation.Pop;
1121

1122
      // restore OpenGL state
1123
      GL.LightModelfv(GL_LIGHT_MODEL_AMBIENT, @ARci.sceneAmbientColor);
1124
      Scene.SetupLights(ARci.GLStates.MaxLights);
1125
      Disable(stStencilTest);
1126
      SetPolygonOffset(0, 0);
1127
      ARci.ignoreBlendingRequests := False;
1128
      ARci.ignoreDepthRequests := False;
1129
    end; // of with
1130
  finally
1131
    FRendering := False;
1132
    opaques.Free;
1133
    opaqueCapping.Free;
1134
  end;
1135
end;
1136

1137
//-------------------------------------------------------------
1138
//-------------------------------------------------------------
1139
//-------------------------------------------------------------
1140

1141
initialization
1142
  //-------------------------------------------------------------
1143
  //-------------------------------------------------------------
1144
  //-------------------------------------------------------------
1145

1146
  RegisterClasses([TGLShadowVolume]);
1147

1148
end.
1149

1150