// // The multimedia graphics platform GLScene https://github.com/glscene // unit GLS.MaterialEx; (* Handles extended material and it components: textures, samplers, combiners, shaders and etc. Features: - material can contain different level of applying accordingly to hardware i.e. Feateres scaling. - if automatically or by user selected level failed, material down to lower level. - direct state access can be used for uniforms setting. - economy mode for texture binding to active units, i.e. if textures less than maximum units may be not one binding occur per frame. *) interface {$I GLScene.inc} uses Winapi.OpenGL, Winapi.OpenGLext, System.Classes, System.SysUtils, System.Math, Vcl.Graphics, GLS.OpenGLTokens, GLS.RenderContextInfo, GLS.PipelineTransformation, GLS.BaseClasses, GLS.Context, GLS.VectorTypes, GLS.Material, GLS.Texture, GLS.Color, GLS.Coordinates, GLS.VectorGeometry, GLS.Graphics, GLS.PersistentClasses, GLS.State, GLS.TextureFormat, GLS.XCollection, GLS.TextureCombiners, GLSL.ShaderParameter, GLS.ApplicationFileIO, GLS.Strings, GLS.ImageUtils, GLS.Utils, GLS.XOpenGL, GLS.Logger; type TGLMaterialComponentName = string; TGLMaterialLibraryEx = class; TGLMatLibComponents = class; TGLLibMaterialEx = class; TGLBaseShaderModel = class; TGLASMVertexProgram = class; TOnAsmProgSetting = procedure(Sender: TGLASMVertexProgram; var ARci: TGLRenderContextInfo) of object; TOnUniformInitialize = procedure(Sender: TGLBaseShaderModel) of object; TOnUniformSetting = procedure(Sender: TGLBaseShaderModel; var ARci: TGLRenderContextInfo) of object; TGLBaseMaterialCollectionItem = class( TXCollectionItem, IGLMaterialLibrarySupported) private FNameHashKey: Integer; FUserList: TGLPersistentObjectList; FDefferedInit: Boolean; FNotifying: Boolean; FIsValid: Boolean; function GetUserList: TGLPersistentObjectList; function GetMaterialLibraryEx: TGLMaterialLibraryEx; protected procedure SetName(const AValue: TGLMaterialComponentName); override; procedure NotifyChange(Sender: TObject); virtual; property UserList: TGLPersistentObjectList read GetUserList; procedure DoOnPrepare(Sender: TGLContext); virtual; abstract; public destructor Destroy; override; procedure RegisterUser(AUser: TGLUpdateAbleObject); procedure UnregisterUser(AUser: TGLUpdateAbleObject); function GetUserCount: Integer; function GetMaterialLibrary: TGLAbstractMaterialLibrary; property MaterialLibrary: TGLMaterialLibraryEx read GetMaterialLibraryEx; property IsValid: Boolean read FIsValid; published property Name: TGLMaterialComponentName read GetName write SetName; (* Run-time flag, indicate that resource should initialize in case of failure material's level. *) property DefferedInit: Boolean read FDefferedInit write FDefferedInit default False; end; CGLBaseMaterialCollectionItem = class of TGLBaseMaterialCollectionItem; TGLLibMaterialProperty = class(TGLUpdateAbleObject, IGLMaterialLibrarySupported) protected FEnabled: Boolean; FNextPassName: TGLLibMaterialName; function GetMaterial: TGLLibMaterialEx; function GetMaterialLibraryEx: TGLMaterialLibraryEx; procedure SetEnabled(AValue: Boolean); virtual; procedure SetNextPass(const AValue: TGLLibMaterialName); procedure Loaded; virtual; property NextPass: TGLLibMaterialName read FNextPassName write SetNextPass; public procedure NotifyChange(Sender: TObject); override; function GetMaterialLibrary: TGLAbstractMaterialLibrary; property MaterialLibrary: TGLMaterialLibraryEx read GetMaterialLibraryEx; published property Enabled: Boolean read FEnabled write SetEnabled; end; TGLTextureSampler = class(TGLBaseMaterialCollectionItem) protected procedure WriteToFiler(AWriter: TWriter); override; procedure ReadFromFiler(AReader: TReader); override; private FHandle: TGLSamplerHandle; FMinFilter: TGLMinFilter; FMagFilter: TGLMagFilter; FFilteringQuality: TGLTextureFilteringQuality; FLODBias: Integer; FLODBiasFract: Single; FWrap: array[0..2] of TGLSeparateTextureWrap; FBorderColor: TGLColor; FCompareMode: TGLTextureCompareMode; FCompareFunc: TGLDepthFunction; FDecodeSRGB: Boolean; procedure SetMagFilter(AValue: TGLMagFilter); procedure SetMinFilter(AValue: TGLMinFilter); procedure SetLODBias(AValue: Integer); procedure SetFilteringQuality(AValue: TGLTextureFilteringQuality); function GetWrap(Index: Integer): TGLSeparateTextureWrap; procedure SetWrap(Index: Integer; AValue: TGLSeparateTextureWrap); procedure SetBorderColor(const AValue: TGLColor); procedure SetCompareMode(AValue: TGLTextureCompareMode); procedure SetCompareFunc(AValue: TGLDepthFunction); procedure SetDecodeSRGB(AValue: Boolean); public constructor Create(AOwner: TXCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure NotifyChange(Sender: TObject); override; procedure DoOnPrepare(Sender: TGLContext); override; procedure Apply(var ARci: TGLRenderContextInfo); procedure UnApply(var ARci: TGLRenderContextInfo); class function FriendlyName: string; override; property Handle: TGLSamplerHandle read FHandle; published // Texture magnification filter. property MagFilter: TGLMagFilter read FMagFilter write SetMagFilter default maLinear; // Texture minification filter. property MinFilter: TGLMinFilter read FMinFilter write SetMinFilter default miLinearMipMapLinear; property FilteringQuality: TGLTextureFilteringQuality read FFilteringQuality write SetFilteringQuality default tfAnisotropic; // Texture LOD bias. property LodBias: Integer read FLODBias write SetLODBias default 0; // Address mode for the texture. property WrapX: TGLSeparateTextureWrap index 0 read GetWrap write SetWrap default twRepeat; property WrapY: TGLSeparateTextureWrap index 1 read GetWrap write SetWrap default twRepeat; property WrapZ: TGLSeparateTextureWrap index 2 read GetWrap write SetWrap default twRepeat; // Texture border color. property BorderColor: TGLColor read FBorderColor write SetBorderColor; // Compare mode and function for depth texture property CompareMode: TGLTextureCompareMode read FCompareMode write SetCompareMode default tcmNone; property CompareFunc: TGLDepthFunction read FCompareFunc write SetCompareFunc default cfLEqual; (* Force retrieving the undecoded sRGB data from the texture and manipulate that directly. *) property sRGB_Encode: Boolean read FDecodeSRGB write SetDecodeSRGB default True; end; TGLAbstractTexture = class(TGLBaseMaterialCollectionItem) protected FHandle: TGLTextureHandle; FInternalFormat: TGLInternalFormat; FWidth: Integer; FHeight: Integer; FDepth: Integer; FSwizzles: TSwizzleVector; FApplicableSampler: TGLTextureSampler; FLastSampler: TGLTextureSampler; function GetTextureTarget: TGLTextureTarget; procedure Apply(var ARci: TGLRenderContextInfo); virtual; abstract; procedure UnApply(var ARci: TGLRenderContextInfo); virtual; abstract; public property Handle: TGLTextureHandle read FHandle; published property Shape: TGLTextureTarget read GetTextureTarget; end; TMipmapGenerationMode = ( mgmNoMip, mgmLeaveExisting, mgmOnFly, mgmBoxFilter, mgmTriangleFilter, mgmHermiteFilter, mgmBellFilter, mgmSplineFilter, mgmLanczos3Filter, mgmMitchellFilter ); TGLTextureImageEx = class(TGLAbstractTexture) protected procedure WriteToFiler(AWriter: TWriter); override; procedure ReadFromFiler(AReader: TReader); override; private FCompression: TGLTextureCompression; FImage: TGLBaseImage; FImageAlpha: TGLTextureImageAlpha; FImageBrightness: Single; FImageGamma: Single; FHeightToNormalScale: Single; FSourceFile: string; FApplyCounter: Integer; FInternallyStored: Boolean; FMipGenMode: TMipmapGenerationMode; FUseStreaming: Boolean; FBaseLevel: Integer; FMaxLevel: Integer; FLastTime: Double; procedure SetInternalFormat(const AValue: TGLInternalFormat); procedure SetImageAlpha(const AValue: TGLTextureImageAlpha); procedure SetImageBrightness(const AValue: Single); function StoreBrightness: Boolean; procedure SetImageGamma(const AValue: Single); function StoreGamma: Boolean; procedure SetNormalMapScale(const AValue: Single); function StoreNormalMapScale: Boolean; procedure SetCompression(const AValue: TGLTextureCompression); procedure SetSourceFile(AValue: string); procedure SetInternallyStored(const AValue: Boolean); procedure SetMipGenMode(const AValue: TMipmapGenerationMode); procedure SetUseStreaming(const AValue: Boolean); procedure PrepareImage; procedure FullTransfer; procedure StreamTransfer; procedure CalcLODRange(out AFirstLOD, ALastLOD: Integer); public constructor Create(AOwner: TXCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure NotifyChange(Sender: TObject); override; procedure DoOnPrepare(Sender: TGLContext); override; procedure Apply(var ARci: TGLRenderContextInfo); override; procedure UnApply(var ARci: TGLRenderContextInfo); override; class function FriendlyName: string; override; published // Factual texture properties property InternalWidth: Integer read FWidth; property InternalHeight: Integer read FHeight; property InternalDepth: Integer read FDepth; property InternalFormat: TGLInternalFormat read FInternalFormat write SetInternalFormat default tfRGBA8; (* Automatic Image Alpha setting. Allows to control how and if the image's Alpha channel (transparency) is computed. *) property ImageAlpha: TGLTextureImageAlpha read FImageAlpha write SetImageAlpha default tiaDefault; (* Texture brightness correction. This correction is applied upon loading a TGLTextureImage, it's a simple saturating scaling applied to the RGB components of the 32 bits image, before it is passed to OpenGL, and before gamma correction (if any). *) property ImageBrightness: Single read FImageBrightness write SetImageBrightness stored StoreBrightness; (*Texture gamma correction. The gamma correction is applied upon loading a TGLTextureImage, applied to the RGB components of the 32 bits image, before it is passed to OpenGL, after brightness correction (if any). *) property ImageGamma: Single read FImageGamma write SetImageGamma stored StoreGamma; (* Texture compression control. If True the compressed TextureFormat variant (the OpenGL ICD must support GL_ARB_texture_compression, or this option is ignored). *) property Compression: TGLTextureCompression read FCompression write SetCompression default tcDefault; (* Normal Map scaling. Force normal map generation from height map and controls the intensity of the bumps. *) property HeightToNormalScale: Single read FHeightToNormalScale write SetNormalMapScale stored StoreNormalMapScale; // Source file path and name. property SourceFile: string read FSourceFile write SetSourceFile; // Force to store image levels in separate files in ready to transfer format property InternallyStored: Boolean read FInternallyStored write SetInternallyStored default False; // Mipmap generation mode. property MipGenMode: TMipmapGenerationMode read FMipGenMode write SetMipGenMode default mgmOnFly; // Enable streaming loading. property UseStreaming: Boolean read FUseStreaming write SetUseStreaming default False; end; TGLFrameBufferAttachment = class(TGLAbstractTexture) protected procedure WriteToFiler(AWriter: TWriter); override; procedure ReadFromFiler(AReader: TReader); override; private FRenderBufferHandle: TGLRenderbufferHandle; FLayered: Boolean; FCubeMap: Boolean; FSamples: Integer; FOnlyWrite: Boolean; FFixedSamplesLocation: Boolean; procedure SetWidth(AValue: Integer); procedure SetHeight(AValue: Integer); procedure SetDepth(AValue: Integer); procedure SetInternalFormat(const AValue: TGLInternalFormat); procedure SetOnlyWrite(AValue: Boolean); procedure SetLayered(AValue: Boolean); procedure SetCubeMap(AValue: Boolean); procedure SetSamples(AValue: Integer); procedure SetFixedSamplesLocation(AValue: Boolean); public constructor Create(AOwner: TXCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure NotifyChange(Sender: TObject); override; procedure DoOnPrepare(Sender: TGLContext); override; procedure Apply(var ARci: TGLRenderContextInfo); override; procedure UnApply(var ARci: TGLRenderContextInfo); override; class function FriendlyName: string; override; published property InternalWidth: Integer read FWidth write SetWidth default 256; property InternalHeight: Integer read FHeight write SetHeight default 256; property InternalDepth: Integer read FDepth write SetDepth default 0; property InternalFormat: TGLInternalFormat read FInternalFormat write SetInternalFormat default tfRGBA8; (* This flag makes use render buffer as target which makes it impossible to read it as texture, but improves efficiency. *) property OnlyWrite: Boolean read FOnlyWrite write SetOnlyWrite default False; // Force targe be texture array. property Layered: Boolean read FLayered write SetLayered default False; // Force target be cube map. property CubeMap: Boolean read FCubeMap write SetCubeMap default False; // Number of samples. Positive value makes texture be multisample. property Samples: Integer read FSamples write SetSamples default -1; (* FixedSamplesLocation flag makes image will use identical sample locations and the same number of samples for all texels in the image, and the sample locations will not depend on the internalformat or size of the image. *) property FixedSamplesLocation: Boolean read FFixedSamplesLocation write SetFixedSamplesLocation default False; end; (* Swizzle the components of a texture fetches in shader or fixed-function pipeline. *) TGLTextureSwizzling = class(TGLUpdateAbleObject) private FSwizzles: TSwizzleVector; function GetSwizzle(AIndex: Integer): TGLTextureSwizzle; procedure SetSwizzle(AIndex: Integer; AValue: TGLTextureSwizzle); function StoreSwizzle(AIndex: Integer): Boolean; public constructor Create(AOwner: TPersistent); override; procedure Assign(Source: TPersistent); override; procedure WriteToFiler(AWriter: TWriter); procedure ReadFromFiler(AReader: TReader); published property RedFrom: TGLTextureSwizzle index 0 read GetSwizzle write SetSwizzle stored StoreSwizzle; property GreenFrom: TGLTextureSwizzle index 1 read GetSwizzle write SetSwizzle stored StoreSwizzle; property BlueFrom: TGLTextureSwizzle index 2 read GetSwizzle write SetSwizzle stored StoreSwizzle; property AlphaFrom: TGLTextureSwizzle index 3 read GetSwizzle write SetSwizzle stored StoreSwizzle; end; TGLTextureProperties = class(TGLLibMaterialProperty) private FLibTextureName: TGLMaterialComponentName; FLibSamplerName: TGLMaterialComponentName; FLibTexture: TGLAbstractTexture; FLibSampler: TGLTextureSampler; FTextureOffset, FTextureScale: TGLCoordinates; FTextureRotate: Single; FTextureMatrixIsIdentity: Boolean; FTextureOverride: Boolean; FTextureMatrix: TGLMatrix; FMappingMode: TGLTextureMappingMode; FEnvColor: TGLColor; FMapSCoordinates: TGLCoordinates4; FMapTCoordinates: TGLCoordinates4; FMapRCoordinates: TGLCoordinates4; FMapQCoordinates: TGLCoordinates4; FSwizzling: TGLTextureSwizzling; function GetLibTextureName: TGLMaterialComponentName; function GetLibSamplerName: TGLMaterialComponentName; procedure SetLibTextureName(const AValue: TGLMaterialComponentName); procedure SetLibSamplerName(const AValue: TGLMaterialComponentName); function GetTextureOffset: TGLCoordinates; procedure SetTextureOffset(const AValue: TGLCoordinates); function StoreTextureOffset: Boolean; function GetTextureScale: TGLCoordinates; procedure SetTextureScale(const AValue: TGLCoordinates); function StoreTextureScale: Boolean; procedure SetTextureMatrix(const AValue: TGLMatrix); procedure SetTextureRotate(AValue: Single); function StoreTextureRotate: Boolean; procedure SetMappingMode(const AValue: TGLTextureMappingMode); function GetMappingSCoordinates: TGLCoordinates4; procedure SetMappingSCoordinates(const AValue: TGLCoordinates4); function StoreMappingSCoordinates: Boolean; function GetMappingTCoordinates: TGLCoordinates4; procedure SetMappingTCoordinates(const AValue: TGLCoordinates4); function StoreMappingTCoordinates: Boolean; function GetMappingRCoordinates: TGLCoordinates4; procedure SetMappingRCoordinates(const AValue: TGLCoordinates4); function StoreMappingRCoordinates: Boolean; function GetMappingQCoordinates: TGLCoordinates4; procedure SetMappingQCoordinates(const AValue: TGLCoordinates4); function StoreMappingQCoordinates: Boolean; procedure SetSwizzling(const AValue: TGLTextureSwizzling); function StoreSwizzling: Boolean; procedure SetEnvColor(const AValue: TGLColor); procedure CalculateTextureMatrix; procedure ApplyMappingMode; procedure UnApplyMappingMode; protected procedure Loaded; override; public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure NotifyChange(Sender: TObject); override; procedure Notification(Sender: TObject; Operation: TOperation); override; function IsValid: Boolean; procedure Apply(var ARci: TGLRenderContextInfo); procedure UnApply(var ARci: TGLRenderContextInfo); property TextureMatrix: TGLMatrix read FTextureMatrix write SetTextureMatrix; published property LibTextureName: TGLMaterialComponentName read GetLibTextureName write SetLibTextureName; property LibSamplerName: TGLMaterialComponentName read GetLibSamplerName write SetLibSamplerName; property TextureOffset: TGLCoordinates read GetTextureOffset write SetTextureOffset stored StoreTextureOffset; (* Texture coordinates scaling. Scaling is applied before applying the offset, and is applied to the texture coordinates, meaning that a scale factor of (2, 2, 2) will make your texture look twice smaller. *) property TextureScale: TGLCoordinates read GetTextureScale write SetTextureScale stored StoreTextureScale; (* Texture coordinates rotating. Rotating is applied after applying offset and scale, and rotate ST direction around R axis. *) property TextureRotate: Single read FTextureRotate write SetTextureRotate stored StoreTextureRotate; // Texture Environment color. property EnvColor: TGLColor read FEnvColor write SetEnvColor; (* Texture coordinates mapping mode. This property controls automatic texture coordinates generation. *) property MappingMode: TGLTextureMappingMode read FMappingMode write SetMappingMode default tmmUser; (* Texture mapping coordinates mode for S, T, R and Q axis. This property stores the coordinates for automatic texture coordinates generation. *) property MappingSCoordinates: TGLCoordinates4 read GetMappingSCoordinates write SetMappingSCoordinates stored StoreMappingSCoordinates; property MappingTCoordinates: TGLCoordinates4 read GetMappingTCoordinates write SetMappingTCoordinates stored StoreMappingTCoordinates; property MappingRCoordinates: TGLCoordinates4 read GetMappingRCoordinates write SetMappingRCoordinates stored StoreMappingRCoordinates; property MappingQCoordinates: TGLCoordinates4 read GetMappingQCoordinates write SetMappingQCoordinates stored StoreMappingQCoordinates; // Texture color fetching parameters. property Swizzling: TGLTextureSwizzling read FSwizzling write SetSwizzling stored StoreSwizzling; end; TGLFixedFunctionProperties = class(TGLLibMaterialProperty) private FFrontProperties: TGLFaceProperties; FBackProperties: TGLFaceProperties; FDepthProperties: TGLDepthProperties; FBlendingMode: TGLBlendingMode; FBlendingParams: TGLBlendingParameters; FTexProp: TGLTextureProperties; FMaterialOptions: TGLMaterialOptions; FFaceCulling: TGLFaceCulling; FPolygonMode: TGLPolygonMode; FTextureMode: TGLTextureMode; function GetBackProperties: TGLFaceProperties; procedure SetBackProperties(AValues: TGLFaceProperties); procedure SetFrontProperties(AValues: TGLFaceProperties); procedure SetDepthProperties(AValues: TGLDepthProperties); procedure SetBlendingMode(const AValue: TGLBlendingMode); procedure SetMaterialOptions(const AValue: TGLMaterialOptions); procedure SetFaceCulling(const AValue: TGLFaceCulling); procedure SetPolygonMode(AValue: TGLPolygonMode); procedure SetBlendingParams(const AValue: TGLBlendingParameters); procedure SetTexProp(AValue: TGLTextureProperties); procedure SetTextureMode(AValue: TGLTextureMode); public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Apply(var ARci: TGLRenderContextInfo); procedure UnApply(var ARci: TGLRenderContextInfo); // Returns True if the material is blended. function Blended: Boolean; published property MaterialOptions: TGLMaterialOptions read FMaterialOptions write SetMaterialOptions default []; property BackProperties: TGLFaceProperties read GetBackProperties write SetBackProperties; property FrontProperties: TGLFaceProperties read FFrontProperties write SetFrontProperties; property DepthProperties: TGLDepthProperties read FDepthProperties write SetDepthProperties; property BlendingMode: TGLBlendingMode read FBlendingMode write SetBlendingMode default bmOpaque; property BlendingParams: TGLBlendingParameters read FBlendingParams write SetBlendingParams; property FaceCulling: TGLFaceCulling read FFaceCulling write SetFaceCulling default fcBufferDefault; property PolygonMode: TGLPolygonMode read FPolygonMode write SetPolygonMode default pmFill; property Texture: TGLTextureProperties read FTexProp write SetTexProp; // Texture application mode. property TextureMode: TGLTextureMode read FTextureMode write SetTextureMode default tmDecal; // Next pass of FFP. property NextPass; end; TGLTextureCombiner = class(TGLBaseMaterialCollectionItem) protected procedure WriteToFiler(AWriter: TWriter); override; procedure ReadFromFiler(AReader: TReader); override; private FHandle: TGLVirtualHandle; FScript: TStringList; FCommandCache: TCombinerCache; procedure SetScript(AValue: TStringList); procedure DoAllocate(Sender: TGLVirtualHandle; var handle: Cardinal); procedure DoDeallocate(Sender: TGLVirtualHandle; var handle: Cardinal); public constructor Create(AOwner: TXCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure NotifyChange(Sender: TObject); override; procedure DoOnPrepare(Sender: TGLContext); override; class function FriendlyName: string; override; published property Script: TStringList read FScript write SetScript; end; TGLASMVertexProgram = class(TGLBaseMaterialCollectionItem) protected procedure WriteToFiler(AWriter: TWriter); override; procedure ReadFromFiler(AReader: TReader); override; private FHandle: TGLARBVertexProgramHandle; FSource: TStringList; FSourceFile: string; FInfoLog: string; procedure SetSource(AValue: TStringList); procedure SetSourceFile(AValue: string); function GetHandle: TGLARBVertexProgramHandle; public constructor Create(AOwner: TXCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure DoOnPrepare(Sender: TGLContext); override; class function FriendlyName: string; override; procedure NotifyChange(Sender: TObject); override; property Handle: TGLARBVertexProgramHandle read GetHandle; published property Source: TStringList read FSource write SetSource; property SourceFile: string read FSourceFile write SetSourceFile; property InfoLog: string read FInfoLog; end; TLightDir2TexEnvColor = ( l2eNone, l2eEnvColor0, l2eEnvColor1, l2eEnvColor2, l2eEnvColor3 ); TGLMultitexturingProperties = class(TGLLibMaterialProperty) private FLibCombiner: TGLTextureCombiner; FLibAsmProg: TGLASMVertexProgram; FLibCombinerName: TGLMaterialComponentName; FLibAsmProgName: TGLMaterialComponentName; FTexProps: array[0..3] of TGLTextureProperties; FTextureMode: TGLTextureMode; FLightDir: TLightDir2TexEnvColor; FLightSourceIndex: Integer; function GetLibCombinerName: string; function GetLibAsmProgName: string; procedure SetLibCombinerName(const AValue: string); procedure SetLibAsmProgName(const AValue: string); function GetTexProps(AIndex: Integer): TGLTextureProperties; procedure SetTexProps(AIndex: Integer; AValue: TGLTextureProperties); procedure SetTextureMode(AValue: TGLTextureMode); procedure SetLightSourceIndex(AValue: Integer); protected procedure Loaded; override; public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure Notification(Sender: TObject; Operation: TOperation); override; function IsValid: Boolean; procedure Apply(var ARci: TGLRenderContextInfo); procedure UnApply(var ARci: TGLRenderContextInfo); published property LibCombinerName: string read GetLibCombinerName write SetLibCombinerName; property LibAsmProgName: string read GetLibAsmProgName write SetLibAsmProgName; property Texture0: TGLTextureProperties index 0 read GetTexProps write SetTexProps; property Texture1: TGLTextureProperties index 1 read GetTexProps write SetTexProps; property Texture2: TGLTextureProperties index 2 read GetTexProps write SetTexProps; property Texture3: TGLTextureProperties index 3 read GetTexProps write SetTexProps; // Texture application mode. property TextureMode: TGLTextureMode read FTextureMode write SetTextureMode default tmDecal; (* Pass light source direction to enviroment color of choosen texture. Vector in model space. *) property LightDirTo: TLightDir2TexEnvColor read FLightDir write FLightDir default l2eNone; // Specify index of light source for LightDirTo. property LightSourceIndex: Integer read FLightSourceIndex write SetLightSourceIndex default 0; // Next pass of combiner. property NextPass; end; TGLShaderType = ( shtVertex, shtControl, shtEvaluation, shtGeometry, shtFragment ); TGLShaderEx = class(TGLBaseMaterialCollectionItem) protected procedure WriteToFiler(AWriter: TWriter); override; procedure ReadFromFiler(AReader: TReader); override; private FHandle: array[TGLShaderType] of TGLShaderHandle; FSource: TStringList; FSourceFile: string; FShaderType: TGLShaderType; FInfoLog: string; FGeometryInput: TGLgsInTypes; FGeometryOutput: TGLgsOutTypes; FGeometryVerticesOut: Integer; procedure SetSource(AValue: TStringList); procedure SetSourceFile(AValue: string); procedure SetShaderType(AValue: TGLShaderType); procedure SetGeometryInput(AValue: TGLgsInTypes); procedure SetGeometryOutput(AValue: TGLgsOutTypes); procedure SetGeometryVerticesOut(AValue: Integer); function GetHandle: TGLShaderHandle; public constructor Create(AOwner: TXCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure DoOnPrepare(Sender: TGLContext); override; class function FriendlyName: string; override; procedure NotifyChange(Sender: TObject); override; property Handle: TGLShaderHandle read GetHandle; published property Source: TStringList read FSource write SetSource; property SourceFile: string read FSourceFile write SetSourceFile; property ShaderType: TGLShaderType read FShaderType write SetShaderType default shtVertex; property InfoLog: string read FInfoLog; property GeometryInput: TGLgsInTypes read FGeometryInput write SetGeometryInput default gsInPoints; property GeometryOutput: TGLgsOutTypes read FGeometryOutput write SetGeometryOutput default gsOutPoints; property GeometryVerticesOut: Integer read FGeometryVerticesOut write SetGeometryVerticesOut default 1; end; TGLAbstractShaderUniform = class(TGLUpdateAbleObject, IShaderParameter) protected FName: string; FNameHashCode: Integer; FType: TGLSLDataType; FSamplerType: TGLSLSamplerType; function GetName: string; function GetGLSLType: TGLSLDataType; function GetGLSLSamplerType: TGLSLSamplerType; function GetAutoSetMethod: string; virtual; function GetTextureName: string; virtual; function GetSamplerName: string; virtual; function GetTextureSwizzle: TSwizzleVector; virtual; procedure SetTextureName(const AValue: string); virtual; procedure SetSamplerName(const AValue: string); virtual; procedure SetAutoSetMethod(const AValue: string); virtual; procedure SetTextureSwizzle(const AValue: TSwizzleVector); virtual; function GetFloat: Single; virtual; function GetVec2: TVector2f; virtual; function GetVec3: TVector3f; virtual; function GetVec4: TGLVector; virtual; function GetInt: TGLint; virtual; function GetIVec2: TVector2i; virtual; function GetIVec3: TVector3i; virtual; function GetIVec4: TVector4i; virtual; function GetUInt: Cardinal; virtual; function GetUVec2: TVector2ui; virtual; function GetUVec3: TVector3ui; virtual; function GetUVec4: TVector4ui; virtual; procedure SetFloat(const Value: TGLFloat); virtual; procedure SetVec2(const Value: TVector2f); virtual; procedure SetVec3(const Value: TVector3f); virtual; procedure SetVec4(const Value: TVector4f); virtual; procedure SetInt(const Value: Integer); virtual; procedure SetIVec2(const Value: TVector2i); virtual; procedure SetIVec3(const Value: TVector3i); virtual; procedure SetIVec4(const Value: TVector4i); virtual; procedure SetUInt(const Value: Cardinal); virtual; procedure SetUVec2(const Value: TVector2ui); virtual; procedure SetUVec3(const Value: TVector3ui); virtual; procedure SetUVec4(const Value: TVector4ui); virtual; function GetMat2: TMatrix2f; virtual; function GetMat3: TMatrix3f; virtual; function GetMat4: TMatrix4f; virtual; procedure SetMat2(const Value: TMatrix2f); virtual; procedure SetMat3(const Value: TMatrix3f); virtual; procedure SetMat4(const Value: TMatrix4f); virtual; procedure SetFloatArray(const Values: PGLFloat; Count: Integer); virtual; procedure SetIntArray(const Values: PGLInt; Count: Integer); virtual; procedure SetUIntArray(const Values: PGLUInt; Count: Integer); virtual; procedure WriteToFiler(AWriter: TWriter); virtual; procedure ReadFromFiler(AReader: TReader); virtual; procedure Apply(var ARci: TGLRenderContextInfo); virtual; end; CGLAbstractShaderUniform = class of TGLAbstractShaderUniform; TGLShaderUniform = class(TGLAbstractShaderUniform, IShaderParameter) protected FLocation: Integer; FStoreProgram: Cardinal; FAutoSet: TUniformAutoSetMethod; function GetProgram: Cardinal; inline; procedure PushProgram; inline; procedure PopProgram; inline; function GetFloat: Single; override; function GetVec2: TVector2f; override; function GetVec3: TVector3f; override; function GetVec4: TGLVector; override; function GetInt: TGLInt; override; function GetIVec2: TVector2i; override; function GetIVec3: TVector3i; override; function GetIVec4: TVector4i; override; function GetUInt: Cardinal; override; function GetUVec2: TVector2ui; override; function GetUVec3: TVector3ui; override; function GetUVec4: TVector4ui; override; procedure SetFloat(const Value: TGLFloat); override; procedure SetVec2(const Value: TVector2f); override; procedure SetVec3(const Value: TVector3f); override; procedure SetVec4(const Value: TVector4f); override; procedure SetInt(const Value: Integer); override; procedure SetIVec2(const Value: TVector2i); override; procedure SetIVec3(const Value: TVector3i); override; procedure SetIVec4(const Value: TVector4i); override; procedure SetUInt(const Value: Cardinal); override; procedure SetUVec2(const Value: TVector2ui); override; procedure SetUVec3(const Value: TVector3ui); override; procedure SetUVec4(const Value: TVector4ui); override; function GetMat2: TMatrix2f; override; function GetMat3: TMatrix3f; override; function GetMat4: TMatrix4f; override; procedure SetMat2(const Value: TMatrix2f); override; procedure SetMat3(const Value: TMatrix3f); override; procedure SetMat4(const Value: TMatrix4f); override; function GetAutoSetMethod: string; override; procedure SetAutoSetMethod(const AValue: string); override; procedure WriteToFiler(AWriter: TWriter); override; procedure ReadFromFiler(AReader: TReader); override; public procedure SetFloatArray(const Values: PGLFloat; Count: Integer); override; procedure SetIntArray(const Values: PGLInt; Count: Integer); override; procedure SetUIntArray(const Values: PGLUInt; Count: Integer); override; procedure Assign(Source: TPersistent); override; procedure Apply(var ARci: TGLRenderContextInfo); override; property Name: string read GetName; property Location: Integer read FLocation; property GLSLType: TGLSLDataType read GetGLSLType; end; TGLShaderUniformDSA = class(TGLShaderUniform) protected procedure SetFloat(const Value: TGLFloat); override; procedure SetVec2(const Value: TVector2f); override; procedure SetVec3(const Value: TVector3f); override; procedure SetVec4(const Value: TVector4f); override; procedure SetInt(const Value: Integer); override; procedure SetIVec2(const Value: TVector2i); override; procedure SetIVec3(const Value: TVector3i); override; procedure SetIVec4(const Value: TVector4i); override; procedure SetUInt(const Value: Cardinal); override; procedure SetUVec2(const Value: TVector2ui); override; procedure SetUVec3(const Value: TVector3ui); override; procedure SetUVec4(const Value: TVector4ui); override; procedure SetMat2(const Value: TMatrix2f); override; procedure SetMat3(const Value: TMatrix3f); override; procedure SetMat4(const Value: TMatrix4f); override; public procedure SetFloatArray(const Values: PGLFloat; Count: Integer); override; procedure SetIntArray(const Values: PGLInt; Count: Integer); override; procedure SetUIntArray(const Values: PGLUInt; Count: Integer); override; end; TGLShaderUniformTexture = class(TGLShaderUniform) private FLibTexture: TGLAbstractTexture; FLibSampler: TGLTextureSampler; FTarget: TGLTextureTarget; FSwizzling: TSwizzleVector; protected FLibTexureName: TGLMaterialComponentName; FLibSamplerName: TGLMaterialComponentName; function GetTextureName: string; override; function GetSamplerName: string; override; function GetTextureSwizzle: TSwizzleVector; override; procedure SetTextureName(const AValue: string); override; procedure SetSamplerName(const AValue: string); override; procedure SetTextureSwizzle(const AValue: TSwizzleVector); override; procedure WriteToFiler(AWriter: TWriter); override; procedure ReadFromFiler(AReader: TReader); override; procedure Loaded; public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Notification(Sender: TObject; Operation: TOperation); override; procedure Apply(var ARci: TGLRenderContextInfo); override; property LibTextureName: TGLMaterialComponentName read GetTextureName write SetTextureName; property LibSamplerName: TGLMaterialComponentName read GetSamplerName write SetSamplerName; property GLSLSampler: TGLSLSamplerType read GetGLSLSamplerType; property Swizzling: TSwizzleVector read GetTextureSwizzle write SetTextureSwizzle; end; TGLBaseShaderModel = class(TGLLibMaterialProperty) protected FHandle: TGLProgramHandle; FLibShaderName: array[TGLShaderType] of string; FShaders: array[TGLShaderType] of TGLShaderEx; FIsValid: Boolean; FInfoLog: string; FUniforms: TGLPersistentObjectList; FAutoFill: Boolean; function GetLibShaderName(AType: TGLShaderType): string; procedure SetLibShaderName(AType: TGLShaderType; const AValue: string); function GetUniform(const AName: string): IShaderParameter; class procedure ReleaseUniforms(AList: TGLPersistentObjectList); property LibVertexShaderName: TGLMaterialComponentName index shtVertex read GetLibShaderName write SetLibShaderName; property LibFragmentShaderName: TGLMaterialComponentName index shtFragment read GetLibShaderName write SetLibShaderName; property LibGeometryShaderName: TGLMaterialComponentName index shtGeometry read GetLibShaderName write SetLibShaderName; property LibTessEvalShaderName: TGLMaterialComponentName index shtEvaluation read GetLibShaderName write SetLibShaderName; property LibTessControlShaderName: TGLMaterialComponentName index shtControl read GetLibShaderName write SetLibShaderName; procedure DefineProperties(Filer: TFiler); override; procedure ReadUniforms(AStream: TStream); procedure WriteUniforms(AStream: TStream); procedure Loaded; override; class function IsSupported: Boolean; virtual; abstract; public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure NotifyChange(Sender: TObject); override; procedure Notification(Sender: TObject; Operation: TOperation); override; procedure DoOnPrepare(Sender: TGLContext); procedure Apply(var ARci: TGLRenderContextInfo); virtual; procedure UnApply(var ARci: TGLRenderContextInfo); virtual; procedure GetUniformNames(Proc: TGetStrProc); property Handle: TGLProgramHandle read FHandle; property IsValid: Boolean read FIsValid; property Uniforms[const AName: string]: IShaderParameter read GetUniform; published // Compilation info log for design time property InfoLog: string read FInfoLog; // Turn on autofill of uniforms property AutoFillOfUniforms: Boolean read FAutoFill write FAutoFill stored False; property NextPass; end; TGLShaderModel3 = class(TGLBaseShaderModel) public class function IsSupported: Boolean; override; published property LibVertexShaderName; property LibFragmentShaderName; end; TGLShaderModel4 = class(TGLBaseShaderModel) public class function IsSupported: Boolean; override; published property LibVertexShaderName; property LibGeometryShaderName; property LibFragmentShaderName; end; TGLShaderModel5 = class(TGLBaseShaderModel) public procedure Apply(var ARci: TGLRenderContextInfo); override; procedure UnApply(var ARci: TGLRenderContextInfo); override; class function IsSupported: Boolean; override; published property LibTessControlShaderName; property LibTessEvalShaderName; property LibVertexShaderName; property LibGeometryShaderName; property LibFragmentShaderName; end; TGLLibMaterialEx = class(TGLAbstractLibMaterial) private FHandle: TGLVirtualHandle; FApplicableLevel: TGLMaterialLevel; FSelectedLevel: TGLMaterialLevel; FFixedFunc: TGLFixedFunctionProperties; FMultitexturing: TGLMultitexturingProperties; FSM3: TGLShaderModel3; FSM4: TGLShaderModel4; FSM5: TGLShaderModel5; FOnAsmProgSetting: TOnAsmProgSetting; FOnSM3UniformInit: TOnUniformInitialize; FOnSM3UniformSetting: TOnUniformSetting; FOnSM4UniformInit: TOnUniformInitialize; FOnSM4UniformSetting: TOnUniformSetting; FOnSM5UniformInit: TOnUniformInitialize; FOnSM5UniformSetting: TOnUniformSetting; FNextPass: TGLLibMaterialEx; FStoreAmalgamating: Boolean; procedure SetLevel(AValue: TGLMaterialLevel); procedure SetFixedFunc(AValue: TGLFixedFunctionProperties); procedure SetMultitexturing(AValue: TGLMultitexturingProperties); procedure SetSM3(AValue: TGLShaderModel3); procedure SetSM4(AValue: TGLShaderModel4); procedure SetSM5(AValue: TGLShaderModel5); procedure DoAllocate(Sender: TGLVirtualHandle; var handle: Cardinal); procedure DoDeallocate(Sender: TGLVirtualHandle; var handle: Cardinal); protected procedure Loaded; override; procedure RemoveDefferedInit; procedure DoOnPrepare(Sender: TGLContext); public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure NotifyChange(Sender: TObject); override; procedure Apply(var ARci: TGLRenderContextInfo); override; function UnApply(var ARci: TGLRenderContextInfo): Boolean; override; function Blended: Boolean; override; published property ApplicableLevel: TGLMaterialLevel read FApplicableLevel write SetLevel default mlAuto; property SelectedLevel: TGLMaterialLevel read FSelectedLevel; property FixedFunction: TGLFixedFunctionProperties read FFixedFunc write SetFixedFunc; property Multitexturing: TGLMultitexturingProperties read FMultitexturing write SetMultitexturing; property ShaderModel3: TGLShaderModel3 read FSM3 write SetSM3; property ShaderModel4: TGLShaderModel4 read FSM4 write SetSM4; property ShaderModel5: TGLShaderModel5 read FSM5 write SetSM5; // Asm vertex program event property OnAsmProgSetting: TOnAsmProgSetting read FOnAsmProgSetting write FOnAsmProgSetting; // Shader model 3 event property OnSM3UniformInitialize: TOnUniformInitialize read FOnSM3UniformInit write FOnSM3UniformInit; property OnSM3UniformSetting: TOnUniformSetting read FOnSM3UniformSetting write FOnSM3UniformSetting; // Shader model 4 event property OnSM4UniformInitialize: TOnUniformInitialize read FOnSM4UniformInit write FOnSM4UniformInit; property OnSM4UniformSetting: TOnUniformSetting read FOnSM4UniformSetting write FOnSM4UniformSetting; // Shader model 5 event property OnSM5UniformInitialize: TOnUniformInitialize read FOnSM5UniformInit write FOnSM5UniformInit; property OnSM5UniformSetting: TOnUniformSetting read FOnSM5UniformSetting write FOnSM5UniformSetting; end; TGLLibMaterialsEx = class(TGLAbstractLibMaterials) protected procedure SetItems(AIndex: Integer; const AValue: TGLLibMaterialEx); function GetItems(AIndex: Integer): TGLLibMaterialEx; public constructor Create(AOwner: TComponent); function MaterialLibrary: TGLMaterialLibraryEx; function IndexOf(const Item: TGLLibMaterialEx): Integer; function Add: TGLLibMaterialEx; function FindItemID(ID: Integer): TGLLibMaterialEx; property Items[index: Integer]: TGLLibMaterialEx read GetItems write SetItems; default; function GetLibMaterialByName(const AName: TGLLibMaterialName): TGLLibMaterialEx; end; TGLMatLibComponents = class(TXCollection) protected function GetItems(index: Integer): TGLBaseMaterialCollectionItem; public function GetNamePath: string; override; class function ItemsClass: TXCollectionItemClass; override; property Items[index: Integer]: TGLBaseMaterialCollectionItem read GetItems; default; function GetItemByName(const AName: TGLMaterialComponentName): TGLBaseMaterialCollectionItem; function GetTextureByName(const AName: TGLMaterialComponentName): TGLAbstractTexture; function GetAttachmentByName(const AName: TGLMaterialComponentName): TGLFrameBufferAttachment; function GetSamplerByName(const AName: TGLMaterialComponentName): TGLTextureSampler; function GetCombinerByName(const AName: TGLMaterialComponentName): TGLTextureCombiner; function GetShaderByName(const AName: TGLMaterialComponentName): TGLShaderEx; function GetAsmProgByName(const AName: TGLMaterialComponentName): TGLASMVertexProgram; function MakeUniqueName(const AName: TGLMaterialComponentName): TGLMaterialComponentName; end; TGLMaterialLibraryEx = class(TGLAbstractMaterialLibrary) private FComponents: TGLMatLibComponents; protected procedure Loaded; override; function GetMaterials: TGLLibMaterialsEx; procedure SetMaterials(AValue: TGLLibMaterialsEx); function StoreMaterials: Boolean; procedure SetComponents(AValue: TGLMatLibComponents); procedure DefineProperties(Filer: TFiler); override; procedure WriteComponents(AStream: TStream); procedure ReadComponents(AStream: TStream); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure GetNames(Proc: TGetStrProc; AClass: CGLBaseMaterialCollectionItem); overload; function AddTexture(const AName: TGLMaterialComponentName): TGLTextureImageEx; function AddAttachment(const AName: TGLMaterialComponentName): TGLFrameBufferAttachment; function AddSampler(const AName: TGLMaterialComponentName): TGLTextureSampler; function AddCombiner(const AName: TGLMaterialComponentName): TGLTextureCombiner; function AddShader(const AName: TGLMaterialComponentName): TGLShaderEx; function AddAsmProg(const AName: TGLMaterialComponentName): TGLASMVertexProgram; procedure SetLevelForAll(const ALevel: TGLMaterialLevel); published // The materials collection. property Materials: TGLLibMaterialsEx read GetMaterials write SetMaterials stored StoreMaterials; property Components: TGLMatLibComponents read FComponents write SetComponents; property TexturePaths; end; procedure RegisterGLMaterialExNameChangeEvent(AEvent: TNotifyEvent); procedure DeRegisterGLMaterialExNameChangeEvent(AEvent: TNotifyEvent); //================================================================= implementation //================================================================= const cTextureMagFilter: array[maNearest..maLinear] of Cardinal = (GL_NEAREST, GL_LINEAR); cTextureMinFilter: array[miNearest..miLinearMipmapLinear] of Cardinal = (GL_NEAREST, GL_LINEAR, GL_NEAREST_MIPMAP_NEAREST, GL_LINEAR_MIPMAP_NEAREST, GL_NEAREST_MIPMAP_LINEAR, GL_LINEAR_MIPMAP_LINEAR); cTextureWrapMode: array[twRepeat..twMirrorClampToBorder] of Cardinal = (GL_REPEAT, GL_CLAMP_TO_EDGE, GL_CLAMP_TO_BORDER, GL_MIRRORED_REPEAT, GL_MIRROR_CLAMP_TO_EDGE_ATI, GL_MIRROR_CLAMP_TO_BORDER_EXT); cTextureCompareMode: array[tcmNone..tcmCompareRtoTexture] of Cardinal = (GL_NONE, GL_COMPARE_R_TO_TEXTURE); cSamplerToTexture: array[TGLSLSamplerType] of TGLTextureTarget = ( ttNoShape, ttTexture1D, ttTexture2D, ttTexture3D, ttTextureCube, ttTexture1D, ttTexture2D, ttTexture1DArray, ttTexture2DArray, ttTexture1DArray, ttTexture1DArray, ttTextureCube, ttTexture1D, ttTexture2D, ttTexture3D, ttTextureCube, ttTexture1DArray, ttTexture2DArray, ttTexture1D, ttTexture2D, ttTexture3D, ttTextureCube, ttTexture1DArray, ttTexture2DArray, ttTextureRect, ttTextureRect, ttTextureBuffer, ttTextureRect, ttTextureBuffer, ttTextureRect, ttTextureBuffer, ttTexture2DMultisample, ttTexture2DMultisample, ttTexture2DMultisample, ttTexture2DMultisampleArray, ttTexture2DMultisampleArray, ttTexture2DMultisample ); cTextureSwizzle: array[TGLTextureSwizzle] of Cardinal = ( GL_RED, GL_GREEN, GL_BLUE, GL_ALPHA, GL_ZERO, GL_ONE ); const cTextureMode: array[TGLTextureMode] of Cardinal = (GL_DECAL, GL_MODULATE, GL_BLEND, GL_REPLACE, GL_ADD); const cShaderTypeName: array[TGLShaderType] of string = ('vertex', 'control', 'evaluation', 'geomtery', 'fragment'); type TFriendlyImage = class(TGLBaseImage); TStandartUniformAutoSetExecutor = class public constructor Create; procedure SetModelMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetViewMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetProjectionMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetInvModelMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetModelViewMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetNormalModelMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetInvModelViewMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetViewProjectionMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetWorldViewProjectionMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetCameraPosition(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); // Lighting procedure SetLightSource0Position(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); // Material procedure SetMaterialFrontAmbient(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialFrontDiffuse(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialFrontSpecular(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialFrontEmission(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialFrontShininess(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialBackAmbient(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialBackDiffuse(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialBackSpecular(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialBackShininess(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); procedure SetMaterialBackEmission(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); end; var vGLMaterialExNameChangeEvent: TNotifyEvent; vStandartUniformAutoSetExecutor: TStandartUniformAutoSetExecutor; vStoreBegin: procedure(mode: Cardinal);{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} procedure RegisterGLMaterialExNameChangeEvent(AEvent: TNotifyEvent); begin vGLMaterialExNameChangeEvent := AEvent; end; procedure DeRegisterGLMaterialExNameChangeEvent(AEvent: TNotifyEvent); begin vGLMaterialExNameChangeEvent := nil; end; function ComputeNameHashKey( const AName: string): Integer; var i, n: Integer; begin n := Length(AName); Result := n; for i := 1 to n do Result := (Result shl 1) + Byte(AName[i]); end; procedure Div2(var Value: Integer); inline; begin Value := Value div 2; if Value = 0 then Value := 1; end; function CalcTextureLevelNumber(ATarget: TGLTextureTarget; w, h, d: Integer): Integer; begin Result := 0; case ATarget of ttNoShape: ; ttTexture1D, ttTexture1DArray, ttTextureCube, ttTextureCubeArray: repeat Inc(Result); Div2(w); until w <= 1; ttTexture2D, ttTexture2DArray: repeat Inc(Result); Div2(w); Div2(h); until (w <= 1) and (h <= 1); ttTexture3D: repeat Inc(Result); Div2(w); Div2(h); Div2(d); until (w <= 1) and (h <= 1) and (d <= 1); ttTextureRect, ttTextureBuffer, ttTexture2DMultisample, ttTexture2DMultisampleArray: Result := 1; end; end; destructor TGLBaseMaterialCollectionItem.Destroy; var I: Integer; begin if Assigned(FUserList) then begin FNotifying := True; for I := FUserList.Count - 1 downto 0 do TGLLibMaterialProperty(FUserList[I]).Notification(Self, opRemove); FreeAndNil(FUserList); end; inherited; end; function TGLBaseMaterialCollectionItem.GetMaterialLibrary: TGLAbstractMaterialLibrary; begin Result := TGLAbstractMaterialLibrary(TGLMatLibComponents(Owner).Owner); end; function TGLBaseMaterialCollectionItem.GetMaterialLibraryEx: TGLMaterialLibraryEx; begin Result := TGLMaterialLibraryEx(TGLMatLibComponents(Owner).Owner); end; function TGLBaseMaterialCollectionItem.GetUserCount: Integer; begin if Assigned(FUserList) then Result := FUserList.Count else Result := 0; end; function TGLBaseMaterialCollectionItem.GetUserList: TGLPersistentObjectList; begin if FUserList = nil then begin FUserList := TGLPersistentObjectList.Create; FNotifying := False; end; Result := FUserList; end; procedure TGLBaseMaterialCollectionItem.NotifyChange(Sender: TObject); var I: Integer; begin if FNotifying then exit; FNotifying := True; if GetUserCount > 0 then for I := 0 to FUserList.Count - 1 do TGLUpdateAbleObject(FUserList[I]).NotifyChange(Self); FNotifying := False; end; procedure TGLBaseMaterialCollectionItem.RegisterUser( AUser: TGLUpdateAbleObject); begin if not FNotifying and (UserList.IndexOf(AUser) < 0) then UserList.Add(AUser); end; procedure TGLBaseMaterialCollectionItem.UnregisterUser( AUser: TGLUpdateAbleObject); begin if not FNotifying then UserList.Remove(AUser); end; procedure TGLBaseMaterialCollectionItem.SetName(const AValue: string); begin if AValue <> Name then begin if not IsValidIdent(AValue) then begin if IsDesignTime then InformationDlg(AValue + ' - is not valid component name'); exit; end; if not (csLoading in MaterialLibrary.ComponentState) then begin if TGLMatLibComponents(Owner).GetItemByName(AValue) <> Self then inherited SetName(TGLMatLibComponents(Owner).MakeUniqueName(AValue)) else inherited SetName(AValue); end else inherited SetName(AValue); FNameHashKey := ComputeNameHashKey(Name); // Notify users NotifyChange(Self); // Notify designer if Assigned(vGLMaterialExNameChangeEvent) then vGLMaterialExNameChangeEvent(Self); end; end; procedure TGLFixedFunctionProperties.Apply(var ARci: TGLRenderContextInfo); begin with ARci.GLStates do begin Disable(stColorMaterial); PolygonMode := FPolygonMode; // Fixed functionality state if True{ not ARci.GLStates.ForwardContext} then begin // Lighting switch if (moNoLighting in MaterialOptions) or not ARci.bufferLighting then begin Disable(stLighting); FFrontProperties.ApplyNoLighting(ARci, cmFront); end else begin Enable(stLighting); FFrontProperties.Apply(ARci, cmFront); end; if FPolygonMode = pmLines then Disable(stLineStipple); // Fog switch if (moIgnoreFog in MaterialOptions) or not ARci.bufferFog then Disable(stFog) else Enable(stFog); end; // Apply FaceCulling and BackProperties (if needs be) case FFaceCulling of fcBufferDefault: begin if ARci.bufferFaceCull then Enable(stCullFace) else Disable(stCullFace); BackProperties.Apply(ARci, cmBack); end; fcCull: Enable(stCullFace); fcNoCull: begin Disable(stCullFace); BackProperties.Apply(ARci, cmBack); end; end; // note: Front + Back with different PolygonMode are no longer supported. // Currently state cache just ignores back facing mode changes, changes to // front affect both front + back PolygonMode // Apply Blending mode if not ARci.ignoreBlendingRequests then case FBlendingMode of bmOpaque: begin Disable(stBlend); Disable(stAlphaTest); end; bmTransparency: begin Enable(stBlend); Enable(stAlphaTest); SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha); SetGLAlphaFunction(cfGreater, 0); end; bmAdditive: begin Enable(stBlend); Enable(stAlphaTest); SetBlendFunc(bfSrcAlpha, bfOne); SetGLAlphaFunction(cfGreater, 0); end; bmAlphaTest50: begin Disable(stBlend); Enable(stAlphaTest); SetGLAlphaFunction(cfGEqual, 0.5); end; bmAlphaTest100: begin Disable(stBlend); Enable(stAlphaTest); SetGLAlphaFunction(cfGEqual, 1.0); end; bmModulate: begin Enable(stBlend); Enable(stAlphaTest); SetBlendFunc(bfDstColor, bfZero); SetGLAlphaFunction(cfGreater, 0); end; bmCustom: begin FBlendingParams.Apply(ARci); end; end; // Apply depth properties if not ARci.ignoreDepthRequests then FDepthProperties.Apply(ARci); // Apply texturing if ARci.currentMaterialLevel = mlFixedFunction then begin if FTexProp.Enabled and FTexProp.IsValid then begin ARci.GLStates.ActiveTexture := 0; FTexProp.Apply(ARci); gl.TexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, cTextureMode[FTextureMode]); end; end; end; end; procedure TGLFixedFunctionProperties.Assign(Source: TPersistent); var LFFP: TGLFixedFunctionProperties; begin if Source is TGLFixedFunctionProperties then begin LFFP := TGLFixedFunctionProperties(Source); if Assigned(LFFP.FBackProperties) then BackProperties.Assign(LFFP.BackProperties) else FreeAndNil(FBackProperties); FFrontProperties.Assign(LFFP.FFrontProperties); FPolygonMode := LFFP.FPolygonMode; FBlendingMode := LFFP.FBlendingMode; FMaterialOptions := LFFP.FMaterialOptions; FFaceCulling := LFFP.FFaceCulling; FDepthProperties.Assign(LFFP.FDepthProperties); FTexProp.Assign(LFFP.FTexProp); FTextureMode := LFFP.TextureMode; NotifyChange(Self); end; inherited; end; function TGLFixedFunctionProperties.Blended: Boolean; begin Result := not (FBlendingMode in [bmOpaque, bmAlphaTest50, bmAlphaTest100, bmCustom]); end; constructor TGLFixedFunctionProperties.Create(AOwner: TPersistent); begin inherited; FFrontProperties := TGLFaceProperties.Create(Self); FFaceCulling := fcBufferDefault; FPolygonMode := pmFill; FBlendingParams := TGLBlendingParameters.Create(Self); FDepthProperties := TGLDepthProperties.Create(Self); FTexProp := TGLTextureProperties.Create(Self); FTextureMode := tmDecal; FEnabled := True; end; destructor TGLFixedFunctionProperties.Destroy; begin FFrontProperties.Destroy; FBackProperties.Free; FDepthProperties.Destroy; FBlendingParams.Destroy; FTexProp.Destroy; inherited; end; function TGLFixedFunctionProperties.GetBackProperties: TGLFaceProperties; begin if not Assigned(FBackProperties) then FBackProperties := TGLFaceProperties.Create(Self); Result := FBackProperties; end; procedure TGLFixedFunctionProperties.SetBackProperties(AValues: TGLFaceProperties); begin BackProperties.Assign(AValues); NotifyChange(Self); end; procedure TGLFixedFunctionProperties.SetBlendingMode(const AValue: TGLBlendingMode); begin if AValue <> FBlendingMode then begin FBlendingMode := AValue; NotifyChange(Self); end; end; procedure TGLFixedFunctionProperties.SetBlendingParams(const AValue: TGLBlendingParameters); begin FBlendingParams.Assign(AValue); NotifyChange(Self); end; procedure TGLFixedFunctionProperties.SetDepthProperties(AValues: TGLDepthProperties); begin FDepthProperties.Assign(AValues); NotifyChange(Self); end; procedure TGLFixedFunctionProperties.SetTexProp(AValue: TGLTextureProperties); begin FTexProp.Assign(AValue); end; procedure TGLFixedFunctionProperties.SetTextureMode(AValue: TGLTextureMode); begin if AValue <> FTextureMode then begin FTextureMode := AValue; NotifyChange(Self); end; end; procedure TGLFixedFunctionProperties.SetFaceCulling(const AValue: TGLFaceCulling); begin if AValue <> FFaceCulling then begin FFaceCulling := AValue; NotifyChange(Self); end; end; procedure TGLFixedFunctionProperties.SetFrontProperties(AValues: TGLFaceProperties); begin FFrontProperties.Assign(AValues); NotifyChange(Self); end; procedure TGLFixedFunctionProperties.SetMaterialOptions(const AValue: TGLMaterialOptions); begin if AValue <> FMaterialOptions then begin FMaterialOptions := AValue; NotifyChange(Self); end; end; procedure TGLFixedFunctionProperties.SetPolygonMode(AValue: TGLPolygonMode); begin if AValue <> FPolygonMode then begin FPolygonMode := AValue; NotifyChange(Self); end; end; procedure TGLFixedFunctionProperties.UnApply(var ARci: TGLRenderContextInfo); begin if FTexProp.Enabled and FTexProp.IsValid then FTexProp.UnApply(ARci); end; function TGLAbstractTexture.GetTextureTarget: TGLTextureTarget; begin Result := FHandle.Target; end; procedure TGLTextureImageEx.Apply(var ARci: TGLRenderContextInfo); begin if FIsValid then begin // Just bind with ARci.GLStates do begin TextureBinding[ActiveTexture, FHandle.Target] := FHandle.Handle; ActiveTextureEnabled[FHandle.Target] := True; end; if not IsDesignTime then begin if not FUseStreaming and Assigned(FImage) then begin Inc(FApplyCounter); if FApplyCounter > 16 then FreeAndNil(FImage); end; if FUseStreaming then begin StreamTransfer; end; end; end else with ARci.GLStates do TextureBinding[ActiveTexture, FHandle.Target] := 0; end; procedure TGLTextureImageEx.Assign(Source: TPersistent); var LTexture: TGLTextureImageEx; begin if Source is TGLTextureImageEx then begin LTexture := TGLTextureImageEx(Source); FCompression := LTexture.FCompression; if Assigned(LTexture.FImage) then begin if not Assigned(FImage) then FImage := TGLImage.Create; FImage.Assign(LTexture.FImage); end else FreeAndNil(FImage); FImageAlpha := LTexture.FImageAlpha; FImageBrightness := LTexture.FImageBrightness; FImageGamma := LTexture.FImageGamma; FHeightToNormalScale := LTexture.FHeightToNormalScale; FSourceFile := LTexture.FSourceFile; NotifyChange(Self); end; inherited; end; constructor TGLTextureImageEx.Create(AOwner: TXCollection); begin inherited; FDefferedInit := False; FHandle := TGLTextureHandle.Create; FHandle.OnPrapare := DoOnPrepare; FCompression := tcDefault; FImageAlpha := tiaDefault; FImageBrightness := 1.0; FImageGamma := 1.0; FHeightToNormalScale := 1.0; FInternalFormat := tfRGBA8; FInternallyStored := False; FMipGenMode := mgmOnFly; FUseStreaming := False; Name := TGLMatLibComponents(AOwner).MakeUniqueName('Texture'); end; destructor TGLTextureImageEx.Destroy; begin FHandle.Destroy; FImage.Free; inherited; end; procedure TGLTextureImageEx.NotifyChange(Sender: TObject); begin FHandle.NotifyChangesOfData; inherited; end; procedure TGLTextureImageEx.DoOnPrepare(Sender: TGLContext); var LTarget: TGLTextureTarget; rowSize: Integer; begin if IsDesignTime and FDefferedInit then exit; FHandle.AllocateHandle; if not FHandle.IsDataNeedUpdate then exit; try PrepareImage; // Target LTarget := FImage.GetTextureTarget; // Check supporting if not IsTargetSupported(LTarget) or not IsFormatSupported(FInternalFormat) then Abort; if (FHandle.Target <> LTarget) and (FHandle.Target <> ttNoShape) then begin FHandle.DestroyHandle; FHandle.AllocateHandle; end; FHandle.Target := LTarget; // Check streaming support if not IsDesignTime then begin FUseStreaming := FUseStreaming and TGLUnpackPBOHandle.IsSupported; FUseStreaming := FUseStreaming and IsServiceContextAvaible; FUseStreaming := FUseStreaming and (LTarget = ttTexture2D); end; with Sender.GLStates do begin ActiveTextureEnabled[FHandle.Target] := True; TextureBinding[ActiveTexture, FHandle.Target] := FHandle.Handle; UnpackRowLength := 0; UnpackSkipRows := 0; UnpackSkipPixels := 0; rowSize := FImage.LevelWidth[0] * FImage.ElementSize; if (rowSize mod 8 = 0) and (FImage.ElementSize > 4) then UnpackAlignment := 8 else if rowSize mod 4 = 0 then UnpackAlignment := 4 else if rowSize mod 2 = 0 then UnpackAlignment := 2 else UnpackAlignment := 1; end; if not IsDesignTime and FUseStreaming then begin TFriendlyImage(FImage).StartStreaming; FLastTime := AppTime; StreamTransfer; FHandle.NotifyDataUpdated; end else FullTransfer; Sender.GLStates.ActiveTextureEnabled[FHandle.Target] := False; FApplyCounter := 0; FIsValid := True; except FIsValid := False; end; end; procedure TGLTextureImageEx.FullTransfer; var LCompression: TGLTextureCompression; glFormat: Cardinal; begin begin if GL.ARB_texture_compression then begin if Compression = tcDefault then if vDefaultTextureCompression = tcDefault then LCompression := tcNone else LCompression := vDefaultTextureCompression else LCompression := Compression; end else LCompression := tcNone; if LCompression <> tcNone then with CurrentGLContext.GLStates do begin case LCompression of tcStandard: TextureCompressionHint := hintDontCare; tcHighQuality: TextureCompressionHint := hintNicest; tcHighSpeed: TextureCompressionHint := hintFastest; else Assert(False, strErrorEx + strUnknownType); end; if not GetGenericCompressedFormat( FInternalFormat, FImage.ColorFormat, glFormat) then glFormat := InternalFormatToOpenGLFormat(FInternalFormat); end else glFormat := InternalFormatToOpenGLFormat(FInternalFormat); FImage.RegisterAsOpenGLTexture( FHandle, FMipGenMode = mgmOnFly, glFormat, FWidth, FHeight, FDepth); if gl.GetError <> GL_NO_ERROR then begin gl.ClearError; CurrentGLContext.GLStates.ActiveTextureEnabled[FHandle.Target] := False; GLSLogger.LogErrorFmt('Unable to create texture "%s"', [Self.Name]); Abort; end else FHandle.NotifyDataUpdated; end; end; procedure TGLTextureImageEx.CalcLODRange(out AFirstLOD, ALastLOD: Integer); var I, MaxLODSize, MinLODSize, MaxLODZSize: Integer; begin case FHandle.Target of ttTexture3D: begin MaxLODSize := CurrentGLContext.GLStates.Max3DTextureSize; MaxLODZSize := MaxLODSize; end; ttTextureCube: begin MaxLODSize := CurrentGLContext.GLStates.MaxCubeTextureSize; MaxLODZSize := 0; end; ttTexture1DArray, ttTexture2DArray, ttTextureCubeArray, ttTexture2DMultisampleArray: begin MaxLODSize := CurrentGLContext.GLStates.MaxTextureSize; MaxLODZSize := CurrentGLContext.GLStates.MaxArrayTextureSize; end; else begin MaxLODSize := CurrentGLContext.GLStates.MaxTextureSize; MaxLODZSize := 0; end; end; MinLODSize := 1; AFirstLOD := 0; for I := 0 to High(TGLImagePiramid) do begin if (FImage.LevelWidth[I] <= MaxLODSize) and (FImage.LevelHeight[I] <= MaxLODSize) and (FImage.LevelDepth[I] <= MaxLODZSize) then break; Inc(AFirstLOD); end; AFirstLOD := MinInteger(AFirstLOD, FImage.LevelCount - 1); ALastLOD := AFirstLOD; for I := AFirstLOD to High(TGLImagePiramid) do begin if (FImage.LevelWidth[I] < MinLODSize) or (FImage.LevelHeight[I] < MinLODSize) then break; Inc(ALastLOD); end; ALastLOD := MinInteger(ALastLOD, FImage.LevelCount - 1); end; procedure TGLTextureImageEx.StreamTransfer; var LImage: TFriendlyImage; bContinueStreaming: Boolean; OldBaseLevel, level: Integer; newTime: Double; glInternalFormat: Cardinal; transferMethod: 0..3; begin LImage := TFriendlyImage(FImage); OldBaseLevel := FBaseLevel; CalcLODRange(FBaseLevel, FMaxLevel); // Select transfer method if FImage.IsCompressed then transferMethod := 1 else transferMethod := 0; if gl.EXT_direct_state_access then transferMethod := transferMethod + 2; bContinueStreaming := False; for level := FMaxLevel downto FBaseLevel do begin case LImage.LevelStreamingState[level] of ssKeeping: begin if FBaseLevel < Level then FBaseLevel := FMaxLevel; LImage.LevelStreamingState[Level] := ssLoading; LImage.DoStreaming; bContinueStreaming := True; end; ssLoading: begin LImage.DoStreaming; bContinueStreaming := True; if FBaseLevel < Level then FBaseLevel := FMaxLevel; end; ssLoaded: begin LImage.LevelPixelBuffer[Level].AllocateHandle; LImage.LevelPixelBuffer[Level].Bind; glInternalFormat := InternalFormatToOpenGLFormat(FInternalFormat); case transferMethod of 0: gl.TexImage2D(GL_TEXTURE_2D, Level, glInternalFormat, FImage.LevelWidth[level], FImage.LevelHeight[level], 0, FImage.ColorFormat, FImage.DataType, nil); 1: gl.CompressedTexImage2D(GL_TEXTURE_2D, Level, glInternalFormat, FImage.LevelWidth[level], FImage.LevelHeight[level], 0, FImage.LevelSizeInByte[Level], nil); 2: gl.TextureImage2D(FHandle.Handle, GL_TEXTURE_2D, Level, glInternalFormat, FImage.LevelWidth[level], FImage.LevelHeight[level], 0, FImage.ColorFormat, FImage.DataType, nil); 3: gl.CompressedTextureImage2D(FHandle.Handle, GL_TEXTURE_2D, Level, glInternalFormat, FImage.LevelWidth[level], FImage.LevelHeight[level], 0, FImage.LevelSizeInByte[Level], nil); end; LImage.LevelPixelBuffer[Level].UnBind; LImage.LevelStreamingState[Level] := ssTransfered; GLSLogger.LogDebug(Format('Texture "%s" level %d loaded', [Name, Level])); end; ssTransfered: begin if LImage.LevelPixelBuffer[Level].IsAllocatedForContext then LImage.LevelPixelBuffer[Level].DestroyHandle; FBaseLevel := Level; end; end; // of case if bContinueStreaming then break; end; // for level if bContinueStreaming then begin gl.TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAX_LEVEL, FMaxLevel); gl.TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_BASE_LEVEL, FBaseLevel); end; // Smooth transition between levels if Assigned(FApplicableSampler) then with FApplicableSampler do begin newTime := AppTime; if FLODBiasFract > 0 then FLODBiasFract := FLODBiasFract - 0.05 * (newTime - FLastTime) else if FLODBiasFract < 0 then FLODBiasFract := 0; FLastTime := newTime; if OldBaseLevel > FBaseLevel then FLODBiasFract := FLODBiasFract + (OldBaseLevel - FBaseLevel); if FApplicableSampler.IsValid then gl.SamplerParameterf(FApplicableSampler.Handle.Handle, GL_TEXTURE_LOD_BIAS, FLODBias + FLODBiasFract) else // To refrash texture parameters when sampler object not supported FLastSampler := nil; end; end; class function TGLTextureImageEx.FriendlyName: string; begin Result := 'Texture Image'; end; procedure TGLTextureImageEx.PrepareImage; const cAlphaProc: array[TGLTextureImageAlpha] of TImageAlphaProc = ( nil, ImageAlphaFromIntensity, ImageAlphaSuperBlackTransparent, ImageAlphaLuminance, ImageAlphaLuminanceSqrt, ImageAlphaOpaque, ImageAlphaTopLeftPointColorTransparent, ImageAlphaInverseLuminance, ImageAlphaInverseLuminanceSqrt, ImageAlphaBottomRightPointColorTransparent ); var ext, filename: string; BaseImageClass: TGLBaseImageClass; LPicture: TPicture; LGraphic: TGraphic; LImage: TGLImage; level: Integer; glColorFormat, glDataType: Cardinal; bReadFromSource: Boolean; LStream: TStream; ptr: PByte; procedure ReplaceImageClass; begin if not (FImage is TGLImage) then begin LImage := TGLImage.Create; LImage.Assign(FImage); FImage.Destroy; FImage := LImage; end else LImage := TGLImage(FImage); end; begin if not Assigned(FImage) then begin try SetExeDirectory; bReadFromSource := True; if FInternallyStored and not IsDesignTime then begin filename := Name+'.image'; if FileStreamExists(filename) then begin FImage := TGLImage.Create; FImage.ResourceName := filename; TFriendlyImage(FImage).LoadHeader; if not FUseStreaming then begin ReallocMem(TFriendlyImage(FImage).fData, FImage.DataSize); for level := FImage.LevelCount - 1 downto 0 do begin LStream := TFileStream.Create(filename + IntToHex(level, 2), fmOpenRead); ptr := PByte(TFriendlyImage(FImage).GetLevelAddress(level)); LStream.Read(ptr^, FImage.LevelSizeInByte[level]); LStream.Destroy; end; end; bReadFromSource := False; end else begin FInternallyStored := False; FUseStreaming := False; end; end; if bReadFromSource then begin if (Length(FSourceFile) > 0) and FileStreamExists(FSourceFile) then begin // At first check moder image file loaders ext := ExtractFileExt(FSourceFile); System.Delete(ext, 1, 1); BaseImageClass := GetRasterFileFormats.FindExt(ext); if Assigned(BaseImageClass) then begin FImage := BaseImageClass.Create; FImage.LoadFromFile(FSourceFile); end else begin // Check old loaders FImage := TGLImage.Create; if ApplicationFileIODefined then begin LGraphic := CreateGraphicFromFile(FSourceFile); FImage.Assign(LGraphic); LGraphic.Free; end else begin LPicture := TPicture.Create; LPicture.LoadFromFile(FSourceFile); FImage.Assign(LPicture.Graphic); LPicture.Destroy; end; end; if FInternalFormat <> FImage.InternalFormat then begin ReplaceImageClass; FindCompatibleDataFormat(FInternalFormat, glColorFormat, glDataType); TGLImage(FImage).SetColorFormatDataType(glColorFormat, glDataType); TFriendlyImage(FImage).fInternalFormat := FInternalFormat; end; if (ImageAlpha <> tiaDefault) or (FImageBrightness <> 1.0) or (FImageGamma <> 1.0) then begin ReplaceImageClass; for level := 0 to FImage.LevelCount - 1 do begin AlphaGammaBrightCorrection( TFriendlyImage(FImage).GetLevelAddress(level), FImage.ColorFormat, FImage.DataType, FImage.LevelWidth[level], FImage.LevelHeight[level], cAlphaProc[ImageAlpha], FImageBrightness, FImageGamma); end; end else if FHeightToNormalScale <> 1.0 then begin ReplaceImageClass; // HeightToNormalMap(); {$Message Hint 'TGLTextureImageEx.HeightToNormalScale not yet implemented' } end; case FMipGenMode of mgmNoMip: FImage.UnMipmap; mgmLeaveExisting, mgmOnFly: ; mgmBoxFilter: FImage.GenerateMipmap(ImageBoxFilter); mgmTriangleFilter: FImage.GenerateMipmap(ImageTriangleFilter); mgmHermiteFilter: FImage.GenerateMipmap(ImageHermiteFilter); mgmBellFilter: FImage.GenerateMipmap(ImageBellFilter); mgmSplineFilter: FImage.GenerateMipmap(ImageSplineFilter); mgmLanczos3Filter: FImage.GenerateMipmap(ImageLanczos3Filter); mgmMitchellFilter: FImage.GenerateMipmap(ImageMitchellFilter); end; // Store cooked image if FInternallyStored and IsDesignTime then begin filename := Name+'.image'; FImage.ResourceName := filename; TFriendlyImage(FImage).SaveHeader; for level := FImage.LevelCount - 1 downto 0 do begin LStream := TFileStream.Create(filename + IntToHex(level, 2), fmOpenWrite or fmCreate); ptr := PByte(TFriendlyImage(FImage).GetLevelAddress(level)); LStream.Write(ptr^, FImage.LevelSizeInByte[level]); LStream.Destroy; end; end; end else begin // no SourceFile FImage := TGLImage.Create; FImage.SetErrorImage; GLSLogger.LogErrorFmt('Source file of texture "%s" image not found', [Self.Name]); end; end; // if bReadFromSource except on E: Exception do begin FImage.Free; FImage := TGLImage.Create; FImage.SetErrorImage; if IsDesignTime then InformationDlg(Self.Name + ' - ' + E.ClassName + ': ' + E.Message) else GLSLogger.LogError(Self.Name + ' - ' + E.ClassName + ': ' + E.Message); end; end; end; // of not Assigned end; procedure TGLTextureImageEx.ReadFromFiler(AReader: TReader); var archiveVersion: Integer; begin with AReader do begin archiveVersion := ReadInteger; if archiveVersion = 0 then begin Name := ReadString; FDefferedInit := ReadBoolean; FInternalFormat := TGLInternalFormat(ReadInteger); FCompression := TGLTextureCompression(ReadInteger); FImageAlpha := TGLTextureImageAlpha(ReadInteger); FImageBrightness := ReadFloat; FImageBrightness := ReadFloat; FImageGamma := ReadFloat; FHeightToNormalScale := ReadFloat; FSourceFile := ReadString; FInternallyStored := ReadBoolean; FMipGenMode := TMipmapGenerationMode(ReadInteger); FUseStreaming := ReadBoolean; end else RaiseFilerException(archiveVersion); end; end; procedure TGLTextureImageEx.SetCompression(const AValue: TGLTextureCompression); begin if AValue <> FCompression then begin FCompression := AValue; NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetImageAlpha(const AValue: TGLTextureImageAlpha); begin if FImageAlpha <> AValue then begin FImageAlpha := AValue; FreeAndNil(FImage); NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetImageBrightness(const AValue: Single); begin if FImageBrightness <> AValue then begin FImageBrightness := AValue; FreeAndNil(FImage); NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetImageGamma(const AValue: Single); begin if FImageGamma <> AValue then begin FImageGamma := AValue; FreeAndNil(FImage); NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetInternalFormat(const AValue: TGLInternalFormat); begin if AValue <> FInternalFormat then begin FInternalFormat := AValue; FreeAndNil(FImage); NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetInternallyStored(const AValue: Boolean); begin if FInternallyStored <> AValue then begin FInternallyStored := AValue; if not AValue then FUseStreaming := AValue else FreeAndNil(FImage); NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetMipGenMode(const AValue: TMipmapGenerationMode); begin if FMipGenMode <> AValue then begin FMipGenMode := AValue; FreeAndNil(FImage); NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetNormalMapScale(const AValue: Single); begin if AValue <> FHeightToNormalScale then begin FHeightToNormalScale := AValue; NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetSourceFile(AValue: string); begin FixPathDelimiter(AValue); if FSourceFile <> AValue then begin FSourceFile := AValue; FUseStreaming := False; FreeAndNil(FImage); NotifyChange(Self); end; end; procedure TGLTextureImageEx.SetUseStreaming(const AValue: Boolean); begin if AValue <> FUseStreaming then begin if AValue then begin if not Assigned(FImage) then exit; if FImage.LevelCount = 1 then begin if IsDesignTime then InformationDlg('Image must be more than one level'); exit; end; FInternallyStored := True; end; FUseStreaming := AValue; NotifyChange(Self); end; end; function TGLTextureImageEx.StoreBrightness: Boolean; begin Result := (FImageBrightness <> 1.0); end; function TGLTextureImageEx.StoreGamma: Boolean; begin Result := (FImageGamma <> 1.0); end; function TGLTextureImageEx.StoreNormalMapScale: Boolean; begin Result := (FHeightToNormalScale <> cDefaultNormalMapScale); end; procedure TGLTextureImageEx.UnApply(var ARci: TGLRenderContextInfo); begin ARci.GLStates.ActiveTextureEnabled[FHandle.Target] := False; end; procedure TGLTextureImageEx.WriteToFiler(AWriter: TWriter); begin with AWriter do begin WriteInteger(0); // archive version WriteString(Name); WriteBoolean(FDefferedInit); WriteInteger(Integer(FInternalFormat)); WriteInteger(Integer(FCompression)); WriteInteger(Integer(FImageAlpha)); WriteFloat(FImageBrightness); WriteFloat(FImageBrightness); WriteFloat(FImageGamma); WriteFloat(FHeightToNormalScale); WriteString(FSourceFile); WriteBoolean(FInternallyStored); WriteInteger(Integer(FMipGenMode)); WriteBoolean(FUseStreaming); end; end; procedure TGLTextureSampler.Apply(var ARci: TGLRenderContextInfo); begin if FIsValid then ARci.GLStates.SamplerBinding[ARci.GLStates.ActiveTexture] := FHandle.Handle; end; procedure TGLTextureSampler.Assign(Source: TPersistent); var LSampler: TGLTextureSampler; begin if Source is TGLTextureSampler then begin LSampler := TGLTextureSampler(Source); FMinFilter := LSampler.FMinFilter; FMagFilter := LSampler.FMagFilter; FFilteringQuality := LSampler.FFilteringQuality; FLODBias := LSampler.FLODBias; FLODBiasFract := 0; FBorderColor.Assign(LSampler.FBorderColor); FWrap := LSampler.FWrap; FCompareMode := LSampler.FCompareMode; FCompareFunc := LSampler.FCompareFunc; FDecodeSRGB := LSampler.FDecodeSRGB; NotifyChange(Self); end; inherited; end; constructor TGLTextureSampler.Create(AOwner: TXCollection); begin inherited; FDefferedInit := False; FHandle := TGLSamplerHandle.Create; FHandle.OnPrapare := DoOnPrepare; FMagFilter := maLinear; FMinFilter := miLinearMipMapLinear; FFilteringQuality := tfAnisotropic; FLODBias := 0; FLODBiasFract := 0; FWrap[0] := twRepeat; FWrap[1] := twRepeat; FWrap[2] := twRepeat; FBorderColor := TGLColor.CreateInitialized(Self, clrTransparent); FCompareMode := tcmNone; FCompareFunc := cfLequal; FDecodeSRGB := True; Name := TGLMatLibComponents(AOwner).MakeUniqueName('Sampler'); end; destructor TGLTextureSampler.Destroy; begin FHandle.Destroy; FBorderColor.Destroy; inherited; end; function TGLTextureSampler.GetWrap(Index: Integer): TGLSeparateTextureWrap; begin Result := FWrap[Index]; end; procedure TGLTextureSampler.NotifyChange(Sender: TObject); begin FHandle.NotifyChangesOfData; inherited; end; procedure TGLTextureSampler.DoOnPrepare(Sender: TGLContext); var ID: Cardinal; begin if IsDesignTime and FDefferedInit then exit; try if FHandle.IsSupported then begin FHandle.AllocateHandle; ID := FHandle.Handle; if FHandle.IsDataNeedUpdate then with Sender.GL do begin SamplerParameterfv(ID, GL_TEXTURE_BORDER_COLOR, FBorderColor.AsAddress); SamplerParameteri(ID, GL_TEXTURE_WRAP_S, cTextureWrapMode[FWrap[0]]); SamplerParameteri(ID, GL_TEXTURE_WRAP_T, cTextureWrapMode[FWrap[1]]); SamplerParameteri(ID, GL_TEXTURE_WRAP_R, cTextureWrapMode[FWrap[2]]); SamplerParameterf(ID, GL_TEXTURE_LOD_BIAS, FLODBias + FLODBiasFract); SamplerParameteri(ID, GL_TEXTURE_MIN_FILTER, cTextureMinFilter[FMinFilter]); SamplerParameteri(ID, GL_TEXTURE_MAG_FILTER, cTextureMagFilter[FMagFilter]); if EXT_texture_filter_anisotropic then begin if FFilteringQuality = tfAnisotropic then SamplerParameteri(ID, GL_TEXTURE_MAX_ANISOTROPY_EXT, CurrentGLContext.GLStates.MaxTextureAnisotropy) else SamplerParameteri(ID, GL_TEXTURE_MAX_ANISOTROPY_EXT, 1); end; SamplerParameteri(ID, GL_TEXTURE_COMPARE_MODE, cTextureCompareMode[FCompareMode]); SamplerParameteri(ID, GL_TEXTURE_COMPARE_FUNC, cGLComparisonFunctionToGLEnum[FCompareFunc]); if EXT_texture_sRGB_decode then begin if FDecodeSRGB then SamplerParameteri(ID, GL_TEXTURE_SRGB_DECODE_EXT, GL_DECODE_EXT) else SamplerParameteri(ID, GL_TEXTURE_SRGB_DECODE_EXT, GL_SKIP_DECODE_EXT); end; {$IFDEF USE_OPENGL_DEBUG} CheckError; {$ENDIF} FHandle.NotifyDataUpdated; end; FIsValid := True; end else FIsValid := False; except FIsValid := False; end; end; class function TGLTextureSampler.FriendlyName: string; begin Result := 'Texture Sampler'; end; procedure TGLTextureSampler.ReadFromFiler(AReader: TReader); var archiveVersion: Integer; begin with AReader do begin archiveVersion := ReadInteger; if archiveVersion = 0 then begin Name := ReadString; FDefferedInit := ReadBoolean; FMinFilter := TGLMinFilter(ReadInteger); FMagFilter := TGLMagFilter(ReadInteger); FFilteringQuality := TGLTextureFilteringQuality(ReadInteger); FLODBias := ReadInteger; FWrap[0] := TGLSeparateTextureWrap(ReadInteger); FWrap[1] := TGLSeparateTextureWrap(ReadInteger); FWrap[2] := TGLSeparateTextureWrap(ReadInteger); Read(FBorderColor.AsAddress^, SizeOf(TGLColorVector)); FCompareMode := TGLTextureCompareMode(ReadInteger); FCompareFunc := TGLDepthFunction(ReadInteger); FDecodeSRGB := ReadBoolean; end else RaiseFilerException(archiveVersion); end; end; procedure TGLTextureSampler.SetBorderColor(const AValue: TGLColor); begin FBorderColor.Assign(AValue); NotifyChange(Self); end; procedure TGLTextureSampler.SetCompareFunc(AValue: TGLDepthFunction); begin if FCompareFunc <> AValue then begin FCompareFunc := AValue; NotifyChange(Self); end; end; procedure TGLTextureSampler.SetCompareMode(AValue: TGLTextureCompareMode); begin if FCompareMode <> AValue then begin FCompareMode := AValue; NotifyChange(Self); end; end; procedure TGLTextureSampler.SetDecodeSRGB(AValue: Boolean); begin if FDecodeSRGB <> AValue then begin FDecodeSRGB := AValue; NotifyChange(Self); end; end; procedure TGLTextureSampler.SetFilteringQuality( AValue: TGLTextureFilteringQuality); begin if FFilteringQuality <> AValue then begin FFilteringQuality := AValue; NotifyChange(Self); end; end; procedure TGLTextureSampler.SetLODBias(AValue: Integer); begin if FLODBias <> AValue then begin FLODBias := AValue; NotifyChange(Self); end; end; procedure TGLTextureSampler.SetMagFilter(AValue: TGLMagFilter); begin if FMagFilter <> AValue then begin FMagFilter := AValue; NotifyChange(Self); end; end; procedure TGLTextureSampler.SetMinFilter(AValue: TGLMinFilter); begin if FMinFilter <> AValue then begin FMinFilter := AValue; NotifyChange(Self); end; end; procedure TGLTextureSampler.SetWrap(Index: Integer; AValue: TGLSeparateTextureWrap); begin if FWrap[Index] <> AValue then begin FWrap[Index] := AValue; NotifyChange(Self); end; end; procedure TGLTextureSampler.UnApply(var ARci: TGLRenderContextInfo); begin if FHandle.IsSupported then with ARci.GLStates do SamplerBinding[ActiveTexture] := 0; end; procedure TGLTextureSampler.WriteToFiler(AWriter: TWriter); begin with AWriter do begin WriteInteger(0); // archive version WriteString(Name); WriteBoolean(FDefferedInit); WriteInteger(Integer(FMinFilter)); WriteInteger(Integer(FMagFilter)); WriteInteger(Integer(FFilteringQuality)); WriteInteger(FLODBias); WriteInteger(Integer(FWrap[0])); WriteInteger(Integer(FWrap[1])); WriteInteger(Integer(FWrap[2])); Write(FBorderColor.AsAddress^, SizeOf(TGLColorVector)); WriteInteger(Integer(FCompareMode)); WriteInteger(Integer(FCompareFunc)); WriteBoolean(FDecodeSRGB); end; end; { TVXTextureCombiner } procedure TGLTextureCombiner.Assign(Source: TPersistent); var LCombiner: TGLTextureCombiner; begin if Source is TGLTextureCombiner then begin LCombiner := TGLTextureCombiner(Source); FScript.Assign(LCombiner.FScript); end; inherited; end; constructor TGLTextureCombiner.Create(AOwner: TXCollection); begin inherited; FDefferedInit := False; FHandle := TGLVirtualHandle.Create; FHandle.OnAllocate := DoAllocate; FHandle.OnDestroy := DoDeallocate; FHandle.OnPrapare := DoOnPrepare; FScript := TStringList.Create; FScript.OnChange := NotifyChange; FIsValid := True; Name := TGLMatLibComponents(AOwner).MakeUniqueName('Combiner'); end; destructor TGLTextureCombiner.Destroy; begin FHandle.Destroy; FScript.Destroy; inherited; end; procedure TGLTextureCombiner.NotifyChange(Sender: TObject); begin FHandle.NotifyChangesOfData; inherited; end; procedure TGLTextureCombiner.DoAllocate(Sender: TGLVirtualHandle; var handle: Cardinal); begin handle := 1; end; procedure TGLTextureCombiner.DoDeallocate(Sender: TGLVirtualHandle; var handle: Cardinal); begin handle := 0; end; procedure TGLTextureCombiner.DoOnPrepare(Sender: TGLContext); begin if IsDesignTime and FDefferedInit then exit; if Sender.gl.ARB_multitexture then begin FHandle.AllocateHandle; if FHandle.IsDataNeedUpdate then begin try FCommandCache := GetTextureCombiners(FScript); FIsValid := True; except on E: Exception do begin FIsValid := False; if IsDesignTime then InformationDlg(E.ClassName + ': ' + E.Message) else GLSLogger.LogError(E.ClassName + ': ' + E.Message); end; end; FHandle.NotifyDataUpdated; end; end else FIsValid := False; end; class function TGLTextureCombiner.FriendlyName: string; begin Result := 'Texture Combiner'; end; procedure TGLTextureCombiner.ReadFromFiler(AReader: TReader); var archiveVersion: Integer; begin with AReader do begin archiveVersion := ReadInteger; if archiveVersion = 0 then begin Name := ReadString; FDefferedInit := ReadBoolean; FScript.Text := ReadString; end else RaiseFilerException(archiveVersion); end; end; procedure TGLTextureCombiner.SetScript(AValue: TStringList); begin FScript.Assign(AValue); NotifyChange(Self); end; procedure TGLTextureCombiner.WriteToFiler(AWriter: TWriter); begin with AWriter do begin WriteInteger(0); // archive version WriteString(Name); WriteBoolean(FDefferedInit); WriteString(FScript.Text); end; end; { TVXLibMaterialEx } procedure TGLLibMaterialEx.Apply(var ARci: TGLRenderContextInfo); var LevelReady: array[TGLMaterialLevel] of Boolean; L, MaxLevel: TGLMaterialLevel; begin if Assigned(FNextPass) then begin FNextPass := nil; exit; end; FHandle.AllocateHandle; if FHandle.IsDataNeedUpdate then begin // Other value than mlAuto indicates a level failure // Need remove deffered initialization and reinitialize used resources if not IsDesignTime and (FSelectedLevel <> mlAuto) then RemoveDefferedInit; // Level selection LevelReady[mlFixedFunction] := FFixedFunc.Enabled; LevelReady[mlMultitexturing] := FMultitexturing.Enabled and FMultitexturing.IsValid; LevelReady[mlSM3] := FSM3.Enabled and FSM3.IsValid; LevelReady[mlSM4] := FSM4.Enabled and FSM4.IsValid; LevelReady[mlSM5] := FSM5.Enabled and FSM5.IsValid; if FApplicableLevel = mlAuto then MaxLevel := mlSM5 else MaxLevel := FApplicableLevel; FSelectedLevel := mlAuto; for L := MaxLevel downto mlFixedFunction do if LevelReady[L] then begin FSelectedLevel := L; break; end; FStoreAmalgamating := ARci.amalgamating; ARci.amalgamating := True; FHandle.NotifyDataUpdated; end; ARci.currentMaterialLevel := FSelectedLevel; case FSelectedLevel of mlAuto: ; // No one level can be used. Worst case. mlFixedFunction: begin FFixedFunc.Apply(ARci); end; mlMultitexturing: begin if LevelReady[mlFixedFunction] then FFixedFunc.Apply(ARci); FMultitexturing.Apply(ARci); end; mlSM3: begin if LevelReady[mlFixedFunction] then FFixedFunc.Apply(ARci); FSM3.Apply(ARci); end; mlSM4: begin if LevelReady[mlFixedFunction] then FFixedFunc.Apply(ARci); FSM4.Apply(ARci); end; mlSM5: begin if LevelReady[mlFixedFunction] then FFixedFunc.Apply(ARci); FSM5.Apply(ARci); end; end; end; procedure TGLLibMaterialEx.Assign(Source: TPersistent); var LMaterial: TGLLibMaterialEx; begin if Source is TGLLibMaterialEx then begin LMaterial := TGLLibMaterialEx(Source); FFixedFunc.Assign(LMaterial.FFixedFunc); FMultitexturing.Assign(LMaterial.FMultitexturing); FSM3.Assign(LMaterial.FSM3); FSM4.Assign(LMaterial.FSM4); FSM5.Assign(LMaterial.FSM5); FApplicableLevel := LMaterial.FApplicableLevel; NotifyChange(Self); end; inherited; end; function TGLLibMaterialEx.Blended: Boolean; begin Result := FFixedFunc.Blended; end; constructor TGLLibMaterialEx.Create(ACollection: TCollection); begin inherited; FHandle := TGLVirtualHandle.Create; FHandle.OnAllocate := DoAllocate; FHandle.OnDestroy := DoDeallocate; FHandle.OnPrapare := DoOnPrepare; FApplicableLevel := mlAuto; FSelectedLevel := mlAuto; FFixedFunc := TGLFixedFunctionProperties.Create(Self); FMultitexturing := TGLMultitexturingProperties.Create(Self); FSM3 := TGLShaderModel3.Create(Self); FSM4 := TGLShaderModel4.Create(Self); FSM5 := TGLShaderModel5.Create(Self); end; type TGLFreindlyMaterial = class(TGLMaterial); destructor TGLLibMaterialEx.Destroy; var I: Integer; LUser: TObject; begin FHandle.Destroy; FFixedFunc.Destroy; FMultitexturing.Destroy; FSM3.Destroy; FSM4.Destroy; FSM5.Destroy; for I := 0 to FUserList.Count - 1 do begin LUser := TObject(FUserList[i]); if LUser is TGLMaterial then TGLFreindlyMaterial(LUser).NotifyLibMaterialDestruction; end; inherited; end; procedure TGLLibMaterialEx.DoAllocate(Sender: TGLVirtualHandle; var handle: Cardinal); begin handle := 1; end; procedure TGLLibMaterialEx.DoDeallocate(Sender: TGLVirtualHandle; var handle: Cardinal); begin handle := 0; end; procedure TGLLibMaterialEx.DoOnPrepare(Sender: TGLContext); begin end; procedure TGLLibMaterialEx.Loaded; begin FFixedFunc.FTexProp.Loaded; FMultitexturing.Loaded; FSM3.Loaded; FSM4.Loaded; FSM5.Loaded; end; procedure TGLLibMaterialEx.NotifyChange(Sender: TObject); begin inherited; FHandle.NotifyChangesOfData; end; procedure TGLLibMaterialEx.RemoveDefferedInit; var I: Integer; ST: TGLShaderType; begin if FFixedFunc.FTexProp.Enabled then begin if Assigned(FFixedFunc.FTexProp.FLibTexture) then FFixedFunc.FTexProp.FLibTexture.FDefferedInit := False; if Assigned(FFixedFunc.FTexProp.FLibSampler) then FFixedFunc.FTexProp.FLibSampler.FDefferedInit := False; end; if FMultitexturing.Enabled then begin if Assigned(FMultitexturing.FLibCombiner) then begin FMultitexturing.FLibCombiner.FDefferedInit := False; for I := 0 to 3 do if Assigned(FMultitexturing.FTexProps[I]) then with FMultitexturing.FTexProps[I] do begin if Assigned(FLibTexture) then FLibTexture.FDefferedInit := False; if Assigned(FLibSampler) then FLibSampler.FDefferedInit := False; end; end; end; if FSM3.Enabled then begin for ST := Low(TGLShaderType) to High(TGLShaderType) do if Assigned(FSM3.FShaders[ST]) then FSM3.FShaders[ST].FDefferedInit := False; end; if FSM4.Enabled then begin for ST := Low(TGLShaderType) to High(TGLShaderType) do if Assigned(FSM4.FShaders[ST]) then FSM4.FShaders[ST].FDefferedInit := False; end; if FSM5.Enabled then begin for ST := Low(TGLShaderType) to High(TGLShaderType) do if Assigned(FSM5.FShaders[ST]) then FSM5.FShaders[ST].FDefferedInit := False; end; CurrentGLContext.PrepareHandlesData; end; procedure TGLLibMaterialEx.SetMultitexturing(AValue: TGLMultitexturingProperties); begin FMultitexturing.Assign(AValue); end; procedure TGLLibMaterialEx.SetFixedFunc(AValue: TGLFixedFunctionProperties); begin FFixedFunc.Assign(AValue); end; procedure TGLLibMaterialEx.SetLevel(AValue: TGLMaterialLevel); begin if FApplicableLevel <> AValue then begin FApplicableLevel := AValue; NotifyChange(Self); end; end; procedure TGLLibMaterialEx.SetSM3(AValue: TGLShaderModel3); begin FSM3.Assign(AValue); end; procedure TGLLibMaterialEx.SetSM4(AValue: TGLShaderModel4); begin FSM4.Assign(AValue); end; procedure TGLLibMaterialEx.SetSM5(AValue: TGLShaderModel5); begin FSM5.Assign(AValue); end; function TGLLibMaterialEx.UnApply(var ARci: TGLRenderContextInfo): Boolean; procedure GetNextPass(AProp: TGLLibMaterialProperty); begin if Length(AProp.NextPass) > 0 then FNextPass := TGLMaterialLibraryEx(GetMaterialLibrary).Materials.GetLibMaterialByName(AProp.NextPass) else FNextPass := nil; if FNextPass = Self then begin AProp.NextPass := ''; FNextPass := nil; end; end; begin if FStoreAmalgamating <> ARci.amalgamating then ARci.amalgamating := FStoreAmalgamating; if Assigned(FNextPass) then begin Result := FNextPass.UnApply(ARci); if Result then FNextPass.Apply(ARci) else FNextPass := nil; exit; end; case FSelectedLevel of mlFixedFunction: begin FFixedFunc.UnApply(ARci); GetNextPass(FFixedFunc); end; mlMultitexturing: begin if FFixedFunc.Enabled then FFixedFunc.UnApply(ARci); FMultitexturing.UnApply(ARci); GetNextPass(FMultitexturing); end; mlSM3: begin if FFixedFunc.Enabled then FFixedFunc.UnApply(ARci); FSM3.UnApply(ARci); GetNextPass(FSM3); end; mlSM4: begin if FFixedFunc.Enabled then FFixedFunc.UnApply(ARci); FSM4.UnApply(ARci); GetNextPass(FSM4); end; mlSM5: begin if FFixedFunc.Enabled then FFixedFunc.UnApply(ARci); FSM5.UnApply(ARci); GetNextPass(FSM5); end; else FNextPass := nil; end; ARci.GLStates.ActiveTexture := 0; Result := Assigned(FNextPass); if Result then FNextPass.Apply(ARCi); end; { TVXMultitexturingProperties } procedure TGLMultitexturingProperties.Apply(var ARci: TGLRenderContextInfo); var N, U: Integer; LDir: TGLVector; begin if FEnabled then begin if Assigned(FLibCombiner) and not FLibCombiner.FIsValid then exit; if Assigned(FLibAsmProg) and not FLibAsmProg.FIsValid then exit; U := 0; for N := 0 to High(FTexProps) do begin if Assigned(FTexProps[N]) and FTexProps[N].Enabled then begin ARci.GLStates.ActiveTexture := N; FTexProps[N].Apply(ARci); if Ord(FLightDir) = N+1 then begin LDir := ARci.GLStates.LightPosition[FLightSourceIndex]; LDir := VectorTransform(LDir, ARci.PipelineTransformation.InvModelMatrix^); NormalizeVector(LDir); gl.TexEnvfv(GL_TEXTURE_ENV, GL_TEXTURE_ENV_COLOR, @LDir); end; U := U or (1 shl N); end; end; if Assigned(FLibAsmProg) then begin FLibAsmProg.Handle.Bind; gl.Enable(GL_VERTEX_PROGRAM_ARB); if Assigned(GetMaterial.FOnAsmProgSetting) then GetMaterial.FOnAsmProgSetting(Self.FLibAsmProg, ARci); end; with GL, ARci.GLStates do begin if Assigned(FLibCombiner) and (Length(FLibCombiner.FCommandCache) > 0) then begin for N := 0 to High(FLibCombiner.FCommandCache) do begin ActiveTexture := FLibCombiner.FCommandCache[N].ActiveUnit; TexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_COMBINE); TexEnvi(GL_TEXTURE_ENV, FLibCombiner.FCommandCache[N].Arg1, FLibCombiner.FCommandCache[N].Arg2); end; end; TexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, cTextureMode[FTextureMode]); ActiveTexture := 0; end; XGL.BeginUpdate; if U > 3 then XGL.MapTexCoordToArbitrary(U) else if (FTexProps[0].Enabled) and (FTexProps[0].MappingMode = tmmUser) then if FTexProps[1].MappingMode = tmmUser then XGL.MapTexCoordToDual else XGL.MapTexCoordToMain else if FTexProps[1].MappingMode = tmmUser then XGL.MapTexCoordToSecond else XGL.MapTexCoordToMain; XGL.EndUpdate; end; end; constructor TGLMultitexturingProperties.Create(AOwner: TPersistent); begin inherited; FEnabled := False; FTextureMode := tmDecal; FLightDir := l2eNone; FLightSourceIndex := 0; end; destructor TGLMultitexturingProperties.Destroy; begin if Assigned(FLibCombiner) then FLibCombiner.UnregisterUser(Self); if Assigned(FLibAsmProg) then FLibAsmProg.UnregisterUser(Self); FTexProps[0].Free; FTexProps[1].Free; FTexProps[2].Free; FTexProps[3].Free; inherited; end; function TGLMultitexturingProperties.GetLibCombinerName: string; begin if Assigned(FLibCombiner) then Result := FLibCombiner.Name else Result := ''; end; function TGLMultitexturingProperties.GetLibAsmProgName: string; begin if Assigned(FLibAsmProg) then Result := FLibAsmProg.Name else Result := ''; end; function TGLMultitexturingProperties.IsValid: Boolean; var I: Integer; begin Result := True; if Assigned(FLibCombiner) then Result := Result and FLibCombiner.IsValid; if Assigned(FLibAsmProg) then Result := Result and FLibAsmProg.IsValid; for I := 0 to High(FTexProps) do if Assigned(FTexProps[I]) and FTexProps[I].FEnabled then Result := Result and FTexProps[I].IsValid; end; procedure TGLMultitexturingProperties.Loaded; var I: Integer; begin SetLibCombinerName(FLibCombinerName); SetLibAsmProgName(FLibAsmProgName); for I := 0 to High(FTexProps) do if Assigned(FTexProps[I]) then FTexProps[I].Loaded; end; procedure TGLMultitexturingProperties.Notification(Sender: TObject; Operation: TOperation); begin if Operation = opRemove then begin if Sender = FLibCombiner then FLibCombiner := nil; if Sender = FLibAsmProg then FLibAsmProg := nil; end; inherited; end; procedure TGLMultitexturingProperties.SetLibCombinerName(const AValue: string); var LCombiner: TGLTextureCombiner; begin if csLoading in GetMaterialLibraryEx.ComponentState then begin FLibCombinerName := AValue; exit; end; if Assigned(FLibCombiner) then begin if FLibCombiner.Name = AValue then exit; FLibCombiner.UnregisterUser(Self); FLibCombiner := nil; end; LCombiner := GetMaterialLibraryEx.Components.GetCombinerByName(AValue); if Assigned(LCombiner) then begin LCombiner.RegisterUser(Self); FLibCombiner := LCombiner; end; NotifyChange(Self); end; procedure TGLMultitexturingProperties.SetLightSourceIndex(AValue: Integer); begin if AValue < 0 then AValue := 0 else if AValue > 7 then AValue := 7; FLightSourceIndex := AValue; end; procedure TGLMultitexturingProperties.SetLibAsmProgName(const AValue: string); var LProg: TGLASMVertexProgram; begin if csLoading in GetMaterialLibraryEx.ComponentState then begin FLibAsmProgName := AValue; exit; end; if Assigned(FLibAsmProg) then begin if FLibAsmProg.Name = AValue then exit; FLibAsmProg.UnregisterUser(Self); FLibAsmProg := nil; end; LProg := GetMaterialLibraryEx.Components.GetAsmProgByName(AValue); if Assigned(LProg) then begin LProg.RegisterUser(Self); FLibAsmProg := LProg; end; NotifyChange(Self); end; function TGLMultitexturingProperties.GetTexProps(AIndex: Integer): TGLTextureProperties; begin if not Assigned(FTexProps[AIndex]) then FTexProps[AIndex] := TGLTextureProperties.Create(Self); Result := FTexProps[AIndex]; end; procedure TGLMultitexturingProperties.SetTexProps(AIndex: Integer; AValue: TGLTextureProperties); begin FTexProps[AIndex].Assign(AValue); end; procedure TGLMultitexturingProperties.SetTextureMode(AValue: TGLTextureMode); begin if AValue <> FTextureMode then begin FTextureMode := AValue; NotifyChange(Self); end; end; procedure TGLMultitexturingProperties.UnApply(var ARci: TGLRenderContextInfo); var N: Integer; begin for N := 0 to High(FTexProps) do begin if FTexProps[N].Enabled then begin ARci.GLStates.ActiveTexture := N; FTexProps[N].UnApply(ARci); end; end; ARci.GLStates.ActiveTexture := 0; if Assigned(FLibAsmProg) then gl.Disable(GL_VERTEX_PROGRAM_ARB); end; { TVXTextureProperties } procedure TGLTextureProperties.Apply(var ARci: TGLRenderContextInfo); var glTarget: Cardinal; begin if Assigned(FLibTexture) then begin FLibTexture.FApplicableSampler := FLibSampler; FLibTexture.Apply(ARci); // Apply swizzling if possible glTarget := DecodeTextureTarget(FLibTexture.Shape); if GL.ARB_texture_swizzle or GL.EXT_texture_swizzle then begin if FSwizzling.FSwizzles[0] <> FLibTexture.FSwizzles[0] then begin FLibTexture.FSwizzles[0] := FSwizzling.FSwizzles[0]; gl.TexParameteri(glTarget, GL_TEXTURE_SWIZZLE_R, cTextureSwizzle[FSwizzling.FSwizzles[0]]); end; if FSwizzling.FSwizzles[1] <> FLibTexture.FSwizzles[1] then begin FLibTexture.FSwizzles[1] := FSwizzling.FSwizzles[1]; gl.TexParameteri(glTarget, GL_TEXTURE_SWIZZLE_G, cTextureSwizzle[FSwizzling.FSwizzles[1]]); end; if FSwizzling.FSwizzles[2] <> FLibTexture.FSwizzles[2] then begin FLibTexture.FSwizzles[2] := FSwizzling.FSwizzles[2]; gl.TexParameteri(glTarget, GL_TEXTURE_SWIZZLE_B, cTextureSwizzle[FSwizzling.FSwizzles[2]]); end; if FSwizzling.FSwizzles[3] <> FLibTexture.FSwizzles[3] then begin FLibTexture.FSwizzles[3] := FSwizzling.FSwizzles[3]; gl.TexParameteri(glTarget, GL_TEXTURE_SWIZZLE_A, cTextureSwizzle[FSwizzling.FSwizzles[3]]); end; end; if Assigned(FLibSampler) then begin if FLibSampler.IsValid then FLibSampler.Apply(ARci) else if FLibTexture.FLastSampler <> FLibSampler then begin // Sampler object not supported, lets use texture states gl.TexParameterfv(glTarget, GL_TEXTURE_BORDER_COLOR, FLibSampler.BorderColor.AsAddress); gl.TexParameteri(glTarget, GL_TEXTURE_WRAP_S, cTextureWrapMode[FLibSampler.WrapX]); gl.TexParameteri(glTarget, GL_TEXTURE_WRAP_T, cTextureWrapMode[FLibSampler.WrapY]); gl.TexParameteri(glTarget, GL_TEXTURE_WRAP_R, cTextureWrapMode[FLibSampler.WrapZ]); gl.TexParameterf(glTarget, GL_TEXTURE_LOD_BIAS, FLibSampler.LODBias + FLibSampler.FLODBiasFract); gl.TexParameteri(glTarget, GL_TEXTURE_MIN_FILTER, cTextureMinFilter[FLibSampler.MinFilter]); gl.TexParameteri(glTarget, GL_TEXTURE_MAG_FILTER, cTextureMagFilter[FLibSampler.MagFilter]); if GL.EXT_texture_filter_anisotropic then begin if FLibSampler.FilteringQuality = tfAnisotropic then gl.TexParameteri(glTarget, GL_TEXTURE_MAX_ANISOTROPY_EXT, CurrentGLContext.GLStates.MaxTextureAnisotropy) else gl.TexParameteri(glTarget, GL_TEXTURE_MAX_ANISOTROPY_EXT, 1); end; gl.TexParameteri(glTarget, GL_TEXTURE_COMPARE_MODE, cTextureCompareMode[FLibSampler.CompareMode]); gl.TexParameteri(glTarget, GL_TEXTURE_COMPARE_FUNC, cGLComparisonFunctionToGLEnum[FLibSampler.CompareFunc]); if GL.EXT_texture_sRGB_decode then begin if FLibSampler.sRGB_Encode then gl.TexParameteri(glTarget, GL_TEXTURE_SRGB_DECODE_EXT, GL_DECODE_EXT) else gl.TexParameteri(glTarget, GL_TEXTURE_SRGB_DECODE_EXT, GL_SKIP_DECODE_EXT); end; FLibTexture.FLastSampler := FLibSampler; end; end; if not FTextureMatrixIsIdentity and (MappingMode = tmmUser) then ARci.GLStates.SetGLTextureMatrix(FTextureMatrix); if ARci.currentMaterialLevel < mlSM3 then begin gl.TexEnvfv(GL_TEXTURE_ENV, GL_TEXTURE_ENV_COLOR, FEnvColor.AsAddress); ApplyMappingMode; if ARci.currentMaterialLevel = mlFixedFunction then XGL.MapTexCoordToMain; end; end; end; procedure TGLTextureProperties.ApplyMappingMode; var R_Dim: Boolean; begin begin R_Dim := GL.ARB_texture_cube_map or GL.EXT_texture3D; case MappingMode of tmmUser: ; // nothing to do, but checked first (common case) tmmObjectLinear: begin gl.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR); gl.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR); gl.TexGenfv(GL_S, GL_OBJECT_PLANE, @MappingSCoordinates.DirectVector); gl.TexGenfv(GL_T, GL_OBJECT_PLANE, @MappingTCoordinates.DirectVector); gl.Enable(GL_TEXTURE_GEN_S); gl.Enable(GL_TEXTURE_GEN_T); if R_Dim then begin gl.TexGeni(GL_R, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR); gl.TexGeni(GL_Q, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR); gl.TexGenfv(GL_R, GL_OBJECT_PLANE, @MappingRCoordinates.DirectVector); gl.TexGenfv(GL_Q, GL_OBJECT_PLANE, @MappingQCoordinates.DirectVector); gl.Enable(GL_TEXTURE_GEN_R); gl.Enable(GL_TEXTURE_GEN_Q); end; end; tmmEyeLinear: begin gl.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR); gl.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR); // specify planes in eye space, not world space gl.MatrixMode(GL_MODELVIEW); gl.PushMatrix; gl.LoadIdentity; gl.TexGenfv(GL_S, GL_EYE_PLANE, @MappingSCoordinates.DirectVector); gl.TexGenfv(GL_T, GL_EYE_PLANE, @MappingTCoordinates.DirectVector); gl.Enable(GL_TEXTURE_GEN_S); gl.Enable(GL_TEXTURE_GEN_T); if R_Dim then begin gl.TexGenfv(GL_R, GL_EYE_PLANE, @MappingRCoordinates.DirectVector); gl.TexGenfv(GL_Q, GL_EYE_PLANE, @MappingQCoordinates.DirectVector); gl.Enable(GL_TEXTURE_GEN_R); gl.Enable(GL_TEXTURE_GEN_Q); end; gl.PopMatrix; end; tmmSphere: begin gl.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP); gl.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP); gl.Enable(GL_TEXTURE_GEN_S); gl.Enable(GL_TEXTURE_GEN_T); end; tmmCubeMapReflection, tmmCubeMapCamera: if R_Dim then begin gl.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP); gl.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP); gl.TexGeni(GL_R, GL_TEXTURE_GEN_MODE, GL_REFLECTION_MAP); gl.Enable(GL_TEXTURE_GEN_S); gl.Enable(GL_TEXTURE_GEN_T); gl.Enable(GL_TEXTURE_GEN_R); end; tmmCubeMapNormal, tmmCubeMapLight0: if R_Dim then begin gl.TexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP); gl.TexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP); gl.TexGeni(GL_R, GL_TEXTURE_GEN_MODE, GL_NORMAL_MAP); gl.Enable(GL_TEXTURE_GEN_S); gl.Enable(GL_TEXTURE_GEN_T); gl.Enable(GL_TEXTURE_GEN_R); end; end; end; end; procedure TGLTextureProperties.Assign(Source: TPersistent); var LTexProp: TGLTextureProperties; begin if Source is TGLTextureProperties then begin LTexProp := TGLTextureProperties(Source); LibTextureName := LTexProp.LibTextureName; LibSamplerName := LTexProp.LibSamplerName; TextureOffset.Assign(LTexProp.TextureOffset); TextureScale.Assign(LTexProp.TextureScale); FTextureRotate := LTexProp.TextureRotate; FEnvColor.Assign(LTexProp.EnvColor); FMappingMode := LTexProp.MappingMode; MappingSCoordinates.Assign(LTexProp.MappingSCoordinates); MappingTCoordinates.Assign(LTexProp.MappingTCoordinates); MappingRCoordinates.Assign(LTexProp.MappingRCoordinates); MappingQCoordinates.Assign(LTexProp.MappingQCoordinates); end; inherited; end; procedure TGLTextureProperties.CalculateTextureMatrix; begin if not (Assigned(FTextureOffset) or Assigned(FTextureScale) or StoreTextureRotate) then begin FTextureMatrixIsIdentity := True; exit; end; if TextureOffset.Equals(NullHmgVector) and TextureScale.Equals(XYZHmgVector) and not StoreTextureRotate then FTextureMatrixIsIdentity := True else begin FTextureMatrixIsIdentity := False; FTextureMatrix := CreateScaleAndTranslationMatrix( TextureScale.AsVector, TextureOffset.AsVector); if StoreTextureRotate then FTextureMatrix := MatrixMultiply(FTextureMatrix, CreateRotationMatrixZ(DegToRad(FTextureRotate))); end; FTextureOverride := False; NotifyChange(Self); end; constructor TGLTextureProperties.Create(AOwner: TPersistent); begin inherited; FTextureRotate := 0; FMappingMode := tmmUser; FTextureMatrix := IdentityHmgMatrix; FEnabled := False; FSwizzling := TGLTextureSwizzling.Create(Self); FEnvColor := TGLColor.CreateInitialized(Self, clrTransparent); end; destructor TGLTextureProperties.Destroy; begin if Assigned(FLibSampler) then FLibSampler.UnregisterUser(Self); if Assigned(FLibTexture) then FLibTexture.UnregisterUser(Self); FTextureOffset.Free; FTextureScale.Free; FMapSCoordinates.Free; FMapTCoordinates.Free; FMapRCoordinates.Free; FMapQCoordinates.Free; FSwizzling.Destroy; FEnvColor.Destroy; inherited; end; function TGLTextureProperties.GetLibSamplerName: TGLMaterialComponentName; begin if Assigned(FLibSampler) then Result := FLibSampler.Name else Result := ''; end; function TGLTextureProperties.GetLibTextureName: TGLMaterialComponentName; begin if Assigned(FLibTexture) then Result := FLibTexture.Name else Result := ''; end; function TGLTextureProperties.GetMappingQCoordinates: TGLCoordinates4; begin if not Assigned(FMapQCoordinates) then FMapQCoordinates := TGLCoordinates4.CreateInitialized(Self, WHmgVector, csVector); Result := FMapQCoordinates; end; function TGLTextureProperties.GetMappingRCoordinates: TGLCoordinates4; begin if not Assigned(FMapRCoordinates) then FMapRCoordinates := TGLCoordinates4.CreateInitialized(Self, ZHmgVector, csVector); Result := FMapRCoordinates; end; function TGLTextureProperties.GetMappingSCoordinates: TGLCoordinates4; begin if not Assigned(FMapSCoordinates) then FMapSCoordinates := TGLCoordinates4.CreateInitialized(Self, XHmgVector, csVector); Result := FMapSCoordinates; end; function TGLTextureProperties.GetMappingTCoordinates: TGLCoordinates4; begin if not Assigned(FMapTCoordinates) then FMapTCoordinates := TGLCoordinates4.CreateInitialized(Self, YHmgVector, csVector); Result := FMapTCoordinates; end; function TGLTextureProperties.GetTextureOffset: TGLCoordinates; begin if not Assigned(FTextureOffset) then FTextureOffset := TGLCoordinates3.CreateInitialized(Self, NullHmgVector, csPoint); Result := FTextureOffset; end; function TGLTextureProperties.GetTextureScale: TGLCoordinates; begin if not Assigned(FTextureScale) then FTextureScale := TGLCoordinates3.CreateInitialized(Self, VectorMake(1, 1, 1, 1), csVector); Result := FTextureScale; end; function TGLTextureProperties.IsValid: Boolean; begin if Assigned(FLibTexture) then Result := FLibTexture.IsValid else Result := False; end; procedure TGLTextureProperties.Loaded; begin SetLibTextureName(FLibTextureName); SetLibSamplerName(FLibSamplerName); CalculateTextureMatrix; end; procedure TGLTextureProperties.Notification(Sender: TObject; Operation: TOperation); begin if Operation = opRemove then begin if Sender = FLibTexture then FLibTexture := nil else if Sender = FLibSampler then FLibSampler := nil; end; end; procedure TGLTextureProperties.NotifyChange(Sender: TObject); begin inherited; if (Sender = FTextureOffset) or (Sender = FTextureScale) then CalculateTextureMatrix; if (Sender = FLibSampler) and Assigned(FLibTexture) then FLibTexture.FLastSampler := nil; end; procedure TGLTextureProperties.SetLibSamplerName(const AValue: TGLMaterialComponentName); var LSampler: TGLTextureSampler; begin if csLoading in GetMaterialLibraryEx.ComponentState then begin FLibSamplerName := AValue; exit; end; if Assigned(FLibSampler) then begin if FLibSampler.Name = AValue then exit; FLibSampler.UnregisterUser(Self); FLibSampler := nil; end; LSampler := GetMaterialLibraryEx.Components.GetSamplerByName(AValue); if Assigned(LSampler) then begin LSampler.RegisterUser(Self); FLibSampler := LSampler; end; NotifyChange(Self); end; procedure TGLTextureProperties.SetLibTextureName(const AValue: TGLMaterialComponentName); var LTexture: TGLAbstractTexture; begin if csLoading in GetMaterialLibraryEx.ComponentState then begin FLibTextureName := AValue; exit; end; if Assigned(FLibTexture) then begin if FLibTexture.Name = AValue then exit; FLibTexture.UnregisterUser(Self); FLibTexture := nil; end; LTexture := GetMaterialLibraryEx.Components.GetTextureByName(AValue); if Assigned(LTexture) then begin if LTexture is TGLFrameBufferAttachment then begin if TGLFrameBufferAttachment(LTexture).OnlyWrite then begin if IsDesignTime then InformationDlg('Can not use write only attachment as texture') else GLSLogger.LogErrorFmt('Attempt to use write only attachment "%s" as texture', [LTexture.Name]); NotifyChange(Self); exit; end; end; LTexture.RegisterUser(Self); FLibTexture := LTexture; end; NotifyChange(Self); end; procedure TGLTextureProperties.SetMappingMode( const AValue: TGLTextureMappingMode); begin if AValue <> FMappingMode then begin FMappingMode := AValue; NotifyChange(Self); end; end; procedure TGLTextureProperties.SetMappingQCoordinates( const AValue: TGLCoordinates4); begin MappingQCoordinates.Assign(AValue); end; procedure TGLTextureProperties.SetMappingRCoordinates( const AValue: TGLCoordinates4); begin MappingRCoordinates.Assign(AValue); end; procedure TGLTextureProperties.SetMappingSCoordinates( const AValue: TGLCoordinates4); begin MappingSCoordinates.Assign(AValue); end; procedure TGLTextureProperties.SetMappingTCoordinates( const AValue: TGLCoordinates4); begin MappingTCoordinates.Assign(AValue); end; procedure TGLTextureProperties.SetSwizzling(const AValue: TGLTextureSwizzling); begin FSwizzling.Assign(AValue); end; procedure TGLTextureProperties.SetTextureMatrix(const AValue: TGLMatrix); begin FTextureMatrixIsIdentity := CompareMem(@AValue.V[0], @IdentityHmgMatrix.V[0], SizeOf(TGLMatrix)); FTextureMatrix := AValue; FTextureOverride := True; NotifyChange(Self); end; procedure TGLTextureProperties.SetTextureOffset(const AValue: TGLCoordinates); begin TextureOffset.Assign(AValue); CalculateTextureMatrix; end; procedure TGLTextureProperties.SetTextureRotate(AValue: Single); begin if AValue <> FTextureRotate then begin FTextureRotate := AValue; CalculateTextureMatrix; NotifyChange(Self); end; end; procedure TGLTextureProperties.SetTextureScale(const AValue: TGLCoordinates); begin TextureScale.Assign(AValue); CalculateTextureMatrix; end; function TGLTextureProperties.StoreMappingQCoordinates: Boolean; begin if Assigned(FMapQCoordinates) then Result := not VectorEquals(FMapQCoordinates.AsVector, WHmgVector) else Result := false; end; function TGLTextureProperties.StoreMappingRCoordinates: Boolean; begin if Assigned(FMapRCoordinates) then Result := not VectorEquals(FMapRCoordinates.AsVector, ZHmgVector) else Result := false; end; function TGLTextureProperties.StoreMappingSCoordinates: Boolean; begin if Assigned(FMapSCoordinates) then Result := not VectorEquals(FMapSCoordinates.AsVector, XHmgVector) else Result := false; end; function TGLTextureProperties.StoreMappingTCoordinates: Boolean; begin if Assigned(FMapTCoordinates) then Result := not VectorEquals(FMapTCoordinates.AsVector, YHmgVector) else Result := false; end; function TGLTextureProperties.StoreSwizzling: Boolean; begin Result := FSwizzling.StoreSwizzle(0); end; function TGLTextureProperties.StoreTextureOffset: Boolean; begin Result := Assigned(FTextureOffset); end; function TGLTextureProperties.StoreTextureRotate: Boolean; begin Result := Abs(FTextureRotate) > EPSILON; end; function TGLTextureProperties.StoreTextureScale: Boolean; begin Result := Assigned(FTextureScale); end; procedure TGLTextureProperties.SetEnvColor(const AValue: TGLColor); begin FEnvColor.Assign(AValue); NotifyChange(Self); end; procedure TGLTextureProperties.UnApply(var ARci: TGLRenderContextInfo); begin if Assigned(FLibTexture) then begin FLibTexture.UnApply(ARci); if Assigned(FLibSampler) then FLibSampler.UnApply(ARci); if ARci.currentMaterialLevel < mlSM3 then begin if not FTextureMatrixIsIdentity and (MappingMode = tmmUser) then ARci.GLStates.SetGLTextureMatrix(IdentityHmgMatrix); UnApplyMappingMode; end; end; end; procedure TGLTextureProperties.UnApplyMappingMode; begin if MappingMode <> tmmUser then begin gl.Disable(GL_TEXTURE_GEN_S); gl.Disable(GL_TEXTURE_GEN_T); if gl.EXT_texture3D or gl.ARB_texture_cube_map then begin gl.Disable(GL_TEXTURE_GEN_R); gl.Disable(GL_TEXTURE_GEN_Q); end; end; end; { TVXShaderEx } procedure TGLShaderEx.Assign(Source: TPersistent); var LShader: TGLShaderEx; begin if Source is TGLShaderEx then begin LShader := TGLShaderEx(Source); FSource.Assign(LShader.Source); FShaderType := LShader.FShaderType; NotifyChange(Self); end; inherited; end; constructor TGLShaderEx.Create(AOwner: TXCollection); const cShaderClasses: array[TGLShaderType] of TGLShaderHandleClass = ( TGLVertexShaderHandle, TGLTessControlShaderHandle, TGLTessEvaluationShaderHandle, TGLGeometryShaderHandle, TGLFragmentShaderHandle ); var S: TGLShaderType; begin inherited; FDefferedInit := False; for S := Low(TGLShaderType) to High(TGLShaderType) do begin FHandle[S] := cShaderClasses[S].Create; FHandle[S].OnPrapare := DoOnPrepare; end; FSource := TStringList.Create; FSource.OnChange := NotifyChange; FShaderType := shtVertex; FGeometryInput := gsInPoints; FGeometryOutput := gsOutPoints; FGeometryVerticesOut := 1; Name := TGLMatLibComponents(AOwner).MakeUniqueName('Shader'); end; destructor TGLShaderEx.Destroy; var S: TGLShaderType; begin for S := Low(TGLShaderType) to High(TGLShaderType) do FHandle[S].Destroy; FSource.Destroy; inherited; end; procedure TGLShaderEx.NotifyChange(Sender: TObject); var S: TGLShaderType; begin for S := Low(TGLShaderType) to High(TGLShaderType) do FHandle[S].NotifyChangesOfData; if (Sender = FSource) and IsDesignTime and (Length(FSourceFile) > 0) then FSource.SaveToFile(FSourceFile); inherited; end; procedure TGLShaderEx.DoOnPrepare(Sender: TGLContext); begin if not IsDesignTime and FDefferedInit then exit; try if FHandle[FShaderType].IsSupported then begin FHandle[FShaderType].AllocateHandle; if FHandle[FShaderType].IsDataNeedUpdate then begin SetExeDirectory; if (Length(FSourceFile) > 0) and FileStreamExists(FSourceFile) then FSource.LoadFromFile(FSourceFile); FHandle[FShaderType].ShaderSource(AnsiString(FSource.Text)); FIsValid := FHandle[FShaderType].CompileShader; if IsDesignTime then begin FInfoLog := FHandle[FShaderType].InfoLog; if (Length(FInfoLog) = 0) and FIsValid then FInfoLog := 'Compilation successful'; end else if FIsValid then GLSLogger.LogInfoFmt('Shader "%s" compilation successful - %s', [Name, FHandle[FShaderType].InfoLog]) else GLSLogger.LogErrorFmt('Shader "%s" compilation failed - %s', [Name, FHandle[FShaderType].InfoLog]); FHandle[FShaderType].NotifyDataUpdated; end; end else begin FIsValid := False; if IsDesignTime then FInfoLog := 'Not supported by hardware'; end; except on E: Exception do begin FIsValid := False; if IsDesignTime then InformationDlg(E.ClassName + ': ' + E.Message) else GLSLogger.LogError(E.ClassName + ': ' + E.Message); end; end; end; class function TGLShaderEx.FriendlyName: string; begin Result := 'GLSL Shader'; end; function TGLShaderEx.GetHandle: TGLShaderHandle; begin Result := FHandle[FShaderType]; end; procedure TGLShaderEx.ReadFromFiler(AReader: TReader); var archiveVersion: Integer; begin with AReader do begin archiveVersion := ReadInteger; if archiveVersion = 0 then begin Name := ReadString; FDefferedInit := ReadBoolean; FSource.Text := ReadString; FSourceFile := ReadString; FShaderType := TGLShaderType(ReadInteger); FGeometryInput := TGLgsInTypes(ReadInteger); FGeometryOutput := TGLgsOutTypes(ReadInteger); FGeometryVerticesOut := ReadInteger; end else RaiseFilerException(archiveVersion); end; end; procedure TGLShaderEx.SetGeometryInput(AValue: TGLgsInTypes); begin if AValue <> FGeometryInput then begin FGeometryInput := AValue; NotifyChange(Self); end; end; procedure TGLShaderEx.SetGeometryOutput(AValue: TGLgsOutTypes); begin if AValue <> FGeometryOutput then begin FGeometryOutput := AValue; NotifyChange(Self); end; end; procedure TGLShaderEx.SetGeometryVerticesOut(AValue: TGLint); begin if AValue < 1 then AValue := 1 else if AValue > 1024 then AValue := 1024; if AValue <> FGeometryVerticesOut then begin FGeometryVerticesOut := AValue; NotifyChange(Self); end; end; procedure TGLShaderEx.SetShaderType(AValue: TGLShaderType); begin if FShaderType <> AValue then begin FShaderType := AValue; NotifyChange(Self); end; end; procedure TGLShaderEx.SetSource(AValue: TStringList); begin FSource.Assign(AValue); end; procedure TGLShaderEx.SetSourceFile(AValue: string); begin FixPathDelimiter(AValue); if FSourceFile <> AValue then begin FSourceFile := AValue; NotifyChange(Self); end; end; procedure TGLShaderEx.WriteToFiler(AWriter: TWriter); begin with AWriter do begin WriteInteger(0); // archive version WriteString(Name); WriteBoolean(FDefferedInit); if Length(FSourceFile) = 0 then WriteString(FSource.Text) else WriteString(''); WriteString(FSourceFile); WriteInteger(Integer(FShaderType)); WriteInteger(Integer(FGeometryInput)); WriteInteger(Integer(FGeometryOutput)); WriteInteger(FGeometryVerticesOut); end; end; { TVXLibMaterialProperty } function TGLLibMaterialProperty.GetMaterial: TGLLibMaterialEx; begin if Owner is TGLLibMaterialEx then Result := TGLLibMaterialEx(Owner) else if Owner is TGLLibMaterialProperty then Result := TGLLibMaterialProperty(Owner).GetMaterial else Result := nil; end; function TGLLibMaterialProperty.GetMaterialLibrary: TGLAbstractMaterialLibrary; begin if Owner is TGLBaseMaterialCollectionItem then Result := TGLBaseMaterialCollectionItem(Owner).GetMaterialLibrary else Result := GetMaterial.GetMaterialLibrary; end; function TGLLibMaterialProperty.GetMaterialLibraryEx: TGLMaterialLibraryEx; begin if Owner is TGLBaseMaterialCollectionItem then Result := TGLBaseMaterialCollectionItem(Owner).GetMaterialLibraryEx else Result := TGLMaterialLibraryEx(GetMaterial.GetMaterialLibrary); end; procedure TGLLibMaterialProperty.SetNextPass(const AValue: TGLLibMaterialName); begin if AValue <> FNextPassName then begin FNextPassName := AValue; NotifyChange(Self); end; end; procedure TGLLibMaterialProperty.Loaded; begin end; procedure TGLLibMaterialProperty.NotifyChange(Sender: TObject); var NA: IGLNotifyAble; begin if Assigned(Owner) then begin if Supports(Owner, IGLNotifyAble, NA) then NA.NotifyChange(Self) end; if Assigned(OnNotifyChange) then OnNotifyChange(Self); end; procedure TGLLibMaterialProperty.SetEnabled(AValue: Boolean); begin if FEnabled <> AValue then begin FEnabled := AValue; if Owner is TGLLibMaterialEx then GetMaterial.NotifyChange(Self); end; end; { TVXLibMaterialsEx } function TGLLibMaterialsEx.Add: TGLLibMaterialEx; begin Result := (inherited Add) as TGLLibMaterialEx; end; constructor TGLLibMaterialsEx.Create(AOwner: TComponent); begin inherited Create(AOwner, TGLLibMaterialEx); end; function TGLLibMaterialsEx.FindItemID(ID: Integer): TGLLibMaterialEx; begin Result := (inherited FindItemID(ID)) as TGLLibMaterialEx; end; function TGLLibMaterialsEx.GetItems(AIndex: Integer): TGLLibMaterialEx; begin Result := TGLLibMaterialEx(inherited Items[AIndex]); end; function TGLLibMaterialsEx.GetLibMaterialByName( const AName: string): TGLLibMaterialEx; var LMaterial: TGLAbstractLibMaterial; begin LMaterial := GetMaterial(AName); if Assigned(LMaterial) and (LMaterial is TGLLibMaterialEx) then Result := TGLLibMaterialEx(LMaterial) else Result := nil; end; function TGLLibMaterialsEx.IndexOf(const Item: TGLLibMaterialEx): Integer; var I: Integer; begin Result := -1; if Count <> 0 then for I := 0 to Count - 1 do if GetItems(I) = Item then begin Result := I; Exit; end; end; function TGLLibMaterialsEx.MaterialLibrary: TGLMaterialLibraryEx; begin Result := TGLMaterialLibraryEx(GetOwner); end; procedure TGLLibMaterialsEx.SetItems(AIndex: Integer; const AValue: TGLLibMaterialEx); begin inherited Items[AIndex] := AValue; end; { TVXBaseShaderModel } procedure TGLBaseShaderModel.Apply(var ARci: TGLRenderContextInfo); var I: Integer; LEvent: TOnUniformSetting; begin if FIsValid then begin FHandle.UseProgramObject; if FAutoFill then for I := FUniforms.Count - 1 downto 0 do TGLAbstractShaderUniform(FUniforms[I]).Apply(ARci); if Self is TGLShaderModel3 then LEvent := GetMaterial.FOnSM3UniformSetting else if Self is TGLShaderModel4 then LEvent := GetMaterial.FOnSM4UniformSetting else if Self is TGLShaderModel5 then LEvent := GetMaterial.FOnSM5UniformSetting else LEvent := nil; if Assigned(LEvent) then LEvent(Self, ARci); end; end; procedure TGLBaseShaderModel.Assign(Source: TPersistent); var SM: TGLBaseShaderModel; begin if Source is TGLBaseShaderModel then begin SM := TGLBaseShaderModel(Source); LibVertexShaderName := SM.LibVertexShaderName; LibFragmentShaderName := SM.LibFragmentShaderName; LibGeometryShaderName := SM.LibGeometryShaderName; LibTessControlShaderName := SM.LibTessControlShaderName; LibTessEvalShaderName := SM.LibTessEvalShaderName; end; inherited; end; constructor TGLBaseShaderModel.Create(AOwner: TPersistent); begin inherited; FHandle := TGLProgramHandle.Create; FHandle.OnPrapare := DoOnPrepare; FEnabled := False; FUniforms := TGLPersistentObjectList.Create; FAutoFill := True; end; procedure TGLBaseShaderModel.DefineProperties(Filer: TFiler); begin inherited; Filer.DefineBinaryProperty( 'Uniforms', ReadUniforms, WriteUniforms, FUniforms.Count > 0); end; destructor TGLBaseShaderModel.Destroy; begin FHandle.Destroy; LibVertexShaderName := ''; LibFragmentShaderName := ''; LibGeometryShaderName := ''; LibTessControlShaderName := ''; LibTessEvalShaderName := ''; FUniforms.CleanFree; inherited; end; procedure TGLBaseShaderModel.DoOnPrepare(Sender: TGLContext); var T: TGLShaderType; LUniforms: TGLPersistentObjectList; LUniform, LUniform2: TGLShaderUniform; ID: Cardinal; I, J, C: Integer; buff: array[0..255] of AnsiChar; Size: TGLInt; Len: TGLsizei; Loc: TGLint; AType: Cardinal; UName: string; GLSLData: TGLSLDataType; GLSLSampler: TGLSLSamplerType; bSampler: Boolean; bNew: Boolean; LEvent: TOnUniformInitialize; begin if FEnabled then try if IsSupported and FHandle.IsSupported then begin FHandle.AllocateHandle; if FHandle.IsDataNeedUpdate then begin // Validate shaders for T := Low(TGLShaderType) to High(TGLShaderType) do if Assigned(FShaders[T]) then begin FShaders[T].DoOnPrepare(Sender); if not FShaders[T].IsValid then begin if IsDesignTime then FInfoLog := Format('%s shader "%s" is invalid', [cShaderTypeName[FShaders[T].ShaderType], FShaders[T].Name]); FIsValid := False; exit; end; end; // Gather shader FHandle.DetachAllObject; for T := Low(TGLShaderType) to High(TGLShaderType) do if Assigned(FShaders[T]) then FHandle.AttachObject(FShaders[T].Handle); ID := FHandle.Handle; begin // Can be override by layouts in shader if Assigned(FShaders[shtGeometry]) then begin gl.ProgramParameteri(ID, GL_GEOMETRY_INPUT_TYPE_EXT, cGLgsInTypes[FShaders[shtGeometry].GeometryInput]); gl.ProgramParameteri(ID, GL_GEOMETRY_OUTPUT_TYPE_EXT, cGLgsOutTypes[FShaders[shtGeometry].GeometryOutput]); gl.ProgramParameteri(ID, GL_GEOMETRY_VERTICES_OUT_EXT, FShaders[shtGeometry].GeometryVerticesOut); end; if FHandle.LinkProgram then begin // Get final values if Assigned(FShaders[shtGeometry]) then begin gl.GetProgramiv(ID, GL_GEOMETRY_INPUT_TYPE_EXT, @AType); case AType of GL_POINTS: FShaders[shtGeometry].FGeometryInput := gsInPoints; GL_LINES: FShaders[shtGeometry].FGeometryInput := gsInLines; GL_LINES_ADJACENCY_EXT: FShaders[shtGeometry].FGeometryInput := gsInAdjLines; GL_TRIANGLES: FShaders[shtGeometry].FGeometryInput := gsInTriangles; GL_TRIANGLES_ADJACENCY_EXT: FShaders[shtGeometry].FGeometryInput := gsInAdjTriangles; end; gl.GetProgramiv(ID, GL_GEOMETRY_OUTPUT_TYPE_EXT, @AType); case AType of GL_POINTS: FShaders[shtGeometry].FGeometryOutput := gsOutPoints; GL_LINE_STRIP: FShaders[shtGeometry].FGeometryOutput := gsOutLineStrip; GL_TRIANGLE_STRIP: FShaders[shtGeometry].FGeometryOutput := sOutTriangleStrip; end; gl.GetProgramiv(ID, GL_GEOMETRY_VERTICES_OUT_EXT, @I); if I > 0 then FShaders[shtGeometry].FGeometryVerticesOut := I; gl.ClearError; end; // Get uniforms LUniforms := TGLPersistentObjectList.Create; gl.GetProgramiv(ID, GL_ACTIVE_UNIFORMS, @C); for I := 0 to C - 1 do begin gl.GetActiveUniform( ID, Cardinal(I), Length(buff), @Len, @Size, @AType, @buff[0]); Loc := gl.GetUniformLocation(ID, @buff[0]); if Loc < 0 then continue; UName := Copy(string(buff), 0, Len); GLSLData := GLSLTypeUndefined; GLSLSampler := GLSLSamplerUndefined; case AType of GL_FLOAT: GLSLData := GLSLType1F; GL_FLOAT_VEC2: GLSLData := GLSLType2F; GL_FLOAT_VEC3: GLSLData := GLSLType3F; GL_FLOAT_VEC4: GLSLData := GLSLType4F; GL_INT: GLSLData := GLSLType1I; GL_INT_VEC2: GLSLData := GLSLType2I; GL_INT_VEC3: GLSLData := GLSLType3I; GL_INT_VEC4: GLSLData := GLSLType4I; GL_UNSIGNED_INT: GLSLData := GLSLType1UI; GL_UNSIGNED_INT_VEC2: GLSLData := GLSLType2UI; GL_UNSIGNED_INT_VEC3: GLSLData := GLSLType3UI; GL_UNSIGNED_INT_VEC4: GLSLData := GLSLType4UI; GL_BOOL: GLSLData := GLSLType1I; GL_BOOL_VEC2: GLSLData := GLSLType2I; GL_BOOL_VEC3: GLSLData := GLSLType3I; GL_BOOL_VEC4: GLSLData := GLSLType4I; GL_FLOAT_MAT2: GLSLData := GLSLTypeMat2F; GL_FLOAT_MAT3: GLSLData := GLSLTypeMat3F; GL_FLOAT_MAT4: GLSLData := GLSLTypeMat4F; //------------------------------------------------------------------------------ GL_SAMPLER_1D: GLSLSampler := GLSLSampler1D; GL_SAMPLER_2D: GLSLSampler := GLSLSampler2D; GL_SAMPLER_3D: GLSLSampler := GLSLSampler3D; GL_SAMPLER_CUBE: GLSLSampler := GLSLSamplerCube; GL_SAMPLER_1D_SHADOW: GLSLSampler := GLSLSampler1DShadow; GL_SAMPLER_2D_SHADOW: GLSLSampler := GLSLSampler2DShadow; GL_SAMPLER_2D_RECT: GLSLSampler := GLSLSamplerRect; GL_SAMPLER_2D_RECT_SHADOW: GLSLSampler := GLSLSamplerRectShadow; GL_SAMPLER_BUFFER: GLSLSampler := GLSLSamplerBuffer; GL_INT_SAMPLER_2D_RECT: GLSLSampler := GLSLIntSamplerRect; GL_INT_SAMPLER_BUFFER: GLSLSampler := GLSLIntSamplerBuffer; GL_UNSIGNED_INT_SAMPLER_1D: GLSLSampler := GLSLUIntSampler1D; GL_UNSIGNED_INT_SAMPLER_2D: GLSLSampler := GLSLUIntSampler2D; GL_UNSIGNED_INT_SAMPLER_3D: GLSLSampler := GLSLUIntSampler3D; GL_UNSIGNED_INT_SAMPLER_CUBE: GLSLSampler := GLSLUIntSamplerCube; GL_UNSIGNED_INT_SAMPLER_1D_ARRAY: GLSLSampler := GLSLUIntSampler1DArray; GL_UNSIGNED_INT_SAMPLER_2D_ARRAY: GLSLSampler := GLSLUIntSampler2DArray; GL_UNSIGNED_INT_SAMPLER_2D_RECT: GLSLSampler := GLSLUIntSamplerRect; GL_UNSIGNED_INT_SAMPLER_BUFFER: GLSLSampler := GLSLUIntSamplerBuffer; GL_SAMPLER_2D_MULTISAMPLE: GLSLSampler := GLSLSamplerMS; GL_INT_SAMPLER_2D_MULTISAMPLE: GLSLSampler := GLSLIntSamplerMS; GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE: GLSLSampler := GLSLUIntSamplerMS; GL_SAMPLER_2D_MULTISAMPLE_ARRAY: GLSLSampler := GLSLSamplerMSArray; GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY: GLSLSampler := GLSLIntSamplerMSArray; GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY: GLSLSampler := GLSLUIntSamplerMSArray; end; bSampler := False; if (GLSLData = GLSLTypeUndefined) and (GLSLSampler = GLSLSamplerUndefined) then begin GLSLogger.LogWarningFmt( 'Detected active uniform "%s" with unknown type', [UName]); continue; end else if GLSLData <> GLSLTypeUndefined then begin GLSLogger.LogInfoFmt('Detected active uniform: %s %s', [cGLSLTypeString[GLSLData], UName]); end else begin bSampler := True; GLSLogger.LogInfoFmt('Detected active uniform: %s %s', [cGLSLSamplerString[GLSLSampler], UName]); end; // Find already existing uniform bNew := True; for J := 0 to FUniforms.Count - 1 do begin if not (FUniforms[J] is TGLShaderUniform) then continue; LUniform := TGLShaderUniform(FUniforms[J]); if not Assigned(LUniform) then continue; if LUniform.Name = UName then begin if bSampler and (LUniform is TGLShaderUniformTexture) then begin if TGLShaderUniformTexture(LUniform).FSamplerType = GLSLSampler then begin LUniform.FLocation := Loc; LUniform.FType := GLSLType1I; TGLShaderUniformTexture(LUniform).FTarget := cSamplerToTexture[GLSLSampler]; LUniforms.Add(LUniform); FUniforms[J] := nil; bNew := False; break; end end else begin if LUniform.FType = GLSLData then begin if (LUniform is TGLShaderUniformDSA) and not GL.EXT_direct_state_access then begin LUniform2 := LUniform; LUniform := TGLShaderUniform.Create(Self); LUniform._AddRef; LUniform.Assign(LUniform2); LUniform2._Release; end; LUniform.FLocation := Loc; LUniforms.Add(LUniform); FUniforms[J] := nil; bNew := False; break; end; end; end; end; // for J if bNew then begin // Creates new uniform if bSampler then begin LUniform := TGLShaderUniformTexture.Create(Self); LUniform.FType := GLSLType1I; TGLShaderUniformTexture(LUniform).FSamplerType := GLSLSampler; TGLShaderUniformTexture(LUniform).FTarget := cSamplerToTexture[GLSLSampler]; end else begin if GL.EXT_direct_state_access then LUniform := TGLShaderUniformDSA.Create(Self) else LUniform := TGLShaderUniform.Create(Self); LUniform.FType := GLSLData; end; LUniform._AddRef; LUniform.FName := UName; LUniform.FNameHashCode := ComputeNameHashKey(UName); LUniform.FLocation := Loc; LUniforms.Add(LUniform); end; end; // for I // Clean old unused uniforms ReleaseUniforms(FUniforms); // Assign new one FUniforms := LUniforms; FHandle.NotifyDataUpdated; FIsValid := True; if Self is TGLShaderModel3 then LEvent := GetMaterial.FOnSM3UniformInit else if Self is TGLShaderModel4 then LEvent := GetMaterial.FOnSM4UniformInit else if Self is TGLShaderModel5 then LEvent := GetMaterial.FOnSM5UniformInit else LEvent := nil; if Assigned(LEvent) then LEvent(Self); end // if LinkProgram else FIsValid := False; end; // with GL if IsDesignTime then begin FInfoLog := FHandle.InfoLog; if (Length(FInfoLog) = 0) and FIsValid then FInfoLog := 'Link successful'; end else if FIsValid then GLSLogger.LogInfoFmt('Program "%s" link successful - %s', [GetMaterial.Name, FHandle.InfoLog]) else GLSLogger.LogErrorFmt('Program "%s" link failed! - %s', [GetMaterial.Name, FHandle.InfoLog]); end; end else begin if IsDesignTime then FInfoLog := 'Not supported by hardware'; FIsValid := False; end; except on E: Exception do begin FIsValid := False; if IsDesignTime then InformationDlg(E.ClassName + ': ' + E.Message) else GLSLogger.LogError(E.ClassName + ': ' + E.Message); end; end; end; procedure TGLBaseShaderModel.Notification(Sender: TObject; Operation: TOperation); var st: TGLShaderType; begin if Operation = opRemove then begin for st := Low(TGLShaderType) to High(TGLShaderType) do if FShaders[st] = Sender then begin FShaders[st] := nil; FLibShaderName[st] := ''; NotifyChange(Self); exit; end; end; end; procedure TGLBaseShaderModel.NotifyChange(Sender: TObject); begin FHandle.NotifyChangesOfData; inherited; end; procedure TGLBaseShaderModel.ReadUniforms(AStream: TStream); var LReader: TReader; N, I: Integer; str: string; LUniform: TGLAbstractShaderUniform; LClass: CGLAbstractShaderUniform; begin LReader := TReader.Create(AStream, 16384); try N := LReader.ReadInteger; for I := 0 to N - 1 do begin str := LReader.ReadString; LClass := CGLAbstractShaderUniform(FindClass(str)); LUniform := LClass.Create(Self); LUniform._AddRef; LUniform.ReadFromFiler(LReader); FUniforms.Add(LUniform); end; finally LReader.Free; end; end; class procedure TGLBaseShaderModel.ReleaseUniforms( AList: TGLPersistentObjectList); var I: Integer; begin for I := 0 to AList.Count - 1 do if Assigned(AList[I]) then TGLAbstractShaderUniform(AList[I])._Release; AList.Destroy; end; function TGLBaseShaderModel.GetLibShaderName(AType: TGLShaderType): string; begin if Assigned(FShaders[AType]) then Result := FShaders[AType].Name else Result := ''; end; function TGLBaseShaderModel.GetUniform(const AName: string): IShaderParameter; var H, I: Integer; U: TGLAbstractShaderUniform; begin Result := nil; H := ComputeNameHashKey(AName); for I := 0 to FUniforms.Count - 1 do begin U := TGLAbstractShaderUniform(FUniforms[I]); if (U.FNameHashCode = H) and (U.FName = AName) then begin Result := U; exit; end; end; if not IsDesignTime then begin GLSLogger.LogErrorFmt('Attempt to use unknow uniform "%s" for material "%s"', [AName, GetMaterial.Name]); U := TGLAbstractShaderUniform.Create(Self); U._AddRef; U.FName := AName; U.FNameHashCode := H; FUniforms.Add(U); Result := U; end; end; procedure TGLBaseShaderModel.Loaded; var T: TGLShaderType; I: Integer; begin for T := Low(TGLShaderType) to High(TGLShaderType) do SetLibShaderName(T, FLibShaderName[T]); for I := 0 to FUniforms.Count - 1 do if FUniforms[I] is TGLShaderUniformTexture then TGLShaderUniformTexture(FUniforms[I]).Loaded; end; procedure TGLBaseShaderModel.GetUniformNames(Proc: TGetStrProc); var I: Integer; begin for I := 0 to FUniforms.Count - 1 do Proc(TGLAbstractShaderUniform(FUniforms[I]).FName); end; procedure TGLBaseShaderModel.SetLibShaderName(AType: TGLShaderType; const AValue: string); var LShader: TGLShaderEx; begin if csLoading in GetMaterialLibraryEx.ComponentState then begin FLibShaderName[AType] := AValue; exit; end; if Assigned(FShaders[AType]) then begin FShaders[AType].UnregisterUser(Self); FShaders[AType] := nil; FLibShaderName[AType] := ''; end; LShader := GetMaterialLibraryEx.Components.GetShaderByName(AValue); if Assigned(LShader) then begin if LShader.ShaderType <> AType then begin if IsDesignTime then InformationDlg(Format('Incompatible shader type, need %s shader', [cShaderTypeName[AType]])); exit; end; LShader.RegisterUser(Self); FShaders[AType] := LShader; FLibShaderName[AType] := AValue; end; NotifyChange(Self); end; procedure TGLBaseShaderModel.UnApply(var ARci: TGLRenderContextInfo); begin if FIsValid {and not ARci.GLStates.ForwardContext} then FHandle.EndUseProgramObject; end; procedure TGLBaseShaderModel.WriteUniforms(AStream: TStream); var LWriter: TWriter; I: Integer; begin LWriter := TWriter.Create(AStream, 16384); try LWriter.WriteInteger(FUniforms.Count); for I := 0 to FUniforms.Count - 1 do begin LWriter.WriteString(FUniforms[I].ClassName); TGLAbstractShaderUniform(FUniforms[I]).WriteToFiler(LWriter); end; finally LWriter.Free; end; end; class function TGLShaderModel3.IsSupported: Boolean; begin Result := gl.ARB_shader_objects; end; class function TGLShaderModel4.IsSupported: Boolean; begin Result := gl.EXT_gpu_shader4; end; class function TGLShaderModel5.IsSupported: Boolean; begin Result := gl.ARB_gpu_shader5; end; procedure BeginPatch(mode: Cardinal);{$IFDEF MSWINDOWS} stdcall{$ELSE}cdecl{$ENDIF}; begin if mode = GL_PATCHES then vStoreBegin(GL_PATCHES) else if (mode = GL_TRIANGLES) or (mode = GL_TRIANGLE_STRIP) or (mode = GL_TRIANGLE_FAN) or (mode = GL_QUADS) then begin if mode = GL_QUADS then gl.PatchParameteri(GL_PATCH_VERTICES, 4) else gl.PatchParameteri(GL_PATCH_VERTICES, 3); vStoreBegin(GL_PATCHES); end else begin gl.Begin_ := vStoreBegin; GLSLogger.LogError('glBegin called with unsupported primitive for tessellation'); Abort; end; end; procedure TGLShaderModel5.Apply(var ARci: TGLRenderContextInfo); begin if Assigned(FShaders[shtControl]) or Assigned(FShaders[shtEvaluation]) then begin vStoreBegin := gl.Begin_; gl.Begin_ := BeginPatch; ARci.amalgamating := True; end; inherited; end; procedure TGLShaderModel5.UnApply(var ARci: TGLRenderContextInfo); begin inherited; if Assigned(FShaders[shtControl]) or Assigned(FShaders[shtEvaluation]) then gl.Begin_ := vStoreBegin; ARci.amalgamating := False; end; { TVXMatLibComponents } function TGLMatLibComponents.GetAttachmentByName( const AName: TGLMaterialComponentName): TGLFrameBufferAttachment; var N, I: Integer; begin N := ComputeNameHashKey(AName); for I := 0 to Count - 1 do begin if (Items[I] is TGLFrameBufferAttachment) and (Items[I].FNameHashKey = N) then begin if Items[I].Name = AName then begin Result := TGLFrameBufferAttachment(Items[I]); exit; end; end; end; Result := nil; end; function TGLMatLibComponents.GetCombinerByName( const AName: TGLMaterialComponentName): TGLTextureCombiner; var N, I: Integer; begin N := ComputeNameHashKey(AName); for I := 0 to Count - 1 do begin if (Items[I] is TGLTextureCombiner) and (Items[I].FNameHashKey = N) then begin if Items[I].Name = AName then begin Result := TGLTextureCombiner(Items[I]); exit; end; end; end; Result := nil; end; function TGLMatLibComponents.GetItemByName( const AName: TGLMaterialComponentName): TGLBaseMaterialCollectionItem; var N, I: Integer; begin N := ComputeNameHashKey(AName); for I := 0 to Count - 1 do begin if (Items[I].FNameHashKey = N) and (Items[I].Name = AName) then begin Result := Items[I]; exit; end; end; Result := nil; end; function TGLMatLibComponents.GetItems( index: Integer): TGLBaseMaterialCollectionItem; begin Result := TGLBaseMaterialCollectionItem(inherited GetItems(index)); end; function TGLMatLibComponents.GetNamePath: string; var s: string; begin Result := ClassName; if GetOwner = nil then Exit; s := GetOwner.GetNamePath; if s = '' then Exit; Result := s + '.Components'; end; function TGLMatLibComponents.GetSamplerByName( const AName: TGLMaterialComponentName): TGLTextureSampler; var N, I: Integer; begin N := ComputeNameHashKey(AName); for I := 0 to Count - 1 do begin if (Items[I] is TGLTextureSampler) and (Items[I].FNameHashKey = N) then begin if Items[I].Name = AName then begin Result := TGLTextureSampler(Items[I]); exit; end; end; end; Result := nil; end; function TGLMatLibComponents.GetShaderByName( const AName: TGLMaterialComponentName): TGLShaderEx; var N, I: Integer; begin N := ComputeNameHashKey(AName); for I := 0 to Count - 1 do begin if (Items[I] is TGLShaderEx) and (Items[I].FNameHashKey = N) then begin if Items[I].Name = AName then begin Result := TGLShaderEx(Items[I]); exit; end; end; end; Result := nil; end; function TGLMatLibComponents.GetAsmProgByName( const AName: TGLMaterialComponentName): TGLASMVertexProgram; var N, I: Integer; begin N := ComputeNameHashKey(AName); for I := 0 to Count - 1 do begin if (Items[I] is TGLASMVertexProgram) and (Items[I].FNameHashKey = N) then begin if Items[I].Name = AName then begin Result := TGLASMVertexProgram(Items[I]); exit; end; end; end; Result := nil; end; function TGLMatLibComponents.GetTextureByName( const AName: TGLMaterialComponentName): TGLAbstractTexture; var N, I: Integer; begin N := ComputeNameHashKey(AName); for I := 0 to Count - 1 do begin if (Items[I] is TGLAbstractTexture) and (Items[I].FNameHashKey = N) then begin if Items[I].Name = AName then begin Result := TGLTextureImageEx(Items[I]); exit; end; end; end; Result := nil; end; class function TGLMatLibComponents.ItemsClass: TXCollectionItemClass; begin Result := TGLBaseMaterialCollectionItem; end; function TGLMatLibComponents.MakeUniqueName(const AName: TGLMaterialComponentName): TGLMaterialComponentName; var I: Integer; begin Result := AName; I := 1; while GetItemByName(Result) <> nil do begin Result := AName + IntToStr(i); Inc(i); end; end; { TVXMaterialLibraryEx } function TGLMaterialLibraryEx.AddAttachment( const AName: TGLMaterialComponentName): TGLFrameBufferAttachment; begin Result := TGLFrameBufferAttachment.Create(Components); Result.Name := AName; Components.Add(Result); end; function TGLMaterialLibraryEx.AddCombiner( const AName: TGLMaterialComponentName): TGLTextureCombiner; begin Result := TGLTextureCombiner.Create(Components); Result.Name := AName; Components.Add(Result); end; function TGLMaterialLibraryEx.AddSampler( const AName: TGLMaterialComponentName): TGLTextureSampler; begin Result := TGLTextureSampler.Create(Components); Result.Name := AName; Components.Add(Result); end; function TGLMaterialLibraryEx.AddShader( const AName: TGLMaterialComponentName): TGLShaderEx; begin Result := TGLShaderEx.Create(Components); Result.Name := AName; Components.Add(Result); end; function TGLMaterialLibraryEx.AddAsmProg( const AName: TGLMaterialComponentName): TGLASMVertexProgram; begin Result := TGLASMVertexProgram.Create(Components); Result.Name := AName; Components.Add(Result); end; function TGLMaterialLibraryEx.AddTexture( const AName: TGLMaterialComponentName): TGLTextureImageEx; begin Result := TGLTextureImageEx.Create(Components); Result.Name := AName; Components.Add(Result); end; constructor TGLMaterialLibraryEx.Create(AOwner: TComponent); begin inherited; FMaterials := TGLLibMaterialsEx.Create(Self); FComponents := TGLMatLibComponents.Create(Self); end; procedure TGLMaterialLibraryEx.DefineProperties(Filer: TFiler); begin Filer.DefineBinaryProperty( 'ComponentsData', ReadComponents, WriteComponents, Components.Count > 0); inherited; end; destructor TGLMaterialLibraryEx.Destroy; begin FMaterials.Destroy; FComponents.Destroy; inherited; end; function TGLMaterialLibraryEx.GetMaterials: TGLLibMaterialsEx; begin Result := TGLLibMaterialsEx(FMaterials); end; procedure TGLMaterialLibraryEx.GetNames(Proc: TGetStrProc; AClass: CGLBaseMaterialCollectionItem); var I: Integer; begin for I := 0 to Components.Count - 1 do if Components[I].ClassType = AClass then Proc(Components[I].Name) end; procedure TGLMaterialLibraryEx.Loaded; begin inherited; end; procedure TGLMaterialLibraryEx.ReadComponents(AStream: TStream); var LReader: TReader; begin LReader := TReader.Create(AStream, 16384); try Components.ReadFromFiler(LReader); finally LReader.Free; end; end; procedure TGLMaterialLibraryEx.SetComponents(AValue: TGLMatLibComponents); begin FComponents.Assign(AValue); end; procedure TGLMaterialLibraryEx.SetLevelForAll(const ALevel: TGLMaterialLevel); var I: Integer; begin for I := Materials.Count - 1 downto 0 do Materials[I].ApplicableLevel := ALevel; end; procedure TGLMaterialLibraryEx.SetMaterials(AValue: TGLLibMaterialsEx); begin FMaterials.Assign(AValue); end; function TGLMaterialLibraryEx.StoreMaterials: Boolean; begin Result := (FMaterials.Count > 0); end; procedure TGLMaterialLibraryEx.WriteComponents(AStream: TStream); var LWriter: TWriter; begin LWriter := TWriter.Create(AStream, 16384); try Components.WriteToFiler(LWriter); finally LWriter.Free; end; end; { TVXShaderUniformTexture } procedure TGLShaderUniformTexture.Apply(var ARci: TGLRenderContextInfo); function FindHotActiveUnit: Boolean; var ID: Cardinal; I, J: Integer; bindTime, minTime: Double; LTex: TGLTextureImageEx; begin with ARci.GLStates do begin if Assigned(FLibTexture) and FLibTexture.IsValid then begin ID := FLibTexture.FHandle.Handle; // Yar: may be need exract this to new method of TGLTextureImageEx ??? if FLibTexture is TGLTextureImageEx then begin LTex := TGLTextureImageEx(FLibTexture); Inc(LTex.FApplyCounter); if LTex.FApplyCounter > 16 then FreeAndNil(LTex.FImage); end; end else ID := 0; // Find alredy binded texture unit for I := 0 to MaxTextureImageUnits - 1 do begin if TextureBinding[I, FTarget] = ID then begin gl.Uniform1i(FLocation, I); ActiveTexture := I; Result := True; exit; end; end; // Find unused texture unit for I := 0 to MaxTextureImageUnits - 1 do begin if TextureBinding[I, FTarget] = 0 then begin TextureBinding[I, FTarget] := ID; gl.Uniform1i(FLocation, I); ActiveTexture := I; Result := True; exit; end; end; // Find most useless texture unit minTime := AppTime; J := 0; for I := 0 to MaxTextureImageUnits - 1 do begin bindTime := TextureBindingTime[I, FTarget]; if bindTime < minTime then begin minTime := bindTime; J := I; end; end; TextureBinding[J, FTarget] := ID; ActiveTexture := J; gl.Uniform1i(FLocation, J); Result := True; exit; end; Result := False; end; var glTarget: Cardinal; begin if FLocation > -1 then begin if FindHotActiveUnit and Assigned(FLibTexture) and Assigned(FLibSampler) then begin // Apply swizzling if possible glTarget := DecodeTextureTarget(FLibTexture.Shape); if GL.ARB_texture_swizzle or GL.EXT_texture_swizzle then begin if FSwizzling[0] <> FLibTexture.FSwizzles[0] then begin FLibTexture.FSwizzles[0] := FSwizzling[0]; gl.TexParameteri(glTarget, GL_TEXTURE_SWIZZLE_R, cTextureSwizzle[FSwizzling[0]]); end; if FSwizzling[1] <> FLibTexture.FSwizzles[1] then begin FLibTexture.FSwizzles[1] := FSwizzling[1]; gl.TexParameteri(glTarget, GL_TEXTURE_SWIZZLE_G, cTextureSwizzle[FSwizzling[1]]); end; if FSwizzling[2] <> FLibTexture.FSwizzles[2] then begin FLibTexture.FSwizzles[2] := FSwizzling[2]; gl.TexParameteri(glTarget, GL_TEXTURE_SWIZZLE_B, cTextureSwizzle[FSwizzling[2]]); end; if FSwizzling[3] <> FLibTexture.FSwizzles[3] then begin FLibTexture.FSwizzles[3] := FSwizzling[3]; gl.TexParameteri(glTarget, GL_TEXTURE_SWIZZLE_A, cTextureSwizzle[FSwizzling[3]]); end; end; if FLibSampler.IsValid then FLibSampler.Apply(ARci) else if FLibTexture.FLastSampler <> FLibSampler then begin // Sampler object not supported, lets use texture states gl.TexParameterfv(glTarget, GL_TEXTURE_BORDER_COLOR, FLibSampler.BorderColor.AsAddress); gl.TexParameteri(glTarget, GL_TEXTURE_WRAP_S, cTextureWrapMode[FLibSampler.WrapX]); gl.TexParameteri(glTarget, GL_TEXTURE_WRAP_T, cTextureWrapMode[FLibSampler.WrapY]); gl.TexParameteri(glTarget, GL_TEXTURE_WRAP_R, cTextureWrapMode[FLibSampler.WrapZ]); gl.TexParameterf(glTarget, GL_TEXTURE_LOD_BIAS, FLibSampler.LODBias + FLibSampler.FLODBiasFract); gl.TexParameteri(glTarget, GL_TEXTURE_MIN_FILTER, cTextureMinFilter[FLibSampler.MinFilter]); gl.TexParameteri(glTarget, GL_TEXTURE_MAG_FILTER, cTextureMagFilter[FLibSampler.MagFilter]); if GL.EXT_texture_filter_anisotropic then begin if FLibSampler.FilteringQuality = tfAnisotropic then gl.TexParameteri(glTarget, GL_TEXTURE_MAX_ANISOTROPY_EXT, CurrentGLContext.GLStates.MaxTextureAnisotropy) else gl.TexParameteri(glTarget, GL_TEXTURE_MAX_ANISOTROPY_EXT, 1); end; gl.TexParameteri(glTarget, GL_TEXTURE_COMPARE_MODE, cTextureCompareMode[FLibSampler.CompareMode]); gl.TexParameteri(glTarget, GL_TEXTURE_COMPARE_FUNC, cGLComparisonFunctionToGLEnum[FLibSampler.CompareFunc]); if GL.EXT_texture_sRGB_decode then begin if FLibSampler.sRGB_Encode then gl.TexParameteri(glTarget, GL_TEXTURE_SRGB_DECODE_EXT, GL_DECODE_EXT) else gl.TexParameteri(glTarget, GL_TEXTURE_SRGB_DECODE_EXT, GL_SKIP_DECODE_EXT); end; FLibTexture.FLastSampler := FLibSampler; end; end; end; end; procedure TGLShaderUniformTexture.Assign(Source: TPersistent); var LUniform: TGLShaderUniformTexture; begin if Source is TGLShaderUniformTexture then begin LUniform := TGLShaderUniformTexture(Source); LibTextureName := LUniform.LibTextureName; LibSamplerName := LUniform.LibSamplerName; end; inherited; end; constructor TGLShaderUniformTexture.Create(AOwner: TPersistent); begin inherited; FSwizzling := cDefaultSwizzleVector; end; destructor TGLShaderUniformTexture.Destroy; begin LibTextureName := ''; LibSamplerName := ''; inherited; end; function TGLShaderUniformTexture.GetSamplerName: string; begin if Assigned(FLibSampler) then Result := FLibSampler.Name else Result := strNothing; end; function TGLShaderUniformTexture.GetTextureName: string; begin if Assigned(FLibTexture) then Result := FLibTexture.Name else Result := strNothing; end; function TGLShaderUniformTexture.GetTextureSwizzle: TSwizzleVector; begin Result := FSwizzling; end; procedure TGLShaderUniformTexture.Loaded; begin SetTextureName(FLibTexureName); SetSamplerName(FLibSamplerName); end; procedure TGLShaderUniformTexture.Notification(Sender: TObject; Operation: TOperation); begin if Operation = opRemove then begin if Sender = FLibTexture then FLibTexture := nil else if Sender = FLibSampler then FLibSampler := nil; end; end; procedure TGLShaderUniformTexture.ReadFromFiler(AReader: TReader); begin with AReader do begin inherited; LibTextureName := ReadString; LibSamplerName := ReadString; FSwizzling[0] := TGLTextureSwizzle(ReadInteger); FSwizzling[1] := TGLTextureSwizzle(ReadInteger); FSwizzling[2] := TGLTextureSwizzle(ReadInteger); FSwizzling[3] := TGLTextureSwizzle(ReadInteger); end; end; procedure TGLShaderUniformTexture.SetTextureName( const AValue: string); var LTexture: TGLAbstractTexture; begin if csLoading in TGLBaseShaderModel(Owner).GetMaterialLibraryEx.ComponentState then begin FLibTexureName := AValue; exit; end; if Assigned(FLibTexture) then begin if FLibTexture.Name = AValue then exit; FLibTexture.UnregisterUser(Self); FLibTexture := nil; end; LTexture := TGLBaseShaderModel(Owner).GetMaterialLibraryEx.Components.GetTextureByName(AValue); if Assigned(LTexture) then begin if LTexture is TGLFrameBufferAttachment then begin if TGLFrameBufferAttachment(LTexture).OnlyWrite then begin if IsDesignTime then InformationDlg('Can not use write only attachment as texture') else GLSLogger.LogErrorFmt('Attempt to write only attachment "%s" for uniform "%s"', [LTexture.Name, Name]); NotifyChange(Self); exit; end; end; LTexture.RegisterUser(Self); FLibTexture := LTexture; end; NotifyChange(Self); end; procedure TGLShaderUniformTexture.SetSamplerName(const AValue: string); var LSampler: TGLTextureSampler; begin if csLoading in TGLBaseShaderModel(Owner).GetMaterialLibraryEx.ComponentState then begin FLibSamplerName := AValue; exit; end; if Assigned(FLibSampler) then begin if FLibSampler.Name = AValue then exit; FLibSampler.UnregisterUser(Self); FLibSampler := nil; end; LSampler := TGLBaseShaderModel(Owner).GetMaterialLibraryEx.Components.GetSamplerByName(AValue); if Assigned(LSampler) then begin LSampler.RegisterUser(Self); FLibSampler := LSampler; end; NotifyChange(Self); end; procedure TGLShaderUniformTexture.SetTextureSwizzle(const AValue: TSwizzleVector); begin FSwizzling := AValue; end; procedure TGLShaderUniformTexture.WriteToFiler(AWriter: TWriter); begin with AWriter do begin inherited; WriteString(LibTextureName); WriteString(LibSamplerName); WriteInteger(Integer(FSwizzling[0])); WriteInteger(Integer(FSwizzling[1])); WriteInteger(Integer(FSwizzling[2])); WriteInteger(Integer(FSwizzling[3])); end; end; { TVXAbstractShaderUniform } function TGLAbstractShaderUniform.GetFloat: Single; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetGLSLSamplerType: TGLSLSamplerType; begin Result := FSamplerType; end; function TGLAbstractShaderUniform.GetGLSLType: TGLSLDataType; begin Result := FType; end; function TGLAbstractShaderUniform.GetInt: TGLint; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetIVec2: TVector2i; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetIVec3: TVector3i; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetIVec4: TVector4i; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetMat2: TMatrix2f; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetMat3: TMatrix3f; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetMat4: TMatrix4f; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetName: string; begin Result := FName; end; function TGLAbstractShaderUniform.GetSamplerName: string; begin Result := strNothing; end; procedure TGLAbstractShaderUniform.Apply(var ARci: TGLRenderContextInfo); begin end; function TGLAbstractShaderUniform.GetAutoSetMethod: string; begin Result := strNothing; end; function TGLAbstractShaderUniform.GetTextureName: string; begin Result := strNothing; end; function TGLAbstractShaderUniform.GetTextureSwizzle: TSwizzleVector; begin Result := cDefaultSwizzleVector; end; function TGLAbstractShaderUniform.GetUInt: Cardinal; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetUVec2: TVector2ui; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetUVec3: TVector3ui; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetUVec4: TVector4ui; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetVec2: TVector2f; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetVec3: TVector3f; begin FillChar(Result, SizeOf(Result), $00); end; function TGLAbstractShaderUniform.GetVec4: TGLVector; begin FillChar(Result, SizeOf(Result), $00); end; procedure TGLAbstractShaderUniform.ReadFromFiler(AReader: TReader); begin end; procedure TGLAbstractShaderUniform.SetFloat(const Value: TGLFloat); begin end; procedure TGLAbstractShaderUniform.SetFloatArray(const Values: PGLFloat; Count: Integer); begin end; procedure TGLAbstractShaderUniform.SetInt(const Value: Integer); begin end; procedure TGLAbstractShaderUniform.SetIntArray(const Values: PGLInt; Count: Integer); begin end; procedure TGLAbstractShaderUniform.SetIVec2(const Value: TVector2i); begin end; procedure TGLAbstractShaderUniform.SetIVec3(const Value: TVector3i); begin end; procedure TGLAbstractShaderUniform.SetIVec4(const Value: TVector4i); begin end; procedure TGLAbstractShaderUniform.SetMat2(const Value: TMatrix2f); begin end; procedure TGLAbstractShaderUniform.SetMat3(const Value: TMatrix3f); begin end; procedure TGLAbstractShaderUniform.SetMat4(const Value: TMatrix4f); begin end; procedure TGLAbstractShaderUniform.SetSamplerName(const AValue: string); begin end; procedure TGLAbstractShaderUniform.SetAutoSetMethod(const AValue: string); begin end; procedure TGLAbstractShaderUniform.SetTextureName(const AValue: string); begin end; procedure TGLAbstractShaderUniform.SetTextureSwizzle(const AValue: TSwizzleVector); begin end; procedure TGLAbstractShaderUniform.SetUInt(const Value: Cardinal); begin end; procedure TGLAbstractShaderUniform.SetUIntArray(const Values: PGLUInt; Count: Integer); begin end; procedure TGLAbstractShaderUniform.SetUVec2(const Value: TVector2ui); begin end; procedure TGLAbstractShaderUniform.SetUVec3(const Value: TVector3ui); begin end; procedure TGLAbstractShaderUniform.SetUVec4(const Value: TVector4ui); begin end; procedure TGLAbstractShaderUniform.SetVec2(const Value: TVector2f); begin end; procedure TGLAbstractShaderUniform.SetVec3(const Value: TVector3f); begin end; procedure TGLAbstractShaderUniform.SetVec4(const Value: TVector4f); begin end; procedure TGLAbstractShaderUniform.WriteToFiler(AWriter: TWriter); begin end; { TVXShaderUniform } function TGLShaderUniform.GetFloat: Single; begin // TODO: Type checking gl.GetUniformfv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetInt: TGLint; begin gl.GetUniformiv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetIVec2: TVector2i; begin gl.GetUniformiv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetIVec3: TVector3i; begin gl.GetUniformiv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetIVec4: TVector4i; begin gl.GetUniformiv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetMat2: TMatrix2f; begin gl.GetUniformfv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetMat3: TMatrix3f; begin gl.GetUniformfv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetMat4: TMatrix4f; begin gl.GetUniformfv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetProgram: Cardinal; begin Result := TGLBaseShaderModel(Owner).FHandle.Handle; end; procedure TGLShaderUniform.Apply(var ARci: TGLRenderContextInfo); begin if Assigned(FAutoSet) then FAutoSet(Self, ARci); end; procedure TGLShaderUniform.Assign(Source: TPersistent); var LUniform: TGLShaderUniform; begin if Source is TGLShaderUniform then begin LUniform := TGLShaderUniform(Source); FName := LUniform.Name; FNameHashCode := LUniform.FNameHashCode; FType := LUniform.FType; FSamplerType := LUniform.FSamplerType; FAutoSet := LUniform.FAutoSet; end; inherited; end; function TGLShaderUniform.GetAutoSetMethod: string; begin Result := GetUniformAutoSetMethodName(FAutoSet); end; function TGLShaderUniform.GetUInt: Cardinal; begin gl.GetUniformuiv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetUVec2: TVector2ui; begin gl.GetUniformuiv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetUVec3: TVector3ui; begin gl.GetUniformuiv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetUVec4: TVector4ui; begin gl.GetUniformuiv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetVec2: TVector2f; begin gl.GetUniformfv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetVec3: TVector3f; begin gl.GetUniformfv(GetProgram, FLocation, @Result); end; function TGLShaderUniform.GetVec4: TGLVector; begin gl.GetUniformfv(GetProgram, FLocation, @Result); end; procedure TGLShaderUniform.PopProgram; begin CurrentGLContext.GLStates.CurrentProgram := FStoreProgram; end; procedure TGLShaderUniform.PushProgram; begin with CurrentGLContext.GLStates do begin FStoreProgram := CurrentProgram; CurrentProgram := GetProgram; end; end; procedure TGLShaderUniform.ReadFromFiler(AReader: TReader); begin with AReader do begin FName := ReadString; FNameHashCode := ComputeNameHashKey(FName); FType := TGLSLDataType(ReadInteger); FSamplerType := TGLSLSamplerType(ReadInteger); SetAutoSetMethod(ReadString); end; end; procedure TGLShaderUniform.SetFloat(const Value: TGLFloat); begin PushProgram; gl.Uniform1f(FLocation, Value); PopProgram; end; procedure TGLShaderUniform.SetFloatArray(const Values: PGLFloat; Count: Integer); begin PushProgram; gl.Uniform1fv(FLocation, Count, Values); PopProgram; end; procedure TGLShaderUniform.SetInt(const Value: Integer); begin PushProgram; gl.Uniform1i(FLocation, Value); PopProgram; end; procedure TGLShaderUniform.SetIntArray(const Values: PGLInt; Count: Integer); begin PushProgram; gl.Uniform1iv(FLocation, Count, Values); PopProgram; end; procedure TGLShaderUniform.SetIVec2(const Value: TVector2i); begin PushProgram; gl.Uniform2i(FLocation, Value.X, Value.Y); PopProgram; end; procedure TGLShaderUniform.SetIVec3(const Value: TVector3i); begin PushProgram; gl.Uniform3i(FLocation, Value.X, Value.Y, Value.Z); PopProgram; end; procedure TGLShaderUniform.SetIVec4(const Value: TVector4i); begin PushProgram; gl.Uniform4i(FLocation, Value.X, Value.Y, Value.Z, Value.W); PopProgram; end; procedure TGLShaderUniform.SetMat2(const Value: TMatrix2f); begin PushProgram; gl.UniformMatrix2fv(FLocation, 1, False, @Value); PopProgram; end; procedure TGLShaderUniform.SetMat3(const Value: TMatrix3f); begin PushProgram; gl.UniformMatrix2fv(FLocation, 1, False, @Value); PopProgram; end; procedure TGLShaderUniform.SetMat4(const Value: TMatrix4f); begin PushProgram; gl.UniformMatrix4fv(FLocation, 1, False, @Value); PopProgram; end; procedure TGLShaderUniform.SetAutoSetMethod(const AValue: string); begin FAutoSet := GetUniformAutoSetMethod(AValue); end; procedure TGLShaderUniform.SetUInt(const Value: Cardinal); begin PushProgram; gl.Uniform1ui(FLocation, Value); PopProgram; end; procedure TGLShaderUniform.SetUIntArray(const Values: PGLUInt; Count: Integer); begin PushProgram; gl.Uniform1uiv(FLocation, Count, Values); PopProgram; end; procedure TGLShaderUniform.SetUVec2(const Value: TVector2ui); begin PushProgram; gl.Uniform2ui(FLocation, Value.X, Value.Y); PopProgram; end; procedure TGLShaderUniform.SetUVec3(const Value: TVector3ui); begin PushProgram; gl.Uniform3ui(FLocation, Value.X, Value.Y, Value.Z); PopProgram; end; procedure TGLShaderUniform.SetUVec4(const Value: TVector4ui); begin PushProgram; gl.Uniform4ui(FLocation, Value.X, Value.Y, Value.Z, Value.W); PopProgram; end; procedure TGLShaderUniform.SetVec2(const Value: TVector2f); begin PushProgram; gl.Uniform2f(FLocation, Value.X, Value.Y); PopProgram; end; procedure TGLShaderUniform.SetVec3(const Value: TVector3f); begin PushProgram; gl.Uniform3f(FLocation, Value.X, Value.Y, Value.Z); PopProgram; end; procedure TGLShaderUniform.SetVec4(const Value: TVector4f); begin PushProgram; gl.Uniform4f(FLocation, Value.X, Value.Y, Value.Z, Value.W); PopProgram; end; procedure TGLShaderUniform.WriteToFiler(AWriter: TWriter); begin with AWriter do begin WriteString(FName); WriteInteger(Integer(FType)); WriteInteger(Integer(FSamplerType)); WriteString(GetAutoSetMethod); end; end; { TVXShaderUniformDSA } procedure TGLShaderUniformDSA.SetFloat(const Value: TGLFloat); begin gl.ProgramUniform1f(GetProgram, FLocation, Value); end; procedure TGLShaderUniformDSA.SetFloatArray(const Values: PGLFloat; Count: Integer); begin gl.ProgramUniform1fv(GetProgram, FLocation, Count, Values); end; procedure TGLShaderUniformDSA.SetInt(const Value: Integer); begin gl.ProgramUniform1i(GetProgram, FLocation, Value); end; procedure TGLShaderUniformDSA.SetIntArray(const Values: PGLInt; Count: Integer); begin gl.ProgramUniform1iv(GetProgram, FLocation, Count, Values); end; procedure TGLShaderUniformDSA.SetIVec2(const Value: TVector2i); begin gl.ProgramUniform2i(GetProgram, FLocation, Value.X, Value.Y); end; procedure TGLShaderUniformDSA.SetIVec3(const Value: TVector3i); begin gl.ProgramUniform3i(GetProgram, FLocation, Value.X, Value.Y, Value.Z); end; procedure TGLShaderUniformDSA.SetIVec4(const Value: TVector4i); begin gl.ProgramUniform4i(GetProgram, FLocation, Value.X, Value.Y, Value.Z, Value.W); end; procedure TGLShaderUniformDSA.SetMat2(const Value: TMatrix2f); begin gl.ProgramUniformMatrix2fv(GetProgram, FLocation, 1, False, @Value); end; procedure TGLShaderUniformDSA.SetMat3(const Value: TMatrix3f); begin gl.ProgramUniformMatrix3fv(GetProgram, FLocation, 1, False, @Value); end; procedure TGLShaderUniformDSA.SetMat4(const Value: TMatrix4f); begin gl.ProgramUniformMatrix4fv(GetProgram, FLocation, 1, False, @Value); end; procedure TGLShaderUniformDSA.SetUInt(const Value: Cardinal); begin gl.ProgramUniform1ui(GetProgram, FLocation, Value); end; procedure TGLShaderUniformDSA.SetUIntArray(const Values: PGLUInt; Count: Integer); begin gl.ProgramUniform1uiv(GetProgram, FLocation, Count, Values); end; procedure TGLShaderUniformDSA.SetUVec2(const Value: TVector2ui); begin gl.ProgramUniform2ui(GetProgram, FLocation, Value.X, Value.Y); end; procedure TGLShaderUniformDSA.SetUVec3(const Value: TVector3ui); begin gl.ProgramUniform3ui(GetProgram, FLocation, Value.X, Value.Y, Value.Z); end; procedure TGLShaderUniformDSA.SetUVec4(const Value: TVector4ui); begin gl.ProgramUniform4ui(GetProgram, FLocation, Value.X, Value.Y, Value.Z, Value.W); end; procedure TGLShaderUniformDSA.SetVec2(const Value: TVector2f); begin gl.ProgramUniform2f(GetProgram, FLocation, Value.X, Value.Y); end; procedure TGLShaderUniformDSA.SetVec3(const Value: TVector3f); begin gl.ProgramUniform3f(GetProgram, FLocation, Value.X, Value.Y, Value.Z); end; procedure TGLShaderUniformDSA.SetVec4(const Value: TVector4f); begin gl.ProgramUniform4f(GetProgram, FLocation, Value.X, Value.Y, Value.Z, Value.W); end; { TVXTextureSwizzling } procedure TGLTextureSwizzling.Assign(Source: TPersistent); var LSwizzling: TGLTextureSwizzling; begin if Source is TGLTextureSwizzling then begin LSwizzling := TGLTextureSwizzling(Source); FSwizzles[0] := LSwizzling.FSwizzles[0]; FSwizzles[1] := LSwizzling.FSwizzles[1]; FSwizzles[2] := LSwizzling.FSwizzles[2]; FSwizzles[3] := LSwizzling.FSwizzles[3]; end; inherited; end; constructor TGLTextureSwizzling.Create(AOwner: TPersistent); begin inherited; FSwizzles := cDefaultSwizzleVector; end; function TGLTextureSwizzling.GetSwizzle(AIndex: Integer): TGLTextureSwizzle; begin Result := FSwizzles[AIndex]; end; procedure TGLTextureSwizzling.ReadFromFiler(AReader: TReader); begin with AReader do begin ReadInteger; FSwizzles[0] := TGLTextureSwizzle(ReadInteger); FSwizzles[1] := TGLTextureSwizzle(ReadInteger); FSwizzles[2] := TGLTextureSwizzle(ReadInteger); FSwizzles[3] := TGLTextureSwizzle(ReadInteger); end; end; procedure TGLTextureSwizzling.SetSwizzle(AIndex: Integer; AValue: TGLTextureSwizzle); begin if AValue <> FSwizzles[AIndex] then begin FSwizzles[AIndex] := AValue; NotifyChange(Self); end; end; function TGLTextureSwizzling.StoreSwizzle(AIndex: Integer): Boolean; begin Result := (FSwizzles[AIndex] <> cDefaultSwizzleVector[AIndex]); end; procedure TGLTextureSwizzling.WriteToFiler(AWriter: TWriter); begin with AWriter do begin WriteInteger(0); WriteInteger(Integer(FSwizzles[0])); WriteInteger(Integer(FSwizzles[1])); WriteInteger(Integer(FSwizzles[2])); WriteInteger(Integer(FSwizzles[3])); end; end; { TVXFrameBufferAttachment } procedure TGLFrameBufferAttachment.Apply(var ARci: TGLRenderContextInfo); begin if FIsValid and not FOnlyWrite then begin // Just bind with ARci.GLStates do begin ActiveTextureEnabled[FHandle.Target] := True; TextureBinding[ActiveTexture, FHandle.Target] := FHandle.Handle; end; end else ARci.GLStates.TextureBinding[ARci.GLStates.ActiveTexture, FHandle.Target] := 0; end; procedure TGLFrameBufferAttachment.Assign(Source: TPersistent); var LAttachment: TGLFrameBufferAttachment; begin if Source is TGLFrameBufferAttachment then begin LAttachment := TGLFrameBufferAttachment(Source); FLayered := LAttachment.Layered; FCubeMap := LAttachment.CubeMap; FSamples := LAttachment.Samples; FOnlyWrite := LAttachment.OnlyWrite; FFixedSamplesLocation := LAttachment.FixedSamplesLocation; FWidth := LAttachment.InternalWidth; FHeight := LAttachment.InternalHeight; FDepth := LAttachment.InternalDepth; FInternalFormat := LAttachment.InternalFormat; NotifyChange(Self); end; inherited; end; constructor TGLFrameBufferAttachment.Create(AOwner: TXCollection); begin inherited; FDefferedInit := False; FHandle := TGLTextureHandle.Create; FHandle.OnPrapare := DoOnPrepare; FRenderBufferHandle := TGLRenderbufferHandle.Create; FRenderBufferHandle.OnPrapare := DoOnPrepare; FInternalFormat := tfRGBA8; FWidth := 256; FHeight := 256; FDepth := 0; FSamples := -1; FLayered := False; FCubeMap := False; FOnlyWrite := False; FFixedSamplesLocation := False; Name := TGLMatLibComponents(AOwner).MakeUniqueName('Attachment'); end; destructor TGLFrameBufferAttachment.Destroy; begin FHandle.Destroy; FRenderBufferHandle.Destroy; inherited; end; procedure TGLFrameBufferAttachment.DoOnPrepare(Sender: TGLContext); var LTarget: TGLTextureTarget; w, h, d, s, Level, MaxLevel: Integer; glTarget, glFormat, glFace: Cardinal; begin if IsDesignTime and FDefferedInit then exit; FHandle.AllocateHandle; FRenderBufferHandle.AllocateHandle; if not (FHandle.IsDataNeedUpdate or FRenderBufferHandle.IsDataNeedUpdate) then exit; // Target if FSamples < 0 then begin LTarget := ttTexture2D; if FHeight = 1 then LTarget := ttTexture1D; if FCubeMap then LTarget := ttTextureCube; if FDepth > 0 then LTarget := ttTexture3D; if FLayered then begin if FDepth < 2 then LTarget := ttTexture1DArray else LTarget := ttTexture2DArray; if FCubeMap then LTarget := ttTextureCubeArray; end; end else begin if FDepth > 0 then LTarget := ttTexture2DMultisampleArray else LTarget := ttTexture2DMultisample; end; // Check target support if FOnlyWrite and (LTarget = ttTexture2DMultisample) and not Sender.gl.EXT_framebuffer_multisample then begin FIsValid := False; exit; end; if not IsTargetSupported(LTarget) then begin FIsValid := False; exit; end; // Adjust dimension w := FWidth; h := FHeight; d := FDepth; s := FSamples; if FCubeMap then begin if w > Integer(Sender.GLStates.MaxCubeTextureSize) then w := Sender.GLStates.MaxCubeTextureSize; h := w; if FLayered then begin if d < 6 then d := 6 else if (d mod 6) > 0 then d := 6 * (d div 6 + 1); end; end else if w > Integer(Sender.GLStates.MaxTextureSize) then w := Sender.GLStates.MaxTextureSize; if h > Integer(Sender.GLStates.MaxTextureSize) then h := Sender.GLStates.MaxTextureSize; if FLayered then begin if d > Integer(Sender.GLStates.MaxArrayTextureSize) then d := Sender.GLStates.MaxArrayTextureSize; end else if d > Integer(Sender.GLStates.Max3DTextureSize) then d := Sender.GLStates.Max3DTextureSize; if (s > -1) and (s > Integer(Sender.GLStates.MaxSamples)) then s := Sender.GLStates.MaxSamples; glTarget := DecodeTextureTarget(LTarget); if (FHandle.Target <> LTarget) and (FHandle.Target <> ttNoShape) then begin FHandle.DestroyHandle; FHandle.AllocateHandle; end; FHandle.Target := LTarget; glFormat := InternalFormatToOpenGLFormat(FInternalFormat); if FOnlyWrite and ((LTarget = ttTexture2D) or (LTarget = ttTexture2DMultisample)) and FRenderBufferHandle.IsSupported then begin if LTarget = ttTexture2D then FRenderBufferHandle.SetStorage(glFormat, w, h) else FRenderBufferHandle.SetStorageMultisample(glFormat, s, w, h); end else with Sender do begin GLStates.ActiveTextureEnabled[FHandle.Target] := True; GLStates.TextureBinding[GLStates.ActiveTexture, FHandle.Target] := FHandle.Handle; MaxLevel := CalcTextureLevelNumber(LTarget, w, h, d); case glTarget of GL_TEXTURE_1D: for Level := 0 to MaxLevel - 1 do begin gl.TexImage1D(glTarget, Level, glFormat, w, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); Div2(w); end; GL_TEXTURE_2D: for Level := 0 to MaxLevel - 1 do begin gl.TexImage2D(glTarget, Level, glFormat, w, h, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); Div2(w); Div2(h); end; GL_TEXTURE_RECTANGLE: begin gl.TexImage2D(glTarget, 0, glFormat, w, h, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); end; GL_TEXTURE_3D: for Level := 0 to MaxLevel - 1 do begin gl.TexImage3D(glTarget, Level, glFormat, w, h, d, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); Div2(w); Div2(h); Div2(d); end; GL_TEXTURE_CUBE_MAP: for Level := 0 to MaxLevel - 1 do begin for glFace := GL_TEXTURE_CUBE_MAP_POSITIVE_X to GL_TEXTURE_CUBE_MAP_NEGATIVE_Z do gl.TexImage2D(glFace, Level, glFormat, w, w, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); Div2(w); end; GL_TEXTURE_1D_ARRAY: for Level := 0 to MaxLevel - 1 do begin gl.TexImage2D(glTarget, Level, glFormat, w, h, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); Div2(w); end; GL_TEXTURE_2D_ARRAY: for Level := 0 to MaxLevel - 1 do begin gl.TexImage3D(glTarget, Level, glFormat, w, h, d, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); Div2(w); Div2(h); end; GL_TEXTURE_CUBE_MAP_ARRAY: for Level := 0 to MaxLevel - 1 do begin gl.TexImage3D(glTarget, Level, glFormat, w, w, d, 0, GL_RGBA, GL_UNSIGNED_BYTE, nil); Div2(w); end; end; // of case GLStates.ActiveTextureEnabled[FHandle.Target] := False; FOnlyWrite := False; end; // of texture if gl.GetError <> GL_NO_ERROR then begin gl.ClearError; GLSLogger.LogErrorFmt('Unable to create attachment "%s"', [Self.Name]); exit; end else FIsValid := True; FHandle.NotifyDataUpdated; FRenderBufferHandle.NotifyDataUpdated; end; class function TGLFrameBufferAttachment.FriendlyName: string; begin Result := 'Framebuffer Attachment'; end; procedure TGLFrameBufferAttachment.NotifyChange(Sender: TObject); begin FHandle.NotifyChangesOfData; FRenderBufferHandle.NotifyChangesOfData; inherited; end; procedure TGLFrameBufferAttachment.ReadFromFiler(AReader: TReader); var archiveVersion: Integer; begin with AReader do begin archiveVersion := ReadInteger; if archiveVersion = 0 then begin Name := ReadString; FDefferedInit := ReadBoolean; FLayered := ReadBoolean; FCubeMap := ReadBoolean; FSamples := ReadInteger; FOnlyWrite := ReadBoolean; FFixedSamplesLocation := ReadBoolean; FWidth := ReadInteger; FHeight := ReadInteger; FDepth := ReadInteger; FInternalFormat := TGLInternalFormat(ReadInteger); end else RaiseFilerException(archiveVersion); end; end; procedure TGLFrameBufferAttachment.SetCubeMap(AValue: Boolean); begin if FCubeMap <> AValue then begin FCubeMap := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.SetDepth(AValue: Integer); begin if FDepth < 0 then FDepth := 0 else if FDepth > 256 then FDepth := 256; if FDepth <> AValue then begin FDepth := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.SetFixedSamplesLocation(AValue: Boolean); begin if FFixedSamplesLocation <> AValue then begin FFixedSamplesLocation := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.SetHeight(AValue: Integer); begin if FHeight < 1 then FHeight := 1 else if FHeight > 8192 then FHeight := 8192; if FHeight <> AValue then begin FHeight := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.SetInternalFormat( const AValue: TGLInternalFormat); begin if FInternalFormat <> AValue then begin FInternalFormat := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.SetLayered(AValue: Boolean); begin if FLayered <> AValue then begin FLayered := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.SetOnlyWrite(AValue: Boolean); begin if FOnlyWrite <> AValue then begin if AValue and ((FDepth > 0) or FLayered or FFixedSamplesLocation or FCubeMap) then exit; FOnlyWrite := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.SetSamples(AValue: Integer); begin if AValue < -1 then AValue := -1; if FSamples <> AValue then begin FSamples := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.SetWidth(AValue: Integer); begin if FWidth < 1 then FWidth := 1 else if FWidth > 8192 then FWidth := 8192; if FWidth <> AValue then begin FWidth := AValue; NotifyChange(Self); end; end; procedure TGLFrameBufferAttachment.UnApply(var ARci: TGLRenderContextInfo); begin ARci.GLStates.ActiveTextureEnabled[FHandle.Target] := False; end; procedure TGLFrameBufferAttachment.WriteToFiler(AWriter: TWriter); begin with AWriter do begin WriteInteger(0); // archive version WriteString(Name); WriteBoolean(FDefferedInit); WriteBoolean(FLayered); WriteBoolean(FCubeMap); WriteInteger(FSamples); WriteBoolean(FOnlyWrite); WriteBoolean(FFixedSamplesLocation); WriteInteger(FWidth); WriteInteger(FHeight); WriteInteger(FDepth); WriteInteger(Integer(FInternalFormat)); end; end; constructor TStandartUniformAutoSetExecutor.Create; begin RegisterUniformAutoSetMethod('Camera world position', GLSLType4F, SetCameraPosition); RegisterUniformAutoSetMethod('LightSource[0] world position', GLSLType4F, SetLightSource0Position); RegisterUniformAutoSetMethod('World (model) matrix', GLSLTypeMat4F, SetModelMatrix); RegisterUniformAutoSetMethod('WorldView matrix', GLSLTypeMat4F, SetModelViewMatrix); RegisterUniformAutoSetMethod('WorldNormal matrix', GLSLTypeMat3F, SetNormalModelMatrix); RegisterUniformAutoSetMethod('Inverse World matrix', GLSLTypeMat4F, SetInvModelMatrix); RegisterUniformAutoSetMethod('View matrix', GLSLTypeMat4F, SetViewMatrix); RegisterUniformAutoSetMethod('Inverse WorldView matrix', GLSLTypeMat4F, SetInvModelViewMatrix); RegisterUniformAutoSetMethod('Projection matrix', GLSLTypeMat4F, SetProjectionMatrix); RegisterUniformAutoSetMethod('ViewProjection matrix', GLSLTypeMat4F, SetViewProjectionMatrix); RegisterUniformAutoSetMethod('WorldViewProjection matrix', GLSLTypeMat4F, SetWorldViewProjectionMatrix); RegisterUniformAutoSetMethod('Material front face emission', GLSLType4F, SetMaterialFrontEmission); RegisterUniformAutoSetMethod('Material front face ambient', GLSLType4F, SetMaterialFrontAmbient); RegisterUniformAutoSetMethod('Material front face diffuse', GLSLType4F, SetMaterialFrontDiffuse); RegisterUniformAutoSetMethod('Material front face specular', GLSLType4F, SetMaterialFrontSpecular); RegisterUniformAutoSetMethod('Material front face shininess', GLSLType1F, SetMaterialFrontShininess); RegisterUniformAutoSetMethod('Material back face emission', GLSLType4F, SetMaterialBackEmission); RegisterUniformAutoSetMethod('Material back face ambient', GLSLType4F, SetMaterialBackAmbient); RegisterUniformAutoSetMethod('Material back face diffuse', GLSLType4F, SetMaterialBackDiffuse); RegisterUniformAutoSetMethod('Material back face specular', GLSLType4F, SetMaterialBackSpecular); RegisterUniformAutoSetMethod('Material back face shininess', GLSLType1F, SetMaterialBackShininess) end; procedure TStandartUniformAutoSetExecutor.SetCameraPosition(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.cameraPosition; end; procedure TStandartUniformAutoSetExecutor.SetInvModelMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat4 := ARci.PipelineTransformation.InvModelMatrix^; end; procedure TStandartUniformAutoSetExecutor.SetInvModelViewMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat4 := ARci.PipelineTransformation.InvModelViewMatrix^; end; procedure TStandartUniformAutoSetExecutor.SetLightSource0Position(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.LightPosition[0]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialBackAmbient(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.MaterialAmbient[cmBack]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialBackDiffuse(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.MaterialDiffuse[cmBack]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialBackEmission(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.MaterialEmission[cmBack]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialBackShininess(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.float := ARci.GLStates.MaterialShininess[cmBack]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialBackSpecular(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.MaterialSpecular[cmBack]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialFrontAmbient(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.MaterialAmbient[cmFront]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialFrontDiffuse(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.MaterialDiffuse[cmFront]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialFrontEmission(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.MaterialEmission[cmFront]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialFrontShininess(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.float := ARci.GLStates.MaterialShininess[cmFront]; end; procedure TStandartUniformAutoSetExecutor.SetMaterialFrontSpecular(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.vec4 := ARci.GLStates.MaterialSpecular[cmFront]; end; procedure TStandartUniformAutoSetExecutor.SetModelMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat4 := ARci.PipelineTransformation.ModelMatrix^; end; procedure TStandartUniformAutoSetExecutor.SetModelViewMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat4 := ARci.PipelineTransformation.ModelViewMatrix^; end; procedure TStandartUniformAutoSetExecutor.SetNormalModelMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat3 := ARci.PipelineTransformation.NormalModelMatrix^; end; procedure TStandartUniformAutoSetExecutor.SetProjectionMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat4 := ARci.PipelineTransformation.ProjectionMatrix^; end; procedure TStandartUniformAutoSetExecutor.SetViewMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat4 := ARci.PipelineTransformation.ViewMatrix^; end; procedure TStandartUniformAutoSetExecutor.SetViewProjectionMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat4 := ARci.PipelineTransformation.ViewProjectionMatrix^; end; procedure TStandartUniformAutoSetExecutor.SetWorldViewProjectionMatrix(Sender: IShaderParameter; var ARci: TGLRenderContextInfo); begin Sender.mat4 := MatrixMultiply( ARci.PipelineTransformation.ModelViewMatrix^, ARci.PipelineTransformation.ProjectionMatrix^); end; { TVXASMVertexProgram } procedure TGLASMVertexProgram.Assign(Source: TPersistent); var LProg: TGLASMVertexProgram; begin if Source is TGLASMVertexProgram then begin LProg := TGLASMVertexProgram(Source); FSource.Assign(LProg.FSource); end; inherited; end; constructor TGLASMVertexProgram.Create(AOwner: TXCollection); begin inherited; FHandle := TGLARBVertexProgramHandle.Create; FHandle.OnPrapare := DoOnPrepare; FSource := TStringList.Create; FSource.OnChange := NotifyChange; Name := TGLMatLibComponents(AOwner).MakeUniqueName('VertexProg'); end; destructor TGLASMVertexProgram.Destroy; begin FHandle.Destroy; FSource.Destroy; inherited; end; procedure TGLASMVertexProgram.DoOnPrepare(Sender: TGLContext); begin if FDefferedInit and not IsDesignTime then exit; try if FHandle.IsSupported then begin FHandle.AllocateHandle; if FHandle.IsDataNeedUpdate then begin SetExeDirectory; if (Length(FSourceFile) > 0) and FileStreamExists(FSourceFile) then FSource.LoadFromFile(FSourceFile); if FSource.Count > 0 then begin FHandle.LoadARBProgram(FSource.Text); FIsValid := FHandle.Ready; if IsDesignTime then begin FInfoLog := FHandle.InfoLog; if (Length(FInfoLog) = 0) and FIsValid then FInfoLog := 'Compilation successful'; end else if FIsValid then GLSLogger.LogInfoFmt('Program "%s" compilation successful - %s', [Name, FHandle.InfoLog]) else GLSLogger.LogErrorFmt('Program "%s" compilation failed - %s', [Name, FHandle.InfoLog]); FHandle.NotifyDataUpdated; end else begin if IsDesignTime then FInfoLog := 'No source' else GLSLogger.LogInfoFmt('Program "%s" has no source code', [Name]); FIsValid := False; end; end; end else begin FIsValid := False; if IsDesignTime then FInfoLog := 'Not supported by hardware'; end; except on E: Exception do begin FIsValid := False; if IsDesignTime then InformationDlg(E.ClassName + ': ' + E.Message) else GLSLogger.LogError(E.ClassName + ': ' + E.Message); end; end; end; class function TGLASMVertexProgram.FriendlyName: string; begin Result := 'ASM Vertex Program'; end; function TGLASMVertexProgram.GetHandle: TGLARBVertexProgramHandle; begin Result := FHandle; end; procedure TGLASMVertexProgram.NotifyChange(Sender: TObject); begin FHandle.NotifyChangesOfData; inherited; end; procedure TGLASMVertexProgram.ReadFromFiler(AReader: TReader); var archiveVersion: Integer; begin with AReader do begin archiveVersion := ReadInteger; if archiveVersion = 0 then begin Name := ReadString; FDefferedInit := ReadBoolean; FSource.Text := ReadString; FSourceFile := ReadString; end else RaiseFilerException(archiveVersion); end; end; procedure TGLASMVertexProgram.SetSource(AValue: TStringList); begin FSource.Assign(AValue); end; procedure TGLASMVertexProgram.SetSourceFile(AValue: string); begin FixPathDelimiter(AValue); if FSourceFile <> AValue then begin FSourceFile := AValue; NotifyChange(Self); end; end; procedure TGLASMVertexProgram.WriteToFiler(AWriter: TWriter); begin with AWriter do begin WriteInteger(0); // archive version WriteString(Name); WriteBoolean(FDefferedInit); if Length(FSourceFile) = 0 then WriteString(FSource.Text) else WriteString(''); WriteString(FSourceFile); end; end; initialization RegisterClasses( [ TGLTextureImageEx, TGLFrameBufferAttachment, TGLTextureSampler, TGLTextureCombiner, TGLShaderEx, TGLASMVertexProgram, TGLMaterialLibraryEx, TGLShaderUniform, TGLShaderUniformDSA, TGLShaderUniformTexture ]); RegisterXCollectionItemClass(TGLTextureImageEx); RegisterXCollectionItemClass(TGLTextureSampler); RegisterXCollectionItemClass(TGLFrameBufferAttachment); RegisterXCollectionItemClass(TGLTextureCombiner); RegisterXCollectionItemClass(TGLShaderEx); RegisterXCollectionItemClass(TGLASMVertexProgram); vStandartUniformAutoSetExecutor := TStandartUniformAutoSetExecutor.Create; finalization vStandartUniformAutoSetExecutor.Destroy; end.