2
// This unit is part of the GLScene Engine https://github.com/glscene
5
Handles all the color and texture stuff.
16
GLStrings, GLCrossPlatform, GLBaseClasses, OpenGLTokens,
17
GLVectorGeometry, GLGraphics, GLContext, GLState, GLColor, GLCoordinates,
18
GLRenderContextInfo, GLTextureFormat, GLApplicationFileIO, GLUtils;
21
cDefaultNormalMapScale = 0.125;
35
miNearestMipmapNearest,
36
miLinearMipmapNearest,
37
miNearestMipmapLinear,
41
TGLMagFilter = (maNearest, maLinear);
43
TGLTextureMode = (tmDecal, tmModulate, tmBlend, tmReplace, tmAdd);
44
TGLTextureWrap = (twBoth, twNone, twVertical, twHorizontal, twSeparate);
46
// Specifies how depth values should be treated
47
// during filtering and texture application
48
TGLDepthTextureMode = (dtmLuminance, dtmIntensity, dtmAlpha);
50
// Specifies the depth comparison function.
51
TGLDepthCompareFunc = TDepthFunction;
53
{ Texture format for OpenGL (rendering) use.54
Internally, GLScene handles all "base" images as 32 Bits RGBA, but you can
55
specify a generic format to reduce OpenGL texture memory use: }
61
tfRGBA16, // = tfRGBA4
62
tfAlpha, // = tfALPHA8
63
tfLuminance, // = tfLUMINANCE8
64
tfLuminanceAlpha, // = tfLUMINANCE8_ALPHA8
65
tfIntensity, // = tfINTENSITY8
66
tfNormalMap, // = tfRGB8
67
tfRGBAFloat16, // = tfRGBA_FLOAT16_ATI
68
tfRGBAFloat32, // = tfRGBA_FLOAT32_ATI
71
// TGLTextureCompression
73
TGLTextureCompression = TGLInternalCompression;
77
IGLTextureNotifyAble = interface(IGLNotifyAble)
78
['{0D9DC0B0-ECE4-4513-A8A1-5AE7022C9426}']79
procedure NotifyTexMapChange(Sender: TObject);
82
// TTextureNeededEvent
84
TTextureNeededEvent = procedure(Sender: TObject; var textureFileName: string)
87
TGLTextureChange = (tcImage, tcParams);
88
TGLTextureChanges = set of TGLTextureChange;
90
{ Defines how and if Alpha channel is defined for a texture image. 91
tiaDefault : uses the alpha channel in the image if any
92
tiaAlphaFromIntensity : the alpha channel value is deduced from other
93
RGB components intensity (the brighter, the more opaque)
94
tiaSuperBlackTransparent : pixels with a RGB color of (0, 0, 0) are
95
completely transparent, others are completely opaque
96
tiaLuminance : the luminance value is calculated for each pixel
97
and used for RGB and Alpha values
98
tiaLuminanceSqrt : same as tiaLuminance but with an Sqrt(Luminance)
99
tiaOpaque : alpha channel is uniformously set to 1.0
100
tiaTopLeftPointColorTransparent : points of the same color as the
101
top left point of the bitmap are transparent, others are opaque.
104
TGLTextureImageAlpha =
107
tiaAlphaFromIntensity,
108
tiaSuperBlackTransparent,
112
tiaTopLeftPointColorTransparent,
114
tiaInverseLuminanceSqrt,
115
tiaBottomRightPointColorTransparent
120
{ Base class for texture image data.121
Basicly, subclasses are to be considered as different ways of getting
122
a HBitmap (interfacing the actual source).
123
SubClasses should be registered using RegisterGLTextureImageClass to allow
124
proper persistence and editability in the IDE experts. }
125
TGLTextureImage = class(TGLUpdateAbleObject)
127
function GetResourceName: string;
129
FOwnerTexture: TGLTexture;
130
FOnTextureNeeded: TTextureNeededEvent;
131
FResourceFile: string;
132
class function IsSelfLoading: Boolean; virtual;
133
procedure LoadTexture(AInternalFormat: TGLInternalFormat); virtual;
134
function GetTextureTarget: TGLTextureTarget; virtual; abstract;
135
function GetHeight: Integer; virtual; abstract;
136
function GetWidth: Integer; virtual; abstract;
137
function GetDepth: Integer; virtual; abstract;
139
property OnTextureNeeded: TTextureNeededEvent read FOnTextureNeeded write
142
{ Public Properties }143
constructor Create(AOwner: TPersistent); override;
144
destructor Destroy; override;
146
property OwnerTexture: TGLTexture read FOwnerTexture write FOwnerTexture;
147
procedure NotifyChange(Sender: TObject); override;
149
{ Save textureImage to file.150
This may not save a picture, but for instance, parameters, if the
151
textureImage is a procedural texture. }
152
procedure SaveToFile(const fileName: string); dynamic;abstract;
153
{ Load textureImage from a file.154
This may not load a picture, but for instance, parameters, if the
155
textureImage is a procedural texture.
156
Subclasses should invoke inherited which will take care of the
157
"OnTextureNeeded" stuff. }
158
procedure LoadFromFile(const fileName: string); dynamic;
159
{ Returns a user-friendly denomination for the class.160
This denomination is used for picking a texture image class
162
class function FriendlyName: string; virtual;abstract;
163
{ Returns a user-friendly description for the class.164
This denomination is used for helping the user when picking a
165
texture image class in the IDE expert. If it's not overriden,
166
takes its value from FriendlyName. }
167
class function FriendlyDescription: string; virtual;
169
{ Request reload/refresh of data upon next use. }170
procedure Invalidate; dynamic;
172
{ Returns image's bitmap handle.173
If the actual image is not a windows bitmap (BMP), descendants should
174
take care of properly converting to bitmap. }
175
function GetBitmap32: TGLImage; virtual; abstract;
176
{ Request for unloading bitmapData, to free some memory.177
This one is invoked when GLScene no longer needs the Bitmap data
178
it got through a call to GetHBitmap.
179
Subclasses may ignore this call if the HBitmap was obtained at
180
no particular memory cost. }
181
procedure ReleaseBitmap32; virtual;
182
//{ AsBitmap : Returns the TextureImage as a TBitmap }183
function AsBitmap: TGLBitmap;
184
procedure AssignToBitmap(aBitmap: TGLBitmap);
186
property Width: Integer read GetWidth;
187
property Height: Integer read GetHeight;
188
property Depth: Integer read GetDepth;
189
{ Native opengl texture target. }190
property NativeTextureTarget: TGLTextureTarget read GetTextureTarget;
191
property ResourceName: string read GetResourceName;
194
TGLTextureImageClass = class of TGLTextureImage;
198
{ A texture image with no specified content, only a size.199
This texture image type is of use if the context of your texture is
200
calculated at run-time (with a TGLMemoryViewer for instance). }
201
TGLBlankImage = class(TGLTextureImage)
204
procedure SetWidth(val: Integer);
205
procedure SetHeight(val: Integer);
206
procedure SetDepth(val: Integer);
207
procedure SetCubeMap(const val: Boolean);
208
procedure SetArray(const val: Boolean);
213
fWidth, fHeight, fDepth: Integer;
214
{ Store a icolor format, because fBitmap is not always defined}215
fColorFormat: GLenum;
218
{ Flag to interparate depth as layer }221
function GetWidth: Integer; override;
222
function GetHeight: Integer; override;
223
function GetDepth: Integer; override;
224
function GetTextureTarget: TGLTextureTarget; override;
227
constructor Create(AOwner: TPersistent); override;
228
destructor Destroy; override;
230
procedure Assign(Source: TPersistent); override;
232
function GetBitmap32: TGLImage; override;
233
procedure ReleaseBitmap32; override;
235
procedure SaveToFile(const fileName: string); override;
236
procedure LoadFromFile(const fileName: string); override;
237
class function FriendlyName: string; override;
238
class function FriendlyDescription: string; override;
242
{ Width, heigth and depth of the blank image (for memory allocation). }243
property Width: Integer read GetWidth write SetWidth default 256;
244
property Height: Integer read GetHeight write SetHeight default 256;
245
property Depth: Integer read GetDepth write SetDepth default 0;
246
property CubeMap: Boolean read fCubeMap write SetCubeMap default false;
247
property TextureArray: Boolean read fArray write SetArray default false;
248
property ColorFormat: GLenum read fColorFormat write fColorFormat;
253
{ Base class for image data classes internally based on a TPicture. }254
TGLPictureImage = class(TGLTextureImage)
258
FGLPicture: TGLPicture;
259
FUpdateCounter: Integer;
263
function GetHeight: Integer; override;
264
function GetWidth: Integer; override;
265
function GetDepth: Integer; override;
266
function GetTextureTarget: TGLTextureTarget; override;
268
function GetPicture: TGLPicture;
269
procedure SetPicture(const aPicture: TGLPicture);
270
procedure PictureChanged(Sender: TObject);
274
constructor Create(AOwner: TPersistent); override;
275
destructor Destroy; override;
277
procedure Assign(Source: TPersistent); override;
279
{ Use this function if you are going to modify the Picture directly.280
Each invokation MUST be balanced by a call to EndUpdate. }
281
procedure BeginUpdate;
282
{ Ends a direct picture modification session.283
Follows a BeginUpdate. }
285
function GetBitmap32: TGLImage; override;
286
procedure ReleaseBitmap32; override;
288
{ Holds the image content. }289
property Picture: TGLPicture read GetPicture write SetPicture;
292
// TGLPersistentImage
294
{ Stores any image compatible with Delphi's TPicture mechanism.295
The picture's data is actually stored into the DFM, the original
296
picture name or path is not remembered. It is similar in behaviour
298
Note that if original image is for instance JPEG format, only the JPEG
299
data will be stored in the DFM (compact) }
300
TGLPersistentImage = class(TGLPictureImage)
305
constructor Create(AOwner: TPersistent); override;
306
destructor Destroy; override;
308
procedure SaveToFile(const fileName: string); override;
309
procedure LoadFromFile(const fileName: string); override;
310
class function FriendlyName: string; override;
311
class function FriendlyDescription: string; override;
312
property NativeTextureTarget;
320
{ Uses a picture whose data is found in a file (only filename is stored).321
The image is unloaded after upload to OpenGL. }
322
TGLPicFileImage = class(TGLPictureImage)
324
FPictureFileName: string;
325
FAlreadyWarnedAboutMissingFile: Boolean;
330
procedure SetPictureFileName(const val: string);
331
function GetWidth: Integer; override;
332
function GetHeight: Integer; override;
333
function GetDepth: Integer; override;
337
constructor Create(AOwner: TPersistent); override;
338
destructor Destroy; override;
340
procedure Assign(Source: TPersistent); override;
342
// Only picture file name is saved
343
procedure SaveToFile(const fileName: string); override;
344
{ Load picture file name or use fileName as picture filename.345
The autodetection is based on the filelength and presence of zeros. }
346
procedure LoadFromFile(const fileName: string); override;
347
class function FriendlyName: string; override;
348
class function FriendlyDescription: string; override;
349
property NativeTextureTarget;
351
function GetBitmap32: TGLImage; override;
352
procedure Invalidate; override;
355
{ Filename of the picture to use. }356
property PictureFileName: string read FPictureFileName write
363
TGLCubeMapTarget = Integer;
367
{ A texture image used for specifying and stroing a cube map.368
Not unlike TGLPictureImage, but storing 6 of them instead of just one.
369
Saving & loading as a whole currently not supported. }
370
TGLCubeMapImage = class(TGLTextureImage)
374
FUpdateCounter: Integer;
375
FPicture: array[cmtPX..cmtNZ] of TGLPicture;
378
function GetWidth: Integer; override;
379
function GetHeight: Integer; override;
380
function GetDepth: Integer; override;
381
procedure SetPicture(index: TGLCubeMapTarget; const val: TGLPicture);
382
function GetPicture(index: TGLCubeMapTarget): TGLPicture;
383
function GetTextureTarget: TGLTextureTarget; override;
385
procedure PictureChanged(Sender: TObject);
389
constructor Create(AOwner: TPersistent); override;
390
destructor Destroy; override;
392
procedure Assign(Source: TPersistent); override;
394
function GetBitmap32: TGLImage; override;
395
procedure ReleaseBitmap32; override;
397
{ Use this function if you are going to modify the Picture directly.398
Each invokation MUST be balanced by a call to EndUpdate. }
399
procedure BeginUpdate;
402
procedure SaveToFile(const fileName: string); override;
403
procedure LoadFromFile(const fileName: string); override;
404
class function FriendlyName: string; override;
405
class function FriendlyDescription: string; override;
406
property NativeTextureTarget;
408
{ Indexed access to the cube map's sub pictures. }409
property Picture[index: TGLCubeMapTarget]: TGLPicture read GetPicture write
414
property PicturePX: TGLPicture index cmtPX read GetPicture write SetPicture;
415
property PictureNX: TGLPicture index cmtNX read GetPicture write SetPicture;
416
property PicturePY: TGLPicture index cmtPY read GetPicture write SetPicture;
417
property PictureNY: TGLPicture index cmtNY read GetPicture write SetPicture;
418
property PicturePZ: TGLPicture index cmtPZ read GetPicture write SetPicture;
419
property PictureNZ: TGLPicture index cmtNZ read GetPicture write SetPicture;
422
// TGLTextureMappingMode
424
TGLTextureMappingMode = (tmmUser, tmmObjectLinear, tmmEyeLinear, tmmSphere,
425
tmmCubeMapReflection, tmmCubeMapNormal,
426
tmmCubeMapLight0, tmmCubeMapCamera);
430
{ Defines basic texturing properties.431
You can control texture wrapping, smoothing/filtering and of course define
432
the texture map (note that texturing is disabled by default).
433
A built-in mechanism (through ImageAlpha) allows auto-generation of an
434
Alpha channel for all bitmaps (see TGLTextureImageAlpha). }
435
TGLTexture = class(TGLUpdateAbleObject)
438
FTextureHandle: TGLTextureHandle;
439
FSamplerHandle: TGLVirtualHandle;
440
FTextureFormat: TGLInternalFormat;
441
FTextureMode: TGLTextureMode;
442
FTextureWrap: TGLTextureWrap;
443
FMinFilter: TGLMinFilter;
444
FMagFilter: TGLMagFilter;
446
FImage: TGLTextureImage;
447
FImageAlpha: TGLTextureImageAlpha;
448
FImageBrightness: Single;
450
FMappingMode: TGLTextureMappingMode;
451
FMapSCoordinates: TGLCoordinates4;
452
FMapTCoordinates: TGLCoordinates4;
453
FMapRCoordinates: TGLCoordinates4;
454
FMapQCoordinates: TGLCoordinates4;
455
FOnTextureNeeded: TTextureNeededEvent;
456
FCompression: TGLTextureCompression;
457
FRequiredMemorySize: Integer;
458
FFilteringQuality: TGLTextureFilteringQuality;
463
FBorderColor: TGLColor;
464
FNormalMapScale: Single;
465
FTextureWrapS: TGLSeparateTextureWrap;
466
FTextureWrapT: TGLSeparateTextureWrap;
467
FTextureWrapR: TGLSeparateTextureWrap;
468
fTextureCompareMode: TGLTextureCompareMode;
469
fTextureCompareFunc: TGLDepthCompareFunc;
470
fDepthTextureMode: TGLDepthTextureMode;
471
FKeepImageAfterTransfer: Boolean;
474
procedure SetImage(AValue: TGLTextureImage);
475
procedure SetImageAlpha(const val: TGLTextureImageAlpha);
476
procedure SetImageBrightness(const val: Single);
477
function StoreBrightness: Boolean;
478
procedure SetImageGamma(const val: Single);
479
function StoreGamma: Boolean;
480
procedure SetMagFilter(AValue: TGLMagFilter);
481
procedure SetMinFilter(AValue: TGLMinFilter);
482
procedure SetTextureMode(AValue: TGLTextureMode);
483
procedure SetTextureWrap(AValue: TGLTextureWrap);
484
procedure SetTextureWrapS(AValue: TGLSeparateTextureWrap);
485
procedure SetTextureWrapT(AValue: TGLSeparateTextureWrap);
486
procedure SetTextureWrapR(AValue: TGLSeparateTextureWrap);
487
function GetTextureFormat: TGLTextureFormat;
488
procedure SetTextureFormat(const val: TGLTextureFormat);
489
procedure SetTextureFormatEx(const val: TGLInternalFormat);
490
function StoreTextureFormatEx: Boolean;
491
procedure SetCompression(const val: TGLTextureCompression);
492
procedure SetFilteringQuality(const val: TGLTextureFilteringQuality);
493
procedure SetMappingMode(const val: TGLTextureMappingMode);
494
function GetMappingSCoordinates: TGLCoordinates4;
495
procedure SetMappingSCoordinates(const val: TGLCoordinates4);
496
function StoreMappingSCoordinates: Boolean;
497
function GetMappingTCoordinates: TGLCoordinates4;
498
procedure SetMappingTCoordinates(const val: TGLCoordinates4);
499
function StoreMappingTCoordinates: Boolean;
500
function GetMappingRCoordinates: TGLCoordinates4;
501
procedure SetMappingRCoordinates(const val: TGLCoordinates4);
502
function StoreMappingRCoordinates: Boolean;
503
function GetMappingQCoordinates: TGLCoordinates4;
504
procedure SetMappingQCoordinates(const val: TGLCoordinates4);
505
function StoreMappingQCoordinates: Boolean;
506
procedure SetDisabled(AValue: Boolean);
507
procedure SetEnabled(const val: Boolean);
508
function GetEnabled: Boolean;
509
procedure SetEnvColor(const val: TGLColor);
510
procedure SetBorderColor(const val: TGLColor);
511
procedure SetNormalMapScale(const val: Single);
512
procedure SetTextureCompareMode(const val: TGLTextureCompareMode);
513
procedure SetTextureCompareFunc(const val: TGLDepthCompareFunc);
514
procedure SetDepthTextureMode(const val: TGLDepthTextureMode);
515
function StoreNormalMapScale: Boolean;
517
function StoreImageClassName: Boolean;
519
function GetHandle: TGLuint; virtual;
520
// Load texture to OpenGL subsystem
521
procedure PrepareImage(target: TGLUInt); virtual;
522
// Setup OpenGL texture parameters
523
procedure PrepareParams(target: TGLUInt); virtual;
525
procedure DoOnTextureNeeded(Sender: TObject; var textureFileName: string);
526
procedure OnSamplerAllocate(Sender: TGLVirtualHandle; var Handle: Cardinal);
527
procedure OnSamplerDestroy(Sender: TGLVirtualHandle; var Handle: Cardinal);
528
// Shows a special image that indicates an error
529
procedure SetTextureErrorImage;
532
constructor Create(AOwner: TPersistent); override;
533
destructor Destroy; override;
535
property OnTextureNeeded: TTextureNeededEvent read FOnTextureNeeded write
538
procedure PrepareBuildList;
539
procedure ApplyMappingMode;
540
procedure UnApplyMappingMode;
541
procedure Apply(var rci: TGLRenderContextInfo);
542
procedure UnApply(var rci: TGLRenderContextInfo);
543
{ Applies to TEXTURE1 }544
procedure ApplyAsTexture2(var rci: TGLRenderContextInfo; textureMatrix: PMatrix
546
procedure UnApplyAsTexture2(var rci: TGLRenderContextInfo;
547
reloadIdentityTextureMatrix: boolean);
548
{ N=1 for TEXTURE0, N=2 for TEXTURE1, etc. }549
procedure ApplyAsTextureN(n: Integer; var rci: TGLRenderContextInfo;
550
textureMatrix: PMatrix = nil);
551
procedure UnApplyAsTextureN(n: Integer; var rci: TGLRenderContextInfo;
552
reloadIdentityTextureMatrix: boolean);
554
procedure Assign(Source: TPersistent); override;
555
procedure NotifyChange(Sender: TObject); override;
556
procedure NotifyImageChange;
557
procedure NotifyParamsChange;
559
procedure DestroyHandles;
561
procedure SetImageClassName(const val: string);
562
function GetImageClassName: string;
564
{ Returns the OpenGL memory used by the texture.565
The compressed size is returned if, and only if texture compression
566
if active and possible, and the texture has been allocated (Handle
567
is defined), otherwise the estimated size (from TextureFormat
568
specification) is returned. }
569
function TextureImageRequiredMemory: Integer;
570
{ Allocates the texture handle if not already allocated.571
The texture is binded and parameters are setup, but no image data
572
is initialized by this call - for expert use only. }
573
function AllocateHandle: TGLuint;
574
function IsHandleAllocated: Boolean;
575
{ Returns OpenGL texture format corresponding to current options. }576
function OpenGLTextureFormat: Integer;
577
{ Returns if of float data type}578
function IsFloatType: Boolean;
579
{ Is the texture enabled?.580
Always equals to 'not Disabled'. }
581
property Enabled: Boolean read GetEnabled write SetEnabled;
582
{ Handle to the OpenGL texture object.583
If the handle hasn't already been allocated, it will be allocated
584
by this call (ie. do not use if no OpenGL context is active!) }
585
property Handle: TGLuint read GetHandle;
586
property TextureHandle: TGLTextureHandle read FTextureHandle;
588
{ Actual width, height and depth used for last texture589
specification binding. }
590
property TexWidth: Integer read FTexWidth;
591
property TexHeight: Integer read FTexHeight;
592
property TexDepth: Integer read FTexDepth;
593
{ Give texture rendering context }597
{ Image ClassName for enabling True polymorphism.598
This is ugly, but since the default streaming mechanism does a
599
really bad job at storing polymorphic owned-object properties,
600
and neither TFiler nor TPicture allow proper use of the built-in
601
streaming, that's the only way I found to allow a user-extensible
603
property ImageClassName: string read GetImageClassName write
604
SetImageClassName stored StoreImageClassName;
605
{ Image data for the texture. }606
property Image: TGLTextureImage read FImage write SetImage;
608
{ Automatic Image Alpha setting.609
Allows to control how and if the image's Alpha channel (transparency)
611
property ImageAlpha: TGLTextureImageAlpha read FImageAlpha write
612
SetImageAlpha default tiaDefault;
613
{ Texture brightness correction.614
This correction is applied upon loading a TGLTextureImage, it's a
615
simple saturating scaling applied to the RGB components of
616
the 32 bits image, before it is passed to OpenGL, and before
617
gamma correction (if any). }
618
property ImageBrightness: Single read FImageBrightness write
619
SetImageBrightness stored StoreBrightness;
620
{ Texture gamma correction.621
The gamma correction is applied upon loading a TGLTextureImage,
622
applied to the RGB components of the 32 bits image, before it is
623
passed to OpenGL, after brightness correction (if any). }
624
property ImageGamma: Single read FImageGamma write SetImageGamma stored
627
{ Texture magnification filter. }628
property MagFilter: TGLMagFilter read FMagFilter write SetMagFilter default
630
{ Texture minification filter. }631
property MinFilter: TGLMinFilter read FMinFilter write SetMinFilter default
632
miLinearMipMapLinear;
633
{ Texture application mode. }634
property TextureMode: TGLTextureMode read FTextureMode write SetTextureMode
636
{ Wrapping mode for the texture. }637
property TextureWrap: TGLTextureWrap read FTextureWrap write SetTextureWrap
639
{ Wrapping mode for the texture when TextureWrap=twSeparate. }640
property TextureWrapS: TGLSeparateTextureWrap read FTextureWrapS write
641
SetTextureWrapS default twRepeat;
642
property TextureWrapT: TGLSeparateTextureWrap read FTextureWrapT write
643
SetTextureWrapT default twRepeat;
644
property TextureWrapR: TGLSeparateTextureWrap read FTextureWrapR write
645
SetTextureWrapR default twRepeat;
647
{ Texture format for use by the renderer.648
See TGLTextureFormat for details. }
649
property TextureFormat: TGLTextureFormat read GetTextureFormat write
650
SetTextureFormat default tfDefault;
651
property TextureFormatEx: TGLInternalFormat read FTextureFormat write
652
SetTextureFormatEx stored StoreTextureFormatEx;
654
{ Texture compression control.655
If True the compressed TextureFormat variant (the OpenGL ICD must
656
support GL_ARB_texture_compression, or this option is ignored). }
657
property Compression: TGLTextureCompression read FCompression write
658
SetCompression default tcDefault;
659
{ Specifies texture filtering quality.660
You can choose between bilinear and trilinear filetring (anisotropic).
661
The OpenGL ICD must support GL_EXT_texture_filter_anisotropic or
662
this property is ignored. }
663
property FilteringQuality: TGLTextureFilteringQuality read FFilteringQuality
664
write SetFilteringQuality default tfIsotropic;
666
{ Texture coordinates mapping mode.667
This property controls automatic texture coordinates generation. }
668
property MappingMode: TGLTextureMappingMode read FMappingMode write
669
SetMappingMode default tmmUser;
670
{ Texture mapping coordinates mode for S, T, R and Q axis.671
This property stores the coordinates for automatic texture
672
coordinates generation. }
673
property MappingSCoordinates: TGLCoordinates4 read GetMappingSCoordinates
674
write SetMappingSCoordinates stored StoreMappingSCoordinates;
675
property MappingTCoordinates: TGLCoordinates4 read GetMappingTCoordinates
676
write SetMappingTCoordinates stored StoreMappingTCoordinates;
677
property MappingRCoordinates: TGLCoordinates4 read GetMappingRCoordinates
678
write SetMappingRCoordinates stored StoreMappingRCoordinates;
679
property MappingQCoordinates: TGLCoordinates4 read GetMappingQCoordinates
680
write SetMappingQCoordinates stored StoreMappingQCoordinates;
682
{ Texture Environment color. }683
property EnvColor: TGLColor read FEnvColor write SetEnvColor;
684
{ Texture Border color. }685
property BorderColor: TGLColor read FBorderColor write SetBorderColor;
686
{ If true, the texture is disabled (not used). }687
property Disabled: Boolean read FDisabled write SetDisabled default True;
689
{ Normal Map scaling.690
Only applies when TextureFormat is tfNormalMap, this property defines
691
the scaling that is applied during normal map generation (ie. controls
692
the intensity of the bumps). }
693
property NormalMapScale: Single read FNormalMapScale write SetNormalMapScale
694
stored StoreNormalMapScale;
696
property TextureCompareMode: TGLTextureCompareMode read fTextureCompareMode
697
write SetTextureCompareMode default tcmNone;
698
property TextureCompareFunc: TGLDepthCompareFunc read fTextureCompareFunc
699
write SetTextureCompareFunc default cfLequal;
700
property DepthTextureMode: TGLDepthTextureMode read fDepthTextureMode write
701
SetDepthTextureMode default dtmLuminance;
703
{ Disable image release after transfering it to VGA. }704
property KeepImageAfterTransfer: Boolean read FKeepImageAfterTransfer
705
write FKeepImageAfterTransfer default False;
710
TGLTextureExItem = class(TCollectionItem, IGLTextureNotifyAble)
712
{ Private Decalarations }713
FTexture: TGLTexture;
714
FTextureIndex: Integer;
715
FTextureOffset, FTextureScale: TGLCoordinates;
716
FTextureMatrixIsIdentity: Boolean;
717
FTextureMatrix: TMatrix;
720
//implementing IInterface
723
function QueryInterface(constref IID: TGUID; out Obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};724
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};725
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};728
{ Protected Decalarations }729
function GetDisplayName: string; override;
730
function GetOwner: TPersistent; override;
731
procedure SetTexture(const Value: TGLTexture);
732
procedure SetTextureIndex(const Value: Integer);
733
procedure SetTextureOffset(const Value: TGLCoordinates);
734
procedure SetTextureScale(const Value: TGLCoordinates);
735
procedure NotifyTexMapChange(Sender: TObject);
737
procedure CalculateTextureMatrix;
739
procedure OnNotifyChange(Sender: TObject);
742
{ Public Decalarations }743
constructor Create(ACollection: TCollection); override;
744
destructor Destroy; override;
746
procedure Assign(Source: TPersistent); override;
747
procedure NotifyChange(Sender: TObject);
749
procedure Apply(var rci: TGLRenderContextInfo);
750
procedure UnApply(var rci: TGLRenderContextInfo);
753
{ Published Decalarations }754
property Texture: TGLTexture read FTexture write SetTexture;
755
property TextureIndex: Integer read FTextureIndex write SetTextureIndex;
756
property TextureOffset: TGLCoordinates read FTextureOffset write
758
property TextureScale: TGLCoordinates read FTextureScale write
765
TGLTextureEx = class(TCollection)
767
FOwner: TGLUpdateAbleObject;
770
{ Protected Decalarations }771
procedure SetItems(index: Integer; const Value: TGLTextureExItem);
772
function GetItems(index: Integer): TGLTextureExItem;
773
function GetOwner: TPersistent; override;
775
{ Public Decalarations }776
constructor Create(AOwner: TGLUpdateAbleObject);
778
procedure NotifyChange(Sender: TObject);
779
procedure Apply(var rci: TGLRenderContextInfo);
780
procedure UnApply(var rci: TGLRenderContextInfo);
781
function IsTextureEnabled(Index: Integer): Boolean;
783
function Add: TGLTextureExItem;
785
property Items[index: Integer]: TGLTextureExItem read GetItems write
790
ETexture = class(Exception);
791
EGLShaderException = class(Exception);
793
// Register a TGLTextureImageClass (used for persistence and IDE purposes)
794
procedure RegisterGLTextureImageClass(textureImageClass: TGLTextureImageClass);
795
// Finds a registerer TGLTextureImageClass using its classname
796
function FindGLTextureImageClass(const className: string): TGLTextureImageClass;
797
// Finds a registerer TGLTextureImageClass using its FriendlyName
798
function FindGLTextureImageClassByFriendlyName(const friendlyName: string):
799
TGLTextureImageClass;
800
// Defines a TStrings with the list of registered TGLTextureImageClass.
801
procedure SetGLTextureImageClassesToStrings(aStrings: TStrings);
802
{ Creates a TStrings with the list of registered TGLTextureImageClass.803
To be freed by caller. }
804
function GetGLTextureImageClassesAsStrings: TStrings;
806
procedure RegisterTGraphicClassFileExtension(const extension: string;
807
const aClass: TGraphicClass);
808
function CreateGraphicFromFile(const fileName: string): TGLGraphic;
810
//------------------------------------------------------------------------------
811
//------------------------------------------------------------------------------
812
//------------------------------------------------------------------------------
814
//------------------------------------------------------------------------------
815
//------------------------------------------------------------------------------
816
//------------------------------------------------------------------------------
818
// TODO: remove dependancy on GLScene.pas unit (related to tmmCubeMapLight0)
823
PictureRegisteredFormats
827
cTextureMode: array[tmDecal..tmAdd] of TGLEnum =
828
(GL_DECAL, GL_MODULATE, GL_BLEND, GL_REPLACE, GL_ADD);
830
cOldTextureFormatToInternalFormat: array[tfRGB..tfRGBAFloat32] of
831
TGLInternalFormat = (
845
vGLTextureImageClasses: TList;
846
vTGraphicFileExtension: array of string;
847
vTGraphicClass: array of TGraphicClass;
850
TFriendlyImage = class(TGLBaseImage);
854
{%region%===== 'Helper functions ================================}856
// RegisterTGraphicClassFileExtension
859
procedure RegisterTGraphicClassFileExtension(const extension: string;
860
const aClass: TGraphicClass);
864
n := Length(vTGraphicFileExtension);
865
SetLength(vTGraphicFileExtension, n + 1);
866
SetLength(vTGraphicClass, n + 1);
867
vTGraphicFileExtension[n] := LowerCase(extension);
868
vTGraphicClass[n] := aClass;
871
// CreateGraphicFromFile
874
function CreateGraphicFromFile(const fileName: string): TGLGraphic;
879
graphicClass: TGraphicClass;
882
if FileStreamExists(fileName) then
885
ext := LowerCase(ExtractFileExt(fileName));
886
for i := 0 to High(vTGraphicFileExtension) do
888
if vTGraphicFileExtension[i] = ext then
890
graphicClass := TGraphicClass(vTGraphicClass[i]);
894
if graphicClass = nil then
895
graphicClass := GraphicClassForExtension(ext);
896
if graphicClass <> nil then
898
Result := graphicClass.Create;
900
fs := CreateFileStream(fileName, fmOpenRead);
902
Result.LoadFromStream(fs);
914
// RegisterGLTextureImageClass
917
procedure RegisterGLTextureImageClass(textureImageClass: TGLTextureImageClass);
919
if not Assigned(vGLTextureImageClasses) then
920
vGLTextureImageClasses := TList.Create;
921
vGLTextureImageClasses.Add(textureImageClass);
924
// FindGLTextureImageClass
927
function FindGLTextureImageClass(const className: string): TGLTextureImageClass;
930
tic: TGLTextureImageClass;
933
if Assigned(vGLTextureImageClasses) then
934
for i := 0 to vGLTextureImageClasses.Count - 1 do
936
tic := TGLTextureImageClass(vGLTextureImageClasses[i]);
937
if tic.ClassName = className then
946
// FindGLTextureImageClassByFriendlyName
949
function FindGLTextureImageClassByFriendlyName(const friendlyName: string):
950
TGLTextureImageClass;
953
tic: TGLTextureImageClass;
956
if Assigned(vGLTextureImageClasses) then
957
for i := 0 to vGLTextureImageClasses.Count - 1 do
959
tic := TGLTextureImageClass(vGLTextureImageClasses[i]);
960
if tic.FriendlyName = friendlyName then
968
// SetGLTextureImageClassesToStrings
971
procedure SetGLTextureImageClassesToStrings(aStrings: TStrings);
974
tic: TGLTextureImageClass;
980
if Assigned(vGLTextureImageClasses) then
981
for i := 0 to vGLTextureImageClasses.Count - 1 do
983
tic := TGLTextureImageClass(vGLTextureImageClasses[i]);
984
AddObject(tic.FriendlyName, TObject(Pointer(tic)));
990
// GetGLTextureImageClassesAsStrings
993
function GetGLTextureImageClassesAsStrings: TStrings;
995
Result := TStringList.Create;
996
SetGLTextureImageClassesToStrings(Result);
1001
{%region%===== 'TGLTextureImage ================================}1006
constructor TGLTextureImage.Create(AOwner: TPersistent);
1009
FOwnerTexture := (AOwner as TGLTexture);
1015
destructor TGLTextureImage.Destroy;
1020
// FriendlyDescription
1023
class function TGLTextureImage.FriendlyDescription: string;
1025
Result := FriendlyName;
1028
procedure TGLTextureImage.Invalidate;
1037
procedure TGLTextureImage.ReleaseBitmap32;
1042
// AsBitmap : Returns the TextureImage as a TBitmap
1043
// WARNING: This Creates a new bitmap. Remember to free it, to prevent leaks.
1044
// If possible, rather use AssignToBitmap.
1047
function TGLTextureImage.AsBitmap: TGLBitmap;
1049
result := self.GetBitmap32.Create32BitsBitmap;
1055
procedure TGLTextureImage.AssignToBitmap(aBitmap: TGLBitmap);
1057
Self.GetBitmap32.AssignToBitmap(aBitmap);
1063
procedure TGLTextureImage.NotifyChange(Sender: TObject);
1065
if Assigned(FOwnerTexture) then
1067
FOwnerTexture.FTextureHandle.NotifyChangesOfData;
1068
FOwnerTexture.FSamplerHandle.NotifyChangesOfData;
1069
// Check for texture target change
1071
FOwnerTexture.NotifyChange(Self);
1078
procedure TGLTextureImage.LoadFromFile(const fileName: string);
1082
if Assigned(FOnTextureNeeded) then
1085
FOnTextureNeeded(Self, buf);
1092
function TGLTextureImage.GetResourceName: string;
1094
Result := FResourceFile;
1097
class function TGLTextureImage.IsSelfLoading: Boolean;
1102
procedure TGLTextureImage.LoadTexture(AInternalFormat: TGLInternalFormat);
1108
{%region%===== 'TGLBlankImage ================================}1111
constructor TGLBlankImage.Create(AOwner: TPersistent);
1117
fColorFormat := GL_RGBA;
1120
destructor TGLBlankImage.Destroy;
1126
procedure TGLBlankImage.Assign(Source: TPersistent);
1130
if Assigned(Source) then
1132
if (Source is TGLBlankImage) then
1134
img := Source as TGLBlankImage;
1135
FWidth := img.Width;
1136
FHeight := img.Height;
1137
FDepth := img.Depth;
1138
FCubeMap := img.fCubeMap;
1139
FArray := img.fArray;
1140
fColorFormat := img.ColorFormat;
1141
FResourceFile := img.ResourceName;
1145
GetBitmap32.Assign(Source);
1152
procedure TGLBlankImage.SetWidth(val: Integer);
1154
if val <> FWidth then
1163
function TGLBlankImage.GetWidth: Integer;
1168
procedure TGLBlankImage.SetHeight(val: Integer);
1170
if val <> FHeight then
1179
function TGLBlankImage.GetHeight: Integer;
1184
procedure TGLBlankImage.SetDepth(val: Integer);
1186
if val <> FDepth then
1195
function TGLBlankImage.GetDepth: Integer;
1200
procedure TGLBlankImage.SetCubeMap(const val: Boolean);
1202
if val <> fCubeMap then
1209
procedure TGLBlankImage.SetArray(const val: Boolean);
1211
if val <> fArray then
1218
function TGLBlankImage.GetBitmap32: TGLImage;
1220
if not Assigned(FBitmap) then
1222
fBitmap := TGLImage.Create;
1223
fBitmap.Width := FWidth;
1224
fBitmap.Height := FHeight;
1225
fBitmap.Depth := FDepth;
1226
fBitmap.CubeMap := FCubeMap;
1227
fBitmap.TextureArray := FArray;
1228
fBitmap.SetColorFormatDataType(FColorFormat, GL_UNSIGNED_BYTE);
1233
procedure TGLBlankImage.ReleaseBitmap32;
1235
if Assigned(FBitmap) then
1242
procedure TGLBlankImage.SaveToFile(const fileName: string);
1244
SaveAnsiStringToFile(fileName, AnsiString(
1245
'[BlankImage]'#13#10'Width=' + IntToStr(Width) +
1246
#13#10'Height=' + IntToStr(Height) +
1247
#13#10'Depth=' + IntToStr(Depth)));
1250
procedure TGLBlankImage.LoadFromFile(const fileName: string);
1256
if Assigned(FOnTextureNeeded) then
1257
FOnTextureNeeded(Self, buf);
1258
if FileExists(buf) then
1260
sl := TStringList.Create;
1262
sl.LoadFromFile(buf{$IFDEF GLS_DELPHI_2009_UP}, TEncoding.ASCII{$ENDIF});1263
FWidth := StrToInt(sl.Values['Width']);
1264
FHeight := StrToInt(sl.Values['Height']);
1265
temp := sl.Values['Depth'];
1266
if Length(temp) > 0 then
1267
FDepth := StrToInt(temp)
1276
Assert(False, Format(glsFailedOpenFile, [fileName]));
1280
class function TGLBlankImage.FriendlyName: string;
1282
Result := 'Blank Image';
1285
class function TGLBlankImage.FriendlyDescription: string;
1287
Result := 'Blank Image (Width x Height x Depth)';
1290
function TGLBlankImage.GetTextureTarget: TGLTextureTarget;
1292
Result := ttTexture2D;
1293
// Choose a texture target
1294
if Assigned(fBitmap) then
1296
FWidth := fBitmap.Width;
1297
FHeight := fBitmap.Height;
1298
FDepth := fBitmap.Depth;
1299
FCubeMap := fBitmap.CubeMap;
1300
FArray := fBitmap.TextureArray;
1304
Result := ttTexture1D;
1306
Result := ttTextureCube;
1308
Result := ttTexture3D;
1312
Result := ttTexture1DArray
1314
Result := ttTexture2DArray;
1316
Result := ttTextureCubeArray;
1319
if Assigned(FOwnerTexture) then
1321
if ((FOwnerTexture.FTextureFormat >= tfFLOAT_R16)
1322
and (FOwnerTexture.FTextureFormat <= tfFLOAT_RGBA32)) then
1323
Result := ttTextureRect;
1329
{%region%===== 'TGLPictureImage ================================}1334
constructor TGLPictureImage.Create(AOwner: TPersistent);
1342
destructor TGLPictureImage.Destroy;
1352
procedure TGLPictureImage.Assign(Source: TPersistent);
1356
if Assigned(Source) then
1358
if (Source is TGLPersistentImage) then
1359
Picture.Assign(TGLPersistentImage(Source).Picture)
1360
else if (Source is TGLGraphic) then
1361
Picture.Assign(Source)
1362
else if (Source is TGLPicture) then
1363
Picture.Assign(Source)
1364
else if (Source is TGLImage) then
1366
bmp := TGLImage(Source).Create32BitsBitmap;
1367
Picture.Graphic := bmp;
1369
FResourceFile := TGLImage(Source).ResourceName;
1381
procedure TGLPictureImage.BeginUpdate;
1383
Inc(FUpdateCounter);
1384
Picture.OnChange := nil;
1390
procedure TGLPictureImage.EndUpdate;
1392
Assert(FUpdateCounter > 0, ClassName + ': Unbalanced Begin/EndUpdate');
1393
Dec(FUpdateCounter);
1394
Picture.OnChange := PictureChanged;
1395
if FUpdateCounter = 0 then
1396
PictureChanged(Picture);
1402
function TGLPictureImage.GetHeight: Integer;
1404
Result := Picture.Height;
1410
function TGLPictureImage.GetWidth: Integer;
1412
Result := Picture.Width;
1418
function TGLPictureImage.GetDepth: Integer;
1426
function TGLPictureImage.GetBitmap32: TGLImage;
1428
if not Assigned(FBitmap) then
1430
FBitmap := TGLImage.Create;
1431
// we need to deactivate OnChange, due to a "glitch" in some TGraphics,
1432
// for instance, TJPegImage triggers an OnChange when it is drawn...
1433
if Assigned(Picture.Graphic) then
1435
if Assigned(Picture.OnChange) then
1437
Picture.OnChange := nil;
1439
FBitmap.Assign(Picture.Graphic);
1441
Picture.OnChange := PictureChanged;
1445
FBitmap.Assign(Picture.Graphic);
1448
FBitmap.SetErrorImage;
1456
procedure TGLPictureImage.ReleaseBitmap32;
1458
if Assigned(FBitmap) then
1468
procedure TGLPictureImage.PictureChanged(Sender: TObject);
1476
function TGLPictureImage.GetPicture: TGLPicture;
1478
if not Assigned(FGLPicture) then
1480
FGLPicture := TGLPicture.Create;
1481
FGLPicture.OnChange := PictureChanged;
1483
Result := FGLPicture;
1489
procedure TGLPictureImage.SetPicture(const aPicture: TGLPicture);
1491
Picture.Assign(aPicture);
1497
function TGLPictureImage.GetTextureTarget: TGLTextureTarget;
1499
Result := ttTexture2D;
1504
{%region%===== 'TGLPersistentImage ================================}1509
constructor TGLPersistentImage.Create(AOwner: TPersistent);
1517
destructor TGLPersistentImage.Destroy;
1525
procedure TGLPersistentImage.SaveToFile(const fileName: string);
1527
Picture.SaveToFile(fileName);
1528
FResourceFile := fileName;
1534
procedure TGLPersistentImage.LoadFromFile(const fileName: string);
1540
FResourceFile := fileName;
1541
if Assigned(FOnTextureNeeded) then
1542
FOnTextureNeeded(Self, buf);
1543
if ApplicationFileIODefined then
1545
gr := CreateGraphicFromFile(buf);
1546
if Assigned(gr) then
1548
Picture.Graphic := gr;
1553
else if FileExists(buf) then
1555
Picture.LoadFromFile(buf);
1558
Picture.Graphic := nil;
1559
raise ETexture.CreateFmt(glsFailedOpenFile, [fileName]);
1565
class function TGLPersistentImage.FriendlyName: string;
1567
Result := 'Persistent Image';
1570
// FriendlyDescription
1573
class function TGLPersistentImage.FriendlyDescription: string;
1575
Result := 'Image data is stored in its original format with other form resources,'
1576
+ 'ie. in the DFM at design-time, and embedded in the EXE at run-time.';
1582
{%region%===== 'TGLPicFileImage ================================}1587
constructor TGLPicFileImage.Create(AOwner: TPersistent);
1595
destructor TGLPicFileImage.Destroy;
1603
procedure TGLPicFileImage.Assign(Source: TPersistent);
1605
if Source is TGLPicFileImage then
1607
FPictureFileName := TGLPicFileImage(Source).FPictureFileName;
1608
FResourceFile := TGLPicFileImage(Source).ResourceName;
1614
// SetPictureFileName
1617
procedure TGLPicFileImage.SetPictureFileName(const val: string);
1619
if val <> FPictureFileName then
1621
FPictureFileName := val;
1622
FResourceFile := val;
1623
FAlreadyWarnedAboutMissingFile := False;
1628
procedure TGLPicFileImage.Invalidate;
1630
Picture.OnChange := nil;
1632
Picture.Assign(nil);
1635
Picture.OnChange := PictureChanged;
1640
function TGLPicFileImage.GetHeight: Integer;
1648
function TGLPicFileImage.GetWidth: Integer;
1653
function TGLPicFileImage.GetDepth: Integer;
1658
function TGLPicFileImage.GetBitmap32: TGLImage;
1663
if (GetWidth <= 0) and (PictureFileName <> '') then
1665
Picture.OnChange := nil;
1667
buf := PictureFileName;
1669
if Assigned(FOnTextureNeeded) then
1670
FOnTextureNeeded(Self, buf);
1671
if FileStreamExists(buf) then
1673
gr := CreateGraphicFromFile(buf);
1674
Picture.Graphic := gr;
1679
Picture.Graphic := nil;
1680
if not FAlreadyWarnedAboutMissingFile then
1682
FAlreadyWarnedAboutMissingFile := True;
1683
GLOKMessageBox(Format(glsFailedOpenFileFromCurrentDir, [PictureFileName, GetCurrentDir]),glsError);
1686
Result := inherited GetBitmap32;
1687
FWidth := Result.Width;
1688
FHeight := Result.Height;
1689
Picture.Graphic := nil;
1691
Picture.OnChange := PictureChanged;
1695
Result := inherited GetBitmap32;
1701
procedure TGLPicFileImage.SaveToFile(const fileName: string);
1703
FResourceFile := fileName;
1704
SaveAnsiStringToFile(fileName, AnsiString(PictureFileName));
1710
procedure TGLPicFileImage.LoadFromFile(const fileName: string);
1715
// attempt to autodetect if we are pointed to a file containing
1716
// a filename or directly to an image
1717
if SizeOfFile(fileName) < 512 then
1719
buf := string(LoadAnsiStringFromFile(fileName));
1720
if Pos(#0, buf) > 0 then
1721
PictureFileName := fileName
1723
PictureFileName := buf;
1726
PictureFileName := fileName;
1727
FResourceFile := FPictureFileName;
1733
class function TGLPicFileImage.FriendlyName: string;
1735
Result := 'PicFile Image';
1738
// FriendlyDescription
1741
class function TGLPicFileImage.FriendlyDescription: string;
1743
Result := 'Image data is retrieved from a file.';
1748
{%region%===== 'TGLCubeMapImage ================================}1753
constructor TGLCubeMapImage.Create(AOwner: TPersistent);
1755
i: TGLCubeMapTarget;
1758
for i := Low(FPicture) to High(FPicture) do
1760
FPicture[i] := TGLPicture.Create;
1761
FPicture[i].OnChange := PictureChanged;
1768
destructor TGLCubeMapImage.Destroy;
1770
i: TGLCubeMapTarget;
1773
for i := Low(FPicture) to High(FPicture) do
1781
procedure TGLCubeMapImage.Assign(Source: TPersistent);
1783
i: TGLCubeMapTarget;
1785
if Assigned(Source) then
1787
if (Source is TGLCubeMapImage) then
1789
for i := Low(FPicture) to High(FPicture) do
1790
FPicture[i].Assign(TGLCubeMapImage(Source).FPicture[i]);
1803
function TGLCubeMapImage.GetWidth: Integer;
1805
Result := FPicture[cmtPX].Width;
1811
function TGLCubeMapImage.GetHeight: Integer;
1813
Result := FPicture[cmtPX].Height;
1819
function TGLCubeMapImage.GetDepth: Integer;
1827
function TGLCubeMapImage.GetBitmap32: TGLImage;
1832
if Assigned(FImage) then
1834
LImage := TGLImage.Create;
1835
LImage.VerticalReverseOnAssignFromBitmap := True;
1840
FPicture[TGLCubeMapTarget(I)].OnChange := nil;
1842
LImage.Assign(FPicture[TGLCubeMapTarget(I)].Graphic);
1843
if not Assigned(FImage) then
1845
FImage := TGLImage.Create;
1846
FImage.Blank := True;
1847
FImage.Width := LImage.Width;
1848
FImage.Height := LImage.Height;
1849
FImage.SetColorFormatDataType(LImage.ColorFormat, LImage.DataType);
1850
FImage.CubeMap := True;
1851
FImage.Blank := False;
1853
Move(LImage.Data^, TFriendlyImage(FImage).GetLevelAddress(0, I)^, LImage.LevelSizeInByte[0]);
1855
FPicture[TGLCubeMapTarget(I)].OnChange := PictureChanged;
1867
procedure TGLCubeMapImage.ReleaseBitmap32;
1869
if Assigned(FImage) then
1879
procedure TGLCubeMapImage.BeginUpdate;
1881
i: TGLCubeMapTarget;
1883
Inc(FUpdateCounter);
1884
for i := Low(FPicture) to High(FPicture) do
1885
FPicture[i].OnChange := nil;
1891
procedure TGLCubeMapImage.EndUpdate;
1893
i: TGLCubeMapTarget;
1895
Assert(FUpdateCounter > 0, ClassName + ': Unbalanced Begin/EndUpdate');
1896
Dec(FUpdateCounter);
1897
for i := Low(FPicture) to High(FPicture) do
1898
FPicture[i].OnChange := PictureChanged;
1899
if FUpdateCounter = 0 then
1900
PictureChanged(FPicture[cmtPX]);
1906
procedure TGLCubeMapImage.SaveToFile(const fileName: string);
1910
i: TGLCubeMapTarget;
1913
fs := TFileStream.Create(fileName, fmCreate);
1914
bmp := TGLBitmap.Create;
1917
fs.Write(version, 2);
1918
for i := Low(FPicture) to High(FPicture) do
1920
bmp.Assign(FPicture[i].Graphic);
1921
bmp.SaveToStream(fs);
1932
procedure TGLCubeMapImage.LoadFromFile(const fileName: string);
1936
i: TGLCubeMapTarget;
1939
fs := TFileStream.Create(fileName, fmOpenRead + fmShareDenyWrite);
1940
bmp := TGLBitmap.Create;
1942
fs.Read(version, 2);
1943
Assert(version = $0100);
1944
for i := Low(FPicture) to High(FPicture) do
1946
bmp.LoadFromStream(fs);
1947
FPicture[i].Graphic := bmp;
1958
class function TGLCubeMapImage.FriendlyName: string;
1960
Result := 'CubeMap Image';
1963
// FriendlyDescription
1966
class function TGLCubeMapImage.FriendlyDescription: string;
1968
Result := 'Image data is contain 6 pictures of cubemap faces.';
1974
procedure TGLCubeMapImage.PictureChanged(Sender: TObject);
1982
function TGLCubeMapImage.GetTextureTarget: TGLTextureTarget;
1984
Result := ttTextureCube;
1990
procedure TGLCubeMapImage.SetPicture(index: TGLCubeMapTarget; const val:
1993
FPicture[index].Assign(val);
1996
function TGLCubeMapImage.GetPicture(index: TGLCubeMapTarget): TGLPicture;
1998
Result := FPicture[index];
2004
{%region%===== 'TGLTexture ================================}2007
constructor TGLTexture.Create(AOwner: TPersistent);
2011
FImage := TGLPersistentImage.Create(Self);
2012
FImage.OnTextureNeeded := DoOnTextureNeeded;
2013
FImageAlpha := tiaDefault;
2014
FImageBrightness := 1.0;
2016
FMagFilter := maLinear;
2017
FMinFilter := miLinearMipMapLinear;
2018
FFilteringQuality := tfIsotropic;
2019
FRequiredMemorySize := -1;
2020
FTextureHandle := TGLTextureHandle.Create;
2021
FSamplerHandle := TGLVirtualHandle.Create;
2022
FSamplerHandle.OnAllocate := OnSamplerAllocate;
2023
FSamplerHandle.OnDestroy := OnSamplerDestroy;
2024
FMappingMode := tmmUser;
2025
FEnvColor := TGLColor.CreateInitialized(Self, clrTransparent);
2026
FBorderColor := TGLColor.CreateInitialized(Self, clrTransparent);
2027
FNormalMapScale := cDefaultNormalMapScale;
2028
FTextureCompareMode := tcmNone;
2029
FTextureCompareFunc := cfLequal;
2030
FDepthTextureMode := dtmLuminance;
2031
TextureFormat := tfDefault;
2032
FCompression := tcDefault;
2033
FKeepImageAfterTransfer := False;
2036
destructor TGLTexture.Destroy;
2040
FMapSCoordinates.Free;
2041
FMapTCoordinates.Free;
2042
FMapRCoordinates.Free;
2043
FMapQCoordinates.Free;
2045
FTextureHandle.Free;
2046
FSamplerHandle.Free;
2051
procedure TGLTexture.Assign(Source: TPersistent);
2053
if Assigned(Source) then
2055
if (Source is TGLTexture) then
2057
if Source <> Self then
2059
FImageAlpha := TGLTexture(Source).FImageAlpha;
2060
FTextureMode := TGLTexture(Source).FTextureMode;
2061
FTextureWrap := TGLTexture(Source).FTextureWrap;
2062
FTextureFormat := TGLTexture(Source).FTextureFormat;
2063
FCompression := TGLTexture(Source).FCompression;
2064
FMinFilter := TGLTexture(Source).FMinFilter;
2065
FMagFilter := TGLTexture(Source).FMagFilter;
2066
FMappingMode := TGLTexture(Source).FMappingMode;
2067
MappingSCoordinates.Assign(TGLTexture(Source).MappingSCoordinates);
2068
MappingTCoordinates.Assign(TGLTexture(Source).MappingTCoordinates);
2069
MappingRCoordinates.Assign(TGLTexture(Source).MappingRCoordinates);
2070
MappingQCoordinates.Assign(TGLTexture(Source).MappingQCoordinates);
2071
FDisabled := TGLTexture(Source).FDisabled;
2072
SetImage(TGLTexture(Source).FImage);
2073
FImageBrightness := TGLTexture(Source).FImageBrightness;
2074
FImageGamma := TGLTexture(Source).FImageGamma;
2075
FFilteringQuality := TGLTexture(Source).FFilteringQuality;
2076
FEnvColor.Assign(TGLTexture(Source).FEnvColor);
2077
FBorderColor.Assign(TGLTexture(Source).FBorderColor);
2078
FNormalMapScale := TGLTexture(Source).FNormalMapScale;
2079
// Probably don't need to assign these....
2080
// FOnTextureNeeded := TGLTexture(Source).FImageGamma;
2081
// FRequiredMemorySize : Integer;
2082
// FTexWidth, FTexHeight : Integer;
2083
FTextureHandle.NotifyChangesOfData;
2084
FSamplerHandle.NotifyChangesOfData;
2087
else if (Source is TGLGraphic) then
2088
Image.Assign(Source)
2089
else if (Source is TGLPicture) then
2090
Image.Assign(TGLPicture(Source).Graphic)
2092
inherited Assign(Source);
2098
FTextureHandle.NotifyChangesOfData;
2099
FSamplerHandle.NotifyChangesOfData;
2103
procedure TGLTexture.NotifyChange(Sender: TObject);
2105
if Assigned(Owner) then
2107
if Owner is TGLTextureExItem then
2108
TGLTextureExItem(Owner).NotifyChange(Self);
2110
if Sender is TGLTextureImage then
2111
FTextureHandle.NotifyChangesOfData;
2116
procedure TGLTexture.NotifyImageChange;
2118
FTextureHandle.NotifyChangesOfData;
2122
procedure TGLTexture.NotifyParamsChange;
2124
FSamplerHandle.NotifyChangesOfData;
2128
procedure TGLTexture.SetImage(AValue: TGLTextureImage);
2130
if Assigned(aValue) then
2132
if FImage.ClassType <> AValue.ClassType then
2135
FImage := TGLTextureImageClass(AValue.ClassType).Create(Self);
2136
FImage.OnTextureNeeded := DoOnTextureNeeded;
2138
FImage.Assign(AValue);
2143
FImage := TGLPersistentImage.Create(Self);
2144
FImage.OnTextureNeeded := DoOnTextureNeeded;
2148
procedure TGLTexture.SetImageClassName(const val: string);
2150
newImage: TGLTextureImage;
2151
newImageClass: TGLTextureImageClass;
2154
if FImage.ClassName <> val then
2156
newImageClass := FindGLTextureImageClass(val);
2157
Assert(newImageClass <> nil, 'Make sure you include the unit for ' + val +
2158
' in your uses clause');
2159
if newImageClass = nil then
2161
newImage := newImageClass.Create(Self);
2162
newImage.OnTextureNeeded := DoOnTextureNeeded;
2168
function TGLTexture.GetImageClassName: string;
2170
Result := FImage.ClassName;
2173
function TGLTexture.TextureImageRequiredMemory: Integer;
2175
w, h, e, levelSize: Integer;
2177
if FRequiredMemorySize < 0 then
2179
if IsCompressedFormat(fTextureFormat) then
2181
w := (Image.Width + 3) div 4;
2182
h := (Image.Height + 3) div 4;
2190
e := GetTextureElementSize(fTextureFormat);
2191
FRequiredMemorySize := w * h * e;
2192
if Image.Depth > 0 then
2193
FRequiredMemorySize := FRequiredMemorySize * Image.Depth;
2195
if not (MinFilter in [miNearest, miLinear]) then
2197
levelSize := FRequiredMemorySize;
2198
while e < levelSize do
2200
levelSize := levelSize div 4;
2201
FRequiredMemorySize := FRequiredMemorySize + levelSize;
2205
if Image.NativeTextureTarget = ttTextureCube then
2206
FRequiredMemorySize := FRequiredMemorySize * 6;
2208
Result := FRequiredMemorySize;
2211
procedure TGLTexture.SetImageAlpha(const val: TGLTextureImageAlpha);
2213
if FImageAlpha <> val then
2220
procedure TGLTexture.SetImageBrightness(const val: Single);
2222
if FImageBrightness <> val then
2224
FImageBrightness := val;
2229
function TGLTexture.StoreBrightness: Boolean;
2231
Result := (FImageBrightness <> 1.0);
2234
procedure TGLTexture.SetImageGamma(const val: Single);
2236
if FImageGamma <> val then
2243
function TGLTexture.StoreGamma: Boolean;
2245
Result := (FImageGamma <> 1.0);
2248
procedure TGLTexture.SetMagFilter(AValue: TGLMagFilter);
2250
if AValue <> FMagFilter then
2252
FMagFilter := AValue;
2257
procedure TGLTexture.SetMinFilter(AValue: TGLMinFilter);
2259
if AValue <> FMinFilter then
2261
FMinFilter := AValue;
2266
procedure TGLTexture.SetTextureMode(AValue: TGLTextureMode);
2268
if AValue <> FTextureMode then
2270
FTextureMode := AValue;
2275
procedure TGLTexture.SetDisabled(AValue: Boolean);
2277
intf: IGLTextureNotifyAble;
2279
if AValue <> FDisabled then
2281
FDisabled := AValue;
2282
if Supports(Owner, IGLTextureNotifyAble, intf) then
2283
intf.NotifyTexMapChange(Self)
2289
procedure TGLTexture.SetEnabled(const val: Boolean);
2291
Disabled := not val;
2294
function TGLTexture.GetEnabled: Boolean;
2296
Result := not Disabled;
2299
procedure TGLTexture.SetEnvColor(const val: TGLColor);
2301
FEnvColor.Assign(val);
2305
procedure TGLTexture.SetBorderColor(const val: TGLColor);
2307
FBorderColor.Assign(val);
2311
procedure TGLTexture.SetNormalMapScale(const val: Single);
2313
if val <> FNormalMapScale then
2315
FNormalMapScale := val;
2316
if TextureFormat = tfNormalMap then
2321
function TGLTexture.StoreNormalMapScale: Boolean;
2323
Result := (FNormalMapScale <> cDefaultNormalMapScale);
2326
procedure TGLTexture.SetTextureWrap(AValue: TGLTextureWrap);
2328
if AValue <> FTextureWrap then
2330
FTextureWrap := AValue;
2335
procedure TGLTexture.SetTextureWrapS(AValue: TGLSeparateTextureWrap);
2337
if AValue <> FTextureWrapS then
2339
FTextureWrapS := AValue;
2344
procedure TGLTexture.SetTextureWrapT(AValue: TGLSeparateTextureWrap);
2346
if AValue <> FTextureWrapT then
2348
FTextureWrapT := AValue;
2353
procedure TGLTexture.SetTextureWrapR(AValue: TGLSeparateTextureWrap);
2355
if AValue <> FTextureWrapR then
2357
FTextureWrapR := AValue;
2362
function TGLTexture.GetTextureFormat: TGLTextureFormat;
2364
i: TGLTextureFormat;
2366
if vDefaultTextureFormat = FTextureFormat then
2368
Result := tfDefault;
2371
for i := tfRGB to tfRGBAFloat32 do
2373
if cOldTextureFormatToInternalFormat[i] = FTextureFormat then
2379
Result := tfExtended;
2382
procedure TGLTexture.SetTextureFormat(const val: TGLTextureFormat);
2384
if val = tfDefault then
2386
FTextureFormat := vDefaultTextureFormat;
2388
else if val < tfExtended then
2390
FTextureFormat := cOldTextureFormatToInternalFormat[val];
2394
procedure TGLTexture.SetTextureFormatEx(const val: TGLInternalFormat);
2396
if val <> FTextureFormat then
2398
FTextureFormat := val;
2403
function TGLTexture.StoreTextureFormatEx: Boolean;
2405
Result := GetTextureFormat >= tfExtended;
2408
procedure TGLTexture.SetCompression(const val: TGLTextureCompression);
2410
if val <> FCompression then
2412
FCompression := val;
2417
procedure TGLTexture.SetFilteringQuality(const val: TGLTextureFilteringQuality);
2419
if val <> FFilteringQuality then
2421
FFilteringQuality := val;
2426
procedure TGLTexture.SetMappingMode(const val: TGLTextureMappingMode);
2428
texMapChange: Boolean;
2429
intf: IGLTextureNotifyAble;
2431
if val <> FMappingMode then
2433
texMapChange := ((val = tmmUser) and (FMappingMode <> tmmUser))
2434
or ((val = tmmUser) and (FMappingMode <> tmmUser));
2435
FMappingMode := val;
2436
if texMapChange then
2438
// when switching between texGen modes and user mode, the geometry
2439
// must be rebuilt in whole (to specify/remove texCoord data!)
2440
if Supports(Owner, IGLTextureNotifyAble, intf) then
2441
intf.NotifyTexMapChange(Self);
2448
procedure TGLTexture.SetMappingSCoordinates(const val: TGLCoordinates4);
2450
MappingSCoordinates.Assign(val);
2453
function TGLTexture.GetMappingSCoordinates: TGLCoordinates4;
2455
if not Assigned(FMapSCoordinates) then
2456
FMapSCoordinates := TGLCoordinates4.CreateInitialized(Self, XHmgVector,
2458
Result := FMapSCoordinates;
2462
function TGLTexture.StoreMappingSCoordinates: Boolean;
2464
if Assigned(FMapSCoordinates) then
2465
Result := not VectorEquals(FMapSCoordinates.AsVector, XHmgVector)
2470
procedure TGLTexture.SetMappingTCoordinates(const val: TGLCoordinates4);
2472
MappingTCoordinates.Assign(val);
2475
function TGLTexture.GetMappingTCoordinates: TGLCoordinates4;
2477
if not Assigned(FMapTCoordinates) then
2478
FMapTCoordinates := TGLCoordinates4.CreateInitialized(Self, YHmgVector,
2480
Result := FMapTCoordinates;
2483
function TGLTexture.StoreMappingTCoordinates: Boolean;
2485
if Assigned(FMapTCoordinates) then
2486
Result := not VectorEquals(FMapTCoordinates.AsVector, YHmgVector)
2492
procedure TGLTexture.SetMappingRCoordinates(const val: TGLCoordinates4);
2494
MappingRCoordinates.Assign(val);
2497
function TGLTexture.GetMappingRCoordinates: TGLCoordinates4;
2499
if not Assigned(FMapRCoordinates) then
2500
FMapRCoordinates := TGLCoordinates4.CreateInitialized(Self, ZHmgVector,
2502
Result := FMapRCoordinates;
2505
function TGLTexture.StoreMappingRCoordinates: Boolean;
2507
if Assigned(FMapRCoordinates) then
2508
Result := not VectorEquals(FMapRCoordinates.AsVector, ZHmgVector)
2513
procedure TGLTexture.SetMappingQCoordinates(const val: TGLCoordinates4);
2515
MappingQCoordinates.Assign(val);
2518
function TGLTexture.GetMappingQCoordinates: TGLCoordinates4;
2520
if not Assigned(FMapQCoordinates) then
2521
FMapQCoordinates := TGLCoordinates4.CreateInitialized(Self, WHmgVector,
2523
Result := FMapQCoordinates;
2526
function TGLTexture.StoreMappingQCoordinates: Boolean;
2528
if Assigned(FMapQCoordinates) then
2529
Result := not VectorEquals(FMapQCoordinates.AsVector, WHmgVector)
2534
function TGLTexture.StoreImageClassName: Boolean;
2536
Result := (FImage.ClassName <> TGLPersistentImage.ClassName);
2539
procedure TGLTexture.SetTextureCompareMode(const val: TGLTextureCompareMode);
2541
if val <> fTextureCompareMode then
2543
fTextureCompareMode := val;
2548
procedure TGLTexture.SetTextureCompareFunc(const val: TGLDepthCompareFunc);
2550
if val <> fTextureCompareFunc then
2552
fTextureCompareFunc := val;
2557
procedure TGLTexture.SetDepthTextureMode(const val: TGLDepthTextureMode);
2559
if val <> fDepthTextureMode then
2561
fDepthTextureMode := val;
2566
procedure TGLTexture.PrepareBuildList;
2572
procedure TGLTexture.ApplyMappingMode;
2576
R_Dim := GL.ARB_texture_cube_map or GL.EXT_texture3D;
2578
tmmUser: ; // nothing to do, but checked first (common case)
2581
GL.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR);
2582
GL.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR);
2583
GL.TexGenfv(GL_S, GL_OBJECT_PLANE, @MappingSCoordinates.DirectVector);
2584
GL.TexGenfv(GL_T, GL_OBJECT_PLANE, @MappingTCoordinates.DirectVector);
2585
GL.Enable(GL_TEXTURE_GEN_S);
2586
GL.Enable(GL_TEXTURE_GEN_T);
2590
GL.TexGeni(GL_R, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR);
2591
GL.TexGeni(GL_Q, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR);
2592
GL.TexGenfv(GL_R, GL_OBJECT_PLANE, @MappingRCoordinates.DirectVector);
2593
GL.TexGenfv(GL_Q, GL_OBJECT_PLANE, @MappingQCoordinates.DirectVector);
2594
GL.Enable(GL_TEXTURE_GEN_R);
2595
GL.Enable(GL_TEXTURE_GEN_Q);
2600
GL.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR);
2601
GL.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR);
2602
// specify planes in eye space, not world space
2603
GL.MatrixMode(GL_MODELVIEW);
2606
GL.TexGenfv(GL_S, GL_EYE_PLANE, @MappingSCoordinates.DirectVector);
2607
GL.TexGenfv(GL_T, GL_EYE_PLANE, @MappingTCoordinates.DirectVector);
2608
GL.Enable(GL_TEXTURE_GEN_S);
2609
GL.Enable(GL_TEXTURE_GEN_T);
2612
GL.TexGenfv(GL_R, GL_EYE_PLANE, @MappingRCoordinates.DirectVector);
2613
GL.TexGenfv(GL_Q, GL_EYE_PLANE, @MappingQCoordinates.DirectVector);
2614
GL.Enable(GL_TEXTURE_GEN_R);
2615
GL.Enable(GL_TEXTURE_GEN_Q);
2621
GL.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP);
2622
GL.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP);
2623
GL.Enable(GL_TEXTURE_GEN_S);
2624
GL.Enable(GL_TEXTURE_GEN_T);
2626
tmmCubeMapReflection, tmmCubeMapCamera: if GL.ARB_texture_cube_map then
2628
GL.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP);
2629
GL.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP);
2630
GL.TexGeni(GL_R, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP);
2631
GL.Enable(GL_TEXTURE_GEN_S);
2632
GL.Enable(GL_TEXTURE_GEN_T);
2633
GL.Enable(GL_TEXTURE_GEN_R);
2635
tmmCubeMapNormal, tmmCubeMapLight0: if GL.ARB_texture_cube_map then
2637
GL.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP);
2638
GL.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP);
2639
GL.TexGeni(GL_R, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP);
2640
GL.Enable(GL_TEXTURE_GEN_S);
2641
GL.Enable(GL_TEXTURE_GEN_T);
2642
GL.Enable(GL_TEXTURE_GEN_R);
2649
procedure TGLTexture.UnApplyMappingMode;
2651
if MappingMode <> tmmUser then
2653
GL.Disable(GL_TEXTURE_GEN_S);
2654
GL.Disable(GL_TEXTURE_GEN_T);
2655
if GL.EXT_texture3D or GL.ARB_texture_cube_map then
2657
GL.Disable(GL_TEXTURE_GEN_R);
2658
GL.Disable(GL_TEXTURE_GEN_Q);
2663
procedure TGLTexture.Apply(var rci: TGLRenderContextInfo);
2665
procedure SetCubeMapTextureMatrix;
2669
// compute model view matrix for proper viewing
2671
tmmCubeMapReflection, tmmCubeMapNormal:
2673
m := rci.PipelineTransformation.ViewMatrix;
2676
rci.GLStates.SetGLTextureMatrix(m);
2680
with TGLScene(rci.scene).Lights do
2683
m := TGLLightSource(Items[0]).AbsoluteMatrix;
2685
mm := rci.PipelineTransformation.ViewMatrix;
2686
NormalizeMatrix(mm);
2687
TransposeMatrix(mm);
2688
m := MatrixMultiply(m, mm);
2689
rci.GLStates.SetGLTextureMatrix(m);
2694
m.V[0] := VectorCrossProduct(rci.cameraUp, rci.cameraDirection);
2695
m.V[1] := VectorNegate(rci.cameraDirection);
2696
m.V[2] := rci.cameraUp;
2697
m.V[3] := WHmgPoint;
2698
mm := rci.PipelineTransformation.ViewMatrix;
2699
NormalizeMatrix(mm);
2700
TransposeMatrix(mm);
2701
m := MatrixMultiply(m, mm);
2702
rci.GLStates.SetGLTextureMatrix(m);
2709
// Multisample image do not work with FFP
2710
if (FTextureHandle.Target = ttTexture2DMultisample) or
2711
(FTextureHandle.Target = ttTexture2DMultisampleArray) then
2715
if not Disabled and (H > 0) then
2717
with rci.GLStates do
2720
TextureBinding[0, FTextureHandle.Target] := H;
2721
ActiveTextureEnabled[FTextureHandle.Target] := True;
2724
if not rci.GLStates.ForwardContext then
2726
if FTextureHandle.Target = ttTextureCube then
2727
SetCubeMapTextureMatrix;
2728
GL.TexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE,
2729
cTextureMode[FTextureMode]);
2730
GL.TexEnvfv(GL_TEXTURE_ENV, GL_TEXTURE_ENV_COLOR, FEnvColor.AsAddress);
2732
xgl.MapTexCoordToMain;
2735
else if not rci.GLStates.ForwardContext then
2737
xgl.MapTexCoordToMain;
2741
procedure TGLTexture.UnApply(var rci: TGLRenderContextInfo);
2744
and not rci.GLStates.ForwardContext then
2746
// Multisample image do not work with FFP
2747
if FTextureHandle.Target in [ttNoShape, ttTexture2DMultisample, ttTexture2DMultisampleArray] then
2749
with rci.GLStates do
2752
ActiveTextureEnabled[FTextureHandle.Target] := False;
2753
if FTextureHandle.Target = ttTextureCube then
2754
ResetGLTextureMatrix;
2760
procedure TGLTexture.ApplyAsTexture2(var rci: TGLRenderContextInfo; textureMatrix:
2763
ApplyAsTextureN(2, rci, textureMatrix);
2766
procedure TGLTexture.UnApplyAsTexture2(var rci: TGLRenderContextInfo;
2767
reloadIdentityTextureMatrix: boolean);
2769
UnApplyAsTextureN(2, rci, reloadIdentityTextureMatrix);
2772
procedure TGLTexture.ApplyAsTextureN(n: Integer; var rci: TGLRenderContextInfo;
2773
textureMatrix: PMatrix = nil);
2777
if not Disabled then
2779
// Multisample image do not work with FFP
2780
if (FTextureHandle.Target = ttTexture2DMultisample) or
2781
(FTextureHandle.Target = ttTexture2DMultisampleArray) then
2783
with rci.GLStates do
2785
ActiveTexture := n - 1;
2786
TextureBinding[n - 1, FTextureHandle.Target] := Handle;
2787
ActiveTextureEnabled[FTextureHandle.Target] := True;
2788
if Assigned(textureMatrix) then
2789
SetGLTextureMatrix(textureMatrix^)
2790
else if FTextureHandle.Target = ttTextureCube then
2792
m := rci.PipelineTransformation.ModelViewMatrix;
2795
rci.GLStates.SetGLTextureMatrix(m);
2798
if not ForwardContext then
2800
GL.TexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, cTextureMode[FTextureMode]);
2801
GL.TexEnvfv(GL_TEXTURE_ENV, GL_TEXTURE_ENV_COLOR, FEnvColor.AsAddress);
2809
procedure TGLTexture.UnApplyAsTextureN(n: Integer; var rci: TGLRenderContextInfo;
2810
reloadIdentityTextureMatrix: boolean);
2812
if not rci.GLStates.ForwardContext then
2814
// Multisample image do not work with FFP
2815
if (FTextureHandle.Target = ttTexture2DMultisample) or
2816
(FTextureHandle.Target = ttTexture2DMultisampleArray) then
2818
with rci.GLStates do
2820
ActiveTexture := n - 1;
2821
ActiveTextureEnabled[FTextureHandle.Target] := False;
2823
if (FTextureHandle.Target = ttTextureCube) or reloadIdentityTextureMatrix then
2824
ResetGLTextureMatrix;
2830
function TGLTexture.AllocateHandle: TGLuint;
2832
vTarget: TGLTextureTarget;
2834
vTarget := Image.NativeTextureTarget;
2835
if (vTarget <> ttNoShape) and (FTextureHandle.Target <> vTarget) then
2836
FTextureHandle.DestroyHandle;
2838
Result := FTextureHandle.Handle;
2841
FTextureHandle.AllocateHandle;
2842
Result := FTextureHandle.Handle;
2844
if FTextureHandle.IsDataNeedUpdate then
2846
FTextureHandle.Target := vTarget;
2847
FSamplerHandle.NotifyChangesOfData;
2849
if FSamplerHandle.Handle = 0 then
2850
FSamplerHandle.AllocateHandle;
2853
if (FTextureHandle.Target <> ttNoShape) and
2854
IsTargetSupported(FTextureHandle.Target) then
2856
if FSamplerHandle.IsDataNeedUpdate then
2858
with CurrentGLContext.GLStates do
2859
TextureBinding[ActiveTexture, FTextureHandle.Target] := Result;
2860
PrepareParams(DecodeGLTextureTarget(FTextureHandle.Target));
2861
FSamplerHandle.NotifyDataUpdated;
2868
function TGLTexture.IsHandleAllocated: Boolean;
2870
Result := (FTextureHandle.Handle <> 0);
2874
function TGLTexture.GetHandle: TGLuint;
2877
LBinding: array[TGLTextureTarget] of TGLuint;
2879
procedure StoreBindings;
2881
t: TGLTextureTarget;
2883
with CurrentGLContext.GLStates do
2885
if TextureBinding[ActiveTexture, FTextureHandle.Target] = FTextureHandle.Handle then
2886
TextureBinding[ActiveTexture, FTextureHandle.Target] := 0;
2887
for t := Low(TGLTextureTarget) to High(TGLTextureTarget) do
2888
LBinding[t] := TextureBinding[ActiveTexture, t];
2892
procedure RestoreBindings;
2894
t: TGLTextureTarget;
2896
with CurrentGLContext.GLStates do
2897
for t := Low(TGLTextureTarget) to High(TGLTextureTarget) do
2898
TextureBinding[ActiveTexture, t] := LBinding[t];
2902
with CurrentGLContext.GLStates do
2906
Result := AllocateHandle;
2907
if FTextureHandle.IsDataNeedUpdate then
2909
FTextureHandle.NotifyDataUpdated;
2911
target := DecodeGLTextureTarget(Image.NativeTextureTarget);
2912
if not IsTargetSupported(target) or not IsFormatSupported(TextureFormatEx) then
2914
SetTextureErrorImage;
2915
target := GL_TEXTURE_2D;
2918
if not GL.EXT_direct_state_access then
2919
TextureBinding[ActiveTexture, FTextureHandle.Target] := Result;
2920
PrepareImage(target);
2928
procedure TGLTexture.DestroyHandles;
2930
FTextureHandle.DestroyHandle;
2931
FSamplerHandle.DestroyHandle;
2932
FRequiredMemorySize := -1;
2935
function TGLTexture.IsFloatType: Boolean;
2937
Result := IsFloatFormat(TextureFormatEx);
2940
function TGLTexture.OpenGLTextureFormat: Integer;
2942
texComp: TGLTextureCompression;
2944
if GL.ARB_texture_compression then
2946
if Compression = tcDefault then
2947
if vDefaultTextureCompression = tcDefault then
2950
texComp := vDefaultTextureCompression
2952
texComp := Compression;
2958
texComp := tcNone; // no compression support for float_type
2960
if (texComp <> tcNone) and (TextureFormat <= tfNormalMap) then
2961
with CurrentGLContext.GLStates do
2964
tcStandard: TextureCompressionHint := hintDontCare;
2965
tcHighQuality: TextureCompressionHint := hintNicest;
2966
tcHighSpeed: TextureCompressionHint := hintFastest;
2970
Result := CompressedInternalFormatToOpenGL(TextureFormatEx);
2973
Result := InternalFormatToOpenGLFormat(TextureFormatEx);
2976
procedure TGLTexture.PrepareImage(target: TGLUInt);
2979
texComp: TGLTextureCompression;
2982
if Image.IsSelfLoading then
2984
Image.LoadTexture(FTextureFormat);
2989
bitmap32 := Image.GetBitmap32;
2991
if (bitmap32 = nil) or bitmap32.IsEmpty then
2994
if TextureFormat = tfNormalMap then
2995
bitmap32.GrayScaleToNormalMap(NormalMapScale,
2996
TextureWrap in [twBoth, twHorizontal],
2997
TextureWrap in [twBoth, twVertical]);
2998
// prepare AlphaChannel
3000
tiaDefault: ; // nothing to do
3001
tiaAlphaFromIntensity:
3002
bitmap32.SetAlphaFromIntensity;
3003
tiaSuperBlackTransparent:
3004
bitmap32.SetAlphaTransparentForColor($000000);
3006
bitmap32.SetAlphaFromIntensity;
3009
bitmap32.SetAlphaFromIntensity;
3013
bitmap32.SetAlphaToValue(255);
3014
tiaTopLeftPointColorTransparent:
3017
bitmap32.SetAlphaTransparentForColor(bitmap32.Data^[0]);
3019
tiaInverseLuminance:
3021
bitmap32.SetAlphaFromIntensity;
3022
bitmap32.InvertAlpha;
3024
tiaInverseLuminanceSqrt:
3026
bitmap32.SetAlphaFromIntensity;
3028
bitmap32.InvertAlpha;
3030
tiaBottomRightPointColorTransparent:
3033
bitmap32.SetAlphaTransparentForColor(bitmap32.Data^[bitmap32.Width - 1]);
3038
// apply brightness correction
3039
if FImageBrightness <> 1.0 then
3040
bitmap32.BrightnessCorrection(FImageBrightness);
3041
// apply gamma correction
3042
if FImageGamma <> 1.0 then
3043
bitmap32.GammaCorrection(FImageGamma);
3045
if GL.ARB_texture_compression
3046
and (TextureFormat <> tfExtended) then
3048
if Compression = tcDefault then
3049
if vDefaultTextureCompression = tcDefault then
3052
texComp := vDefaultTextureCompression
3054
texComp := Compression;
3062
if (texComp <> tcNone) and (TextureFormat <= tfNormalMap) then
3063
with CurrentGLContext.GLStates do
3066
tcStandard: TextureCompressionHint := hintDontCare;
3067
tcHighQuality: TextureCompressionHint := hintNicest;
3068
tcHighSpeed: TextureCompressionHint := hintFastest;
3070
Assert(False, glsErrorEx + glsUnknownType);
3072
glFormat := CompressedInternalFormatToOpenGL(FTextureFormat);
3075
glFormat := InternalFormatToOpenGLFormat(FTextureFormat);
3077
bitmap32.RegisterAsOpenGLTexture(
3079
not (FMinFilter in [miNearest, miLinear]),
3086
if GL.GetError <> GL_NO_ERROR then
3089
SetTextureErrorImage;
3093
FRequiredMemorySize := -1;
3094
TextureImageRequiredMemory;
3095
if not IsDesignTime and not FKeepImageAfterTransfer then
3096
Image.ReleaseBitmap32;
3100
procedure TGLTexture.PrepareParams(target: TGLUInt);
3102
cTextureSWrap: array[twBoth..twHorizontal] of TGLEnum =
3103
(GL_REPEAT, GL_CLAMP_TO_EDGE, GL_CLAMP_TO_EDGE, GL_REPEAT);
3104
cTextureTWrap: array[twBoth..twHorizontal] of TGLEnum =
3105
(GL_REPEAT, GL_CLAMP_TO_EDGE, GL_REPEAT, GL_CLAMP_TO_EDGE);
3106
cTextureRWrap: array[twBoth..twHorizontal] of TGLEnum =
3107
(GL_REPEAT, GL_CLAMP_TO_EDGE, GL_REPEAT, GL_CLAMP_TO_EDGE);
3108
cTextureSWrapOld: array[twBoth..twHorizontal] of TGLEnum =
3109
(GL_REPEAT, GL_CLAMP, GL_CLAMP, GL_REPEAT);
3110
cTextureTWrapOld: array[twBoth..twHorizontal] of TGLEnum =
3111
(GL_REPEAT, GL_CLAMP, GL_REPEAT, GL_CLAMP);
3112
cTextureMagFilter: array[maNearest..maLinear] of TGLEnum =
3113
(GL_NEAREST, GL_LINEAR);
3114
cTextureMinFilter: array[miNearest..miLinearMipmapLinear] of TGLEnum =
3115
(GL_NEAREST, GL_LINEAR, GL_NEAREST_MIPMAP_NEAREST,
3116
GL_LINEAR_MIPMAP_NEAREST, GL_NEAREST_MIPMAP_LINEAR,
3117
GL_LINEAR_MIPMAP_LINEAR);
3118
cFilteringQuality: array[tfIsotropic..tfAnisotropic] of Integer = (1, 2);
3119
cSeparateTextureWrap: array[twRepeat..twMirrorClampToBorder] of TGLenum =
3120
(GL_REPEAT, GL_CLAMP_TO_EDGE, GL_CLAMP_TO_BORDER,
3121
GL_MIRRORED_REPEAT, GL_MIRROR_CLAMP_TO_EDGE_ATI, GL_MIRROR_CLAMP_TO_BORDER_EXT);
3122
cTextureCompareMode: array[tcmNone..tcmCompareRtoTexture] of TGLenum =
3123
(GL_NONE, GL_COMPARE_R_TO_TEXTURE);
3124
cDepthTextureMode: array[dtmLuminance..dtmAlpha] of TGLenum =
3125
(GL_LUMINANCE, GL_INTENSITY, GL_ALPHA);
3129
lMinFilter: TGLMinFilter;
3131
if (target = GL_TEXTURE_2D_MULTISAMPLE)
3132
or (target = GL_TEXTURE_2D_MULTISAMPLE_ARRAY) then
3135
R_Dim := GL.ARB_texture_cube_map or GL.EXT_texture3D;
3137
with CurrentGLContext.GLStates do
3139
UnpackAlignment := 1;
3140
UnpackRowLength := 0;
3141
UnpackSkipRows := 0;
3142
UnpackSkipPixels := 0;
3145
GL.TexParameterfv(target, GL_TEXTURE_BORDER_COLOR, FBorderColor.AsAddress);
3147
if (GL.VERSION_1_2 or GL.EXT_texture_edge_clamp) then
3149
if FTextureWrap = twSeparate then
3151
GL.TexParameteri(target, GL_TEXTURE_WRAP_S,
3152
cSeparateTextureWrap[FTextureWrapS]);
3153
GL.TexParameteri(target, GL_TEXTURE_WRAP_T,
3154
cSeparateTextureWrap[FTextureWrapT]);
3156
GL.TexParameteri(target, GL_TEXTURE_WRAP_R,
3157
cSeparateTextureWrap[FTextureWrapR]);
3161
GL.TexParameteri(target, GL_TEXTURE_WRAP_S, cTextureSWrap[FTextureWrap]);
3162
GL.TexParameteri(target, GL_TEXTURE_WRAP_T, cTextureTWrap[FTextureWrap]);
3164
GL.TexParameteri(target, GL_TEXTURE_WRAP_R, cTextureRWrap[FTextureWrap]);
3169
GL.TexParameteri(target, GL_TEXTURE_WRAP_S, cTextureSWrapOld[FTextureWrap]);
3170
GL.TexParameteri(target, GL_TEXTURE_WRAP_T, cTextureTWrapOld[FTextureWrap]);
3173
lMinFilter := FMinFilter;
3174
// Down paramenter to rectangular texture supported
3175
if (target = GL_TEXTURE_RECTANGLE)
3176
or not (GL.EXT_texture_lod or GL.SGIS_texture_lod) then
3178
if lMinFilter in [miNearestMipmapNearest, miNearestMipmapLinear] then
3179
lMinFilter := miNearest;
3180
if FMinFilter in [miLinearMipmapNearest, miLinearMipmapLinear] then
3181
lMinFilter := miLinear;
3184
GL.TexParameteri(target, GL_TEXTURE_MIN_FILTER, cTextureMinFilter[lMinFilter]);
3185
GL.TexParameteri(target, GL_TEXTURE_MAG_FILTER, cTextureMagFilter[FMagFilter]);
3187
if GL.EXT_texture_filter_anisotropic then
3188
GL.TexParameteri(target, GL_TEXTURE_MAX_ANISOTROPY_EXT,
3189
cFilteringQuality[FFilteringQuality]);
3191
if IsDepthFormat(fTextureFormat) then
3193
GL.TexParameteri(target, GL_TEXTURE_COMPARE_MODE,
3194
cTextureCompareMode[fTextureCompareMode]);
3195
GL.TexParameteri(target, GL_TEXTURE_COMPARE_FUNC,
3196
cGLComparisonFunctionToGLEnum[fTextureCompareFunc]);
3197
if not FTextureHandle.RenderingContext.GLStates.ForwardContext then
3198
GL.TexParameteri(target, GL_DEPTH_TEXTURE_MODE,
3199
cDepthTextureMode[fDepthTextureMode]);
3203
procedure TGLTexture.DoOnTextureNeeded(Sender: TObject; var textureFileName:
3206
if Assigned(FOnTextureNeeded) then
3207
FOnTextureNeeded(Sender, textureFileName);
3210
procedure TGLTexture.OnSamplerAllocate(Sender: TGLVirtualHandle; var Handle: Cardinal);
3215
procedure TGLTexture.OnSamplerDestroy(Sender: TGLVirtualHandle; var Handle: Cardinal);
3220
procedure TGLTexture.SetTextureErrorImage;
3224
img := TGLImage.Create;
3227
ImageClassName := TGLBlankImage.className;
3228
TGLBlankImage(Image).Assign(img);
3231
MagFilter := maNearest;
3232
MinFilter := miNearest;
3233
TextureWrap := twBoth;
3234
MappingMode := tmmUser;
3235
Compression := tcNone;
3242
{%region%===== 'TGLTextureExItem ================================}3244
constructor TGLTextureExItem.Create(ACollection: TCollection);
3248
FTexture := TGLTexture.Create(Self);
3249
FTextureOffset := TGLCoordinates.CreateInitialized(Self, NullHMGVector,
3251
FTextureOffset.OnNotifyChange := OnNotifyChange;
3252
FTextureScale := TGLCoordinates.CreateInitialized(Self, XYZHmgVector,
3254
FTextureScale.OnNotifyChange := OnNotifyChange;
3256
FTextureIndex := ID;
3257
FTextureMatrix := IdentityHMGMatrix;
3259
//DanB - hmmm, not very flexible code, assumes it's owned by a material,
3260
// that has a Texture property, but may need to re-implement it somehow
3261
{ if ACollection is TGLTextureEx then3262
if TGLTextureEx(ACollection).FOwner <> nil then
3263
FTexture.OnTextureNeeded := TGLTextureEx(ACollection).FOwner.Texture.OnTextureNeeded;
3268
destructor TGLTextureExItem.Destroy;
3271
FTextureOffset.Free;
3278
function TGLTextureExItem.QueryInterface(constref IID: TGUID; out Obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};3282
if GetInterface(IID, Obj) then
3285
Result := E_NOINTERFACE;
3289
function TGLTextureExItem._AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};3293
Result := -1; //ignore
3296
function TGLTextureExItem._Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};3300
Result := -1; //ignore
3303
procedure TGLTextureExItem.Assign(Source: TPersistent);
3305
if Source is TGLTextureExItem then
3307
Texture := TGLTextureExItem(Source).Texture;
3308
TextureIndex := TGLTextureExItem(Source).TextureIndex;
3309
TextureOffset := TGLTextureExItem(Source).TextureOffset;
3310
TextureScale := TGLTextureExItem(Source).TextureScale;
3317
procedure TGLTextureExItem.NotifyChange(Sender: TObject);
3319
if Assigned(Collection) then
3320
TGLTextureEx(Collection).NotifyChange(Self);
3323
procedure TGLTextureExItem.Apply(var rci: TGLRenderContextInfo);
3326
if FTexture.Enabled then
3328
rci.GLStates.ActiveTexture := FTextureIndex;
3329
GL.MatrixMode(GL_TEXTURE);
3331
if FTextureMatrixIsIdentity then
3334
GL.LoadMatrixf(@FTextureMatrix.V[0].V[0]);
3335
GL.MatrixMode(GL_MODELVIEW);
3336
rci.GLStates.ActiveTexture := 0;
3337
if FTextureIndex = 0 then
3339
else if FTextureIndex = 1 then
3340
FTexture.ApplyAsTexture2(rci, nil)
3341
else if FTextureIndex >= 2 then
3342
FTexture.ApplyAsTextureN(FTextureIndex + 1, rci, nil);
3347
procedure TGLTextureExItem.UnApply(var rci: TGLRenderContextInfo);
3351
if FTextureIndex = 0 then
3352
FTexture.UnApply(rci)
3353
else if FTextureIndex = 1 then
3354
FTexture.UnApplyAsTexture2(rci, false)
3355
else if FTextureIndex >= 2 then
3356
FTexture.UnApplyAsTextureN(FTextureIndex + 1, rci, false);
3357
rci.GLStates.ActiveTexture := FTextureIndex;
3358
GL.MatrixMode(GL_TEXTURE);
3360
GL.MatrixMode(GL_MODELVIEW);
3361
rci.GLStates.ActiveTexture := 0;
3366
function TGLTextureExItem.GetDisplayName: string;
3368
Result := Format('Tex [%d]', [FTextureIndex]);3371
function TGLTextureExItem.GetOwner: TPersistent;
3373
Result := Collection;
3376
procedure TGLTextureExItem.NotifyTexMapChange(Sender: TObject);
3378
intf: IGLTextureNotifyAble;
3380
if Supports(TObject(TGLTextureEx(Collection).FOwner), IGLTextureNotifyAble,
3382
intf.NotifyTexMapChange(Sender);
3385
procedure TGLTextureExItem.SetTexture(const Value: TGLTexture);
3387
FTexture.Assign(Value);
3391
procedure TGLTextureExItem.SetTextureIndex(const Value: Integer);
3398
if temp <> FTextureIndex then
3400
FTextureIndex := temp;
3405
procedure TGLTextureExItem.SetTextureOffset(const Value: TGLCoordinates);
3407
FTextureOffset.Assign(Value);
3411
procedure TGLTextureExItem.SetTextureScale(const Value: TGLCoordinates);
3413
FTextureScale.Assign(Value);
3417
procedure TGLTextureExItem.CalculateTextureMatrix;
3419
if TextureOffset.Equals(NullHmgVector) and TextureScale.Equals(XYZHmgVector) then
3420
FTextureMatrixIsIdentity := True
3423
FTextureMatrixIsIdentity := False;
3424
FTextureMatrix := CreateScaleAndTranslationMatrix(TextureScale.AsVector,
3425
TextureOffset.AsVector);
3430
procedure TGLTextureExItem.OnNotifyChange(Sender: TObject);
3432
CalculateTextureMatrix;
3437
{%region%===== TGLTextureEx ================================}3440
constructor TGLTextureEx.Create(AOwner: TGLUpdateAbleObject);
3442
inherited Create(TGLTextureExItem);
3448
procedure TGLTextureEx.NotifyChange(Sender: TObject);
3450
if Assigned(FOwner) then
3451
FOwner.NotifyChange(Self);
3455
procedure TGLTextureEx.Apply(var rci: TGLRenderContextInfo);
3457
i, texUnits: Integer;
3460
if not GL.ARB_multitexture then
3464
GL.GetIntegerv(GL_MAX_TEXTURE_UNITS, @texUnits);
3465
for i := 0 to Count - 1 do
3467
if Items[i].TextureIndex < texUnits then
3469
Items[i].Apply(rci);
3470
if Items[i].FApplied then
3471
if (Items[i].TextureIndex > 0) and (Items[i].Texture.MappingMode =
3473
units := units or (1 shl Items[i].TextureIndex);
3477
xgl.MapTexCoordToArbitraryAdd(units);
3481
procedure TGLTextureEx.UnApply(var rci: TGLRenderContextInfo);
3485
if not GL.ARB_multitexture then
3487
for i := 0 to Count - 1 do
3488
Items[i].UnApply(rci);
3491
function TGLTextureEx.Add: TGLTextureExItem;
3493
Result := TGLTextureExItem(inherited Add);
3496
procedure TGLTextureEx.Loaded;
3500
for i := 0 to Count - 1 do
3501
Items[i].CalculateTextureMatrix;
3504
function TGLTextureEx.GetOwner: TPersistent;
3509
procedure TGLTextureEx.SetItems(index: Integer; const Value: TGLTextureExItem);
3511
inherited SetItem(index, Value);
3514
function TGLTextureEx.GetItems(index: Integer): TGLTextureExItem;
3516
Result := TGLTextureExItem(inherited GetItem(index));
3519
function TGLTextureEx.IsTextureEnabled(Index: Integer): Boolean;
3526
for i := 0 to Count - 1 do
3527
if Items[i].TextureIndex = Index then
3528
Result := Result or Items[i].Texture.Enabled;
3535
RegisterGLTextureImageClass(TGLBlankImage);
3536
RegisterGLTextureImageClass(TGLPersistentImage);
3537
RegisterGLTextureImageClass(TGLPicFileImage);
3538
RegisterGLTextureImageClass(TGLCubeMapImage);
3540
RegisterTGraphicClassFileExtension('.bmp', TGLBitmap);3544
vGLTextureImageClasses.Free;
3545
vGLTextureImageClasses := nil;