// // The graphics engine GLScene // unit GLSL.CustomShader; (* A collection of pure abstract classes - descendants of TGLShader, which are used for purpose of not having to write the same stuff all over and over again in your own shader classes. It also contains a procedures and function that can be used in all shaders. The whole history is logged in a former GLS version of the unit. *) interface uses Winapi.OpenGL, Winapi.OpenGLext, System.Classes, System.SysUtils, Stage.VectorGeometry, Stage.VectorTypes, Stage.OpenGLTokens, Stage.TextureFormat, Stage.Strings, GLS.Texture, GLS.Cadencer, GLS.Scene, GLS.Context, GLS.RenderContextInfo, GLS.Material, GLS.VectorLists, GLSL.ShaderParameter; const glsShaderMaxLightSources = 8; type TGLShaderFogSupport = (sfsEnabled, sfsDisabled, sfsAuto); TGLTransformFeedBackMode = (tfbmInterleaved, tfbmSeparate); EGLCustomShaderException = class(EGLShaderException); TGLCustomShader = class; TGLVertexProgram = class; TGLFragmentProgram = class; TGLGeometryProgram = class; TGLShaderEvent = procedure(Shader: TGLCustomShader) of object; TGLShaderUnAplyEvent = procedure(Shader: TGLCustomShader; var ThereAreMorePasses: Boolean) of object; TGLLightSourceEnum = 1..glsShaderMaxLightSources; TGLLightSourceSet = set of TGLLightSourceEnum; (* This interface describes user shaders, in order to be able to access them via a unified interface. If user shader does not support some option, don't raise an axception, just ignore it. *) IGLShaderDescription = interface ['{04089C64-60C2-43F5-AC9C-38ED46264812}'] procedure SetShaderTextures(const Textures: array of TGLTexture); procedure GetShaderTextures(var Textures: array of TGLTexture); procedure SetShaderColorParams(const AAmbientColor, ADiffuseColor, ASpecularcolor: TVector4f); procedure GetShaderColorParams(var AAmbientColor, ADiffuseColor, ASpecularcolor: TVector4f); procedure SetShaderMiscParameters(const ACadencer: TGLCadencer; const AMatLib: TGLMaterialLibrary; const ALightSources: TGLLightSourceSet); procedure GetShaderMiscParameters(var ACadencer: TGLCadencer; var AMatLib: TGLMaterialLibrary; var ALightSources: TGLLightSourceSet); function GetShaderAlpha: Single; procedure SetShaderAlpha(const Value: Single); function GetShaderDescription: string; end; // Used in the TGLPostShaderHolder component. IGLPostShader = interface ['{68A62362-AF0A-4CE8-A9E1-714FE02AFA4A}'] // Called on every pass. procedure DoUseTempTexture(const TempTexture: TGLTextureHandle; TextureTarget: TGLTextureTarget); // Called to determine if it is compatible. function GetTextureTarget: TGLTextureTarget; end; // A pure abstract class, must be overriden. TGLCustomShader = class(TGLShader) private FFragmentProgram: TGLFragmentProgram; FVertexProgram: TGLVertexProgram; FGeometryProgram: TGLGeometryProgram; FTagObject: TObject; procedure SetFragmentProgram(const Value: TGLFragmentProgram); procedure SetGeometryProgram(const Value: TGLGeometryProgram); procedure SetVertexProgram(const Value: TGLVertexProgram); function StoreFragmentProgram: Boolean; function StoreGeometryProgram: Boolean; function StoreVertexProgram: Boolean; protected FDebugMode: Boolean; procedure SetDebugMode(const Value: Boolean); virtual; property FragmentProgram: TGLFragmentProgram read FFragmentProgram write SetFragmentProgram stored StoreFragmentProgram; property VertexProgram: TGLVertexProgram read FVertexProgram write SetVertexProgram stored StoreVertexProgram; property GeometryProgram: TGLGeometryProgram read FGeometryProgram write SetGeometryProgram stored StoreGeometryProgram; (* Treats warnings as errors and displays this error, instead of a general shader-not-supported message. *) property DebugMode: Boolean read FDebugMode write SetDebugMode default False; property TagObject: TObject read FTagObject write FTagObject default nil; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure LoadShaderPrograms(const VPFilename, FPFilename: string; const GPFilename: string = ''); end; // A custom shader program. TGLShaderProgram = class(TPersistent) private FParent: TGLCustomShader; FEnabled: Boolean; FCode: TStrings; procedure SetCode(const Value: TStrings); procedure SetEnabled(const Value: Boolean); procedure OnChangeCode(Sender: TObject); protected function GetOwner: TPersistent; override; public procedure LoadFromFile(const AFileName: string); procedure Apply; virtual; constructor Create(const AParent: TGLCustomShader); virtual; destructor Destroy; override; procedure Assign(Source: TPersistent); override; published property Code: TStrings read FCode write SetCode; property Enabled: Boolean read FEnabled write SetEnabled default False; end; TGLVertexProgram = class(TGLShaderProgram) published property Code; property Enabled; end; TGLFragmentProgram = class(TGLShaderProgram) published property Code; property Enabled; end; TGLGeometryProgram = class(TGLShaderProgram) private FInputPrimitiveType: TGLgsInTypes; FOutputPrimitiveType: TGLgsOutTypes; FVerticesOut: TGLint; procedure SetInputPrimitiveType(const Value: TGLgsInTypes); procedure SetOutputPrimitiveType(const Value: TGLgsOutTypes); procedure SetVerticesOut(const Value: TGLint); public constructor Create(const AParent: TGLCustomShader); override; published property Code; property Enabled; property InputPrimitiveType: TGLgsInTypes read FInputPrimitiveType write SetInputPrimitiveType default gsInPoints; property OutputPrimitiveType: TGLgsOutTypes read FOutputPrimitiveType write SetOutputPrimitiveType default gsOutPoints; property VerticesOut: TGLint read FVerticesOut write SetVerticesOut default 0; end; // Wrapper around a parameter of the main program. TGLCustomShaderParameter = class(TObject) private protected function GetAsVector1f: Single; virtual; abstract; function GetAsVector2f: TVector2f; virtual; abstract; function GetAsVector3f: TVector3f; virtual; abstract; function GetAsVector4f: TGLVector; virtual; abstract; function GetAsVector1i: Integer; virtual; abstract; function GetAsVector2i: TVector2i; virtual; abstract; function GetAsVector3i: TVector3i; virtual; abstract; function GetAsVector4i: TVector4i; virtual; abstract; function GetAsVector1ui: Cardinal; virtual; abstract; function GetAsVector2ui: TVector2ui; virtual; abstract; function GetAsVector3ui: TVector3ui; virtual; abstract; function GetAsVector4ui: TVector4ui; virtual; abstract; procedure SetAsVector1f(const Value: Single); virtual; abstract; procedure SetAsVector2f(const Value: TVector2f); virtual; abstract; procedure SetAsVector3f(const Value: TVector3f); virtual; abstract; procedure SetAsVector4f(const Value: TVector4f); virtual; abstract; procedure SetAsVector1i(const Value: Integer); virtual; abstract; procedure SetAsVector2i(const Value: TVector2i); virtual; abstract; procedure SetAsVector3i(const Value: TVector3i); virtual; abstract; procedure SetAsVector4i(const Value: TVector4i); virtual; abstract; procedure SetAsVector1ui(const Value: Cardinal); virtual; abstract; procedure SetAsVector2ui(const Value: TVector2ui); virtual; abstract; procedure SetAsVector3ui(const Value: TVector3ui); virtual; abstract; procedure SetAsVector4ui(const Value: TVector4ui); virtual; abstract; function GetAsMatrix2f: TMatrix2f; virtual; abstract; function GetAsMatrix3f: TMatrix3f; virtual; abstract; function GetAsMatrix4f: TMatrix4f; virtual; abstract; procedure SetAsMatrix2f(const Value: TMatrix2f); virtual; abstract; procedure SetAsMatrix3f(const Value: TMatrix3f); virtual; abstract; procedure SetAsMatrix4f(const Value: TMatrix4f); virtual; abstract; procedure SetAsTexture(const TextureIndex: Integer; const Value: TGLTexture); procedure SetAsTexture1D(const TextureIndex: Integer; const Value: TGLTexture); procedure SetAsTexture2D(const TextureIndex: Integer; const Value: TGLTexture); procedure SetAsTexture3D(const TextureIndex: Integer; const Value: TGLTexture); procedure SetAsTextureCube(const TextureIndex: Integer; const Value: TGLTexture); procedure SetAsTextureRect(const TextureIndex: Integer; const Value: TGLTexture); function GetAsCustomTexture(const TextureIndex: Integer; TextureTarget: TGLTextureTarget): Cardinal; virtual; abstract; procedure SetAsCustomTexture(const TextureIndex: Integer; TextureTarget: TGLTextureTarget; const Value: Cardinal); virtual; abstract; function GetAsUniformBuffer: Cardinal; virtual; abstract; procedure SetAsUniformBuffer(UBO: Cardinal); virtual; abstract; public (* This overloaded SetAsVector accepts open array as input. e.g. SetAsVectorF([0.1, 0.2]). Array length must between 1-4. *) procedure SetAsVectorF(const Values: array of Single); overload; procedure SetAsVectorI(const Values: array of Integer); overload; // SetToTextureOf determines texture type on-the-fly. procedure SetToTextureOf(const LibMaterial: TGLLibMaterial; const TextureIndex: Integer); overload; procedure SetToTextureOf(const Texture: TGLTexture; const TextureIndex: Integer); overload; // GLScene-friendly properties. property AsVector: TGLVector read GetAsVector4f write SetAsVector4f; property AsAffineVector: TAffineVector read GetAsVector3f write SetAsVector3f; // Standard types. property AsFloat: Single read GetAsVector1f write SetAsVector1f; property AsInteger: Integer read GetAsVector1i write SetAsVector1i; // Float vector types. property AsVector1f: Single read GetAsVector1f write SetAsVector1f; property AsVector2f: TVector2f read GetAsVector2f write SetAsVector2f; property AsVector3f: TVector3f read GetAsVector3f write SetAsVector3f; property AsVector4f: TVector4f read GetAsVector4f write SetAsVector4f; // Integer vector types. property AsVector1i: Integer read GetAsVector1i write SetAsVector1i; property AsVector2i: TVector2i read GetAsVector2i write SetAsVector2i; property AsVector3i: TVector3i read GetAsVector3i write SetAsVector3i; property AsVector4i: TVector4i read GetAsVector4i write SetAsVector4i; // Unsigned integer vector types. property AsVector1ui: Cardinal read GetAsVector1ui write SetAsVector1ui; property AsVector2ui: TVector2ui read GetAsVector2ui write SetAsVector2ui; property AsVector3ui: TVector3ui read GetAsVector3ui write SetAsVector3ui; property AsVector4ui: TVector4ui read GetAsVector4ui write SetAsVector4ui; // Matrix Types. property AsMatrix2f: TMatrix2f read GetAsMatrix2f write SetAsMatrix2f; property AsMatrix3f: TMatrix3f read GetAsMatrix3f write SetAsMatrix3f; property AsMatrix4f: TMatrix4f read GetAsMatrix4f write SetAsMatrix4f; // Texture Types. property AsTexture [const TextureIndex: Integer]: TGLTexture write SetAsTexture; property AsTexture1D [const TextureIndex: Integer]: TGLTexture write SetAsTexture1D; property AsTexture2D [const TextureIndex: Integer]: TGLTexture write SetAsTexture2D; property AsTexture3D [const TextureIndex: Integer]: TGLTexture write SetAsTexture3D; property AsTextureRect[const TextureIndex: Integer]: TGLTexture write SetAsTextureRect; property AsTextureCube[const TextureIndex: Integer]: TGLTexture write SetAsTextureCube; property AsCustomTexture[const TextureIndex: Integer; TextureTarget: TGLTextureTarget]: Cardinal read GetAsCustomTexture write SetAsCustomTexture; property AsUniformBuffer: Cardinal read GetAsUniformBuffer write SetAsUniformBuffer; end; (* Adds two more blending modes to standard ones. Not sure how to name them or if they should be included in TBlending mode, so I created a new type here. *) TGLBlendingModeEx = (bmxOpaque, bmxTransparency, bmxAdditive, bmxAlphaTest50, bmxAlphaTest100, bmxModulate, bmxDestColorOne, bmxDestAlphaOne); // Exported procedures. procedure ApplyBlendingModeEx(const BlendingMode: TGLBlendingModeEx); procedure UnApplyBlendingModeEx; procedure InitTexture( const TextureHandle: Cardinal; const TextureSize: TGLSize; const TextureTarget: TGLTextureTarget = ttTexture2D); // Probably need to give them proper names, instead of numbers... procedure DrawTexturedScreenQuad; procedure DrawTexturedScreenQuad2(const ViewPortSize: TGLSize); procedure DrawTexturedScreenQuad3; procedure DrawTexturedScreenQuad4(const ViewPortSize: TGLSize); procedure DrawTexturedScreenQuad5(const ViewPortSize: TGLSize); procedure DrawTexturedScreenQuad6(const ViewPortSize: TGLSize); procedure CopyScreentoTexture(const ViewPortSize: TGLSize; const TextureTarget: Word = GL_TEXTURE_2D); procedure CopyScreentoTexture2(const ViewPortSize: TGLSize; const TextureTarget: Word = GL_TEXTURE_2D); function IsFogEnabled(const AFogSupportMode: TGLShaderFogSupport; var rci: TGLRenderContextInfo): Boolean; procedure GetActiveLightsList(const ALightIDs: TGLIntegerList); //------------------------------------------ implementation //------------------------------------------ uses GLS.State; procedure GetActiveLightsList(const ALightIDs: TGLIntegerList); var I: Integer; begin ALightIDs.Clear; with CurrentGLContext.GLStates do begin for I := 0 to MaxLights - 1 do begin if LightEnabling[I] then ALightIDs.Add(I); end; end; end; function IsFogEnabled(const AFogSupportMode: TGLShaderFogSupport; var rci: TGLRenderContextInfo): Boolean; begin case AFogSupportMode of sfsEnabled: Result := True; sfsDisabled: Result := False; sfsAuto: Result := TGLSceneBuffer(rci.buffer).FogEnable; else Result := False; Assert(False, strUnknownType); end; end; procedure CopyScreentoTexture(const ViewPortSize: TGLSize; const TextureTarget: Word = GL_TEXTURE_2D); begin gl.CopyTexSubImage2D(TextureTarget, 0, 0, 0, 0, 0, ViewPortSize.cx, ViewPortSize.cy); end; procedure CopyScreentoTexture2(const ViewPortSize: TGLSize; const TextureTarget: Word = GL_TEXTURE_2D); begin gl.CopyTexImage2D(TextureTarget, 0, GL_RGB, 0, 0, ViewPortSize.cx, ViewPortSize.cy, 0); end; procedure ApplyBlendingModeEx(const BlendingMode: TGLBlendingModeEx); begin with CurrentGLContext.GLStates do begin Enable(stBlend); case BlendingMode of bmxOpaque: SetBlendFunc(bfSRCALPHA, bfONE); bmxTransparency: SetBlendFunc(bfSRCALPHA, bfONEMINUSSRCALPHA); bmxAdditive: SetBlendFunc(bfSRCALPHA, bfONE); bmxAlphaTest50: SetGLAlphaFunction(cfGEQUAL, 0.5); bmxAlphaTest100: SetGLAlphaFunction(cfGEQUAL, 1.0); bmxModulate: SetBlendFunc(bfDSTCOLOR, bfZERO); bmxDestColorOne: SetBlendFunc(bfDSTCOLOR, bfONE); bmxDestAlphaOne: SetBlendFunc(bfDSTALPHA, bfONE); else Assert(False, strErrorEx + strUnknownType); end; end; end; procedure UnApplyBlendingModeEx; begin end; procedure DrawTexturedScreenQuad; begin gl.MatrixMode(GL_MODELVIEW); gl.PushMatrix; gl.LoadIdentity; gl.MatrixMode(GL_PROJECTION); gl.PushMatrix; gl.LoadIdentity; // drawing rectangle over screen gl.Disable(GL_DEPTH_TEST); DrawTexturedScreenQuad3; gl.Enable(GL_DEPTH_TEST); gl.PopMatrix; gl.MatrixMode(GL_MODELVIEW); gl.PopMatrix; end; procedure DrawTexturedScreenQuad2(const ViewPortSize: TGLSize); begin gl.PushMatrix; gl.MatrixMode(GL_PROJECTION); gl.PushMatrix; gl.LoadIdentity; gl.Ortho(0, ViewPortSize.cx, ViewPortSize.cy, 0, 0, 1); gl.Disable(GL_DEPTH_TEST); gl.DepthMask(False); gl.Begin_(GL_QUADS); gl.TexCoord2f(0.0, ViewPortSize.cy); gl.Vertex2f(0, 0); gl.TexCoord2f(0.0, 0.0); gl.Vertex2f(0, ViewPortSize.cy); gl.TexCoord2f(ViewPortSize.cx, 0.0); gl.Vertex2f(ViewPortSize.cx, ViewPortSize.cy); gl.TexCoord2f(ViewPortSize.cx, ViewPortSize.cy); gl.Vertex2f(ViewPortSize.cx, 0); gl.End_; gl.DepthMask(True); gl.Enable(GL_DEPTH_TEST); gl.MatrixMode(GL_PROJECTION); gl.PopMatrix; gl.MatrixMode(GL_MODELVIEW); gl.PopMatrix; end; procedure DrawTexturedScreenQuad4(const ViewPortSize: TGLSize); begin gl.Begin_(GL_QUADS); gl.TexCoord2f(0, 0); gl.Vertex2f(-1, -1); gl.TexCoord2f(ViewPortSize.cx, 0); gl.Vertex2f( 1, -1); gl.TexCoord2f(ViewPortSize.cx, ViewPortSize.cy); gl.Vertex2f( 1, 1); gl.TexCoord2f(0, ViewPortSize.cy); gl.Vertex2f(-1, 1); gl.End_; end; procedure DrawTexturedScreenQuad5(const ViewPortSize: TGLSize); begin gl.MatrixMode( GL_PROJECTION ); gl.PushMatrix; gl.LoadIdentity; gl.Ortho( 0, ViewPortSize.cx, ViewPortSize.cy, 0, 0, 1 ); gl.MatrixMode(GL_MODELVIEW); gl.PushMatrix; gl.LoadIdentity; gl.Disable(GL_DEPTH_TEST); gl.DepthMask( FALSE ); DrawTexturedScreenQuad3; gl.DepthMask( TRUE ); gl.Enable(GL_DEPTH_TEST); gl.PopMatrix; gl.MatrixMode( GL_PROJECTION ); gl.PopMatrix; gl.MatrixMode( GL_MODELVIEW ); end; procedure DrawTexturedScreenQuad6(const ViewPortSize: TGLSize); begin gl.MatrixMode( GL_PROJECTION ); gl.PushMatrix; gl.LoadIdentity; gl.Ortho( 0, ViewPortSize.cx, ViewPortSize.cy, 0, 0, 1 ); gl.MatrixMode(GL_MODELVIEW); gl.PushMatrix; gl.LoadIdentity; gl.Disable(GL_DEPTH_TEST); gl.DepthMask( FALSE ); DrawTexturedScreenQuad4(ViewPortSize);; gl.DepthMask( TRUE ); gl.Enable(GL_DEPTH_TEST); gl.PopMatrix; gl.MatrixMode( GL_PROJECTION ); gl.PopMatrix; gl.MatrixMode( GL_MODELVIEW ); end; procedure DrawTexturedScreenQuad3; begin gl.Begin_(GL_QUADS); gl.TexCoord2f(0, 0); gl.Vertex2f(-1, -1); gl.TexCoord2f(1, 0); gl.Vertex2f(1, -1); gl.TexCoord2f(1, 1); gl.Vertex2f(1, 1); gl.TexCoord2f(0, 1); gl.Vertex2f(-1, 1); gl.End_; end; procedure InitTexture( const TextureHandle: Cardinal; const TextureSize: TGLSize; const TextureTarget: TGLTextureTarget = ttTexture2D); var glTarget: Cardinal; begin with CurrentGLContext.GLStates do begin TextureBinding[ActiveTexture, TextureTarget] := TextureHandle; end; glTarget := DecodeTextureTarget(TextureTarget); gl.TexParameteri(glTarget, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); gl.TexParameteri(glTarget, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); gl.TexParameteri(glTarget, GL_TEXTURE_MIN_FILTER, GL_LINEAR); gl.TexParameteri(glTarget, GL_TEXTURE_MAG_FILTER, GL_LINEAR); gl.CopyTexImage2D(glTarget, 0, GL_RGBA8, 0, 0, TextureSize.cx, TextureSize.cy, 0); end; //--------------------------------------------- // TGLShaderProgram //--------------------------------------------- procedure TGLShaderProgram.Apply; begin FParent.FinalizeShader; end; procedure TGLShaderProgram.Assign(Source: TPersistent); begin if Source = nil then Exit; if (Source is TGLShaderProgram) then begin FEnabled := TGLShaderProgram(Source).FEnabled; FCode.Assign(TGLShaderProgram(Source).FCode); end else inherited; //die, die, die!!! end; constructor TGLShaderProgram.Create(const AParent: TGLCustomShader); begin FParent := AParent; FCode := TStringList.Create; TStringList(FCode).OnChange := OnChangeCode; FEnabled := False; end; destructor TGLShaderProgram.Destroy; begin FCode.Destroy; end; function TGLShaderProgram.GetOwner: TPersistent; begin Result := FParent; end; procedure TGLShaderProgram.LoadFromFile(const AFileName: string); begin FCode.LoadFromFile(AFileName); FEnabled := True; end; procedure TGLShaderProgram.OnChangeCode(Sender: TObject); begin FEnabled := True; FParent.NotifyChange(self); end; procedure TGLShaderProgram.SetCode(const Value: TStrings); begin FCode.Assign(Value); FParent.NotifyChange(self); end; procedure TGLShaderProgram.SetEnabled(const Value: Boolean); begin if Value = FEnabled then Exit; FEnabled := Value; if FEnabled then FParent.FinalizeShader; end; //--------------------------------------------- // TGLCustomShader //--------------------------------------------- procedure TGLCustomShader.Assign(Source: TPersistent); begin if Source is TGLCustomShader then begin FFragmentProgram.Assign(TGLCustomShader(Source).FFragmentProgram); FVertexProgram.Assign(TGLCustomShader(Source).FVertexProgram); FGeometryProgram.Assign(TGLCustomShader(Source).FGeometryProgram); FTagObject := TGLCustomShader(Source).FTagObject; end; inherited; end; constructor TGLCustomShader.Create(AOwner: TComponent); begin inherited Create(AOwner); FDebugMode := False; FFragmentProgram := TGLFragmentProgram.Create(Self); FVertexProgram := TGLVertexProgram.Create(Self); FGeometryProgram := TGLGeometryProgram.Create(Self); end; destructor TGLCustomShader.Destroy; begin FFragmentProgram.Destroy; FVertexProgram.Destroy; FGeometryProgram.Destroy; inherited; end; procedure TGLCustomShader.LoadShaderPrograms(const VPFilename, FPFilename: string; const GPFilename: string = ''); begin If VPFilename <> '' then VertexProgram.LoadFromFile(VPFilename); If FPFilename <> '' then FragmentProgram.LoadFromFile(FPFilename); If GPFilename <> '' then GeometryProgram.LoadFromFile(GPFilename); end; procedure TGLCustomShader.SetDebugMode(const Value: Boolean); begin if FDebugMode <> Value then begin FDebugMode := Value; if FDebugMode then FailedInitAction := fiaReRaiseException else FailedInitAction := fiaRaiseStandardException; end; end; procedure TGLCustomShader.SetFragmentProgram(const Value: TGLFragmentProgram); begin FFragmentProgram.Assign(Value); end; procedure TGLCustomShader.SetGeometryProgram(const Value: TGLGeometryProgram); begin FGeometryProgram.Assign(Value); end; procedure TGLCustomShader.SetVertexProgram(const Value: TGLVertexProgram); begin FVertexProgram.Assign(Value); end; function TGLCustomShader.StoreFragmentProgram: Boolean; begin Result := FFragmentProgram.Enabled or (FFragmentProgram.Code.Text <> '') end; function TGLCustomShader.StoreGeometryProgram: Boolean; begin Result := FGeometryProgram.Enabled or (FGeometryProgram.Code.Text <> '') end; function TGLCustomShader.StoreVertexProgram: Boolean; begin Result := FVertexProgram.Enabled or (FVertexProgram.Code.Text <> '') end; //--------------------------------------------- // TGLCustomShaderParameter //--------------------------------------------- procedure TGLCustomShaderParameter.SetAsTexture( const TextureIndex: Integer; const Value: TGLTexture); begin SetAsCustomTexture(TextureIndex, Value.TextureHandle.Target, Value.Handle); end; procedure TGLCustomShaderParameter.SetAsTexture1D( const TextureIndex: Integer; const Value: TGLTexture); begin SetAsCustomTexture(TextureIndex, ttTexture1D, Value.Handle); end; procedure TGLCustomShaderParameter.SetAsTexture2D( const TextureIndex: Integer; const Value: TGLTexture); begin SetAsCustomTexture(TextureIndex, ttTexture2D, Value.Handle); end; procedure TGLCustomShaderParameter.SetAsTexture3D( const TextureIndex: Integer; const Value: TGLTexture); begin SetAsCustomTexture(TextureIndex, ttTexture3D, Value.Handle); end; procedure TGLCustomShaderParameter.SetAsTextureCube( const TextureIndex: Integer; const Value: TGLTexture); begin SetAsCustomTexture(TextureIndex, ttTextureCube, Value.Handle); end; procedure TGLCustomShaderParameter.SetAsTextureRect( const TextureIndex: Integer; const Value: TGLTexture); begin SetAsCustomTexture(TextureIndex, ttTextureRect, Value.Handle); end; procedure TGLCustomShaderParameter.SetAsVectorF(const Values: array of Single); begin case Length(Values) of 1: SetAsVector1f(Values[0]); 2: SetAsVector2f(Vector2fMake(Values[0], Values[1])); 3: SetAsVector3f(Vector3fMake(Values[0], Values[1], Values[2])); 4: SetAsVector4f(Vector4fMake(Values[0], Values[1], Values[2], Values[3])); else Assert(False, 'Vector length must be between 1 to 4'); end; end; procedure TGLCustomShaderParameter.SetAsVectorI(const Values: array of Integer); begin case Length(Values) of 1: SetAsVector1i(Values[0]); 2: SetAsVector2i(Vector2iMake(Values[0], Values[1])); 3: SetAsVector3i(Vector3iMake(Values[0], Values[1], Values[2])); 4: SetAsVector4i(Vector4iMake(Values[0], Values[1], Values[2], Values[3])); else Assert(False, 'Vector length must be between 1 to 4'); end; end; procedure TGLCustomShaderParameter.SetToTextureOf( const LibMaterial: TGLLibMaterial; const TextureIndex: Integer); begin SetToTextureOf(LibMaterial.Material.Texture, TextureIndex); end; procedure TGLCustomShaderParameter.SetToTextureOf( const Texture: TGLTexture; const TextureIndex: Integer); begin SetAsCustomTexture(TextureIndex, Texture.Image.NativeTextureTarget, Texture.Handle); end; constructor TGLGeometryProgram.Create(const AParent: TGLCustomShader); begin inherited Create(AParent); FInputPrimitiveType := gsInPoints; FOutputPrimitiveType := gsOutPoints; FVerticesOut := 0; end; procedure TGLGeometryProgram.SetInputPrimitiveType(const Value: TGLgsInTypes); begin if Value <> FInputPrimitiveType then begin FInputPrimitiveType := Value; FParent.NotifyChange(Self); end; end; procedure TGLGeometryProgram.SetOutputPrimitiveType(const Value: TGLgsOutTypes); begin if Value<>FOutputPrimitiveType then begin FOutputPrimitiveType := Value; FParent.NotifyChange(Self); end; end; procedure TGLGeometryProgram.SetVerticesOut(const Value: TGLint); begin if Value<>FVerticesOut then begin FVerticesOut := Value; FParent.NotifyChange(Self); end; end; //--------------------------------------------- initialization //--------------------------------------------- RegisterClasses([TGLCustomShader, TGLShaderProgram, TGLVertexProgram, TGLFragmentProgram, TGLGeometryProgram]); end.