LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{ 
5
  GLScene's brute-force terrain renderer.
6

7
   History :  
8
   10/01/13 - PW - Added CPP compatibility: considered sensitivity to upper case characters in identifiers
9
   23/08/10 - Yar - Added OpenGLTokens to uses, replaced OpenGL1x functions to OpenGLAdapter
10
   15/08/10 - Yar - Return missing part of code in BuildList
11
   20/05/10 - Yar - Fixes for Linux x64
12
   20/07/07 - LC - Fixed a problem when camera is far away from the terrain bounds.
13
  (Bugtracker ID = 1757733)
14
   30/03/07 - DaStr - Added $I GLScene.inc
15
   28/03/07 - DaStr - Cosmetic fixes for FPC compatibility
16
   27/03/07 - Lin- Added TileManagement flags. - Helps prevent tile cache fushes.
17
   19/03/07 - Lin- Added IgnoredByRenderer flag to TGLHeightData.
18
  Helps manage duplicate tiles, when a dirty tile is being replaced.
19
   16/03/07 - DaStr - Added explicit pointer dereferencing
20
  (thanks Burkhard Carstens) (Bugtracker ID = 1678644)
21
   08/02/07 - Lin- Ignore tiles that are not hdsReady (Prevents crashes when threading)
22
   30/01/07 - Lin- Added HashedTileCount - Counts the tiles in the buffer
23
   19/10/06 - LC - Changed the behaviour of OnMaxCLODTrianglesReached
24
   09/10/06 - Lin- Added OnMaxCLODTrianglesReached event.(Rene Lindsay)
25
   01/09/04 - SG - Fix for RayCastIntersect (Alan Rose)
26
   02/08/04 - LR, YHC - BCB corrections: use record instead array
27
   25/04/04 - EG - Occlusion testing support
28
   13/01/04 - EG - Leak fix (Phil Scadden)
29
   05/11/03 - SG - Fixed minuscule bug in RayCastIntersect (thanks Michael)
30
   06/02/03 - EG - Fixed speculative range computation, better hashkey
31
   14/01/03 - EG - RayCastIntersect normals fix (Stuart Gooding)
32
   24/09/02 - EG - Added RayCastIntersect (Stuart Gooding)
33
   28/08/02 - EG - Now longer wrongly requests hdtByte (Phil Scadden),
34
  Terrain bounds limiting event (Erazem Polutnik)
35
   10/07/02 - EG - Added support for "holes" in the elevation data
36
   16/06/02 - EG - Added support for multi-material terrains
37
   24/02/02 - EG - Hybrid ROAM-stripifier engine
38
   18/12/01 - EG - Vertex-cache aware stripifier (+10% on GeForce)
39
   12/08/01 - EG - Completely rewritten handles management
40
   21/07/01 - EG - Added Notication registration in SeTGLHeightDataSource
41
   04/03/01 - EG - Completed for first release
42
   12/02/01 - EG - Creation
43
   
44

45
  NOTA : multi-materials terrain support is not yet optimized to minimize
46
  texture switches (in case of resued tile textures).
47
}
48
unit GLTerrainRenderer;
49

50
interface
51

52
{$I GLScene.inc}
53

54
uses
55
  Classes, SysUtils,
56
   
57
  GLScene, GLHeightData, GLMaterial, GLVectorGeometry, GLContext, GLROAMPatch,
58
  GLVectorLists, GLRenderContextInfo, OpenGLTokens, XOpenGL, GLUtils
59
, GLVectorTypes;
60

61
const
62
  cTilesHashSize = 255;
63

64
type
65

66
  TGetTerrainBoundsEvent = procedure(var l, t, r, b: single) of object;
67
  TPatchPostRenderEvent = procedure(var rci: TGLRenderContextInfo;
68
    const patches: TList) of object;
69
  TGLHeightDataPostRenderEvent = procedure(var rci: TGLRenderContextInfo;
70
    var HeightDatas: TList) of object;
71
  TMaxCLODTrianglesReachedEvent = procedure(var rci: TGLRenderContextInfo)
72
    of object;
73

74
  TTerrainHighResStyle = (hrsFullGeometry, hrsTesselated);
75
  TTerrainOcclusionTesselate = (totTesselateAlways, totTesselateIfVisible);
76

77
  TTileManagementFlag = (tmClearUsedFlags, tmMarkUsedTiles,
78
    tmReleaseUnusedTiles, tmAllocateNewTiles, tmWaitForPreparing);
79
  TTileManagementFlags = set of TTileManagementFlag;
80

81
  // TGLTerrainRenderer
82

83
  { : Basic terrain renderer.
84
    This renderer uses no sophisticated meshing, it just builds and maintains
85
    a set of terrain tiles, performs basic visibility culling and renders its
86
    stuff. You can use it has a base class/sample for more specialized
87
    terrain renderers.
88
    The Terrain heightdata is retrieved directly from a TGLHeightDataSource, and
89
    expressed as z=f(x, y) data. }
90
  // TGLTerrainRenderer = class (TGLSceneObject)
91
  TGLTerrainRenderer = class(TGLSceneObject)
92
  private
93
     
94
    FHeightDataSource: TGLHeightDataSource;
95
    FTileSize: Integer;
96
    FQualityDistance, FinvTileSize: single;
97
    FLastTriangleCount: Integer;
98
    FTilesPerTexture: single;
99
    FMaxCLODTriangles, FCLODPrecision: Integer;
100
    FBufferVertices: TAffineVectorList;
101
    FBufferTexPoints: TTexPointList;
102
    FBufferVertexIndices: TIntegerList;
103
    FMaterialLibrary: TGLMaterialLibrary;
104
    FOnGetTerrainBounds: TGetTerrainBoundsEvent;
105
    FOnPatchPostRender: TPatchPostRenderEvent;
106
    FOnHeightDataPostRender: TGLHeightDataPostRenderEvent;
107
    FOnMaxCLODTrianglesReached: TMaxCLODTrianglesReachedEvent;
108

