// // The graphics engine GLXEngine. The unit of GXScene for Delphi // unit GXS.Material; (* Handles all the material + material library stuff *) interface {$I Stage.Defines.inc} uses Winapi.OpenGL, Winapi.OpenGLext, System.Classes, System.SysUtils, System.Types, FMX.Dialogs, FMX.Graphics, GXS.XOpenGL, Stage.VectorTypes, Stage.VectorGeometry, GXS.BaseClasses, GXS.PersistentClasses, Stage.Strings, Stage.TextureFormat, GXS.Color, GXS.Coordinates, Stage.Utils, GXS.ApplicationFileIO, GXS.RenderContextInfo, GXS.Context, GXS.Texture, GXS.State, GXS.Graphics, GXS.ImageUtils; {$UNDEF USE_MULTITHREAD} type TgxFaceProperties = class; TgxMaterial = class; TgxAbstractMaterialLibrary = class; TgxMaterialLibrary = class; // an interface for proper TgxLibMaterialNameProperty support IgxMaterialLibrarySupported = interface(IInterface) ['{8E442AF9-D212-4A5E-8A88-92F798BABFD1}'] function GetMaterialLibrary: TgxAbstractMaterialLibrary; end; TgxAbstractLibMaterial = class; TgxLibMaterial = class; (* Define VXShader style application relatively to a material. ssHighLevel: shader is applied before material application, and unapplied after material unapplication ssLowLevel: shader is applied after material application, and unapplied before material unapplication ssReplace: shader is applied in place of the material (and material is completely ignored) *) TgxShaderStyle = (ssHighLevel, ssLowLevel, ssReplace); (* Defines what to do if for some reason shader failed to initialize. fiaSilentdisable: just disable it fiaRaiseHandledException: raise an exception, and handle it right away (usefull, when debigging within Delphi) fiaRaiseStardardException: raises the exception with a string from this function GetStardardNotSupportedMessage fiaReRaiseException: Re-raises the exception fiaGenerateEvent: Handles the exception, but generates an event that user can respond to. For example, he can try to compile a substitude shader, or replace it by a material. Note: HandleFailedInitialization does *not* create this event, it is left to user shaders which may chose to override this procedure. Commented out, because not sure if this option should exist, let other generations of developers decide ;) *) TgxShaderFailedInitAction = (fiaSilentDisable, fiaRaiseStandardException, fiaRaiseHandledException, fiaReRaiseException (* ,fiaGenerateEvent *) ); (* Generic, abstract shader class. Shaders are modeled here as an abstract material-altering entity with transaction-like behaviour. The base class provides basic context and user tracking, as well as setup/application facilities. Subclasses are expected to provide implementation for DoInitialize, DoApply, DoUnApply and DoFinalize. *) TgxShader = class(TgxUpdateAbleComponent) private FEnabled: Boolean; FLibMatUsers: TList; FVirtualHandle: TgxVirtualHandle; FShaderStyle: TgxShaderStyle; FUpdateCount: Integer; FShaderActive: Boolean; FFailedInitAction: TgxShaderFailedInitAction; protected (* Invoked once, before the first call to DoApply. The call happens with the OpenGL context being active. *) procedure DoInitialize(var rci: TgxRenderContextInfo; Sender: TObject); virtual; (* Request to apply the shader. Always followed by a DoUnApply when the shader is no longer needed. *) procedure DoApply(var rci: TgxRenderContextInfo; Sender: TObject); virtual; abstract; (* Request to un-apply the shader. Subclasses can assume the shader has been applied previously. Return True to request a multipass. *) function DoUnApply(var rci: TgxRenderContextInfo): Boolean; virtual; abstract; (* Invoked once, before the destruction of context or release of shader. The call happens with the OpenGL context being active. *) procedure DoFinalize; virtual; function GetShaderInitialized: Boolean; procedure InitializeShader(var rci: TgxRenderContextInfo; Sender: TObject); procedure FinalizeShader; procedure OnVirtualHandleAllocate(Sender: TgxVirtualHandle; var handle: Cardinal); procedure OnVirtualHandleDestroy(Sender: TgxVirtualHandle; var handle: Cardinal); procedure SetEnabled(val: Boolean); property ShaderInitialized: Boolean read GetShaderInitialized; property ShaderActive: Boolean read FShaderActive; procedure RegisterUser(libMat: TgxLibMaterial); procedure UnRegisterUser(libMat: TgxLibMaterial); // Used by the DoInitialize procedure of descendant classes to raise errors. procedure HandleFailedInitialization(const LastErrorMessage: string = ''); virtual; // May be this should be a function inside HandleFailedInitialization... function GetStardardNotSupportedMessage: string; virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; (* Subclasses should invoke this function when shader properties are altered. This procedure can also be used to reset/recompile the shader. *) procedure NotifyChange(Sender: TObject); override; procedure BeginUpdate; procedure EndUpdate; // Apply shader to OpenGL state machine. procedure Apply(var rci: TgxRenderContextInfo; Sender: TObject); (* UnApply shader. When returning True, the caller is expected to perform a multipass rendering by re-rendering then invoking UnApply again, until a "False" is returned. *) function UnApply(var rci: TgxRenderContextInfo): Boolean; // Shader application style (default is ssLowLevel). property ShaderStyle: TgxShaderStyle read FShaderStyle write FShaderStyle default ssLowLevel; procedure Assign(Source: TPersistent); override; (* Defines if shader is supported by hardware/drivers. Default - always supported. Descendants are encouraged to override this function. *) function ShaderSupported: Boolean; virtual; (* Defines what to do if for some reason shader failed to initialize. Note, that in some cases it cannon be determined by just checking the required OpenGL extentions. You need to try to compile and link the shader - only at that stage you might catch an error *) property FailedInitAction: TgxShaderFailedInitAction read FFailedInitAction write FFailedInitAction default fiaRaiseStandardException; published (* Turns on/off shader application. Note that this only turns on/off the shader application, if the ShaderStyle is ssReplace, the material won't be applied even if the shader is disabled. *) property Enabled: Boolean read FEnabled write SetEnabled default True; end; TgxShaderClass = class of TgxShader; TgxShininess = 0 .. 128; (* Stores basic face lighting properties. The lighting is described with the standard ambient/diffuse/emission/specular properties that behave like those of most rendering tools. You also have control over shininess (governs specular lighting) and polygon mode (lines / fill). *) TgxFaceProperties = class(TgxUpdateAbleObject) private FAmbient, FDiffuse, FSpecular, FEmission: TgxColor; FShininess: TgxShininess; protected procedure SetAmbient(AValue: TgxColor); procedure SetDiffuse(AValue: TgxColor); procedure SetEmission(AValue: TgxColor); procedure SetSpecular(AValue: TgxColor); procedure SetShininess(AValue: TgxShininess); public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure Apply(var rci: TgxRenderContextInfo; AFace: TgxCullFaceMode); procedure ApplyNoLighting(var rci: TgxRenderContextInfo; AFace: TgxCullFaceMode); procedure Assign(Source: TPersistent); override; published property Ambient: TgxColor read FAmbient write SetAmbient; property Diffuse: TgxColor read FDiffuse write SetDiffuse; property Emission: TgxColor read FEmission write SetEmission; property Shininess: TgxShininess read FShininess write SetShininess default 0; property Specular: TgxColor read FSpecular write SetSpecular; end; TgxDepthProperties = class(TgxUpdateAbleObject) private FDepthTest: Boolean; FDepthWrite: Boolean; FZNear, FZFar: Single; FCompareFunc: TgxDepthfunction; FDepthClamp: Boolean; protected procedure SetZNear(Value: Single); procedure SetZFar(Value: Single); procedure SetCompareFunc(Value: TgxDepthCompareFunc); procedure SetDepthTest(Value: Boolean); procedure SetDepthWrite(Value: Boolean); procedure SetDepthClamp(Value: Boolean); function StoreZNear: Boolean; function StoreZFar: Boolean; public constructor Create(AOwner: TPersistent); override; procedure Apply(var rci: TgxRenderContextInfo); procedure Assign(Source: TPersistent); override; published (* Specifies the mapping of the near clipping plane to window coordinates. The initial value is 0. *) property ZNear: Single read FZNear write SetZNear stored StoreZNear; (* Specifies the mapping of the far clipping plane to window coordinates. The initial value is 1. *) property ZFar: Single read FZFar write SetZFar stored StoreZFar; (* Specifies the function used to compare each incoming pixel depth value with the depth value present in the depth buffer. *) property DepthCompareFunction: TgxDepthfunction read FCompareFunc write SetCompareFunc default cfLequal; (* DepthTest enabling. When DepthTest is enabled, objects closer to the camera will hide farther ones (via use of Z-Buffering). When DepthTest is disabled, the latest objects drawn/rendered overlap all previous objects, whatever their distance to the camera. Even when DepthTest is enabled, objects may chose to ignore depth testing through the osIgnoreDepthBuffer of their ObjectStyle property. *) property DepthTest: Boolean read FDepthTest write SetDepthTest default True; // If True, object will not write to Z-Buffer. property DepthWrite: Boolean read FDepthWrite write SetDepthWrite default False; // Enable clipping depth to the near and far planes property DepthClamp: Boolean read FDepthClamp write SetDepthClamp default False; end; TgxLibMaterialName = string; (* To show up in design-time editor vTGlAlphaFuncValues and vTgxBlendFuncFactorValues arrays if you type smth like af_GL_NEVER = GL_NEVER in the definition. *) TgxAlphaFunc = TgxComparisonFunction; TgxBlendingParameters = class(TgxUpdateAbleObject) private FUseAlphaFunc: Boolean; FUseBlendFunc: Boolean; FSeparateBlendFunc: Boolean; FAlphaFuncType: TgxAlphaFunc; FAlphaFuncRef: Single; FBlendFuncSFactor: TgxBlendFunction; FBlendFuncDFactor: TgxBlendFunction; FAlphaBlendFuncSFactor: TgxBlendFunction; FAlphaBlendFuncDFactor: TgxBlendFunction; procedure SetUseAlphaFunc(const Value: Boolean); procedure SetUseBlendFunc(const Value: Boolean); procedure SetSeparateBlendFunc(const Value: Boolean); procedure SetAlphaFuncRef(const Value: Single); procedure SetAlphaFuncType(const Value: TgxAlphaFunc); procedure SetBlendFuncDFactor(const Value: TgxBlendFunction); procedure SetBlendFuncSFactor(const Value: TgxBlendFunction); procedure SetAlphaBlendFuncDFactor(const Value: TgxBlendFunction); procedure SetAlphaBlendFuncSFactor(const Value: TgxBlendFunction); function StoreAlphaFuncRef: Boolean; public constructor Create(AOwner: TPersistent); override; procedure Apply(var rci: TgxRenderContextInfo); published property UseAlphaFunc: Boolean read FUseAlphaFunc write SetUseAlphaFunc default False; property AlphaFunctType: TgxAlphaFunc read FAlphaFuncType write SetAlphaFuncType default cfGreater; property AlphaFuncRef: Single read FAlphaFuncRef write SetAlphaFuncRef stored StoreAlphaFuncRef; property UseBlendFunc: Boolean read FUseBlendFunc write SetUseBlendFunc default True; property SeparateBlendFunc: Boolean read FSeparateBlendFunc write SetSeparateBlendFunc default False; property BlendFuncSFactor: TgxBlendFunction read FBlendFuncSFactor write SetBlendFuncSFactor default bfSrcAlpha; property BlendFuncDFactor: TgxBlendFunction read FBlendFuncDFactor write SetBlendFuncDFactor default bfOneMinusSrcAlpha; property AlphaBlendFuncSFactor: TgxBlendFunction read FAlphaBlendFuncSFactor write SetAlphaBlendFuncSFactor default bfSrcAlpha; property AlphaBlendFuncDFactor: TgxBlendFunction read FAlphaBlendFuncDFactor write SetAlphaBlendFuncDFactor default bfOneMinusSrcAlpha; end; (* Simplified blending options. bmOpaque : disable blending bmTransparency : uses standard alpha blending bmAdditive : activates additive blending (with saturation) bmAlphaTest50 : uses opaque blending, with alpha-testing at 50% (full transparency if alpha is below 0.5, full opacity otherwise) bmAlphaTest100 : uses opaque blending, with alpha-testing at 100% bmModulate : uses modulation blending bmCustom : uses TgxBlendingParameters options *) TgxBlendingMode = (bmOpaque, bmTransparency, bmAdditive, bmAlphaTest50, bmAlphaTest100, bmModulate, bmCustom); TgxFaceCulling = (fcBufferDefault, fcCull, fcNoCull); (* Control special rendering options for a material. moIgnoreFog : fog is deactivated when the material is rendered *) TgxMaterialOption = (moIgnoreFog, moNoLighting); TgxMaterialOptions = set of TgxMaterialOption; (* Describes a rendering material. A material is basically a set of face properties (front and back) that take care of standard material rendering parameters (diffuse, ambient, emission and specular) and texture mapping. An instance of this class is available for almost all objects in GLScene to allow quick definition of material properties. It can link to a TgxLibMaterial (taken for a material library). The TgxLibMaterial has more advanced properties (like texture transforms) and provides a standard way of sharing definitions and texture maps *) TgxMaterial = class(TgxUpdateAbleObject, IgxMaterialLibrarySupported, IgxNotifyable, IgxTextureNotifyAble) private FFrontProperties, FBackProperties: TgxFaceProperties; FDepthProperties: TgxDepthProperties; FBlendingMode: TgxBlendingMode; FBlendingParams: TgxBlendingParameters; FTexture: TgxTexture; FTextureEx: TgxTextureEx; FMaterialLibrary: TgxAbstractMaterialLibrary; FLibMaterialName: TgxLibMaterialName; FMaterialOptions: TgxMaterialOptions; FFaceCulling: TgxFaceCulling; FPolygonMode: TgxPolygonMode; currentLibMaterial: TgxAbstractLibMaterial; (* Implementing IVXMaterialLibrarySupported. *) function GetMaterialLibrary: TgxAbstractMaterialLibrary; protected function GetBackProperties: TgxFaceProperties; procedure SetBackProperties(Values: TgxFaceProperties); procedure SetFrontProperties(Values: TgxFaceProperties); procedure SetDepthProperties(Values: TgxDepthProperties); procedure SetBlendingMode(const val: TgxBlendingMode); procedure SetMaterialOptions(const val: TgxMaterialOptions); function GetTexture: TgxTexture; procedure SetTexture(ATexture: TgxTexture); procedure SetMaterialLibrary(const val: TgxAbstractMaterialLibrary); procedure SetLibMaterialName(const val: TgxLibMaterialName); procedure SetFaceCulling(const val: TgxFaceCulling); procedure SetPolygonMode(AValue: TgxPolygonMode); function GetTextureEx: TgxTextureEx; procedure SetTextureEx(const Value: TgxTextureEx); function StoreTextureEx: Boolean; procedure SetBlendingParams(const Value: TgxBlendingParameters); procedure NotifyLibMaterialDestruction; // Back, Front, Texture and blending not stored if linked to a LibMaterial function StoreMaterialProps: Boolean; public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure PrepareBuildList; procedure Apply(var rci: TgxRenderContextInfo); { Restore non-standard material states that were altered; A return value of True is a multipass request. } function UnApply(var rci: TgxRenderContextInfo): Boolean; procedure Assign(Source: TPersistent); override; procedure NotifyChange(Sender: TObject); override; procedure NotifyTexMapChange(Sender: TObject); procedure DestroyHandles; procedure Loaded; (* Returns True if the material is blended. Will return the libmaterial's blending if it is linked to a material library. *) function Blended: Boolean; // True if the material has a secondary texture function HasSecondaryTexture: Boolean; // True if the material comes from the library instead of the texture property function MaterialIsLinkedToLib: Boolean; // Gets the primary texture either from material library or the texture property function GetActualPrimaryTexture: TgxTexture; // Gets the primary Material either from material library or the texture property function GetActualPrimaryMaterial: TgxMaterial; // Return the LibMaterial (see LibMaterialName) function GetLibMaterial: TgxLibMaterial; procedure QuickAssignMaterial(const MaterialLibrary: TgxMaterialLibrary; const Material: TgxLibMaterial); published property BackProperties: TgxFaceProperties read GetBackProperties write SetBackProperties stored StoreMaterialProps; property FrontProperties: TgxFaceProperties read FFrontProperties write SetFrontProperties stored StoreMaterialProps; property DepthProperties: TgxDepthProperties read FDepthProperties write SetDepthProperties stored StoreMaterialProps; property BlendingMode: TgxBlendingMode read FBlendingMode write SetBlendingMode stored StoreMaterialProps default bmOpaque; property BlendingParams: TgxBlendingParameters read FBlendingParams write SetBlendingParams; property MaterialOptions: TgxMaterialOptions read FMaterialOptions write SetMaterialOptions default []; property Texture: TgxTexture read GetTexture write SetTexture stored StoreMaterialProps; property FaceCulling: TgxFaceCulling read FFaceCulling write SetFaceCulling default fcBufferDefault; property MaterialLibrary: TgxAbstractMaterialLibrary read FMaterialLibrary write SetMaterialLibrary; property LibMaterialName: TgxLibMaterialName read FLibMaterialName write SetLibMaterialName; property TextureEx: TgxTextureEx read GetTextureEx write SetTextureEx stored StoreTextureEx; property PolygonMode: TgxPolygonMode read FPolygonMode write SetPolygonMode default pmFill; end; TgxAbstractLibMaterial = class(TCollectionItem, IgxMaterialLibrarySupported, IgxNotifyable) protected FUserList: TList; FName: TgxLibMaterialName; FNameHashKey: Integer; FTag: Integer; FNotifying: Boolean; // used for recursivity protection // implementing IVXMaterialLibrarySupported function GetMaterialLibrary: TgxAbstractMaterialLibrary; // implementing IInterface function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; protected function GetDisplayName: string; override; class function ComputeNameHashKey(const name: string): Integer; procedure SetName(const val: TgxLibMaterialName); procedure Loaded; virtual; abstract; public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Apply(var ARci: TgxRenderContextInfo); virtual; abstract; // Restore non-standard material states that were altered function UnApply(var ARci: TgxRenderContextInfo): Boolean; virtual; abstract; procedure RegisterUser(Obj: TgxUpdateAbleObject); overload; procedure UnRegisterUser(Obj: TgxUpdateAbleObject); overload; procedure RegisterUser(comp: TgxUpdateAbleComponent); overload; procedure UnRegisterUser(comp: TgxUpdateAbleComponent); overload; procedure RegisterUser(libMaterial: TgxLibMaterial); overload; procedure UnRegisterUser(libMaterial: TgxLibMaterial); overload; procedure NotifyUsers; function IsUsed: Boolean; // returns true if the texture has registed users property NameHashKey: Integer read FNameHashKey; procedure NotifyChange(Sender: TObject); virtual; function Blended: Boolean; virtual; property MaterialLibrary: TgxAbstractMaterialLibrary read GetMaterialLibrary; published property Name: TgxLibMaterialName read FName write SetName; property Tag: Integer read FTag write FTag; end; (* Material in a material library. Introduces Texture transformations (offset and scale). Those transformations are available only for lib materials to minimize the memory cost of basic materials (which are used in almost all objects). *) TgxLibMaterial = class(TgxAbstractLibMaterial, IgxTextureNotifyAble) private FMaterial: TgxMaterial; FTextureOffset, FTextureScale: TgxCoordinates; FTextureRotate: Single; FTextureMatrixIsIdentity: Boolean; FTextureOverride: Boolean; FTextureMatrix: TMatrix4f; FTexture2Name: TgxLibMaterialName; FShader: TgxShader; libMatTexture2: TgxLibMaterial; // internal cache protected procedure Loaded; override; procedure SetMaterial(const val: TgxMaterial); procedure SetTextureOffset(const val: TgxCoordinates); procedure SetTextureScale(const val: TgxCoordinates); procedure SetTextureMatrix(const Value: TMatrix4f); procedure SetTexture2Name(const val: TgxLibMaterialName); procedure SetShader(const val: TgxShader); procedure SetTextureRotate(Value: Single); function StoreTextureRotate: Boolean; procedure CalculateTextureMatrix; procedure DestroyHandles; procedure DoOnTextureNeeded(Sender: TObject; var textureFileName: string); procedure OnNotifyChange(Sender: TObject); public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure PrepareBuildList; procedure Apply(var ARci: TgxRenderContextInfo); override; // Restore non-standard material states that were altered function UnApply(var ARci: TgxRenderContextInfo): Boolean; override; procedure NotifyUsersOfTexMapChange; property TextureMatrix: TMatrix4f read FTextureMatrix write SetTextureMatrix; property TextureMatrixIsIdentity: Boolean read FTextureMatrixIsIdentity; procedure NotifyTexMapChange(Sender: TObject); function Blended: Boolean; override; published property Material: TgxMaterial read FMaterial write SetMaterial; (* Texture offset in texture coordinates. The offset is applied after scaling. *) property TextureOffset: TgxCoordinates read FTextureOffset write SetTextureOffset; (* 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: TgxCoordinates read FTextureScale write SetTextureScale; property TextureRotate: Single read FTextureRotate write SetTextureRotate stored StoreTextureRotate; (* Reference to the second texture. The referred LibMaterial *must* be in the same material library. Second textures are supported only through ARB multitexturing (ignored if not supported). *) property Texture2Name: TgxLibMaterialName read FTexture2Name write SetTexture2Name; // Optionnal shader for the material. property Shader: TgxShader read FShader write SetShader; end; TgxAbstractLibMaterials = class(TOwnedCollection) protected procedure Loaded; function GetMaterial(const AName: TgxLibMaterialName): TgxAbstractLibMaterial; inline; public function MakeUniqueName(const nameRoot: TgxLibMaterialName): TgxLibMaterialName; virtual; end; // A collection of materials, mainly used in material libraries. TgxLibMaterials = class(TgxAbstractLibMaterials) protected procedure SetItems(index: Integer; const val: TgxLibMaterial); function GetItems(index: Integer): TgxLibMaterial; procedure DestroyHandles; public constructor Create(AOwner: TComponent); function Owner: TPersistent; function IndexOf(const Item: TgxLibMaterial): Integer; function Add: TgxLibMaterial; function FindItemID(ID: Integer): TgxLibMaterial; property Items[index: Integer]: TgxLibMaterial read GetItems write SetItems; default; function GetLibMaterialByName(const AName: TgxLibMaterialName): TgxLibMaterial; // Returns index of this Texture if it exists. function GetTextureIndex(const Texture: TgxTexture): Integer; // Returns index of this Material if it exists. function GetMaterialIndex(const Material: TgxMaterial): Integer; // Returns name of this Texture if it exists. function GetNameOfTexture(const Texture: TgxTexture): TgxLibMaterialName; // Returns name of this Material if it exists. function GetNameOfLibMaterial(const Material: TgxLibMaterial): TgxLibMaterialName; procedure PrepareBuildList; (* Deletes all the unused materials in the collection. A material is considered unused if no other material or updateable object references it. WARNING: For this to work, objects that use the texture, have to REGISTER to the texture. *) procedure DeleteUnusedMaterials; end; TgxAbstractMaterialLibrary = class(TgxCadenceAbleComponent) protected FMaterials: TgxAbstractLibMaterials; FLastAppliedMaterial: TgxAbstractLibMaterial; FTexturePaths: string; FTexturePathList: TStringList; procedure SetTexturePaths(const val: string); property TexturePaths: string read FTexturePaths write SetTexturePaths; procedure Loaded; override; public procedure SetNamesToTStrings(AStrings: TStrings); (* Applies the material of given name. Returns False if the material could not be found. ake sure this call is balanced with a corresponding UnApplyMaterial (or an assertion will be triggered in the destructor). If a material is already applied, and has not yet been unapplied, an assertion will be triggered. *) function ApplyMaterial(const AName: string; var ARci: TgxRenderContextInfo): Boolean; virtual; (* Un-applies the last applied material. Use this function in conjunction with ApplyMaterial. If no material was applied, an assertion will be triggered. *) function UnApplyMaterial(var ARci: TgxRenderContextInfo): Boolean; virtual; end; (* Stores a set of materials, to be used and shared by scene objects. Use a material libraries for storing commonly used materials, it provides an efficient way to share texture and material data among many objects, thus reducing memory needs and rendering time. Materials in a material library also feature advanced control properties like texture coordinates transforms. *) TgxMaterialLibrary = class(TgxAbstractMaterialLibrary) private FDoNotClearMaterialsOnLoad: Boolean; FOnTextureNeeded: TgxTextureNeededEvent; protected function GetMaterials: TgxLibMaterials; procedure SetMaterials(const val: TgxLibMaterials); function StoreMaterials: Boolean; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure DestroyHandles; procedure WriteToFiler(writer: TgxVirtualWriter); procedure ReadFromFiler(reader: TgxVirtualReader); procedure SaveToStream(aStream: TStream); virtual; procedure LoadFromStream(aStream: TStream); virtual; procedure AddMaterialsFromStream(aStream: TStream); (* Save library content to a file. Recommended extension : .GLML Currently saves only texture, ambient, diffuse, emission and specular colors. *) procedure SaveToFile(const fileName: string); procedure LoadFromFile(const fileName: string); procedure AddMaterialsFromFile(const fileName: string); (* Add a "standard" texture material. "standard" means linear texturing mode with mipmaps and texture modulation mode with default-strength color components. If persistent is True, the image will be loaded persistently in memory (via a TgxPersistentImage), if false, it will be unloaded after upload to OpenRX (via TgxPicFileImage). *) function AddTextureMaterial(const MaterialName, fileName: string; persistent: Boolean = True): TgxLibMaterial; overload; (* Add a "standard" texture material. TgxGraphic based variant. *) function AddTextureMaterial(const MaterialName: string; Graphic: TBitmap): TgxLibMaterial; overload; // Returns libMaterial of given name if any exists. function LibMaterialByName(const AName: TgxLibMaterialName): TgxLibMaterial; // Returns Texture of given material's name if any exists. function TextureByName(const LibMatName: TgxLibMaterialName): TgxTexture; // Returns name of texture if any exists. function GetNameOfTexture(const Texture: TgxTexture): TgxLibMaterialName; // Returns name of Material if any exists. function GetNameOfLibMaterial(const libMat: TgxLibMaterial): TgxLibMaterialName; published // The materials collection. property Materials: TgxLibMaterials read GetMaterials write SetMaterials stored StoreMaterials; (* This event is fired whenever a texture needs to be loaded from disk. The event is triggered before even attempting to load the texture, and before TexturePaths is used. *) property OnTextureNeeded: TgxTextureNeededEvent read FOnTextureNeeded write FOnTextureNeeded; (* Paths to lookup when attempting to load a texture. You can specify multiple paths when loading a texture, the separator being the semi-colon ';' character. Directories are looked up from first to last, the first file name match is used. The current directory is always implicit and checked last. Note that you can also use the OnTextureNeeded event to provide a filename. *) property TexturePaths; end; // ------------------------------------------------------------------------------ implementation // ------------------------------------------------------------------------------ // ------------------ // ------------------ TgxFaceProperties ------------------ // ------------------ constructor TgxFaceProperties.Create(AOwner: TPersistent); begin inherited; // default colors FAmbient := TgxColor.CreateInitialized(Self, clrGray20); FDiffuse := TgxColor.CreateInitialized(Self, clrGray80); FEmission := TgxColor.Create(Self); FSpecular := TgxColor.Create(Self); FShininess := 0; end; destructor TgxFaceProperties.Destroy; begin FAmbient.Free; FDiffuse.Free; FEmission.Free; FSpecular.Free; inherited Destroy; end; procedure TgxFaceProperties.Apply(var rci: TgxRenderContextInfo; aFace: TgxCullFaceMode); begin with rci.gxStates do begin SetMaterialColors(aFace, Emission.Color, Ambient.Color, Diffuse.Color, Specular.Color, FShininess); end; end; procedure TgxFaceProperties.ApplyNoLighting(var rci: TgxRenderContextInfo; aFace: TgxCullFaceMode); begin glColor4fv(@Diffuse.AsAddress^); end; procedure TgxFaceProperties.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TgxFaceProperties) then begin FAmbient.DirectColor := TgxFaceProperties(Source).Ambient.Color; FDiffuse.DirectColor := TgxFaceProperties(Source).Diffuse.Color; FEmission.DirectColor := TgxFaceProperties(Source).Emission.Color; FSpecular.DirectColor := TgxFaceProperties(Source).Specular.Color; FShininess := TgxFaceProperties(Source).Shininess; NotifyChange(Self); end; end; procedure TgxFaceProperties.SetAmbient(AValue: TgxColor); begin FAmbient.DirectColor := AValue.Color; NotifyChange(Self); end; procedure TgxFaceProperties.SetDiffuse(AValue: TgxColor); begin FDiffuse.DirectColor := AValue.Color; NotifyChange(Self); end; procedure TgxFaceProperties.SetEmission(AValue: TgxColor); begin FEmission.DirectColor := AValue.Color; NotifyChange(Self); end; procedure TgxFaceProperties.SetSpecular(AValue: TgxColor); begin FSpecular.DirectColor := AValue.Color; NotifyChange(Self); end; procedure TgxFaceProperties.SetShininess(AValue: TgxShininess); begin if FShininess <> AValue then begin FShininess := AValue; NotifyChange(Self); end; end; // ------------------ // ------------------ TgxDepthProperties ------------------ // ------------------ constructor TgxDepthProperties.Create(AOwner: TPersistent); begin inherited Create(AOwner); FDepthTest := True; FDepthWrite := False; FZNear := 0; FZFar := 1; FCompareFunc := cfLequal; FDepthClamp := False; end; procedure TgxDepthProperties.Apply(var rci: TgxRenderContextInfo); begin with rci.gxStates do begin if FDepthTest and rci.bufferDepthTest then Enable(stDepthTest) else Disable(stDepthTest); DepthWriteMask := FDepthWrite; DepthFunc := FCompareFunc; SetDepthRange(FZNear, FZFar); if FDepthClamp then Enable(stDepthClamp) else Disable(stDepthClamp); end; end; procedure TgxDepthProperties.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TgxDepthProperties) then begin FDepthTest := TgxDepthProperties(Source).FDepthTest; FDepthWrite := TgxDepthProperties(Source).FDepthWrite; FZNear := TgxDepthProperties(Source).FZNear; FZFar := TgxDepthProperties(Source).FZFar; FCompareFunc := TgxDepthProperties(Source).FCompareFunc; NotifyChange(Self); end; end; procedure TgxDepthProperties.SetZNear(Value: Single); begin Value := ClampValue(Value, 0, 1); if Value <> FZNear then begin FZNear := Value; NotifyChange(Self); end; end; procedure TgxDepthProperties.SetZFar(Value: Single); begin Value := ClampValue(Value, 0, 1); if Value <> FZFar then begin FZFar := Value; NotifyChange(Self); end; end; procedure TgxDepthProperties.SetCompareFunc(Value: TgxDepthfunction); begin if Value <> FCompareFunc then begin FCompareFunc := Value; NotifyChange(Self); end; end; procedure TgxDepthProperties.SetDepthTest(Value: Boolean); begin if Value <> FDepthTest then begin FDepthTest := Value; NotifyChange(Self); end; end; procedure TgxDepthProperties.SetDepthWrite(Value: Boolean); begin if Value <> FDepthWrite then begin FDepthWrite := Value; NotifyChange(Self); end; end; procedure TgxDepthProperties.SetDepthClamp(Value: Boolean); begin if Value <> FDepthClamp then begin FDepthClamp := Value; NotifyChange(Self); end; end; function TgxDepthProperties.StoreZNear: Boolean; begin Result := FZNear <> 0.0; end; function TgxDepthProperties.StoreZFar: Boolean; begin Result := FZFar <> 1.0; end; // ------------------ // ------------------ TgxShader ------------------ // ------------------ constructor TgxShader.Create(AOwner: TComponent); begin FLibMatUsers := TList.Create; FVirtualHandle := TgxVirtualHandle.Create; FVirtualHandle.OnAllocate := OnVirtualHandleAllocate; FVirtualHandle.OnDestroy := OnVirtualHandleDestroy; FShaderStyle := ssLowLevel; FEnabled := True; FFailedInitAction := fiaRaiseStandardException; inherited; end; destructor TgxShader.Destroy; var i: Integer; list: TList; begin FVirtualHandle.DestroyHandle; FinalizeShader; inherited; list := FLibMatUsers; FLibMatUsers := nil; for i := list.Count - 1 downto 0 do TgxLibMaterial(list[i]).Shader := nil; list.Free; FVirtualHandle.Free; end; procedure TgxShader.NotifyChange(Sender: TObject); var i: Integer; begin if FUpdateCount = 0 then begin for i := FLibMatUsers.Count - 1 downto 0 do TgxLibMaterial(FLibMatUsers[i]).NotifyUsers; FinalizeShader; end; end; procedure TgxShader.BeginUpdate; begin Inc(FUpdateCount); end; procedure TgxShader.EndUpdate; begin Dec(FUpdateCount); if FUpdateCount = 0 then NotifyChange(Self); end; procedure TgxShader.DoInitialize(var rci: TgxRenderContextInfo; Sender: TObject); begin // nothing here end; procedure TgxShader.DoFinalize; begin // nothing here end; function TgxShader.GetShaderInitialized: Boolean; begin Result := (FVirtualHandle.handle <> 0); end; procedure TgxShader.InitializeShader(var rci: TgxRenderContextInfo; Sender: TObject); begin FVirtualHandle.AllocateHandle; if FVirtualHandle.IsDataNeedUpdate then begin DoInitialize(rci, Sender); FVirtualHandle.NotifyDataUpdated; end; end; procedure TgxShader.FinalizeShader; begin FVirtualHandle.NotifyChangesOfData; DoFinalize; end; procedure TgxShader.Apply(var rci: TgxRenderContextInfo; Sender: TObject); begin {$IFNDEF USE_MULTITHREAD} Assert(not FShaderActive, 'Unbalanced shader application.'); {$ENDIF} // Need to check it twice, because shader may refuse to initialize // and choose to disable itself during initialization. if FEnabled then if FVirtualHandle.IsDataNeedUpdate then InitializeShader(rci, Sender); if FEnabled then DoApply(rci, Sender); FShaderActive := True; end; function TgxShader.UnApply(var rci: TgxRenderContextInfo): Boolean; begin {$IFNDEF USE_MULTITHREAD} Assert(FShaderActive, 'Unbalanced shader application.'); {$ENDIF} if Enabled then begin Result := DoUnApply(rci); if not Result then FShaderActive := False; end else begin FShaderActive := False; Result := False; end; end; procedure TgxShader.OnVirtualHandleDestroy(Sender: TgxVirtualHandle; var handle: Cardinal); begin handle := 0; end; procedure TgxShader.OnVirtualHandleAllocate(Sender: TgxVirtualHandle; var handle: Cardinal); begin handle := 1; end; procedure TgxShader.SetEnabled(val: Boolean); begin {$IFNDEF USE_MULTITHREAD} Assert(not FShaderActive, 'Shader is active.'); {$ENDIF} if val <> FEnabled then begin FEnabled := val; NotifyChange(Self); end; end; procedure TgxShader.RegisterUser(libMat: TgxLibMaterial); var i: Integer; begin i := FLibMatUsers.IndexOf(libMat); if i < 0 then FLibMatUsers.Add(libMat); end; procedure TgxShader.UnRegisterUser(libMat: TgxLibMaterial); begin if Assigned(FLibMatUsers) then FLibMatUsers.Remove(libMat); end; procedure TgxShader.Assign(Source: TPersistent); begin if Source is TgxShader then begin FShaderStyle := TgxShader(Source).FShaderStyle; FFailedInitAction := TgxShader(Source).FFailedInitAction; Enabled := TgxShader(Source).FEnabled; end else inherited Assign(Source); // to the pit of doom ;) end; function TgxShader.ShaderSupported: Boolean; begin Result := True; end; procedure TgxShader.HandleFailedInitialization(const LastErrorMessage: string = ''); begin case FailedInitAction of fiaSilentDisable: ; // Do nothing ;) fiaRaiseHandledException: try raise EShaderException.Create(GetStardardNotSupportedMessage); except end; fiaRaiseStandardException: raise EShaderException.Create(GetStardardNotSupportedMessage); fiaReRaiseException: begin if LastErrorMessage <> '' then raise EShaderException.Create(LastErrorMessage) else raise EShaderException.Create(GetStardardNotSupportedMessage) end; // fiaGenerateEvent:; // Do nothing. Event creation is left up to user shaders // // which may choose to override this procedure. else Assert(False, strErrorEx + strUnknownType); end; end; function TgxShader.GetStardardNotSupportedMessage: string; begin if Name <> '' then Result := 'Your hardware/driver doesn''t support shader "' + Name + '"!' else Result := 'Your hardware/driver doesn''t support shader "' + ClassName + '"!'; end; // ----------------- TgxMaterial -------------------------------------------------- constructor TgxMaterial.Create(AOwner: TPersistent); begin inherited; FFrontProperties := TgxFaceProperties.Create(Self); FTexture := nil; // AutoCreate FFaceCulling := fcBufferDefault; FPolygonMode := pmFill; FBlendingParams := TgxBlendingParameters.Create(Self); FDepthProperties := TgxDepthProperties.Create(Self) end; destructor TgxMaterial.Destroy; begin if Assigned(currentLibMaterial) then currentLibMaterial.UnRegisterUser(Self); FBackProperties.Free; FFrontProperties.Free; FDepthProperties.Free; FTexture.Free; FTextureEx.Free; FBlendingParams.Free; inherited Destroy; end; function TgxMaterial.GetMaterialLibrary: TgxAbstractMaterialLibrary; begin Result := FMaterialLibrary; end; procedure TgxMaterial.SetBackProperties(Values: TgxFaceProperties); begin BackProperties.Assign(Values); NotifyChange(Self); end; function TgxMaterial.GetBackProperties: TgxFaceProperties; begin if not Assigned(FBackProperties) then FBackProperties := TgxFaceProperties.Create(Self); Result := FBackProperties; end; procedure TgxMaterial.SetFrontProperties(Values: TgxFaceProperties); begin FFrontProperties.Assign(Values); NotifyChange(Self); end; procedure TgxMaterial.SetDepthProperties(Values: TgxDepthProperties); begin FDepthProperties.Assign(Values); NotifyChange(Self); end; procedure TgxMaterial.SetBlendingMode(const val: TgxBlendingMode); begin if val <> FBlendingMode then begin FBlendingMode := val; NotifyChange(Self); end; end; procedure TgxMaterial.SetMaterialOptions(const val: TgxMaterialOptions); begin if val <> FMaterialOptions then begin FMaterialOptions := val; NotifyChange(Self); end; end; function TgxMaterial.GetTexture: TgxTexture; begin if not Assigned(FTexture) then FTexture := TgxTexture.Create(Self); Result := FTexture; end; procedure TgxMaterial.SetTexture(ATexture: TgxTexture); begin if Assigned(ATexture) then Texture.Assign(ATexture) else FreeAndNil(FTexture); end; procedure TgxMaterial.SetFaceCulling(const val: TgxFaceCulling); begin if val <> FFaceCulling then begin FFaceCulling := val; NotifyChange(Self); end; end; procedure TgxMaterial.SetMaterialLibrary(const val: TgxAbstractMaterialLibrary); begin FMaterialLibrary := val; SetLibMaterialName(LibMaterialName); end; procedure TgxMaterial.SetLibMaterialName(const val: TgxLibMaterialName); var oldLibrary: TgxMaterialLibrary; function MaterialLoopFrom(curMat: TgxLibMaterial): Boolean; var loopCount: Integer; begin loopCount := 0; while Assigned(curMat) and (loopCount < 16) do begin with curMat.Material do begin if Assigned(oldLibrary) then curMat := oldLibrary.Materials.GetLibMaterialByName(LibMaterialName) else curMat := nil; end; Inc(loopCount) end; Result := (loopCount >= 16); end; var newLibMaterial: TgxAbstractLibMaterial; begin // locate new libmaterial if Assigned(FMaterialLibrary) then newLibMaterial := FMaterialLibrary.FMaterials.GetMaterial(val) else newLibMaterial := nil; // make sure new won't trigger an infinite loop if FMaterialLibrary is TgxMaterialLibrary then begin oldLibrary := TgxMaterialLibrary(FMaterialLibrary); if MaterialLoopFrom(TgxLibMaterial(newLibMaterial)) then begin if IsDesignTime then InformationDlg(Format(strCyclicRefMat, [val])) else ShowMessage(Format(strCyclicRefMat, [val])); exit; end; end; FLibMaterialName := val; // unregister if required if newLibMaterial <> currentLibMaterial then begin // unregister from old if Assigned(currentLibMaterial) then currentLibMaterial.UnRegisterUser(Self); currentLibMaterial := newLibMaterial; // register with new if Assigned(currentLibMaterial) then currentLibMaterial.RegisterUser(Self); NotifyTexMapChange(Self); end; end; function TgxMaterial.GetTextureEx: TgxTextureEx; begin if not Assigned(FTextureEx) then FTextureEx := TgxTextureEx.Create(Self); Result := FTextureEx; end; procedure TgxMaterial.SetTextureEx(const Value: TgxTextureEx); begin if Assigned(Value) or Assigned(FTextureEx) then TextureEx.Assign(Value); end; function TgxMaterial.StoreTextureEx: Boolean; begin Result := (Assigned(FTextureEx) and (TextureEx.Count > 0)); end; procedure TgxMaterial.SetBlendingParams(const Value: TgxBlendingParameters); begin FBlendingParams.Assign(Value); NotifyChange(Self); end; procedure TgxMaterial.NotifyLibMaterialDestruction; begin FMaterialLibrary := nil; FLibMaterialName := ''; currentLibMaterial := nil; end; procedure TgxMaterial.Loaded; begin inherited; if Assigned(FTextureEx) then TextureEx.Loaded; end; function TgxMaterial.StoreMaterialProps: Boolean; begin Result := not Assigned(currentLibMaterial); end; procedure TgxMaterial.PrepareBuildList; begin if Assigned(FTexture) and (not FTexture.Disabled) then FTexture.PrepareBuildList; end; procedure TgxMaterial.Apply(var rci: TgxRenderContextInfo); begin if Assigned(currentLibMaterial) then currentLibMaterial.Apply(rci) else with rci.gxStates do begin Disable(stColorMaterial); PolygonMode := FPolygonMode; if FPolygonMode = pmLines then Disable(stLineStipple); // Lighting switch if (moNoLighting in MaterialOptions) or not rci.bufferLighting then begin Disable(stLighting); FFrontProperties.ApplyNoLighting(rci, cmFront); end else begin Enable(stLighting); FFrontProperties.Apply(rci, cmFront); end; // Apply FaceCulling and BackProperties (if needs be) case FFaceCulling of fcBufferDefault: begin if rci.bufferFaceCull then Enable(stCullFace) else Disable(stCullFace); BackProperties.Apply(rci, cmBack); end; fcCull: Enable(stCullFace); fcNoCull: begin Disable(stCullFace); BackProperties.Apply(rci, 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 rci.ignoreBlendingRequests then case FBlendingMode of bmOpaque: begin Disable(stBlend); Disable(stAlphaTest); end; bmTransparency: begin Enable(stBlend); Enable(stAlphaTest); SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha); SetAlphaFunction(cfGreater, 0); end; bmAdditive: begin Enable(stBlend); Enable(stAlphaTest); SetBlendFunc(bfSrcAlpha, bfOne); SetAlphaFunction(cfGreater, 0); end; bmAlphaTest50: begin Disable(stBlend); Enable(stAlphaTest); SetAlphaFunction(cfGEqual, 0.5); end; bmAlphaTest100: begin Disable(stBlend); Enable(stAlphaTest); SetAlphaFunction(cfGEqual, 1.0); end; bmModulate: begin Enable(stBlend); Enable(stAlphaTest); SetBlendFunc(bfDstColor, bfZero); SetAlphaFunction(cfGreater, 0); end; bmCustom: begin FBlendingParams.Apply(rci); end; end; // Fog switch if (moIgnoreFog in MaterialOptions) or not rci.bufferFog then Disable(stFog) else Enable(stFog); if not Assigned(FTextureEx) then begin if Assigned(FTexture) then FTexture.Apply(rci) end else begin if Assigned(FTexture) and not FTextureEx.IsTextureEnabled(0) then FTexture.Apply(rci) else if FTextureEx.Count > 0 then FTextureEx.Apply(rci); end; // Apply depth properties if not rci.ignoreDepthRequests then FDepthProperties.Apply(rci); end; end; function TgxMaterial.UnApply(var rci: TgxRenderContextInfo): Boolean; begin if Assigned(currentLibMaterial) then Result := currentLibMaterial.UnApply(rci) else begin if Assigned(FTexture) and (not FTexture.Disabled) and (not FTextureEx.IsTextureEnabled(0)) then FTexture.UnApply(rci) else if Assigned(FTextureEx) then FTextureEx.UnApply(rci); Result := False; end; end; procedure TgxMaterial.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TgxMaterial) then begin if Assigned(TgxMaterial(Source).FBackProperties) then BackProperties.Assign(TgxMaterial(Source).BackProperties) else FreeAndNil(FBackProperties); FFrontProperties.Assign(TgxMaterial(Source).FFrontProperties); FPolygonMode := TgxMaterial(Source).FPolygonMode; FBlendingMode := TgxMaterial(Source).FBlendingMode; FMaterialOptions := TgxMaterial(Source).FMaterialOptions; if Assigned(TgxMaterial(Source).FTexture) then Texture.Assign(TgxMaterial(Source).FTexture) else FreeAndNil(FTexture); FFaceCulling := TgxMaterial(Source).FFaceCulling; FMaterialLibrary := TgxMaterial(Source).MaterialLibrary; SetLibMaterialName(TgxMaterial(Source).LibMaterialName); TextureEx.Assign(TgxMaterial(Source).TextureEx); FDepthProperties.Assign(TgxMaterial(Source).DepthProperties); NotifyChange(Self); end else inherited; end; procedure TgxMaterial.NotifyChange(Sender: TObject); var intf: IgxNotifyable; begin if Supports(Owner, IgxNotifyable, intf) then intf.NotifyChange(Self); end; procedure TgxMaterial.NotifyTexMapChange(Sender: TObject); var intf: IgxTextureNotifyAble; begin if Supports(Owner, IgxTextureNotifyAble, intf) then intf.NotifyTexMapChange(Self) else NotifyChange(Self); end; procedure TgxMaterial.DestroyHandles; begin if Assigned(FTexture) then FTexture.DestroyHandles; end; function TgxMaterial.Blended: Boolean; begin if Assigned(currentLibMaterial) then begin Result := currentLibMaterial.Blended end else Result := not(BlendingMode in [bmOpaque, bmAlphaTest50, bmAlphaTest100, bmCustom]); end; function TgxMaterial.HasSecondaryTexture: Boolean; begin Result := Assigned(currentLibMaterial) and (currentLibMaterial is TgxLibMaterial) and Assigned(TgxLibMaterial(currentLibMaterial).libMatTexture2); end; function TgxMaterial.MaterialIsLinkedToLib: Boolean; begin Result := Assigned(currentLibMaterial); end; function TgxMaterial.GetActualPrimaryTexture: TgxTexture; begin if Assigned(currentLibMaterial) and (currentLibMaterial is TgxLibMaterial) then Result := TgxLibMaterial(currentLibMaterial).Material.Texture else Result := Texture; end; function TgxMaterial.GetActualPrimaryMaterial: TgxMaterial; begin if Assigned(currentLibMaterial) and (currentLibMaterial is TgxLibMaterial) then Result := TgxLibMaterial(currentLibMaterial).Material else Result := Self; end; function TgxMaterial.GetLibMaterial: TgxLibMaterial; begin if Assigned(currentLibMaterial) and (currentLibMaterial is TgxLibMaterial) then Result := TgxLibMaterial(currentLibMaterial) else Result := nil; end; procedure TgxMaterial.QuickAssignMaterial(const MaterialLibrary: TgxMaterialLibrary; const Material: TgxLibMaterial); begin FMaterialLibrary := MaterialLibrary; FLibMaterialName := Material.FName; if Material <> currentLibMaterial then begin // unregister from old if Assigned(currentLibMaterial) then currentLibMaterial.UnRegisterUser(Self); currentLibMaterial := Material; // register with new if Assigned(currentLibMaterial) then currentLibMaterial.RegisterUser(Self); NotifyTexMapChange(Self); end; end; procedure TgxMaterial.SetPolygonMode(AValue: TgxPolygonMode); begin if AValue <> FPolygonMode then begin FPolygonMode := AValue; NotifyChange(Self); end; end; // ------------------ // ------------------ TgxAbstractLibMaterial ------------------ // ------------------ constructor TgxAbstractLibMaterial.Create(ACollection: TCollection); begin inherited Create(ACollection); FUserList := TList.Create; if Assigned(ACollection) then begin FName := TgxAbstractLibMaterials(ACollection).MakeUniqueName('LibMaterial'); FNameHashKey := ComputeNameHashKey(FName); end; end; destructor TgxAbstractLibMaterial.Destroy; begin FUserList.Free; inherited Destroy; end; procedure TgxAbstractLibMaterial.Assign(Source: TPersistent); begin if Source is TgxAbstractLibMaterial then begin FName := TgxLibMaterials(Collection).MakeUniqueName(TgxLibMaterial(Source).name); FNameHashKey := ComputeNameHashKey(FName); end else inherited; // Raise AssignError end; function TgxAbstractLibMaterial.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; function TgxAbstractLibMaterial._AddRef: Integer; stdcall; begin Result := -1; // ignore end; function TgxAbstractLibMaterial._Release: Integer; stdcall; begin Result := -1; // ignore end; procedure TgxAbstractLibMaterial.RegisterUser(Obj: TgxUpdateAbleObject); begin Assert(FUserList.IndexOf(Obj) < 0); FUserList.Add(Obj); end; procedure TgxAbstractLibMaterial.UnRegisterUser(Obj: TgxUpdateAbleObject); begin FUserList.Remove(Obj); end; procedure TgxAbstractLibMaterial.RegisterUser(comp: TgxUpdateAbleComponent); begin Assert(FUserList.IndexOf(comp) < 0); FUserList.Add(comp); end; procedure TgxAbstractLibMaterial.UnRegisterUser(comp: TgxUpdateAbleComponent); begin FUserList.Remove(comp); end; procedure TgxAbstractLibMaterial.RegisterUser(libMaterial: TgxLibMaterial); begin Assert(FUserList.IndexOf(libMaterial) < 0); FUserList.Add(libMaterial); end; procedure TgxAbstractLibMaterial.UnRegisterUser(libMaterial: TgxLibMaterial); begin FUserList.Remove(libMaterial); end; procedure TgxAbstractLibMaterial.NotifyChange(Sender: TObject); begin NotifyUsers(); end; procedure TgxAbstractLibMaterial.NotifyUsers; var i: Integer; Obj: TObject; begin if FNotifying then exit; FNotifying := True; try for i := 0 to FUserList.Count - 1 do begin Obj := TObject(FUserList[i]); if Obj is TgxUpdateAbleObject then TgxUpdateAbleObject(FUserList[i]).NotifyChange(Self) else if Obj is TgxUpdateAbleComponent then TgxUpdateAbleComponent(FUserList[i]).NotifyChange(Self) else begin Assert(Obj is TgxAbstractLibMaterial); TgxAbstractLibMaterial(FUserList[i]).NotifyUsers; end; end; finally FNotifying := False; end; end; function TgxAbstractLibMaterial.IsUsed: Boolean; begin Result := Assigned(Self) and (FUserList.Count > 0); end; function TgxAbstractLibMaterial.GetDisplayName: string; begin Result := Name; end; function TgxAbstractLibMaterial.GetMaterialLibrary: TgxAbstractMaterialLibrary; var LOwner: TPersistent; begin Result := nil; if Assigned(Collection) then begin LOwner := TgxAbstractLibMaterials(Collection).Owner; if LOwner is TgxAbstractMaterialLibrary then Result := TgxAbstractMaterialLibrary(LOwner); end; end; function TgxAbstractLibMaterial.Blended: Boolean; begin Result := False; end; class function TgxAbstractLibMaterial.ComputeNameHashKey(const name: string): Integer; var i, n: Integer; begin n := Length(name); Result := n; for i := 1 to n do Result := (Result shl 1) + Byte(name[i]); end; procedure TgxAbstractLibMaterial.SetName(const val: TgxLibMaterialName); begin if val <> FName then begin if not(csLoading in TComponent(Collection.Owner).ComponentState) then begin if TgxLibMaterials(Collection).GetLibMaterialByName(val) <> Self then FName := TgxLibMaterials(Collection).MakeUniqueName(val) else FName := val; end else FName := val; FNameHashKey := ComputeNameHashKey(FName); end; end; // ------------------ // ------------------ TgxLibMaterial ------------------ // ------------------ constructor TgxLibMaterial.Create(ACollection: TCollection); begin inherited Create(ACollection); FMaterial := TgxMaterial.Create(Self); FMaterial.Texture.OnTextureNeeded := DoOnTextureNeeded; FTextureOffset := TgxCoordinates.CreateInitialized(Self, NullHmgVector, csPoint); FTextureOffset.OnNotifyChange := OnNotifyChange; FTextureScale := TgxCoordinates.CreateInitialized(Self, XYZHmgVector, csPoint); FTextureScale.OnNotifyChange := OnNotifyChange; FTextureRotate := 0; FTextureOverride := False; FTextureMatrixIsIdentity := True; end; destructor TgxLibMaterial.Destroy; var i: Integer; matObj: TObject; begin Shader := nil; // drop dependency Texture2Name := ''; // drop dependency for i := 0 to FUserList.Count - 1 do begin matObj := TObject(FUserList[i]); if matObj is TgxMaterial then TgxMaterial(matObj).NotifyLibMaterialDestruction else if matObj is TgxLibMaterial then begin TgxLibMaterial(matObj).libMatTexture2 := nil; TgxLibMaterial(matObj).FTexture2Name := ''; end; end; FMaterial.Free; FTextureOffset.Free; FTextureScale.Free; inherited; end; procedure TgxLibMaterial.Assign(Source: TPersistent); begin if Source is TgxLibMaterial then begin FMaterial.Assign(TgxLibMaterial(Source).Material); FTextureOffset.Assign(TgxLibMaterial(Source).TextureOffset); FTextureScale.Assign(TgxLibMaterial(Source).TextureScale); FTextureRotate := TgxLibMaterial(Source).TextureRotate; TextureMatrix := TgxLibMaterial(Source).TextureMatrix; FTextureOverride := TgxLibMaterial(Source).FTextureOverride; FTexture2Name := TgxLibMaterial(Source).Texture2Name; FShader := TgxLibMaterial(Source).Shader; end; inherited; end; function TgxLibMaterial.Blended: Boolean; begin Result := Material.Blended; end; procedure TgxLibMaterial.PrepareBuildList; begin if Assigned(Self) then Material.PrepareBuildList; end; procedure TgxLibMaterial.Apply(var ARci: TgxRenderContextInfo); var multitextured: Boolean; begin xglBeginUpdate; if Assigned(FShader) then begin case Shader.ShaderStyle of ssHighLevel: Shader.Apply(ARci, Self); ssReplace: begin Shader.Apply(ARci, Self); exit; end; end; end else ARci.gxStates.CurrentProgram := 0; if (Texture2Name <> '') and (not vSecondTextureUnitForbidden) then begin if not Assigned(libMatTexture2) then begin libMatTexture2 := TgxLibMaterials(Collection).GetLibMaterialByName(Texture2Name); if Assigned(libMatTexture2) then libMatTexture2.RegisterUser(Self) else FTexture2Name := ''; end; multitextured := Assigned(libMatTexture2) and (not libMatTexture2.Material.Texture.Disabled); end else multitextured := False; if not multitextured then begin // no multitexturing ("standard" mode) if not FTextureMatrixIsIdentity then ARci.gxStates.SetTextureMatrix(FTextureMatrix); Material.Apply(ARci); end else begin // multitexturing is ON if not FTextureMatrixIsIdentity then ARci.gxStates.SetTextureMatrix(FTextureMatrix); Material.Apply(ARci); if not libMatTexture2.FTextureMatrixIsIdentity then libMatTexture2.Material.Texture.ApplyAsTexture2(ARci, @libMatTexture2.FTextureMatrix.X.X) else libMatTexture2.Material.Texture.ApplyAsTexture2(ARci); if (not Material.Texture.Disabled) and (Material.Texture.MappingMode = tmmUser) then if libMatTexture2.Material.Texture.MappingMode = tmmUser then xglMapTexCoordToDual else xglMapTexCoordToMain else if libMatTexture2.Material.Texture.MappingMode = tmmUser then xglMapTexCoordToSecond else xglMapTexCoordToMain; end; if Assigned(FShader) then begin case Shader.ShaderStyle of ssLowLevel: Shader.Apply(ARci, Self); end; end; xglEndUpdate; end; function TgxLibMaterial.UnApply(var ARci: TgxRenderContextInfo): Boolean; begin Result := False; if Assigned(FShader) then begin case Shader.ShaderStyle of ssLowLevel: Result := Shader.UnApply(ARci); ssReplace: begin Result := Shader.UnApply(ARci); exit; end; end; end; if not Result then begin if Assigned(libMatTexture2) and (not vSecondTextureUnitForbidden) then begin libMatTexture2.Material.Texture.UnApplyAsTexture2(ARci, (not libMatTexture2.TextureMatrixIsIdentity)); xglMapTexCoordToMain; end; Material.UnApply(ARci); if not Material.Texture.Disabled then if not FTextureMatrixIsIdentity then ARci.gxStates.ResetTextureMatrix; if Assigned(FShader) then begin case Shader.ShaderStyle of ssHighLevel: Result := Shader.UnApply(ARci); end; end; end; end; procedure TgxLibMaterial.NotifyTexMapChange(Sender: TObject); begin NotifyUsersOfTexMapChange(); end; procedure TgxLibMaterial.NotifyUsersOfTexMapChange; var i: Integer; Obj: TObject; begin if FNotifying then exit; FNotifying := True; try for i := 0 to FUserList.Count - 1 do begin Obj := TObject(FUserList[i]); if Obj is TgxMaterial then TgxMaterial(FUserList[i]).NotifyTexMapChange(Self) else if Obj is TgxLibMaterial then TgxLibMaterial(FUserList[i]).NotifyUsersOfTexMapChange else if Obj is TgxUpdateAbleObject then TgxUpdateAbleObject(FUserList[i]).NotifyChange(Self) else if Obj is TgxUpdateAbleComponent then TgxUpdateAbleComponent(FUserList[i]).NotifyChange(Self); end; finally FNotifying := False; end; end; procedure TgxLibMaterial.Loaded; begin CalculateTextureMatrix; Material.Loaded; end; procedure TgxLibMaterial.SetMaterial(const val: TgxMaterial); begin FMaterial.Assign(val); end; procedure TgxLibMaterial.SetTextureOffset(const val: TgxCoordinates); begin FTextureOffset.AsVector := val.AsVector; CalculateTextureMatrix; end; procedure TgxLibMaterial.SetTextureScale(const val: TgxCoordinates); begin FTextureScale.AsVector := val.AsVector; CalculateTextureMatrix; end; procedure TgxLibMaterial.SetTextureMatrix(const Value: TMatrix4f); begin FTextureMatrixIsIdentity := CompareMem(@Value.X, @IdentityHmgMatrix.X, SizeOf(TMatrix4f)); FTextureMatrix := Value; FTextureOverride := True; NotifyUsers; end; procedure TgxLibMaterial.SetTextureRotate(Value: Single); begin if Value <> FTextureRotate then begin FTextureRotate := Value; CalculateTextureMatrix; end; end; function TgxLibMaterial.StoreTextureRotate: Boolean; begin Result := Abs(FTextureRotate) > EPSILON; end; procedure TgxLibMaterial.SetTexture2Name(const val: TgxLibMaterialName); begin if val <> Texture2Name then begin if Assigned(libMatTexture2) then begin libMatTexture2.UnRegisterUser(Self); libMatTexture2 := nil; end; FTexture2Name := val; NotifyUsers; end; end; procedure TgxLibMaterial.SetShader(const val: TgxShader); begin if val <> FShader then begin if Assigned(FShader) then FShader.UnRegisterUser(Self); FShader := val; if Assigned(FShader) then FShader.RegisterUser(Self); NotifyUsers; end; end; procedure TgxLibMaterial.CalculateTextureMatrix; begin 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(DegToRadian(FTextureRotate))); end; FTextureOverride := False; NotifyUsers; end; procedure TgxLibMaterial.DestroyHandles; var libMat: TgxLibMaterial; begin FMaterial.DestroyHandles; if FTexture2Name <> '' then begin libMat := TgxLibMaterials(Collection).GetLibMaterialByName(Texture2Name); if Assigned(libMat) then libMat.DestroyHandles; end; end; procedure TgxLibMaterial.OnNotifyChange(Sender: TObject); begin CalculateTextureMatrix; end; procedure TgxLibMaterial.DoOnTextureNeeded(Sender: TObject; var textureFileName: string); var mLib: TgxMaterialLibrary; i: Integer; tryName: string; begin if not Assigned(Collection) then exit; mLib := TgxMaterialLibrary((Collection as TgxLibMaterials).GetOwner); with mLib do if Assigned(FOnTextureNeeded) then FOnTextureNeeded(mLib, textureFileName); // if a ':' is present, or if it starts with a '\', consider it as an absolute path if (Pos(':', textureFileName) > 0) or (Copy(textureFileName, 1, 1) = PathDelim) then exit; // ok, not an absolute path, try given paths with mLib do begin if FTexturePathList <> nil then for i := 0 to FTexturePathList.Count - 1 do begin tryName := IncludeTrailingPathDelimiter(FTexturePathList[i]) + textureFileName; if (Assigned(vGXAFIOCreateFileStream) and FileStreamExists(tryName)) or FileExists(tryName) then begin textureFileName := tryName; Break; end; end; end; end; // ------------------ // ------------------ TgxLibMaterials ------------------ // ------------------ function TgxAbstractLibMaterials.GetMaterial(const AName: TgxLibMaterialName): TgxAbstractLibMaterial; var i, hk: Integer; lm: TgxAbstractLibMaterial; begin hk := TgxAbstractLibMaterial.ComputeNameHashKey(AName); for i := 0 to Count - 1 do begin lm := TgxAbstractLibMaterial(inherited Items[i]); if (lm.NameHashKey = hk) and (lm.name = AName) then begin Result := lm; exit; end; end; Result := nil; end; procedure TgxAbstractLibMaterials.Loaded; var i: Integer; begin for i := Count - 1 downto 0 do TgxAbstractLibMaterial(Items[i]).Loaded; end; function TgxAbstractLibMaterials.MakeUniqueName(const nameRoot: TgxLibMaterialName): TgxLibMaterialName; var i: Integer; begin Result := nameRoot; i := 1; while GetMaterial(Result) <> nil do begin Result := nameRoot + IntToStr(i); Inc(i); end; end; constructor TgxLibMaterials.Create(AOwner: TComponent); begin inherited Create(AOwner, TgxLibMaterial); end; procedure TgxLibMaterials.SetItems(index: Integer; const val: TgxLibMaterial); begin inherited Items[index] := val; end; function TgxLibMaterials.GetItems(index: Integer): TgxLibMaterial; begin Result := TgxLibMaterial(inherited Items[index]); end; procedure TgxLibMaterials.DestroyHandles; var i: Integer; begin for i := 0 to Count - 1 do Items[i].DestroyHandles; end; function TgxLibMaterials.Owner: TPersistent; begin Result := GetOwner; end; function TgxLibMaterials.Add: TgxLibMaterial; begin Result := (inherited Add) as TgxLibMaterial; end; function TgxLibMaterials.FindItemID(ID: Integer): TgxLibMaterial; begin Result := (inherited FindItemID(ID)) as TgxLibMaterial; end; function TgxLibMaterials.GetLibMaterialByName(const AName: TgxLibMaterialName): TgxLibMaterial; var LMaterial: TgxAbstractLibMaterial; begin LMaterial := GetMaterial(AName); if Assigned(LMaterial) and (LMaterial is TgxLibMaterial) then Result := TgxLibMaterial(LMaterial) else Result := nil; end; function TgxLibMaterials.GetTextureIndex(const Texture: TgxTexture): Integer; var i: Integer; begin if Count <> 0 then for i := 0 to Count - 1 do if GetItems(i).Material.Texture = Texture then begin Result := i; exit; end; Result := -1; end; function TgxLibMaterials.GetMaterialIndex(const Material: TgxMaterial): Integer; var i: Integer; begin if Count <> 0 then for i := 0 to Count - 1 do if GetItems(i).Material = Material then begin Result := i; exit; end; Result := -1; end; function TgxLibMaterials.GetNameOfTexture(const Texture: TgxTexture): TgxLibMaterialName; var MatIndex: Integer; begin MatIndex := GetTextureIndex(Texture); if MatIndex <> -1 then Result := GetItems(MatIndex).name else Result := ''; end; function TgxLibMaterials.GetNameOfLibMaterial(const Material: TgxLibMaterial): TgxLibMaterialName; var MatIndex: Integer; begin MatIndex := IndexOf(Material); if MatIndex <> -1 then Result := GetItems(MatIndex).name else Result := ''; end; function TgxLibMaterials.IndexOf(const Item: TgxLibMaterial): 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; procedure TgxLibMaterials.PrepareBuildList; var i: Integer; begin for i := 0 to Count - 1 do TgxLibMaterial(inherited Items[i]).PrepareBuildList; end; procedure TgxLibMaterials.DeleteUnusedMaterials; var i: Integer; gotNone: Boolean; begin BeginUpdate; repeat gotNone := True; for i := Count - 1 downto 0 do begin if TgxLibMaterial(inherited Items[i]).FUserList.Count = 0 then begin TgxLibMaterial(inherited Items[i]).Free; gotNone := False; end; end; until gotNone; EndUpdate; end; procedure TgxAbstractMaterialLibrary.SetTexturePaths(const val: string); var i, lp: Integer; procedure AddCurrent; var buf: string; begin buf := Trim(Copy(val, lp + 1, i - lp - 1)); if Length(buf) > 0 then begin // make sure '\' is the terminator buf := IncludeTrailingPathDelimiter(buf); FTexturePathList.Add(buf); end; end; begin FTexturePathList.Free; FTexturePathList := nil; FTexturePaths := val; if val <> '' then begin FTexturePathList := TStringList.Create; lp := 0; for i := 1 to Length(val) do begin if val[i] = ';' then begin AddCurrent; lp := i; end; end; i := Length(val) + 1; AddCurrent; end; end; function TgxAbstractMaterialLibrary.ApplyMaterial(const AName: string; var ARci: TgxRenderContextInfo): Boolean; begin FLastAppliedMaterial := FMaterials.GetMaterial(AName); Result := Assigned(FLastAppliedMaterial); if Result then FLastAppliedMaterial.Apply(ARci); end; function TgxAbstractMaterialLibrary.UnApplyMaterial(var ARci: TgxRenderContextInfo): Boolean; begin if Assigned(FLastAppliedMaterial) then begin Result := FLastAppliedMaterial.UnApply(ARci); if not Result then FLastAppliedMaterial := nil; end else Result := False; end; procedure TgxAbstractMaterialLibrary.SetNamesToTStrings(AStrings: TStrings); var i: Integer; lm: TgxAbstractLibMaterial; begin with AStrings do begin BeginUpdate; Clear; for i := 0 to FMaterials.Count - 1 do begin lm := TgxAbstractLibMaterial(FMaterials.Items[i]); AddObject(lm.name, lm); end; EndUpdate; end; end; procedure TgxAbstractMaterialLibrary.Loaded; begin inherited; FMaterials.Loaded; end; // ------------------ // ------------------ TgxMaterialLibrary ------------------ // ------------------ constructor TgxMaterialLibrary.Create(AOwner: TComponent); begin inherited; FMaterials := TgxLibMaterials.Create(Self); end; destructor TgxMaterialLibrary.Destroy; begin Assert(FLastAppliedMaterial = nil, 'Unbalanced material application'); FTexturePathList.Free; FMaterials.Free; FMaterials := nil; inherited; end; procedure TgxMaterialLibrary.DestroyHandles; begin if Assigned(FMaterials) then Materials.DestroyHandles; end; procedure TgxMaterialLibrary.SetMaterials(const val: TgxLibMaterials); begin FMaterials.Assign(val); end; function TgxMaterialLibrary.StoreMaterials: Boolean; begin Result := (FMaterials.Count > 0); end; procedure TgxMaterialLibrary.WriteToFiler(writer: TgxVirtualWriter); var i, j: Integer; libMat: TgxLibMaterial; tex: TgxTexture; img: TgxTextureImage; pim: TgxPersistentImage; ss: TStringStream; bmp: TBitmap; texExItem: TgxTextureExItem; begin with writer do begin WriteInteger(4); // archive version 0, texture persistence only // archive version 1, libmat properties // archive version 2, Material.TextureEx properties // archive version 3, Material.Texture properties // archive version 4, Material.TextureRotate WriteInteger(Materials.Count); for i := 0 to Materials.Count - 1 do begin // version 0 libMat := Materials[i]; WriteString(libMat.name); tex := libMat.Material.Texture; img := tex.Image; pim := TgxPersistentImage(img); if tex.Enabled and (img is TgxPersistentImage) and (pim.Picture.Bitmap <> nil) then begin WriteBoolean(True); ss := TStringStream.Create(''); try bmp := TBitmap.Create; try bmp.Assign(pim.Picture.Bitmap); bmp.SaveToStream(ss); finally bmp.Free; end; WriteString(ss.DataString); finally ss.Free; end; // version 3 with libMat.Material.Texture do begin Write(BorderColor.AsAddress^, SizeOf(Single) * 4); WriteInteger(Integer(Compression)); WriteInteger(Integer(DepthTextureMode)); Write(EnvColor.AsAddress^, SizeOf(Single) * 4); WriteInteger(Integer(FilteringQuality)); WriteInteger(Integer(ImageAlpha)); WriteFloat(ImageBrightness); WriteFloat(ImageGamma); WriteInteger(Integer(MagFilter)); WriteInteger(Integer(MappingMode)); Write(MappingSCoordinates.AsAddress^, SizeOf(Single) * 4); Write(MappingTCoordinates.AsAddress^, SizeOf(Single) * 4); Write(MappingRCoordinates.AsAddress^, SizeOf(Single) * 4); Write(MappingQCoordinates.AsAddress^, SizeOf(Single) * 4); WriteInteger(Integer(MinFilter)); WriteFloat(NormalMapScale); WriteInteger(Integer(TextureCompareFunc)); WriteInteger(Integer(TextureCompareMode)); WriteInteger(Integer(TextureFormat)); WriteInteger(Integer(TextureMode)); WriteInteger(Integer(TextureWrap)); WriteInteger(Integer(TextureWrapR)); WriteInteger(Integer(TextureWrapS)); WriteInteger(Integer(TextureWrapT)); end; // version 3 end end else WriteBoolean(False); with libMat.Material.FrontProperties do begin Write(Ambient.AsAddress^, SizeOf(Single) * 3); Write(Diffuse.AsAddress^, SizeOf(Single) * 4); Write(Emission.AsAddress^, SizeOf(Single) * 3); Write(Specular.AsAddress^, SizeOf(Single) * 3); end; // version 1 with libMat.Material.FrontProperties do begin Write(FShininess, 1); WriteInteger(Integer(libMat.Material.PolygonMode)); end; with libMat.Material.BackProperties do begin Write(Ambient.AsAddress^, SizeOf(Single) * 3); Write(Diffuse.AsAddress^, SizeOf(Single) * 4); Write(Emission.AsAddress^, SizeOf(Single) * 3); Write(Specular.AsAddress^, SizeOf(Single) * 3); Write(Byte(FShininess), 1); WriteInteger(Integer(libMat.Material.PolygonMode)); end; WriteInteger(Integer(libMat.Material.BlendingMode)); // version 3 with libMat.Material do begin if BlendingMode = bmCustom then begin WriteBoolean(True); with BlendingParams do begin WriteFloat(AlphaFuncRef); WriteInteger(Integer(AlphaFunctType)); WriteInteger(Integer(BlendFuncDFactor)); WriteInteger(Integer(BlendFuncSFactor)); WriteBoolean(UseAlphaFunc); WriteBoolean(UseBlendFunc); end; end else WriteBoolean(False); WriteInteger(Integer(FaceCulling)); end; // version 3 end WriteInteger(SizeOf(TgxMaterialOptions)); Write(libMat.Material.MaterialOptions, SizeOf(TgxMaterialOptions)); Write(libMat.TextureOffset.AsAddress^, SizeOf(Single) * 3); Write(libMat.TextureScale.AsAddress^, SizeOf(Single) * 3); WriteString(libMat.Texture2Name); // version 4 WriteFloat(libMat.TextureRotate); // version 2 WriteInteger(libMat.Material.TextureEx.Count); for j := 0 to libMat.Material.TextureEx.Count - 1 do begin texExItem := libMat.Material.TextureEx[j]; img := texExItem.Texture.Image; pim := TgxPersistentImage(img); if texExItem.Texture.Enabled and (img is TgxPersistentImage) and (pim.Picture.Bitmap <> nil) then begin WriteBoolean(True); ss := TStringStream.Create(''); try bmp := TBitmap.Create; try bmp.Assign(pim.Picture.Bitmap); bmp.SaveToStream(ss); finally bmp.Free; end; WriteString(ss.DataString); finally ss.Free; end; end else WriteBoolean(False); WriteInteger(texExItem.TextureIndex); Write(texExItem.TextureOffset.AsAddress^, SizeOf(Single) * 3); Write(texExItem.TextureScale.AsAddress^, SizeOf(Single) * 3); end; end; end; end; procedure TgxMaterialLibrary.ReadFromFiler(reader: TgxVirtualReader); var archiveVersion: Integer; libMat: TgxLibMaterial; i, n, size, tex, texCount: Integer; LName: string; ss: TStringStream; /// -> bmp: TBitmap; texExItem: TgxTextureExItem; begin archiveVersion := reader.ReadInteger; if (archiveVersion >= 0) and (archiveVersion <= 4) then with reader do begin if not FDoNotClearMaterialsOnLoad then Materials.Clear; n := ReadInteger; for i := 0 to n - 1 do begin // version 0 LName := ReadString; if FDoNotClearMaterialsOnLoad then libMat := LibMaterialByName(LName) else libMat := nil; if ReadBoolean then begin ss := TStringStream.Create(ReadString); try /// -> bmp := TBitmap.Create; try /// -> bmp.LoadFromStream(ss); if libMat = nil then { TODO : E2250 There is no overloaded version of 'AddTextureMaterial' that can be called with these arguments } (* libMat := AddTextureMaterial(LName, bmp) *) else /// -> libMat.Material.Texture.Image.Assign(bmp); finally /// -> bmp.Free; end; finally ss.Free; end; // version 3 if archiveVersion >= 3 then with libMat.Material.Texture do begin Read(BorderColor.AsAddress^, SizeOf(Single) * 4); Compression := TgxTextureCompression(ReadInteger); DepthTextureMode := TgxDepthTextureMode(ReadInteger); Read(EnvColor.AsAddress^, SizeOf(Single) * 4); FilteringQuality := TglTextureFilteringQuality(ReadInteger); ImageAlpha := TgxTextureImageAlpha(ReadInteger); ImageBrightness := ReadFloat; ImageGamma := ReadFloat; MagFilter := TgxMagFilter(ReadInteger); MappingMode := TgxTextureMappingMode(ReadInteger); Read(MappingSCoordinates.AsAddress^, SizeOf(Single) * 4); Read(MappingTCoordinates.AsAddress^, SizeOf(Single) * 4); Read(MappingRCoordinates.AsAddress^, SizeOf(Single) * 4); Read(MappingQCoordinates.AsAddress^, SizeOf(Single) * 4); MinFilter := TgxMinFilter(ReadInteger); NormalMapScale := ReadFloat; TextureCompareFunc := TgxDepthCompareFunc(ReadInteger); TextureCompareMode := TglTextureCompareMode(ReadInteger); TextureFormat := TgxTextureFormat(ReadInteger); TextureMode := TgxTextureMode(ReadInteger); TextureWrap := TgxTextureWrap(ReadInteger); TextureWrapR := TglSeparateTextureWrap(ReadInteger); TextureWrapS := TglSeparateTextureWrap(ReadInteger); TextureWrapT := TglSeparateTextureWrap(ReadInteger); end; // version 3 end end else begin if libMat = nil then begin libMat := Materials.Add; libMat.name := LName; end; end; with libMat.Material.FrontProperties do begin Read(Ambient.AsAddress^, SizeOf(Single) * 3); Read(Diffuse.AsAddress^, SizeOf(Single) * 4); Read(Emission.AsAddress^, SizeOf(Single) * 3); Read(Specular.AsAddress^, SizeOf(Single) * 3); end; // version 1 if archiveVersion >= 1 then begin with libMat.Material.FrontProperties do begin Read(FShininess, 1); libMat.Material.PolygonMode := TgxPolygonMode(ReadInteger); end; with libMat.Material.BackProperties do begin Read(Ambient.AsAddress^, SizeOf(Single) * 3); Read(Diffuse.AsAddress^, SizeOf(Single) * 4); Read(Emission.AsAddress^, SizeOf(Single) * 3); Read(Specular.AsAddress^, SizeOf(Single) * 3); Read(FShininess, 1); { PolygonMode := TPolygonMode( } ReadInteger; end; libMat.Material.BlendingMode := TgxBlendingMode(ReadInteger); // version 3 if archiveVersion >= 3 then begin if ReadBoolean then with libMat.Material.BlendingParams do begin AlphaFuncRef := ReadFloat; AlphaFunctType := TgxAlphaFunc(ReadInteger); BlendFuncDFactor := TgxBlendFunction(ReadInteger); BlendFuncSFactor := TgxBlendFunction(ReadInteger); UseAlphaFunc := ReadBoolean; UseBlendFunc := ReadBoolean; end; libMat.Material.FaceCulling := TgxFaceCulling(ReadInteger); end; // version 3 end size := ReadInteger; Read(libMat.Material.FMaterialOptions, size); Read(libMat.TextureOffset.AsAddress^, SizeOf(Single) * 3); Read(libMat.TextureScale.AsAddress^, SizeOf(Single) * 3); libMat.Texture2Name := ReadString; // version 4 if archiveVersion >= 4 then libMat.TextureRotate := ReadFloat; end; // version 2 if archiveVersion >= 2 then begin texCount := ReadInteger; for tex := 0 to texCount - 1 do begin texExItem := libMat.Material.TextureEx.Add; if ReadBoolean then begin ss := TStringStream.Create(ReadString); /// -> bmp := TBitmap.Create; try /// -> bmp.LoadFromStream(ss); /// -> texExItem.Texture.Image.Assign(bmp); texExItem.Texture.Enabled := True; finally /// -> bmp.Free; ss.Free; end; end; texExItem.TextureIndex := ReadInteger; Read(texExItem.TextureOffset.AsAddress^, SizeOf(Single) * 3); Read(texExItem.TextureScale.AsAddress^, SizeOf(Single) * 3); end; end; end; end else RaiseFilerException(Self.ClassType, archiveVersion); end; procedure TgxMaterialLibrary.SaveToStream(aStream: TStream); var wr: TgxBinaryWriter; begin wr := TgxBinaryWriter.Create(aStream); try Self.WriteToFiler(wr); finally wr.Free; end; end; procedure TgxMaterialLibrary.LoadFromStream(aStream: TStream); var rd: TgxBinaryReader; begin rd := TgxBinaryReader.Create(aStream); try Self.ReadFromFiler(rd); finally rd.Free; end; end; procedure TgxMaterialLibrary.AddMaterialsFromStream(aStream: TStream); begin FDoNotClearMaterialsOnLoad := True; try LoadFromStream(aStream); finally FDoNotClearMaterialsOnLoad := False; end; end; procedure TgxMaterialLibrary.SaveToFile(const fileName: string); var fs: TStream; begin fs := TFileStream.Create(fileName, fmCreate); try SaveToStream(fs); finally fs.Free; end; end; procedure TgxMaterialLibrary.LoadFromFile(const fileName: string); var fs: TStream; begin fs := TFileStream.Create(fileName, fmOpenRead + fmShareDenyNone); try LoadFromStream(fs); finally fs.Free; end; end; procedure TgxMaterialLibrary.AddMaterialsFromFile(const fileName: string); var fs: TStream; begin fs := TFileStream.Create(fileName, fmOpenRead + fmShareDenyNone); try AddMaterialsFromStream(fs); finally fs.Free; end; end; function TgxMaterialLibrary.AddTextureMaterial(const MaterialName, fileName: string; persistent: Boolean = True) : TgxLibMaterial; begin Result := Materials.Add; with Result do begin Name := MaterialName; with Material.Texture do begin MinFilter := miLinearMipmapLinear; MagFilter := maLinear; TextureMode := tmModulate; Disabled := False; if persistent then begin ImageClassName := TgxPersistentImage.ClassName; if fileName <> '' then Image.LoadFromFile(fileName); end else begin ImageClassName := TgxPicFileImage.ClassName; TgxPicFileImage(Image).PictureFileName := fileName; end; end; end; end; function TgxMaterialLibrary.AddTextureMaterial(const MaterialName: string; Graphic: TBitmap): TgxLibMaterial; begin Result := Materials.Add; with Result do begin Name := MaterialName; with Material.Texture do begin MinFilter := miLinearMipmapLinear; MagFilter := maLinear; TextureMode := tmModulate; Disabled := False; Image.Assign(Graphic); end; end; end; function TgxMaterialLibrary.LibMaterialByName(const AName: TgxLibMaterialName): TgxLibMaterial; begin if Assigned(Self) then Result := Materials.GetLibMaterialByName(AName) else Result := nil; end; function TgxMaterialLibrary.TextureByName(const LibMatName: TgxLibMaterialName): TgxTexture; var libMat: TgxLibMaterial; begin if Self = nil then raise ETexture.Create(strErrorEx + strMatLibNotDefined) else if LibMatName = '' then Result := nil else begin libMat := LibMaterialByName(LibMatName); if libMat = nil then raise ETexture.CreateFmt(strErrorEx + strMaterialNotFoundInMatlibEx, [LibMatName]) else Result := libMat.Material.Texture; end; end; function TgxMaterialLibrary.GetNameOfTexture(const Texture: TgxTexture): TgxLibMaterialName; begin if (Self = nil) or (Texture = nil) then Result := '' else Result := Materials.GetNameOfTexture(Texture); end; function TgxMaterialLibrary.GetMaterials: TgxLibMaterials; begin Result := TgxLibMaterials(FMaterials); end; function TgxMaterialLibrary.GetNameOfLibMaterial(const libMat: TgxLibMaterial): TgxLibMaterialName; begin if (Self = nil) or (libMat = nil) then Result := '' else Result := Materials.GetNameOfLibMaterial(libMat); end; { TgxBlendingParameters } procedure TgxBlendingParameters.Apply(var rci: TgxRenderContextInfo); begin if FUseAlphaFunc then begin rci.gxStates.Enable(stAlphaTest); rci.gxStates.SetAlphaFunction(FAlphaFuncType, FAlphaFuncRef); end else rci.gxStates.Disable(stAlphaTest); if FUseBlendFunc then begin rci.gxStates.Enable(stBlend); if FSeparateBlendFunc then rci.gxStates.SetBlendFuncSeparate(FBlendFuncSFactor, FBlendFuncDFactor, FAlphaBlendFuncSFactor, FAlphaBlendFuncDFactor) else rci.gxStates.SetBlendFunc(FBlendFuncSFactor, FBlendFuncDFactor); end else rci.gxStates.Disable(stBlend); end; constructor TgxBlendingParameters.Create(AOwner: TPersistent); begin inherited; FUseAlphaFunc := False; FAlphaFuncType := cfGreater; FAlphaFuncRef := 0; FUseBlendFunc := True; FSeparateBlendFunc := False; FBlendFuncSFactor := bfSrcAlpha; FBlendFuncDFactor := bfOneMinusSrcAlpha; FAlphaBlendFuncSFactor := bfSrcAlpha; FAlphaBlendFuncDFactor := bfOneMinusSrcAlpha; end; procedure TgxBlendingParameters.SetAlphaFuncRef(const Value: Single); begin if (FAlphaFuncRef <> Value) then begin FAlphaFuncRef := Value; NotifyChange(Self); end; end; procedure TgxBlendingParameters.SetAlphaFuncType(const Value: TgxAlphaFunc); begin if (FAlphaFuncType <> Value) then begin FAlphaFuncType := Value; NotifyChange(Self); end; end; procedure TgxBlendingParameters.SetBlendFuncDFactor(const Value: TgxBlendFunction); begin if (FBlendFuncDFactor <> Value) then begin FBlendFuncDFactor := Value; if not FSeparateBlendFunc then FAlphaBlendFuncDFactor := Value; NotifyChange(Self); end; end; procedure TgxBlendingParameters.SetBlendFuncSFactor(const Value: TgxBlendFunction); begin if (FBlendFuncSFactor <> Value) then begin FBlendFuncSFactor := Value; if not FSeparateBlendFunc then FAlphaBlendFuncSFactor := Value; NotifyChange(Self); end; end; procedure TgxBlendingParameters.SetAlphaBlendFuncDFactor(const Value: TgxBlendFunction); begin if FSeparateBlendFunc and (FAlphaBlendFuncDFactor <> Value) then begin FAlphaBlendFuncDFactor := Value; NotifyChange(Self); end; end; procedure TgxBlendingParameters.SetAlphaBlendFuncSFactor(const Value: TgxBlendFunction); begin if FSeparateBlendFunc and (FAlphaBlendFuncSFactor <> Value) then begin FAlphaBlendFuncSFactor := Value; NotifyChange(Self); end; end; procedure TgxBlendingParameters.SetUseAlphaFunc(const Value: Boolean); begin if (FUseAlphaFunc <> Value) then begin FUseAlphaFunc := Value; NotifyChange(Self); end; end; procedure TgxBlendingParameters.SetUseBlendFunc(const Value: Boolean); begin if (FUseBlendFunc <> Value) then begin FUseBlendFunc := Value; NotifyChange(Self); end; end; procedure TgxBlendingParameters.SetSeparateBlendFunc(const Value: Boolean); begin if (FSeparateBlendFunc <> Value) then begin FSeparateBlendFunc := Value; if not Value then begin FAlphaBlendFuncSFactor := FBlendFuncSFactor; FAlphaBlendFuncDFactor := FBlendFuncDFactor; end; NotifyChange(Self); end; end; function TgxBlendingParameters.StoreAlphaFuncRef: Boolean; begin Result := (Abs(AlphaFuncRef) > 0.001); end; initialization //-------------------------------------------------------------- RegisterClasses([TgxMaterialLibrary, TgxMaterial, TgxShader]); end.