unit ShaderObjects;

interface

uses Windows, SysUtils, Classes, Math3D, GL, GLu, GLext, WGLext, GLtools;

type
  TShaderObject = class
  protected
    FShader             : GLhandleARB;
    FCompiled           : boolean;
    FLog                : PGLcharARB;
    FSource             : TStringList;
  public
    constructor Create(shaderType: GLenum); virtual;
    destructor Destroy; override;
    procedure Source(count: GLsizei; strings: PChar); virtual;
    procedure Load(filename: string); virtual;
    procedure Save(filename: string); virtual;
    procedure Compile; virtual;
    property ShaderObject: GLhandleARB read FShader;
    property Compiled: boolean read FCompiled;
    property Log: PGLcharARB read FLog;
  end;

  TProgramObject = class;

  TUniformObject = class
  protected
    FProgramObject      : TProgramObject;
    FUniformLocation    : GLint;
    procedure SetValue1f(val: single);
    procedure SetValue2f(val: TVector2);
    procedure SetValue3f(val: TVector3);
    procedure SetValue4f(val: TVector4);
    procedure SetValue16f(val: TMatrix4x4);
    procedure SetValue1i(val: longint);
  public
    constructor Create(programObj: TProgramObject; const name: PChar); virtual;
    destructor Destroy; override;
    property UniformLocation: GLint read FUniformLocation;
    property Value1f: single write SetValue1f;
    property Value2f: TVector2 write SetValue2f;
    property Value3f: TVector3 write SetValue3f;
    property Value4f: TVector4 write SetValue4f;
    property Value16f: TMatrix4x4 write SetValue16f;
    property Value1i: longint write SetValue1i;
  end;

  TProgramObject = class
  protected
    FProgram            : GLhandleARB;
    FLinked             : boolean;
    FLog                : PGLcharARB;
    procedure SetIntParam(loc: longint; value: longint); virtual;
    function GetIntParam(loc: longint): longint; virtual;
    procedure SetFloatParam(loc: longint; value: single); virtual;
    function GetFloatParam(loc: longint): single; virtual;
    procedure SetVector2Param(loc: longint; value: TVector2); virtual;
    function GetVector2Param(loc: longint): TVector2; virtual;
    procedure SetVector3Param(loc: longint; value: TVector3); virtual;
    function GetVector3Param(loc: longint): TVector3; virtual;
    procedure SetVector4Param(loc: longint; value: TVector4); virtual;
    function GetVector4Param(loc: longint): TVector4; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Attach(shader: TShaderObject); virtual;
    procedure Detach(shader: TShaderObject); virtual;
    procedure Link; virtual;
    procedure Enable; virtual;
    procedure Disable; virtual;
    procedure Validate; virtual;
    function GetUniformLocation(const name: PChar): GLint; virtual;
    function GetUniformObject(const name: PChar): TUniformObject; virtual;
    property ProgramObject: GLhandleARB read FProgram;
    property Linked: boolean read FLinked;
    property Log: PGLcharARB read FLog;
    property IntParam[i: longint]: longint read GetIntParam write SetIntParam;
    property FloatParam[i: longint]: single read GetFloatParam write SetFloatParam;
    property Vector2Param[i: longint]: TVector2 read GetVector2Param write SetVector2Param;
    property Vector3Param[i: longint]: TVector3 read GetVector3Param write SetVector3Param;
    property Vector4Param[i: longint]: TVector4 read GetVector4Param write SetVector4Param;
  end;

implementation

constructor TShaderObject.Create;
begin
  if not Load_GL_ARB_shader_objects then
    raise Exception.Create('GL_ARB_shader_objects required!');

  inherited Create;

  FSource               := TStringList.Create;
  FShader               := glCreateShaderObjectARB(shaderType);
  FCompiled             := false;
  GetMem(FLog, 1000);
end;

destructor TShaderObject.Destroy;
begin
  glDeleteObjectARB(FShader);
  FSource.Free;
  FreeMem(FLog, 1000);

  inherited Destroy;
end;

procedure TShaderObject.Source;
begin
  glShaderSourceARB(FShader, count, PGLcharARB(@strings), nil);
  FCompiled := false;
end;

procedure TShaderObject.Load;
var
  p: PGLcharARB;
begin
  FSource.LoadFromFile(filename);
  p := PGLcharARB(FSource.Text);
  glShaderSourceARB(FShader, 1, @p, nil);
  FCompiled := false;
end;

procedure TShaderObject.Save;
begin
  FSource.SaveToFile(filename);
