unit ObjectGL;

interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
 Forms, Dialogs,
 OpenGL, OBGLFunc, ImagingTypes, Imaging, ImagingClasses, ImagingCanvases;


procedure glGenTextures(n: GLsizei; var textures: GLuint); stdcall; external opengl32;
procedure glBindTexture(target: GLenum; texture: GLuint); stdcall; external opengl32;
procedure glDeleteTextures(n: GLsizei; var textures: GLuint); stdcall; external opengl32;
function glIsTexture(texture: gluint):GLboolean; stdcall; external opengl32;


type
 imgCoord = word;
 float = single;
 TPoint3D = record
  x, y, z: glFloat;
 end;
 TPoint3DGL = record
  x, y, z: glFloat;
  res: glFloat;
 end;
 TPointUV = record
  u, v: float;
 end;
 TColorRGBA = record
  r, g, b, a: glFloat;
 end;
 PColorRGBA = ^TColorRGBA;
 TColorRGB = record
  r, g, b: byte;
 end;
 TColorARGBb = record
  a,r,g,b: byte;
 end;
 TColorRGBAb = record
  r,g,b,a: byte;
 end;

 TImageBytes = array of byte;
 PImageBytes = ^TImageBytes;

 TTexture = class
 public
  Data: TImageBytes;
  id: gluint;
  Width: imgCoord;
  Height: imgCoord;
  FileName: string;
  UseAlpha: bool;
//  procedure AssignBitmap(bmp:TBitmap);
//  procedure AssignPng(bmp:TPNGGraphic);
  procedure LoadFromFile(AFileName:string);
  procedure PrepareTexture(UseMipmaps:bool=true);
  procedure BeforeUse;
  constructor Create;
  destructor Free;
 end;

 TColorSettings = record
  Ambient, Diffuse, Specular: TColorRGBA;
 end;

 TMaterial = class
 private
  function GetAmbientPtr: PColorRGBA;
  function GetDiffusePtr: PColorRGBA;
  function GetSpecularPtr: PColorRGBA;
 public
  Shininess: float;
  UseTexture: bool;
  Texture: TTexture;
  Color: TColorSettings;
  property Ambient: TColorRGBA read Color.Ambient write Color.Ambient;
  property Diffuse: TColorRGBA read Color.Diffuse write Color.Diffuse;
  property Specular: TColorRGBA read Color.Specular write Color.Specular;
  property AmbientPtr: PColorRGBA read GetAmbientPtr;
  property DiffusePtr: PColorRGBA read GetDiffusePtr;
  property SpecularPtr: PColorRGBA read GetSpecularPtr;
  procedure SetMaterial;
  constructor Create;
  destructor Destroy; override;
 end;

 TLightNumber = GL_LIGHT0..GL_LIGHT7;
 TLight = class
 public
  Position: TPoint3DGL;
  Color: TColorSettings;
  Id: TLightNumber;
  property Ambient: TColorRGBA read Color.Ambient write Color.Ambient;
  property Diffuse: TColorRGBA read Color.Diffuse write Color.Diffuse;
  property Specular: TColorRGBA read Color.Specular write Color.Specular;
  procedure SetLight;
 end;

 TCamera = class
 public
  Eye: TPoint3DGL;
  LookAt: TPoint3DGL;
  
 end;

 TVertex = record
  Position: TPoint3D;
  TextureCoords: TPointUV;
 end;
 TVertexes = array[0..2] of TVertex;
 TTriangle = record
  Material: TMaterial;
  Vertexes: TVertexes;
 end;
 TTriangles = array of TTriangle;
 TPoints3DArray = array of TPoint3D;
 TPointsUVArray = array of TPointUV;

 TModel = class
 private
  ListId: Cardinal;
 public
  Triangles: TTriangles;
  Position: TPoint3D;
  Orientation: TPoint3D;
  Scale: TPoint3D;
  UsedTextures: TList;
  procedure Prepare;
  procedure Display;
  procedure LoadFromObjFile(AFileName:string);
  constructor Create;
  destructor Free;
//  procedure Create;
//  procedure Destroy; override;
 end;

 TOpenglOutput = class
 private
  DC: HDC;
  RC: HGLRC;
  FControl: TWinControl;
  FPixelFormat: TPixelFormatDescriptor;
  procedure SetupPixelFormat(const pf:TPixelFormatDescriptor);
  procedure SetControl(ctl: TWinControl);
 public
  property Control: TWinControl read FControl write SetControl;
  procedure MakeCurrent;
  property PixelFormat: TPixelFormatDescriptor read FPixelFormat write SetupPixelFormat;
  procedure EnableFeature(cap: Cardinal);
  procedure DisableFeature(cap: Cardinal);
  procedure SetLightStatus(s: byte);
  procedure PreRender;
  procedure PostRender;
  procedure UpdateSize;
 end;
 EObjectGLError = class(Exception);
 EOpenglError = class(EObjectGLError);
 EInvalidObjFormat = class(EObjectGLError);
 EInvalidMtlFormat = class(EObjectGLError);



