LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
    A collection of components that generate post effects.
6

7
	 History :  
8
       23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
9
       22/04/10 - Yar - Fixes after GLState revision
10
       28/05/08 - DaStr - Fixed AV in TGLPostEffect.MakeDistortEffect()
11
                             Got rid of all R- hacks
12
       10/04/08 - DaStr - Added a Delpi 5 interface bug work-around to
13
                              TGLPostShaderCollectionItem.SetShader()
14
                              (BugTracker ID = 1938988)
15
       16/08/07 - DaStr - Added pepBlur preset (by Paul van Dinther)
16
       25/03/07 - DaStr - Small fix for Delphi5 compatibility
17
       23/03/07 - DaStr - Added TGLPostShaderHolder.Assign
18
       20/03/07 - DaStr - Fixed TGLPostShaderHolder.DoRender
19
       09/03/07 - DaStr - Added pepNightVision preset (thanks Roman Ganz)
20
                             Changed back all Trunc() calls to Round()
21
       07/03/07 - DaStr - Moved "Weird" effect to the demo
22
                             Added "Distort" effect
23
                             Modified "RedNoise" to simple monochrome noise
24
                                                   (preset renamed to "Noise")
25
                             Made "Negative" effect really negative,
26
                                             instead swapping R and B channels
27
                             Changed all Round() calls to Trunc()
28
                             Removed all TGLPostEffectColor typecasts
29
                             (All above changes were made by Michail Glukhov)
30
                             TGLPostEffect and TGLPostShaderHolder are not
31
                              rendered when DrawState=dsPicking (suggested by Riz)
32
       04/03/07 - DaStr - Added TGLPostShaderHolder
33
       02/03/07 - DaStr - TGLOnCustomPostEffectEvent now passes rci
34
                             pepNone preset does not call gl[Read/Draw]Pixels
35
       23/02/07 - DaStr - Initial version of TGLPostEffect
36
                                                (based on OldCity demo by FedeX)
37
                                                     
38

39
}
40
unit GLPostEffects;
41

42
interface
43

44
{$I GLScene.inc}
45

46
uses
47
  // VCL
48
  Classes, SysUtils,
49

50

51
  GLScene, GLTexture, OpenGLTokens, GLGraphics, GLStrings, GLCustomShader,
52
  GLContext, GLVectorGeometry, GLRenderContextInfo, GLMaterial, GLTextureFormat;
53

54
type
55
  EGLPostShaderHolderException = class(Exception);
56
  TGLPostShaderHolder = class;
57

58
  TGLPostShaderCollectionItem = class(TCollectionItem)
59
  private
60
    FShader: TGLShader;
61
    FPostShaderInterface: IGLPostShader;
62
    procedure SetShader(const Value: TGLShader);
63
  protected
64
    function GetRealOwner: TGLPostShaderHolder;
65
    function GetDisplayName: string; override;
66
  public
67
    procedure Assign(Source: TPersistent); override;
68
  published
69
    property Shader: TGLShader read FShader write SetShader;
70
  end;
71

72
  TGLPostShaderCollection = class(TOwnedCollection)
73
  private
74
    function GetItems(const Index: Integer): TGLPostShaderCollectionItem;
75
    procedure SetItems(const Index: Integer;
76
      const Value: TGLPostShaderCollectionItem);
77
  public
78
    procedure Remove(const Item: TGLShader);
79
    function Add: TGLPostShaderCollectionItem;
80

81
    property Items[const Index: Integer]: TGLPostShaderCollectionItem read GetItems write SetItems; default;
82
  end;
83

84
  { A class that allows several post-shaders to be applied to the scene,
85
    one after another. It does not provide any optimizations related to
86
    multi-shader rendering, just a convenient interface. }
87
  TGLPostShaderHolder = class(TGLBaseSCeneObject)
88
  private
89
    FShaders: TGLPostShaderCollection;
90
    FTempTexture: TGLTextureHandle;
91
    FPreviousViewportSize: TGLSize;
92
    FTempTextureTarget: TGLTextureTarget;
93
    procedure SetShaders(const Value: TGLPostShaderCollection);
94
  protected
95
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
96
  public
97
    constructor Create(Owner: TComponent); override;