end;

procedure TShaderObject.Compile;
var
  ok: longint;
begin
  glCompileShaderARB(FShader);
  glGetInfoLogARB(FShader, 1000, nil, FLog);
  glGetObjectParameterivARB(FShader, GL_OBJECT_COMPILE_STATUS_ARB, @ok);
  FCompiled := (ok <> 0);
end;

constructor TUniformObject.Create(programObj: TProgramObject; const name: PAnsiChar);
begin
  inherited Create;

  FProgramObject := programObj;
  FUniformLocation := programObj.GetUniformLocation(name);
end;

destructor TUniformObject.Destroy;
begin
  inherited Destroy;
end;

procedure TUniformObject.SetValue1f(val: Single);
begin
  glUniform1fARB(FUniformLocation, val);
end;

procedure TUniformObject.SetValue2f(val: TVector2);
begin
  glUniform2fARB(FUniformLocation, val.x, val.y);
end;

procedure TUniformObject.SetValue3f(val: TVector3);
begin
  glUniform3fARB(FUniformLocation, val.x, val.y, val.z);
end;

procedure TUniformObject.SetValue4f(val: TVector4);
begin
  glUniform4fARB(FUniformLocation, val.x, val.y, val.z, val.w);
end;

procedure TUniformObject.SetValue16f(val: TMatrix4x4);
begin
  glUniformMatrix4fvARB(FUniformLocation, 16, GL_TRUE, @val);
end;

procedure TUniformObject.SetValue1i(val: longint);
begin
  glUniform1iARB(FUniformLocation, val);
end;

constructor TProgramObject.Create;
begin
  if not Load_GL_ARB_shader_objects then
    raise Exception.Create('GL_ARB_shader_objects required!');

  inherited Create;

  FProgram              := glCreateProgramObjectARB;
  FLinked               := false;
  GetMem(FLog, 1000);
end;

destructor TProgramObject.Destroy;
begin
  glDeleteObjectARB(FProgram);
  FreeMem(FLog, 1000);

  inherited Destroy;
end;

procedure TProgramObject.Attach;
begin
  if not shader.Compiled then shader.Compile;
  glAttachObjectARB(FProgram, shader.ShaderObject);
  FLinked := false;
end;

procedure TProgramObject.Detach;
begin
  glDetachObjectARB(FProgram, shader.ShaderObject);
  FLinked := false;
end;

procedure TProgramObject.Link;
var
  ok: longint;
begin
  glLinkProgramARB(FProgram);
  glGetInfoLogARB(FProgram, 1000, nil, FLog);
  glGetObjectParameterivARB(FProgram, GL_OBJECT_LINK_STATUS_ARB, @ok);
  FLinked := (ok <> 0);
end;

procedure TProgramObject.Enable;
begin
  if not FLinked then Link;
  glUseProgramObjectARB(FProgram);
end;

procedure TProgramObject.Disable;
begin
  glUseProgramObjectARB(0);
end;

procedure TProgramObject.Validate;
begin
  glValidateProgramARB(FProgram);
end;

function TProgramObject.GetUniformLocation;
begin
  result := glGetUniformLocationARB(FProgram, PGLcharARB(name));
end;

function TProgramObject.GetUniformObject(const name: PAnsiChar): TUniformObject;
begin
  result := TUniformObject.Create(Self, name);
end;

procedure TProgramObject.SetIntParam;
begin
  glUniform1iARB(loc, value);
end;

function TProgramObject.GetIntParam;
begin
  glGetUniformivARB(FProgram, loc, @result);
end;

procedure TProgramObject.SetFloatParam;
begin
  glUniform1fARB(loc, value);
end;

function TProgramObject.GetFloatParam;
begin
  glGetUniformfvARB(FProgram, loc, @result);
end;

procedure TProgramObject.SetVector2Param;
begin
  glUniform2fvARB(loc, 1, @value);
end;

function TProgramObject.GetVector2Param;
begin
  glGetUniformfvARB(FProgram, loc, @result);
end;

procedure TProgramObject.SetVector3Param;
begin
  glUniform3fvARB(loc, 1, @value);
end;

function TProgramObject.GetVector3Param;
begin
  glGetUniformfvARB(FProgram, loc, @result);
end;

procedure TProgramObject.SetVector4Param;
begin
  glUniform4fvARB(loc, 1, @value);
end;

function TProgramObject.GetVector4Param;
begin
  glGetUniformfvARB(FProgram, loc, @result);
end;

end.
