Browse Source

* Initial Commit

master
Bergmann89 9 years ago
commit
4e1207880c
9 changed files with 4549 additions and 0 deletions
  1. +105
    -0
      uglcArrayBuffer.pas
  2. +254
    -0
      uglcCamera.pas
  3. +622
    -0
      uglcFrameBufferObject.pas
  4. +424
    -0
      uglcLight.pas
  5. +931
    -0
      uglcShader.pas
  6. +318
    -0
      uglcTypes.pas
  7. +318
    -0
      ugluMatrix.pas
  8. +384
    -0
      ugluQuaternion.pas
  9. +1193
    -0
      ugluVector.pas

+ 105
- 0
uglcArrayBuffer.pas View File

@@ -0,0 +1,105 @@
unit uglcArrayBuffer;

{ Package: OpenGLCore
Prefix: glc - OpenGL Core
Beschreibung: diese Unit enthält eine Klassen-Kapselung für OpenGL Array Buffer }

{$mode objfpc}{$H+}

interface

uses
dglOpenGL, sysutils, uglcTypes;

type
EglcArrayBuffer = class(Exception);
TglcArrayBuffer = class(TObject)
private
fID: GLuint;
fTarget: TglcBufferTarget;
fUsage: TglcBufferUsage;
protected
fDataCount: Integer;
fDataSize: Integer;
public
property ID: gluInt read fID;
property Target: TglcBufferTarget read fTarget;
property Usage: TglcBufferUsage read fUsage;
property DataCount: Integer read fDataCount;
property DataSize: Integer read fDataSize;

procedure BufferData(const aDataCount, aDataSize: Cardinal; const aUsage: TglcBufferUsage; const aData: Pointer);
function MapBuffer(const aAccess: TglcBufferAccess): Pointer;
procedure UnmapBuffer;
procedure Bind;
procedure Unbind;
constructor Create(const aTarget: TglcBufferTarget);
destructor Destroy; override;
end;

implementation

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcArrayBuffer///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////[c]
procedure TglcArrayBuffer.BufferData(const aDataCount, aDataSize: Cardinal; const aUsage: TglcBufferUsage; const aData: Pointer);
begin
glGetError(); //clear Errors
Bind;
fDataCount := aDataCount;
fDataSize := aDataSize;
fUsage := aUsage;
glBufferData(GLenum(fTarget), fDataCount * fDataSize, aData, GLenum(fUsage));
glcCheckAndRaiseError;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////[c]
function TglcArrayBuffer.MapBuffer(const aAccess: TglcBufferAccess): Pointer;
begin
glGetError();
result := nil;
if (fDataCount * fDataSize) <= 0 then
exit;
result := glMapBuffer(GLenum(fTarget), GLenum(aAccess));
glcCheckAndRaiseError;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////[c]
procedure TglcArrayBuffer.UnmapBuffer;
begin
glUnmapBuffer(GLenum(fTarget));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////[c]
procedure TglcArrayBuffer.Bind;
begin
glBindBuffer(GLenum(fTarget), fID);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////[c]
procedure TglcArrayBuffer.Unbind;
begin
glBindBuffer(GLenum(fTarget), 0);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////[c]
constructor TglcArrayBuffer.Create(const aTarget: TglcBufferTarget);
begin
if not GL_ARB_Vertex_Buffer_Object then
raise EglcArrayBuffer.Create('Create - VertexBuffer: not supported');
inherited Create;
glGenBuffers(1, @fID);
fDataCount := 0;
fDataSize := 0;
fTarget := aTarget;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////[c]
destructor TglcArrayBuffer.Destroy;
begin
glDeleteBuffers(1, @fID);
inherited Destroy;
end;

end.


+ 254
- 0
uglcCamera.pas View File

@@ -0,0 +1,254 @@
unit uglcCamera;

{ Package: OpenGLCore
Prefix: glc - OpenGL Core
Beschreibung: diese Unit enthält eine Klassen-Kapselung für OpenGL Frustum und Kamera }

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils,
ugluVector, ugluMatrix;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TglcFrustum = class(TObject)
private
function GetWidth: Single;
function GetHeight: Single;
function GetFOVAngle: Single;
function GetAspectRatio: Single;
protected
fIsOrthogonal: Boolean;
fTop, fBottom, fLeft, fRight, fNear, fFar: Single;
public
property Top : Single read fTop;
property Bottom : Single read fBottom;
property Left : Single read fLeft;
property Right : Single read fRight;
property Near : Single read fNear;
property Far : Single read fFar;
property Width : Single read GetWidth;
property Height : Single read GetHeight;
property FOVAngle : Single read GetFOVAngle;
property AspectRatio : Single read GetAspectRatio;
property IsOrthogonal: Boolean read fIsOrthogonal;

procedure Frustum(const aLeft, aRight, aBottom, aTop, aNear, aFar: Single);
procedure Perspective(const aFOVAngle, aAspectRatio, aNear, aFar: Single);
procedure Ortho(const aLeft, aRight, aBottom, aTop, aNear, aFar: Single);
procedure Activate;
procedure Render;

constructor Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TglcCamera = class(TglcFrustum)
private
fPosition: TgluMatrix4f;
public
property Position: TgluMatrix4f read fPosition write fPosition;

procedure Move(const aVec: TgluVector3f);
procedure Tilt(const aAngle: Single);
procedure Turn(const aAngle: Single);
procedure Roll(const aAngle: Single);
procedure Activate;
function GetRay(const aPos: TgluVector2f): TgluRayf;

constructor Create;
end;

implementation

uses
Math, dglOpenGL;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcFrustum///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrustum.GetWidth: Single;
begin
result := (fRight - fLeft);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrustum.GetHeight: Single;
begin
result := (fTop - fBottom);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrustum.GetFOVAngle: Single;
begin
result := arctan2(Height/2, fNear)/Pi*360;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrustum.GetAspectRatio: Single;
begin
result := Height / Width;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrustum.Frustum(const aLeft, aRight, aBottom, aTop, aNear, aFar: Single);
begin
fIsOrthogonal := false;
fTop := aRight;
fBottom := aLeft;
fLeft := aBottom;
fRight := aTop;
fNear := aNear;
fFar := aFar;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrustum.Perspective(const aFOVAngle, aAspectRatio, aNear, aFar: Single);
begin
fIsOrthogonal := false;
fNear := aNear;
fFar := aFar;
fTop := fNear * tan(aFOVAngle / 360 * Pi);
fBottom := -fTop;
fRight := aAspectRatio * fTop;
fLeft := -fRight;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrustum.Ortho(const aLeft, aRight, aBottom, aTop, aNear, aFar: Single);
begin
fIsOrthogonal := true;
fLeft := aLeft;
fRight := aRight;
fTop := aTop;
fBottom := aBottom;
fNear := aNear;
fFar := aFar;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrustum.Activate;
begin
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
if fIsOrthogonal then
glOrtho(fLeft, fRight, fBottom, fTop, fNear, fFar)
else
glFrustum(fLeft, fRight, fBottom, fTop, fNear, fFar);
glMatrixMode(GL_MODELVIEW);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrustum.Render;
var
min, max: TgluVector2f;
begin
min[0] := fLeft / fNear * fFar;
min[1] := fBottom / fNear * fFar;
max[0] := fRight / fNear * fFar;
max[1] := fTop / fNear * fFar;

glBegin(GL_LINE_LOOP);
glVertex3f(fLeft, fTop, -fNear);
glVertex3f(fLeft, fBottom, -fNear);
glVertex3f(fRight, fBottom, -fNear);
glVertex3f(fRight, fTop, -fNear);
glEnd;

glBegin(GL_LINE_LOOP);
glVertex3f(min[0], min[0], -fFar);
glVertex3f(min[0], max[0], -fFar);
glVertex3f(max[0], max[0], -fFar);
glVertex3f(max[0], min[0], -fFar);
glEnd;

glBegin(GL_LINES);
glVertex3f(0, 0, 0); glVertex3f(min[0], min[0], -fFar);
glVertex3f(0, 0, 0); glVertex3f(min[0], max[0], -fFar);
glVertex3f(0, 0, 0); glVertex3f(max[0], max[0], -fFar);
glVertex3f(0, 0, 0); glVertex3f(max[0], min[0], -fFar);
glEnd;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TglcFrustum.Create;
begin
inherited Create;
fTop := 0;
fBottom := 0;
fLeft := 0;
fRight := 0;
fNear := 0;
fFar := 0;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcCamera////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcCamera.Move(const aVec: TgluVector3f);
begin
fPosition := gluMatrixMult(gluMatrixTranslate(aVec), fPosition);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcCamera.Tilt(const aAngle: Single);
begin
fPosition := gluMatrixMult(gluMatrixRotate(gluVector3f(1,0,0), aAngle), fPosition);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcCamera.Turn(const aAngle: Single);
begin
fPosition := gluMatrixMult(gluMatrixRotate(gluVector3f(0,1,0), aAngle), fPosition);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcCamera.Roll(const aAngle: Single);
begin
fPosition := gluMatrixMult(gluMatrixRotate(gluVector3f(0,0,1), aAngle), fPosition);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcCamera.Activate;
begin
inherited Activate;
glLoadMatrixf(@fPosition[0, 0]);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcCamera.GetRay(const aPos: TgluVector2f): TgluRayf;
var
p: TgluVector3f;
begin
if (aPos[0] < 0) then
p[0] := -aPos[0] * fLeft
else
p[0] := aPos[0] * fRight;
if (aPos[1] < 0) then
p[1] := -aPos[1] * fBottom
else
p[1] := aPos[1] * fTop;
if (fIsOrthogonal) then begin
p[2] := 0;
result.p := fPosition * p;
result.v := fPosition * gluVector3f(0, 0, -1);
end else begin
p[2] := -fNear;
result.p := gluVector3f(0, 0, 0);
result.v := fPosition * p;
end;
result := gluRayNormalize(result);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TglcCamera.Create;
begin
inherited Create;
fPosition := gluMatrixIdentity;
end;

end.


+ 622
- 0
uglcFrameBufferObject.pas View File

@@ -0,0 +1,622 @@
unit uglcFrameBufferObject;

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

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, fgl, dglOpenGl, uglcTypes;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TglcBufferType = (btRenderBuffer, btTextureBuffer);
TglcBuffer = class(TObject)
private
fBufferType: TglcBufferType;
fWidth: Integer;
fHeight: Integer;

