LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   ZBuffer retrieval and computations.
6

7
   See readme.txt in the Demos/SpecialsFX/Shadows directory. 
8
   By René Lindsay.
9

10
  History :  
11
       10/11/12 - PW - Added CPP compatibility: changed vector arrays to records
12
       23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
13
       22/04/10 - Yar - Fixes after GLState revision
14
       05/03/10 - DanB - More state added to TGLStateCache
15
       29/05/08 - DaStr - Removed unused variables in TGLZShadows.CalcShadowTexture()
16
       20/01/08 - DaStr - Bugfixed TGLZShadows.HardSet(Bugtracker ID = 1875708)
17
                             Removed some old commented out code
18
                             Removed TGLZShadows.Trnc() procedure - there is a
19
                              similar procedure in GLVectorGeometry.pas
20
       28/03/07 - DaStr - Renamed parameters in some methods
21
                             (thanks Burkhard Carstens) (Bugtracker ID = 1678658)
22
       24/03/07 - DaStr - Improved Cross-Platform compatibility
23
                             (thanks Burkhard Carstens) (Bugtracker ID = 1684432)
24
       17/03/07 - DaStr - Dropped Kylix support in favor of FPC (BugTracekrID=1681585)
25
       16/03/07 - DaStr - Added explicit pointer dereferencing
26
                             (thanks Burkhard Carstens) (Bugtracker ID = 1678644)
27
       08/02/07 - Lin - LONG overdue bugfix: Now sets GL_BLEND to prevent black screen.(thanks Jurgen Linker)
28
       08/03/06 - ur - Fixed warnigs for Delphi 2006
29
       02/08/04 - LR, YHC - BCB corrections: use record instead array
30
       03/07/04 - LR - Added ifdef for Linux
31
       07/03/02 - Lin - Removed XRes/YRes properties - Shadow-res now always matches viewer-res.
32
       21/02/02 - Lin - Now uses 1 Byte per pixel, instead of 4. Faster, and uses less Video Ram.
33
       14/02/02 - Lin - Bugfix: No longer stalls the Cadencer + small speed improvements
34
       12/02/02 - Lin - Bilinear filtering of soft shadow edges - much better quality
35
       08/02/02 - Lin - Removed the material property (not used)
36
       05/02/02 - Lin - Tolerance scaling - reduces shadow-creeping(far) and self-shadowing(near)
37
       05/02/02 - Lin - A little more speed in 16in1 mode (but 9in1 is still the best quality)
38
       05/02/02 - EG  - Fixed glTex[Sub]Image calls
39
       20/11/01 - EG  - Removed warnings (axed out... hope I didn't broke anything)
40
       17/10/01 - Lin - Added Xres and Yres...makes shadow texture size independent from viewer.
41
                           Calculations now use z-depth in stead of world distance
42
                           - more acurate, and 15% faster.
43
       27/09/01 - Lin - Bypass the GLScene Material.texture.image, and send the shadow
44
                           texture directly to OpenGL. This increased speed by almost 20%
45
       25/09/01 - Lin - Add Optimise property to specify faster rastering methods
46
       07/09/01 - Lin - Restructure zBuffer code, to support the new TGLMemoryViewer
47
       06/09/01 - Lin - Created TGLZShadows object, for casting shadows
48
       30/08/01 - Lin - More speed + bugfixes
49
       24/07/01 - Lin - Greatly improved speed
50
       07/07/01 - Lin - Added PixelToWorld, WorldToPixel, and PixelToDistance
51
       01/07/01 - Lin - Precalculate the corner vectors in GetDepthBuffer,
52
                            to speed up FastVectorToScreen and FastScreenToVector
53
       28/06/01 - Lin - First operational code
54
       26/06/01 - Lin - Creation of zBuffer class
55
  
56
}
57

58
   //--------These formulas are the key to making use of the z-Buffer--------
59
   //
60
   // dst (d): world distance
61
   // dov    : depth of view (distance between Far-plane and Near-plane)
62
   // np     : near plane
63
   // fp     : far plane (dov+np)
64
   //
65
   //------------------------
66
   //dst:=(fp*np)/(fp-z*dov);  //calc from z-buffer value to frustrum depth
67
   //z  :=(1-np/d)/(1-np/fp);  //calc from frustrum depth to z-buffer value
68
   //------------------------  z:=1-(fp/d-1)/(fp/np-1); //old FtoZ
69
   //------------------------------------------------------------------------
70

71
unit GLzBuffer;
72

73
interface
74

75
{$I GLScene.inc}
76

77
uses
78
  Classes, SysUtils,
79
   
80
  GLScene, GLVectorGeometry, GLGraphics, GLObjects, GLContext, GLViewer,
81
  GLColor, GLRenderContextInfo, GLState, GLTextureFormat,
82
  OpenGLTokens, XOpenGL , GLVectorTypes;
83

84

85
type
86
  EZBufferException = class(Exception);
87

88
  TZArray = array[0..MaxInt shr 3] of Single;
89
  PZArray = ^TZArray;
90
  TZArrayIdx = array of PZArray;
91

92
  TAArray = array[0..MaxInt shr 3] of Byte;
93
  PAArray = ^TAArray;
94
  TAArrayIdx = array of PAArray;
95

96
  TOptimise = (opNone, op4in1, op9in1, op16in1);
97

98
  TGLzBuffer = class(TPersistent)
99
  private
100
    FData: PZArray;
101
    FDataIdx, FDataInvIdx: TZArrayIdx;
102
    FWidth, FHeight: Integer;
103
    FDataSize: Integer;
104

105
    ang1, ang2, scal, c1, s1, c2, s2, vw, vh: single; //VectorToScreen variables;
106
    lt, rt, lb, rb: TAffineVector; //ScreenToVector corner vectors;
107
    UpVec, riVec: TAffineVector;
108

109
    ltW, rtW, lbW, rbW: TAffineVector; //ScreenToVector corner vectors;(Warped)
110
    UpVecW, riVecW: TAffineVector;
111
    OrthInvDov, OrthAddX, OrthMulX, OrthAddY, OrthMulY: single;
112

113
    dov, np, fp, NpFp, OneMinNp_Fp, invOneMinNp_Fp: single; //Calc Variables;
114

115
    cam: TGLCamera;
116

117
    procedure DoCalcVectors;
118

119
  protected
120
    procedure PrepareBufferMemory;
121
    procedure SetWidth(val: Integer);
122
    procedure SetHeight(const val: Integer);
123

124
  public
125
    SceneViewer: TGLSceneViewer;
126
    MemoryViewer: TGLMemoryViewer;
127
    Buffer: TGLSceneBuffer;
128

129
    Normal: TAffineVector; //Absolute direction of camera
130

131
    constructor Create;
132
    destructor Destroy; override;
133

134
    procedure LinkToViewer(viewer: TGLSceneViewer); overload;
135
    procedure LinkToViewer(viewer: TGLMemoryViewer); overload;
136
    function GetDepthBuffer(CalcVectors: Boolean; ContextIsActive: boolean):