function RGBA(const r, g, b: float; const a: float = 1):TColorRGBA;
function Point3DGL(const x, y, z: float): TPoint3DGL;
function Point3D(const x, y, z: float): TPoint3D;
function ColorToRGB(cl:TColor):TColorRGB;
function PointUV(const u,v:float): TPointUV;

const
 OBGL_DEFAULT_PIXELFORMAT: TPixelFormatDescriptor = (
  nSize: sizeof(TPixelFormatDescriptor);
  nVersion: 1;
  dwFlags: PFD_SUPPORT_OPENGL or PFD_DRAW_TO_WINDOW or PFD_DOUBLEBUFFER;
  iPixelType: PFD_TYPE_RGBA;
  cColorBits: 24;
  cRedBits: 0; cRedShift: 0;
  cGreenBits: 0; cGreenShift: 0;
  cBlueBits: 0; cBlueShift: 0;
  cAlphaBits: 0;  cAlphaShift: 0;
  cAccumBits: 0;
  cAccumRedBits: 0;
  cAccumGreenBits: 0;
  cAccumBlueBits: 0;
  cAccumAlphaBits: 0;
  cDepthBits: 32;
  cStencilBits: 0;
  cAuxBuffers: 0;
  iLayerType: PFD_MAIN_PLANE;
  bReserved: 0;
  dwLayerMask: 0;
  dwVisibleMask: 0;
  dwDamageMask: 0;
 );


implementation

procedure DisplayOpenglError;
var r:cardinal;
begin
 r := glGetError;
 if r<>0 then raise EOpenglError.Create('OpenGL error number '+IntToStr(r)+'.'#13+
  'Description: '+String(gluErrorString(r))+#13#13#13+
  'This error message has been generated by ObjectGL, not OpenGL.');
end;

procedure TModel.Prepare;
var i:integer; j:byte; vert:TVertex; lastmtl:TMaterial; changemtl:bool;
begin
 ListId := glGenLists(1);
 glNewList(ListId, GL_COMPILE);
 lastmtl := nil;
 for i := 0 to Length(Triangles)-1 do begin
  changemtl := lastmtl<>Triangles[i].Material;
  if ChangeMtl and (Triangles[i].Material<>nil) then
   Triangles[i].Material.SetMaterial;
  glBegin(GL_TRIANGLES);
  for j := 0 to 2 do begin
   vert := Triangles[i].Vertexes[j];
   glTexCoord2f(vert.TextureCoords.u, vert.TextureCoords.v);
   glVertex3f(vert.Position.x, vert.Position.y, vert.Position.z);
  end;
  glEnd;
 end;
 glEndList;
end;

procedure TModel.Display;
begin
 glPushMatrix;
 glTranslatef(Position.x, position.y, position.z);
 glRotatef(orientation.x, 1,0,0);
 glRotatef(orientation.y, 0,1,0);
 glRotatef(orientation.z, 0,0,1);
 glScalef(Scale.x, Scale.y, Scale.z);
 glCallList(ListId);
 glPopMatrix;
end;

constructor TModel.Create;
begin
 inherited Create;
 UsedTextures := TList.Create;
end;

destructor TModel.Free;
var i:integer;
begin
 for i := 0 to UsedTextures.Count-1 do TTexture(UsedTextures[i]).Free;
 glDeleteLists(ListId, 1);
end;


function Float2Str(f:float):string;
begin
 Result := StringReplace(FloatToStrF(f,ffFixed,12,5),',','.',[]);
end;
function Str2Float(s:string):float;
begin
 Result := StrToFloat(StringReplace(s,'.',',',[]));
end;

