LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
    TGLAsmShader is a wrapper for all ARB shaders
6
    This component is only a template and has to be replaced with a
7
    proper version by someone who uses ARB shaders more then me.
8

9
  History :  
10
       23/08/10 - Yar - Upgraded program hadles
11
       04/06/10 - Yar - Replace OpenGL functons to OpenGLAdapter
12
       28/07/09 - DaStr - Added GeomertyShader support (thanks YarUnderoaker)
13
       24/07/09 - DaStr - TGLShader.DoInitialize() now passes rci
14
                              (BugTracker ID = 2826217)
15
       20/03/07 - DaStr - TGLCustomAsmShader now generates its own events
16
                             All outside stuff moved back to TGLPhongShader
17
       22/02/07 - DaStr - Initial version (contributed to GLScene)
18

19
    Previous version history:
20
      v1.0    12 March     '2005  Creation
21
      v1.1    31 October   '2006  TGLCustomAsmShader.DoUnApply() Fix
22
                                  TGLAsmShader has more stuff in the published section
23
}
24
unit GLAsmShader;
25

26
interface
27

28
{$I GLScene.inc}
29

30
uses
31
  // VCL
32
  Classes, SysUtils,
33

34
  GLVectorGeometry, GLVectorTypes, GLTexture, OpenGLTokens, GLContext,
35
  GLCustomShader, GLRenderContextInfo;
36

37
type
38
  TGLCustomAsmShader = class;
39
  TGLAsmShaderEvent = procedure(Shader: TGLCustomAsmShader) of object;
40
  TGLAsmShaderUnUplyEvent = procedure(Shader: TGLCustomAsmShader; var ThereAreMorePasses: Boolean) of object;
41

42
  TGLAsmShaderParameter = class(TGLCustomShaderParameter)
43
  private
44
     
45
  protected
46
     
47
{
48
    function GetAsVector1f: Single; override;
49
    function GetAsVector1i: Integer; override;
50
    function GetAsVector2f: TVector2f; override;
51
    function GetAsVector2i: TVector2i; override;
52
    function GetAsVector3f: TVector3f; override;
53
    function GetAsVector3i: TVector3i; override;
54
    function GetAsVector4f: TVector; override;
55
    function GetAsVector4i: TVector4i; override;
56

57
    procedure SetAsVector1f(const Value: Single); override;
58
    procedure SetAsVector1i(const Value: Integer); override;
59
    procedure SetAsVector2i(const Value: TVector2i); override;
60
    procedure SetAsVector3i(const Value: TVector3i); override;
61
    procedure SetAsVector4i(const Value: TVector4i); override;
62
    procedure SetAsVector2f(const Value: TVector2f); override;
63
    procedure SetAsVector3f(const Value: TVector3f); override;
64
    procedure SetAsVector4f(const Value: TVector4f); override;
65

66
    function GetAsMatrix2f: TMatrix2f; override;
67
    function GetAsMatrix3f: TMatrix3f; override;
68
    function GetAsMatrix4f: TMatrix4f; override;
69
    procedure SetAsMatrix2f(const Value: TMatrix2f); override;
70
    procedure SetAsMatrix3f(const Value: TMatrix3f); override;
71
    procedure SetAsMatrix4f(const Value: TMatrix4f); override;
72

73
    procedure SetAsTexture1D(const TextureIndex: Integer;
74
      const Value: TGLTexture);
75
    procedure SetAsTexture2D(const TextureIndex: Integer;
76
      const Value: TGLTexture);
77
    procedure SetAsTexture3D(const TextureIndex: Integer;
78
      const Value: TGLTexture);
79
    procedure SetAsTextureCube(const TextureIndex: Integer;
80
      const Value: TGLTexture);
81
    procedure SetAsTextureRect(const TextureIndex: Integer;
82
      const Value: TGLTexture);
83

84
    function GetAsCustomTexture(const TextureIndex: Integer;
85
      const TextureTarget: Word): Cardinal; override;
86
    procedure SetAsCustomTexture(const TextureIndex: Integer;
87
      const TextureTarget: Word; const Value: Cardinal); override;
88
}
89
  end;
90

91
  TGLCustomAsmShader = class(TGLCustomShader)
92
  private
93
     
94
    FVPHandle: TGLARBVertexProgramHandle;
95
    FFPHandle: TGLARBFragmentProgramHandle;
96
    FGPHandle: TGLARBGeometryProgramHandle;
97

98
    FOnInitialize: TGLAsmShaderEvent;
99
    FOnApply: TGLAsmShaderEvent;
100
    FOnUnApply: TGLAsmShaderUnUplyEvent;
101
  protected
102
     
103
    procedure ApplyShaderPrograms;
104
    procedure UnApplyShaderPrograms;
105
    procedure DestroyARBPrograms; virtual;
106

107
    property OnApply: TGLAsmShaderEvent read FOnApply write FOnApply;
108
    property OnUnApply: TGLAsmShaderUnUplyEvent read FOnUnApply write FOnUnApply;
109
    property OnInitialize: TGLAsmShaderEvent read FOnInitialize write FOnInitialize;
110

111
    procedure DoInitialize(var rci: TGLRenderContextInfo; Sender: TObject); override;
112
    procedure DoApply(var rci: TGLRenderContextInfo; Sender: TObject); override;
113
    function DoUnApply(var rci: TGLRenderContextInfo): Boolean; override;
114
    procedure DoFinalize; override;
115
  public
