LZScene

1
// This unit is part of the GLScene Engine https://github.com/glscene
2
//
3
{
4
    A collection of pure abstract classes - descendants of TGLShader, which are
5
    used for purpose of not having to write the same stuff all over and over
6
    again in your own shader classes.
7
    It also contains a procedures and function that can be used in all shaders.
8

9
	 History :  
10
       23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
11
       15/16/10 - Yar - Rewrited static procedures (InitTexture, etc.)
12
       04/06/10 - Yar - Added unsigned integer uniforms
13
       22/04/10 - Yar - Fixes after GLState revision
14
       22/01/10 - Yar - Added to TGLCustomShaderParameter property AsTexture
15
       25/10/09 - DaStr - Updated TGLGeometryProgram (thanks YarUnderoaker)
16
       24/08/09 - DaStr - Separated TGLShaderProgram into TGLVertexProgram,
17
                              TGLFragmentProgram and TGLGeometryProgram
18
                             Added TGLCustomShaderParameter.AsUniformBuffer
19
                              (thanks YarUnderoaker)
20
       28/07/09 - DaStr - Added GeometryShader support (thanks YarUnderoaker)
21
                             Fixed TGLCustomShader.[...]Program serialization
22
       24/07/09 - DaStr - Added TGLCustomShader.DebugMode
23
                             Fixed spelling mistake in TGLShaderUnAplyEvent
24
                             Added TGLShaderFogSupport, IsFogEnabled()
25
       03/04/07 - DaStr - Added TGLCustomShaderParameter.AsFloat and AsInteger
26
       25/03/07 - DaStr - Added TGLCustomShaderParameter.SetToTextureOf
27
       20/03/07 - DaStr - Added DrawTexturedScreenQuad[4/5/6]
28
                             "TextureType" parameter renamed to "TextureTarget"
29
                             Finished working on TGLCustomShaderParameter
30
       04/03/07 - DaStr - Added IGLPostShader
31
       03/03/07 - DaStr - Added TGLCustomShaderParameter (beta state)
32
       22/02/07 - DaStr - Initial version (contributed to GLScene)
33

34

35
    What different shader prefixes might mean:
36

37
      ML - Multi Light      -    Shader supports up to 8 lights.
38
                                 Attributes such as [Ambient/Diffuse/Specular]
39
                                 Colors are taken from the current OpenGL
40
                                 state (that means from TGLLightSource too)
41
                                 In all other cases shader supports only
42
                                 one light, position of which is taken
43
                                 from the first registered OpenGL light.
44

45

46

47
      What different shader suffixes might mean:
48

49
       MP - Manual Parameters    - [Ambient/Diffuse/Specular] Colors have
50
                                   to be set manualy as shader's properties.
51
                                   In all other cases they are taken from
52
                                   the current OpenGL  state
53
                                   (that means from TGLLightSource too)
54

55
       MT - Manual Main Texture  - Main Texture is taken not from the
56
                                   current texture, that is applied to the
57
                                   rendered object, but has to be set manualy
58
                                   as shader's property
59
                                   In all other cases it is taken from
60
                                   the current texture, that is applied to
61
                                   the rendered object
62

63
       AM - All Manual           - MP + MMT
64

65
       AST - Auto Secondary Textures - All other textures are taken from the
66
                                       textures, that are applied to the
67
                                       rendered object after the main one
68
                                       (like the one in TGLLIbMaterial.Texture2Name,
69
                                       or any other textures that are applied to the
70
                                       object manualy using TGLMaterial.Apply
71
                                       or Direct OpenGL API)
72
                                       In all other cases they are taken from
73
                                       the shader's properties
74

75

76
    Previous version history:
77
      v1.0    11 March     '2006  Creation, separated from GLSLShader
78
      v1.1    06 August    '2006  TGLCustomShader.HandleShaderNotSupportedException added
79
                                  TGLCustomShader.ShaderNotSupportedExceptionMessage added
80
      v1.2    14 August    '2006  IGLShaderSupported separated
81
                                  TGLShaderTextureSource added
82
      v1.2.2  19 August    '2006  IMultiShaderCompatible added
83
      v1.2.4  24 August    '2006  TGLCustomShader.ParameterTexture[1-3]D added
84
      v1.2.6  04 September '2006  Minor fixes
85
      v1.3    04 November  '2006  TGLShaderUnUplyEvent added
86
                                  OnApply, OnUnApply, OnInitialize moved to
87
                                   the protected section
88
                                  (Un)ApplyBlendingMode added
89
                                  (Get/Set)ParameterTexture[1/2/3]DHandle added
90
                                  InitTexture(), DrawTexturedScreenQuad() added
91
                                  (Get/Set)ParameterCustomTextureHandle support added
92
      v1.3.2  16 December  '2006  Added shader Naming convention in the comments
93
                                  STR_SHADER_NEEDS_AT_LEAST_ONE_LIGHT_SOURCE
94
                                   moved here from StrangeGLSLBumpShader
95
                                  vStrangeShaderClassList and all shader
96
                                   registration utility functions added
97
      v1.3.4  18 February  '2007  StrangeTextureUtilities dependancy removed
98
                                  Updated to the latest CVS version of GLScene
99

100

101
}
102
unit GLCustomShader;
103

