LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   Implements a basic, stencil-based mirror (as in Mark Kilgard's demo).
6

7
   It is strongly recommended to read and understand the explanations in the
8
   materials/mirror demo before using this component.
9

10
  History :  
11
       23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
12
       22/04/10 - Yar - Fixes after GLState revision
13
       05/03/10 - DanB - More state added to TGLStateCache
14
       15/12/08- Paul Robello - corrected call to  FOnEndRenderingMirrors
15
       06/06/07 - DaStr - Added GLColor to uses (BugtrackerID = 1732211)
16
       30/03/07 - DaStr - Added $I GLScene.inc
17
       28/03/07 - DaStr - Renamed parameters in some methods
18
                             (thanks Burkhard Carstens) (Bugtracker ID = 1678658)
19
       18/07/04 - Orlando - added custom shapes
20
       13/02/03 - DanB - added TGLMirror.AxisAlignedDimensionsUnscaled
21
       13/11/02 - EG - Fixed TGLMirror.DoRender transform
22
       06/11/02 - EG - Fixed Stencil setup
23
       30/10/02 - EG - Added OnBegin/EndRenderingMirrors
24
       25/10/02 - EG - Fixed Stencil cleanup
25
       22/02/01 - EG - Fixed change notification,
26
                          Fixed special effects support (PFX, etc.)
27
       07/12/01 - EG - Creation
28
    
29
}
30
unit GLMirror;
31

32
interface
33

34
{$I GLScene.inc}
35

36
uses
37
  Classes,
38
  GLScene, GLVectorGeometry, OpenGLAdapter, OpenGLTokens, GLContext,
39
  GLMaterial, GLColor, GLRenderContextInfo,
40
  GLState
41
  , GLVectorTypes;
42

43

44
type
45

46
  // TMirrorOptions
47
  //
48
  TMirrorOption = (moUseStencil, moOpaque, moMirrorPlaneClip, moClearZBuffer);
49
  TMirrorOptions = set of TMirrorOption;
50

51
const
52
  cDefaultMirrorOptions = [moUseStencil];
53

54
type
55

56
  // TMirrorShapes  ORL
57
  TMirrorShapes = (msRect, msDisk);
58

59
  // TGLMirror
60
  //
61
  { A simple plane mirror.
62
     This mirror requires a stencil buffer for optimal rendering!
63
     The object is a mix between a plane and a proxy object, in that the plane
64
     defines the mirror's surface, while the proxy part is used to reference
65
     the objects that should be mirrored (it is legal to self-mirror, but no
66
     self-mirror visuals will be rendered).
67
     It is strongly recommended to read and understand the explanations in the
68
     materials/mirror demo before using this component. }
69
  TGLMirror = class(TGLSceneObject)
70
  private
71
     
72
    FRendering: Boolean;
73
    FMirrorObject: TGLBaseSceneObject;
74
    FWidth, FHeight: TGLFloat;
75
    FMirrorOptions: TMirrorOptions;
76
    FOnBeginRenderingMirrors, FOnEndRenderingMirrors: TNotifyEvent;
77

78
    FShape: TMirrorShapes; //ORL
79
    FRadius: TGLFloat; //ORL
80
    FSlices: TGLInt; //ORL
81

82
  protected
83
     
84
    procedure Notification(AComponent: TComponent; Operation: TOperation);
85
      override;
86
    procedure SetMirrorObject(const val: TGLBaseSceneObject);
87
    procedure SetMirrorOptions(const val: TMirrorOptions);
88
    procedure ClearZBufferArea(aBuffer: TGLSceneBuffer);
89

90
    procedure SetHeight(AValue: TGLFloat);
91
    procedure SetWidth(AValue: TGLFloat);
92

93
    procedure SetRadius(const aValue: Single); //ORL
94
    procedure SetSlices(const aValue: TGLInt); //ORL
95
    procedure SetShape(aValue: TMirrorShapes); //ORL
96
    function GetRadius: single; //ORL
97
    function GetSlices: TGLInt; //ORL
98

99
  public
100
     
101
    constructor Create(AOwner: TComponent); override;
102

103
    procedure DoRender(var ARci: TGLRenderContextInfo;
104
      ARenderSelf, ARenderChildren: Boolean); override;
