2
// This unit is part of the GLScene Engine https://github.com/glscene
5
Classes for height data access.
7
The components and classes in the unit are the core data providers for
8
height-based objects (terrain rendering mainly), they are independant
9
from the rendering stage.
11
In short: access to raw height data is performed by a TGLHeightDataSource
12
subclass, that must take care of performing all necessary data access,
13
cacheing and manipulation to provide TGLHeightData objects. A TGLHeightData
14
is basicly a square, power of two dimensionned raster heightfield, and
15
holds the data a renderer needs.
18
10/01/13 - PW - Added CPP compatibility: considered sensitivity to upper case characters in identifiers
19
18/07/10 - Yar - Improved FPC compatibility (thanks to Rustam Asmandiarov aka Predator)
20
17/07/07 - LIN - Bugfix: hdsNone tiles were not being released. (Now also deletes Queued tiles that are no longer needed).
21
17/07/07 - LIN - Reversed the order in which Queued tiles are prepared.
22
03/04/07 - DaStr - Commented out lines that caused compiler hints
23
Added more explicit pointer dereferencing
24
Renamed GLS_DELPHI_5_UP to GLS_DELPHI_4_DOWN for
25
FPC compatibility (thanks Burkhard Carstens)
26
27/03/07 - LIN- Data is now prepared in 3 stages, to prevent multi-threading issues:
27
-BeforePreparingData : (Main Thread) - Create empty data structures and textures here.
28
-PreparingData : (Sub-Thread) - Fill in the empty structures (MUST be thread safe)
29
-AfterPreparingData : (Main Thread) - Perform any cleanup, which cant be done from a sub-thread
30
17/03/07 - DaStr - Dropped Kylix support in favor of FPC (BugTracekrID=1681585)
31
14/03/07 - DaStr - Added explicit pointer dereferencing
32
(thanks Burkhard Carstens) (Bugtracker ID = 1678644)
33
13/02/07 - LIN- Added TGLHeightDataSource.TextureCoordinates -
34
Called from TGLBitmapHDS and TGLHeightTileFileHDS
35
Many tweaks and changes to threading. (I hope I havent broken anything)
36
02/02/07 - LIN- Added TGLHeightDataSourceFilter
37
30/01/07 - LIN- Added GLHeightData.LibMaterial. (Use instead of MaterialName)
38
GLHeightData is now derived from TGLUpdateAbleObject
39
GLHeightData is now compatible with TGLLibMaterials.DeleteUnusedMaterials
40
19/01/07 - LIN- Added 'Inverted' property to TGLBitmapHDS
41
10/08/04 - SG - TGLHeightData.InterpolatedHeight fix (Alan Rose)
42
03/07/04 - LR - Corrections for Linux compatibility
43
CreateMonochromeBitmap NOT implemented for Linux
44
12/07/03 - EG - Further InterpolatedHeight fixes
45
26/06/03 - EG - Fixed InterpolatedHeight HDS selection
46
06/02/03 - EG - Added Hash index to HeightDataSource, HeightMin/Max
47
24/01/03 - EG - Fixed ByteHeight normalization scaling
48
07/01/03 - JJ - fixed InterpolatedHeight... Old code left in comment...
49
03/12/02 - EG - Added hdtDefault, InterpolatedHeight/Dirty fix (Phil Scadden)
50
25/08/02 - EG - TGLHeightData.MarkData/Release fix (Phil Scadden)
51
10/07/02 - EG - Support for non-wrapping TGLBitmapHDS
52
16/06/02 - EG - Changed HDS destruction sequence (notification-safe),
53
TGLHeightData now has a MaterialName property
54
24/02/02 - EG - Faster Cleanup & cache management
55
21/02/02 - EG - hdtWord replaced by hdtSmallInt, added MarkDirty
56
04/02/02 - EG - CreateMonochromeBitmap now shielded against Jpeg "Change" oddity
57
10/09/01 - EG - Added TGLTerrainBaseHDS
58
04/03/01 - EG - Added InterpolatedHeight
59
11/02/01 - EG - Creation
71
Windows, // for CreateMonochromeBitmap
74
GLApplicationFileIO, GLUtils,
75
GLVectorGeometry, GLCrossPlatform, GLMaterial, GLBaseClasses;
78
TByteArray = array [0 .. MaxInt div (2 * SizeOf(Byte))] of Byte;
79
TByteRaster = array [0 .. MaxInt div (2 * SizeOf(Pointer))] of PByteArray;
80
PByteRaster = ^TByteRaster;
81
TSmallintArray = array [0 .. MaxInt div (2 * SizeOf(SmallInt))] of SmallInt;
82
PSmallIntArray = ^TSmallintArray;
83
TSmallIntRaster = array [0 .. MaxInt div (2 * SizeOf(Pointer))
85
PSmallIntRaster = ^TSmallIntRaster;
86
TSingleRaster = array [0 .. MaxInt div (2 * SizeOf(Pointer))] of PSingleArray;
87
PSingleRaster = ^TSingleRaster;
89
TGLHeightData = class;
90
TGLHeightDataClass = class of TGLHeightData;
94
{ : Determines the type of data stored in a TGLHeightData.95
There are 3 data types (8 bits unsigned, signed 16 bits and 32 bits).
96
Conversions: (128*(ByteValue-128)) = SmallIntValue = Round(SingleValue).
97
The 'hdtDefault' type is used for request only, and specifies that the
98
default type for the source should be used. }
99
TGLHeightDataType = (hdtByte, hdtSmallInt, hdtSingle, hdtDefault);
101
// TGLHeightDataSource
103
{ : Base class for height datasources.104
This class is abstract and presents the standard interfaces for height
105
data retrieval (TGLHeightData objects). The class offers the following
106
features (that a subclass may decide to implement or not, what follow
107
is the complete feature set, check subclass doc to see what is actually
109
Pooling / Cacheing (return a TGLHeightData with its "Release" method)
110
Pre-loading : specify a list of TGLHeightData you want to preload
111
Multi-threaded preload/queueing : specified list can be loaded in
115
TGLHeightDataSource = class(TComponent)
118
FData: TThreadList; // stores all TGLHeightData, whatever their state/type
119
FDataHash: array [0 .. 255] of TList; // X/Y hash references for HeightDatas
120
FThread: TThread; // queue manager
121
FMaxThreads: Integer;
122
FMaxPoolSize: Integer;
123
FHeightDataClass: TGLHeightDataClass;
124
// FReleaseLatency : TDateTime; //Not used anymore???
125
FDefaultHeight: Single;
128
procedure SetMaxThreads(const Val: Integer);
130
function HashKey(XLeft, YTop: Integer): Integer;
132
{ : Adjust this property in you subclasses. }133
property HeightDataClass: TGLHeightDataClass read FHeightDataClass
134
write FHeightDataClass;
136
{ : Looks up the list and returns the matching TGLHeightData, if any. }137
function FindMatchInList(XLeft, YTop, size: Integer;
138
DataType: TGLHeightDataType): TGLHeightData;
142
constructor Create(AOwner: TComponent); override;
143
destructor Destroy; override;
145
{ : Access to currently pooled TGLHeightData objects, and Thread locking }146
property Data: TThreadList read FData;
148
{ : Empties the Data list, terminating thread if necessary.149
If some TGLHeightData are hdsInUse, triggers an exception and does
152
{ : Removes less used TDataHeight objects from the pool.153
Only removes objects whose state is hdsReady and UseCounter is zero,
154
starting from the end of the list until total data size gets below
155
MaxPoolSize (or nothing can be removed). }
158
{ : Base TGLHeightData requester method.159
Returns (by rebuilding it or from the cache) a TGLHeightData
160
corresponding to the given area. Size must be a power of two.
161
Subclasses may choose to publish it or just publish datasource-
162
specific requester method using specific parameters. }
163
function GetData(XLeft, YTop, size: Integer; DataType: TGLHeightDataType)
164
: TGLHeightData; virtual;
165
{ : Preloading request.166
See GetData for details. }
167
function PreLoad(XLeft, YTop, size: Integer; DataType: TGLHeightDataType)
168
: TGLHeightData; virtual;
170
{ : Replacing dirty tiles. }171
procedure PreloadReplacement(aHeightData: TGLHeightData);
173
{ : Notification that the data is no longer used by the renderer.174
Default behaviour is just to change DataState to hdsReady (ie. return
175
the data to the pool) }
176
procedure Release(aHeightData: TGLHeightData); virtual;
177
{ : Marks the given area as "dirty" (ie source data changed).178
All loaded and in-cache tiles overlapping the area are flushed. }
179
procedure MarkDirty(const Area: TGLRect); overload; virtual;
180
procedure MarkDirty(XLeft, YTop, xRight, yBottom: Integer); overload;
181
procedure MarkDirty; overload;
183
{ : Maximum number of background threads.184
If 0 (zero), multithreading is disabled and StartPreparingData
185
will be called from the mainthread, and all preload requirements
186
(queued TGLHeightData objects) will be loaded in sequence from
188
If 1, basic multithreading and queueing gets enabled,
189
ie. StartPreparingData will be called from a thread, but from one
190
thread only (ie. there is no need to implement a TGLHeightDataThread,
191
just make sure StartPreparingData code is thread-safe).
192
Other values (2 and more) are relevant only if you implement
193
a TGLHeightDataThread subclass and fire it in StartPreparingData. }
194
property MaxThreads: Integer read FMaxThreads write SetMaxThreads;
195
{ : Maximum Size of TDataHeight pool in bytes.196
The pool (cache) can actually get larger if more data than the pool
197
can accomodate is used, but as soon as data gets released and returns
198
to the pool, TDataHeight will be freed until total pool Size gets
200
The pool manager frees TDataHeight objects who haven't been requested
201
for the longest time first.
202
The default value of zero effectively disables pooling. }
203
property MaxPoolSize: Integer read FMaxPoolSize write FMaxPoolSize;
204
{ : Height to return for undefined tiles. }205
property DefaultHeight: Single read FDefaultHeight write FDefaultHeight;
207
{ : Interpolates height for the given point. }208
function InterpolatedHeight(x, y: Single; tileSize: Integer)
211
function Width: Integer; virtual; abstract;
212
function Height: Integer; virtual; abstract;
213
procedure ThreadIsIdle; virtual;
215
{ : This is called BEFORE StartPreparing Data, but always from the main thread. }216
procedure BeforePreparingData(HeightData: TGLHeightData); virtual;
218
{ : Request to start preparing data.219
If your subclass is thread-enabled, this is here that you'll create
220
your thread and fire it (don't forget the requirements), if not,
221
that'll be here you'll be doing your work.
222
Either way, you are responsible for adjusting the DataState to
223
hdsReady when you're done (DataState will be hdsPreparing when this
224
method will be invoked). }
225
procedure StartPreparingData(HeightData: TGLHeightData); virtual;
227
{ : This is called After "StartPreparingData", but always from the main thread. }228
procedure AfterPreparingData(HeightData: TGLHeightData); virtual;
230
procedure TextureCoordinates(HeightData: TGLHeightData;
231
Stretch: boolean = false);
234
// THDTextureCoordinatesMode
236
THDTextureCoordinatesMode = (tcmWorld, tcmLocal);
238
// TGLHeightDataState
240
{ : Possible states for a TGLHeightData.242
hdsQueued : the data has been queued for loading
243
hdsPreparing : the data is currently loading or being prepared for use
244
hdsReady : the data is fully loaded and ready for use
245
hdsNone : the height data does not exist for this tile
247
TGLHeightDataState = (hdsQueued, hdsPreparing, hdsReady, hdsNone);
249
TGLHeightDataThread = class;
250
TOnHeightDataDirtyEvent = procedure(sender: TGLHeightData) of object;
252
TGLHeightDataUser = record
254
event: TOnHeightDataDirtyEvent;
259
{ : Base class for height data, stores a height-field raster.260
The raster is a square, whose Size must be a power of two. Data can be
261
accessed through a base pointer ("ByteData[n]" f.i.), or through pointer262
indirections ("ByteRaster[y][x]" f.i.), this are the fastest way to access263
height data (and the most unsecure).
264
Secure (with range checking) data access is provided by specialized
265
methods (f.i. "ByteHeight"), in which coordinates (x & y) are always
266
considered relative (like in raster access).
267
The class offers conversion facility between the types (as a whole data
268
conversion), but in any case, the TGLHeightData should be directly requested
269
from the TGLHeightDataSource with the appropriate format.
270
Though this class can be instantiated, you will usually prefer to subclass
271
it in real-world cases, f.i. to add texturing data. }
272
// TGLHeightData = class (TObject)
273
TGLHeightData = class(TGLUpdateAbleObject)
276
FUsers: array of TGLHeightDataUser;
277
FOwner: TGLHeightDataSource;
278
FDataState: TGLHeightDataState;
280
FXLeft, FYTop: Integer;
281
FUseCounter: Integer;
282
FDataType: TGLHeightDataType;
284
FByteData: PByteArray;
285
FByteRaster: PByteRaster;
286
FSmallIntData: PSmallIntArray;
287
FSmallIntRaster: PSmallIntRaster;
288
FSingleData: PSingleArray;
289
FSingleRaster: PSingleRaster;
290
FTextureCoordinatesMode: THDTextureCoordinatesMode;
291
FTCOffset, FTCScale: TTexPoint;
292
FMaterialName: String; // Unsafe. Use FLibMaterial instead
293
FLibMaterial: TGLLibMaterial;
295
FTag, FTag2: Integer;
296
FOnDestroy: TNotifyEvent;
298
FHeightMin, FHeightMax: Single;
300
procedure BuildByteRaster;
301
procedure BuildSmallIntRaster;
302
procedure BuildSingleRaster;
304
procedure ConvertByteToSmallInt;
305
procedure ConvertByteToSingle;
306
procedure ConvertSmallIntToByte;
307
procedure ConvertSmallIntToSingle;
308
procedure ConvertSingleToByte;
309
procedure ConvertSingleToSmallInt;
313
FThread: TGLHeightDataThread;
314
// thread used for multi-threaded processing (if any)
316
procedure SetDataType(const Val: TGLHeightDataType);
317
procedure SetMaterialName(const MaterialName: string);
318
procedure SetLibMaterial(LibMaterial: TGLLibMaterial);
320
function GetHeightMin: Single;
321
function GetHeightMax: Single;
324
OldVersion: TGLHeightData; // previous version of this tile
325
NewVersion: TGLHeightData; // the replacement tile
326
DontUse: boolean; // Tells TerrainRenderer which version to use
330
// constructor Create(AOwner : TComponent); override;
331
constructor Create(AOwner: TGLHeightDataSource; aXLeft, aYTop, aSize: Integer;
332
aDataType: TGLHeightDataType); reintroduce; virtual;
333
destructor Destroy; override;
335
{ : The component who created and maintains this data. }336
property Owner: TGLHeightDataSource read FOwner;
338
{ : Fired when the object is destroyed. }339
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
341
{ : Counter for use registration.342
A TGLHeightData is not returned to the pool until this counter reaches
344
property UseCounter: Integer read FUseCounter;
345
{ : Increments UseCounter.346
User objects should implement a method that will be notified when
347
the data becomes dirty, when invoked they should release the heightdata
348
immediately after performing their own cleanups. }
349
procedure RegisterUse;
350
{ : Allocate memory and prepare lookup tables for current datatype.351
Fails if already allocated. Made Dynamic to allow descendants }
352
procedure Allocate(const Val: TGLHeightDataType); dynamic;
353
{ : Decrements UseCounter.354
When the counter reaches zero, notifies the Owner TGLHeightDataSource
355
that the data is no longer used.
356
The renderer should call Release when it no longer needs a THeighData,
357
and never free/destroy the object directly. }
359
{ : Marks the tile as dirty.360
The immediate effect is currently the destruction of the tile. }
363
{ : World X coordinate of top left point. }364
property XLeft: Integer read FXLeft;
365
{ : World Y coordinate of top left point. }366
property YTop: Integer read FYTop;
367
{ : Type of the data.368
Assigning a new datatype will result in the data being converted. }
369
property DataType: TGLHeightDataType read FDataType write SetDataType;
370
{ : Current state of the data. }371
property DataState: TGLHeightDataState read FDataState write FDataState;
372
{ : Size of the data square, in data units. }373
property Size: Integer read FSize;
374
{ : True if the data is dirty (ie. no longer up-to-date). }375
property Dirty: boolean read FDirty write FDirty;
377
{ : Memory Size of the raw data in bytes. }378
property DataSize: Integer read FDataSize;
380
{ : Access to data as a byte array (n = y*Size+x).381
If TGLHeightData is not of type hdtByte, this value is nil. }
382
property ByteData: PByteArray read FByteData;
383
{ : Access to data as a byte raster (y, x).384
If TGLHeightData is not of type hdtByte, this value is nil. }
385
property ByteRaster: PByteRaster read FByteRaster;
386
{ : Access to data as a SmallInt array (n = y*Size+x).387
If TGLHeightData is not of type hdtSmallInt, this value is nil. }
388
property SmallIntData: PSmallIntArray read FSmallIntData;
389
{ : Access to data as a SmallInt raster (y, x).390
If TGLHeightData is not of type hdtSmallInt, this value is nil. }
391
property SmallIntRaster: PSmallIntRaster read FSmallIntRaster;
392
{ : Access to data as a Single array (n = y*Size+x).393
If TGLHeightData is not of type hdtSingle, this value is nil. }
394
property SingleData: PSingleArray read FSingleData;
395
{ : Access to data as a Single raster (y, x).396
If TGLHeightData is not of type hdtSingle, this value is nil. }
397
property SingleRaster: PSingleRaster read FSingleRaster;
399
{ : Name of material for the tile (if terrain uses multiple materials). }400
// property MaterialName : String read FMaterialName write FMaterialName;
401
// (WARNING: Unsafe when deleting textures! If possible, rather use LibMaterial.)
402
property MaterialName: String read FMaterialName write SetMaterialName;
403
// property LibMaterial : Links directly to the tile's TGLLibMaterial.
404
// Unlike 'MaterialName', this property also registers the tile as
405
// a user of the texture.
406
// This prevents TGLLibMaterials.DeleteUnusedTextures from deleting the
407
// used texture by mistake and causing Access Violations.
408
// Use this instead of the old MaterialName property, to prevent AV's.
409
property LibMaterial: TGLLibMaterial read FLibMaterial write SetLibMaterial;
410
{ : Texture coordinates generation mode.411
Default is tcmWorld coordinates. }
412
property TextureCoordinatesMode: THDTextureCoordinatesMode
413
read FTextureCoordinatesMode write FTextureCoordinatesMode;
414
property TextureCoordinatesOffset: TTexPoint read FTCOffset write FTCOffset;
415
property TextureCoordinatesScale: TTexPoint read FTCScale write FTCScale;
416
{ : Height of point x, y as a Byte. }417
function ByteHeight(x, y: Integer): Byte;
418
{ : Height of point x, y as a SmallInt. }419
function SmallIntHeight(x, y: Integer): SmallInt;
420
{ : Height of point x, y as a Single. }421
function SingleHeight(x, y: Integer): Single;
422
{ : Interopolated height of point x, y as a Single. }423
function InterpolatedHeight(x, y: Single): Single;
425
{ : Minimum height in the tile.426
DataSources may assign a value to prevent automatic computation
427
if they have a faster/already computed value. }
428
property HeightMin: Single read GetHeightMin write FHeightMin;
429
{ : Maximum height in the tile.430
DataSources may assign a value to prevent automatic computation
431
if they have a faster/already computed value. }
432
property HeightMax: Single read GetHeightMax write FHeightMax;
434
{ : Returns the height as a single, whatever the DataType (slow). }435
function Height(x, y: Integer): Single;
437
{ : Calculates and returns the normal for vertex point x, y.438
Sub classes may provide normal cacheing, the default implementation
439
being rather blunt. }
440
function Normal(x, y: Integer; const scale: TAffineVector)
441
: TAffineVector; virtual;
443
{ : Calculates and returns the normal for cell x, y.(between vertexes) }444
function NormalAtNode(x, y: Integer; const scale: TAffineVector)
445
: TAffineVector; virtual;
447
{ : Returns True if the data tile overlaps the area. }448
function OverlapsArea(const Area: TGLRect): boolean;
450
{ : Reserved for renderer use. }451
property ObjectTag: TObject read FObjectTag write FObjectTag;
452
{ : Reserved for renderer use. }453
property Tag: Integer read FTag write FTag;
454
{ : Reserved for renderer use. }455
property Tag2: Integer read FTag2 write FTag2;
456
{ : Used by perlin HDS. }457
property Thread: TGLHeightDataThread read FThread write FThread;
460
// TGLHeightDataThread
462
{ : A thread specialized for processing TGLHeightData in background.464
must have FreeOnTerminate set to true,
465
must check and honour Terminated swiftly
467
TGLHeightDataThread = class(TThread)
470
FHeightData: TGLHeightData;
474
destructor Destroy; override;
475
{ : The Height Data the thread is to prepare. }476
property HeightData: TGLHeightData read FHeightData write FHeightData;
482
{ : Bitmap-based Height Data Source.483
The image is automatically wrapped if requested data is out of picture Size,
484
or if requested data is larger than the picture.
485
The internal format is an 8 bit bitmap whose dimensions are a power of two,
486
if the original image does not comply, it is StretchDraw'ed on a monochrome
488
TGLBitmapHDS = class(TGLHeightDataSource)
491
FScanLineCache: array of PByteArray;
494
IntfImg1: TLazIntfImage;
496
FPicture: TGLPicture;
497
FInfiniteWrap: boolean;
502
procedure SetPicture(const Val: TGLPicture);
503
procedure OnPictureChanged(sender: TObject);
504
procedure SetInfiniteWrap(Val: boolean);
505
procedure SetInverted(Val: boolean);
507
procedure CreateMonochromeBitmap(size: Integer);
508
procedure FreeMonochromeBitmap;
509
function GetScanLine(y: Integer): PByteArray;
512
constructor Create(AOwner: TComponent); override;
513
destructor Destroy; override;
515
procedure StartPreparingData(HeightData: TGLHeightData); override;
516
procedure MarkDirty(const Area: TGLRect); override;
517
function Width: Integer; override;
518
function Height: Integer; override;
522
{ : The picture serving as Height field data reference.523
The picture is (if not already) internally converted to a 8 bit
524
bitmap (grayscale). For better performance and to save memory,
525
feed it this format! }
526
property Picture: TGLPicture read FPicture write SetPicture;
527
{ : If true the height field is wrapped indefinetely. }528
property InfiniteWrap: boolean read FInfiniteWrap write SetInfiniteWrap
530
{ : If true, the rendered terrain is a mirror image of the input data. }531
property Inverted: boolean read FInverted write SetInverted default True;
533
property MaxPoolSize;
536
TStartPreparingDataEvent = procedure(HeightData: TGLHeightData) of object;
537
TMarkDirtyEvent = procedure(const Area: TGLRect) of object;
539
// TTexturedHeightDataSource = class (TGLTexturedHeightDataSource)
543
{ : An Height Data Source for custom use.544
Provides event handlers for the various requests to be implemented
545
application-side (for application-specific needs). }
546
TGLCustomHDS = class(TGLHeightDataSource)
549
FOnStartPreparingData: TStartPreparingDataEvent;
550
FOnMarkDirty: TMarkDirtyEvent;
557
constructor Create(AOwner: TComponent); override;
558
destructor Destroy; override;
559
procedure StartPreparingData(HeightData: TGLHeightData); override;
561
procedure MarkDirty(const Area: TGLRect); override;
565
property MaxPoolSize;
567
property OnStartPreparingData: TStartPreparingDataEvent
568
read FOnStartPreparingData write FOnStartPreparingData;
569
property OnMarkDirtyEvent: TMarkDirtyEvent read FOnMarkDirty
575
{ : TerrainBase-based Height Data Source.576
This component takes its data from the TerrainBase Gobal Terrain Model.
577
Though it can be used directly, the resolution of the TerrainBase dataset
578
isn't high enough for accurate short-range representation and the data
579
should rather be used as basis for further (fractal) refinement.
580
TerrainBase is freely available from the National Geophysical Data Center
581
and World Data Center web site (http://ngdc.noaa.com).
582
(this component expects to find "tbase.bin" in the current directory). }
583
TGLTerrainBaseHDS = class(TGLHeightDataSource)
592
constructor Create(AOwner: TComponent); override;
593
destructor Destroy; override;
594
procedure StartPreparingData(HeightData: TGLHeightData); override;
598
property MaxPoolSize;
601
TGLHeightDataSourceFilter = Class;
602
TSourceDataFetchedEvent = procedure(sender: TGLHeightDataSourceFilter;
603
HeightData: TGLHeightData) of object;
605
// TGLHeightDataSourceFilter
607
{ : Height Data Source Filter.608
This component sits between the TGLTerrainRenderer, and a real TGLHeightDataSource.
609
i.e. TGLTerrainRenderer links to this. This links to the real TGLHeightDataSource.
610
Use the 'HeightDataSource' property, to link to a source HDS.
611
The 'OnSourceDataFetched' event then gives you the opportunity to make any changes,
612
or link in a texture to the TGLHeightData object, BEFORE it is cached.
613
It bypasses the cache of the source HDS, by calling the source's StartPreparingData procedure directly.
614
The TGLHeightData objects are then cached by THIS component, AFTER you have made your changes.
615
This eliminates the need to copy and release the TGLHeightData object from the Source HDS's cache,
616
before linking your texture. See the new version of TGLBumpmapHDS for an example. (LIN)
617
To create your own HDSFilters, Derive from this component, and override the PreparingData procedure.
619
TGLHeightDataSourceFilter = Class(TGLHeightDataSource)
622
FHDS: TGLHeightDataSource;
623
FOnSourceDataFetched: TSourceDataFetchedEvent;
628
Override this function in your filter subclasses, to make any
629
updates/changes to HeightData, before it goes into the cache.
630
Make sure any code in this function is thread-safe, in case TAsyncHDS was used. }
631
procedure PreparingData(HeightData: TGLHeightData); virtual; abstract;
632
procedure SetHDS(Val: TGLHeightDataSource);
635
constructor Create(AOwner: TComponent); override;
636
destructor Destroy; override;
637
procedure Release(aHeightData: TGLHeightData); override;
638
procedure StartPreparingData(HeightData: TGLHeightData); override;
639
procedure Notification(AComponent: TComponent;
640
Operation: TOperation); override;
641
function Width: Integer; override;
642
function Height: Integer; override;
643
property OnSourceDataFetched: TSourceDataFetchedEvent
644
read FOnSourceDataFetched write FOnSourceDataFetched;
648
property MaxPoolSize;
649
property HeightDataSource: TGLHeightDataSource read FHDS write SetHDS;
650
property Active: boolean read FActive write FActive;
651
// If Active=False, height data passes through unchanged
654
// ------------------------------------------------------------------
655
// ------------------------------------------------------------------
656
// ------------------------------------------------------------------
659
// ------------------------------------------------------------------
660
// ------------------------------------------------------------------
661
// ------------------------------------------------------------------
664
// ------------------ TGLHeightDataSourceThread ------------------
668
TGLHeightDataSourceThread = class(TThread)
669
FOwner: TGLHeightDataSource;
670
procedure Execute; override;
671
function WaitForTile(HD: TGLHeightData; seconds: Integer): boolean;
677
procedure TGLHeightDataSourceThread.Execute;
685
while not Terminated do
687
max := FOwner.MaxThreads;
688
lst := FOwner.FData.LockList;
690
// --count active threads--
693
while (i < lst.Count) and (TdCtr < max) do
695
if TGLHeightData(lst.Items[i]).FThread <> nil then
699
// ------------------------
701
// --Find the queued tiles, and Start preparing them--
703
While ((i < lst.Count) and (TdCtr < max)) do
705
HD := TGLHeightData(lst.Items[i]);
706
if HD.DataState = hdsQueued then
708
FOwner.StartPreparingData(HD); // prepare
713
// ---------------------------------------------------
715
FOwner.FData.UnlockList;
717
synchronize(HDSIdle);
721
sleep(0); // sleep longer if no Queued tiles were found
727
// When Threading, wait a specified time, for the tile to finish preparing
728
function TGLHeightDataSourceThread.WaitForTile(HD: TGLHeightData;
729
seconds: Integer): boolean;
734
eTime := now + (1000 * seconds);
735
while (HD.FThread <> nil) and (now < eTime) do
739
Result := (HD.FThread = nil); // true if the thread has finished
744
// When using threads, HDSIdle is called in the main thread,
745
// whenever all HDS threads have finished, AND no queued tiles were found.
746
// (GLAsyncHDS uses this for the OnIdle event.)
747
procedure TGLHeightDataSourceThread.HDSIdle;
749
self.FOwner.ThreadIsIdle;
753
// ------------------ TGLHeightDataSource ------------------
758
constructor TGLHeightDataSource.Create(AOwner: TComponent);
762
inherited Create(AOwner);
763
FHeightDataClass := TGLHeightData;
764
FData := TThreadList.Create;
765
for i := 0 to High(FDataHash) do
766
FDataHash[i] := TList.Create;
767
// FReleaseLatency:=15/(3600*24);
768
FThread := TGLHeightDataSourceThread.Create(True);
769
FThread.FreeOnTerminate := false;
770
TGLHeightDataSourceThread(FThread).FOwner := self;
771
if self.MaxThreads > 0 then
772
{$IFDEF GLS_DELPHI_2009_DOWN}781
destructor TGLHeightDataSource.Destroy;
786
if Assigned(FThread) then
789
{$IFDEF GLS_DELPHI_2009_DOWN}799
for i := 0 to High(FDataHash) do
805
procedure TGLHeightDataSource.Clear;
809
with FData.LockList do
812
for i := 0 to Count - 1 do
813
if TGLHeightData(Items[i]).UseCounter > 0 then
814
if not(csDestroying in ComponentState) then
815
raise Exception.Create('ERR: HeightData still in use');816
for i := 0 to Count - 1 do
818
TGLHeightData(Items[i]).FOwner := nil;
819
TGLHeightData(Items[i]).Free;
821
for i := 0 to High(FDataHash) do
832
function TGLHeightDataSource.HashKey(XLeft, YTop: Integer): Integer;
834
Result := (XLeft + (XLeft shr 8) + (YTop shl 1) + (YTop shr 7)) and
841
function TGLHeightDataSource.FindMatchInList(XLeft, YTop, size: Integer;
842
DataType: TGLHeightDataType): TGLHeightData;
850
with FDataHash[HashKey(XLeft, YTop)] do
851
for i := 0 to Count - 1 do
853
HD := TGLHeightData(Items[i]);
854
// if (not hd.Dirty) and (hd.XLeft=xLeft) and (hd.YTop=YTop) and (hd.Size=Size) and (hd.DataType=DataType) then begin
855
if (HD.XLeft = XLeft) and (HD.YTop = YTop) and (HD.size = size) and
856
(HD.DataType = DataType) and (HD.DontUse = false) then
869
function TGLHeightDataSource.GetData(XLeft, YTop, size: Integer;
870
DataType: TGLHeightDataType): TGLHeightData;
872
Result := FindMatchInList(XLeft, YTop, size, DataType);
873
if not Assigned(Result) then
874
Result := PreLoad(XLeft, YTop, size, DataType)
876
with FData.LockList do
879
Move(IndexOf(Result), 0); // Moves item to the beginning of the list.
884
// got one... can be used ?
885
// while not (Result.DataState in [hdsReady, hdsNone]) do Sleep(0);
890
function TGLHeightDataSource.PreLoad(XLeft, YTop, size: Integer;
891
DataType: TGLHeightDataType): TGLHeightData;
893
Result := HeightDataClass.Create(self, XLeft, YTop, size, DataType);
894
with FData.LockList do
897
BeforePreparingData(Result);
898
FDataHash[HashKey(XLeft, YTop)].Add(Result);
903
// -- When NOT using Threads, fully prepare the tile immediately--
904
if MaxThreads = 0 then
906
StartPreparingData(Result);
907
AfterPreparingData(Result);
909
// ---------------------------------------------------------------
914
// When Multi-threading, this queues a replacement for a dirty tile
915
// The Terrain renderer will continue to use the dirty tile, until the replacement is complete
916
procedure TGLHeightDataSource.PreloadReplacement(aHeightData: TGLHeightData);
919
NewHD: TGLHeightData;
921
Assert(MaxThreads > 0);
923
NewHD := HeightDataClass.Create(self, HD.XLeft, HD.YTop, HD.size,
925
with FData.LockList do
928
NewHD.OldVersion := HD; // link
929
HD.NewVersion := NewHD; // link
930
NewHD.DontUse := True;
931
BeforePreparingData(NewHD);
932
FDataHash[HashKey(HD.XLeft, HD.YTop)].Add(NewHD);
940
procedure TGLHeightDataSource.Release(aHeightData: TGLHeightData);
947
procedure TGLHeightDataSource.MarkDirty(const Area: TGLRect);
952
with FData.LockList do
955
for i := Count - 1 downto 0 do
957
HD := TGLHeightData(Items[i]);
958
if HD.OverlapsArea(Area) then
969
procedure TGLHeightDataSource.MarkDirty(XLeft, YTop, xRight, yBottom: Integer);
982
procedure TGLHeightDataSource.MarkDirty;
986
MarkDirty(-m, -m, m, m);
991
procedure TGLHeightDataSource.CleanUp;
997
ReleaseThis: boolean;
999
with FData.LockList do
1004
// Cleanup dirty tiles and compute used memory
1005
for i := Count - 1 downto 0 do
1007
HD := TGLHeightData(Items[i]);
1011
// --Release criteria for dirty tiles--
1012
ReleaseThis := false;
1014
begin // Only release dirty tiles
1015
if (MaxThreads = 0) then
1017
// when not threading, delete ALL dirty tiles
1018
else if (HD.DataState <> hdsPreparing) then
1019
begin // Dont release Preparing tiles
1020
if (HD.UseCounter = 0) then
1021
ReleaseThis := True; // This tile is unused
1022
if (HD.NewVersion = nil) then
1024
// This tile has no queued replacement to wait for
1025
else if (HD.DontUse) then
1026
ReleaseThis := True; // ??This tile has already been replaced.
1029
// ------------------------------------
1030
// if Dirty then ReleaseThis:=true;
1033
FDataHash[HashKey(HD.XLeft, HD.YTop)].Remove(HD);
1040
usedMemory := usedMemory + HD.DataSize;
1043
// If MaxPoolSize exceeded, release all that may be, and pack the list
1045
if usedMemory > MaxPoolSize then
1047
for i := 0 to Count - 1 do
1049
HD := TGLHeightData(Items[i]);
1053
if (DataState <> hdsPreparing) and (UseCounter = 0) and
1055
// if (DataState=hdsReady)and(UseCounter=0)and(OldVersion=nil)
1058
FDataHash[HashKey(HD.XLeft, HD.YTop)].Remove(HD);
1073
else if packList then
1075
for i := 0 to Count - 1 do
1076
if Items[i] <> nil then
1078
Items[k] := Items[i];
1091
procedure TGLHeightDataSource.SetMaxThreads(const Val: Integer);
1097
// If we didn't do threading, but will now
1098
// resume our thread
1099
if (FMaxThreads <= 0) then
1100
{$IFDEF GLS_DELPHI_2009_DOWN}1109
// BeforePreparingData
1110
// Called BEFORE StartPreparingData, but always from the MAIN thread.
1111
// Override this in subclasses, to prepare for Threading.
1113
procedure TGLHeightDataSource.BeforePreparingData(HeightData: TGLHeightData);
1118
// StartPreparingData
1119
// When Threads are used, this runs from the sub-thread, so this MUST be thread-safe.
1120
// Any Non-thread-safe code should be placed in "BeforePreparingData"
1122
procedure TGLHeightDataSource.StartPreparingData(HeightData: TGLHeightData);
1124
// Only the tile Owner may set the preparing tile to ready
1125
if (HeightData.Owner = self) and (HeightData.DataState = hdsPreparing) then
1126
HeightData.FDataState := hdsReady;
1129
// AfterPreparingData
1130
// Called AFTER StartPreparingData, but always from the MAIN thread.
1131
// Override this in subclasses, if needed.
1133
procedure TGLHeightDataSource.AfterPreparingData(HeightData: TGLHeightData);
1140
procedure TGLHeightDataSource.ThreadIsIdle;
1142
// TGLAsyncHDS overrides this
1145
// TextureCoordinates
1146
// Calculates texture World texture coordinates for the current tile.
1147
// Use Stretch for OpenGL1.1, to hide the seams when using linear filtering.
1148
procedure TGLHeightDataSource.TextureCoordinates(HeightData: TGLHeightData;
1149
Stretch: boolean = false);
1151
w, h, size: Integer;
1152
scaleS, scaleT: Single;
1153
offsetS, offsetT: Single;
1161
// if GL_VERSION_1_2 then begin //OpenGL1.2 supports texture clamping, so seams dont show.
1162
if Stretch = false then
1163
begin // These are the real Texture coordinates
1164
scaleS := w / (size - 1);
1165
scaleT := h / (size - 1);
1166
offsetS := -((HD.XLeft / w) * scaleS);
1167
offsetT := -(h - (HD.YTop + size - 1)) / (size - 1);
1170
begin // --Texture coordinates: Stretched by 1 pixel, to hide seams on OpenGL-1.1(no Clamping)--
1173
halfpixel := 1 / (size shr 1);
1174
offsetS := -((HD.XLeft / w) * scaleS) + halfpixel;
1175
offsetT := -(h - (HD.YTop + size)) / size - halfpixel;
1177
HD.FTCScale.S := scaleS;
1178
HD.FTCScale.T := scaleT;
1179
HD.FTCOffset.S := offsetS;
1180
HD.FTCOffset.T := offsetT;
1183
// InterpolatedHeight
1185
function TGLHeightDataSource.InterpolatedHeight(x, y: Single;
1186
tileSize: Integer): Single;
1189
HD, foundHd: TGLHeightData;
1191
with FData.LockList do
1194
// first, lookup data list to find if aHeightData contains our point
1196
for i := 0 to Count - 1 do
1198
HD := TGLHeightData(Items[i]);
1199
if (HD.XLeft <= x) and (HD.YTop <= y) and (HD.XLeft + HD.size - 1 > x)
1200
and (HD.YTop + HD.size - 1 > y) then
1210
if (foundHd = nil) or foundHd.Dirty then
1212
// not found, request one... slowest mode (should be avoided)
1213
if tileSize > 1 then
1214
foundHd := GetData(Round(x / (tileSize - 1) - 0.5) * (tileSize - 1),
1215
Round(y / (tileSize - 1) - 0.5) * (tileSize - 1), tileSize, hdtDefault)
1218
Result := DefaultHeight;
1224
// request it using "standard" way (takes care of threads)
1225
foundHd := GetData(foundHd.XLeft, foundHd.YTop, foundHd.size,
1228
if foundHd.DataState = hdsNone then
1229
Result := DefaultHeight
1231
Result := foundHd.InterpolatedHeight(x - foundHd.XLeft, y - foundHd.YTop);
1234
// ------------------
1235
// ------------------ TGLHeightData ------------------
1236
// ------------------
1240
constructor TGLHeightData.Create(AOwner: TGLHeightDataSource;
1241
aXLeft, aYTop, aSize: Integer; aDataType: TGLHeightDataType);
1243
inherited Create(AOwner);
1244
SetLength(FUsers, 0);
1249
FTextureCoordinatesMode := tcmWorld;
1250
FTCScale := XYTexPoint;
1251
FDataType := aDataType;
1252
FDataState := hdsQueued;
1263
destructor TGLHeightData.Destroy;
1265
Assert(Length(FUsers) = 0,
1266
'You should *not* free a TGLHeightData, use "Release" instead');
1267
Assert(not Assigned(FOwner),
1268
'You should *not* free a TGLHeightData, use "Release" instead');
1269
if Assigned(FThread) then
1272
if FThread.Suspended then
1273
{$IFDEF GLS_DELPHI_2009_DOWN}1281
// if Assigned(FOnDestroy) then FOnDestroy(self); Assertion Occurs
1286
FreeMem(FByteRaster);
1290
FreeMem(FSmallIntData);
1291
FreeMem(FSmallIntRaster);
1295
FreeMem(FSingleData);
1296
FreeMem(FSingleRaster);
1303
// ----------------------
1304
self.LibMaterial := nil; // release a used material
1306
// --Break any link with a new/old version of this tile--
1307
if Assigned(self.OldVersion) then
1309
self.OldVersion.NewVersion := nil;
1310
self.OldVersion := nil;
1312
if Assigned(self.NewVersion) then
1314
self.NewVersion.OldVersion := nil;
1315
self.NewVersion := nil;
1317
// ------------------------------------------------------
1319
// ----------------------
1325
procedure TGLHeightData.RegisterUse;
1332
procedure TGLHeightData.Release;
1334
if FUseCounter > 0 then
1336
if FUseCounter = 0 then
1338
Owner.Release(self); // ???
1344
// Release Dirty tiles, unless threading, and the tile is being used.
1345
// In that case, start building a replacement tile instead.
1347
procedure TGLHeightData.MarkDirty;
1349
with Owner.Data.LockList do
1351
if (not Dirty) and (DataState <> hdsQueued) then
1352
begin // dont mark queued tiles as dirty
1354
if (Owner.MaxThreads > 0) and (FUseCounter > 0) then
1355
Owner.PreloadReplacement(self)
1359
Owner.Release(self);
1363
Owner.Data.UnlockList;
1369
procedure TGLHeightData.Allocate(const Val: TGLHeightDataType);
1371
Assert(FDataSize = 0);
1375
FDataSize := size * size * SizeOf(Byte);
1376
GetMem(FByteData, FDataSize);
1381
FDataSize := size * size * SizeOf(SmallInt);
1382
GetMem(FSmallIntData, FDataSize);
1383
BuildSmallIntRaster;
1387
FDataSize := size * size * SizeOf(Single);
1388
GetMem(FSingleData, FDataSize);
1397
// WARNING: SetMaterialName does NOT register the tile as a user of this texture.
1398
// So, TGLLibMaterials.DeleteUnusedMaterials may see this material as unused, and delete it.
1399
// This may lead to AV's the next time this tile is rendered.
1400
// To be safe, rather assign the new TGLHeightData.LibMaterial property
1401
procedure TGLHeightData.SetMaterialName(const MaterialName: string);
1403
SetLibMaterial(nil);
1404
FMaterialName := MaterialName;
1407
procedure TGLHeightData.SetLibMaterial(LibMaterial: TGLLibMaterial);
1409
if Assigned(FLibMaterial) then
1410
FLibMaterial.UnregisterUser(self); // detach from old texture
1411
FLibMaterial := LibMaterial; // Attach new Material
1412
if Assigned(LibMaterial) then
1414
LibMaterial.RegisterUser(self); // Mark new Material as 'used'
1415
FMaterialName := LibMaterial.Name; // sync up MaterialName property
1418
FMaterialName := '';
1423
procedure TGLHeightData.SetDataType(const Val: TGLHeightDataType);
1425
if (Val <> FDataType) and (Val <> hdtDefault) then
1427
if DataState <> hdsNone then
1433
ConvertByteToSmallInt;
1435
ConvertByteToSingle;
1442
ConvertSmallIntToByte;
1444
ConvertSmallIntToSingle;
1451
ConvertSingleToByte;
1453
ConvertSingleToSmallInt;
1458
; // nothing, assume StartPreparingData knows what it's doing
1469
procedure TGLHeightData.BuildByteRaster;
1473
GetMem(FByteRaster, size * SizeOf(PByteArray));
1474
for i := 0 to size - 1 do
1475
FByteRaster^[i] := @FByteData[i * size]
1478
// BuildSmallIntRaster
1480
procedure TGLHeightData.BuildSmallIntRaster;
1484
GetMem(FSmallIntRaster, size * SizeOf(PSmallIntArray));
1485
for i := 0 to size - 1 do
1486
FSmallIntRaster^[i] := @FSmallIntData[i * size]
1491
procedure TGLHeightData.BuildSingleRaster;
1495
GetMem(FSingleRaster, size * SizeOf(PSingleArray));
1496
for i := 0 to size - 1 do
1497
FSingleRaster^[i] := @FSingleData[i * size]
1500
// ConvertByteToSmallInt
1502
procedure TGLHeightData.ConvertByteToSmallInt;
1506
FreeMem(FByteRaster);
1508
FDataSize := size * size * SizeOf(SmallInt);
1509
GetMem(FSmallIntData, FDataSize);
1510
for i := 0 to size * size - 1 do
1511
FSmallIntData^[i] := (FByteData^[i] - 128) shl 7;
1514
BuildSmallIntRaster;
1517
// ConvertByteToSingle
1519
procedure TGLHeightData.ConvertByteToSingle;
1523
FreeMem(FByteRaster);
1525
FDataSize := size * size * SizeOf(Single);
1526
GetMem(FSingleData, FDataSize);
1527
for i := 0 to size * size - 1 do
1528
FSingleData^[i] := (FByteData^[i] - 128) shl 7;
1534
// ConvertSmallIntToByte
1536
procedure TGLHeightData.ConvertSmallIntToByte;
1540
FreeMem(FSmallIntRaster);
1541
FSmallIntRaster := nil;
1542
FByteData := Pointer(FSmallIntData);
1543
for i := 0 to size * size - 1 do
1544
FByteData^[i] := (FSmallIntData^[i] div 128) + 128;
1545
FDataSize := size * size * SizeOf(Byte);
1546
ReallocMem(FByteData, FDataSize);
1547
FSmallIntData := nil;
1551
// ConvertSmallIntToSingle
1553
procedure TGLHeightData.ConvertSmallIntToSingle;
1557
FreeMem(FSmallIntRaster);
1558
FSmallIntRaster := nil;
1559
FDataSize := size * size * SizeOf(Single);
1560
GetMem(FSingleData, FDataSize);
1561
for i := 0 to size * size - 1 do
1562
FSingleData^[i] := FSmallIntData^[i];
1563
FreeMem(FSmallIntData);
1564
FSmallIntData := nil;
1568
// ConvertSingleToByte
1570
procedure TGLHeightData.ConvertSingleToByte;
1574
FreeMem(FSingleRaster);
1575
FSingleRaster := nil;
1576
FByteData := Pointer(FSingleData);
1577
for i := 0 to size * size - 1 do
1578
FByteData^[i] := (Round(FSingleData^[i]) div 128) + 128;
1579
FDataSize := size * size * SizeOf(Byte);
1580
ReallocMem(FByteData, FDataSize);
1585
// ConvertSingleToSmallInt
1587
procedure TGLHeightData.ConvertSingleToSmallInt;
1591
FreeMem(FSingleRaster);
1592
FSingleRaster := nil;
1593
FSmallIntData := Pointer(FSingleData);
1594
for i := 0 to size * size - 1 do
1595
FSmallIntData^[i] := Round(FSingleData^[i]);
1596
FDataSize := size * size * SizeOf(SmallInt);
1597
ReallocMem(FSmallIntData, FDataSize);
1599
BuildSmallIntRaster;
1604
function TGLHeightData.ByteHeight(x, y: Integer): Byte;
1606
Assert((Cardinal(x) < Cardinal(size)) and (Cardinal(y) < Cardinal(size)));
1607
Result := ByteRaster^[y]^[x];
1612
function TGLHeightData.SmallIntHeight(x, y: Integer): SmallInt;
1614
Assert((Cardinal(x) < Cardinal(size)) and (Cardinal(y) < Cardinal(size)));
1615
Result := SmallIntRaster^[y]^[x];
1620
function TGLHeightData.SingleHeight(x, y: Integer): Single;
1622
Assert((Cardinal(x) < Cardinal(size)) and (Cardinal(y) < Cardinal(size)));
1623
Result := SingleRaster^[y]^[x];
1626
// InterpolatedHeight
1628
function TGLHeightData.InterpolatedHeight(x, y: Single): Single;
1630
ix, iy, ixn, iyn: Integer;
1633
if FDataState = hdsNone then
1649
// top-right triangle
1650
h1 := Height(ixn, iy);
1651
h2 := Height(ix, iy);
1652
h3 := Height(ixn, iyn);
1653
Result := h1 + (h2 - h1) * (1 - x) + (h3 - h1) * y;
1657
// bottom-left triangle
1658
h1 := Height(ix, iyn);
1659
h2 := Height(ixn, iyn);
1660
h3 := Height(ix, iy);
1661
Result := h1 + (h2 - h1) * (x) + (h3 - h1) * (1 - y);
1668
function TGLHeightData.Height(x, y: Integer): Single;
1672
Result := (ByteHeight(x, y) - 128) shl 7;
1674
Result := SmallIntHeight(x, y);
1676
Result := SingleHeight(x, y);
1685
function TGLHeightData.GetHeightMin: Single;
1692
if FHeightMin = 1E30 then
1694
if DataState = hdsReady then
1700
for i := 1 to size * size - 1 do
1701
if FByteData^[i] < b then
1703
FHeightMin := ((Integer(b) - 128) shl 7);
1707
sm := FSmallIntData^[0];
1708
for i := 1 to size * size - 1 do
1709
if FSmallIntData^[i] < sm then
1710
sm := FSmallIntData^[i];
1715
si := FSingleData^[0];
1716
for i := 1 to size * size - 1 do
1717
if FSingleData^[i] < si then
1718
si := FSingleData^[i];
1728
Result := FHeightMin;
1733
function TGLHeightData.GetHeightMax: Single;
1740
if FHeightMax = 1E30 then
1742
if DataState = hdsReady then
1748
for i := 1 to size * size - 1 do
1749
if FByteData^[i] > b then
1751
FHeightMax := ((Integer(b) - 128) shl 7);
1755
sm := FSmallIntData^[0];
1756
for i := 1 to size * size - 1 do
1757
if FSmallIntData^[i] > sm then
1758
sm := FSmallIntData^[i];
1763
si := FSingleData^[0];
1764
for i := 1 to size * size - 1 do
1765
if FSingleData^[i] > si then
1766
si := FSingleData^[i];
1776
Result := FHeightMax;
1781
// Calculates the normal at a vertex
1782
function TGLHeightData.Normal(x, y: Integer; const scale: TAffineVector) : TAffineVector;
1787
if x < size - 1 then
1788
dx := (Height(x + 1, y) - Height(x - 1, y))
1790
dx := (Height(x, y) - Height(x - 1, y))
1792
dx := (Height(x + 1, y) - Height(x, y));
1794
if y < size - 1 then
1795
dy := (Height(x, y + 1) - Height(x, y - 1))
1797
dy := (Height(x, y) - Height(x, y - 1))
1799
dy := (Height(x, y + 1) - Height(x, y));
1800
Result.V[0] := dx * scale.V[1] * scale.V[2];
1801
Result.V[1] := dy * scale.V[0] * scale.V[2];
1802
Result.V[2] := scale.V[0] * scale.V[1];
1803
NormalizeVector(Result);
1808
// Calculates the normal at a surface cell (Between vertexes)
1809
function TGLHeightData.NormalAtNode(x, y: Integer; const scale: TAffineVector)
1812
dx, dy, Hxy: Single;
1814
MinInteger(MaxInteger(x, 0), size - 2); // clamp x to 0 -> Size-2
1815
MinInteger(MaxInteger(y, 0), size - 2); // clamp x to 0 -> Size-2
1816
Hxy := Height(x, y);
1817
dx := Height(x + 1, y) - Hxy;
1818
dy := Height(x, y + 1) - Hxy;
1819
Result.V[0] := dx * scale.V[1] * scale.V[2]; // Result[0]:=dx/scale[0];
1820
Result.V[1] := dy * scale.V[0] * scale.V[2]; // Result[1]:=dy/scale[1];
1821
Result.V[2] := 1 * scale.V[0] * scale.V[1]; // Result[2]:=1 /scale[2];
1822
NormalizeVector(Result);
1827
function TGLHeightData.OverlapsArea(const Area: TGLRect): boolean;
1829
Result := (XLeft <= Area.Right) and (YTop <= Area.Bottom) and
1830
(XLeft + size > Area.Left) and (YTop + size > Area.Top);
1833
// ------------------
1834
// ------------------ TGLHeightDataThread ------------------
1835
// ------------------
1839
destructor TGLHeightDataThread.Destroy;
1841
if Assigned(FHeightData) then
1842
FHeightData.FThread := nil;
1846
// ------------------
1847
// ------------------ TGLBitmapHDS ------------------
1848
// ------------------
1852
constructor TGLBitmapHDS.Create(AOwner: TComponent);
1854
inherited Create(AOwner);
1855
FPicture := TGLPicture.Create;
1856
FPicture.OnChange := OnPictureChanged;
1857
FInfiniteWrap := True;
1863
destructor TGLBitmapHDS.Destroy;
1866
FreeMonochromeBitmap;
1872
procedure TGLBitmapHDS.SetPicture(const Val: TGLPicture);
1874
FPicture.Assign(Val);
1879
procedure TGLBitmapHDS.OnPictureChanged(sender: TObject);
1881
oldPoolSize, size: Integer;
1884
oldPoolSize := MaxPoolSize;
1887
MaxPoolSize := oldPoolSize;
1888
// prepare MonoChromeBitmap
1889
FreeMonochromeBitmap;
1890
size := Picture.Width;
1892
CreateMonochromeBitmap(size);
1897
procedure TGLBitmapHDS.SetInfiniteWrap(Val: boolean);
1899
if FInfiniteWrap <> Val then
1901
FInfiniteWrap := Val;
1908
procedure TGLBitmapHDS.SetInverted(Val: boolean);
1910
if FInverted = Val then
1918
procedure TGLBitmapHDS.MarkDirty(const Area: TGLRect);
1921
FreeMonochromeBitmap;
1922
if Picture.Width > 0 then
1923
CreateMonochromeBitmap(Picture.Width);
1926
// CreateMonochromeBitmap
1928
procedure TGLBitmapHDS.CreateMonochromeBitmap(size: Integer);
1931
TPaletteEntryArray = array [0 .. 255] of TPaletteEntry;
1932
PPaletteEntryArray = ^TPaletteEntryArray;
1936
pe: TPaletteEntryArray;
1944
size := RoundUpToPowerOf2(size);
1945
FBitmap := TGLBitmap.Create;
1946
FBitmap.PixelFormat := glpf8bit;
1947
FBitmap.Width := size;
1948
FBitmap.Height := size;
1949
for x := 0 to 255 do
1950
with PPaletteEntryArray(@logpal.lpal.palPalEntry[0])[x] do
1960
palNumEntries := 256;
1962
hPal := CreatePalette(logpal.lpal);
1964
FBitmap.Palette := hPal;
1965
// some picture formats trigger a "change" when drawed
1966
Picture.OnChange := nil;
1968
FBitmap.Canvas.StretchDraw(Classes.Rect(0, 0, Size, Size), Picture.Graphic);
1970
Picture.OnChange := OnPictureChanged;
1973
IntfImg1 := TLazIntfImage.Create(0, 0);
1974
IntfImg1.LoadFromBitmap(FBitmap.Handle, FBitmap.MaskHandle);
1976
SetLength(FScanLineCache, 0); // clear the cache
1977
SetLength(FScanLineCache, size);
1982
{$MESSAGE Warn 'CreateMonochromeBitmap: Needs to be implemented'}1986
// FreeMonochromeBitmap
1988
procedure TGLBitmapHDS.FreeMonochromeBitmap;
1990
SetLength(FScanLineCache, 0);
2001
function TGLBitmapHDS.GetScanLine(y: Integer): PByteArray;
2003
Result := FScanLineCache[y];
2004
if not Assigned(Result) then
2006
Result := IntfImg1.GetDataLineStart(y);
2007
FScanLineCache[y] := Result;
2011
// StartPreparingData
2013
procedure TGLBitmapHDS.StartPreparingData(HeightData: TGLHeightData);
2016
bmpSize, wrapMask: Integer;
2017
bitmapLine, rasterLine: PByteArray;
2018
oldType: TGLHeightDataType;
2022
if FBitmap = nil then
2024
HeightData.FDataState := hdsPreparing;
2025
bmpSize := FBitmap.Width;
2026
wrapMask := bmpSize - 1;
2030
if (not InfiniteWrap) and ((XLeft >= bmpSize) or (XLeft < 0) or
2031
(YTop >= bmpSize) or (YTop < 0)) then
2033
HeightData.FDataState := hdsNone;
2036
oldType := DataType;
2041
YPos := 1 - size - YTop;
2042
for y := 0 to size - 1 do
2044
bitmapLine := GetScanLine((y + YPos) and wrapMask);
2046
rasterLine := ByteRaster^[y]
2048
rasterLine := ByteRaster^[size - 1 - y];
2049
// *BIG CAUTION HERE* : Don't remove the intermediate variable here!!!
2050
// or Delphi compiler will "optimize" to 32 bits access with clamping
2051
// Resulting in possible reads of stuff beyon bitmapLine length!!!!
2052
for x := XLeft to XLeft + size - 1 do
2054
b := bitmapLine^[x and wrapMask];
2055
rasterLine^[x - XLeft] := b;
2058
if (oldType <> hdtByte) and (oldType <> hdtDefault) then
2059
DataType := oldType;
2061
TextureCoordinates(HeightData);
2065
function TGLBitmapHDS.Width: Integer;
2067
if Assigned(self.FBitmap) then
2068
Result := self.FBitmap.Width
2073
function TGLBitmapHDS.Height: Integer;
2075
if Assigned(self.FBitmap) then
2076
Result := self.FBitmap.Height
2082
// ------------------
2083
// ------------------ TGLCustomHDS ------------------
2084
// ------------------
2088
constructor TGLCustomHDS.Create(AOwner: TComponent);
2090
inherited Create(AOwner);
2095
destructor TGLCustomHDS.Destroy;
2102
procedure TGLCustomHDS.MarkDirty(const Area: TGLRect);
2105
if Assigned(FOnMarkDirty) then
2109
// StartPreparingData
2111
procedure TGLCustomHDS.StartPreparingData(HeightData: TGLHeightData);
2113
if Assigned(FOnStartPreparingData) then
2114
FOnStartPreparingData(HeightData);
2115
if HeightData.DataState <> hdsNone then
2116
HeightData.DataState := hdsReady;
2119
// ------------------
2120
// ------------------ TGLTerrainBaseHDS ------------------
2121
// ------------------
2125
constructor TGLTerrainBaseHDS.Create(AOwner: TComponent);
2127
inherited Create(AOwner);
2132
destructor TGLTerrainBaseHDS.Destroy;
2137
// StartPreparingData
2139
procedure TGLTerrainBaseHDS.StartPreparingData(HeightData: TGLHeightData);
2141
cTBWidth: Integer = 4320;
2142
cTBHeight: Integer = 2160;
2144
y, x, offset: Integer;
2145
rasterLine: PSmallIntArray;
2146
oldType: TGLHeightDataType;
2150
if not FileExists('tbase.bin') then2152
fs := CreateFileStream('tbase.bin', fmOpenRead + fmShareDenyNone);2157
oldType := DataType;
2158
Allocate(hdtSmallInt);
2159
for y := YTop to YTop + size - 1 do
2161
offset := (y mod cTBHeight) * (cTBWidth * 2);
2162
rasterLine := SmallIntRaster^[y - YTop];
2163
for x := XLeft to XLeft + size - 1 do
2165
fs.Seek(offset + (x mod cTBWidth) * 2, soFromBeginning);
2169
rasterLine^[x - XLeft] := SmallInt(b);
2172
if oldType <> hdtSmallInt then
2173
DataType := oldType;
2182
// ------------------
2183
// ------------------ TGLHeightDataSourceFilter ------------------
2184
// ------------------
2186
constructor TGLHeightDataSourceFilter.Create(AOwner: TComponent);
2188
inherited Create(AOwner);
2194
destructor TGLHeightDataSourceFilter.Destroy;
2196
HeightDataSource := nil;
2200
procedure TGLHeightDataSourceFilter.Release(aHeightData: TGLHeightData);
2202
if Assigned(HeightDataSource) then
2203
HeightDataSource.Release(aHeightData);
2208
procedure TGLHeightDataSourceFilter.Notification(AComponent: TComponent;
2209
Operation: TOperation);
2211
if Operation = opRemove then
2213
if AComponent = FHDS then
2214
HeightDataSource := nil
2219
// SetHDS - Set HeightDataSource property
2221
procedure TGLHeightDataSourceFilter.SetHDS(Val: TGLHeightDataSource);
2224
Val := nil; // prevent self-referencing
2227
if Assigned(FHDS) then
2228
FHDS.RemoveFreeNotification(self);
2230
if Assigned(FHDS) then
2231
FHDS.FreeNotification(self);
2233
self.Clear; // when removing the HDS, also remove all tiles from the cache
2237
function TGLHeightDataSourceFilter.Width: Integer;
2239
if Assigned(FHDS) then
2240
Result := FHDS.Width
2245
function TGLHeightDataSourceFilter.Height: Integer;
2247
if Assigned(FHDS) then
2248
Result := FHDS.Height
2253
procedure TGLHeightDataSourceFilter.StartPreparingData(HeightData: TGLHeightData);
2255
// ---if there is no linked HDS then return an empty tile--
2256
if not Assigned(FHDS) then
2258
HeightData.Owner.Data.LockList;
2259
HeightData.DataState := hdsNone;
2260
HeightData.Owner.Data.UnlockList;
2263
// ---Use linked HeightDataSource to prepare height data--
2264
if HeightData.DataState = hdsQueued then
2266
HeightData.Owner.Data.LockList;
2267
HeightData.DataState := hdsPreparing;
2268
HeightData.Owner.Data.UnlockList;
2270
FHDS.StartPreparingData(HeightData);
2271
if Assigned(FOnSourceDataFetched) then
2272
FOnSourceDataFetched(self, HeightData);
2273
if HeightData.DataState = hdsNone then
2276
PreparingData(HeightData);
2277
inherited; // HeightData.DataState:=hdsReady;
2280
// ------------------------------------------------------------------
2281
// ------------------------------------------------------------------
2282
// ------------------------------------------------------------------
2285
// ------------------------------------------------------------------
2286
// ------------------------------------------------------------------
2287
// ------------------------------------------------------------------
2289
// class registrations
2290
RegisterClasses([TGLBitmapHDS, TGLCustomHDS, TGLHeightDataSourceFilter]);