104
interface
105

106
{$I GLScene.inc}
107

108
uses
109
  // VCL
110
  Classes, SysUtils,
111

112
  GLVectorGeometry, GLVectorTypes, GLTexture, GLCadencer, OpenGLTokens, GLScene,
113
  GLStrings, GLCrossPlatform, GLContext, GLRenderContextInfo, GLMaterial,
114
  GLVectorLists, GLTextureFormat, GLSLParameter;
115

116
const
117
  glsShaderMaxLightSources = 8;
118

119
type
120
  TGLShaderFogSupport = (sfsEnabled, sfsDisabled, sfsAuto);
121
  TGLTransformFeedBackMode = (tfbmInterleaved, tfbmSeparate);
122

123
  EGLCustomShaderException = class(EGLShaderException);
124

125
  TGLCustomShader = class;
126
  TGLVertexProgram = class;
127
  TGLFragmentProgram = class;
128
  TGLGeometryProgram = class;
129

130
  TGLShaderEvent = procedure(Shader: TGLCustomShader) of object;
131
  TGLShaderUnAplyEvent = procedure(Shader: TGLCustomShader; var ThereAreMorePasses: Boolean) of object;
132

133
  TGLLightSourceEnum = 1..glsShaderMaxLightSources;
134
  TGLLightSourceSet = set of TGLLightSourceEnum;
135

136
  { This interface describes user shaders, in order to be able to access them
137
    via a unified interface. If user shader does not support some option, don't
138
    raise an axception, just ignore it.
139
  }
140
  IGLShaderDescription = interface
141
  ['{04089C64-60C2-43F5-AC9C-38ED46264812}']
142
    procedure SetShaderTextures(const Textures: array of TGLTexture);
143
    procedure GetShaderTextures(var Textures: array of TGLTexture);
144

145
    procedure SetShaderColorParams(const AAmbientColor, ADiffuseColor, ASpecularcolor: TVector4f);
146
    procedure GetShaderColorParams(var AAmbientColor, ADiffuseColor, ASpecularcolor: TVector4f);
147

148
    procedure SetShaderMiscParameters(const ACadencer: TGLCadencer; const AMatLib: TGLMaterialLibrary; const ALightSources: TGLLightSourceSet);
149
    procedure GetShaderMiscParameters(var ACadencer: TGLCadencer; var AMatLib: TGLMaterialLibrary; var ALightSources: TGLLightSourceSet);
150

151
    function GetShaderAlpha: Single;
152
    procedure SetShaderAlpha(const Value: Single);
153

154
    function GetShaderDescription: string;
155
  end;
156

157
  { Used in the TGLPostShaderHolder component. }
158
  IGLPostShader = interface
159
  ['{68A62362-AF0A-4CE8-A9E1-714FE02AFA4A}']
160
    { Called on every pass. }
161
    procedure DoUseTempTexture(const TempTexture: TGLTextureHandle;
162
      TextureTarget: TGLTextureTarget);
163
    { Called to determine if it is compatible. }
164
    function GetTextureTarget: TGLTextureTarget;
165
  end;
166

167
  { A pure abstract class, must be overriden. }
168
  TGLCustomShader = class(TGLShader)
169
  private
170
    FFragmentProgram: TGLFragmentProgram;
171
    FVertexProgram: TGLVertexProgram;
172
    FGeometryProgram: TGLGeometryProgram;
173

174
    FTagObject: TObject;
175
    procedure SetFragmentProgram(const Value: TGLFragmentProgram);
176
    procedure SetGeometryProgram(const Value: TGLGeometryProgram);
177
    procedure SetVertexProgram(const Value: TGLVertexProgram);
178
    function StoreFragmentProgram: Boolean;
179
    function StoreGeometryProgram: Boolean;
180
    function StoreVertexProgram: Boolean;
181
  protected
182
    FDebugMode: Boolean;
183
    procedure SetDebugMode(const Value: Boolean); virtual;
184

185
    property FragmentProgram: TGLFragmentProgram read FFragmentProgram write SetFragmentProgram stored StoreFragmentProgram;
186
    property VertexProgram: TGLVertexProgram read FVertexProgram write SetVertexProgram stored StoreVertexProgram;
187
    property GeometryProgram: TGLGeometryProgram read FGeometryProgram write SetGeometryProgram stored StoreGeometryProgram;
188

189
    { Treats warnings as errors and displays this error,
190
       instead of a general shader-not-supported message. }
191
    property DebugMode: Boolean read FDebugMode write SetDebugMode default False;
192
    property TagObject: TObject read FTagObject write FTagObject default nil;
193
  public
194
    constructor Create(AOwner: TComponent); override;
195
    destructor Destroy; override;
196
    procedure Assign(Source: TPersistent); override;
197

198
    procedure LoadShaderPrograms(const VPFilename, FPFilename: string; GPFilename: string = '');
199
  end;