137
      PZArray;
138

139
    function GetPixelzDepth(x, y: integer): Single;
140
    function PixelToDistance_OLD(x, y: integer): Single;
141
    function PixelToDistance(x, y: integer): Single;
142
    property Width: Integer read FWidth write SetWidth;
143
    property Height: Integer read FHeight write SetHeight;
144
    property DataSize: Integer read FDataSize;
145
    property Data: PZArray read FData;
146
    property DataIdx: TZArrayIdx read FDataIdx;
147
    property DataInvIdx: TZArrayIdx read FDataIdx;
148

149
    procedure Refresh;
150
    function FastScreenToVector(x, y: Integer): TAffineVector;
151
    function FastVectorToScreen(vec: TAffineVector): TAffineVector;
152

153
    function PixelToWorld(const x, y: Integer): TAffineVector;
154
    function WorldToPixel(const aPoint: TAffineVector; out pixX, pixY: integer;
155
      out pixZ: single): boolean;
156
    function WorldToPixelZ(const aPoint: TAffineVector; out pixX, pixY: integer;
157
      out pixZ: single): boolean; overload;
158
    function WorldToPixelZ(const aPoint: TAffineVector; out pixX, pixY: single;
159
      out pixZ: single): boolean; overload;
160
    function OrthWorldToPixelZ(const aPoint: TAffineVector; out pixX, pixY:
161
      single; out pixZ: single): boolean;
162
  end;
163

164
  // TGLZShadows
165
  //
166
  TGLZShadows = class(TGLBaseSceneObject)
167
  private
168
    FViewer: TGLSceneViewer;
169
    FCaster: TGLMemoryViewer;
170
    FDepthFade: Boolean;
171
    FFrustShadow: Boolean;
172
    FSkyShadow: Boolean;
173
    FOptimise: TOptimise;
174

175
    FData: PAArray;
176
    FDataIdx, FDataInvIdx: TAArrayIdx;
177
    FDataSize: Integer;
178

179
    FWidth: integer;
180
    FHeight: integer;
181
    FXRes: integer;
182
    FYRes: integer;
183
    Fsoft: boolean;
184
    FTolerance: single;
185

186
    FColor: TGLColor;
187
    SCol: TGLPixel32;
188

189
    //stepX, stepY :single;
190

191
    FTexturePrepared: Boolean;
192

193
    FTexHandle: TGLTextureHandle;
194

195
  protected
196
    procedure PrepareAlphaMemory;
197

198
    function GetViewer: TGLSceneViewer;
199
    procedure SetViewer(const val: TGLSceneViewer);
200
    function GetCaster: TGLMemoryViewer;
201
    procedure SetCaster(const val: TGLMemoryViewer);
202
    procedure CalcShadowTexture(var rci: TGLRenderContextInfo);
203
    function HardSet(const x, y: integer): Byte;
204

205
    function SoftTest(const x, y: integer): Byte;
206
    procedure SetWidth(const val: integer);
207
    procedure SetHeight(const val: integer);
208
    procedure SetXRes(const val: integer);
209
    procedure SetYRes(const val: integer);
210
    procedure SetSoft(const val: boolean);
211

212
    procedure BindTexture;
213
  public
214
    ViewerZBuf: TGLzBuffer;
215
    CasterZBuf: TGLzBuffer;
216
    constructor Create(AOwner: TComponent); override;
217
    destructor Destroy; override;
218
    procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf,
219
      ARenderChildren: Boolean); override;
220
  published
221
    property Viewer: TGLSceneViewer read GetViewer write SetViewer;
222
    property Caster: TGLMemoryViewer read GetCaster write SetCaster;
223
    property FrustShadow: Boolean read FFrustShadow write FFrustShadow;
224
    property SkyShadow: Boolean read FSkyShadow write FSkyShadow;
225
    property Optimise: TOptimise read FOptimise write FOptimise;
226
    property Width: integer read FWidth write SetWidth;
227
    property Height: integer read FHeight write SetHeight;
228
    property Color: TGLColor read FColor write FColor;
229
    //          property Xres        :integer read FXRes write SetXRes;// default 64;
230
    //          property Yres        :integer read FYRes write SetYRes;// default 64;
231
    property Soft: Boolean read Fsoft write SetSoft;
232
    property Tolerance: single read FTolerance write FTolerance;
233
    //          property Material;
234
    property ObjectsSorting;
235
    property Visible;
236

237
    property DepthFade: Boolean read FDepthFade write FDepthFade;
238
    function CastShadow: boolean;
239
  end;
240

241
implementation
242

243
constructor TGLzBuffer.Create;
244
begin
245
  inherited Create;
246

247
  self.FWidth := 0;
248
  self.FHeight := 0;
249
  self.FDataSize := 0;
250
  self.cam := nil;
251
  self.SceneViewer := nil;
252
  self.MemoryViewer := nil;
253
  self.buffer := nil;
254
  // self.DoCalcVectors;
255
end;
256

257
procedure TGLzBuffer.LinkToViewer(viewer: TGLSceneViewer); // overload;
258
begin
259
  if ((FWidth <> Viewer.width) or (FHeight <> Viewer.height)) then
260
  begin
261
    FWidth := Viewer.width;
262
    FHeight := Viewer.height;
263
    PrepareBufferMemory;
264
  end;
265
  cam := Viewer.camera;
266
  SceneViewer := Viewer;
267
  Buffer := Viewer.Buffer;
268
  self.DoCalcVectors;
269
end;
270

271
procedure TGLzBuffer.LinkToViewer(viewer: TGLMemoryViewer); // overload;
272
begin
273
  if ((FWidth <> Viewer.width) or (FHeight <> Viewer.height)) then
274
  begin
275
    FWidth := Viewer.width;
276
    FHeight := Viewer.height;
277
    PrepareBufferMemory;
278
  end;
279
  cam := Viewer.camera;
280
  MemoryViewer := Viewer;
281
  Buffer := Viewer.Buffer;
282
  self.DoCalcVectors;
283
end;
284

285
//---Destroy---
286

287
destructor TGLzBuffer.Destroy;
288
begin
289
  FreeMem(FData);
290
  inherited Destroy;
291
end;
292

293
procedure TGLzBuffer.PrepareBufferMemory;
294
var
295
  i: Integer;
296
begin
297
  FDataSize := FWidth * FHeight * 4;
298
  ReallocMem(FData, FDataSize);
299
  SetLength(FDataIdx, FHeight + 2);
300
  SetLength(FDataInvIdx, FHeight + 2);
301
  for i := 0 to FHeight - 1 do
302
  begin
303
    FDataIdx[i] := @FData[i * FWidth]; // range: [0..height-1]
304
    FDataInvIdx[i] := @FData[(FHeight - i - 1) * FWidth]; // range: [0..height-1]
305
  end;
306
  FDataIdx[FHeight] := FDataIdx[FHeight - 1];
307
  FDataInvIdx[FHeight] := FDataInvIdx[FHeight - 1];
