OpenGLCore/uglcShader.pas

unit uglcShader;

{ Package:      OpenGLCore
  Prefix:       glc - OpenGL Core
  Beschreibung: diese Unit enthält eine Klassen-Kapselung der OpenGL Shader Objekte }

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, fgl, dglOpenGL, uglcTypes, ugluMatrix;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  EglcShader = class(Exception);
  TglcShaderProgram = class;
  TglcShaderLogEvent = procedure(aSender: TObject; const aMsg: String) of Object;
  TglcShaderObject = class(TObject)
  private
    fAtachedTo: TglcShaderProgram;
    fShaderObj: GLHandle;
    fShaderType: TglcShaderType;
    fCode: String;
    fOnLog: TglcShaderLogEvent;
    fAttachedTo: TglcShaderProgram;

    function GetInfoLog(aObj: GLHandle): String;
    function GetCompiled: Boolean;
    procedure Log(const aMsg: String);
    procedure CreateShaderObj;
    procedure AttachTo(const aProgram: TglcShaderProgram);
  public
    property ShaderObj : GLHandle           read fShaderObj;
    property ShaderType: TglcShaderType     read fShaderType;
    property Compiled:   Boolean            read GetCompiled;
    property AtachedTo:  TglcShaderProgram  read fAtachedTo;
    property Code:       String             read fCode  write fCode;
    property OnLog:      TglcShaderLogEvent read fOnLog write fOnLog;

    procedure Compile;

    constructor Create(const aShaderType: TglcShaderType; const aLogEvent: TglcShaderLogEvent = nil);
    destructor Destroy; override;
  end;
  TglcShaderObjectList = specialize TFPGObjectList<TglcShaderObject>;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TglcShaderProgram = class(TglcShaderObjectList)
  private
    fProgramObj: GLHandle;
    fOnLog: TglcShaderLogEvent;
    fFilename: String;
    fGeometryInputType: GLint;
    fGeometryOutputType: GLint;
    fGeometryVerticesOut: GLint;

    function GetUniformLocation(const aName: String; out aPos: glInt): Boolean;
    function GetInfoLog(Obj: GLHandle): String;
    function GetCompiled: Boolean;
    function GetLinked: Boolean;

    procedure CreateProgramObj;
    procedure Log(const msg: String);
    procedure AttachShaderObj(const aShaderObj: TglcShaderObject);
  public
    property ProgramObj: glHandle           read fProgramObj;
    property Filename:   String             read fFilename;
    property Compiled:   Boolean            read GetCompiled;
    property Linked:     Boolean            read GetLinked;
    property OnLog:      TglcShaderLogEvent read fOnLog               write fOnLog;
    property GeometryInputType:   GLint     read fGeometryInputType   write fGeometryInputType;
    property GeometryOutputType:  GLint     read fGeometryOutputType  write fGeometryOutputType;
    property GeometryVerticesOut: GLint     read fGeometryVerticesOut write fGeometryVerticesOut;

    procedure Compile;
    procedure Enable;
    procedure Disable;

    procedure Add(aShaderObj: TglcShaderObject);
    procedure Delete(aID: Integer; aFreeOwnedObj: Boolean = True);
    procedure Clear;

    function Uniform1f(const aName: String; aP1: GLFloat): Boolean;
    function Uniform2f(const aName: String; aP1, aP2: GLFloat): Boolean;
    function Uniform3f(const aName: String; aP1, aP2, aP3: GLFloat): Boolean;
    function Uniform4f(const aName: String; aP1, aP2, aP3, aP4: GLFloat): Boolean;
    function Uniform1i(const aName: String; aP1: GLint): Boolean;
    function Uniform2i(const aName: String; aP1, aP2: GLint): Boolean;
    function Uniform3i(const aName: String; aP1, aP2, aP3: GLint): Boolean;
    function Uniform4i(const aName: String; aP1, aP2, aP3, aP4: GLint): Boolean;
    function Uniform1fv(const aName: String; aCount: GLint; aP1: PGLFloat): Boolean;
    function Uniform2fv(const aName: String; aCount: GLint; aP1: PGLFloat): Boolean;
    function Uniform3fv(const aName: String; aCount: GLint; aP1: PGLFloat): Boolean;
    function Uniform4fv(const aName: String; aCount: GLint; aP1: PGLFloat): Boolean;
    function Uniform1iv(const aName: String; aCount: GLint; aP1: PGLInt): Boolean;
    function Uniform2iv(const aName: String; aCount: GLint; aP1: PGLInt): Boolean;
    function Uniform3iv(const aName: String; aCount: GLint; aP1: PGLInt): Boolean;
    function Uniform4iv(const aName: String; aCount: GLint; aP1: PGLInt): Boolean;
    function UniformMatrix2fv(const aName: String; aTranspose: Boolean; aCount: GLint; aP1: PgluMatrix2f): Boolean;
    function UniformMatrix3fv(const aName: String; aTranspose: Boolean; aCount: GLint; aP1: PgluMatrix3f): Boolean;
    function UniformMatrix4fv(const aName: String; aTranspose: Boolean; aCount: GLint; aP1: PgluMatrix4f): Boolean;

    function GetUniformfv(const aName: String; aP: PGLfloat): Boolean;
    function GetUniformfi(const aName: String; aP: PGLint): Boolean;
    function HasUniform(const aName: String): Boolean;

    procedure LoadFromFile(const aFilename: String);
    procedure LoadFromStream(const aStream: TStream);
    procedure SaveToFile(const aFilename: String);
    procedure SaveToStream(const aStream: TStream);

    constructor Create(aLogEvent: TglcShaderLogEvent = nil);
    destructor Destroy; override;
  end;