200

201
  { A custom shader program. }
202
  TGLShaderProgram = class(TPersistent)
203
  private
204
    FParent: TGLCustomShader;
205
    FEnabled: Boolean;
206
    FCode: TStrings;
207
    procedure SetCode(const Value: TStrings);
208
    procedure SetEnabled(const Value: Boolean);
209
    procedure OnChangeCode(Sender: TObject);
210
  protected
211
    function GetOwner: TPersistent; override;
212
  public
213
    procedure LoadFromFile(const AFileName: string);
214
    procedure Apply; virtual;
215
    constructor Create(const AParent: TGLCustomShader); virtual;
216
    destructor Destroy; override;
217
    procedure Assign(Source: TPersistent); override;
218
  published
219
    property Code: TStrings read FCode write SetCode;
220
    property Enabled: Boolean read FEnabled write SetEnabled default False;
221
  end;
222

223
  TGLVertexProgram = class(TGLShaderProgram)
224
  published
225
    property Code;
226
    property Enabled;
227
  end;
228

229
  TGLFragmentProgram = class(TGLShaderProgram)
230
  published
231
    property Code;
232
    property Enabled;
233
  end;
234

235
  TGLGeometryProgram = class(TGLShaderProgram)
236
  private
237
    FInputPrimitiveType: TGLgsInTypes;
238
    FOutputPrimitiveType: TGLgsOutTypes;
239
    FVerticesOut: TGLint;
240
    procedure SetInputPrimitiveType(const Value: TGLgsInTypes);
241
    procedure SetOutputPrimitiveType(const Value: TGLgsOutTypes);
242
    procedure SetVerticesOut(const Value: TGLint);
243
  public
244
    constructor Create(const AParent: TGLCustomShader); override;
245
  published
246
    property Code;
247
    property Enabled;
248

249
    property InputPrimitiveType: TGLgsInTypes read FInputPrimitiveType write SetInputPrimitiveType default gsInPoints;
250
    property OutputPrimitiveType: TGLgsOutTypes read FOutputPrimitiveType write SetOutputPrimitiveType default gsOutPoints;
251
    property VerticesOut: TGLint read FVerticesOut write SetVerticesOut default 0;
252
  end;
253

254
  { Wrapper around a parameter of the main program. }
255
  TGLCustomShaderParameter = class(TObject)
256
  private
257
     
258
  protected
259
     
260
    function GetAsVector1f: Single; virtual; abstract;
261
    function GetAsVector2f: TVector2f; virtual; abstract;
262
    function GetAsVector3f: TVector3f; virtual; abstract;
263
    function GetAsVector4f: TVector; virtual; abstract;
264

265
    function GetAsVector1i: Integer; virtual; abstract;
266
    function GetAsVector2i: TVector2i; virtual; abstract;
267
    function GetAsVector3i: TVector3i; virtual; abstract;
268
    function GetAsVector4i: TVector4i; virtual; abstract;
269

270
    function GetAsVector1ui: GLuint; virtual; abstract;
271
    function GetAsVector2ui: TVector2ui; virtual; abstract;
272
    function GetAsVector3ui: TVector3ui; virtual; abstract;
273
    function GetAsVector4ui: TVector4ui; virtual; abstract;
274

275
    procedure SetAsVector1f(const Value: Single); virtual; abstract;
276
    procedure SetAsVector2f(const Value: TVector2f); virtual; abstract;
277
    procedure SetAsVector3f(const Value: TVector3f); virtual; abstract;
278
    procedure SetAsVector4f(const Value: TVector4f); virtual; abstract;
279

280
    procedure SetAsVector1i(const Value: Integer); virtual; abstract;
281
    procedure SetAsVector2i(const Value: TVector2i); virtual; abstract;
282
    procedure SetAsVector3i(const Value: TVector3i); virtual; abstract;
283
    procedure SetAsVector4i(const Value: TVector4i); virtual; abstract;
284

285
    procedure SetAsVector1ui(const Value: GLuint); virtual; abstract;
286
    procedure SetAsVector2ui(const Value: TVector2ui); virtual; abstract;
287
    procedure SetAsVector3ui(const Value: TVector3ui); virtual; abstract;
288
    procedure SetAsVector4ui(const Value: TVector4ui); virtual; abstract;
289

290
    function GetAsMatrix2f: TMatrix2f; virtual; abstract;
291
    function GetAsMatrix3f: TMatrix3f; virtual; abstract;
292
    function GetAsMatrix4f: TMatrix4f; virtual; abstract;
293
    procedure SetAsMatrix2f(const Value: TMatrix2f); virtual; abstract;
294
    procedure SetAsMatrix3f(const Value: TMatrix3f); virtual; abstract;
295
    procedure SetAsMatrix4f(const Value: TMatrix4f); virtual; abstract;
296

297
    procedure SetAsTexture(const TextureIndex: Integer;
298
      const Value: TGLTexture);
299
    procedure SetAsTexture1D(const TextureIndex: Integer;
300
      const Value: TGLTexture);