308
end;
309

310
//---Width---
311

312
procedure TGLzBuffer.SetWidth(val: Integer);
313
begin
314
  if val <> FWidth then
315
  begin
316
    Assert(val >= 0);
317
    FWidth := val;
318
    PrepareBufferMemory;
319
  end;
320
end;
321

322
//---Height---
323

324
procedure TGLzBuffer.SetHeight(const val: Integer);
325
begin
326
  if val <> FHeight then
327
  begin
328
    Assert(val >= 0);
329
    FHeight := val;
330
    PrepareBufferMemory;
331
  end;
332
end;
333

334
function TGLzBuffer.GetDepthBuffer(CalcVectors: Boolean; ContextIsActive:
335
  boolean): PZArray;
336
begin
337
  if ContextIsActive = True then
338
  begin
339
    GL.ReadPixels(0, 0, FWidth, FHeight, GL_DEPTH_COMPONENT, GL_FLOAT, FData);
340
  end
341
  else
342
  begin
343
    Buffer.RenderingContext.Activate;
344
    try
345
      GL.ReadPixels(0, 0, FWidth, FHeight, GL_DEPTH_COMPONENT, GL_FLOAT, FData);
346
    finally
347
      Buffer.RenderingContext.Deactivate;
348
    end;
349
  end;
350

351
  if CalcVectors = True then
352
    DoCalcVectors;
353
  Result := FData;
354
end;
355

356
function TGLzBuffer.GetPixelzDepth(x, y: integer): Single;
357
begin
358
  if (Cardinal(x) < Cardinal(FWidth)) and (Cardinal(y) < Cardinal(FHeight)) then
359
    Result := FDataInvIdx[y]^[x]
360
  else
361
    Result := 0;
362
end;
363

364
function TGLzBuffer.PixelToDistance_OLD(x, y: integer): Single;
365
var
366
  z, dst, camAng, wrpdst: single;
367
  vec: TAffineVector;
368
begin
369
  if ((x < 0) or (x > FWidth) or (y < 0) or (y > FWidth)) then
370
    result := 0
371
  else
372
  begin
373
    z := FData^[x + (FHeight - y) * FWidth]; //fetch pixel z-depth
374
    dst := (NpFp) / (fp - z * dov); //calc from z-buffer value to frustrum depth
375
    vec := FastScreenToVector(x, y);
376
    camAng := VectorAngleCosine(normal, vec);
377
    wrpdst := dst / camAng; //compensate for flat frustrum face
378
    result := wrpdst;
379
  end;
380
end;
381

382
function TGLzBuffer.PixelToDistance(x, y: integer): Single;
383
var
384
  z, dst: single;
385
  xx, yy, zz: single;
386
  fy: integer;
387
begin
388
  if ((x < 0) or (x >= FWidth) or (y < 0) or (y >= FHeight)) then
389
    result := 0
390
  else
391
  begin
392
    fy := FHeight - y;
393
    z := FData^[x + fy * FWidth]; //fetch pixel z-depth
394
    if z < 1 then
395
    begin
396
      dst := (NpFp) / (fp - z * dov);
397
      //calc from z-buffer value to frustrum depth
398
      xx := (lbW.V[0] + riVecW.V[0] * x + UpVecW.V[0] * fy);
399
      yy := (lbW.V[1] + riVecW.V[1] * x + UpVecW.V[1] * fy);
400
      zz := (lbW.V[2] + riVecW.V[2] * x + UpVecW.V[2] * fy);
401
      result := sqrt(xx * xx + yy * yy + zz * zz) * dst;
402
    end
403
    else
404
      result := 0;
405
  end;
406
end;
407

408
procedure TGLzBuffer.Refresh;
409
begin
410
  if assigned(Buffer) then
411
    GetDepthBuffer(True, False);
412
end;
413

414
procedure TGLzBuffer.DoCalcVectors;
415
var
416
  axs: TAffineVector;
417
  Hnorm, hcvec: TVector;
418
  vec: TAffineVector;
419
  w, h: integer;
420
  wrp: single;
421
begin
422
  if not (assigned(Buffer) and Buffer.RCInstantiated) then
423
    exit;
424
  if not assigned(cam) then
425
    raise EZBufferException.Create('No Camera!');
426

427
  //-----------For ScreenToVector-------------
428
  w := FWidth;
429
  h := FHeight;
430
  setVector(vec, 0, 0, 0);
431
  lb := buffer.ScreenToVector(vec); // same as cvec...optimise?
432
  setVector(vec, w, 0, 0);
433
  rb := buffer.ScreenToVector(vec);
434
  setVector(vec, 0, h, 0);
435
  lt := buffer.ScreenToVector(vec);
436
  setVector(vec, w, h, 0);
437
  rt := buffer.ScreenToVector(vec);
438
  //------------Set Camera values-------------
439
  normal := VectorLerp(lb, rt, 0.5);
440
  upVec := VectorSubtract(lt, lb);
441
  riVec := VectorSubtract(rb, lb);
442
  // cam:=viewer.Camera;
443
  dov := Cam.DepthOfView;
444
  np := Cam.NearPlane;
445
  fp := Cam.NearPlane + dov;
446
  NpFp := np * fp;
447
  OneMinNp_Fp := 1 - np / fp;
448
  invOneMinNp_Fp := 1 / OneMinNp_Fp;
449
  //-----------For VectorToScreen-------------
450
  {
451
    cam :=Viewer.Camera.Position.AsAffineVector;
452
    targ:=Viewer.Camera.TargetObject.Position.AsAffineVector;
453
    norm:=VectorSubtract(targ,cam);     //---Camera Normal vector---
454
    MakeVector(hnorm,norm);
455
  }
456
  MakeVector(hnorm, normal);
457

458
  MakeVector(hcVec, lb); //---Corner Vector---
459
  ang1 := ArcTan2(Hnorm.V[0], Hnorm.V[2]);
460
  SetVector(axs, 0, 1, 0);
461
  RotateVector(hnorm, axs, ang1);
462
  RotateVector(hcvec, axs, ang1);
463

464
  ang2 := ArcTan2(Hnorm.V[1], Hnorm.V[2]);
465
  SetVector(axs, 1, 0, 0);
466
  RotateVector(hcvec, axs, -ang2);
467

468
  hcvec.V[0] := hcvec.V[0] / hcvec.V[2];
469
  vw := Fwidth / 2;
470
  vh := Fheight / 2;
471
  scal := vw / hcvec.V[0];
472
  SinCos(-ang1, s1, c1);
473
  SinCos(-ang2, s2, c2);
474
  //------------------------------------------
475
  //--------------------2-----------------
476
  vec := self.FastScreenToVector(0, 1);
477
  wrp := VectorAngleCosine(normal, vec);
478
  ltW := VectorNormalize(lt);
479
  rtW := VectorNormalize(rt);
480
  lbW := VectorNormalize(lb);
481
  rbW := VectorNormalize(rb);
482
  ltW := VectorScale(ltW, 1 / wrp);