procedure ExplodeSpaceDivided(List:TStringList; text:string);
var i:integer;s:string; wasdiv:bool; ch:char;
begin
 wasdiv := false;
 for i := 1 to Length(text) do begin
 ch := text[i];
  if (ch=#32) or (ch=#7) then begin
   if not wasdiv then begin
    List.Add(s);
    s := '';
    wasdiv := true;
   end;
  end else begin
   s := s+text[i];
   wasdiv := false;
  end;
 end;
 if s<>'' then
  List.Add(s);
end;


procedure Explode(List:TStringList; seperator:char; text:string);
var i:integer;s:string; wasdiv:bool;
begin
 //wasdiv := false;
 for i := 1 to Length(text) do begin
  if text[i]=seperator then begin
   List.Add(s);
   s := '';
   //wasdiv := true;
  end else s := s+text[i];
 end;
 if s<>'' then
  List.Add(s);
end;

function Cmd2Color(cmd:TStringList):TColorRGBA;
begin
 Result.r := Str2Float(cmd[1]);
 Result.g := Str2Float(cmd[2]);
 Result.b := Str2Float(cmd[3]);
 Result.a := 1;
end;

procedure ReadMtlFile(AFileName:string; Materials:TNamedList; ATextures:TList);
var fsl, cmd:TStringList; i:integer; currmtl:TMaterial; tex:TTexture; cs:string;
 textures:TNamedList;
begin
 fsl := TStringList.Create;
 fsl.LoadFromFile(AFileName);
 textures := TNamedList.Create;
 cmd := TStringList.Create;
 for i := 0 to fsl.Count-1 do begin
  if (fsl[i]='') or (fsl[i][1]='#') then continue;
  cmd.Clear;
  ExplodeSpaceDivided(cmd, fsl[i]);
  if cmd.Count<1 then continue;
  cs := cmd[0];
  if cs='newmtl' then begin
   currmtl := TMaterial.Create;
   currmtl.UseTexture := false;
   Materials.Values[cmd[1]] := currmtl;
  end;
  if cs='Ka' then
   currmtl.Ambient := Cmd2Color(cmd);
  if cs='Kd' then
   currmtl.Diffuse := Cmd2Color(cmd);
  if cs='Ks' then
   currmtl.Specular := Cmd2Color(cmd);
  if (cs='d') or (cs='Tr') then begin
   currmtl.Color.Ambient.a := Str2Float(cmd[1]);
   currmtl.Color.Diffuse.a := currmtl.Ambient.a;
   currmtl.Color.Specular.a := currmtl.Ambient.a;
  end;
  if cs='Ns' then currmtl.Shininess := Str2Float(cmd[1]);
  if (cs='map_Ka') or (cs='map_Kd') or (cs='map_Ks') then begin
   if textures.Values[cmd[1]]=nil then begin
    tex := TTexture.Create;
    tex.LoadFromFile(ExtractFilePath(AFileName)+cmd[1]);
    tex.PrepareTexture;
    textures.Values[cmd[1]] := tex;
    ATextures.Add(tex);
   end else tex := textures.Values[cmd[1]];
   currmtl.Texture := tex;
   currmtl.UseTexture := true;
  end;
 end;


end;

procedure TModel.LoadFromObjFile(AFileName:string);
var fsl, cmd, subcmd:TStringList; i,j:integer;
 Points: TPoints3DArray; TexCoords: TPointsUVArray;
 cs: string; tr: TTriangle; currmtl: TMaterial; Materials:TNamedList;
begin
 Materials := TNamedList.Create;
 fsl := TStringList.Create;
 fsl.LoadFromFile(AFileName);
 cmd := TStringList.Create;
 subcmd := TStringList.Create;
 for i := 0 to fsl.Count-1 do begin
  if (fsl[i]='') or (fsl[i][1]='#') then continue;
  cmd.Clear;
  ExplodeSpaceDivided(cmd, fsl[i]);
  if cmd.Count<1 then continue;
  cs := cmd[0];
  if cs='mtllib' then for j := 1 to cmd.Count-1 do
   ReadMtlFile(ExtractFilePath(AFileName)+cmd[j], Materials, UsedTextures);
  if cs='usemtl' then begin
   currmtl := Materials.Values[cmd[1]];
   if currmtl=nil then raise EInvalidObjFormat.Create(
    'A non-existing material has been used in OBJ file.');
  end;
  if cs='v' then begin
   SetLength(Points, Length(Points)+1);
   Points[Length(Points)-1] := Point3D(Str2Float(cmd[1]),
    Str2Float(cmd[2]),Str2Float(cmd[3]));
  end;
  if cs='vt' then begin
   SetLength(TexCoords, Length(TexCoords)+1);
   TexCoords[Length(TexCoords)-1] := PointUV(Str2Float(cmd[1]),
    1-Str2Float(cmd[2]));
  end;
  if cs='f' then begin
   for j := 0 to 2 do begin
    subcmd.Clear;
    Explode(subcmd, '/', cmd[j+1]);
    if subcmd.Count>0 then
     tr.Vertexes[j].Position := Points[StrToInt(subcmd[0])-1];
    if subcmd.Count>1 then
     tr.Vertexes[j].TextureCoords := TexCoords[StrToInt(subcmd[1])-1];
   end;
   tr.Material := currmtl;
   SetLength(Triangles, Length(Triangles)+1);
   Triangles[Length(Triangles)-1] := tr;
  end;
 end;
end;


procedure TTexture.LoadFromFile(AFileName:string);
var img: TSingleImage; canv:TImagingCanvas; i,j:imgCoord; ap: Cardinal;
 tc: TColor32Rec; pt:Cardinal;
begin
 try
  img := TSingleImage.CreateFromFile(AFileName);
 except
  raise Exception.Create('Error reading image '+FileName);
  exit;
 end;
 FileName := AFileName;
 Width := img.Width;
 Height := img.Height;
 //UseAlpha := img.FormatInfo.HasAlphaChannel;
 UseAlpha := true;
 canv := TImagingCanvas.CreateForImage(img);
 ap := 0;
 pt := GetTickCount;
 SetLength(Data, Height*Width*4);
 for i := 0 to Height-1 do for j := 0 to Width-1 do begin;
  tc := TColor32Rec(canv.Pixels32[j,i]);
  Data[ap] := tc.r;
  Data[ap+1] := tc.g;
  Data[ap+2] := tc.b;
  Data[ap+3] := tc.a;
  ap := ap+4;
 end;
 Application.Title := IntToStr(GetTickCount-pt);
 canv.Free;
 img.Free;
end;

destructor TTexture.Free;
begin
 glDeleteTextures(1, id);
end;

{procedure TTexture.AssignBitmap(bmp:TBitmap);
var i, j: imgCoord; texi: cardinal;
begin
 SetLength(Data, bmp.Width*bmp.Height*3);
 texi := 0;
 Width := bmp.Width;
 Height := bmp.Height;
 for i := 0 to bmp.Height-1 do for j := 0 to bmp.Width-1 do begin
  Data[texi] := GetRValue(bmp.Canvas.Pixels[j,i]);
  Data[texi+1] := GetGValue(bmp.Canvas.Pixels[j,i]);
  Data[texi+2] := GetBValue(bmp.Canvas.Pixels[j,i]);
  texi := texi+3;
 end;
 UseAlpha := false;
end; }


procedure TTexture.PrepareTexture(UseMipmaps:bool=true);
var format: cardinal;
begin
 glGenTextures(1, id);
 glBindTexture(GL_TEXTURE_2D, id);

 if UseAlpha then format := GL_RGBA else format := GL_RGB;
 glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);
 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);
 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
 if UseMipmaps then begin
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR);
  gluBuild2DMipmaps(GL_TEXTURE_2D,GL_RGBA,Width,Height,format,GL_UNSIGNED_BYTE,data);
 end else begin
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
  glTexImage2D(GL_TEXTURE_2D,0,GL_RGBA,Width,Height,0,format,GL_UNSIGNED_BYTE,data);
 end;
 DisplayOpenglError;