98
    destructor Destroy; override;
99
    procedure Assign(Source: TPersistent); override;
100
    procedure DoRender(var rci : TGLRenderContextInfo;
101
                       renderSelf, renderChildren : Boolean); override;
102
  published
103
    property TempTextureTarget: TGLTextureTarget read FTempTextureTarget write FTempTextureTarget default ttTexture2d;
104
    property Shaders: TGLPostShaderCollection read FShaders write SetShaders;
105

106
    // Publish some stuff from TGLBaseSceneObject.
107
    property Visible;
108
    property OnProgress;
109
  end;
110

111

112
  TGLPostEffectColor = record
113
    R, G, B, A: TGLubyte;
114
  end;
115

116
  TGLPostEffectBuffer = array of TGLPostEffectColor;
117

118
  TGLOnCustomPostEffectEvent = procedure(Sender: TObject; var rci : TGLRenderContextInfo; var Buffer: TGLPostEffectBuffer) of object;
119

120
  { Some presets for TGLPostEffect:
121
       pepNone - does nothing.
122
       pepGray - makes picture gray.
123
       pepNegative - inverts all colors.
124
       pepDistort - simulates shaky TV image.
125
       pepNoise - just adds random niose.
126
       pepNightVision - simulates nightvision goggles.
127
       pepBlur - blurs the scene.
128
       pepCustom - calls the OnCustomEffect event.
129
  }
130
  TGLPostEffectPreset = (pepNone, pepGray, pepNegative, pepDistort, pepNoise,
131
                         pepNightVision, pepBlur, pepCustom);
132