483
  rtW := VectorScale(rtW, 1 / wrp);
484
  lbW := VectorScale(lbW, 1 / wrp);
485
  rbW := VectorScale(rbW, 1 / wrp);
486
  upVecW := VectorSubtract(ltW, lbW);
487
  upVecW := VectorScale(upVecW, 1 / Fheight);
488
  riVecW := VectorSubtract(rbW, lbW);
489
  riVecW := VectorScale(riVecW, 1 / Fwidth);
490

491
  // UpVecW[0]:=-UpVecW[0];
492
  // UpVecW[1]:=-UpVecW[1];
493
  // UpVecW[2]:=-UpVecW[2];
494

495
  //--------------------------------------
496
  //-------orth---------
497
  // OrthAdd:=2;
498
  // OrthMul:=64;
499

500
  orthAddX := rt.V[0];
501
  OrthMulX := FWidth / (OrthAddX * 2);
502
  orthAddY := rt.V[2];
503
  OrthMulY := FHeight / (OrthAddY * 2);
504
  OrthInvDov := 1 / dov;
505

506
  //--------------------
507
end;
508

509
function TGLzBuffer.FastScreenToVector(x, y: integer): TAffineVector;
510
var
511
  w, h: integer;
512
  Rlerp, Ulerp: single;
513
begin
514
  w := FWidth;
515
  h := FHeight;
516
  Rlerp := x / w;
517
  Ulerp := (h - y) / h;
518
  result.V[0] := lb.V[0] + riVec.V[0] * Rlerp + UpVec.V[0] * Ulerp;
519
  result.V[1] := lb.V[1] + riVec.V[1] * Rlerp + UpVec.V[1] * Ulerp;
520
  result.V[2] := lb.V[2] + riVec.V[2] * Rlerp + UpVec.V[2] * Ulerp;
521
end;
522

523
function TGLzBuffer.FastVectorToScreen(Vec: TAffineVector): TAffineVector;
524
var
525
  v0, v1, x, y, z: Single;
526
begin
527
  x := vec.V[0];
528
  y := vec.V[1];
529
  z := vec.V[2];
530
  v0 := x;
531
  x := c1 * v0 + s1 * z;
532
  z := c1 * z - s1 * v0; //Rotate around Y-axis
533
  v1 := y;
534
  y := c2 * v1 + s2 * z;
535
  z := c2 * z - s2 * v1; //Rotate around X-axis
536
  Result.V[0] := Round(-x / z * scal + vw);
537
  Result.V[1] := Round(y / z * scal + vh);
538

539
end;
540

541
function TGLzBuffer.PixelToWorld(const x, y: Integer): TAffineVector;
542
var
543
  z, dst: single;
544
  fy: integer;
545
  camvec: TVector;
546
begin
547
  // if (Cardinal(x)<Cardinal(FWidth)) and (Cardinal(y)<Cardinal(FWidth)) then begin       //xres,yres?
548
  if (x < FWidth) and (y < FHeight) then
549
  begin
550
    z := FDataInvIdx[y]^[x];
551
    dst := (NpFp) / (fp - z * dov); //calc from z-buffer value to frustrum depth
552
    camvec := cam.AbsolutePosition;
553
    fy := FHeight - y;
554
    result.V[0] := (lbW.V[0] + riVecW.V[0] * x + UpVecW.V[0] * fy) * dst + camvec.V[0];
555
    result.V[1] := (lbW.V[1] + riVecW.V[1] * x + UpVecW.V[1] * fy) * dst + camvec.V[1];
556
    result.V[2] := (lbW.V[2] + riVecW.V[2] * x + UpVecW.V[2] * fy) * dst + camvec.V[2];
557
  end
558
  else
559
  begin
560
    result.V[0] := 0;
561
    result.V[1] := 0;
562
    result.V[2] := 0;
563
  end;
564
end;
565

566
function TGLzBuffer.WorldToPixel(const aPoint: TAffineVector; out pixX, pixY:
567
  integer; out pixZ: single): boolean;
568
var
569
  camPos: TVector;
570
  x, y, z, v0, v1, zscal: single;
571
begin
572
  //---Takes x,y,z world coordinate.
573
  //---Result is true if pixel lies within view frustrum
574
  //---returns canvas pixel x,y coordinate, and the world distance
575
  result := false;
576
  campos := cam.AbsolutePosition;
577
  x := apoint.V[0] - camPos.V[0];
578
  y := apoint.V[1] - camPos.V[1];
579
  z := apoint.V[2] - camPos.V[2]; //get vector from camera to world point
580
  v0 := x;
581
  x := c1 * v0 + s1 * z;
582
  z := c1 * z - s1 * v0; //Rotate around Y-axis
583
  v1 := y;
584
  y := c2 * v1 + s2 * z;
585
  z := c2 * z - s2 * v1; //Rotate around X-axis
586
  if z > 0 then
587
  begin
588
    zscal := scal / z;
589
    pixX := Round(-x * zscal + vw);
590
    pixY := Round(y * zscal + vh);
591
    pixZ := sqrt(x * x + y * y + z * z);
592
    if (pixX >= 0) and (pixX < FWidth) and (pixY >= 0) and (pixY < FHeight) then
593
      Result := true;
594
  end
595
  else
596
  begin //ignore anything that is behind the camera
597
    pixX := 0;
598
    pixY := 0;
599
    pixZ := 0;
600
  end;
601
end;
602

603
function TGLzBuffer.WorldToPixelZ(const aPoint: TAffineVector; out pixX, pixY:
604
  integer; out pixZ: single): boolean; //OVERLOAD
605
var
606
  camPos: TVector;
607
  x, y, z, v0, v1, zscal: single;
608
begin
609
  //---Takes x,y,z world coordinate.
610
  //---Result is true if pixel lies within view frustrum
611
  //---returns canvas pixel x,y coordinate, and CALCULATES the z-buffer distance
612
  campos := cam.AbsolutePosition;
613
  x := apoint.V[0] - camPos.V[0];
614
  y := apoint.V[1] - camPos.V[1];
615
  z := apoint.V[2] - camPos.V[2]; //get vector from camera to world point
616
  v0 := x;
617
  x := c1 * v0 + s1 * z;
618
  z := c1 * z - s1 * v0; //Rotate around Y-axis
619
  v1 := y;
620
  y := c2 * v1 + s2 * z;
621
  z := c2 * z - s2 * v1; //Rotate around X-axis
622
  if z > 0 then
623
  begin
624
    zscal := scal / z;
625
    pixX := Round(-x * zscal + vw);
626
    pixY := Round(y * zscal + vh);
627
    //------z:=(1-np/z)/(1-np/fp);------
628
    //      pixZ:=(1-np/z)/(1-np/fp);
629
    pixZ := (1 - np / z) * invOneMinNp_Fp;
630
    Result := (Cardinal(pixX) < Cardinal(FWidth)) and (Cardinal(pixY) <
631
      Cardinal(FHeight));
632
  end
633
  else
634
  begin //ignore anything that is behind the camera