116
     
117
    constructor Create(AOwner: TComponent); override;
118
    destructor Destroy; override;
119
    procedure Assign(Source: TPersistent); override;
120

121
    function ShaderSupported: Boolean; override;
122
  end;
123

124
  TGLAsmShader = class(TGLCustomAsmShader)
125
  published
126
    property FragmentProgram;
127
    property VertexProgram;
128
    property GeometryProgram;
129

130
    property OnApply;
131
    property OnUnApply;
132
    property OnInitialize;
133

134
    property ShaderStyle;
135
    property FailedInitAction;
136
  end;
137

138
implementation
139

140
{ TGLCustomAsmShader }
141

142
procedure TGLCustomAsmShader.DoFinalize;
143
begin
144
  inherited;
145
  DestroyARBPrograms;
146
end;
147

148
procedure TGLCustomAsmShader.Assign(Source: TPersistent);
149
begin
150
  inherited Assign(Source);
151

152
  if Source is TGLCustomAsmShader then
153
  begin
154
    // Nothing here ...yet
155
  end;
156
end;
157

158
constructor TGLCustomAsmShader.Create(AOwner: TComponent);
159
begin
160
  inherited Create(AOwner);
161
end;
162

163
destructor TGLCustomAsmShader.Destroy;
164
begin
165
  DestroyARBPrograms;
166

167
  inherited Destroy;
168
end;
169

170
procedure TGLCustomAsmShader.DestroyARBPrograms;
171
begin
172
  FVPHandle.Free;
173
  FVPHandle := nil;
174
  FFPHandle.Free;
175
  FFPHandle := nil;
176
  FGPHandle.Free;
177
  FGPHandle := nil;
178
end;
179

180
procedure TGLCustomAsmShader.DoApply(var rci: TGLRenderContextInfo; Sender: TObject);
181
begin
182
  ApplyShaderPrograms();
183

184
  if Assigned(FOnApply) then
185
    FOnApply(Self);
186
end;
187

188
procedure TGLCustomAsmShader.DoInitialize(var rci: TGLRenderContextInfo; Sender: TObject);
189
begin
190
  if not ShaderSupported then
191
  begin
192
    Enabled := False;
193
    HandleFailedInitialization;
194
  end
195
  else
196
  begin
197
    if VertexProgram.Enabled then
198
    begin
199
      if not Assigned(FVPHandle) then
200
        FVPHandle := TGLARBVertexProgramHandle.CreateAndAllocate;
201
      FVPHandle.LoadARBProgram(VertexProgram.Code.Text);
202
      VertexProgram.Enabled := FVPHandle.Ready;
203
    end;
204

205
    if FragmentProgram.Enabled then
206
    begin
207
      if not Assigned(FFPHandle) then
208
        FFPHandle := TGLARBFragmentProgramHandle.CreateAndAllocate;
209
      FFPHandle.LoadARBProgram(FragmentProgram.Code.Text);
210
      FragmentProgram.Enabled := FFPHandle.Ready;
211
    end;
212

213
    if GeometryProgram.Enabled then
214
    begin
215
      if not Assigned(FGPHandle) then
216
        FGPHandle := TGLARBGeometryProgramHandle.CreateAndAllocate;
217
      FGPHandle.LoadARBProgram(GeometryProgram.Code.Text);
218
      GeometryProgram.Enabled := FGPHandle.Ready;
219
    end;
220

221
    Enabled := (FragmentProgram.Enabled or VertexProgram.Enabled or GeometryProgram.Enabled);
222

223
    if Enabled then
224
    begin
225
      if Assigned(FOnInitialize) then
226
        FOnInitialize(Self)
227
    end;
228
  end;
229
end;
230

231
function TGLCustomAsmShader.DoUnApply(var rci: TGLRenderContextInfo): Boolean;
232
begin
233
  if Assigned(FOnUnApply) then
234
    FOnUnApply(Self, Result)
235
  else
236
    Result := False;
237

238
  UnApplyShaderPrograms();
239
end;
240

241
function TGLCustomAsmShader.ShaderSupported: Boolean;
242
begin
243
  Result :=
244
    (VertexProgram.Enabled and TGLARBVertexProgramHandle.IsSupported) or
245
    (FragmentProgram.Enabled and TGLARBFragmentProgramHandle.IsSupported) or
246
    (GeometryProgram.Enabled and TGLARBGeometryProgramHandle.IsSupported);
247
end;
248

249
procedure TGLCustomAsmShader.ApplyShaderPrograms;
250
begin
251
  if VertexProgram.Enabled then
252
  begin
253
    FVPHandle.Enable;
254
    FVPHandle.Bind;
255
  end;
256
  if FragmentProgram.Enabled then
257
  begin
258
    FFPHandle.Enable;
259
    FFPHandle.Bind;
260
  end;
261
  if GeometryProgram.Enabled then
262
  begin
263
    FGPHandle.Enable;
264
    FGPHandle.Bind;
265
  end;
266
end;
267

268
procedure TGLCustomAsmShader.UnApplyShaderPrograms;
269
begin
270
  if VertexProgram.Enabled then
271
    FVPHandle.Disable;
272
  if FragmentProgram.Enabled then
273
    FFPHandle.Disable;
274
  if GeometryProgram.Enabled then
275
    FGPHandle.Disable;
276
end;
277

278
initialization
279
  RegisterClasses([TGLCustomAsmShader, TGLAsmShader]);
280

281
end.
282

283