procedure SetWidth(const aValue: Integer);
procedure SetHeight(const aValue: Integer);
public
property Width : Integer read fWidth write SetWidth;
property Height: Integer read fHeight write SetHeight;
property BufferType: TglcBufferType read fBufferType;

procedure SetSize(const aWidth, aHeight: Integer); virtual;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
EglcRenderBuffer = class(Exception);
TglcRenderBuffer = class(TglcBuffer)
private
fID: gluInt;
fFormat: TglcInternalFormat;

procedure UpdateRenderBufferStorage;
procedure SetFormat(const aValue: TglcInternalFormat);
public
property ID: gluInt read fID;
property Format: TglcInternalFormat read fFormat write SetFormat;

procedure SetSize(const aWidth, aHeight: Integer); override;
procedure Bind;
procedure Unbind;

constructor Create(const aFormat: TglcInternalFormat);
destructor Destroy; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
EglcTextureBuffer = class(exception);
TglcTextureBuffer = class(TglcBuffer)
private
fID: GLuint;
fFormat: TglcFormat;
fInternalFormat: TglcInternalFormat;
fBorder: Boolean;

procedure UpdateTexImage;
procedure SetFormat(const aValue: TglcFormat);
procedure SetInternalFormat(const aValue: TglcInternalFormat);
procedure SetBorder(const aValue: Boolean);
public
property ID : GLuint read fID;
property Border : Boolean read fBorder write SetBorder;
property Format : TglcFormat read fFormat write SetFormat;
property InternalFormat: TglcInternalFormat read fInternalFormat write SetInternalFormat;

procedure SetSize(const aWidth, aHeight: Integer); override;
procedure Bind(const aEnableTextureUnit: Boolean = true);
procedure Unbind(const aDisableTextureUnit: Boolean = true);

constructor Create(const aFormat: TglcFormat; const aInternalFormat: TglcInternalFormat);
destructor Destroy; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
EglcFrameBufferObject = class(Exception);
TglcFrameBufferObject = class(TObject)
private type
TglcAttachmentContainer = class(TObject)
Buffer: TglcBuffer;
Attachment: TglcAttachment;
OwnsObject: Boolean;
constructor Create(const aBuffer: TglcBuffer; const aAttachment: TglcAttachment; const aOwnsObject: Boolean = true);
destructor Destroy; override;
end;
TglcAttachmentContainerList = specialize TFPGObjectList<TglcAttachmentContainer>;
private
fID: GLuint;
fOwnsObjects: Boolean;
fWidth: Integer;
fHeight: Integer;
fBuffers: TglcAttachmentContainerList;

function GetBuffer(const aIndex: Integer): TglcBuffer;
procedure SetBuffer(const aIndex: Integer; const aValue: TglcBuffer);

function GetAttachment(const aIndex: Integer): TglcAttachment;
procedure SetAttachment(const aIndex: Integer; const aValue: TglcAttachment);

function GetBufferCount: Integer;

procedure Attach(const aIndex: Integer);
procedure Detach(const aIndex: Integer);

procedure SetWidth(const aValue: Integer);
procedure SetHeight(const aValue: Integer);
procedure CheckFrameBufferStatus;
procedure UpdateAndCheckFBO;
public
property ID : GLuint read fID;
property Count : Integer read GetBufferCount;
property OwnsObjects: Boolean read fOwnsObjects;
property Width : Integer read fWidth write SetWidth;
property Height : Integer read fHeight write SetHeight;
property Attachments[const aIndex: Integer]: TglcAttachment read GetAttachment write SetAttachment;
property Buffers [const aIndex: Integer]: TglcBuffer read GetBuffer write SetBuffer;

procedure AddBuffer(const aBuffer: TglcBuffer; const aAttachment: TglcAttachment; const aOwnsBuffer: Boolean = true);
procedure DelBuffer(const aIndex: Integer);
function RemBuffer(const aBuffer: TglcBuffer): Integer;
function IndexOfBuffer(const aBuffer: TglcBuffer): Integer;

procedure SetSize(const aWidth, aHeight: Integer);
function CheckAttachment(const aAttachment: TglcAttachment): Boolean;

procedure Bind(const aSetViewport: Boolean = true);
procedure Unbind(const aResetViewport: Boolean = true);

constructor Create(const aOwnBuffers: Boolean = true);
destructor Destroy; override;
end;