635
    Result := false;
636
    pixX := 0;
637
    pixY := 0;
638
    pixZ := 0;
639
  end;
640
end;
641

642
function TGLzBuffer.WorldToPixelZ(const aPoint: TAffineVector; out pixX, pixY:
643
  single; out pixZ: single): boolean; //OVERLOAD
644
var
645
  camPos: TVector;
646
  x, y, z, invZ, v0, v1, zscal: single;
647
begin
648
  //---Takes x,y,z world coordinate. (aPoint)
649
  //---Result is true if pixel lies within view frustrum
650
  //---returns canvas pixel x,y coordinate, and CALCULATES the z-buffer distance
651
  campos := cam.AbsolutePosition;
652
  x := apoint.V[0] - camPos.V[0];
653
  y := apoint.V[1] - camPos.V[1];
654
  z := apoint.V[2] - camPos.V[2]; //get vector from camera to world point
655
  v0 := x;
656
  x := c1 * v0 + s1 * z;
657
  z := c1 * z - s1 * v0; //Rotate around Y-axis
658
  v1 := y;
659
  y := c2 * v1 + s2 * z;
660
  z := c2 * z - s2 * v1; //Rotate around X-axis
661
  if z > 0 then
662
  begin
663
    invZ := 1 / z;
664
    zscal := scal * invZ;
665
    pixX := vw - x * zscal;
666
    pixY := vh + y * zscal;
667
    //------z:=(1-np/z)/(1-np/fp);------
668
    //      pixZ:=(1-np/z)/(1-np/fp);
669
    pixZ := (1 - np * invZ) * invOneMinNp_Fp;
670
    Result := (pixX >= 0) and (pixX < FWidth) and (pixY >= 0) and (pixY <
671
      FHeight);
672
  end
673
  else
674
  begin //ignore anything that is behind the camera
675
    result := false;
676
    pixX := 0;
677
    pixY := 0;
678
    pixZ := 0;
679
  end;
680
end;
681

682
function TGLzBuffer.OrthWorldToPixelZ(const aPoint: TAffineVector; out pixX,
683
  pixY: single; out pixZ: single): boolean;
684
var
685
  camPos: TVector;
686
  x, y, z: single;
687
begin
688
  campos := cam.AbsolutePosition;
689
  x := apoint.V[0] - camPos.V[0];
690
  y := apoint.V[1] - camPos.V[1];
691
  z := apoint.V[2] - camPos.V[2]; //get vector from camera to world point
692

693
  pixX := (x + OrthAddX) * OrthMulX;
694
  pixY := (z + OrthAddY) * OrthMulY;
695
  pixZ := (-y - np) * OrthInvDov; //(-y-np)/dov
696
  Result := (pixX >= 0) and (pixX < FWidth) and (pixY >= 0) and (pixY <
697
    FHeight);
698
end;
699

700
// ------------------
701
// ------------------ TGLZShadows ------------------
702
// ------------------
703

704
// Create
705
//
706

707
constructor TGLZShadows.Create(AOwner: TComponent);
708
begin
709
  inherited;
710
  ObjectStyle := ObjectStyle + [osDirectDraw, osNoVisibilityCulling];
711
  FColor := TGLColor.Create(Self);
712
  self.FDataSize := 0;
713
  self.FXRes := 64;
714
  self.FYRes := 64;
715
  self.Tolerance := 0.015;
716
  FTexHandle := TGLTextureHandle.Create;
717
end;
718

719
//---Destroy---
720

721
destructor TGLZShadows.Destroy;
722
begin
723
  ViewerZBuf.Free;
724
  CasterZBuf.Free;
725
  FColor.Free;
726
  FTexHandle.Free;
727
  FreeMem(FData);
728
  inherited Destroy;
729
end;
730

731
// BindTexture
732
//
733

734
procedure TGLZShadows.BindTexture;
735
begin
736
  if FTexHandle.Handle = 0 then
737
    with FTexHandle do
738
    begin
739
      AllocateHandle;
740
      with RenderingContext.GLStates do
741
      begin
742
        TextureBinding[0, ttTexture2D] := Handle;
743

744
        GL.Hint(GL_PERSPECTIVE_CORRECTION_HINT, GL_Fastest);
745
        UnpackAlignment := 1;
746
        UnpackRowLength := 0;
747
        UnpackSkipRows := 0;
748
        UnpackSkipPixels := 0;
749

750
        GL.TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
751
        GL.TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
752

753
        ActiveTextureEnabled[ttTexture2D] := True;
754
        SetBlendFunc(bfSRCALPHA, bfONEMINUSSRCALPHA);
755
        GL.TexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);
756
        Enable(stBlend);
757

758
        PrepareAlphaMemory;
759
      end;
760
    end
761
  else
762
    with FTexHandle do
763
      RenderingContext.GLStates.TextureBinding[0, ttTexture2D] := Handle;
764
end;
765

766
procedure TGLZShadows.PrepareAlphaMemory;
767
var
768
  i: Integer;
769
begin
770
  //   ShowMessage(IntToStr(FWidth)+'  '+IntToStr(FXRes));
771
  FDataSize := FXRes * FYRes * 1;
772
  ReallocMem(FData, FDataSize);
773
  SetLength(FDataIdx, FYRes);
774
  SetLength(FDataInvIdx, FYRes);
775
  for i := 0 to FYres - 1 do
776
  begin
777
    FDataIdx[i] := @FData[i * FXRes]; // range: [0..height-1]
778
    FDataInvIdx[i] := @FData[(FYRes - i - 1) * FXRes]; // range: [0..height-1]
779
  end;
780
end;
781

782
// DoRender
783
//
784

785
procedure TGLZShadows.DoRender(var ARci: TGLRenderContextInfo;
786
  ARenderSelf, ARenderChildren: Boolean);
787
var
788
  vx, vy, vx1, vy1: Single;
789
  xtex, ytex: single;
790
begin
791
  if not assigned(FViewer) then
792
    exit;
793
  if not assigned(FCaster) then
794
    exit;
795
  if not assigned(CasterZBuf) then
796
    exit; //only render if a shadow has been cast
797
  //only render in view-camera
798
  if TGLSceneBuffer(ARci.buffer).Camera <> FViewer.Camera then
799
    exit;
800
  if not assigned(ViewerZBuf) then
801
  begin //Create viewer zbuffer
802
    ViewerZBuf := TGLZBuffer.Create;
803
    ViewerZBuf.LinkToViewer(FViewer);
804
    Bindtexture;
805
    FTexturePrepared := False;
806
  end;
807
  ViewerZBuf.Refresh;
808

809
  ARci.GLStates.ActiveTextureEnabled[ttTexture2D] := True;
810
  ARci.GLStates.Enable(stBlend);
811
  ARci.GLStates.SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha);
812

813
  if FWidth > ARci.viewPortSize.cx then
814
    Fwidth := ARci.viewPortSize.cx;
815
  if FHeight > ARci.viewPortSize.cy then
816
    FHeight := ARci.viewPortSize.cy;