implementation

uses
  RegExpr;

const
  ERROR_STR_VAR_NAME: String = 'can''t find the variable ''%s'' in the program';

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//glShaderObject////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRI//
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//ließt das Log eines OpenGL-Objekts aus
//@Obj: Handle des Objekts, dessen Log ausgelesen werden soll;
//@result: Log des Objekts;
function TglcShaderObject.GetInfoLog(aObj: GLHandle): String;
var
  Msg: PChar;
  bLen, sLen: GLint;
begin
  bLen := 0;
  glGetShaderiv(aObj, GL_INFO_LOG_LENGTH, @bLen);
  if bLen > 1 then begin
    GetMem(Msg, bLen * SizeOf(Char));
    glGetShaderInfoLog(aObj, bLen, sLen{%H-}, Msg);
    result := PChar(Msg);
    Dispose(Msg);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//ließt aus, ob der Shader ohne Fehler kompiliert wurde
//@result: TRUE wenn ohne Fehler kompiliert, sonst FALSE;
function TglcShaderObject.GetCompiled: Boolean;
var
  value: glInt;
begin
  glGetShaderiv(fShaderObj, GL_COMPILE_STATUS, @value);
  result := (value = GL_TRUE);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//ruft das Log-Event auf, wenn es gesetzt ist
//@msg: Nachricht die geloggt werden soll;
procedure TglcShaderObject.Log(const aMsg: String);
begin
  if Assigned(fOnLog) then begin
    fOnLog(self, aMsg);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcShaderObject.CreateShaderObj;
begin
  if (fShaderObj <> 0) then
    exit;
  fShaderObj := glCreateShader(GLenum(fShaderType));
  if fShaderObj = 0 then
    raise EglcShader.Create('can''t create ShaderObject');
  Log('shader object created: #'+IntToHex(fShaderObj, 4));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcShaderObject.AttachTo(const aProgram: TglcShaderProgram);
begin
  if (aProgram <> fAtachedTo) then begin
    CreateShaderObj;
    glAttachShader(aProgram.ProgramObj, fShaderObj);
    fAttachedTo := aProgram;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBL//
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//kompiliert das Shader-Objekt
procedure TglcShaderObject.Compile;
var
  len, i: GLint;
  List: TStringList;
  c: PAnsiChar;
begin
  CreateShaderObj;
  len := Length(fCode);
  if len > 0 then begin
    c := PAnsiChar(fCode);
    glShaderSource(fShaderObj, 1, @c, @len);
    glCompileShader(fShaderObj);
    List := TStringList.Create;
    List.Text := GetInfoLog(fShaderObj);
    for i := 0 to List.Count-1 do
      Log(List[i]);
    List.Free;
  end else Log('error while compiling: no bound shader code');
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//erzeugt das Objekt
//@ShaderType: Typ des Shader-Objekts;
//@LogEvent: Event zum loggen von Fehlern und Ereignissen;
//@raise: EglcShader wenn der Shadertyp unbekannt oder ungültig ist;
constructor TglcShaderObject.Create(const aShaderType: TglcShaderType; const aLogEvent: TglcShaderLogEvent);
begin
  inherited Create;
  fCode       := '';
  fOnLog      := aLogEvent;
  fShaderType := aShaderType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//gibt das Objekt frei