301
    procedure SetAsTexture2D(const TextureIndex: Integer;
302
      const Value: TGLTexture);
303
    procedure SetAsTexture3D(const TextureIndex: Integer;
304
      const Value: TGLTexture);
305
    procedure SetAsTextureCube(const TextureIndex: Integer;
306
      const Value: TGLTexture);
307
    procedure SetAsTextureRect(const TextureIndex: Integer;
308
      const Value: TGLTexture);
309

310
    function GetAsCustomTexture(const TextureIndex: Integer;
311
      TextureTarget: TGLTextureTarget): Cardinal; virtual; abstract;
312
    procedure SetAsCustomTexture(const TextureIndex: Integer;
313
      TextureTarget: TGLTextureTarget; const Value: Cardinal); virtual; abstract;
314

315
    function GetAsUniformBuffer: GLenum; virtual; abstract;
316
    procedure SetAsUniformBuffer(UBO: GLenum); virtual; abstract;
317
  public
318
     
319

320
    { This overloaded SetAsVector accepts open array as input. e.g.
321
       SetAsVectorF([0.1, 0.2]). Array length must between 1-4. }
322
    procedure SetAsVectorF(const Values: array of Single); overload;
323
    procedure SetAsVectorI(const Values: array of Integer); overload;
324

325
    { SetToTextureOf determines texture type on-the-fly.}
326
    procedure SetToTextureOf(const LibMaterial: TGLLibMaterial; const TextureIndex: Integer); overload;
327
    procedure SetToTextureOf(const Texture: TGLTexture; const TextureIndex: Integer); overload;
328

329
    // GLScene-friendly properties.
330
    property AsVector: TVector read GetAsVector4f write SetAsVector4f;
331
    property AsAffineVector: TAffineVector read GetAsVector3f write SetAsVector3f;
332

333
    // Standard types.
334
    property AsFloat: Single read GetAsVector1f write SetAsVector1f;
335
    property AsInteger: Integer read GetAsVector1i write SetAsVector1i;
336

337
    // Float vector types.
338
    property AsVector1f: Single    read GetAsVector1f write SetAsVector1f;
339
    property AsVector2f: TVector2f read GetAsVector2f write SetAsVector2f;
340
    property AsVector3f: TVector3f read GetAsVector3f write SetAsVector3f;
341
    property AsVector4f: TVector4f read GetAsVector4f write SetAsVector4f;
342

343
    // Integer vector  types.
344
    property AsVector1i: Integer   read GetAsVector1i write SetAsVector1i;
345
    property AsVector2i: TVector2i read GetAsVector2i write SetAsVector2i;
346
    property AsVector3i: TVector3i read GetAsVector3i write SetAsVector3i;
347
    property AsVector4i: TVector4i read GetAsVector4i write SetAsVector4i;
348

349
    // Unsigned integer vector  types.
350
    property AsVector1ui: GLuint   read GetAsVector1ui write SetAsVector1ui;
351
    property AsVector2ui: TVector2ui read GetAsVector2ui write SetAsVector2ui;
352
    property AsVector3ui: TVector3ui read GetAsVector3ui write SetAsVector3ui;
353
    property AsVector4ui: TVector4ui read GetAsVector4ui write SetAsVector4ui;
354

355
    // Matrix Types.
356
    property AsMatrix2f: TMatrix2f read GetAsMatrix2f write SetAsMatrix2f;
357
    property AsMatrix3f: TMatrix3f read GetAsMatrix3f write SetAsMatrix3f;
358
    property AsMatrix4f: TMatrix4f read GetAsMatrix4f write SetAsMatrix4f;
359

360
    // Texture Types.
361
    property AsTexture    [const TextureIndex: Integer]: TGLTexture write SetAsTexture;
362
    property AsTexture1D  [const TextureIndex: Integer]: TGLTexture write SetAsTexture1D;
363
    property AsTexture2D  [const TextureIndex: Integer]: TGLTexture write SetAsTexture2D;
364
    property AsTexture3D  [const TextureIndex: Integer]: TGLTexture write SetAsTexture3D;
365
    property AsTextureRect[const TextureIndex: Integer]: TGLTexture write SetAsTextureRect;
366
    property AsTextureCube[const TextureIndex: Integer]: TGLTexture write SetAsTextureCube;
367

368
    property AsCustomTexture[const TextureIndex: Integer; TextureTarget: TGLTextureTarget]: Cardinal read GetAsCustomTexture write SetAsCustomTexture;
369

370
    property AsUniformBuffer: GLenum read GetAsUniformBuffer write SetAsUniformBuffer;
371
  end;
372

373

374
  { Adds two more blending modes to standard ones.
375
    Not sure how to name them or if they should be included in TBlending mode,
376
    so I created a new type here. }
377
  TGLBlendingModeEx = (bmxOpaque, bmxTransparency, bmxAdditive,
378
    bmxAlphaTest50, bmxAlphaTest100, bmxModulate,
379
    bmxDestColorOne, bmxDestAlphaOne);
380