817

818
  //-----------------------
819
  CalcShadowTexture(ARci);
820
  //-----------------------
821
  ARci.GLStates.TextureBinding[0, ttTexture2D] := FTexHandle.Handle;
822

823
  //>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
824

825
  GL.Color3f(SCol.r, SCol.g, SCol.b);
826

827
  if not FTexturePrepared then
828
  begin
829
    GL.TexImage2D(GL_TEXTURE_2D, 0, GL_ALPHA, FXRes, FYRes, 0, GL_ALPHA,
830
      GL_UNSIGNED_BYTE, @FData[0]);
831
    FTexturePrepared := True;
832
  end
833
  else
834
    GL.TexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, FXRes, FYRes, GL_ALPHA,
835
      GL_UNSIGNED_BYTE, @FData[0]);
836

837
  //   NotifyChange(Self);
838
  //>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
839

840
     // Prepare matrices
841
  GL.MatrixMode(GL_MODELVIEW);
842
  GL.PushMatrix;
843
  GL.LoadMatrixf(@TGLSceneBuffer(ARci.buffer).BaseProjectionMatrix);
844
  GL.Scalef(2 / ARci.viewPortSize.cx, 2 / ARci.viewPortSize.cy, 1);
845
  GL.Translatef(Position.X - ARci.viewPortSize.cx * 0.5,
846
    ARci.viewPortSize.cy * 0.5 - Position.Y, Position.Z);
847

848
  GL.MatrixMode(GL_PROJECTION);
849
  GL.PushMatrix;
850
  GL.LoadIdentity;
851
  ARci.GLStates.Disable(stDepthTest);
852
  ARci.GLStates.Disable(stLighting);
853

854
  vx := 0;
855
  vx1 := vx + FWidth;
856
  vy := 0;
857
  vy1 := vy - FHeight;
858

859
  Xtex := FWidth / FXres; //1
860
  Ytex := 1 - (FHeight / FYres); //0
861

862
  // issue quad
863
  GL.Begin_(GL_QUADS);
864
  GL.Normal3fv(@YVector);
865
  GL.TexCoord2f(0, ytex);
866
  GL.Vertex2f(vx, vy1);
867
  GL.TexCoord2f(xtex, ytex);
868
  GL.Vertex2f(vx1, vy1);
869
  GL.TexCoord2f(xtex, 1);
870
  GL.Vertex2f(vx1, vy);
871
  GL.TexCoord2f(0, 1);
872
  GL.Vertex2f(vx, vy);
873
  GL.End_;
874
  // restore state
875
  GL.PopMatrix;
876
  GL.MatrixMode(GL_MODELVIEW);
877
  GL.PopMatrix;
878

879
  if Count > 0 then
880
    Self.RenderChildren(0, Count - 1, ARci);
881
end;
882

883
procedure TGLZShadows.CalcShadowTexture(var rci: TGLRenderContextInfo);
884
var
885
  pix, p0, p1, p2, p3, p4: Byte;
886
  pM, pL, pT: Byte;
887
  pixa: PAArray;
888
  x, y, w, h: integer;
889
  xy: integer;
890
begin
891
  pixa := FData;
892
  w := fXres;
893
  h := fYres;
894

895
  SCol.r := Round(FColor.Red * 255);
896
  SCol.g := Round(FColor.green * 255);
897
  SCol.b := Round(FColor.Blue * 255);
898
  SCol.a := Round(FColor.Alpha * 255);
899

900
  //-----------No optimising-----------
901
  if FOptimise = opNone then
902
  begin
903

904
    y := 0;
905
    while y < FHeight do
906
    begin
907
      x := 0;
908
      while x < fWidth do
909
      begin
910
        HardSet(x, y);
911
        x := x + 1;
912
      end;
913
      y := y + 1;
914
    end;
915
  end
916
  else
917

918
    if FOptimise = op4in1 then
919
    begin
920
      for x := 0 to fXres - 1 do
921
        HardSet(x, 0);
922
      for x := 0 to fXres - 1 do
923
        HardSet(x, fYres - 1);
924
      for y := 1 to fYres - 1 do
925
        HardSet(0, y);
926
      for y := 1 to fYres - 1 do
927
        HardSet(fXres - 1, y);
928
      y := 2;
929
      while y < fYres do
930
      begin
931
        x := 2;
932
        p1 := HardSet(x - 1, y - 2);
933
        HardSet(x - 1, y - 1);
934
        p0 := HardSet(x - 1, y);
935
        while x < fXres do
936
        begin
937
          pix := HardSet(x, y);
938
          if (pix = p1) and (pix = p0) then
939
          begin
940
            FDataInvIdx[y]^[x - 1] := pix;
941
            FDataInvIdx[y - 1]^[x - 1] := pix;
942
          end
943
          else
944
          begin
945
            HardSet(x - 1, y);
946
            HardSet(x - 1, y - 1);
947
          end;
948
          p2 := SoftTest(x + 1, y - 2);
949

950
          if (pix = p2) then
951
            FDataInvIdx[y - 1]^[x] := pix
952
          else
953
            HardSet(x, y - 1);
954
          p1 := p2;
955
          p0 := pix;
956
          x := x + 2;
957
        end;
958
        y := y + 2;
959
      end;
960

961
    end
962
    else
963
      if FOptimise = op9in1 then
964
      begin
965
        for x := 0 to fXres - 1 do
966
          HardSet(x, 0);
967
        for x := 0 to fXres - 1 do
968
          HardSet(x, fYres - 1);
969
        for y := 0 to fYres - 1 do
970
          HardSet(fXres - 1, y);
971
        //  for y:=1 to fYres-1 do HardSet(fXres-2,y);
972

973
        y := 3;
974
        while y < fYres do
975
        begin
976
          x := 3;
977
          p1 := HardSet(x - 3, y - 3);
978
          //    p2:=HardSet(x  ,y-3);
979
          p3 := HardSet(x - 3, y);
980
          while x < fXres do
981
          begin
982
            p2 := SoftTest(x, y - 3);
983
            p4 := HardSet(x, y);
984
            if ((p1 = p2) and (p3 = p4) and (p2 = p4)) then
985
            begin
986
              xy := x + (fYres - (y - 3) - 1) * fXres;
987
              pixa^[xy - 2] := p4;
988
              pixa^[xy - 1] := p4;
989
              xy := xy - w; //xy:=x+(fYres-(y-2)-1)*fXres;
990
              pixa^[xy - 3] := p4;
991
              pixa^[xy - 2] := p4;
992
              pixa^[xy - 1] := p4;
993
              xy := xy - w; //xy:=x+(fYres-(y-1)-1)*fXres;
994
              pixa^[xy - 3] := p4;
995
              pixa^[xy - 2] := p4;
996
              pixa^[xy - 1] := p4;
997
            end
998
            else
999
            begin
1000
              HardSet(x - 2, y - 3);
1001
              HardSet(x - 1, y - 3);
1002
              HardSet(x - 3, y - 2);