destructor TglcShaderObject.Destroy;
begin
  if (fShaderObj <> 0) then
    glDeleteShader(fShaderObj);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//glShaderProgram///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRIVATE//PRI//
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcShaderProgram.GetUniformLocation(const aName: String; out aPos: glInt): Boolean;
begin
  aPos := glGetUniformLocation(fProgramObj, PChar(aName));
  result := (aPos <> -1);
  if not result then
    Log(StringReplace(ERROR_STR_VAR_NAME, '%s', aName, [rfIgnoreCase, rfReplaceAll]));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//ließt das Log eines OpenGL-Objekts aus
//@Obj: Handle des Objekts, dessen Log ausgelesen werden soll;
//@result: Log des Objekts;
function TglcShaderProgram.GetInfoLog(Obj: GLHandle): String;
var
  Msg: PChar;
  bLen, sLen: GLint;
begin
  bLen := 0;
  glGetProgramiv(Obj, GL_INFO_LOG_LENGTH, @bLen);
  if bLen > 1 then begin
    GetMem(Msg, bLen * SizeOf(Char));
    glGetProgramInfoLog(Obj, bLen, sLen{%H-}, Msg);
    result := PChar(Msg);
    Dispose(Msg);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//prüft ob alle Shader ohne Fehler compiliert wurden
//@result: TRUE wenn alle erfolgreich compiliert, sonst FALSE;
function TglcShaderProgram.GetCompiled: Boolean;
var
  i: Integer;
begin
  result := (Count > 0);
  for i := 0 to Count-1 do
    result := result and Items[i].Compiled;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//prüft ob das Programm ohne Fehler gelinkt wurde
//@result: TRUE wenn linken erfolgreich, sonst FASLE;
function TglcShaderProgram.GetLinked: Boolean;
var
  value: glInt;
begin
  glGetProgramiv(fProgramObj, GL_LINK_STATUS, @value);
  result := (value = GL_TRUE);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcShaderProgram.CreateProgramObj;
begin
  if (fProgramObj = 0) then begin
    if GL_LibHandle = nil then
      raise EglcShader.Create('TglShaderProgram.Create - OpenGL not initialized');

    if (wglGetCurrentContext() = 0) or (wglGetCurrentDC() = 0) then
      raise EglcShader.Create('TglShaderProgram.Create - no valid render context');

    fProgramObj := glCreateProgram();
    Log('shader program created: #'+IntToHex(fProgramObj, 4));
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//ruft das Log-Event auf, wenn es gesetzt ist
//@msg: Nachricht die geloggt werden soll;
procedure TglcShaderProgram.Log(const msg: String);
begin
  if Assigned(fOnLog) then begin
    fOnLog(self, msg);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcShaderProgram.AttachShaderObj(const aShaderObj: TglcShaderObject);
begin
  CreateProgramObj;
  aShaderObj.AttachTo(self);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBLIC//PUBL//
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//Kompiliert den Shader-Code
procedure TglcShaderProgram.Compile;
var
  i: Integer;
  l: TStringList;
begin
  CreateProgramObj;
  for i := 0 to Count-1 do begin
    AttachShaderObj(Items[i]);
    Items[i].Compile;
  end;
  glLinkProgram(fProgramObj);
  l := TStringList.Create;
  l.Text := GetInfoLog(fProgramObj);
  for i := 0 to l.Count-1 do
    Log(l[i]);
  l.Free;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//aktiviert den Shader
procedure TglcShaderProgram.Enable;
begin
  glUseProgram(fProgramObj);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//deaktiviert den Shader