109
    FQualityStyle: TTerrainHighResStyle;
110
    FOcclusionFrameSkip: Integer;
111
    FOcclusionTesselate: TTerrainOcclusionTesselate;
112

113
  protected
114
     
115
    FTilesHash: packed array [0 .. cTilesHashSize] of TList;
116

117
    procedure MarkAllTilesAsUnused;
118
    procedure ReleaseAllUnusedTiles;
119
    procedure MarkHashedTileAsUsed(const tilePos: TAffineVector);
120
    function HashedTile(const tilePos: TAffineVector;
121
      canAllocate: boolean = True): TGLHeightData; overload;
122
    function HashedTile(const xLeft, yTop: Integer; canAllocate: boolean = True)
123
      : TGLHeightData; overload;
124

125
    procedure SeTGLHeightDataSource(const val: TGLHeightDataSource);
126
    procedure SetTileSize(const val: Integer);
127
    procedure SetTilesPerTexture(const val: single);
128
    procedure SetCLODPrecision(const val: Integer);
129
    procedure SetMaterialLibrary(const val: TGLMaterialLibrary);
130
    procedure SetQualityStyle(const val: TTerrainHighResStyle);
131
    procedure SetOcclusionFrameSkip(val: Integer);
132

133
    procedure Notification(AComponent: TComponent;
134
      Operation: TOperation); override;
135
    procedure DestroyHandle; override;
136

137
    procedure ReleaseAllTiles; dynamic;
138
    procedure OnTileDestroyed(Sender: TObject); virtual;
139
    function GetPreparedPatch(const tilePos, eyePos: TAffineVector;
140
      texFactor: single; hdList: TList): TGLROAMPatch;
141

142
  public
143
     
144

145
    { :TileManagement flags can be used to turn off various Tile cache management features.
146
      This helps to prevent unnecessary tile cache flushes, when rendering from multiple cameras. }
147
    TileManagement: TTileManagementFlags;
148

149
    constructor Create(AOwner: TComponent); override;
150
    destructor Destroy; override;
151

152
    procedure BuildList(var rci: TGLRenderContextInfo); override;
153
    function RayCastIntersect(const rayStart, rayVector: TVector;
154
      intersectPoint: PVector = nil; intersectNormal: PVector = nil)
155
      : boolean; override;
156

157
    { : Interpolates height for the given point.
158
      Expects a point expressed in absolute coordinates. }
159
    function InterpolatedHeight(const p: TVector): single; overload; virtual;
160
    function InterpolatedHeight(const p: TAffineVector): single; overload;
161
    { : Triangle count for the last render. }
162
    property LastTriangleCount: Integer read FLastTriangleCount;
163
    function HashedTileCount: Integer;
164

165
  published
166
     
167
    { : Specifies the HeightData provider component. }
168
    property HeightDataSource: TGLHeightDataSource read FHeightDataSource
169
      write SeTGLHeightDataSource;
170
    { : Size of the terrain tiles.
171
      Must be a power of two. }
172
    property TileSize: Integer read FTileSize write SetTileSize default 16;
173
    { : Number of tiles required for a full texture map. }
174
    property TilesPerTexture: single read FTilesPerTexture
175
      write SetTilesPerTexture;
