LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   A shader that applies cel shading through a vertex program
6
   and shade definition texture.
7

8
    History :  
9
       23/08/10 - Yar - Upgraded program hadles
10
       22/04/10 - Yar - Fixes after GLState revision
11
       05/03/10 - DanB - More state added to TGLStateCache
12
       22/01/10 - Yar   - Added bmp32.Blank:=false for memory allocation
13
       06/06/07 - DaStr - Added GLColor to uses (BugtrackerID = 1732211)
14
       31/03/07 - DaStr - Added $I GLScene.inc
15
       21/03/07 - DaStr - Added explicit pointer dereferencing
16
                             (thanks Burkhard Carstens) (Bugtracker ID = 1678644)
17
       25/02/07 - DaStr - Moved registration to GLSceneRegister.pas
18
       28/09/04 - SG - Vertex program now uses ARB_position_invariant option.
19
       09/06/04 - SG - Added OutlineColor, vertex programs now use GL state.
20
       28/05/04 - SG - Creation.
21
    
22
}
23
unit GLCelShader;
24

25
interface
26

27
{$I GLScene.inc}
28

29
uses
30
  Classes, SysUtils, GLTexture, GLContext, GLGraphics, GLUtils,
31
  GLVectorGeometry, OpenGLTokens, GLColor, GLRenderContextInfo,
32
  GLMaterial, GLState, GLTextureFormat;
33

34
type
35
  // TGLCelShaderOption
36
  //
37
  { Cel shading options.
38
     csoOutlines: Render a second outline pass.
39
     csoTextured: Allows for a primary texture that the cel shading
40
                  is modulated with and forces the shade definition
41
                  to render as a second texture. }
42
  TGLCelShaderOption = (csoOutlines, csoTextured, csoNoBuildShadeTexture);
43
  TGLCelShaderOptions = set of TGLCelShaderOption;
44

45
  // TGLCelShaderGetIntensity
46
  //
47
  // An event for user defined cel intensity.
48
  TGLCelShaderGetIntensity = procedure(Sender: TObject; var intensity: Byte) of
49
    object;
50

51
  // TGLCelShader
52
  //
53
  { A generic cel shader. }
54
  TGLCelShader = class(TGLShader)
55
  private
56
    FOutlineWidth: Single;
57
    FCelShaderOptions: TGLCelShaderOptions;
58
    FVPHandle: TGLARBVertexProgramHandle;
59
    FShadeTexture: TGLTexture;
60
    FOnGetIntensity: TGLCelShaderGetIntensity;
61
    FOutlinePass,
62
      FUnApplyShadeTexture: Boolean;
63
    FOutlineColor: TGLColor;
64
  protected
65
    procedure SetCelShaderOptions(const val: TGLCelShaderOptions);
66
    procedure SetOutlineWidth(const val: Single);
67
    procedure SetOutlineColor(const val: TGLColor);
68
    procedure BuildShadeTexture;
69
    procedure Loaded; override;
70
    function GenerateVertexProgram: string;
71

72
  public
73
    constructor Create(AOwner: TComponent); override;
74
    destructor Destroy; override;
75

76
    procedure DoApply(var rci: TGLRenderContextInfo; Sender: TObject); override;
77
    function DoUnApply(var rci: TGLRenderContextInfo): Boolean; override;
78

79
    property ShadeTexture: TGLTexture read FShadeTexture;
80

81
  published
82
    property CelShaderOptions: TGLCelShaderOptions read FCelShaderOptions write
83
      SetCelShaderOptions;
84
    property OutlineColor: TGLColor read FOutlineColor write SetOutlineColor;
85
    property OutlineWidth: Single read FOutlineWidth write SetOutlineWidth;
86
    property OnGetIntensity: TGLCelShaderGetIntensity read FOnGetIntensity write
87
      FOnGetIntensity;
88
  end;
89

90
  // ------------------------------------------------------------------
91
  // ------------------------------------------------------------------
92
  // ------------------------------------------------------------------
93
implementation
94
// ------------------------------------------------------------------
95
// ------------------------------------------------------------------
96
// ------------------------------------------------------------------
97

98
// ------------------
99
// ------------------ TGLCelShader ------------------
100
// ------------------
101

102
// Create
103
//
104

105
constructor TGLCelShader.Create(AOwner: TComponent);
106
begin
107
  inherited;