1003
              HardSet(x - 2, y - 2);
1004
              HardSet(x - 1, y - 2);
1005
              HardSet(x - 3, y - 1);
1006
              HardSet(x - 2, y - 1);
1007
              HardSet(x - 1, y - 1);
1008
            end;
1009
            p1 := p2;
1010
            p3 := p4;
1011

1012
            x := x + 3;
1013
          end;
1014
          y := y + 3;
1015
        end;
1016

1017
      end
1018
      else
1019

1020
        if FOptimise = op16in1 then
1021
        begin
1022

1023
          y := 4;
1024
          while (y <> FHeight + 3) do
1025
          begin
1026
            if y >= FHeight then
1027
              y := FHeight - 1;
1028
            repeat
1029
              x := 4;
1030
              p1 := HardSet(x - 4, y - 4);
1031
              //        HardSet(x  ,y-4); //p2
1032
              p3 := HardSet(x - 4, y);
1033
              while (x <> fWidth + 3) do
1034
              begin
1035
                if x >= FWidth then
1036
                  x := FWidth - 1;
1037
                repeat
1038
                  p2 := SoftTest(x, y - 4);
1039
                  p4 := HardSet(x, y);
1040
                  //p4.r:=255;
1041
                  if ((p1 = p2) and (p3 = p4) and (p2 = p4)) then
1042
                  begin
1043
                    xy := x + (h - (y - 4) - 1) * w;
1044
                    pixa^[xy - 3] := p4;
1045
                    pixa^[xy - 2] := p4;
1046
                    pixa^[xy - 1] := p4;
1047
                    xy := xy - w;
1048
                    pixa^[xy - 4] := p4;
1049
                    pixa^[xy - 3] := p4;
1050
                    pixa^[xy - 2] := p4;
1051
                    pixa^[xy - 1] := p4;
1052
                    xy := xy - w;
1053
                    pixa^[xy - 4] := p4;
1054
                    pixa^[xy - 3] := p4;
1055
                    pixa^[xy - 2] := p4;
1056
                    pixa^[xy - 1] := p4;
1057
                    xy := xy - w;
1058
                    pixa^[xy - 4] := p4;
1059
                    pixa^[xy - 3] := p4;
1060
                    pixa^[xy - 2] := p4;
1061
                    pixa^[xy - 1] := p4;
1062
                  end
1063
                  else
1064
                  begin
1065
                    //--------------------------------------------
1066
                    pM := HardSet(x - 2, y - 2);
1067
                    pL := HardSet(x - 4, y - 2);
1068
                    pT := HardSet(x - 2, y - 4);
1069

1070
                    xy := x + (h - (y - 4) - 1) * w;
1071
                    if (p1 = pT) then
1072
                      pixa^[xy - 3] := pT
1073
                    else
1074
                      HardSet(x - 3, y - 4);
1075
                    if (p2 = pT) then
1076
                      pixa^[xy - 1] := pT
1077
                    else
1078
                      HardSet(x - 1, y - 4);
1079
                    xy := xy - w; //down
1080
                    if (pL = p1) then
1081
                      pixa^[xy - 4] := pL
1082
                    else
1083
                      HardSet(x - 4, y - 3);
1084
                    if (p1 = pM) then
1085
                      pixa^[xy - 3] := pM
1086
                    else
1087
                      HardSet(x - 3, y - 3);
1088
                    if (p2 = pM) then
1089
                      pixa^[xy - 1] := pM
1090
                    else
1091
                      HardSet(x - 1, y - 3); //p2m
1092
                    if (pT = pM) then
1093
                      pixa^[xy - 2] := pM
1094
                    else
1095
                      HardSet(x - 2, y - 3);
1096
                    xy := xy - w; //down
1097
                    if (pL = pM) then
1098
                      pixa^[xy - 3] := pM
1099
                    else
1100
                      HardSet(x - 3, y - 2);
1101
                    xy := xy - w; //down
1102
                    if (p3 = pL) then
1103
                      pixa^[xy - 4] := pL
1104
                    else
1105
                      HardSet(x - 4, y - 1);
1106
                    if (p3 = pM) then
1107
                      pixa^[xy - 3] := pM
1108
                    else
1109
                      HardSet(x - 3, y - 1); //p3m
1110
                    if (p4 = pM) then
1111
                    begin
1112
                      pixa^[xy - 1] := pM;
1113
                      if (pM = p2) then
1114
                        pixa^[xy + w - 1] := pM
1115
                      else
1116
                        HardSet(x - 1, y - 2);
1117
                      if (pM = p3) then
1118
                        pixa^[xy - 2] := pM
1119
                      else
1120
                        HardSet(x - 2, y - 1);
1121
                    end
1122
                    else
1123
                    begin
1124
                      HardSet(x - 1, y - 1); //p4m
1125
                      HardSet(x - 1, y - 2);
1126
                      HardSet(x - 2, y - 1);
1127
                    end;
1128
                  end;
1129
                  p1 := p2;
1130
                  p3 := p4;
1131
                  x := x + 4;
1132
                until x >= FWidth;
1133
              end; //while
1134
              y := y + 4;
1135
            until y > (FHeight - 2);
1136
          end; //while
1137
          for x := 0 to FWidth - 1 do
1138
            FDataIdx[0][x] := FDataIdx[1][x];
1139
          for y := 0 to FHeight - 1 do
1140
            FDataIdx[y][FWidth - 1] := FDataIdx[y][FWidth - 2];
1141
        end;
1142
end;
1143

1144
function TGLZShadows.HardSet(const x, y: integer): Byte;
1145

1146
var
1147
  pix: Byte;
1148
  coord: TAffineVector;
1149

1150
  ipixX, ipixY: integer;
1151
  pixX, pixY: single;
1152
  pixZ: single;
1153
  IsInFrust: Boolean;
1154
  ilum: Integer;
1155
  shad: single;
1156
  Tol: Single;
1157

1158
  modx, mody: single;
1159

1160
  d2, d4, d5, d6, d8: single;
1161
  shad2, shad4, shad5, shad6, shad8: single;
1162

1163
  function ComputeIlum: Integer;
1164
  begin
1165
    //---Lighting---
1166
    if FDepthFade = True then
1167
    begin
1168
      Result := Round(SCol.a * (pixZ * 10 - 9));
1169
      if Result < 0 then
1170
        Result := 0;
1171
      //if ilum>255 then ilum:=255;
1172
      if Result > SCol.a then
1173
        Result := SCol.a;
1174
    end
1175
    else
1176
      Result := 0;
1177
  end;
1178

1179
begin
1180
  //---test pixel for shadow---
1181
  if ViewerZBuf.GetPixelzDepth(x, y) < 1 then
1182
  begin
1183
    coord := ViewerZBuf.PixelToWorld(x, y);
1184
    IsInFrust := CasterZBuf.WorldToPixelZ(coord, pixX, pixY, pixZ);
1185
    //if caster.Camera.CameraStyle=csOrthogonal  then IsInFrust:=CasterZBuf.OrthWorldToPixelZ(coord,pixX,pixY,pixZ);