end;

procedure TTexture.BeforeUse;
begin
 glBindTexture(GL_TEXTURE_2D, Id);
end;

constructor TTexture.Create;
begin
 UseAlpha := false;
end;


constructor TMaterial.Create;
begin
 UseTexture := false;
end;

destructor TMaterial.Destroy;
begin
end;

function Is2Power(const num:cardinal):smallint;
begin
 asm
   mov EAX, 1
   mov EDX, num
   add EDX, 0
   jz @zp
   mov CX, 0
 @mlp:
   cmp EAX, EDX
   jz @yp
   shl EAX, 1
   add CL, 1
   jz @np
   jmp @mlp
 @yp:
   mov Result, CX
   jmp @endpr
 @zp:
   mov Result, -2
   jmp @endpr
 @np:
   mov Result, -1
 @endpr:
 end;
end;


procedure TOpenglOutput.SetupPixelFormat(const pf:TPixelFormatDescriptor);
begin
 FPixelFormat := pf;
 SetPixelFormat(DC, ChoosePixelFormat(DC, @FPixelFOrmat), @FPixelFOrmat);
end;

procedure TOpenglOutput.SetControl(ctl:TWinControl);
begin
 FControl := ctl;
 DC := GetDC(ctl.Handle);
 SetupPixelFormat(OBGL_DEFAULT_PIXELFORMAT);
 RC := wglCreateContext(DC);
end;

procedure TOpenglOutput.MakeCurrent;
begin
 wglMakeCurrent(DC, RC);
end;

procedure TOpenglOutput.EnableFeature(cap:cardinal);
begin
 MakeCurrent;
 glEnable(cap);
end;

procedure TOpenglOutput.DisableFeature(cap:cardinal);
begin
 MakeCurrent;
 glDisable(cap);