108

109
  FOutlineWidth := 3;
110
  FCelShaderOptions := [csoOutlines];
111
  FShadeTexture := TGLTexture.Create(Self);
112
  with FShadeTexture do
113
  begin
114
    Enabled := True;
115
    MinFilter := miNearest;
116
    MagFilter := maNearest;
117
    TextureWrap := twNone;
118
    TextureMode := tmModulate;
119
  end;
120

121
  FOutlineColor := TGLColor.Create(Self);
122
  FOutlineColor.OnNotifyChange := NotifyChange;
123
  FOutlineColor.Initialize(clrBlack);
124

125
  ShaderStyle := ssLowLevel;
126

127
  FVPHandle := TGLARBVertexProgramHandle.Create;
128
end;
129

130
// Destroy
131
//
132

133
destructor TGLCelShader.Destroy;
134
begin
135
  FVPHandle.Free;
136
  FShadeTexture.Free;
137
  FOutlineColor.Free;
138
  inherited;
139
end;
140

141
// Loaded
142
//
143

144
procedure TGLCelShader.Loaded;
145
begin
146
  inherited;
147
  BuildShadeTexture;
148
end;
149

150
// BuildShadeTexture
151
//
152

153
procedure TGLCelShader.BuildShadeTexture;
154
var
155
  bmp32: TGLBitmap32;
156
  i: Integer;
157
  intensity: Byte;
158
begin
159
  if csoNoBuildShadeTexture in FCelShaderOptions then
160
    exit;
161

162
  with FShadeTexture do
163
  begin
164
    ImageClassName := 'TGLBlankImage';
165
    TGLBlankImage(Image).Width := 128;
166
    TGLBlankImage(Image).Height := 2;
167
  end;
168

169
  bmp32 := FShadeTexture.Image.GetBitmap32;
170
  bmp32.Blank := false;
171
  for i := 0 to bmp32.Width - 1 do
172
  begin
173
    intensity := i * (256 div bmp32.Width);
174

175
    if Assigned(FOnGetIntensity) then
176
      FOnGetIntensity(Self, intensity)
177
    else
178
    begin
179
      if intensity > 230 then
180
        intensity := 255
181
      else if intensity > 150 then
182
        intensity := 230
183
      else if intensity > 100 then
184
        intensity := intensity + 50
185
      else
186
        intensity := 150;
187
    end;
188

189
    bmp32.Data^[i].r := intensity;
190
    bmp32.Data^[i].g := intensity;
191
    bmp32.Data^[i].b := intensity;
192
    bmp32.Data^[i].a := 1;
193
    bmp32.Data^[i + bmp32.Width] := bmp32.Data^[i];
194
  end;
195
end;
196

197
// GenerateVertexProgram
198
//
199

200
function TGLCelShader.GenerateVertexProgram: string;
201
var
202
  VP: TStringList;
203
begin
204
  VP := TStringList.Create;
205

206
  VP.Add('!!ARBvp1.0');
207
  VP.Add('OPTION ARB_position_invariant;');
208

209
  VP.Add('PARAM mvinv[4] = { state.matrix.modelview.inverse };');
210
  VP.Add('PARAM lightPos = program.local[0];');
211
  VP.Add('TEMP temp, light, normal;');
212

213
  VP.Add('   DP4 light.x, mvinv[0], lightPos;');
214
  VP.Add('   DP4 light.y, mvinv[1], lightPos;');
215
  VP.Add('   DP4 light.z, mvinv[2], lightPos;');
216
  VP.Add('   ADD light, light, -vertex.position;');
217
  VP.Add('   DP3 temp.x, light, light;');
218
  VP.Add('   RSQ temp.x, temp.x;');
219
  VP.Add('   MUL light, temp.x, light;');
220

221
  VP.Add('   DP3 temp, vertex.normal, vertex.normal;');
222
  VP.Add('   RSQ temp.x, temp.x;');
223
  VP.Add('   MUL normal, temp.x, vertex.normal;');
224

225
  VP.Add('   MOV result.color, state.material.diffuse;');
226

227
  if csoTextured in FCelShaderOptions then
228
  begin
229
    VP.Add('   MOV result.texcoord[0], vertex.texcoord[0];');
230
    VP.Add('   DP3 result.texcoord[1].x, normal, light;');