implementation

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcBuffer////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcBuffer.SetWidth(const aValue: Integer);
begin
SetSize(aValue, fHeight);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcBuffer.SetHeight(const aValue: Integer);
begin
SetSize(fWidth, aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcBuffer.SetSize(const aWidth, aHeight: Integer);
begin
fWidth := aWidth;
fHeight := aHeight;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcRenderBuffer//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcRenderBuffer.UpdateRenderBufferStorage;
begin
glGetError; //clear Erroros
Bind;
glRenderbufferStorage(GL_RENDERBUFFER, GLenum(fFormat), fWidth, fHeight);
Unbind;
glcCheckAndRaiseError;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcRenderBuffer.SetFormat(const aValue: TglcInternalFormat);
begin
fFormat := aValue;
UpdateRenderBufferStorage;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcRenderBuffer.SetSize(const aWidth, aHeight: Integer);
begin
if (aWidth <= 0) or (aHeight <= 0) then
raise EglcRenderBuffer.Create('invalid width or height');
if (aWidth <> fWidth) or (aHeight <> fHeight) then begin
inherited SetSize(aWidth, aHeight);
UpdateRenderBufferStorage;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcRenderBuffer.Bind;
begin
glBindRenderbuffer(GL_RENDERBUFFER, fID);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcRenderBuffer.Unbind;
begin
glBindRenderbuffer(GL_RENDERBUFFER, 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TglcRenderBuffer.Create(const aFormat: TglcInternalFormat);
begin
inherited Create;
fBufferType := btRenderBuffer;
glGenRenderbuffers(1, @fID);
fFormat := aFormat;
SetSize(64, 64);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TglcRenderBuffer.Destroy;
begin
glDeleteRenderbuffers(1, @fID);
inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcTextureBuffer/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcTextureBuffer.UpdateTexImage;
begin
glGetError; //clear errors
Bind(false);
glTexImage2D(GL_TEXTURE_2D, 0, GLenum(fInternalFormat), fWidth, fHeight, GLint(Byte(fBorder) and Byte(1)), GLenum(fFormat), GL_UNSIGNED_BYTE, nil);
Unbind(false);
glcCheckAndRaiseError;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcTextureBuffer.SetFormat(const aValue: TglcFormat);
begin
if (fFormat <> aValue) then begin
fFormat := aValue;
UpdateTexImage;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcTextureBuffer.SetInternalFormat(const aValue: TglcInternalFormat);
begin
if (fInternalFormat <> aValue) then begin
fInternalFormat := aValue;
UpdateTexImage;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcTextureBuffer.SetBorder(const aValue: Boolean);
begin
if (fBorder <> aValue) then begin
fBorder := aValue;
UpdateTexImage;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcTextureBuffer.SetSize(const aWidth, aHeight: Integer);
begin
if (aWidth <= 0) or (aHeight <= 0) then
raise EglcTextureBuffer.Create('invalid width or height');
if (aWidth <> fWidth) or (aHeight <> fHeight) then begin
inherited SetSize(aWidth, aHeight);
UpdateTexImage;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcTextureBuffer.Bind(const aEnableTextureUnit: Boolean = true);
begin
if aEnableTextureUnit then
glEnable(GL_TEXTURE_2D);
glBindTexture(GL_TEXTURE_2D, fID);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcTextureBuffer.Unbind(const aDisableTextureUnit: Boolean = true);
begin
if aDisableTextureUnit then
glDisable(GL_TEXTURE_2D);
glBindTexture(GL_TEXTURE_2D, 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TglcTextureBuffer.Create(const aFormat: TglcFormat; const aInternalFormat: TglcInternalFormat);
begin
inherited Create;
fBufferType := btTextureBuffer;

glGenTextures(1, @fID);
Bind(false);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
Unbind(false);

fFormat := aFormat;
fInternalFormat := aInternalFormat;
SetSize(64, 64);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TglcTextureBuffer.Destroy;
begin
glDeleteTextures(1, @fID);
inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcAttachment////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TglcFrameBufferObject.TglcAttachmentContainer.Create(const aBuffer: TglcBuffer;
const aAttachment: TglcAttachment; const aOwnsObject: Boolean);
begin
inherited Create;
Buffer := aBuffer;
Attachment := aAttachment;
OwnsObject := aOwnsObject;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TglcFrameBufferObject.TglcAttachmentContainer.Destroy;
begin
if OwnsObject then
Buffer.Free;
inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcFrameBufferObject/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrameBufferObject.GetBuffer(const aIndex: Integer): TglcBuffer;
begin
if (aIndex >= 0) and (aIndex < fBuffers.Count) then
result := fBuffers[aIndex].Buffer
else
raise EglcFrameBufferObject.Create('Index out of Bounds: ' + IntToStr(aIndex));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrameBufferObject.SetBuffer(const aIndex: Integer; const aValue: TglcBuffer);
begin
if (aIndex < 0) or (aIndex >= fBuffers.Count) then
raise EglcFrameBufferObject.Create('Index out of Bounds: ' + IntToStr(aIndex));

if not Assigned(aValue) then
raise EglcFrameBufferObject.Create('invalid buffer');

Detach(aIndex);
fBuffers[aIndex].Buffer := aValue;
Attach(aIndex);
UpdateAndCheckFBO;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrameBufferObject.GetAttachment(const aIndex: Integer): TglcAttachment;
begin
if (aIndex >= 0) and (aIndex < fBuffers.Count) then
result := fBuffers[aIndex].Attachment
else
raise EglcFrameBufferObject.Create('Index out of Bounds: ' + IntToStr(aIndex));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrameBufferObject.SetAttachment(const aIndex: Integer; const aValue: TglcAttachment);
begin
if (aIndex < 0) or (aIndex >= fBuffers.Count) then
raise EglcFrameBufferObject.Create('Index out of Bounds: ' + IntToStr(aIndex));

if not CheckAttachment(aValue) then
raise EglcFrameBufferObject.Create('Attachment already assigned');

Detach(aIndex);
fBuffers[aIndex].Attachment := aValue;
Attach(aIndex);
UpdateAndCheckFBO;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrameBufferObject.Attach(const aIndex: Integer);
var
a: TglcAttachment;
b: TglcBuffer;
begin
a := Attachments[aIndex];
b := Buffers[aIndex];
Bind(false);
if (b.BufferType = btRenderBuffer) then
glFramebufferRenderbuffer(GL_FRAMEBUFFER, GLenum(a), GL_RENDERBUFFER, (b as TglcRenderBuffer).ID)
else
glFramebufferTexture2D(GL_FRAMEBUFFER, GLenum(a), GL_TEXTURE_2D, (b as TglcTextureBuffer).ID, 0);
Unbind(false);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrameBufferObject.Detach(const aIndex: Integer);
var
a: TglcAttachment;
b: TglcBuffer;
begin
a := Attachments[aIndex];
b := Buffers[aIndex];
Bind(false);
if (b.BufferType = btRenderBuffer) then
glFramebufferRenderbuffer(GL_FRAMEBUFFER, GLenum(a), GL_RENDERBUFFER, 0)
else
glFramebufferTexture2D(GL_FRAMEBUFFER, GLenum(a), GL_TEXTURE_2D, 0, 0);
Unbind(false);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//legt die neue Breite fest
//@Value: Breite;
procedure TglcFrameBufferObject.SetWidth(const aValue: Integer);
begin
SetSize(aValue, fHeight);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//legt die neue Höhe fest
//@Value: neue Höhe;
procedure TglcFrameBufferObject.SetHeight(const aValue: Integer);
begin
SetSize(fWidth, aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrameBufferObject.CheckFrameBufferStatus;
begin
case glCheckFramebufferStatus(GL_FRAMEBUFFER) of
GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT:
raise EglcFrameBufferObject.Create('Incomplete attachment');
GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT:
raise EglcFrameBufferObject.Create('Missing attachment');
GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT:
raise EglcFrameBufferObject.Create('Incomplete dimensions');
GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT:
raise EglcFrameBufferObject.Create('Incomplete formats');
GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER:
raise EglcFrameBufferObject.Create('Incomplete draw buffer');
GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER:
raise EglcFrameBufferObject.Create('Incomplete read buffer');
GL_FRAMEBUFFER_UNSUPPORTED:
raise EglcFrameBufferObject.Create('Framebufferobjects unsupported');
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//prüft das FrameBufferObjekt auf Fehler
procedure TglcFrameBufferObject.UpdateAndCheckFBO;

function IsColorAttachment(const a: TglcAttachment): Boolean;
begin
result := (GLenum(a) >= GL_COLOR_ATTACHMENT0) and (GLenum(a) <= GL_COLOR_ATTACHMENT15);
end;

var
buff: array of GLenum;
b: GLboolean;
i: Integer;
begin
if (fBuffers.Count = 0) then
exit;
Bind(false);

//find ColorBuffers
SetLength(buff, 0);
for i := 0 to fBuffers.Count-1 do
if IsColorAttachment(fBuffers[i].Attachment) then begin
SetLength(buff, Length(buff) + 1);
buff[High(buff)] := GLenum(fBuffers[i].Attachment);
end;

//set Read and Draw Buffer
if (Length(buff) = 0) then begin
glReadBuffer(GL_NONE);
glDrawBuffer(GL_NONE);
end else begin
glDrawBuffers(Length(buff), @buff[0]);
glGetBooleanv(GL_DOUBLEBUFFER, @b);
if b then
glReadBuffer(GL_BACK)
else
glReadBuffer(GL_FRONT);
end;
Unbind(false);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrameBufferObject.GetBufferCount: Integer;
begin
result := fBuffers.Count;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrameBufferObject.AddBuffer(const aBuffer: TglcBuffer;
const aAttachment: TglcAttachment; const aOwnsBuffer: Boolean);
begin
if not Assigned(aBuffer) then
raise EglcFrameBufferObject.Create('invalid buffer');
if not CheckAttachment(aAttachment) then
raise EglcFrameBufferObject.Create('attachment already assigned');

fBuffers.Add(TglcAttachmentContainer.Create(aBuffer, aAttachment, fOwnsObjects and aOwnsBuffer));
if OwnsObjects then
aBuffer.SetSize(fWidth, fHeight);
Attach(fBuffers.Count-1);

UpdateAndCheckFBO;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcFrameBufferObject.DelBuffer(const aIndex: Integer);
begin
if (aIndex >= 0) and (aIndex < fBuffers.Count) then begin
Detach(aIndex);
fBuffers.Delete(aIndex);
UpdateAndCheckFBO;
end else
raise EglcFrameBufferObject.Create('Index out of Bounds: ' + IntToStr(aIndex));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrameBufferObject.RemBuffer(const aBuffer: TglcBuffer): Integer;
begin
result := IndexOfBuffer(aBuffer);
if (result >= 0) then
DelBuffer(result);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrameBufferObject.IndexOfBuffer(const aBuffer: TglcBuffer): Integer;
var
i: Integer;
begin
for i := 0 to fBuffers.Count-1 do
if (fBuffers[i].Buffer = aBuffer) then begin
result := i;
exit;
end;
result := -1;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//legt die Größe neu fest
//@Width: neue Breite;
//@Height: neue Höhe;
procedure TglcFrameBufferObject.SetSize(const aWidth, aHeight: Integer);
var
c: TglcAttachmentContainer;
begin
if (aWidth <= 0) or (aHeight <= 0) then
raise EglcFrameBufferObject.Create('invalid width or height');

fWidth := aWidth;
fHeight := aHeight;
if OwnsObjects then
for c in fBuffers do
if c.OwnsObject then
c.Buffer.SetSize(fWidth, fHeight);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcFrameBufferObject.CheckAttachment(const aAttachment: TglcAttachment): Boolean;
var
i: Integer;
begin
result := false;
for i := 0 to fBuffers.Count-1 do
if (fBuffers[i].Attachment = aAttachment) then
exit;
result := true;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//Bindet das FrameBufferObjekt
procedure TglcFrameBufferObject.Bind(const aSetViewport: Boolean = true);
begin
glBindFramebuffer(GL_FRAMEBUFFER, fID);
if aSetViewport then begin
glPushAttrib(GL_VIEWPORT_BIT);
glViewPort(0, 0, fWidth, fHeight);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//Entbindet das FrameBufferObjekt
procedure TglcFrameBufferObject.Unbind(const aResetViewport: Boolean = true);
begin
if aResetViewport then
glPopAttrib;
glBindFramebuffer(GL_FRAMEBUFFER, 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//erzeugt das Objekt
constructor TglcFrameBufferObject.Create(const aOwnBuffers: Boolean = true);
begin
inherited Create;

glGenFramebuffers(1, @fID);
fWidth := 64;
fHeight := 64;
fOwnsObjects := aOwnBuffers;
fBuffers := TglcAttachmentContainerList.Create(true); //containers are always owned by this object!
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//gibt das Objekt frei
destructor TglcFrameBufferObject.Destroy;
begin
fBuffers.Free;
glDeleteFramebuffers(1, @fID);
inherited Destroy;
end;

end.


+ 424
- 0
uglcLight.pas View File

@@ -0,0 +1,424 @@
unit uglcLight;

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

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, dglOpenGL, ugluVector, uglcTypes;

type
TglcMaterialRec = packed record
Ambient: TgluVector4f;
Diffuse: TgluVector4f;
Specular: TgluVector4f;
Emission: TgluVector4f;
Shininess: GLfloat;
end;
PglcMaterialRec = ^TglcMaterialRec;

TglcLightType = (ltGlobal, ltPoint, ltSpot);
TglcLightRec = packed record
Ambient: TgluVector4f;
Diffuse: TgluVector4f;
Specular: TgluVector4f;
Position: TgluVector4f;
SpotDirection: TgluVector3f;
SpotExponent: GLfloat;
SpotCutoff: GLfloat;
ConstantAtt: GLfloat;
LinearAtt: GLfloat;
QuadraticAtt: GLfloat;
end;
PglcLightRec = ^TglcLightRec;

const
MAT_DEFAULT_AMBIENT: TgluVector4f = (0.2, 0.2, 0.2, 1.0);
MAT_DEFAULT_DIFFUSE: TgluVector4f = (0.8, 0.8, 0.8, 1.0);
MAT_DEFAULT_SPECULAR: TgluVector4f = (0.5, 0.5, 0.5, 1.0);
MAT_DEFAULT_EMISSION: TgluVector4f = (0.0, 0.0, 0.0, 1.0);
MAT_DEFAULT_SHININESS: GLfloat = 50.0;

LIGHT_DEFAULT_AMBIENT: TgluVector4f = (0.4, 0.4, 0.4, 1.0);
LIGHT_DEFAULT_DIFFUSE: TgluVector4f = (0.7, 0.7, 0.7, 1.0);
LIGHT_DEFAULT_SPECULAR: TgluVector4f = (0.9, 0.9, 0.9, 1.0);
LIGHT_DEFAULT_POSITION: TgluVector4f = (0.0, 0.0, 1.0, 0.0);
LIGHT_DEFAULT_SPOT_DIRECTION: TgluVector3f = (0.0, 0.0, -1.0);
LIGHT_DEFAULT_SPOT_EXPONENT: GLfloat = 0.0;
LIGHT_DEFAULT_SPOT_CUTOFF: GLfloat = 180.0;
LIGHT_DEFAULT_CONSTANT_ATT: GLfloat = 1.0;
LIGHT_DEFAULT_LINEAR_ATT: GLfloat = 0.0;
LIGHT_DEFAULT_QUADRATIC_ATT: GLfloat = 0.0;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TglcMaterial = class(TObject)
private
fData: TglcMaterialRec;
public
property Diffuse: TgluVector4f read fData.Diffuse write fData.Diffuse;
property Ambient: TgluVector4f read fData.Ambient write fData.Ambient;
property Specular: TgluVector4f read fData.Specular write fData.Specular;
property Emission: TgluVector4f read fData.Emission write fData.Emission;
property Shininess: GLfloat read fData.Shininess write fData.Shininess;
property Data: TglcMaterialRec read fData write fData;

procedure Bind(const aFace: TglcFace);

class procedure Bind(const aFace: TglcFace; const aMaterial: TglcMaterialRec);
class function DefaultValues: TglcMaterialRec;

constructor Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
EglcLight = class(Exception);
TglcLight = class(TObject)
private
function GetDataPtr: PglcLightRec;
protected
fData: TglcLightRec;

procedure SetAmbient (const aValue: TgluVector4f); virtual;
procedure SetDiffuse (const aValue: TgluVector4f); virtual;
procedure SetSpecular (const aValue: TgluVector4f); virtual;
procedure SetPosition4f (const aValue: TgluVector4f); virtual;
procedure SetSpotDirection(const aValue: TgluVector3f); virtual;
procedure SetSpotExponent (const aValue: GLfloat); virtual;
procedure SetSpotCutoff (const aValue: GLfloat); virtual;
procedure SetConstantAtt (const aValue: GLfloat); virtual;
procedure SetLinearAtt (const aValue: GLfloat); virtual;
procedure SetQuadraticAtt (const aValue: GLfloat); virtual;
procedure SetData (const aValue: TglcLightRec); virtual;

property Ambient: TgluVector4f read fData.Ambient write SetAmbient;
property Diffuse: TgluVector4f read fData.Diffuse write SetDiffuse;
property Specular: TgluVector4f read fData.Specular write SetSpecular;
property Position4f: TgluVector4f read fData.Position write SetPosition4f;
property SpotDirection: TgluVector3f read fData.SpotDirection write SetSpotDirection;
property SpotExponent: GLfloat read fData.SpotExponent write SetSpotExponent;
property SpotCutoff: GLfloat read fData.SpotCutoff write SetSpotCutoff;
property ConstantAtt: GLfloat read fData.ConstantAtt write SetConstantAtt;
property LinearAtt: GLfloat read fData.LinearAtt write SetLinearAtt;
property QuadraticAtt: GLfloat read fData.QuadraticAtt write SetQuadraticAtt;
public
property Data: TglcLightRec read fData write SetData;
property DataPtr: PglcLightRec read GetDataPtr;

procedure Bind(const aLightID: GLenum; const aEnableLighting: Boolean = false); virtual; abstract;

class procedure Bind(const aLightID: GLenum; const aLight: TglcLightRec;
const aEnableLighting: Boolean; const aLightType: TglcLightType);
class procedure Unbind(const aLightID: GLenum; const aDisableLighting: Boolean = true);
class function DefaultValues: TglcLightRec; virtual;

constructor Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TglcLightGlobal = class(TglcLight)
private
function GetDirection: TgluVector3f;
procedure SetDirection(aValue: TgluVector3f);
public
property Ambient;
property Diffuse;
property Specular;
property Direction: TgluVector3f read GetDirection write SetDirection;

procedure Bind(const aLightID: GLenum; const aEnableLighting: Boolean = false); override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TglcLightPoint = class(TglcLight)
private
fMaxSize: Single;
fSizeFactor: Single;
function GetPosition: TgluVector3f;
procedure SetPosition(const aValue: TgluVector3f);
protected
procedure SetMaxSize (const aValue: Single); virtual;
procedure SetSizeFactor(const aValue: Single); virtual;
public
property Ambient;
property Diffuse;
property Specular;
property ConstantAtt;
property LinearAtt;
property QuadraticAtt;
property MaxSize: Single read fMaxSize write SetMaxSize;
property SizeFactor: Single read fSizeFactor write SetSizeFactor;
property Position: TgluVector3f read GetPosition write SetPosition;

procedure Bind(const aLightID: GLenum; const aEnableLighting: Boolean = false); override;

constructor Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TglcLightSpot = class(TglcLightPoint)
public
property SpotCutoff;
property SpotDirection;
property SpotExponent;

procedure Bind(const aLightID: GLenum; const aEnableLighting: Boolean = false); override;
end;

implementation

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcMaterial//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcMaterial.Bind(const aFace: TglcFace);
begin
Bind(aFace, fData);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TglcMaterial.Bind(const aFace: TglcFace; const aMaterial: TglcMaterialRec);
begin
glMaterialfv(GLenum(aFace), GL_AMBIENT, @aMaterial.Ambient[0]);
glMaterialfv(GLenum(aFace), GL_DIFFUSE, @aMaterial.Diffuse[0]);
glMaterialfv(GLenum(aFace), GL_EMISSION, @aMaterial.Emission[0]);
glMaterialfv(GLenum(aFace), GL_SPECULAR, @aMaterial.Specular[0]);
glMaterialfv(GLenum(aFace), GL_SHININESS, @aMaterial.Shininess);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TglcMaterial.DefaultValues: TglcMaterialRec;
begin
result.Ambient := MAT_DEFAULT_AMBIENT;
result.Diffuse := MAT_DEFAULT_DIFFUSE;
result.Specular := MAT_DEFAULT_SPECULAR;
result.Emission := MAT_DEFAULT_EMISSION;
result.Shininess := MAT_DEFAULT_SHININESS;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TglcMaterial.Create;
begin
inherited Create;
fData := DefaultValues;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcLight/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcLight.GetDataPtr: PglcLightRec;
begin
result := @fData;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetAmbient(const aValue: TgluVector4f);
begin
fData.Ambient := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetDiffuse(const aValue: TgluVector4f);
begin
fData.Diffuse := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetSpecular(const aValue: TgluVector4f);
begin
fData.Specular := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetPosition4f(const aValue: TgluVector4f);
begin
fData.Position := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetConstantAtt(const aValue: GLfloat);
begin
fData.ConstantAtt := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetLinearAtt(const aValue: GLfloat);
begin
fData.LinearAtt := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetQuadraticAtt(const aValue: GLfloat);
begin
fData.QuadraticAtt := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetSpotDirection(const aValue: TgluVector3f);
begin
fData.SpotDirection := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetSpotExponent(const aValue: GLfloat);
begin
fData.SpotExponent := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetSpotCutoff(const aValue: GLfloat);
begin
fData.SpotCutoff := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLight.SetData(const aValue: TglcLightRec);
begin
fData := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TglcLight.Bind(const aLightID: GLenum; const aLight: TglcLightRec;
const aEnableLighting: Boolean; const aLightType: TglcLightType);
begin
glEnable(aLightID);
if (aEnableLighting) then
glEnable(GL_LIGHTING);

if (aLightType in [ltGlobal, ltPoint, ltSpot]) then begin
glLightfv(aLightID, GL_AMBIENT, @aLight.Ambient[0]);
glLightfv(aLightID, GL_DIFFUSE, @aLight.Diffuse[0]);
glLightfv(aLightID, GL_SPECULAR, @aLight.Specular[0]);
glLightfv(aLightID, GL_POSITION, @aLight.Position[0]);
end else begin
glLightfv(aLightID, GL_AMBIENT, @LIGHT_DEFAULT_AMBIENT[0]);
glLightfv(aLightID, GL_DIFFUSE, @LIGHT_DEFAULT_DIFFUSE[0]);
glLightfv(aLightID, GL_SPECULAR, @LIGHT_DEFAULT_SPECULAR[0]);
glLightfv(aLightID, GL_POSITION, @LIGHT_DEFAULT_POSITION[0]);
end;

if (aLightType in [ltPoint, ltSpot]) then begin
glLightfv(aLightID, GL_CONSTANT_ATTENUATION, @aLight.ConstantAtt);
glLightfv(aLightID, GL_LINEAR_ATTENUATION, @aLight.LinearAtt);
glLightfv(aLightID, GL_QUADRATIC_ATTENUATION, @aLight.QuadraticAtt);
end else begin
glLightfv(aLightID, GL_CONSTANT_ATTENUATION, @LIGHT_DEFAULT_CONSTANT_ATT);
glLightfv(aLightID, GL_LINEAR_ATTENUATION, @LIGHT_DEFAULT_LINEAR_ATT);
glLightfv(aLightID, GL_QUADRATIC_ATTENUATION, @LIGHT_DEFAULT_QUADRATIC_ATT);
end;

if (aLightType in [ltSpot]) then begin
glLightfv(aLightID, GL_SPOT_DIRECTION, @aLight.SpotDirection[0]);
glLightfv(aLightID, GL_SPOT_EXPONENT, @aLight.SpotExponent);
glLightfv(aLightID, GL_SPOT_CUTOFF, @aLight.SpotCutoff);
end else begin
glLightfv(aLightID, GL_SPOT_DIRECTION, @LIGHT_DEFAULT_SPOT_DIRECTION[0]);
glLightfv(aLightID, GL_SPOT_EXPONENT, @LIGHT_DEFAULT_SPOT_EXPONENT);
glLightfv(aLightID, GL_SPOT_CUTOFF, @LIGHT_DEFAULT_SPOT_CUTOFF);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TglcLight.Unbind(const aLightID: GLenum; const aDisableLighting: Boolean);
begin
glDisable(aLightID);
if aDisableLighting then
glDisable(GL_LIGHTING);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TglcLight.DefaultValues: TglcLightRec;
begin
result.Ambient := LIGHT_DEFAULT_AMBIENT;
result.Diffuse := LIGHT_DEFAULT_DIFFUSE;
result.Specular := LIGHT_DEFAULT_SPECULAR;
result.Position := LIGHT_DEFAULT_POSITION;
result.SpotDirection := LIGHT_DEFAULT_SPOT_DIRECTION;
result.SpotExponent := LIGHT_DEFAULT_SPOT_EXPONENT;
result.SpotCutoff := LIGHT_DEFAULT_SPOT_CUTOFF;
result.ConstantAtt := LIGHT_DEFAULT_CONSTANT_ATT;
result.LinearAtt := LIGHT_DEFAULT_LINEAR_ATT;
result.QuadraticAtt := LIGHT_DEFAULT_QUADRATIC_ATT;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TglcLight.Create;
begin
inherited Create;
fData := DefaultValues;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcLightGlobal///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcLightGlobal.GetDirection: TgluVector3f;
begin
result := gluVector3f(Position4f);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLightGlobal.SetDirection(aValue: TgluVector3f);
begin
Position4f := gluVector4f(aValue, 0.0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLightGlobal.Bind(const aLightID: GLenum; const aEnableLighting: Boolean);
begin
TglcLight.Bind(aLightID, fData, aEnableLighting, ltGlobal);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcLightPoint////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TglcLightPoint.GetPosition: TgluVector3f;
begin
result := gluVector3f(fData.Position);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLightPoint.SetPosition(const aValue: TgluVector3f);
begin
SetPosition4f(gluVector4f(aValue, 1.0));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLightPoint.SetMaxSize(const aValue: Single);
begin
fMaxSize := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLightPoint.SetSizeFactor(const aValue: Single);
begin
fSizeFactor := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLightPoint.Bind(const aLightID: GLenum; const aEnableLighting: Boolean);
begin
TglcLight.Bind(aLightID, fData, aEnableLighting, ltPoint);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TglcLightPoint.Create;
begin
inherited Create;
Position := gluVector3f(0.0, 0.0, 0.0);
fMaxSize := 0;
fSizeFactor := 1.0;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TglcLightSpot/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TglcLightSpot.Bind(const aLightID: GLenum; const aEnableLighting: Boolean);
begin
TglcLight.Bind(aLightID, fData, aEnableLighting, ltSpot);
end;

end.


+ 931
- 0
uglcShader.pas View File

@@ -0,0 +1,931 @@
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.


+ 318
- 0
uglcTypes.pas View File

@@ -0,0 +1,318 @@
unit uglcTypes;

{ Package: OpenGLCore
Prefix: glc - OpenGL Core
Beschreibung: diese Unit definiert Enum-Typen die OpenGL Konstanten wrappen und stellt zusätzlich
Funktions-Wrapper zur verfügung die diese Enum-Typen als Parameter entgegen nehmen }

{$mode objfpc}{$H+}
{$MACRO ON}
{$SCOPEDENUMS ON}

interface

uses
dglOpenGL, sysutils;

type
TglcFace = (
faFront = GL_FRONT,
faBack = GL_BACK,
faBoth = GL_FRONT_AND_BACK);

TglcPolygonMode = (
pmPoint = GL_POINT,
pmLine = GL_LINE,
pmFill = GL_FILL);

TglcDepthFunc = (
dfNever = GL_NEVER,
dfLess = GL_LESS,
dfEqual = GL_EQUAL,
dfLessEqual = GL_LEQUAL,
dfGreater = GL_GREATER,
dfNotEqual = GL_NOTEQUAL,
dfGreaterEqual = GL_GEQUAL,
dfAlways = GL_ALWAYS);

TglcClearBuffer = (
cbDepthBuffer = GL_DEPTH_BUFFER_BIT,
cbAccumBuffer = GL_ACCUM_BUFFER_BIT,
cbStencilBuffer = GL_STENCIL_BUFFER_BIT,
cbColorBuffer = GL_COLOR_BUFFER_BIT);

TglcTextureMinFilter = (
mfNearest = GL_NEAREST,
mfLinear = GL_LINEAR,
mfNearestMipmapNearest = GL_NEAREST_MIPMAP_NEAREST,
mfLinearMipmapNearest = GL_LINEAR_MIPMAP_NEAREST,
mfNearestMipmapLinear = GL_NEAREST_MIPMAP_LINEAR,
mfLinearMipmapLinear = GL_LINEAR_MIPMAP_LINEAR);

TglcTextureMagFilter = (
mfNearest = GL_NEAREST,
mfLinear = GL_LINEAR);

TglcTextureWrap = (
twClamp = GL_CLAMP,
twRepeat = GL_REPEAT,
twClampToBorder = GL_CLAMP_TO_BORDER,
twClampToEdge = GL_CLAMP_TO_EDGE,
twMirroredRepeat = GL_MIRRORED_REPEAT);

TglcBlendFactor = (
bfZero = GL_ZERO,
bfOne = GL_ONE,
bfSrcColor = GL_SRC_COLOR,
bfOneMinusSrcColor = GL_ONE_MINUS_SRC_COLOR,
bfSrcAlpha = GL_SRC_ALPHA,
bfOneMinusSrcAlpha = GL_ONE_MINUS_SRC_ALPHA,
bfDstAlpha = GL_DST_ALPHA,
bfOneMinusDstAlpha = GL_ONE_MINUS_DST_ALPHA,
bfDstColor = GL_DST_COLOR,
bfOneMinusDstColor = GL_ONE_MINUS_DST_COLOR,
bfSrcAlphaSaturate = GL_SRC_ALPHA_SATURATE,
bgConstColor = GL_CONSTANT_COLOR,
bfOneMinusConstColor = GL_ONE_MINUS_CONSTANT_COLOR,
bfConstAlpha = GL_CONSTANT_ALPHA,
bfOneMinusConstAlpha = GL_ONE_MINUS_CONSTANT_ALPHA);

TglcBlendMode = (
bmNone,
bmAlphaBlend,
bmAdditiveAlphaBlend,
bmAdditiveBlend);

TglcFormat = (
fmUnknown = 0,
fmColorIndex = GL_COLOR_INDEX,
fmDepthComponent = GL_DEPTH_COMPONENT,
fmRed = GL_RED,
fmGreen = GL_GREEN,
fmBlue = GL_BLUE,
fmAlpha = GL_ALPHA,
fmRGB = GL_RGB,
fmRGBA = GL_RGBA,
fmLuminance = GL_LUMINANCE,
fmLuminanceAlpha = GL_LUMINANCE_ALPHA,
fmBGR = GL_BGR,
fmBGRA = GL_BGRA,
fmDepthStencil = GL_DEPTH_STENCIL);

TglcInternalFormat = (
ifUnknown = 0,
ifDepthComponent = GL_DEPTH_COMPONENT,
ifAlpha = GL_ALPHA,
ifRGB = GL_RGB,
ifRGBA = GL_RGBA,
ifLuminance = GL_LUMINANCE,
ifLuminanceAlpha = GL_LUMINANCE_ALPHA,
ifR3G3B2 = GL_R3_G3_B2,
ifAlpha4 = GL_ALPHA4,
ifAlpha8 = GL_ALPHA8,
ifAlpha12 = GL_ALPHA12,
ifAlpha16 = GL_ALPHA16,
ifLuminance4 = GL_LUMINANCE4,
ifLuminance8 = GL_LUMINANCE8,
ifLuminance12 = GL_LUMINANCE12,
ifLuminance16 = GL_LUMINANCE16,
ifLuminance4Alpha4 = GL_LUMINANCE4_ALPHA4,
ifLuminance6Alpha2 = GL_LUMINANCE6_ALPHA2,
ifLuminance8Alpha8 = GL_LUMINANCE8_ALPHA8,
ifLuminance12Alpha4 = GL_LUMINANCE12_ALPHA4,
ifLuminance12Alpha12 = GL_LUMINANCE12_ALPHA12,
ifLuminance16Alpha16 = GL_LUMINANCE16_ALPHA16,
ifIntensity = GL_INTENSITY,
ifIntensity4 = GL_INTENSITY4,
ifIntensity8 = GL_INTENSITY8,
ifIntensity12 = GL_INTENSITY12,
ifIntensity16 = GL_INTENSITY16,
ifRGB4 = GL_RGB4,
ifRGB5 = GL_RGB5,
ifRGB8 = GL_RGB8,
ifRGB10 = GL_RGB10,
ifRGB12 = GL_RGB12,
ifRGB16 = GL_RGB16,
ifRGBA2 = GL_RGBA2,
ifRGBA4 = GL_RGBA4,
ifRGB5A1 = GL_RGB5_A1,
ifRGBA8 = GL_RGBA8,
ifRGB10A2 = GL_RGB10_A2,
ifRGBA12 = GL_RGBA12,
ifRGBA16 = GL_RGBA16,
ifDepthComponent16 = GL_DEPTH_COMPONENT16,
ifDepthComponent24 = GL_DEPTH_COMPONENT24,
ifDepthComponent32 = GL_DEPTH_COMPONENT32,
ifCompressedAlpha = GL_COMPRESSED_ALPHA,
ifCompressedLuminance = GL_COMPRESSED_LUMINANCE,
ifCompressedLuminanceAlpha = GL_COMPRESSED_LUMINANCE_ALPHA,
ifCompressedIntensity = GL_COMPRESSED_INTENSITY,
ifCompressedRGB = GL_COMPRESSED_RGB,
ifCompressedRGBA = GL_COMPRESSED_RGBA,
ifRGBA32f = GL_RGBA32F,
ifRGB32f = GL_RGB32F,
ifRGBA16F = GL_RGBA16F,
ifRGB16F = GL_RGB16F,
ifDepth24Stencil8 = GL_DEPTH24_STENCIL8,
ifSRGB = GL_SRGB,
ifSRGB8 = GL_SRGB8,
ifSRGBA = GL_SRGB_ALPHA,
ifSRGBA8 = GL_SRGB8_ALPHA8,
ifSLuminanceAlpha = GL_SLUMINANCE_ALPHA,
ifSLuminance8Alpha8 = GL_SLUMINANCE8_ALPHA8,
ifSLuminance = GL_SLUMINANCE,
ifSLuminance8 = GL_SLUMINANCE8,
ifDepth32fStencil8 = GL_DEPTH32F_STENCIL8,
ifStencil1 = GL_STENCIL_INDEX1,
ifStencil4 = GL_STENCIL_INDEX4,
ifStencil8 = GL_STENCIL_INDEX8,
ifStencil16 = GL_STENCIL_INDEX16);

TglcAttachment = (
atDepthStencil = GL_DEPTH_STENCIL_ATTACHMENT,
atColor0 = GL_COLOR_ATTACHMENT0,
atColor1 = GL_COLOR_ATTACHMENT1,
atColor2 = GL_COLOR_ATTACHMENT2,
atColor3 = GL_COLOR_ATTACHMENT3,
atColor4 = GL_COLOR_ATTACHMENT4,
atColor5 = GL_COLOR_ATTACHMENT5,
atColor6 = GL_COLOR_ATTACHMENT6,
atColor7 = GL_COLOR_ATTACHMENT7,
atColor8 = GL_COLOR_ATTACHMENT8,
atColor9 = GL_COLOR_ATTACHMENT9,
atColor10 = GL_COLOR_ATTACHMENT10,
atColor11 = GL_COLOR_ATTACHMENT11,
atColor12 = GL_COLOR_ATTACHMENT12,
atColor13 = GL_COLOR_ATTACHMENT13,
atColor14 = GL_COLOR_ATTACHMENT14,
atColor15 = GL_COLOR_ATTACHMENT15,
atDepth = GL_DEPTH_ATTACHMENT,
atStencil = GL_STENCIL_ATTACHMENT);

TglcShaderType = (
stFragment = GL_FRAGMENT_SHADER,
stVertex = GL_VERTEX_SHADER,
stGeometry = GL_GEOMETRY_SHADER,
stTessEvaluation = GL_TESS_EVALUATION_SHADER,
stTessControl = GL_TESS_CONTROL_SHADER);

TglcBufferTarget = (
btArrayBuffer = GL_ARRAY_BUFFER,
btElementArrayBuffer = GL_ELEMENT_ARRAY_BUFFER);

TglcBufferUsage = (
buStreamDraw = GL_STREAM_DRAW,
buStreamRead = GL_STREAM_READ,
buStreamCopy = GL_STREAM_COPY,
buStaticDraw = GL_STATIC_DRAW,
buStaticRead = GL_STATIC_READ,
buStaticCopy = GL_STATIC_COPY,
buDynamicDraw = GL_DYNAMIC_DRAW,
buDynamicRead = GL_DYNAMIC_READ,
buDynamicCopy = GL_DYNAMIC_COPY);

TglcBufferAccess = (
baReadOnly = GL_READ_ONLY,
baWriteOnly = GL_WRITE_ONLY,
baReadWrite = GL_READ_WRITE);

EOpenGL = class(Exception)
private
fErrorCode: GLenum;
public
property ErrorCode: GLenum read fErrorCode;
constructor Create(const aErrorCode: GLenum);
constructor Create(const aMsg: String; const aErrorCode: GLenum);
end;

procedure glcRenderFace(const aValue: TglcFace); inline;
procedure glcPolygonMode(const aFace: TglcFace; const aValue: TglcPolygonMode); inline;
procedure glcDepthFunc(const aValue: TglcDepthFunc); inline;
procedure glcBlendFunc(const aSource, aDest: TglcBlendFactor); inline; overload;
procedure glcBlendFunc(const aMode: TglcBlendMode); inline; overload;
procedure glcCheckAndRaiseError;

implementation

type
TglcBlendModeValue = packed record
src, dst: TglcBlendFactor;
end;

const
BLEND_MODE_VALUES: array[TglcBlendMode] of TglcBlendModeValue = (
(src: TglcBlendFactor.bfOne; dst: TglcBlendFactor.bfZero), //bmNone
(src: TglcBlendFactor.bfSrcAlpha; dst: TglcBlendFactor.bfOneMinusSrcAlpha), //bmAlphaBlend
(src: TglcBlendFactor.bfSrcAlpha; dst: TglcBlendFactor.bfOne), //bmAdditiveAlphaBlend
(src: TglcBlendFactor.bfOne; dst: TglcBlendFactor.bfOne)); //bmAdditiveBlend

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure glcRenderFace(const aValue: TglcFace);
begin
case aValue of
TglcFace.faBoth: begin
glDisable(GL_CULL_FACE);
end;
TglcFace.faFront: begin
glEnable(GL_CULL_FACE);
glCullFace(GL_BACK);
end;
TglcFace.faBack: begin
glEnable(GL_CULL_FACE);
glCullFace(GL_FRONT);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure glcPolygonMode(const aFace: TglcFace; const aValue: TglcPolygonMode);
begin
glPolygonMode(GLenum(aFace), GLenum(aValue));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure glcDepthFunc(const aValue: TglcDepthFunc);
begin
glDepthFunc(GLenum(aValue));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure glcBlendFunc(const aSource, aDest: TglcBlendFactor);
begin
glBlendFunc(GLenum(aSource), GLenum(aDest));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure glcBlendFunc(const aMode: TglcBlendMode); overload;
begin
glBlendFunc(GLenum(BLEND_MODE_VALUES[aMode].src), GLenum(BLEND_MODE_VALUES[aMode].dst));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure glcCheckAndRaiseError;
var
e: GLenum;
begin
e := glGetError();
if (e <> GL_NO_ERROR) then
raise EOpenGL.Create(e);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//EOpenGL///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EOpenGL.Create(const aErrorCode: GLenum);
begin
fErrorCode := aErrorCode;
inherited Create(gluErrorString(fErrorCode));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EOpenGL.Create(const aMsg: String; const aErrorCode: GLenum);
begin
fErrorCode := aErrorCode;
inherited Create(aMsg + ': ' + gluErrorString(fErrorCode))
end;

end.


+ 318
- 0
ugluMatrix.pas View File

@@ -0,0 +1,318 @@
unit ugluMatrix;

{ Package: OpenGLCore
Prefix: glu - OpenGL Utils
Beschreibung: diese Unit enthält Matrix-Typen und Methoden um diese zu erstellen und zu manipulieren }

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, ugluVector;

type
//Matrixtypen
TgluMatrix2ub = array[0..1] of TgluVector2ub;
TgluMatrix2i = array[0..1] of TgluVector2i;
TgluMatrix2f = array[0..1] of TgluVector2f;
TgluMatrix2d = array[0..1] of TgluVector2d;

TgluMatrix3ub = array[0..2] of TgluVector3ub;
TgluMatrix3i = array[0..2] of TgluVector3i;
TgluMatrix3f = array[0..2] of TgluVector3f;
TgluMatrix3d = array[0..2] of TgluVector3d;

TgluMatrix4ub = array[0..3] of TgluVector4ub;
TgluMatrix4i = array[0..3] of TgluVector4i;
TgluMatrix4f = array[0..3] of TgluVector4f;
TgluMatrix4d = array[0..3] of TgluVector4d;

//MatrixPointer
PgluMatrix2ub = ^TgluMatrix2ub;
PgluMatrix2i = ^TgluMatrix2i;
PgluMatrix2f = ^TgluMatrix2f;
PgluMatrix2d = ^TgluMatrix2d;

PgluMatrix3ub = ^TgluMatrix3ub;
PgluMatrix3i = ^TgluMatrix3i;
PgluMatrix3f = ^TgluMatrix3f;
PgluMatrix3d = ^TgluMatrix3d;

PgluMatrix4ub = ^TgluMatrix4ub;
PgluMatrix4i = ^TgluMatrix4i;
PgluMatrix4f = ^TgluMatrix4f;
PgluMatrix4d = ^TgluMatrix4d;

//Konstructoren
function gluMatrix4d(const m: TgluMatrix4f): TgluMatrix4d;

//Matrixfunktionen
function gluMatrixTranslate(const v: TgluVector3f): TgluMatrix4f;
function gluMatrixScale(const v: TgluVector3f): TgluMatrix4f; overload;
function gluMatrixScale(const s: Single): TgluMatrix4f; overload;
function gluMatrixRotate(axis: TgluVector3f; const angle: Single): TgluMatrix4f;
function gluMatrixMult(const m1, m2: TgluMatrix4f): TgluMatrix4f;
function gluMatrixMultVec(const m: TgluMatrix4f; const v: TgluVector4f): TgluVector4f;
function gluMatrixTranspose(const m: TgluMatrix3f): TgluMatrix3f; overload;
function gluMatrixTranspose(const m: TgluMatrix4f): TgluMatrix4f; overload;
function gluMatrixSubMatrix(const m:TgluMatrix4f; const s, z: Integer): TgluMatrix3f;
function gluMatrixDeterminant(const m: TgluMatrix3f): Single; overload;
function gluMatrixDeterminant(const m: TgluMatrix4f): Single; overload;
function gluMatrixAdjoint(const m: TgluMatrix4f): TgluMatrix4f;
function gluMatrixInvert(const m: TgluMatrix4f): TgluMatrix4f;

operator * (const m1, m2: TgluMatrix4f): TgluMatrix4f;
operator * (const m: TgluMatrix4f; const v: TgluVector4f): TgluVector4f;
operator * (const m: TgluMatrix4f; const v: TgluVector3f): TgluVector3f;

const
maAxisX = 0;
maAxisY = 1;
maAxisZ = 2;
maPos = 3;
gluMatrixIdentity: TgluMatrix4f = ((1,0,0,0),(0,1,0,0),(0,0,1,0),(0,0,0,1));

implementation

uses
Math;

operator * (const m1, m2: TgluMatrix4f): TgluMatrix4f;
begin
result := gluMatrixMult(m1, m2);
end;

operator * (const m: TgluMatrix4f; const v: TgluVector4f): TgluVector4f;
begin
result := gluMatrixMultVec(m, v);
end;

operator * (const m: TgluMatrix4f; const v: TgluVector3f): TgluVector3f;
begin
result := gluVector3f(gluMatrixMultVec(m, gluVEctor4f(v, 1.0)));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function gluMatrix4d(const m: TgluMatrix4f): TgluMatrix4d;
var
i, j: Integer;
begin
for i := 0 to 3 do
for j := 0 to 3 do
result[i, j] := m[i, j];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//erstellt eine Translationsmatrix
//@v: Vektor der Translationsmatrix;
function gluMatrixTranslate(const v: TgluVector3f): TgluMatrix4f;
var
i: Integer;
begin
result := gluMatrixIdentity;
for i := 0 to 2 do
result[3, i] := v[i];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//erstellt eine Skalierungsmatrix
//@v: Vektor der Skalierungsmatrix;
function gluMatrixScale(const v: TgluVector3f): TgluMatrix4f;
var
i: Integer;
begin
result := gluMatrixIdentity;
for i := 0 to 2 do
result[i, i] := v[i];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function gluMatrixScale(const s: Single): TgluMatrix4f;
var
i: Integer;
begin
result := gluMatrixIdentity;
for i := 0 to 2 do
result[i, i] := s;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//erstellt eine Rotationsmatrix;
//@axis: Achse um die gedreht werden soll;
//@angle: Winkel mit dem gedreht werden soll;
function gluMatrixRotate(axis: TgluVector3f; const angle: Single): TgluMatrix4f;
var
X, Y, Z, a, s, c: Single;
begin
axis := gluVectorNormalize(axis);
X := axis[0];
Y := axis[1];
Z := axis[2];
a := angle/180*Pi;
s := sin(a);
c := cos(a);
result := gluMatrixIdentity;
result[maAxisX] := gluVector4f(
SQR(X) + (1-SQR(X))*c,
X*Y*(1-c) + Z*s,
X*Z*(1-c) - Y*s,
0);
result[maAxisY] := gluVector4f(
X*Y*(1-c) - Z*s,
SQR(Y) + (1-SQR(Y))*c,
Y*Z*(1-c) + X*s,
0);
result[maAxisZ] := gluVector4f(
X*Z*(1-c) + Y*s,
Y*Z*(1-c) - X*s,
SQR(Z) + (1-SQR(Z))*c,
0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//Mutlipliziert Matrix1 mit Matrix2
//@Matrix1: 1. Multiplikator;
//@Matrix2: 2. Multiplikator;
//@result: Matrix1 * Matrix2
function gluMatrixMult(const m1, m2: TgluMatrix4f): TgluMatrix4f;
var
x, y, i: Integer;
sum: Single;
begin
for x := 0 to 3 do begin
for y := 0 to 3 do begin
sum := 0;
for i := 0 to 3 do
sum := sum + m1[i, y] * m2[x, i];
result[x, y] := sum;
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//Multiplizerit eine Matrix mit einem Vektor
//@m: Matrix mit der multipliziert werden soll;
//@v: Vektor mit dem multipliziert werden soll;
//@result: Ergebnis der Multiplikation
function gluMatrixMultVec(const m: TgluMatrix4f; const v: TgluVector4f): TgluVector4f;
var
i, j: Integer;
sum: Single;
begin
for i := 0 to 3 do begin
sum := 0;
for j := 0 to 3 do
sum := sum + m[j,i] * v[j];
result[i] := sum;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//berechnet die Transponierte Matrix
//@m: Matrix die Transponiert werden soll;
//@result: Transponierte Matrix;
function gluMatrixTranspose(const m: TgluMatrix3f): TgluMatrix3f;
var
i, j: Integer;
begin
for i := 0 to 2 do
for j := 0 to 2 do
result[i, j] := m[j, i];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//berechnet die Transponierte Matrix
//@m: Matrix die Transponiert werden soll;
//@result: Transponierte Matrix;
function gluMatrixTranspose(const m: TgluMatrix4f): TgluMatrix4f;
var
i, j: Integer;
begin
for i := 0 to 3 do
for j := 0 to 3 do
result[i, j] := m[j, i];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//ermittelt die Untermatrix einer Matrix
//@m: Matrix derren Untermatrix berechnet werden soll;
//@s: Spalte die gelöscht werden soll;
//@z: Zeile die gelöscht werden soll;
//@result: Untermatrix von m
function gluMatrixSubMatrix(const m: TgluMatrix4f; const s, z: Integer): TgluMatrix3f;
var
x, y, i, j: Integer;
begin
for i := 0 to 2 do
for j := 0 to 2 do begin
x := i;
y := j;
if (i >= s) then
inc(x);
if (j >= z) then
inc(y);
result[i, j] := m[x, y];
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//berechnet die Determinante einer Matrix
//@m: Matrix derren Determinaten berechnet werden soll;
//@result: Determinante von m
function gluMatrixDeterminant(const m: TgluMatrix3f): Single;
begin
result :=
m[0,0] * m[1,1] * m[2,2] +
m[1,0] * m[2,1] * m[0,2] +
m[2,0] * m[0,1] * m[1,2] -
m[2,0] * m[1,1] * m[0,2] -
m[1,0] * m[0,1] * m[2,2] -
m[0,0] * m[2,1] * m[1,2];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//berechnet die Determinante einer Matrix
//@m: Matrix derren Determinaten berechnet werden soll;
//@result: Determinante von m
function gluMatrixDeterminant(const m: TgluMatrix4f): Single;
var
i: Integer;
begin
result := 0;
for i := 0 to 3 do
result := result + power(-1, i) * m[i, 0] * gluMatrixDeterminant(gluMatrixSubMatrix(m, i, 0));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//berechnet die Adjunkte einer Matrix
//@m: Matrix derren Adjunkte berechnet werden soll;
//@result: Adjunkte von m
function gluMatrixAdjoint(const m: TgluMatrix4f): TgluMatrix4f;
var
i, j: Integer;
begin
for i := 0 to 3 do
for j := 0 to 3 do
result[i, j] := power(-1, i+j) * gluMatrixDeterminant(gluMatrixSubMatrix(m, i, j));
result := gluMatrixTranspose(result);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//berechnet die inverse Matrix einer Matrix
//@m: Matrix derren Inverse berechnet werden soll;
//@result: Inverse Matrix von m;
function gluMatrixInvert(const m: TgluMatrix4f): TgluMatrix4f;
var
d: Single;
i, j: Integer;
begin
d := gluMatrixDeterminant(m);
result := gluMatrixAdjoint(m);
for i := 0 to 3 do
for j := 0 to 3 do
result[i,j] := result[i,j] / d;
end;

end.


+ 384
- 0
ugluQuaternion.pas View File

@@ -0,0 +1,384 @@
unit ugluQuaternion;

{ Package: OpenGLCore
Prefix: glu - OpenGL Utils
Beschreibung: diese Unit enthält Quaternion-Typen und Methoden um diese zu erstellen und zu manipulieren }

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, ugluVector, ugluMatrix;

type
TgluQuaternion = type TgluVector4f; // w,x,y,z

{
Winkel : rad, außer glRotate-Komponenten
Absolute Werte : Orientation
Relative Werte/"Drehanweisungen" : Rotation
To/FromVector : Position im R^4

Alle Funktionen nehmen an, dass die Quaternion nur zur Rotation verwendet wird (kein Scale),
mathematisch also normalisiert ist. Es findet keine Überprüfung statt.
}

//Quaternion Konstruktoren
function gluQuaternion(const W, X, Y, Z: Single): TgluQuaternion;
function gluQuaternionNormalize(const q: TgluQuaternion): TgluQuaternion;
procedure gluQuaternionNormalizeInplace(var q: TgluQuaternion);
function gluQuaternionToVector(const q: TgluQuaternion): TgluVector3f;
function gluVectorToQuaternion(const v: TgluVector3f): TgluQuaternion;

//Arithmetic
function gluQuaternionConjugate(const q: TgluQuaternion): TgluQuaternion;
function gluQuaternionMultiply(const l,r: TgluQuaternion): TgluQuaternion;
function gluQuaternionAdd(const a,b: TgluQuaternion): TgluQuaternion;
function gluQuaternionSubtract(const l,r: TgluQuaternion): TgluQuaternion;
function gluQuaternionScale(const q: TgluQuaternion; const f: Single): TgluQuaternion;


//To/From RotationMatrix
function gluQuaternionToMatrix(const q: TgluQuaternion): TgluMatrix4f;
function gluMatrixToQuaternion(const m: TgluMatrix4f): TgluQuaternion;

//To/From Axis/Angle {WINKEL IN °DEG}
function gluQuaternionToRotation(const q: TgluQuaternion; out angle: Single): TgluVector3f;
function gluRotationToQuaternion(const angle: Single; const axis: TgluVector3f): TgluQuaternion;

//Transforms
function gluQuaternionTransformVec(const q: TgluQuaternion; const v: TgluVector3f): TgluVector3f;

function gluQuaternionLookAt(const Location, Target, UpVector: TgluVector3f): TgluQuaternion;
//Rotation zw. Richtungen: Wie muss a modifiziert werden um b zu bekommen?
function gluVectorRotationTo(const a, b: TgluVector3f): TgluQuaternion;

//Modifying Quaternions
function gluQuaternionHalfAngle(const q: TgluQuaternion): TgluQuaternion;
function gluQuaternionAngleBetween(const a, b: TgluQuaternion): double;
function gluQuaternionSlerpOrientation(const a, b: TgluQuaternion; const t: single): TgluQuaternion;
function gluQuaternionNlerpOrientation(const a, b: TgluQuaternion; const t: single): TgluQuaternion;

operator +(const a, b: TgluQuaternion): TgluQuaternion;
operator -(const l, r: TgluQuaternion): TgluQuaternion;
operator *(const l, r: TgluQuaternion): TgluQuaternion;
operator *(const q: TgluQuaternion; const s: Sigle): TgluQuaternion;

const
quW = 0;
quX = 1;
quY = 2;
quZ = 3;
gluQuaternionIdentity: TgluQuaternion = (1,0,0,0);

implementation

uses
Math;

operator +(const a, b: TgluQuaternion): TgluQuaternion;
begin
result := gluQuaternionAdd(a, b);
end;

operator -(const l, r: TgluQuaternion): TgluQuaternion;
begin
result := gluQuaternionSubtract(l, r);
end;

operator *(const l, r: TgluQuaternion): TgluQuaternion;
begin
result := gluQuaternionMultiply(l, r);
end;

operator *(const q: TgluQuaternion; const s: Sigle): TgluQuaternion;
begin
result := gluQuaternionScale(q, s);
end;

function gluQuaternion(const W, X, Y, Z: Single): TgluQuaternion;
begin
Result:= gluVector4f(W,X,Y,Z);
end;

function gluQuaternionNormalize(const q: TgluQuaternion): TgluQuaternion;
begin
Result:= q;
gluQuaternionNormalizeInplace(Result);
end;

procedure gluQuaternionNormalizeInplace(var q: TgluQuaternion);
var
s: Double;
begin
s:= sqr(q[quX])+sqr(q[quY])+sqr(q[quZ])+sqr(q[quW]);
// already normalized?
if IsZero(s - 1) then
exit;
s:= 1/sqrt(s);
q[quX]:= q[quX] * s;
q[quY]:= q[quY] * s;
q[quZ]:= q[quZ] * s;
q[quW]:= q[quW] * s;
end;

function gluQuaternionToVector(const q: TgluQuaternion): TgluVector3f;
begin
Result:= gluVector3f(q[quX], q[quY], q[quZ]);
end;

function gluVectorToQuaternion(const v: TgluVector3f): TgluQuaternion;
begin
Result:= gluQuaternion(0, v[0], v[1], v[2]);
end;


function gluQuaternionConjugate(const q: TgluQuaternion): TgluQuaternion;
begin
Result[quW] := q[quW];
Result[quX] := -q[quX];
Result[quY] := -q[quY];
Result[quZ] := -q[quZ];
end;

function gluQuaternionMultiply(const l, r: TgluQuaternion): TgluQuaternion;
begin
Result[quW] := -l[qux] * r[qux] - l[quy] * r[quy] - l[quz] * r[quz] + l[quw] * r[quw];
Result[quX] := l[qux] * r[quw] + l[quy] * r[quz] - l[quz] * r[quy] + l[quw] * r[qux];
Result[quY] := -l[qux] * r[quz] + l[quy] * r[quw] + l[quz] * r[qux] + l[quw] * r[quy];
Result[quZ] := l[qux] * r[quy] - l[quy] * r[qux] + l[quz] * r[quw] + l[quw] * r[quz];
end;

function gluQuaternionAdd(const a, b: TgluQuaternion): TgluQuaternion;
begin
Result[quW] := a[quW] + b[quW];
Result[quX] := a[quX] + b[quX];
Result[quY] := a[quY] + b[quY];
Result[quZ] := a[quZ] + b[quZ];
end;

function gluQuaternionSubtract(const l, r: TgluQuaternion): TgluQuaternion;
begin
Result[quW] := l[quW] - r[quW];
Result[quX] := l[quX] - r[quX];
Result[quY] := l[quY] - r[quY];
Result[quZ] := l[quZ] - r[quZ];
end;

function gluQuaternionScale(const q: TgluQuaternion; const f: Single): TgluQuaternion;
begin
Result[quW] := q[quW] * f;
Result[quX] := q[quX] * f;
Result[quY] := q[quY] * f;
Result[quZ] := q[quZ] * f;
end;

// http://www.euclideanspace.com/maths/geometry/rotations/conversions/quaternionToMatrix/index.htm
function gluQuaternionToMatrix(const q: TgluQuaternion): TgluMatrix4f;
var
qx,qy,qz,qw: Single;
begin
qw:= q[quW];
qx:= q[quX];
qy:= q[quY];
qz:= q[quZ];
Result:= gluMatrixIdentity;
Result[maAxisX] := gluVector4f(
1 - 2*SQR(qy) - 2*SQR(qz),
2*qx*qy + 2*qz*qw,
2*qx*qz - 2*qy*qw,
0);
Result[maAxisY] := gluVector4f(
2*qx*qy - 2*qz*qw,
1 - 2*SQR(qx) - 2*SQR(qz),
2*qy*qz + 2*qx*qw,
0);
Result[maAxisZ] := gluVector4f(
2*qx*qz + 2*qy*qw,
2*qy*qz - 2*qx*qw,
1 - 2*SQR(qx) - 2*SQR(qy),
0);
end;

// http://www.euclideanspace.com/maths/geometry/rotations/conversions/matrixToQuaternion/index.htm
function gluMatrixToQuaternion(const m: TgluMatrix4f): TgluQuaternion;
var
trace, s: double;
q: TgluQuaternion;

begin
trace := m[0][0] + m[1][1] + m[2][2]; // I removed + 1.0f; see discussion with Ethan
if( trace > 0 ) then begin// I changed M_EPSILON to 0
s := 0.5 / SQRT(trace+ 1.0);
q[quW] := 0.25 / s;
q[quX] := ( m[2][1] - m[1][2] ) * s;
q[quY] := ( m[0][2] - m[2][0] ) * s;
q[quZ] := ( m[1][0] - m[0][1] ) * s;
end else begin
if ( m[0][0] > m[1][1]) and (m[0][0] > m[2][2] ) then begin
s := 2.0 * SQRT( 1.0 + m[0][0] - m[1][1] - m[2][2]);
q[quW] := (m[2][1] - m[1][2] ) / s;
q[quX] := 0.25 * s;
q[quY] := (m[0][1] + m[1][0] ) / s;
q[quZ] := (m[0][2] + m[2][0] ) / s;
end else if (m[1][1] > m[2][2]) then begin
s := 2.0 * SQRT( 1.0 + m[1][1] - m[0][0] - m[2][2]);
q[quW] := (m[0][2] - m[2][0] ) / s;
q[quX] := (m[0][1] + m[1][0] ) / s;
q[quY] := 0.25 * s;
q[quZ] := (m[1][2] + m[2][1] ) / s;
end else begin
s := 2.0 * SQRT( 1.0 + m[2][2] - m[0][0] - m[1][1] );
q[quW] := (m[1][0] - m[0][1] ) / s;
q[quX] := (m[0][2] + m[2][0] ) / s;
q[quY] := (m[1][2] + m[2][1] ) / s;
q[quZ] := 0.25 * s;
end;
end;
Result:= q;
end;

// http://www.euclideanspace.com/maths/geometry/rotations/conversions/quaternionToAngle/index.htm
function gluQuaternionToRotation(const q: TgluQuaternion; out angle: Single): TgluVector3f;
var
s: double;
begin
angle := radtodeg(2 * arccos(q[quW]));
s := sqrt(1-q[quW]*q[quW]); // assuming quaternion normalised then w is less than 1, so term always positive.
if (s < 0.001) then begin // test to avoid divide by zero, s is always positive due to sqrt
// if s close to zero then direction of axis not important
Result[0] := q[quX]; // if it is important that axis is normalised then replace with x=1; y=z=0;
Result[1] := q[quY];
Result[2] := q[quZ];
end else begin
Result[0] := q[quX] / s; // normalise axis
Result[1] := q[quY] / s;
Result[2] := q[quZ] / s;
end;
end;

function gluRotationToQuaternion(const angle: Single; const axis: TgluVector3f): TgluQuaternion;
var
a: single;
begin
a:= degtorad(angle) / 2;
Result:= gluQuaternion(
cos(a),
sin(a) * axis[0],
sin(a) * axis[1],
sin(a) * axis[2]);
end;

// http://www.euclideanspace.com/maths/algebra/realNormedAlgebra/quaternions/transforms/index.htm
function gluQuaternionTransformVec(const q: TgluQuaternion; const v: TgluVector3f): TgluVector3f;
var
p: TgluQuaternion;
begin
//Pout = q * Pin * q'
p:= gluQuaternionMultiply(q, gluVectorToQuaternion(v));
p:= gluQuaternionMultiply(p, gluQuaternionConjugate(q));
Result:= gluQuaternionToVector(p);
end;

// http://www.euclideanspace.com/maths/algebra/realNormedAlgebra/quaternions/transforms/halfAngle.htm
function gluQuaternionHalfAngle(const q: TgluQuaternion): TgluQuaternion;
begin
Result:= q;
Result[quW]:= Result[quW] + 1;
gluQuaternionNormalizeInplace(Result);
end;

function gluQuaternionAngleBetween(const a, b: TgluQuaternion): double;
var
cosHalfTheta: double;
begin
cosHalfTheta:= a[quW] * b[quW] + a[quX] * b[quX] + a[quY] * b[quY] + a[quZ] * b[quZ];
Result:= arccos(cosHalfTheta) * 2;
end;

// http://www.euclideanspace.com/maths/algebra/realNormedAlgebra/quaternions/slerp/index.htm
function gluQuaternionSlerpOrientation(const a, b: TgluQuaternion; const t: single): TgluQuaternion;
var
qa,qb: TgluQuaternion;
cosHalfTheta, sinHalfTheta,
halfTheta,
ratioA, ratioB: double;
begin
qa:= a;
qb:= b;
// Calculate angle between them.
cosHalfTheta:= a[quW] * b[quW] + a[quX] * b[quX] + a[quY] * b[quY] + a[quZ] * b[quZ];
if (cosHalfTheta < 0) then begin
qb:= gluQuaternion(
-b[quW],
-b[quX],
-b[quY],
b[quZ]
);
cosHalfTheta:= -cosHalfTheta;
end;

// if qa=qb or qa=-qb then theta = 0 and we can return qa
if abs(cosHalfTheta) >= 1.0 then begin
Result:= qa;
Exit;
end;

// Calculate temporary values.
halfTheta := arccos(cosHalfTheta);
sinHalfTheta := sqrt(1.0 - sqr(cosHalfTheta));
// if theta = 180 degrees then result is not fully defined
// we could rotate around any axis normal to qa or qb
if (abs(sinHalfTheta) < 0.001) then begin
Result:= gluQuaternionAdd(gluQuaternionScale(qa, 0.5), gluQuaternionScale(qb, 0.5));
exit
end;
ratioA := sin((1 - t) * halfTheta) / sinHalfTheta;
ratioB := sin(t * halfTheta) / sinHalfTheta;
//calculate Quaternion.
Result:= gluQuaternionAdd(gluQuaternionScale(qa, ratioA), gluQuaternionScale(qb, ratioB));
end;

function gluQuaternionNlerpOrientation(const a, b: TgluQuaternion; const t: single): TgluQuaternion;
begin
Result:= gluQuaternionAdd(a, gluQuaternionScale(gluQuaternionSubtract(b,a), t));
gluQuaternionNormalizeInplace(Result);
end;

function gluQuaternionLookAt(const Location, Target, UpVector: TgluVector3f): TgluQuaternion;
var
front, up, right: TgluVector3f;
w4_recip: Single;
begin
front:= gluVectorSubtract(Location, Target); // eigentlich falschrum. don't ask.
up:= UpVector;
gluVectorOrthoNormalize(front, up);
right:= gluVectorProduct(up, front);

Result[quW]:= SQRT(1 + right[0] + up[1] + front[2]) * 0.5;
w4_recip:= 1 / (4 * Result[quW]);

Result[quX]:= (front[1] - up[2]) * w4_recip;
Result[quY]:= (right[2] - front[0]) * w4_recip;
Result[quZ]:= (up[0] - right[1]) * w4_recip;
end;

function gluVectorRotationTo(const a, b: TgluVector3f): TgluQuaternion;
var
d, qw: single;
ax: TgluVector3f;
begin
d:=gluVectorScalar(a, b);
ax:= gluVectorProduct(a, b);
qw:= gluVectorLength(a) * gluVectorLength(b) + d;
if (qw < 0.0001) then begin // vectors are 180 degrees apart
Result:= gluQuaternion(0, -a[2],a[1],a[0]);
end else begin
Result:= gluQuaternion(qw, ax[0],ax[1],ax[2]);
end;
gluQuaternionNormalizeInplace(Result);
end;

end.


+ 1193
- 0
ugluVector.pas
File diff suppressed because it is too large
View File


Loading…
Cancel
Save