176
    { : Link to the material library holding terrain materials.
177
      If unspecified, and for all terrain tiles with unspecified material,
178
      the terrain renderer's material is used. }
179
    property MaterialLibrary: TGLMaterialLibrary read FMaterialLibrary
180
      write SetMaterialLibrary;
181

182
    { : Quality distance hint.
183
      This parameter gives an hint to the terrain renderer at which distance
184
      the terrain quality can be degraded to favor speed. The distance is
185
      expressed in absolute coordinates units.
186
      All tiles closer than this distance are rendered according to
187
      QualityStyle and with a static resolution. }
188
    property QualityDistance: single read FQualityDistance
189
      write FQualityDistance;
190
    { : Determines how high-res tiles (closer than QualityDistance) are rendered.
191
      hrsFullGeometry (default value) means that the high-res tiles are rendered
192
      with full-geometry, and no LOD of any kind, while hrsTesselated means
193
      the tiles will be tesselated once, with the best output for the
194
      CLODPrecision, and the result of that tesselation will be reused
195
      in further frames without any adpative tesselation. }
196
    property QualityStyle: TTerrainHighResStyle read FQualityStyle
197
      write SetQualityStyle default hrsFullGeometry;
198
    { : Maximum number of CLOD triangles per scene.
199
      Triangles in high-resolution tiles (closer than QualityDistance) do
200
      not count toward this limit. }
201
    property MaxCLODTriangles: Integer read FMaxCLODTriangles
202
      write FMaxCLODTriangles default 65536;
203
    { : Precision of CLOD tiles.
204
      The lower the value, the higher the precision and triangle count.
205
      Large values will result in coarse terrain. 
206
      high-resolution tiles (closer than QualityDistance) ignore this setting. }
207
    property CLODPrecision: Integer read FCLODPrecision write SetCLODPrecision
208
      default 100;
209
    { : Numbers of frames to skip for a tile when occlusion testing found it invisible.
210
      Occlusion testing can help reduce CPU, T&L and fillrate requirements
211
      when tiles are occluded, either by the terrain itself (tiles behind
212
      a mountain or a cliff) or by geometry that was rendered before the
213
      terrain (large buildings). If there is little occlusion in your scene
214
      (such as in top down or high-altitude view), turning occlusion on
215
      may have a slightly negative effect on framerate. 
216
      It works by turning off rendering of tiles for the specified number
217
      of frames if it has been found invisible, after FrameSkip number
218
      of frames have been skipped, it will be rendered again, and a new
219
      occlusion testing made. This makes occlusion-testing a frame-to-frame
220
      coherency optimization, and as such, shouldn't be used for static
221
      rendering (ie. leave value to its default of zero). 
222
      This optimization requires the hardware to support GL_NV_occlusion_query. }
223
    property OcclusionFrameSkip: Integer read FOcclusionFrameSkip
224
      write SetOcclusionFrameSkip default 0;
225
    { : Determines if and how occlusion testing affects tesselation.
226
      Turning off tesselation of tiles determined invisible can improve
227
      performance, however, it may result in glitches since the tesselation
228
      of an ivisible tile can have a slight effect on the tesselation
229
      of its adjacent tiles (by forcing higher resolution at the border
230
      for instance). This negative effect can be lessened by increasing
231
      the QualityDistance, so that glitches will apear farther away
232
      (this will mean increasing your triangle count though, so you'll
233
      trade CPU power against T&L power). }
234
    property OcclusionTesselate: TTerrainOcclusionTesselate
235
      read FOcclusionTesselate write FOcclusionTesselate
236
      default totTesselateIfVisible;
237

238
    { : Allows to specify terrain bounds.
239
      Default rendering bounds will reach depth of view in all direction,
240
      with this event you can chose to specify a smaller rendered
241
      terrain area. }
242
    property OnGetTerrainBounds: TGetTerrainBoundsEvent read FOnGetTerrainBounds
243
      write FOnGetTerrainBounds;
244
    { : Invoked for each rendered patch after terrain render has completed.
245
      The list holds TGLROAMPatch objects and allows per-patch
246
      post-processings, like waters, trees... It is invoked *before*
247
      OnHeightDataPostRender. }
248
    property OnPatchPostRender: TPatchPostRenderEvent read FOnPatchPostRender
249
      write FOnPatchPostRender;
250
    { : Invoked for each heightData not culled out by the terrain renderer.
251
      The list holds TGLHeightData objects and allows per-patch
252
      post-processings, like waters, trees... It is invoked *after*
253
      OnPatchPostRender. }
254
    property OnHeightDataPostRender: TGLHeightDataPostRenderEvent
255
      read FOnHeightDataPostRender write FOnHeightDataPostRender;
256
    { : Invoked whenever the MaxCLODTriangles limit was reached during last rendering.
257
      This forced the terrain renderer to resize the buffer, which affects performance.
258
      If this event is fired frequently, one should increase MaxCLODTriangles.
259
    }
260
    property OnMaxCLODTrianglesReached: TMaxCLODTrianglesReachedEvent
261
      read FOnMaxCLODTrianglesReached write FOnMaxCLODTrianglesReached;
262
  end;
263

264
  // ------------------------------------------------------------------
265
  // ------------------------------------------------------------------
266
  // ------------------------------------------------------------------
267
implementation
268

269
// ------------------------------------------------------------------
270
// ------------------------------------------------------------------
271
// ------------------------------------------------------------------
272

273
// HashKey
274

275
function HashKey(const xLeft, yTop: Integer): Integer;
276
begin
277
  Result := (xLeft + (xLeft shr 8) + (xLeft shr 16) + (yTop shl 1) +
278
    (yTop shr 9) + (yTop shr 17)) and cTilesHashSize;
279
end;
280

281

282
// ------------------
283
// ------------------ TGLTerrainRenderer ------------------
284
// ------------------
285

286
// Create
287

288
constructor TGLTerrainRenderer.Create(AOwner: TComponent);
289
var
290
  i: Integer;
291
begin
292
  inherited Create(AOwner);
293
  for i := 0 to cTilesHashSize do
294
    FTilesHash[i] := TList.Create;
295
  ObjectStyle := ObjectStyle + [osDirectDraw];
296
  FTileSize := 16;
297
  FinvTileSize := 1 / 16;
298
  FTilesPerTexture := 1;
299
  FMaxCLODTriangles := 65536;
300
  FCLODPrecision := 100;
301
  FOcclusionTesselate := totTesselateIfVisible;
302
  FBufferVertices := TAffineVectorList.Create;
303
  FBufferTexPoints := TTexPointList.Create;
304
  FBufferVertexIndices := TIntegerList.Create;
305
  TileManagement := [tmClearUsedFlags, tmMarkUsedTiles, tmReleaseUnusedTiles,
306
    tmAllocateNewTiles];
307
end;
308

309
// Destroy
310

311
destructor TGLTerrainRenderer.Destroy;
312
var
313
  i: Integer;
314
begin
315
  FBufferVertices.Free;
316
  FBufferTexPoints.Free;
317
  FBufferVertexIndices.Free;
318
  ReleaseAllTiles;
319
  for i := 0 to cTilesHashSize do
320
  begin
321
    FTilesHash[i].Free;
322
    FTilesHash[i] := nil;
323
  end;
324
  inherited Destroy;
325
end;
326

327
// Notification
328

329
procedure TGLTerrainRenderer.Notification(AComponent: TComponent;
330
  Operation: TOperation);
331
begin
332
  if Operation = opRemove then
333
  begin
334
    if AComponent = FHeightDataSource then
335
      HeightDataSource := nil
336
    else if AComponent = FMaterialLibrary then
337
      MaterialLibrary := nil;
338
  end;
339
  inherited;
340
end;
341

342
// DestroyHandle
343

344
procedure TGLTerrainRenderer.DestroyHandle;
345
begin
346
  inherited;
347
  ReleaseAllTiles;
348
  if Assigned(HeightDataSource) then
349
    HeightDataSource.Clear;
350
end;
351

352
// RayCastIntersect
353

354
function TGLTerrainRenderer.RayCastIntersect(const rayStart, rayVector: TVector;
355
  intersectPoint: PVector = nil; intersectNormal: PVector = nil): boolean;
356
var
357
  p1, d, p2, p3: TVector;
358
  step, i, h, minH, maxH, p1height: single;
359
  startedAbove: boolean;
360
  failSafe: Integer;
361
  AbsX, AbsY, AbsZ: TVector;
362
begin
363
  Result := False;
364
  if Assigned(HeightDataSource) then
365
  begin
366
    step := (Scale.X + Scale.Y); // Initial step size guess
367
    i := step;
368
    d := VectorNormalize(rayVector);
369
    AbsZ := VectorNormalize(LocalToAbsolute(ZHMGVector));
370
    startedAbove := ((InterpolatedHeight(rayStart) - VectorDotProduct(rayStart,
371
      AbsZ)) < 0);
372
    maxH := Scale.Z * 256;
373
    minH := -Scale.Z * 256;
374
    failSafe := 0;
375
    while True do
376
    begin
377
      p1 := VectorCombine(rayStart, d, 1, i);
378
      h := InterpolatedHeight(p1);
379
      p1height := VectorDotProduct(AbsZ, p1);
380
      if Abs(h - p1height) < 0.1 then
381
      begin // Need a tolerance variable here (how close is good enough?)
382
        Result := True;
383
        Break;
384
      end
385
      else
386
      begin
387
        if startedAbove then
388
        begin
389
          if h < p1height then
390
            i := i + step;
391
          if (h - p1height) > 0 then
392
          begin
393
            step := step * 0.5;
394
            i := i - step;
395
          end;
396
        end
397
        else
398
        begin
399
          if h > p1height then
400
            i := i + step;
401
        end;
402
      end;
403
      Inc(failSafe);
404
      if failSafe > 1024 then
405
        Break;
406
      if VectorDotProduct(AbsZ, d) < 0 then
407
      begin
408
        if h < minH then
409
          Exit;
410
      end
411
      else if h > maxH then
412
        Exit;
413
    end;
414

415
    if Result then
416
    begin
417
      p1 := VectorAdd(p1, VectorScale(AbsZ, InterpolatedHeight(p1) -
418
        VectorDotProduct(p1, AbsZ)));
419
      if Assigned(intersectPoint) then
420
        intersectPoint^ := p1;
421

422
      // Calc Normal
423
      if Assigned(intersectNormal) then
424
      begin
425
        // Get 2 nearby points for cross-product
426
        AbsX := VectorNormalize(LocalToAbsolute(XHMGVector));
427
        AbsY := VectorNormalize(LocalToAbsolute(YHMGVector));
428
        p2 := VectorAdd(p1, VectorScale(AbsX, 0.1));
429
        p2 := VectorAdd(p2, VectorScale(AbsZ, InterpolatedHeight(p2) -
430
          VectorDotProduct(p2, AbsZ)));
431
        p3 := VectorAdd(p1, VectorScale(AbsY, 0.1));
432
        p3 := VectorAdd(p3, VectorScale(AbsZ, InterpolatedHeight(p3) -
433
          VectorDotProduct(p3, AbsZ)));
434

435
        intersectNormal^ :=
436
          VectorNormalize(VectorCrossProduct(VectorSubtract(p1, p2),
437
          VectorSubtract(p3, p1)));
438
      end;
439
    end;
440
  end;
441
end;
442

443
// ReleaseAllTiles
444

445
procedure TGLTerrainRenderer.ReleaseAllTiles;
446
var
447
  i, k: Integer;
448
  hd: TGLHeightData;
449
begin
450
  for i := 0 to cTilesHashSize do
451
    with FTilesHash[i] do
452
    begin
453
      for k := Count - 1 downto 0 do
454
      begin
455
        hd := TGLHeightData(Items[k]);
456
        OnTileDestroyed(hd);
457
        hd.OnDestroy := nil;
458
        hd.Release;
459
      end;
460
      Clear;
461
    end;
462
end;
463

464
// OnTileDestroyed
465

466
procedure TGLTerrainRenderer.OnTileDestroyed(Sender: TObject);
467
var
468
  list: TList;
469
begin
470
  with Sender as TGLHeightData do
471
  begin
472
    if ObjectTag <> nil then
473
    begin
474
      ObjectTag.Free;
475
      ObjectTag := nil;
476
    end;
477
    list := FTilesHash[HashKey(xLeft, yTop)];
478
    Assert(Assigned(list));
479
    list.Remove(Sender);
480
  end;
481
end;
482

483
// InterpolatedHeight (hmg)
484

485
function TGLTerrainRenderer.InterpolatedHeight(const p: TVector): single;
486
var
487
  pLocal: TVector;
488
begin
489
  if Assigned(HeightDataSource) then
490
  begin
491
    pLocal := AbsoluteToLocal(p);
492
    Result := HeightDataSource.InterpolatedHeight(pLocal.V[0], pLocal.V[1],
493
      TileSize + 1) * Scale.Z * (1 / 128);
494
  end
495
  else
496
    Result := 0;
497
end;
498

499
// InterpolatedHeight (affine)
500

501
function TGLTerrainRenderer.InterpolatedHeight(const p: TAffineVector): single;
502
begin
503
  Result := InterpolatedHeight(PointMake(p));
504
end;
505

506
// BuildList
507

508
procedure TGLTerrainRenderer.BuildList(var rci: TGLRenderContextInfo);
509
var
510
  vEye, vEyeDirection: TVector;
511
  tilePos, absTilePos, observer: TAffineVector;
512
  deltaX, nbX, iX: Integer;
513
  deltaY, nbY, iY: Integer;
514
  n, rpIdxDelta, accumCount: Integer;
515
  f, tileRadius, tileGroundRadius, texFactor, tileDist, qDist: single;
516
  patch, prevPatch: TGLROAMPatch;
517
  patchList, rowList, prevRow, buf: TList;
518
  postRenderPatchList, postRenderHeightDataList: TList;
519
  rcci: TRenderContextClippingInfo;
520
  currentMaterialName: string;
521
  maxTilePosX, maxTilePosY, minTilePosX, minTilePosY: single;
522
  t_l, t_t, t_r, t_b: single;
523

524
  procedure ApplyMaterial(const materialName: string);
525
  begin
526
    if (MaterialLibrary = nil) or (currentMaterialName = materialName) then
527
      Exit;
528
    // flush whatever is in progress
529
    TGLROAMPatch.FlushAccum(FBufferVertices, FBufferVertexIndices,
530
      FBufferTexPoints);
531
    // unapply current
532
    if currentMaterialName = '' then
533
    begin
534
      repeat
535
        // ... proper multipass support will be implemented later
536
      until not Material.UnApply(rci);
537
    end
538
    else
539
    begin
540
      repeat
541
        // ... proper multipass support will be implemented later
542
      until not MaterialLibrary.UnApplyMaterial(rci);
543
    end;
544
    // apply new
545
    if materialName = '' then
546
      Material.Apply(rci)
547
    else
548
      MaterialLibrary.ApplyMaterial(materialName, rci);
549
    currentMaterialName := materialName;
550
  end;
551

552
begin
553
  if csDesigning in ComponentState then
554
    Exit;
555
  if HeightDataSource = nil then
556
    Exit;
557

558
  currentMaterialName := '';
559
  // first project eye position into heightdata coordinates
560
  vEye := VectorTransform(rci.cameraPosition, InvAbsoluteMatrix);
561
  vEyeDirection := VectorTransform(rci.cameraDirection, InvAbsoluteMatrix);
562
  SetVector(observer, vEye);
563
  vEye.V[0] := Round(vEye.V[0] * FinvTileSize - 0.5) * TileSize +
564
    TileSize * 0.5;
565
  vEye.V[1] := Round(vEye.V[1] * FinvTileSize - 0.5) * TileSize +
566
    TileSize * 0.5;
567
  tileGroundRadius := Sqr(TileSize * 0.5 * Scale.X) +
568
    Sqr(TileSize * 0.5 * Scale.Y);
569
  tileRadius := Sqrt(tileGroundRadius + Sqr(256 * Scale.Z));
570
  tileGroundRadius := Sqrt(tileGroundRadius);
571
  // now, we render a quad grid centered on eye position
572
  SetVector(tilePos, vEye);
573
  tilePos.V[2] := 0;
574
  f := (rci.rcci.farClippingDistance + tileGroundRadius) / Scale.X;
575
  f := Round(f * FinvTileSize + 1.0) * TileSize;
576
  maxTilePosX := vEye.V[0] + f;
577
  maxTilePosY := vEye.V[1] + f;
578
  minTilePosX := vEye.V[0] - f;
579
  minTilePosY := vEye.V[1] - f;
580

581
  if Assigned(FOnGetTerrainBounds) then
582
  begin
583
    // User-specified terrain bounds, may override ours
584
    t_l := minTilePosX;
585
    t_t := maxTilePosY;
586
    t_r := maxTilePosX;
587
    t_b := minTilePosY;
588

589
    FOnGetTerrainBounds(t_l, t_t, t_r, t_b);
590

591
    t_l := Round(t_l / TileSize - 0.5) * TileSize + TileSize * 0.5;
592
    t_t := Round(t_t / TileSize - 0.5) * TileSize - TileSize * 0.5;
593
    t_r := Round(t_r / TileSize - 0.5) * TileSize - TileSize * 0.5;
594
    t_b := Round(t_b / TileSize - 0.5) * TileSize + TileSize * 0.5;
595

596
    if maxTilePosX > t_r then
597
      maxTilePosX := t_r;
598
    if maxTilePosY > t_t then
599
      maxTilePosY := t_t;
600
    if minTilePosX < t_l then
601
      minTilePosX := t_l;
602
    if minTilePosY < t_b then
603
      minTilePosY := t_b;
604
  end;
605
  // if max is less than min, we have nothing to render
606
  if (maxTilePosX < minTilePosX) or (maxTilePosY < minTilePosY) then
607
    Exit;
608

609
  nbX := Round((maxTilePosX - minTilePosX) / TileSize);
610
  nbY := Round((maxTilePosY - minTilePosY) / TileSize);
611

612
  texFactor := 1 / (TilesPerTexture * TileSize);
613
  rcci := rci.rcci;
614
  if QualityDistance > 0 then
615
    qDist := QualityDistance + tileRadius * 0.5
616
  else
617
    qDist := -1;
618

619
  SetROAMTrianglesCapacity(MaxCLODTriangles);
620
  n := MaxInteger(MaxCLODTriangles * 2, Integer(Sqr(TileSize + 1) * 2));
621
  FBufferVertices.Capacity := n;
622
  FBufferTexPoints.Capacity := n;
623

624
  xgl.PushState;
625
  try
626
    if GL.ARB_multitexture then
627
      xgl.MapTexCoordToDual
628
    else
629
      xgl.MapTexCoordToMain;
630

631
    GL.PushMatrix;
632
    GL.Scalef(1, 1, 1 / 128);
633
    GL.Translatef(-0.5 * TileSize, -0.5 * TileSize, 0);
634
    GL.EnableClientState(GL_VERTEX_ARRAY);
635
    xgl.EnableClientState(GL_TEXTURE_COORD_ARRAY);
636
    GL.DisableClientState(GL_COLOR_ARRAY);
637
    GL.DisableClientState(GL_NORMAL_ARRAY);
638

639
    GL.VertexPointer(3, GL_FLOAT, 0, FBufferVertices.list);
640
    xgl.TexCoordPointer(2, GL_FLOAT, 0, FBufferTexPoints.list);
641
  finally
642
    xgl.PopState;
643
  end;
644

645
  HeightDataSource.Data.LockList; // Lock out the HDS thread while rendering
646

647
  FLastTriangleCount := 0;
648
  patchList := TList.Create;
649
  patchList.Capacity := (nbX + 1) * (nbY + 1);
650
  rowList := TList.Create;
651
  prevRow := TList.Create;
652
  if Assigned(FOnPatchPostRender) then
653
    postRenderPatchList := TList.Create
654
  else
655
    postRenderPatchList := nil;
656
  if Assigned(FOnHeightDataPostRender) then
657
    postRenderHeightDataList := TList.Create
658
  else
659
    postRenderHeightDataList := nil;
660

661
  MarkAllTilesAsUnused;
662
  AbsoluteMatrix; // makes sure it is available
663

664
  // determine orientation (to render front-to-back)
665
  if vEyeDirection.V[0] >= 0 then
666
    deltaX := TileSize
667
  else
668
  begin
669
    deltaX := -TileSize;
670
    minTilePosX := maxTilePosX;
671
  end;
672
  if vEyeDirection.V[1] >= 0 then
673
    deltaY := TileSize
674
  else
675
  begin
676
    deltaY := -TileSize;
677
    minTilePosY := maxTilePosY;
678
  end;
679

680
  tileRadius := tileRadius;
681

682
  tilePos.V[1] := minTilePosY;
683
  for iY := 0 to nbY - 1 do
684
  begin
685
    tilePos.V[0] := minTilePosX;
686
    prevPatch := nil;
687
    n := 0;
688
    for iX := 0 to nbX do
689
    begin
690
      absTilePos := VectorTransform(tilePos, DirectAbsoluteMatrix^);
691
      if not IsVolumeClipped(absTilePos, tileRadius, rcci.frustum) then
692
      begin
693
        patch := GetPreparedPatch(tilePos, observer, texFactor,
694
          postRenderHeightDataList);
695

696
        if patch <> nil then
697
        begin
698

699
          tileDist := VectorDistance(PAffineVector(@rcci.origin)^, absTilePos);
700
          patch.HighRes := (tileDist < qDist);
701

702
          if not patch.HighRes then
703
            patch.ResetTessellation;
704
          if Assigned(prevPatch) then
705
          begin
706
            if deltaX > 0 then
707
              patch.ConnectToTheWest(prevPatch)
708
            else
709
              prevPatch.ConnectToTheWest(patch);
710
          end;
711
          if (prevRow.Count > n) and (prevRow.Items[n] <> nil) then
712
          begin
713
            if deltaY > 0 then
714
              patch.ConnectToTheNorth(TGLROAMPatch(prevRow.Items[n]))
715
            else
716
              TGLROAMPatch(prevRow.Items[n]).ConnectToTheNorth(patch);
717
          end;
718

719
          if patch.HighRes then
720
          begin
721
            // high-res patches are issued immediately
722
            ApplyMaterial(patch.HeightData.materialName);
723
            patch.RenderHighRes(FBufferVertices, FBufferVertexIndices,
724
              FBufferTexPoints, (QualityStyle = hrsTesselated));
725
            FLastTriangleCount := FLastTriangleCount + patch.TriangleCount;
726
          end
727
          else
728
          begin
729
            // CLOD patches are issued after tesselation
730
            patchList.Add(patch);
731
          end;
732

733
          prevPatch := patch;
734
          rowList.Add(patch);
735

736
          if Assigned(postRenderPatchList) then
737
            postRenderPatchList.Add(patch);
738
        end
739
        else
740
        begin
741
          prevPatch := nil;
742
          rowList.Add(nil);
743
        end;
744
      end
745
      else
746
      begin
747
        MarkHashedTileAsUsed(tilePos);
748
        prevPatch := nil;
749
        rowList.Add(nil);
750
      end;
751
      tilePos.V[0] := tilePos.V[0] + deltaX;
752
      Inc(n);
753
    end;
754
    tilePos.V[1] := tilePos.V[1] + deltaY;
755
    buf := prevRow;
756
    prevRow := rowList;
757
    rowList := buf;
758
    rowList.Count := 0;
759
  end;
760

761
  accumCount := FBufferVertexIndices.Capacity shr 3;
762

763
  // Interleave Tesselate and Render so we can send some work to the hardware
764
  // while the CPU keeps working
765
  rpIdxDelta := Round(2 * f / TileSize) + 2;
766
  for n := 0 to patchList.Count - 1 + rpIdxDelta do
767
  begin
768
    if n < patchList.Count then
769
    begin
770
      patch := TGLROAMPatch(patchList[n]);
771
      if Assigned(patch) then
772
      begin
773
        if (patch.LastOcclusionTestPassed) or (patch.OcclusionCounter <= 0) or
774
          (OcclusionTesselate = totTesselateAlways) then
775
          patch.SafeTesselate;
776
      end;
777
    end;
778
    if n >= rpIdxDelta then
779
    begin
780
      patch := TGLROAMPatch(patchList[n - rpIdxDelta]);
781
      if Assigned(patch) then
782
      begin
783
        ApplyMaterial(patch.HeightData.materialName);
784
        patch.RenderAccum(FBufferVertices, FBufferVertexIndices,
785
          FBufferTexPoints, accumCount);
786
        Inc(FLastTriangleCount, patch.TriangleCount);
787
      end;
788
    end;
789
  end;
790

791
  if (GetROAMTrianglesCapacity > MaxCLODTriangles) and
792
    Assigned(FOnMaxCLODTrianglesReached) then
793
  begin
794
    FOnMaxCLODTrianglesReached(rci);
795
    // Fire an event if the MaxCLODTriangles limit was reached
796
  end;
797

798
  TGLROAMPatch.FlushAccum(FBufferVertices, FBufferVertexIndices,
799
    FBufferTexPoints);
800

801
  xgl.PushState;
802
  try
803
    if GL.ARB_multitexture then
804
      xgl.MapTexCoordToDual
805
    else
806
      xgl.MapTexCoordToMain;
807

808
    GL.DisableClientState(GL_VERTEX_ARRAY);
809
    xgl.DisableClientState(GL_TEXTURE_COORD_ARRAY);
810
  finally
811
    xgl.PopState;
812
  end;
813

814
  ApplyMaterial('');
815
  if Assigned(postRenderPatchList) then
816
  begin
817
    FOnPatchPostRender(rci, postRenderPatchList);
818
    postRenderPatchList.Free;
819
  end;
820
  if Assigned(postRenderHeightDataList) then
821
  begin
822
    FOnHeightDataPostRender(rci, postRenderHeightDataList);
823
    postRenderHeightDataList.Free;
824
  end;
825

826
  GL.PopMatrix;
827

828
  if (tmReleaseUnusedTiles in TileManagement) then
829
  begin // Tile cache management option
830
    ReleaseAllUnusedTiles;
831
    HeightDataSource.CleanUp;
832
  end;
833

834
  rowList.Free;
835
  prevRow.Free;
836
  patchList.Free;
837

838
  HeightDataSource.Data.UnLockList;
839
end;
840

841
// MarkAllTilesAsUnused
842

843
procedure TGLTerrainRenderer.MarkAllTilesAsUnused;
844
var
845
  i, j, zero: Integer;
846
begin
847
  if not(tmClearUsedFlags in TileManagement) then
848
    Exit; // Tile cache management option
849
  for i := 0 to cTilesHashSize do
850
    with FTilesHash[i] do
851
    begin
852
      zero := 0;
853
      for j := Count - 1 downto 0 do
854
        TGLHeightData(Items[j]).Tag := zero;
855
    end;
856
end;
857

858
// ReleaseAllUnusedTiles
859

860
procedure TGLTerrainRenderer.ReleaseAllUnusedTiles;
861
var
862
  i, j: Integer;
863
  hashList: TList;
864
  hd: TGLHeightData;
865
begin
866
  for i := 0 to cTilesHashSize do
867
  begin
868
    hashList := FTilesHash[i];
869
    for j := hashList.Count - 1 downto 0 do
870
    begin
871
      hd := TGLHeightData(hashList.Items[j]);
872
      if hd.Tag = 0 then
873
      begin
874
        hashList.Delete(j);
875
        OnTileDestroyed(hd);
876
        hd.OnDestroy := nil;
877
        hd.Release;
878
      end;
879
    end;
880
  end;
881
end;
882

883
// HashedTileCount
884

885
function TGLTerrainRenderer.HashedTileCount: Integer;
886
var
887
  i: Integer;
888
  hashList: TList;
889
  cnt: Integer;
890
begin
891
  cnt := 0;
892
  for i := 0 to cTilesHashSize do
893
  begin
894
    hashList := FTilesHash[i]; // get the number of tiles in each list
895
    cnt := cnt + hashList.Count; // Add the current list's count to the total
896
  end;
897
  Result := cnt;
898
end;
899

900

901
// MarkHashedTileAsUsed
902

903
procedure TGLTerrainRenderer.MarkHashedTileAsUsed(const tilePos: TAffineVector);
904
var
905
  hd: TGLHeightData;
906
  canAllocate: boolean;
907
begin
908
  if not(tmMarkUsedTiles in TileManagement) then
909
    Exit; // Mark used tiles option
910
  canAllocate := tmAllocateNewTiles in TileManagement;
911
  // Allocate tile if not in the list
912
  hd := HashedTile(tilePos, canAllocate);
913
  if Assigned(hd) then
914
    hd.Tag := 1;
915
end;
916

917
// HashedTile
918

919
function TGLTerrainRenderer.HashedTile(const tilePos: TAffineVector;
920
  canAllocate: boolean = True): TGLHeightData;
921
var
922
  xLeft, yTop: Integer;
923
begin
924
  xLeft := Round(tilePos.V[0] * FinvTileSize - 0.5) * (TileSize);
925
  yTop := Round(tilePos.V[1] * FinvTileSize - 0.5) * (TileSize);
926
  Result := HashedTile(xLeft, yTop, canAllocate);
927
end;
928

929
// HashedTile
930

931
function TGLTerrainRenderer.HashedTile(const xLeft, yTop: Integer;
932
  canAllocate: boolean = True): TGLHeightData;
933
var
934
  i: Integer;
935
  hd: TGLHeightData;
936
  hashList: TList;
937
begin
938
  // is the tile already in our list?
939
  hashList := FTilesHash[HashKey(xLeft, yTop)];
940
  for i := hashList.Count - 1 downto 0 do
941
  begin
942
    hd := TGLHeightData(hashList.Items[i]);
943
    if (hd.xLeft = xLeft) and (hd.yTop = yTop) then
944
    begin
945
      if hd.DontUse then
946
      begin
947
        hashList.Remove(hd);
948
        // This tile has now been replaced. Remove it from the hash-table.
949
      end
950
      else
951
      begin
952
        Result := hd;
953
        Exit;
954
      end;
955
    end;
956
  end;
957
  // if not, request it
958
  if canAllocate then
959
  begin
960
    Result := HeightDataSource.GetData(xLeft, yTop, TileSize + 1, hdtSmallInt);
961
    Result.RegisterUse;
962
    Result.OnDestroy := OnTileDestroyed;
963
    if Result.DataState <> hdsNone then
964
      Result.DataType := hdtSmallInt;
965
    FTilesHash[HashKey(xLeft, yTop)].Add(Result);
966
  end
967
  else
968
    Result := nil;
969
end;
970

971
// GetPreparedPatch
972

973
function TGLTerrainRenderer.GetPreparedPatch(const tilePos,
974
  eyePos: TAffineVector; texFactor: single; hdList: TList): TGLROAMPatch;
975
var
976
  tile: TGLHeightData;
977
  patch: TGLROAMPatch;
978
  xLeft, yTop: Integer;
979
  canAllocate: boolean;
980
begin
981
  canAllocate := tmAllocateNewTiles in TileManagement;
982
  xLeft := Round(tilePos.V[0] * FinvTileSize - 0.5) * TileSize;
983
  yTop := Round(tilePos.V[1] * FinvTileSize - 0.5) * TileSize;
984
  tile := HashedTile(xLeft, yTop, canAllocate);
985
  Result := nil;
986
  if not Assigned(tile) then
987
    Exit;
988

989
  if (tmClearUsedFlags in TileManagement) // Tile cache management option
990
  then
991
    tile.Tag := 1; // mark tile as used
992
  if Assigned(hdList) then
993
    hdList.Add(tile);
994

995
  // if tile.DataState=hdsNone then begin
996
  if tile.DataState <> hdsReady then
997
  begin
998
    Result := nil; // if the tile is still not hdsReady, then skip it
999
  end
1000
  else
1001
  begin
1002
    patch := TGLROAMPatch(tile.ObjectTag);
1003
    if not Assigned(patch) then
1004
    begin
1005
      // spawn ROAM patch
1006
      patch := TGLROAMPatch.Create;
1007
      tile.ObjectTag := patch;
1008
      patch.HeightData := tile;
1009
      patch.VertexScale := XYZVector;
1010
      patch.VertexOffset := tilePos;
1011
      patch.OcclusionSkip := OcclusionFrameSkip;
1012
      case tile.TextureCoordinatesMode of
1013
        tcmWorld:
1014
          begin
1015
            patch.TextureScale := AffineVectorMake(texFactor, -texFactor,
1016
              texFactor);
1017
            patch.TextureOffset := AffineVectorMake(xLeft * texFactor,
1018
              1 - yTop * texFactor, 0);
1019
          end;
1020
        tcmLocal:
1021
          begin
1022
            with tile.TextureCoordinatesScale do
1023
              patch.TextureScale := AffineVectorMake(texFactor * S,
1024
                -texFactor * t, texFactor);
1025
            with tile.TextureCoordinatesOffset do
1026
              patch.TextureOffset := AffineVectorMake(0 + S, 1 + t, 0);
1027
          end;
1028
      else
1029
        Assert(False);
1030
      end;
1031
      patch.ComputeVariance(FCLODPrecision);
1032
    end;
1033
    patch.ObserverPosition := VectorSubtract(eyePos, tilePos);
1034
    Result := patch;
1035
  end;
1036
end;
1037

1038
// SeTGLHeightDataSource
1039

1040
procedure TGLTerrainRenderer.SeTGLHeightDataSource(const val: TGLHeightDataSource);
1041
begin
1042
  if FHeightDataSource <> val then
1043
  begin
1044
    if Assigned(FHeightDataSource) then
1045
    begin
1046
      FHeightDataSource.RemoveFreeNotification(Self);
1047
      ReleaseAllTiles;
1048
      FHeightDataSource.Clear;
1049
    end;
1050
    FHeightDataSource := val;
1051
    if Assigned(FHeightDataSource) then
1052
      FHeightDataSource.FreeNotification(Self);
1053
    StructureChanged;
1054
  end;
1055
end;
1056

1057
// SetTileSize
1058

1059
procedure TGLTerrainRenderer.SetTileSize(const val: Integer);
1060
begin
1061
  if val <> FTileSize then
1062
  begin
1063
    if val < 8 then
1064
      FTileSize := 8
1065
    else
1066
      FTileSize := RoundUpToPowerOf2(val);
1067
    FinvTileSize := 1 / FTileSize;
1068
    ReleaseAllTiles;
1069
    StructureChanged;
1070
  end;
1071
end;
1072

1073
// SetTilesPerTexture
1074

1075
procedure TGLTerrainRenderer.SetTilesPerTexture(const val: single);
1076
begin
1077
  if val <> FTilesPerTexture then
1078
  begin
1079
    FTilesPerTexture := val;
1080
    StructureChanged;
1081
  end;
1082
end;
1083

1084
// SetCLODPrecision
1085

1086
procedure TGLTerrainRenderer.SetCLODPrecision(const val: Integer);
1087
var
1088
  i, k: Integer;
1089
  hd: TGLHeightData;
1090
begin
1091
  if val <> FCLODPrecision then
1092
  begin
1093
    FCLODPrecision := val;
1094
    if FCLODPrecision < 1 then
1095
      FCLODPrecision := 1;
1096
    // drop all ROAM data (CLOD has changed, rebuild required)
1097
    for i := 0 to cTilesHashSize do
1098
      with FTilesHash[i] do
1099
      begin
1100
        for k := Count - 1 downto 0 do
1101
        begin
1102
          hd := TGLHeightData(Items[k]);
1103
          if Assigned(hd.ObjectTag) then
1104
          begin
1105
            (hd.ObjectTag as TGLROAMPatch).Free;
1106
            hd.ObjectTag := nil;
1107
          end;
1108
        end;
1109
        Clear;
1110
      end;
1111
  end;
1112
end;
1113

1114
// SetMaterialLibrary
1115

1116
procedure TGLTerrainRenderer.SetMaterialLibrary(const val: TGLMaterialLibrary);
1117
begin
1118
  if val <> FMaterialLibrary then
1119
  begin
1120
    FMaterialLibrary := val;
1121
    StructureChanged;
1122
  end;
1123
end;
1124

1125
// SetQualityStyle
1126

1127
procedure TGLTerrainRenderer.SetQualityStyle(const val: TTerrainHighResStyle);
1128
begin
1129
  if val <> FQualityStyle then
1130
  begin
1131
    FQualityStyle := val;
1132
    StructureChanged;
1133
  end;
1134
end;
1135

1136
// SetOcclusionFrameSkip
1137

1138
procedure TGLTerrainRenderer.SetOcclusionFrameSkip(val: Integer);
1139
var
1140
  i, k: Integer;
1141
  hd: TGLHeightData;
1142
begin
1143
  if val < 0 then
1144
    val := 0;
1145
  if FOcclusionFrameSkip <> val then
1146
  begin
1147
    FOcclusionFrameSkip := val;
1148
    for i := 0 to cTilesHashSize do
1149
      with FTilesHash[i] do
1150
      begin
1151
        for k := Count - 1 downto 0 do
1152
        begin
1153
          hd := TGLHeightData(Items[k]);
1154
          if hd.ObjectTag <> nil then
1155
            TGLROAMPatch(hd.ObjectTag).OcclusionSkip := OcclusionFrameSkip;
1156
        end;
1157
      end;
1158
    NotifyChange(Self);
1159
  end;
1160
end;
1161

1162
// ------------------------------------------------------------------
1163
// ------------------------------------------------------------------
1164
// ------------------------------------------------------------------
1165
initialization
1166

1167
// ------------------------------------------------------------------
1168
// ------------------------------------------------------------------
1169
// ------------------------------------------------------------------
1170

1171
// class registrations
1172
RegisterClass(TGLTerrainRenderer);
1173

1174
end.
1175