procedure TglcShaderProgram.Disable;
begin
  glUseProgram(0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//fügt der Liste einen Shader hinzu
//@ShaderObj: Objekt, das hinzugefügt werden soll;
procedure TglcShaderProgram.Add(aShaderObj: TglcShaderObject);
begin
  inherited Add(aShaderObj);
  if (fProgramObj <> 0) then
    AttachShaderObj(aShaderObj);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//löscht ein ShaderObjekt aus der Liste
//@ID: Index des Objekts, das gelöscht werden soll;
//@FreeOwnedObj: wenn TRUE wird das gelöschte Objekt freigegeben;
procedure TglcShaderProgram.Delete(aID: Integer; aFreeOwnedObj: Boolean);
var
  b: Boolean;
begin
  if (aID >= 0) and (aID < Count) and (fProgramObj <> 0) then begin
    glDetachShader(fProgramObj, Items[aID].fShaderObj);
    Items[aID].fAttachedTo := nil;
  end;
  b := FreeObjects;
  FreeObjects := aFreeOwnedObj;
  inherited Delete(aID);
  FreeObjects := b;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcShaderProgram.Clear;
begin
  while (Count > 0) do
    Delete(0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen 1-Komponenten Float-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform1f(const aName: String; aP1: GLFloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform1f(pos, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen 2-Komponenten Float-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@p2: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform2f(const aName: String; aP1, aP2: GLFloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform2f(pos, aP1, aP2);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen 3-Komponenten Float-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@p2: Wert der Variable, der gesetzt werden soll;
//@p3: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform3f(const aName: String; aP1, aP2, aP3: GLFloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform3f(pos, aP1, aP2, aP3);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen 4-Komponenten Float-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@p2: Wert der Variable, der gesetzt werden soll;
//@p3: Wert der Variable, der gesetzt werden soll;
//@p4: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform4f(const aName: String; aP1, aP2, aP3, aP4: GLFloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform4f(pos, aP1, aP2, aP3, aP4);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen 1-Komponenten Integer-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform1i(const aName: String; aP1: GLint): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform1i(pos, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen 2-Komponenten Integer-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform2i(const aName: String; aP1, aP2: GLint): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform2i(pos, aP1, aP2);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen 3-Komponenten Integer-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@p2: Wert der Variable, der gesetzt werden soll;
//@p3: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform3i(const aName: String; aP1, aP2, aP3: GLint): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform3i(pos, aP1, aP2, aP3);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen 4-Komponenten Integer-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@p1: Wert der Variable, der gesetzt werden soll;
//@p2: Wert der Variable, der gesetzt werden soll;
//@p3: Wert der Variable, der gesetzt werden soll;
//@p4: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform4i(const aName: String; aP1, aP2, aP3, aP4: GLint): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform4i(pos, aP1, aP2, aP3, aP4);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen oder mehrere 1-Komponenten Float-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@count: Anzahl an Parametern auf die p1 zeigt;
//@p1: Zeiger auf den ersten Wert der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform1fv(const aName: String; aCount: GLint; aP1: PGLFloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform1fv(pos, aCount, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen oder mehrere 2-Komponenten Float-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@count: Anzahl an Parametern auf die p1 zeigt;
//@p1: Zeiger auf den ersten Wert der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform2fv(const aName: String; aCount: GLint; aP1: PGLFloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform2fv(pos, aCount, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen oder mehrere 3-Komponenten Float-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@count: Anzahl an Parametern auf die p1 zeigt;
//@p1: Zeiger auf den ersten Wert der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform3fv(const aName: String; aCount: GLint; aP1: PGLFloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform3fv(pos, aCount, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen oder mehrere 4-Komponenten Float-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@count: Anzahl an Parametern auf die p1 zeigt;
//@p1: Zeiger auf den ersten Wert der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform4fv(const aName: String; aCount: GLint; aP1: PGLFloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform4fv(pos, aCount, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen oder mehrere 1-Komponenten Integer-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@count: Anzahl an Parametern auf die p1 zeigt;
//@p1: Zeiger auf den ersten Wert der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform1iv(const aName: String; aCount: GLint; aP1: PGLInt): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform1iv(pos, aCount, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen oder mehrere 2-Komponenten Integer-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@count: Anzahl an Parametern auf die p1 zeigt;
//@p1: Zeiger auf den ersten Wert der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform2iv(const aName: String; aCount: GLint; aP1: PGLInt): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform2iv(pos, aCount, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen oder mehrere 3-Komponenten Integer-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@count: Anzahl an Parametern auf die p1 zeigt;
//@p1: Zeiger auf den ersten Wert der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform3iv(const aName: String; aCount: GLint; aP1: PGLInt): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform3iv(pos, aCount, aP1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt einen oder mehrere 4-Komponenten Integer-Vektoren an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@count: Anzahl an Parametern auf die p1 zeigt;
//@p1: Zeiger auf den ersten Wert der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.Uniform4iv(const aName: String; aCount: GLint; aP1: PGLInt): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniform4iv(pos, aCount, aP1) ;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt eine oder mehrere 2x2-Matrizen an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@Transpose: wenn TRUe wird die matrix vor der Übergabe transponiert;
//@Count: Anzahl der zu übergebenden Elemente;
//@p1: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.UniformMatrix2fv(const aName: String; aTranspose: Boolean; aCount: GLint; aP1: PgluMatrix2f): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniformMatrix2fv(pos, aCount, aTranspose, PGLfloat(aP1));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt eine oder mehrere 3x3-Matrizen an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@Transpose: wenn TRUe wird die matrix vor der Übergabe transponiert;
//@Count: Anzahl der zu übergebenden Elemente;
//@p1: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.UniformMatrix3fv(const aName: String; aTranspose: Boolean; aCount: GLint; aP1: PgluMatrix3f): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniformMatrix3fv(pos, aCount, aTranspose, PGLfloat(aP1));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//übergibt eine oder mehrere 4x4-Matrizen an den Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gesetzt werden soll;
//@Transpose: wenn TRUe wird die matrix vor der Übergabe transponiert;
//@Count: Anzahl der zu übergebenden Elemente;
//@p1: Wert der Variable, der gesetzt werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.UniformMatrix4fv(const aName: String; aTranspose: Boolean; aCount: GLint; aP1: PgluMatrix4f): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glUniformMatrix4fv(pos, aCount, aTranspose, PGLfloat(aP1));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//holt den Wert einer Float-Uniform-Variable aus dem Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gelesen werden soll;
//@p: Zeiger auf die Variable, in die der gelesene Wert geschrieben werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.GetUniformfv(const aName: String; aP: PGLfloat): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glGetUniformfv(fProgramObj, pos, aP);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//holt den Wert einer Integer-Uniform-Variable aus dem Shader
//!!!Der Shader muss dazu aktiviert sein!!!
//@Name: Name der Variablen die gelesen werden soll;
//@p: Zeiger auf die Variable, in die der gelesene Wert geschrieben werden soll;
//@result: TRUE wenn erfolgreich, sonst FALSE (Variablenname konnte nicht aufgelöst werden);
function TglcShaderProgram.GetUniformfi(const aName: String; aP: PGLint): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
  if result then
    glGetUniformiv(fProgramObj, pos, aP);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcShaderProgram.HasUniform(const aName: String): Boolean;
var
  pos: GLint;
begin
  result := GetUniformLocation(aName, pos);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//läd den Shader aus einer Datei
//@Filename: Datei aus der gelesen werden soll;
//@raise: EglcShader, wenn Datei nicht vorhanden ist;
procedure TglcShaderProgram.LoadFromFile(const aFilename: String);
var
  Stream: TFileStream;
begin
  if FileExists(aFilename) then begin
    Stream := TFileStream.Create(aFilename, fmOpenRead);
    try
      LoadFromStream(Stream);
      fFilename := aFilename;
    finally
      Stream.Free;
    end;
  end else raise EglcShader.Create('TglShaderProgram.LoadFromFile - file not found: '+Filename);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//läd den Shader aus einem Stream
//@Stream: Stream aus dem gelesen werden soll;
//@raise: EglcShader wenn kein Stream-Objekt übergeben wurde;
procedure TglcShaderProgram.LoadFromStream(const aStream: TStream);

  function GetShaderType(const aStr: String): TglcShaderType;
  begin
    if (aStr = 'GL_VERTEX_SHADER') then
      result := TglcShaderType.stVertex
    else if (aStr = 'GL_FRAGMENT_SHADER') then
      result := TglcShaderType.stFragment
    else if (aStr = 'GL_GEOMETRY_SHADER') then
      result := TglcShaderType.stGeometry
    else if (aStr = 'GL_TESS_CONTROL_SHADER') then
      result := TglcShaderType.stTessControl
    else if (aStr = 'GL_TESS_EVALUATION_SHADER') then
      result := TglcShaderType.stTessEvaluation
    else
      raise Exception.Create('invalid shader type: ' + aStr);
  end;

var
  sl: TStringList;
  s: String;
  rx: TRegExpr;
  LastMatchPos: PtrInt;
  st: TglcShaderType;
  o: TglcShaderObject;

  procedure AddObj(const aPos: Integer);
  begin
    if (LastMatchPos > 0) then begin
      o := TglcShaderObject.Create(st, fOnLog);
      o.Code := Trim(Copy(s, LastMatchPos, aPos - LastMatchPos));
      Add(o);
    end;
  end;

begin
  if not Assigned(aStream) then
    raise EglcShader.Create('TglShaderProgram.SaveToStream - stream is nil');

  Clear;
  sl := TStringList.Create;
  rx := TRegExpr.Create;
  try
    sl.LoadFromStream(aStream);
    s := sl.Text;
    LastMatchPos := 0;
    rx.Expression  := '/\*\s*ShaderObject\s*:\s*(GL_[A-Z_]+)\s*\*/\s*$?';
    rx.InputString := s;

    while rx.Exec(LastMatchPos+1) do begin
      AddObj(rx.MatchPos[0]);
      LastMatchPos := rx.MatchPos[0] + rx.MatchLen[0];
      st := GetShaderType(rx.Match[1]);
    end;
    AddObj(Length(s));
  finally
    rx.Free;
    sl.Free;
  end;


  {
  if Assigned(aStream) then begin
    Clear;
    fFilename := '';
    reader := TutlStreamReader.Create(aStream);
    try
      if reader.ReadAnsiString <> GLSL_FILE_HEADER then
        raise EglcShader.Create('TglShaderProgram.SaveToStream - incompatible file');
      v := reader.ReadInteger;

      if v >= 100 then begin //version 1.00
        c := reader.ReadInteger;
        for i := 0 to c-1 do begin
          Add(TglcShaderObject.Create(Cardinal(reader.ReadInteger), fOnLog));
          Last.fCode := reader.ReadAnsiString;
        end;
      end;
    finally
      reader.Free;
    end;
  end else
  }
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//speichert den Shader in einer Datei
//@Filename: Datei in die geschrieben werden soll;
procedure TglcShaderProgram.SaveToFile(const aFilename: String);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(aFilename, fmCreate);
  try
    SaveToStream(Stream);
    fFilename := aFilename;
  finally
    Stream.Free;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//speichert den Shader in einen Stream
//@Stream: Stream in den geschrieben werden soll;
//@raise: EglcShader wenn kein Stream-Objekt übergeben wurde;
//@raise: EglcShader wenn ungültige Datei;
procedure TglcShaderProgram.SaveToStream(const aStream: TStream);
var
  i: Integer;
  sl: TStringList;
  sObj: TglcShaderObject;

  function GetShaderTypeStr(const aShaderType: TglcShaderType): String;
  begin
    case aShaderType of
      TglcShaderType.stVertex:          result := 'GL_VERTEX_SHADER';
      TglcShaderType.stFragment:        result := 'GL_FRAGMENT_SHADER';
      TglcShaderType.stGeometry:        result := 'GL_GEOMETRY_SHADER';
      TglcShaderType.stTessControl:     result := 'GL_TESS_CONTROL_SHADER';
      TglcShaderType.stTessEvaluation:  result := 'GL_TESS_EVALUATION_SHADER';
    else
      result := 'UNKNOWN';
    end;
  end;

begin
  if not Assigned(aStream) then
    raise EglcShader.Create('TglShaderProgram.LoadFromStream - stream is nil');
  fFilename := '';
  sl := TStringList.Create;
  try
    for i := 0 to Count-1 do begin
      sObj := Items[i];
      sl.Add('/* ShaderObject: ' + GetShaderTypeStr(sObj.ShaderType) + ' */');
      sl.Add(sObj.Code);
    end;
    sl.SaveToStream(aStream);
  finally
    sl.Free;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//erzeugt das Objekt
//@LogEvent: Event zum loggen von Fehlern und Ereignissen;
//@raise: EglcShader wenn OpenGL nicht initialisiert werden konnte;
//@raise:
constructor TglcShaderProgram.Create(aLogEvent: TglcShaderLogEvent);
begin
  inherited Create;
  fOnLog      := aLogEvent;
  fFilename   := '';
  fProgramObj := 0;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//gibt das Objekt frei
destructor TglcShaderProgram.Destroy;
begin
  if (fProgramObj <> 0) then
    glDeleteProgram(fProgramObj);
  inherited Destroy;
end;

end.