231
  end
232
  else
233
  begin
234
    VP.Add('   DP3 result.texcoord[0].x, normal, light;');
235
  end;
236

237
  VP.Add('END');
238

239
  Result := VP.Text;
240
  VP.Free;
241
end;
242

243
// DoApply
244
//
245

246
procedure TGLCelShader.DoApply(var rci: TGLRenderContextInfo; Sender: TObject);
247
var
248
  light: TVector;
249
begin
250
  if (csDesigning in ComponentState) then
251
    exit;
252

253
  FVPHandle.AllocateHandle;
254
  if FVPHandle.IsDataNeedUpdate then
255
  begin
256
    FVPHandle.LoadARBProgram(GenerateVertexProgram);
257
    Enabled := FVPHandle.Ready;
258
    FVPHandle.NotifyDataUpdated;
259
    if not Enabled then
260
      Abort;
261
  end;
262

263
  rci.GLStates.Disable(stLighting);
264
  GL.GetLightfv(GL_LIGHT0, GL_POSITION, @light.V[0]);
265
  FVPHandle.Enable;
266
  FVPHandle.Bind;
267
  GL.ProgramLocalParameter4fv(GL_VERTEX_PROGRAM_ARB, 0, @light.V[0]);
268

269
  if (csoTextured in FCelShaderOptions) then
270
    FShadeTexture.ApplyAsTexture2(rci, nil)
271
  else
272
    FShadeTexture.Apply(rci);
273

274
  FOutlinePass := csoOutlines in FCelShaderOptions;
275
  FUnApplyShadeTexture := True;
276
end;
277

278
// DoUnApply
279
//
280

281
function TGLCelShader.DoUnApply(var rci: TGLRenderContextInfo): Boolean;
282
begin
283
  Result := False;
284
  if (csDesigning in ComponentState) then
285
    exit;
286

287
  FVPHandle.Disable;
288

289
  if FUnApplyShadeTexture then
290
  begin
291
    if (csoTextured in FCelShaderOptions) then
292
      FShadeTexture.UnApplyAsTexture2(rci, false)
293
    else
294
      FShadeTexture.UnApply(rci);
295
    FUnApplyShadeTexture := False;
296
  end;
297

298
  if FOutlinePass then
299
    with rci.GLStates do
300
    begin
301
      ActiveTexture := 0;
302
      ActiveTextureEnabled[ttTexture2D] := False;
303
      Enable(stBlend);
304
      Enable(stLineSmooth);
305
      Disable(stLineStipple);
306
      Enable(stCullFace);
307

308
      PolygonMode := pmLines;
309
      LineWidth := FOutlineWidth;
310
      CullFaceMode := cmFront;
311
      LineSmoothHint := hintNicest;
312
      SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha);
313
      DepthFunc := cfLEqual;
314
      GL.Color4fv(FOutlineColor.AsAddress);
315

316
      Result := True;
317
      FOutlinePass := False;
318
      Exit;
319
    end
320
  else
321
    with rci.GLStates do
322
    begin
323
      rci.GLStates.PolygonMode := pmFill;
324
      rci.GLStates.CullFaceMode := cmBack;
325
      rci.GLStates.DepthFunc := cfLEqual;
326
    end;
327

328
end;
329

330
// SetCelShaderOptions
331
//
332

333
procedure TGLCelShader.SetCelShaderOptions(const val: TGLCelShaderOptions);
334
begin
335
  if val <> FCelShaderOptions then
336
  begin
337
    FCelShaderOptions := val;
338
    BuildShadeTexture;
339
    FVPHandle.NotifyChangesOfData;
340
    NotifyChange(Self);
341
  end;
342
end;
343

344
// SetOutlineWidth
345
//
346

347
procedure TGLCelShader.SetOutlineWidth(const val: Single);
348
begin
349
  if val <> FOutlineWidth then
350
  begin
351
    FOutlineWidth := val;
352
    NotifyChange(Self);
353
  end;
354
end;
355

356
// SetOutlineColor
357
//
358

359
procedure TGLCelShader.SetOutlineColor(const val: TGLColor);
360
begin
361
  if val <> FOutlineColor then
362
  begin
363
    FOutlineColor.Assign(val);
364
    NotifyChange(Self);
365
  end;
366
end;
367

368
end.
369

370