381
// Exported procedures.
382
procedure ApplyBlendingModeEx(const BlendingMode: TGLBlendingModeEx);
383
procedure UnApplyBlendingModeEx;
384
procedure InitTexture(
385
  const TextureHandle: Cardinal;
386
  const TextureSize: TGLSize;
387
  const TextureTarget: TGLTextureTarget = ttTexture2D);
388
// Probably need to give them proper names, instead of numbers... 
389
procedure DrawTexturedScreenQuad;
390
procedure DrawTexturedScreenQuad2(const ViewPortSize: TGLSize);
391
procedure DrawTexturedScreenQuad3;
392
procedure DrawTexturedScreenQuad4(const ViewPortSize: TGLSize);
393
procedure DrawTexturedScreenQuad5(const ViewPortSize: TGLSize);
394
procedure DrawTexturedScreenQuad6(const ViewPortSize: TGLSize);
395

396
procedure CopyScreentoTexture(const ViewPortSize: TGLSize; const TextureTarget: Word = GL_TEXTURE_2D);
397
procedure CopyScreentoTexture2(const ViewPortSize: TGLSize; const TextureTarget: Word = GL_TEXTURE_2D);
398

399
function IsFogEnabled(const AFogSupportMode: TGLShaderFogSupport; var rci: TGLRenderContextInfo): Boolean;
400
procedure GetActiveLightsList(const ALightIDs: TIntegerList);
401

402
implementation
403

404
uses
405
  GLState;
406

407
procedure GetActiveLightsList(const ALightIDs: TIntegerList);
408
var
409
  I: Integer;
410
begin
411
  ALightIDs.Clear;
412
  with CurrentGLContext.GLStates do
413
  begin
414
    for I := 0 to MaxLights - 1 do
415
    begin
416
      if LightEnabling[I] then
417
        ALightIDs.Add(I);
418
    end;
419
  end;
420
end;
421

422
function IsFogEnabled(const AFogSupportMode: TGLShaderFogSupport; var rci: TGLRenderContextInfo): Boolean;
423
begin
424
  case AFogSupportMode of
425
    sfsEnabled:  Result := True;
426
    sfsDisabled: Result := False;
427
    sfsAuto:     Result := TGLSceneBuffer(rci.buffer).FogEnable;
428
  else
429
    Result := False;
430
    Assert(False, glsUnknownType);
431
  end;
432
end;
433

434
procedure CopyScreentoTexture(const ViewPortSize: TGLSize; const TextureTarget: Word = GL_TEXTURE_2D);
435
begin
436
  GL.CopyTexSubImage2D(TextureTarget, 0, 0, 0, 0, 0, ViewPortSize.cx, ViewPortSize.cy);
437
end;
438

439
procedure CopyScreentoTexture2(const ViewPortSize: TGLSize; const TextureTarget: Word = GL_TEXTURE_2D);
440
begin
441
  GL.CopyTexImage2D(TextureTarget, 0, GL_RGB, 0, 0, ViewPortSize.cx, ViewPortSize.cy, 0);
442
end;
443

444
procedure ApplyBlendingModeEx(const BlendingMode: TGLBlendingModeEx);
445
begin
446
  with CurrentGLContext.GLStates do
447
  begin
448
    Enable(stBlend);
449

450
    case BlendingMode of
451
      bmxOpaque: SetBlendFunc(bfSRCALPHA, bfONE);
452
      bmxTransparency: SetBlendFunc(bfSRCALPHA, bfONEMINUSSRCALPHA);
453
      bmxAdditive: SetBlendFunc(bfSRCALPHA, bfONE);
454
      bmxAlphaTest50: SetGLAlphaFunction(cfGEQUAL, 0.5);
455
      bmxAlphaTest100: SetGLAlphaFunction(cfGEQUAL, 1.0);
456
      bmxModulate: SetBlendFunc(bfDSTCOLOR, bfZERO);
457
      bmxDestColorOne: SetBlendFunc(bfDSTCOLOR, bfONE);
458
      bmxDestAlphaOne: SetBlendFunc(bfDSTALPHA, bfONE);
459
      else
460
        Assert(False, glsErrorEx + glsUnknownType);
461
    end;
462
  end;
463
end;
464

465
procedure UnApplyBlendingModeEx;
466
begin
467
end;
468

469
procedure DrawTexturedScreenQuad;
470
begin
471
  GL.MatrixMode(GL_MODELVIEW);
472
  GL.PushMatrix;
473
  GL.LoadIdentity;
474
  GL.MatrixMode(GL_PROJECTION);
475
    GL.PushMatrix;
476
    GL.LoadIdentity;
477

478
    // drawing rectangle over screen
479
    GL.Disable(GL_DEPTH_TEST);
480
    DrawTexturedScreenQuad3;
481
    GL.Enable(GL_DEPTH_TEST);
482

483
  GL.PopMatrix;
484
  GL.MatrixMode(GL_MODELVIEW);
485
  GL.PopMatrix;
486
end;
487

488
procedure DrawTexturedScreenQuad2(const ViewPortSize: TGLSize);
489
begin
490
  GL.PushMatrix;
491
  GL.MatrixMode(GL_PROJECTION);