105
    procedure BuildList(var ARci: TGLRenderContextInfo); override;
106

107
    procedure Assign(Source: TPersistent); override;
108
    function AxisAlignedDimensionsUnscaled: TVector; override;
109

110
  published
111
     
112
          { Selects the object to mirror.
113
             If nil, the whole scene is mirrored. }
114
    property MirrorObject: TGLBaseSceneObject read FMirrorObject write
115
      SetMirrorObject;
116
    { Controls rendering options.
117
        
118
        moUseStencil: mirror area is stenciled, prevents reflected
119
          objects to be visible on the sides of the mirror (stencil buffer
120
          must be active in the viewer)
121
        moOpaque: mirror is opaque (ie. painted with background color)
122
        moMirrorPlaneClip: a ClipPlane is defined to prevent reflections
123
          from popping out of the mirror (for objects behind or halfway through)
124
        moClearZBuffer: mirror area's ZBuffer is cleared so that background
125
          objects don't interfere with reflected objects (reflected objects
126
          must be rendered AFTER the mirror in the hierarchy). Works only
127
          along with stenciling.
128
        
129
    }
130
    property MirrorOptions: TMirrorOptions read FMirrorOptions write
131
      SetMirrorOptions default cDefaultMirrorOptions;
132

133
    property Height: TGLFloat read FHeight write SetHeight;
134
    property Width: TGLFloat read FWidth write SetWidth;
135