end;

function IsBitHigh(b:cardinal; bitnum:byte):bool;
//var c:byte;
begin
 asm
   mov ECX, 1;
   mov CH, 0;
   mov CL, bitnum;
   rep shl ECX, 1;
   mov EDX, b;
   and EDX, ECX;
   cmp EDX, ECX;
   jz @yes;
   mov Result, false;
   jmp @endpr;
 @yes:
   mov Result, true;
 @endpr:
 end;
end;


procedure TOpenglOutput.SetLightStatus(s:byte);
begin
 if IsBitHigh(s, 0) then EnableFeature(GL_LIGHT0) else DisableFeature(GL_LIGHT0);
 if IsBitHigh(s, 1) then EnableFeature(GL_LIGHT1) else DisableFeature(GL_LIGHT1);
 if IsBitHigh(s, 2) then EnableFeature(GL_LIGHT2) else DisableFeature(GL_LIGHT2);
 if IsBitHigh(s, 3) then EnableFeature(GL_LIGHT3) else DisableFeature(GL_LIGHT3);
 if IsBitHigh(s, 4) then EnableFeature(GL_LIGHT4) else DisableFeature(GL_LIGHT4);
 if IsBitHigh(s, 5) then EnableFeature(GL_LIGHT5) else DisableFeature(GL_LIGHT5);
 if IsBitHigh(s, 6) then EnableFeature(GL_LIGHT6) else DisableFeature(GL_LIGHT6);
 if IsBitHigh(s, 7) then EnableFeature(GL_LIGHT7) else DisableFeature(GL_LIGHT7);
end;


procedure TOpenglOutput.PreRender;
begin
 MakeCurrent;
 glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
 glPushMatrix;
end;

procedure TOpenglOutput.PostRender;
begin
 glPopMatrix;
 glFlush;
 SwapBuffers(wglGetCurrentDC);
end;

procedure TOpenglOutput.UpdateSize;
//var aspect: double;
begin
 with Control do begin
  glViewport(0, 0, ClientWidth, ClientHeight);
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity;
  gluPerspective(60.0, ClientWidth/ClientHeight, 1.0, 1000.0);
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
 end;
end;

function TMaterial.GetAmbientPtr: PColorRGBA;
begin
 Result := @Color.Ambient;
end;

function TMaterial.GetDiffusePtr: PColorRGBA;
begin
 Result := @Color.Diffuse;
end;

function TMaterial.GetSpecularPtr: PColorRGBA;
begin
 Result := @Color.Specular;

end;

procedure TMaterial.SetMaterial;
begin
 glMaterialfv(GL_FRONT_AND_BACK, GL_AMBIENT, @Color.Ambient);
 glMaterialfv(GL_FRONT_AND_BACK, GL_DIFFUSE, @Color.Diffuse);
 glMaterialfv(GL_FRONT_AND_BACK, GL_SPECULAR, @Color.Specular);
 glMaterialf(GL_FRONT_AND_BACK, GL_SHININESS, Shininess);
 if self=nil then
 asm nop end;
 if UseTexture then Texture.BeforeUse;
end;

procedure TLight.SetLight;
begin
 glLightfv(Id, GL_AMBIENT, @Color.Ambient);
 glLightfv(Id, GL_DIFFUSE, @Color.Diffuse);
 glLightfv(Id, GL_SPECULAR, @Color.Specular);
 glLightfv(Id, GL_POSITION, @Position);
end;


function ColorRGB2RGBA(cl:TColorRGB):TColorRGBA;
begin
 Result.r := cl.r/255;
 Result.g := cl.g/255;
 Result.b := cl.b/255;
 Result.a := 1;
end;

function ColorToRGB(cl:TColor):TColorRGB;
begin
 Result.r := GetRValue(cl);
 Result.g := GetGValue(cl);
 Result.b := GetBValue(cl);
end;

function ColorToRGBA(cl:TColor):TColorRGBA;
begin
 Result := ColorRGB2RGBA(ColorToRGB(cl));
end;

function RGBA(const r, g, b: float; const a: float = 1):TColorRGBA;
begin
 Result.r := r;
 Result.g := g;
 Result.b := b;
 Result.a := a;
end;

function Point3D(const x, y, z: float): TPoint3D;
begin
 Result.x := x;
 Result.y := y;
 Result.z := z;
end;

function PointUV(const u,v:float): TPointUV;
begin
 Result.u := u;
 Result.v := v;
end;

function Point3DGL(const x, y, z: float): TPoint3DGL;
begin
 Result.x := x;
 Result.y := y;
 Result.z := z;
 Result.res := 1;
end;

end.