492
    GL.PushMatrix;
493
    GL.LoadIdentity;
494
    GL.Ortho(0, ViewPortSize.cx, ViewPortSize.cy, 0, 0, 1);
495
    GL.Disable(GL_DEPTH_TEST);
496
    GL.DepthMask(False);
497
    GL.Begin_(GL_QUADS);
498
      GL.TexCoord2f(0.0, ViewPortSize.cy);             GL.Vertex2f(0, 0);
499
      GL.TexCoord2f(0.0, 0.0);                         GL.Vertex2f(0, ViewPortSize.cy);
500
      GL.TexCoord2f(ViewPortSize.cx, 0.0);             GL.Vertex2f(ViewPortSize.cx, ViewPortSize.cy);
501
      GL.TexCoord2f(ViewPortSize.cx, ViewPortSize.cy); GL.Vertex2f(ViewPortSize.cx, 0);
502
    GL.End_;
503
    GL.DepthMask(True);
504
    GL.Enable(GL_DEPTH_TEST);
505
    GL.MatrixMode(GL_PROJECTION);
506
    GL.PopMatrix;
507
  GL.MatrixMode(GL_MODELVIEW);
508
  GL.PopMatrix;
509
end;
510

511
procedure DrawTexturedScreenQuad4(const ViewPortSize: TGLSize);
512
begin
513
  GL.Begin_(GL_QUADS);
514
    GL.TexCoord2f(0, 0);                             GL.Vertex2f(-1, -1);
515
    GL.TexCoord2f(ViewPortSize.cx, 0);               GL.Vertex2f( 1, -1);
516
    GL.TexCoord2f(ViewPortSize.cx, ViewPortSize.cy); GL.Vertex2f( 1,  1);
517
    GL.TexCoord2f(0, ViewPortSize.cy);               GL.Vertex2f(-1,  1);
518
  GL.End_;
519
end;
520

521
procedure DrawTexturedScreenQuad5(const ViewPortSize: TGLSize);
522
begin
523
  GL.MatrixMode( GL_PROJECTION );
524
  GL.PushMatrix;
525
    GL.LoadIdentity;
526
    GL.Ortho( 0, ViewPortSize.cx, ViewPortSize.cy, 0, 0, 1 );
527
    GL.MatrixMode(GL_MODELVIEW);
528
    GL.PushMatrix;
529
      GL.LoadIdentity;
530
      GL.Disable(GL_DEPTH_TEST);
531
      GL.DepthMask( FALSE );
532
      DrawTexturedScreenQuad3;
533
      GL.DepthMask( TRUE );
534
      GL.Enable(GL_DEPTH_TEST);
535
    GL.PopMatrix;
536
    GL.MatrixMode( GL_PROJECTION );
537
  GL.PopMatrix;
538
  GL.MatrixMode( GL_MODELVIEW );
539
end;
540

541
procedure DrawTexturedScreenQuad6(const ViewPortSize: TGLSize);
542
begin
543
  GL.MatrixMode( GL_PROJECTION );
544
  GL.PushMatrix;
545
    GL.LoadIdentity;
546
    GL.Ortho( 0, ViewPortSize.cx, ViewPortSize.cy, 0, 0, 1 );
547
    GL.MatrixMode(GL_MODELVIEW);
548
    GL.PushMatrix;
549
      GL.LoadIdentity;
550
      GL.Disable(GL_DEPTH_TEST);
551
      GL.DepthMask( FALSE );
552
      DrawTexturedScreenQuad4(ViewPortSize);;
553
      GL.DepthMask( TRUE );
554
      GL.Enable(GL_DEPTH_TEST);
555
    GL.PopMatrix;
556
    GL.MatrixMode( GL_PROJECTION );
557
  GL.PopMatrix;
558
  GL.MatrixMode( GL_MODELVIEW );
559
end;
560

561
procedure DrawTexturedScreenQuad3;
562
begin
563
  GL.Begin_(GL_QUADS);
564
    GL.TexCoord2f(0, 0); GL.Vertex2f(-1, -1);
565
    GL.TexCoord2f(1, 0); GL.Vertex2f(1, -1);
566
    GL.TexCoord2f(1, 1); GL.Vertex2f(1, 1);
567
    GL.TexCoord2f(0, 1); GL.Vertex2f(-1, 1);
568
  GL.End_;
569
end;
570

571
procedure InitTexture(
572
  const TextureHandle: Cardinal;
573
  const TextureSize: TGLSize;
574
  const TextureTarget: TGLTextureTarget = ttTexture2D);
575
var
576
  glTarget: TGLEnum;
577
begin
578
  with CurrentGLContext.GLStates do
579
  begin
580
    TextureBinding[ActiveTexture, TextureTarget] := TextureHandle;
581
  end;
582
  glTarget := DecodeGLTextureTarget(TextureTarget);
583
  GL.TexParameteri(glTarget, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);
584
  GL.TexParameteri(glTarget, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);