136
    { Fired before the object's mirror images are rendered. }
137
    property OnBeginRenderingMirrors: TNotifyEvent read FOnBeginRenderingMirrors
138
      write FOnBeginRenderingMirrors;
139
    { Fired after the object's mirror images are rendered. }
140
    property OnEndRenderingMirrors: TNotifyEvent read FOnEndRenderingMirrors
141
      write FOnEndRenderingMirrors;
142

143
    property Radius: TGLFloat read FRadius write SetRadius; //ORL
144
    property Slices: TGLInt read FSlices write SetSlices default 16; //ORL
145
    property Shape: TMirrorShapes read FShape write SetShape default msRect;
146
    //ORL
147
  end;
148

149
  //-------------------------------------------------------------
150
  //-------------------------------------------------------------
151
  //-------------------------------------------------------------
152
implementation
153
//-------------------------------------------------------------
154
//-------------------------------------------------------------
155
//-------------------------------------------------------------
156

157
// ------------------
158
// ------------------ TGLMirror ------------------
159
// ------------------
160

161
// Create
162
//
163

164
constructor TGLMirror.Create(AOwner: Tcomponent);
165
begin
166
  inherited Create(AOwner);
167
  FWidth := 1;
168
  FHeight := 1;
169
  FMirrorOptions := cDefaultMirrorOptions;
170
  ObjectStyle := ObjectStyle + [osDirectDraw];
171
  Material.FrontProperties.Diffuse.Initialize(VectorMake(1, 1, 1, 0.1));
172
  Material.BlendingMode := bmTransparency;
173

174
  FRadius := 1; //ORL
175
  FSlices := 16; //ORL
176
  Shape := msRect; //ORL
177
end;
178

179
// DoRender
180
//
181

182
procedure TGLMirror.DoRender(var ARci: TGLRenderContextInfo;
183
  ARenderSelf, ARenderChildren: Boolean);
184
var
185
  oldProxySubObject: Boolean;
186
  refMat, curMat, ModelMat: TMatrix;
187
  clipPlane: TDoubleHmgPlane;
188
  bgColor: TColorVector;
189
  cameraPosBackup, cameraDirectionBackup: TVector;
190
  CurrentBuffer: TGLSceneBuffer;
191
begin
192
  if FRendering then
193
    Exit;
194
  FRendering := True;
195
  try
196
    oldProxySubObject := ARci.proxySubObject;
197
    ARci.proxySubObject := True;
198
    CurrentBuffer := TGLSceneBuffer(ARci.buffer);
199

200
    if VectorDotProduct(VectorSubtract(ARci.cameraPosition, AbsolutePosition),
201
      AbsoluteDirection) > 0 then
202
      with ARci.GLStates do
203
      begin
204

205
        // "Render" stencil mask
206
        if MirrorOptions <> [] then
207
        begin
208
          if (moUseStencil in MirrorOptions) then
209
          begin
210
            Enable(stStencilTest);
211
            ARci.GLStates.StencilClearValue := 0;
212
            GL.Clear(GL_STENCIL_BUFFER_BIT);
213
            SetStencilFunc(cfAlways, 1, 1);
214
            SetStencilOp(soReplace, soZero, soReplace);
215
          end;
216
          if (moOpaque in MirrorOptions) then
217
          begin
218
            bgColor := ConvertWinColor(CurrentBuffer.BackgroundColor);
219
            ARci.GLStates.SetGLMaterialColors(cmFront, bgColor, clrBlack,
220
              clrBlack, clrBlack, 0);
221
          end
222
          else
223
            SetGLColorWriting(False);
224

225
          Enable(stDepthTest);
226
          DepthWriteMask := False;
227

228
          BuildList(ARci);
229

230
          DepthWriteMask := True;
231
          if (moUseStencil in MirrorOptions) then
232
          begin
233
            SetStencilFunc(cfEqual, 1, 1);
234
            SetStencilOp(soKeep, soKeep, soKeep);
235
          end;
236

237
          if (moClearZBuffer in MirrorOptions) then
238
            ClearZBufferArea(CurrentBuffer);
239

240
          if not (moOpaque in MirrorOptions) then
241
            SetGLColorWriting(True);
242
        end;
243

244
        ARci.PipelineTransformation.Push;
245
        ARci.PipelineTransformation.ModelMatrix := IdentityHmgMatrix;
246

247
        Disable(stCullFace);
248
        Enable(stNormalize);
249

250
        if moMirrorPlaneClip in MirrorOptions then
251
        begin
252
          GL.Enable(GL_CLIP_PLANE0);
253
          SetPlane(clipPlane, PlaneMake(AffineVectorMake(AbsolutePosition),
254
            VectorNegate(AffineVectorMake(AbsoluteDirection))));
255
          GL.ClipPlane(GL_CLIP_PLANE0, @clipPlane);
256
        end;
257

258
        // Mirror lights
259
        refMat := MakeReflectionMatrix(
260
          AffineVectorMake(AbsolutePosition),
261
          AffineVectorMake(AbsoluteDirection));
262
        curMat := MatrixMultiply(refMat, ARci.PipelineTransformation.ViewMatrix);
263
        ARci.PipelineTransformation.ViewMatrix := curMat;
264
        Scene.SetupLights(CurrentBuffer.LimitOf[limLights]);
265

266
        // mirror geometry and render master
267
        cameraPosBackup := ARci.cameraPosition;
268
        cameraDirectionBackup := ARci.cameraDirection;
269
        ARci.cameraPosition := VectorTransform(ARci.cameraPosition, refMat);
270
        ARci.cameraDirection := VectorTransform(ARci.cameraDirection, refMat);
271

272
        // temporary fix? (some objects don't respect culling options, or ?)
273
        CullFaceMode := cmFront;
274
        if Assigned(FOnBeginRenderingMirrors) then
275
          FOnBeginRenderingMirrors(Self);
276
        if Assigned(FMirrorObject) then
277
        begin
278
          ModelMat := IdentityHmgMatrix;
279
          if FMirrorObject.Parent <> nil then
280
            MatrixMultiply(ModelMat, FMirrorObject.Parent.AbsoluteMatrix, ModelMat);
281
          MatrixMultiply(ModelMat, FMirrorObject.LocalMatrix^, ModelMat);
282
          ARci.PipelineTransformation.ModelMatrix := ModelMat;
283
          FMirrorObject.DoRender(ARci, ARenderSelf, FMirrorObject.Count > 0);
284
        end
285
        else
286
        begin
287
          Scene.Objects.DoRender(ARci, ARenderSelf, True);
288
        end;
289
        if Assigned(FOnEndRenderingMirrors) then
290
          FOnEndRenderingMirrors(Self);
291

292
        // Restore to "normal"
293
        ARci.cameraPosition := cameraPosBackup;
294
        ARci.cameraDirection := cameraDirectionBackup;
295
        ARci.GLStates.CullFaceMode := cmBack;
296
        ARci.PipelineTransformation.ReplaceFromStack;
297
        Scene.SetupLights(CurrentBuffer.LimitOf[limLights]);
298
        ARci.PipelineTransformation.Pop;
299
        if moMirrorPlaneClip in MirrorOptions then
300
          GL.Disable(GL_CLIP_PLANE0);
301
        ARci.GLStates.Disable(stStencilTest);
302

303
        ARci.proxySubObject := oldProxySubObject;
304

305
        // start rendering self
306
        if ARenderSelf then
307
        begin
308
          Material.Apply(ARci);
309
          repeat
310
            BuildList(ARci);
311
          until not Material.UnApply(ARci);
312
        end;
313

314
      end;
315

316
    if ARenderChildren then
317
      Self.RenderChildren(0, Count - 1, ARci);
318

319
    if Assigned(FMirrorObject) then
320
      FMirrorObject.Effects.RenderPostEffects(ARci);
321
  finally
322
    FRendering := False;
323
  end;
324
end;
325

326
// BuildList
327
//
328

329
procedure TGLMirror.BuildList(var ARci: TGLRenderContextInfo);
330
var
331
  hw, hh: TGLFloat;
332
  quadric: PGLUquadricObj;
333
begin
334
  if msRect = FShape then
335
  begin
336
    hw := FWidth * 0.5;
337
    hh := FHeight * 0.5;
338
    GL.Normal3fv(@ZVector);
339
    GL.Begin_(GL_QUADS);
340
    GL.Vertex3f(hw, hh, 0);
341
    GL.Vertex3f(-hw, hh, 0);
342
    GL.Vertex3f(-hw, -hh, 0);
343
    GL.Vertex3f(hw, -hh, 0);
344
    GL.End_;
345
  end
346
  else
347
  begin
348
    quadric := gluNewQuadric;
349
    gluDisk(Quadric, 0, FRadius, FSlices, 1); //radius. slices, loops
350
  end;
351
end;
352

353
// BuildList
354
//
355

356
procedure TGLMirror.ClearZBufferArea(aBuffer: TGLSceneBuffer);
357
var
358
  worldMat: TMatrix;
359
  p: TAffineVector;
360
begin
361
  with aBuffer do
362
  begin
363
    GL.PushMatrix;
364
    worldMat := Self.AbsoluteMatrix;
365
    GL.MatrixMode(GL_PROJECTION);
366
    GL.PushMatrix;
367
    GL.LoadIdentity;
368
    GL.Ortho(0, Width, 0, Height, 1, -1);
369
    GL.MatrixMode(GL_MODELVIEW);
370
    GL.LoadIdentity;
371

372
    with aBuffer.RenderingContext.GLStates do
373
    begin
374
      DepthFunc := cfAlways;
375
      SetGLColorWriting(False);
376
    end;
377

378
    GL.Begin_(GL_QUADS);
379
    p := WorldToScreen(VectorTransform(AffineVectorMake(Self.Width * 0.5,
380
      Self.Height * 0.5, 0), worldMat));
381
    GL.Vertex3f(p.V[0], p.V[1], 0.999);
382
    p := WorldToScreen(VectorTransform(AffineVectorMake(-Self.Width * 0.5,
383
      Self.Height * 0.5, 0), worldMat));
384
    GL.Vertex3f(p.V[0], p.V[1], 0.999);
385
    p := WorldToScreen(VectorTransform(AffineVectorMake(-Self.Width * 0.5,
386
      -Self.Height * 0.5, 0), worldMat));
387
    GL.Vertex3f(p.V[0], p.V[1], 0.999);
388
    p := WorldToScreen(VectorTransform(AffineVectorMake(Self.Width * 0.5,
389
      -Self.Height * 0.5, 0), worldMat));
390
    GL.Vertex3f(p.V[0], p.V[1], 0.999);
391
    GL.End_;
392

393
    with aBuffer.RenderingContext.GLStates do
394
    begin
395
      DepthFunc := cfLess;
396
      SetGLColorWriting(True);
397
    end;
398

399
    GL.MatrixMode(GL_PROJECTION);
400
    GL.PopMatrix;
401
    GL.MatrixMode(GL_MODELVIEW);
402
    GL.PopMatrix;
403
  end;
404
end;
405

406
// Notification
407
//
408

409
procedure TGLMirror.Notification(AComponent: TComponent; Operation: TOperation);
410
begin
411
  if (Operation = opRemove) and (AComponent = FMirrorObject) then
412
    MirrorObject := nil;
413
  inherited;
414
end;
415

416
// SetMirrorObject
417
//
418

419
procedure TGLMirror.SetMirrorObject(const val: TGLBaseSceneObject);
420
begin
421
  if FMirrorObject <> val then
422
  begin
423
    if Assigned(FMirrorObject) then
424
      FMirrorObject.RemoveFreeNotification(Self);
425
    FMirrorObject := val;
426
    if Assigned(FMirrorObject) then
427
      FMirrorObject.FreeNotification(Self);
428
    NotifyChange(Self);
429
  end;
430
end;
431

432
// SetWidth
433
//
434

435
procedure TGLMirror.SetWidth(AValue: TGLFloat);
436
begin
437
  if AValue <> FWidth then
438
  begin
439
    FWidth := AValue;
440
    NotifyChange(Self);
441
  end;
442
end;
443

444
// SetHeight
445
//
446

447
procedure TGLMirror.SetHeight(AValue: TGLFloat);
448
begin
449
  if AValue <> FHeight then
450
  begin
451
    FHeight := AValue;
452
    NotifyChange(Self);
453
  end;
454
end;
455

456
 
457
//
458

459
procedure TGLMirror.Assign(Source: TPersistent);
460
begin
461
  if Assigned(Source) and (Source is TGLMirror) then
462
  begin
463
    FWidth := TGLMirror(Source).FWidth;
464
    FHeight := TGLMirror(Source).FHeight;
465
    FMirrorOptions := TGLMirror(Source).FMirrorOptions;
466
    MirrorObject := TGLMirror(Source).MirrorObject;
467
  end;
468
  inherited Assign(Source);
469
end;
470

471
// AxisAlignedDimensions
472
//
473

474
function TGLMirror.AxisAlignedDimensionsUnscaled: TVector;
475
begin
476
  Result := VectorMake(0.5 * Abs(FWidth),
477
    0.5 * Abs(FHeight), 0);
478
end;
479

480
// SetMirrorOptions
481
//
482

483
procedure TGLMirror.SetMirrorOptions(const val: TMirrorOptions);
484
begin
485
  if FMirrorOptions <> val then
486
  begin
487
    FMirrorOptions := val;
488
    NotifyChange(Self);
489
  end;
490
end;
491

492
//ORL add-ons
493

494
// SetRadius
495
//
496

497
procedure TGLMirror.SetRadius(const aValue: Single);
498
begin
499
  if aValue <> FRadius then
500
  begin
501
    FRadius := aValue;
502
    StructureChanged;
503
  end;
504
end;
505

506
// GetRadius
507
//
508

509
function TGLMirror.GetRadius: single;
510
begin
511
  result := FRadius;
512
end;
513

514
// SetSlices
515
//
516

517
procedure TGLMirror.SetSlices(const aValue: TGLInt);
518
begin
519
  if aValue <> FSlices then
520
  begin
521
    if aValue > 2 then
522
      FSlices := aValue;
523
    StructureChanged;
524
  end
525
  else
526
  begin
527
  end;
528
end;
529

530
// GetSlices
531
//
532

533
function TGLMirror.GetSlices: TGLInt;
534
begin
535
  result := FSlices;
536
end;
537

538
// SetShape
539
//
540

541
procedure TGLMirror.SetShape(aValue: TMirrorShapes);
542
begin
543
  if aValue <> FShape then
544
  begin
545
    FShape := aValue;
546
    StructureChanged;
547
  end;
548
end;
549

550
//-------------------------------------------------------------
551
//-------------------------------------------------------------
552
//-------------------------------------------------------------
553
initialization
554
  //-------------------------------------------------------------
555
  //-------------------------------------------------------------
556
  //-------------------------------------------------------------
557

558
  RegisterClasses([TGLMirror]);
559

560
end.
561

562