133
  { Provides a simple way to producing post-effects without shaders.
134
     It is slow as hell, but it's worth it in some cases.}
135
  TGLPostEffect = class(TGLBaseSCeneObject)
136
  private
137
    FOnCustomEffect: TGLOnCustomPostEffectEvent;
138
    FPreset: TGLPostEffectPreset;
139
    FRenderBuffer: TGLPostEffectBuffer;
140
  protected
141
    // May be should be private...
142
    procedure MakeGrayEffect; virtual;
143
    procedure MakeNegativeEffect; virtual;
144
    procedure MakeDistortEffect; virtual;
145
    procedure MakeNoiseEffect; virtual;
146
    procedure MakeNightVisionEffect; virtual;
147
    procedure MakeBlurEffect(var rci : TGLRenderContextInfo); virtual;
148
    procedure DoOnCustomEffect(var rci : TGLRenderContextInfo; var Buffer: TGLPostEffectBuffer); virtual;
149
  public
150
    procedure DoRender(var rci : TGLRenderContextInfo;
151
                       renderSelf, renderChildren : Boolean); override;
152
    procedure Assign(Source: TPersistent); override;
153
  published
154
    property Preset: TGLPostEffectPreset read FPreset write FPreset default pepNone;
155
    // User creates this effect.
156
    property OnCustomEffect: TGLOnCustomPostEffectEvent read FOnCustomEffect write FOnCustomEffect;
157
    // Publish some stuff from TGLBaseSCeneObject.
158
    property Visible;
159
    property OnProgress;
160
  end;
161

162
implementation
163

164
{ TGLPostEffect }
165

166
procedure TGLPostEffect.Assign(Source: TPersistent);
167
begin
168
  inherited;
169
  if Source is TGLPostEffect then
170
  begin
171
    FPreset := TGLPostEffect(Source).FPreset;
172
  end;
173
end;
174

175
procedure TGLPostEffect.DoOnCustomEffect(
176
  var rci : TGLRenderContextInfo; var Buffer: TGLPostEffectBuffer);
177
begin
178
  if Assigned(FOnCustomEffect) then
179
    FOnCustomEffect(Self, rci, Buffer);
180
end;
181

182
procedure TGLPostEffect.DoRender(var rci : TGLRenderContextInfo;
183
                                      renderSelf, renderChildren : Boolean);
184
var
185
  NewScreenSize: Integer;
186
begin
187
  if (not rci.ignoreMaterials) and (FPreset <> pepNone) and (rci.drawState <> dsPicking) then
188
  begin
189
    NewScreenSize := rci.viewPortSize.cx * rci.viewPortSize.cy;
190
    if NewScreenSize <> Length(FRenderBuffer) then
191
      SetLength(FRenderBuffer, NewScreenSize);
192

193
    GL.ReadPixels(0, 0, rci.viewPortSize.cx, rci.viewPortSize.cy, GL_RGBA, GL_UNSIGNED_BYTE, FRenderBuffer);
194
    case FPreset of
195
      // pepNone is handled in the first line.
196
      pepGray:        MakeGrayEffect;
197
      pepNegative:    MakeNegativeEffect;
198
      pepDistort:     MakeDistortEffect;
199
      pepNoise:       MakeNoiseEffect;
200
      pepNightVision: MakeNightVisionEffect;
201
      pepBlur:        MakeBlurEffect(rci);
202
      pepCustom:      DoOnCustomEffect(rci, FRenderBuffer);
203
    else
204
      Assert(False, glsErrorEx + glsUnknownType);
205
    end;
206
    GL.DrawPixels(rci.viewPortSize.cx, rci.viewPortSize.cy, GL_RGBA, GL_UNSIGNED_BYTE, FRenderBuffer);
207
  end;
208

209
  // Start rendering children (if any).
210
  if renderChildren then
211
    Self.RenderChildren(0, Count - 1, rci);
212
end;
213

214
procedure TGLPostEffect.MakeGrayEffect;
215
var
216
  I:    Longword;
217
  gray: TGLubyte;
218
begin
219
  for I := 0 to High(FRenderBuffer) do
220
  begin
221
    gray := Round((0.30 * FRenderBuffer[I].r) +
222
                  (0.59 * FRenderBuffer[I].g) +
223
                  (0.11 * FRenderBuffer[I].b));
224
    FRenderBuffer[I].r := gray;
225
    FRenderBuffer[I].g := gray;
226
    FRenderBuffer[I].b := gray;
227
  end;
228
end;
229

230
procedure TGLPostEffect.MakeNegativeEffect;
231
var
232
  I: Longword;
233
begin
234
  for I := 0 to High(FRenderBuffer) do
235
  begin
236
    FRenderBuffer[I].r := 255 - FRenderBuffer[I].r;
237
    FRenderBuffer[I].g := 255 - FRenderBuffer[I].g;
238
    FRenderBuffer[I].b := 255 - FRenderBuffer[I].b;
239
  end;
240
end;
241

242
procedure TGLPostEffect.MakeDistortEffect;
243
var
244
  I: Integer;
245
  lMaxLength: Integer;
246
  lNewIndex: Integer;
247
begin
248
  lMaxLength := High(FRenderBuffer);
249

250
  for I := 0 to lMaxLength do
251
  begin
252
    lNewIndex := MaxInteger(0, MinInteger(lMaxLength, I + Random(10) - 5));
253
    FRenderBuffer[I].r := FRenderBuffer[lNewIndex].r;
254
    FRenderBuffer[I].g := FRenderBuffer[lNewIndex].g;
255
    FRenderBuffer[I].b := FRenderBuffer[lNewIndex].b;
256
  end;
257
end;
258

259
procedure TGLPostEffect.MakeNoiseEffect;
260
var
261
  I:   Longword;
262
  rnd: Single;
263
begin
264
  for I := 0 to High(FRenderBuffer) do
265
  begin
266
    rnd := 0.25 + Random(75)/100;
267

268
    FRenderBuffer[I].r := Round(FRenderBuffer[I].r * rnd);
269
    FRenderBuffer[I].g := Round(FRenderBuffer[I].g * rnd);
270
    FRenderBuffer[I].b := Round(FRenderBuffer[I].b * rnd);
271
  end;
272
end;
273

274
procedure TGLPostEffect.MakeNightVisionEffect;
275
var
276
   gray: Single;
277
   I: Integer;
278
   lNewIndex, lMaxLength: Integer;
279
begin
280
  lMaxLength := High(FRenderBuffer);
281

282
  for I := 0 to lMaxLength do
283
  begin
284
    lNewIndex := MaxInteger(0, MinInteger(lMaxLength, I + Random(20) - 10));
285

286
    gray := 60 + (0.30 * FRenderBuffer[lNewIndex].r) +
287
                 (0.59 * FRenderBuffer[lNewIndex].g) +
288
                 (0.11 * FRenderBuffer[lNewIndex].b);
289

290
    FRenderBuffer[I].r := Round(gray * 0.25);
291
    FRenderBuffer[I].g := Round((gray + 4) * 0.6);
292
    FRenderBuffer[I].b := Round((gray + 4) * 0.11);
293
  end;
294
end;
295

296
procedure TGLPostEffect.MakeBlurEffect(var rci : TGLRenderContextInfo);
297
const
298
  lOffset: Integer = 2;
299
var
300
  I: Integer;
301
  lUp: Integer;
302
begin
303
  lUp := rci.viewPortSize.cx * lOffset;
304
  for I := lUp to High(FRenderBuffer) - lUp do
305
  begin
306
    FRenderBuffer[I].r := (FRenderBuffer[I].r + FRenderBuffer[I - lOffset].r +
307
        FRenderBuffer[I + lOffset].r + FRenderBuffer[I - lUp].r +
308
        FRenderBuffer[I + lUp].r) div 5;
309
    FRenderBuffer[I].g := (FRenderBuffer[I].g + FRenderBuffer[I - lOffset].g +
310
        FRenderBuffer[I + lOffset].g + FRenderBuffer[I - lUp].g +
311
        FRenderBuffer[I + lUp].r) div 5;
312
    FRenderBuffer[I].b := (FRenderBuffer[I].b + FRenderBuffer[I - lOffset].b +
313
        FRenderBuffer[I + lOffset].b + FRenderBuffer[I - lUp].g +
314
        FRenderBuffer[I + lUp].r) div 5;
315
  end;
316
end;
317

318
{ TGLPostShaderCollectionItem }
319

320
procedure TGLPostShaderCollectionItem.Assign(Source: TPersistent);
321
begin
322
  if Source is TGLPostShaderCollectionItem then
323
  begin
324
    SetShader(TGLPostShaderCollectionItem(Source).FShader);
325
  end
326
  else
327
    inherited; // Die!!!
328
end;
329

330
function TGLPostShaderCollectionItem.GetDisplayName: string;
331
begin
332
  if FShader = nil then
333
    Result := ''
334
  else
335
  begin
336
    if FShader.Name <> '' then
337
      Result := FShader.Name
338
    else
339
      Result := FShader.ClassName;
340
  end;
341
end;
342

343
type
344
  // Required for Delphi5 compatibility.
345
  THackCollection = class(TOwnedCollection)end;
346

347
function TGLPostShaderCollectionItem.GetRealOwner: TGLPostShaderHolder;
348
begin
349
  if Collection = nil then
350
    Result := nil
351
  else
352
    Result := TGLPostShaderHolder(THackCollection(Collection).GetOwner);
353
end;
354

355
procedure TGLPostShaderCollectionItem.SetShader(const Value: TGLShader);
356
var
357
  RealOwner: TGLPostShaderHolder;
358
begin
359
  if FShader = Value then Exit;
360
  RealOwner := GetRealOwner;
361

362
  if FShader <> nil then
363
      FShader.RemoveFreeNotification(RealOwner);
364

365
  if not Supports(TObject(Value), IGLPostShader, FPostShaderInterface) then
366
    raise EGLPostShaderHolderException.Create('Shader must support interface IGLPostShader!');
367

368
  if RealOwner <> nil then
369
    if FPostShaderInterface.GetTextureTarget <> RealOwner.TempTextureTarget then
370
      raise EGLPostShaderHolderException.Create(glsErrorEx + 'TextureTarget is not compatible!');
371
  // If RealOwner = nil, we ignore this case and hope it will turn out ok...
372

373
  FShader := Value;
374

375
  if FShader <> nil then
376
    if RealOwner <> nil then
377
      FShader.FreeNotification(RealOwner);
378
end;
379

380
{ TGLPostShaderHolder }
381

382
procedure TGLPostShaderHolder.Assign(Source: TPersistent);
383
begin
384
  if Source is TGLPostShaderHolder then
385
  begin
386
    FShaders.Assign(TGLPostShaderHolder(Source).FShaders);
387
    FTempTextureTarget := TGLPostShaderHolder(Source).FTempTextureTarget;
388
  end;
389
  inherited;
390
end;
391

392
constructor TGLPostShaderHolder.Create(Owner: TComponent);
393
begin
394
  inherited;
395
  FTempTexture := TGLTextureHandle.Create;
396
  FTempTextureTarget :=ttTexture2D;
397
  FShaders := TGLPostShaderCollection.Create(Self, TGLPostShaderCollectionItem);
398
end;
399

400
destructor TGLPostShaderHolder.Destroy;
401
begin
402
  FShaders.Destroy;
403
  FTempTexture.Destroy;
404
  inherited;
405
end;
406

407
procedure TGLPostShaderHolder.DoRender(var rci: TGLRenderContextInfo;
408
  renderSelf, renderChildren: Boolean);
409
var
410
  I: Integer;
411
begin
412
  if not (rci.ignoreMaterials) and not (csDesigning in ComponentState) and
413
         (rci.drawState <> dsPicking) then
414
  begin
415
    if (FPreviousViewportSize.cx <> rci.viewPortSize.cx) or
416
       (FPreviousViewportSize.cy <> rci.viewPortSize.cy) then
417
    begin
418
      InitTexture(FTempTexture.Handle, rci.viewPortSize,
419
        FTempTextureTarget);
420
      FPreviousViewportSize := rci.viewPortSize;
421
    end;
422

423
    if FShaders.Count <> 0 then
424
    begin
425
      for I := 0 to FShaders.Count - 1 do
426
      begin
427
        Assert(Assigned(FShaders[I].FShader));
428
        if FShaders[I].FShader.Enabled then
429
        begin
430
          rci.GLStates.ActiveTextureEnabled[FTempTextureTarget] := True;
431
          FShaders[I].FShader.Apply(rci, Self);
432
          repeat
433
            CopyScreenToTexture(rci.viewPortSize, DecodeGLTextureTarget(FTempTextureTarget));
434
            FShaders[I].FPostShaderInterface.DoUseTempTexture(FTempTexture, FTempTextureTarget);
435
            DrawTexturedScreenQuad5(rci.viewPortSize);
436
          until not FShaders[I].FShader.UnApply(rci);
437
          rci.GLStates.ActiveTextureEnabled[FTempTextureTarget] := False;
438
        end;
439
      end;
440
    end;
441
  end;
442
  if renderChildren then
443
    Self.RenderChildren(0, Count - 1, rci);
444
end;
445

446
procedure TGLPostShaderHolder.Notification(AComponent: TComponent;
447
  Operation: TOperation);
448
begin
449
  inherited;
450
  if Operation = opRemove then
451
  begin
452
    if AComponent is TGLShader then
453
      FShaders.Remove(TGLShader(AComponent));
454
  end;
455
end;
456

457
procedure TGLPostShaderHolder.SetShaders(
458
  const Value: TGLPostShaderCollection);
459
begin
460
  FShaders.Assign(Value);
461
end;
462

463
{ TGLPostShaderCollection }
464

465
function TGLPostShaderCollection.Add: TGLPostShaderCollectionItem;
466
begin
467
  Result := TGLPostShaderCollectionItem(inherited Add);
468
end;
469

470
function TGLPostShaderCollection.GetItems(
471
  const Index: Integer): TGLPostShaderCollectionItem;
472
begin
473
  Result := TGLPostShaderCollectionItem(GetItem(Index));
474
end;
475

476
procedure TGLPostShaderCollection.Remove(
477
  const Item: TGLShader);
478
var
479
  I: Integer;
480
begin
481
  if Count <> 0 then
482
    for I := Count - 1 downto 0 do
483
      if GetItems(I).FShader = Item then
484
        Delete(I);
485
  // Don't exit because the same shader might be applied more than once.
486
end;
487

488
procedure TGLPostShaderCollection.SetItems(const Index: Integer;
489
  const Value: TGLPostShaderCollectionItem);
490
begin
491
  GetItems(Index).Assign(Value);
492
end;
493

494
initialization
495
  RegisterClasses([TGLPostEffect, TGLPostShaderHolder,
496
                   TGLPostShaderCollection, TGLPostShaderCollectionItem]);
497

498
end.
499