585
  GL.TexParameteri(glTarget, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
586
  GL.TexParameteri(glTarget, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
587
  GL.CopyTexImage2D(glTarget, 0, GL_RGBA8, 0, 0, TextureSize.cx, TextureSize.cy, 0);
588
end;
589

590
{ TGLShaderProgram }
591

592
procedure TGLShaderProgram.Apply;
593
begin
594
  FParent.FinalizeShader;
595
end;
596

597

598
procedure TGLShaderProgram.Assign(Source: TPersistent);
599
begin
600
  if Source = nil then
601
    Exit;
602

603
  if (Source is TGLShaderProgram) then
604
  begin
605
    FEnabled := TGLShaderProgram(Source).FEnabled;
606
    FCode.Assign(TGLShaderProgram(Source).FCode);
607
  end
608
  else
609
    inherited; //die, die, die!!!
610
end;
611

612

613
constructor TGLShaderProgram.Create(const AParent: TGLCustomShader);
614
begin
615
  FParent := AParent;
616
  FCode := TStringList.Create;
617
  TStringList(FCode).OnChange := OnChangeCode;
618
  FEnabled := False;
619
end;
620

621

622
destructor TGLShaderProgram.Destroy;
623
begin
624
  FCode.Destroy;
625
end;
626

627

628
function TGLShaderProgram.GetOwner: TPersistent;
629
begin
630
  Result := FParent;
631
end;
632

633
procedure TGLShaderProgram.LoadFromFile(const AFileName: string);
634
begin
635
  FCode.LoadFromFile(AFileName);
636
  FEnabled := True;
637
end;
638

639

640
procedure TGLShaderProgram.OnChangeCode(Sender: TObject);
641
begin
642
  FEnabled := True;
643
  FParent.NotifyChange(self);
644
end;
645

646

647
procedure TGLShaderProgram.SetCode(const Value: TStrings);
648
begin
649
  FCode.Assign(Value);
650
  FParent.NotifyChange(self);
651
end;
652

653

654
procedure TGLShaderProgram.SetEnabled(const Value: Boolean);
655
begin
656
  if Value = FEnabled then
657
    Exit;
658
  FEnabled := Value;
659
  if FEnabled then
660
    FParent.FinalizeShader;
661
end;
662

663

664
{ TGLCustomShader }
665

666
procedure TGLCustomShader.Assign(Source: TPersistent);
667
begin
668
  if Source is TGLCustomShader then
669
  begin
670
    FFragmentProgram.Assign(TGLCustomShader(Source).FFragmentProgram);
671
    FVertexProgram.Assign(TGLCustomShader(Source).FVertexProgram);
672
    FGeometryProgram.Assign(TGLCustomShader(Source).FGeometryProgram);
673
    FTagObject := TGLCustomShader(Source).FTagObject;
674
  end;
675
  inherited;
676
end;
677

678

679
constructor TGLCustomShader.Create(AOwner: TComponent);
680
begin
681
  inherited Create(AOwner);
682

683
  FDebugMode := False;
684
  FFragmentProgram := TGLFragmentProgram.Create(Self);
685
  FVertexProgram := TGLVertexProgram.Create(Self);
686
  FGeometryProgram := TGLGeometryProgram.Create(Self);
687
end;
688

689

690
destructor TGLCustomShader.Destroy;
691
begin
692
  FFragmentProgram.Destroy;
693
  FVertexProgram.Destroy;
694
  FGeometryProgram.Destroy;
695

696
  inherited;
697
end;
698

699
procedure TGLCustomShader.LoadShaderPrograms(const VPFilename, FPFilename: string; GPFilename: string = '');
700
begin
701
  If VPFilename <> '' then VertexProgram.LoadFromFile(VPFilename);
702
  If FPFilename <> '' then FragmentProgram.LoadFromFile(FPFilename);
703
  If GPFilename <> '' then GeometryProgram.LoadFromFile(GPFilename);
704
end;
705

706
procedure TGLCustomShader.SetDebugMode(const Value: Boolean);
707
begin
708
  if FDebugMode <> Value then
709
  begin
710
    FDebugMode := Value;
711

712
    if FDebugMode then
713
      FailedInitAction := fiaReRaiseException
714
    else
715
      FailedInitAction := fiaRaiseStandardException;
716
  end;
717
end;
718

719
procedure TGLCustomShader.SetFragmentProgram(const Value: TGLFragmentProgram);
720
begin
721
  FFragmentProgram.Assign(Value);
722
end;
723

724
procedure TGLCustomShader.SetGeometryProgram(const Value: TGLGeometryProgram);
725
begin
726
  FGeometryProgram.Assign(Value);
727
end;
728

729
procedure TGLCustomShader.SetVertexProgram(const Value: TGLVertexProgram);
730
begin
731
  FVertexProgram.Assign(Value);
732
end;
733

734
function TGLCustomShader.StoreFragmentProgram: Boolean;
735
begin
736
  Result := FFragmentProgram.Enabled or (FFragmentProgram.Code.Text <> '')
737
end;
738

739
function TGLCustomShader.StoreGeometryProgram: Boolean;
740
begin
741
  Result := FGeometryProgram.Enabled or (FGeometryProgram.Code.Text <> '')
742
end;
743

744
function TGLCustomShader.StoreVertexProgram: Boolean;
745
begin
746
  Result := FVertexProgram.Enabled or (FVertexProgram.Code.Text <> '')
747
end;
748

749
{ TGLCustomShaderParameter }
750

751
procedure TGLCustomShaderParameter.SetAsTexture(
752
  const TextureIndex: Integer; const Value: TGLTexture);
753
begin
754
  SetAsCustomTexture(TextureIndex, Value.TextureHandle.Target, Value.Handle);
755
end;
756

757
procedure TGLCustomShaderParameter.SetAsTexture1D(
758
  const TextureIndex: Integer; const Value: TGLTexture);
759
begin
760
  SetAsCustomTexture(TextureIndex, ttTexture1D, Value.Handle);
761
end;
762

763
procedure TGLCustomShaderParameter.SetAsTexture2D(
764
  const TextureIndex: Integer; const Value: TGLTexture);
765
begin
766
  SetAsCustomTexture(TextureIndex, ttTexture2D, Value.Handle);
767
end;
768

769
procedure TGLCustomShaderParameter.SetAsTexture3D(
770
  const TextureIndex: Integer; const Value: TGLTexture);
771
begin
772
  SetAsCustomTexture(TextureIndex, ttTexture3D, Value.Handle);
773
end;
774

775
procedure TGLCustomShaderParameter.SetAsTextureCube(
776
  const TextureIndex: Integer; const Value: TGLTexture);
777
begin
778
  SetAsCustomTexture(TextureIndex, ttTextureCube, Value.Handle);
779
end;
780

781
procedure TGLCustomShaderParameter.SetAsTextureRect(
782
  const TextureIndex: Integer; const Value: TGLTexture);
783
begin
784
  SetAsCustomTexture(TextureIndex, ttTextureRect, Value.Handle);
785
end;
786

787
procedure TGLCustomShaderParameter.SetAsVectorF(const Values: array of Single);
788
begin
789
  case Length(Values) of
790
    1: SetAsVector1f(Values[0]);
791
    2: SetAsVector2f(Vector2fMake(Values[0], Values[1]));
792
    3: SetAsVector3f(Vector3fMake(Values[0], Values[1], Values[2]));
793
    4: SetAsVector4f(Vector4fMake(Values[0], Values[1], Values[2], Values[3]));
794
  else
795
    Assert(False, 'Vector length must be between 1 to 4');
796
  end;
797
end;
798

799
procedure TGLCustomShaderParameter.SetAsVectorI(const Values: array of Integer);
800
begin
801
  case Length(Values) of
802
    1: SetAsVector1i(Values[0]);
803
    2: SetAsVector2i(Vector2iMake(Values[0], Values[1]));
804
    3: SetAsVector3i(Vector3iMake(Values[0], Values[1], Values[2]));
805
    4: SetAsVector4i(Vector4iMake(Values[0], Values[1], Values[2], Values[3]));
806
  else
807
    Assert(False, 'Vector length must be between 1 to 4');
808
  end;
809
end;
810

811
procedure TGLCustomShaderParameter.SetToTextureOf(
812
  const LibMaterial: TGLLibMaterial; const TextureIndex: Integer);
813
begin
814
  SetToTextureOf(LibMaterial.Material.Texture, TextureIndex);
815
end;
816

817
procedure TGLCustomShaderParameter.SetToTextureOf(
818
  const Texture: TGLTexture; const TextureIndex: Integer);
819
begin
820
  SetAsCustomTexture(TextureIndex, Texture.Image.NativeTextureTarget, Texture.Handle);
821
end;
822

823
constructor TGLGeometryProgram.Create(const AParent: TGLCustomShader);
824
begin
825
  inherited Create(AParent);
826
  FInputPrimitiveType := gsInPoints;
827
  FOutputPrimitiveType := gsOutPoints;
828
  FVerticesOut := 0;
829
end;
830

831
procedure TGLGeometryProgram.SetInputPrimitiveType(const Value: TGLgsInTypes);
832
begin
833
  if Value <> FInputPrimitiveType then
834
  begin
835
    FInputPrimitiveType := Value;
836
    FParent.NotifyChange(Self);
837
  end;
838
end;
839

840
procedure TGLGeometryProgram.SetOutputPrimitiveType(const Value: TGLgsOutTypes);
841
begin
842
  if Value<>FOutputPrimitiveType then
843
  begin
844
    FOutputPrimitiveType := Value;
845
    FParent.NotifyChange(Self);
846
  end;
847
end;
848

849
procedure TGLGeometryProgram.SetVerticesOut(const Value: TGLint);
850
begin
851
  if Value<>FVerticesOut then
852
  begin
853
    FVerticesOut := Value;
854
    FParent.NotifyChange(Self);
855
  end;
856
end;
857

858
initialization
859
  RegisterClasses([TGLCustomShader, TGLShaderProgram,
860
                   TGLVertexProgram, TGLFragmentProgram, TGLGeometryProgram]);
861

862
end.
863