1186
    //--- Tolerance scaling - reduces shadow-creeping at long-range and self-shadowing at short-range ---
1187
    tol := FTolerance * (1.0 - pixZ);
1188
    //---  ilum=light  ------  SCol.a=shade  ------
1189
    if not isInFrust then
1190
    begin
1191
      if FFrustShadow then
1192
        pix := SCol.a //dark  outside frustrum
1193
      else
1194
        pix := ComputeIlum; //light outside frustrum
1195
    end
1196
    else
1197
    begin
1198
      ipixX := Trunc(pixX);
1199
      ipixY := Trunc(pixY);
1200
      if (FSoft = True) and (ipixY > 0) then
1201
      begin //---soft shadows---
1202
        modx := Frac(pixX);
1203
        //extract the fraction part only - used to interpolate soft shadow edges
1204
        mody := Frac(pixY);
1205

1206
        if ipixX > 0 then
1207
          d4 := CasterZBuf.DataIdx[ipixY]^[ipixX - 1]
1208
        else
1209
          d4 := CasterZBuf.DataIdx[ipixY]^[0];
1210

1211
        d5 := CasterZBuf.DataIdx[ipixY]^[ipixX];
1212
        d6 := CasterZBuf.DataIdx[ipixY]^[ipixX + 1];
1213
        d8 := CasterZBuf.DataIdx[ipixY + 1]^[ipixX];
1214
        //             if ipixY<1 then d2:=d5 else
1215
        d2 := CasterZBuf.DataIdx[ipixY - 1]^[ipixX];
1216
        ilum := ComputeIlum;
1217

1218
        if ((pixZ - d2) > Tol) then
1219
          Shad2 := SCol.a
1220
        else
1221
          Shad2 := ilum;
1222
        if ((pixZ - d4) > Tol) then
1223
          Shad4 := SCol.a
1224
        else
1225
          Shad4 := ilum;
1226
        if ((pixZ - d5) > Tol) then
1227
          Shad5 := SCol.a
1228
        else
1229
          Shad5 := ilum;
1230
        if ((pixZ - d6) > Tol) then
1231
          Shad6 := SCol.a
1232
        else
1233
          Shad6 := ilum;
1234
        if ((pixZ - d8) > Tol) then
1235
          Shad8 := SCol.a
1236
        else
1237
          Shad8 := ilum;
1238
        shad := shad2 + (shad8 - shad2) * mody +
1239
          shad4 + (shad6 - shad4) * modx + shad5;
1240
        pix := Round(Shad / 3);
1241

1242
      end
1243
      else
1244
      begin //---hard shadows---
1245
        if pixZ - Tol > CasterZBuf.DataIdx[ipixY]^[ipixX] then
1246
          pix := SCol.a //dark
1247
        else
1248
          pix := ComputeIlum; //light
1249
      end;
1250
    end;
1251
  end
1252
  else
1253
  begin // if z=1 ... i.e. nothing was drawn at this pixel (sky)
1254
    if FSkyShadow then
1255
      pix := SCol.a // dark
1256
    else
1257
      pix := 0; //ComputeIlum;            // light
1258
  end;
1259
  FDataInvIdx[y]^[x] := pix; //Write pixel
1260
  result := pix;
1261
end;
1262

1263
function TGLZShadows.SoftTest(const x, y: integer): Byte;
1264
begin
1265
  result := FDataInvIdx[y]^[x];
1266
end;
1267

1268
function TGLZShadows.GetViewer: TGLSceneViewer;
1269
begin
1270
  result := FViewer;
1271
end;
1272

1273
procedure TGLZShadows.SetViewer(const val: TGLSceneViewer);
1274
begin
1275
  FViewer := Val;
1276
  Width := FViewer.Width;
1277
  Height := FViewer.Height;
1278
end;
1279

1280
function TGLZShadows.GetCaster: TGLMemoryViewer;
1281
begin
1282
  result := FCaster;
1283
end;
1284

1285
procedure TGLZShadows.SetCaster(const val: TGLMemoryViewer);
1286
begin
1287
  FCaster := Val;
1288
end;
1289

1290
function TGLZShadows.CastShadow: Boolean;
1291
begin
1292
  if Caster <> nil then
1293
  begin
1294
    if not assigned(CasterZBuf) then
1295
    begin
1296
      CasterZBuf := TGLZBuffer.Create;
1297
      CasterZBuf.LinkToViewer(FCaster);
1298
    end;
1299

1300
    if FCaster.Camera.CameraStyle = csOrthogonal then
1301
    begin
1302
      if assigned(FCaster.Camera.TargetObject) then
1303
      begin
1304
        FCaster.Camera.Position.x := FCaster.Camera.TargetObject.Position.x;
1305
        FCaster.Camera.Position.z := FCaster.Camera.TargetObject.Position.z;
1306
      end;
1307
      with FCaster.Camera.direction do
1308
      begin
1309
        x := 0;
1310
        y := -1;
1311
        z := 0;
1312
      end;
1313
    end;
1314

1315
    try
1316
      FCaster.Render;
1317
    except
1318
      Caster := nil; // prevents further attempts
1319
      raise;
1320
    end;
1321

1322
    CasterZBuf.Refresh;
1323
    Result := False;
1324
  end
1325
  else
1326
    Result := True;
1327
end;
1328

1329
procedure TGLZShadows.SetWidth(const val: integer);
1330
begin
1331
  FWidth := val;
1332
  SetXRes(val);
1333
end;
1334

1335
procedure TGLZShadows.SetHeight(const val: integer);
1336
begin
1337
  FHeight := val;
1338
  SetYRes(val);
1339
end;
1340

1341
procedure TGLZShadows.SetXRes(const val: integer);
1342
var
1343
  i: integer;
1344
begin
1345
  i := 2;
1346
  while val > i do
1347
    i := i * 2; //
1348
  FXRes := i; //calculate the closest power of 2, smaller than val
1349
  FTexturePrepared := False;
1350
  PrepareAlphaMemory;
1351
end;
1352

1353
procedure TGLZShadows.SetYRes(const val: integer);
1354
var
1355
  i: integer;
1356
begin
1357
  i := 2;
1358
  while val > i do
1359
    i := i * 2; //
1360
  FYRes := i; //calculate the closest power of 2, larger than val
1361
  FTexturePrepared := False;
1362
  PrepareAlphaMemory;
1363
end;
1364

1365
procedure TGLZShadows.SetSoft(const val: boolean);
1366
begin
1367
  FSoft := val;
1368
  NotifyChange(Self);
1369
end;
1370

1371
// ------------------------------------------------------------------
1372
// ------------------------------------------------------------------
1373
// ------------------------------------------------------------------
1374
initialization
1375
  // ------------------------------------------------------------------
1376
  // ------------------------------------------------------------------
1377
  // ------------------------------------------------------------------
1378

1379
     // class registrations
1380
  RegisterClasses([TGLZShadows]);
1381

1382
end.
1383

1384