{
        This Code Was Created By Jan Koci 2001
        Visit My Site At koci.opengl.cz
}

unit DXF_f;


interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  OpenGL, jpeg, Menus;


type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    LoadDXF1: TMenuItem;
    Load1: TMenuItem;
    OpenDialog1: TOpenDialog;
    Speed1: TMenuItem;
    N1x1: TMenuItem;
    N10x1: TMenuItem;
    N20x1: TMenuItem;
    ResetPosition1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ClearFace(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure Load1Click(Sender: TObject);
    procedure N1x1Click(Sender: TObject);
    procedure N10x1Click(Sender: TObject);
    procedure N20x1Click(Sender: TObject);
    procedure ResetPosition1Click(Sender: TObject);

  end;

    procedure InitScene;
    procedure LoadDXF(filename:string);   //Load DXF
    procedure InitWindow;
    procedure PixelFormat(DC : HDC);
    procedure InitArea;
    procedure InitTriangleTexture;
    procedure DrawTriangles;
    procedure MoveObject;
    procedure DrawScene;
    procedure SetFullScreen(SizeX,SizeY,Bits:longint);
    procedure RestoreMode;
    procedure ProcessKeyb;
    procedure InitTexture;
    procedure LoadTexture(Num:LongInt;FileName:string;Typ:word);
    procedure LoadPicture(FileName:String;var Pic:TPicture);
    procedure StoreTexture(Num:LongInt;Pic:TPicture);
    procedure SetTexture(Num:Longint;Typ:word);

//Textures
type TRGBByte=record
     r: byte;
     g: byte;
     b: byte;
end;
type TRGBAByte=record
     r: byte;
     g: byte;
     b: byte;
     a: byte;
end;

type TRGBColors=array[1..1024*1024] of TRGBByte;
     TRGBAColors=array[1..1024*1024] of TRGBAByte;

type TTexture=record
     ColorSystem:TGLEnum;
     FileName:String;
     rgbcolor:^TRGBColors;
     rgbacolor:^TRGBAColors;
     Width:Word;
     Height:Word;
     Mip:boolean;
end;




//Triangles
type TPoint3=record
     x: double;
     y: double;
     z: double;
end;

type TPoint2=record
     x: double;
     y: double;
end;

var
  Point1, Point2, Point3: array [0..100000] of TPoint3;
  Coord1, Coord2, Coord3: array [0..100000] of TPoint2;
  TriangleMax: integer;


//other
var
  Form1: TForm1;
  Handles : integer;
  ThreadID : LongWord;
  TextureBin:array[1..256] of word;
  TextureH:TTexture;
  Texture:array[1..256] of TTexture;
  UniPicture:TPicture;
  a: real;
  Angle, Tran: TPoint3;
  KeybUp, KeybDown, KeybRight, KeybLeft, KeybHome, KeybEnd, KeybEsc, KeybMoveUp, KeybMoveDown: boolean;
  RC : HGLRC;
  MoveSpeed: integer=1;

const PFDError = 'Chyba poi nastavení PFD.';


implementation


{$R *.DFM}




function Thread(P : pointer) : integer;
var
  i: integer;
begin
  i := 1;
  repeat
    Form1.Repaint;
  until
    i = 2;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  InitScene;
end;

procedure InitScene;
begin
  Tran.Z := -30;

  InitWindow;
  InitArea;
  Handles := BeginThread(nil, 0, Thread, nil, 0, ThreadID);

end;

///////////////////////////////  LoadDXF
procedure TForm1.Load1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then begin
  LoadDXF(OpenDialog1.FileName);
end;
end;

procedure LoadDXF(filename:String);
var sou:textfile;
    L1:longint;
    S1:String;

function LoadString:String;
var St:String;
    L1:longint;
begin
     readln(sou,St);
     for L1:=1 to length(St) do if St[L1]='.' then St[L1]:=',';
     LoadString:=St;
end;

function LoadLong:longint;
var S1:String;
    L1:longint;
begin
    readln(sou,S1);L1:=Strtoint(S1);LoadLong:=L1;
end;


begin
   AssignFile(sou,filename);reset(sou);
   L1:=LoadLong;S1:=LoadString;
   TriangleMax := 0;
   if (L1<>0) or (S1<>'SECTION') then begin close(sou);exit;end;
   repeat
   L1:=LoadLong;S1:=LoadString;
   if L1=10 then begin  TriangleMax := TriangleMax + 1;
                        Point1[TriangleMax].x := StrToFloat(S1);end;
   if L1=20 then begin  Point1[TriangleMax].z := StrToFloat(S1) end;
   if L1=30 then begin  Point1[TriangleMax].y := StrToFloat(S1) end;
   if L1=11 then begin  Point2[TriangleMax].x := StrToFloat(S1) end;
   if L1=21 then begin  Point2[TriangleMax].z := StrToFloat(S1) end;
   if L1=31 then begin  Point2[TriangleMax].y := StrToFloat(S1) end;
   if L1=12 then begin  Point3[TriangleMax].x := StrToFloat(S1) end;
   if L1=22 then begin  Point3[TriangleMax].z := StrToFloat(S1) end;
   if L1=32 then begin  Point3[TriangleMax].y := StrToFloat(S1) end;
   until (S1='EOF');
   close(sou);
end;
//////////////////////  end Load DXF


procedure InitWindow;
var
  i: integer;
begin
  PixelFormat(Form1.Canvas.Handle);
  RC := wglCreateContext(Form1.Canvas.Handle);
  wglMakeCurrent(Form1.Canvas.Handle,RC);
  glClearColor(0.0,0.0,0.0,0.0);
  glShadeModel(GL_SMOOTH);
  glEnable(GL_DEPTH_TEST);
  InitTriangleTexture;
  wglMakeCurrent(0,0);
end;

procedure PixelFormat(DC : HDC);
var PFD : TPixelFormatDescriptor;
    nPixelFormat : integer;
begin
  FillChar(PFD,SizeOf(PFD),0);
  with PFD do
    begin
       nSize := SizeOf(TPixelFormatDescriptor);
       nVersion := 1;
       dwFlags := PFD_DRAW_TO_WINDOW or
                  PFD_SUPPORT_OPENGL or
                  PFD_DOUBLEBUFFER;
       iPixelType := PFD_TYPE_RGBA;
       cColorBits := 24;
       cDepthBits   := 32;
       iLayerType   := PFD_MAIN_PLANE;
    end;
  nPixelFormat := ChoosePixelFormat(DC,@PFD);
  Assert(nPixelFormat <> 0,PFDError);
  SetPixelFormat(DC,nPixelFormat,@PFD)
end;

procedure InitArea;
begin
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity;
  gluPerspective(30.0,Form1.ClientWidth / Form1.ClientHeight,0.1,100000);
  glViewport(0,0,Form1.ClientWidth,Form1.ClientHeight);
end;

procedure InitTriangleTexture;
var
  Path: string;
begin
  Path := ExtractFilePath(Application.ExeName);
  InitTexture;
  LoadTexture(1,Path + 'drat.jpg',gl_rgb8);
end;

procedure DrawTriangles;
var
  i,j: integer;
begin
      glPushMatrix;
        glBindTexture(GL_TEXTURE_2D, TextureBin[1]);
        glEnable(GL_TEXTURE_2D);

        for i := 1 to TriangleMax do begin
        Coord1[i].x := 0;
        Coord1[i].y := 0;
        Coord2[i].x := 1;
        Coord2[i].y := 0;
        Coord3[i].x := 0;
        Coord3[i].y := 1;

        glBegin(GL_TRIANGLES);
          glTexCoord2f(Coord1[i].x,Coord1[i].y);
          glVertex3f(Point1[i].x,Point1[i].y,Point1[i].z);

          glTexCoord2f(Coord2[i].x,Coord2[i].y);
          glVertex3f(Point2[i].x,Point2[i].y,Point2[i].z);

          glTexCoord2f(Coord3[i].x,Coord3[i].y);
          glVertex3f(Point3[i].x,Point3[i].y,Point3[i].z);
        glEnd;
        end;
      glPopMatrix;
end;

procedure MoveObject;
begin
  ProcessKeyb;
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
  glTranslatef(0,0,0);
  glRotatef(Angle.x, 1, 0, 0);
  glRotatef(Angle.y, 0, 1, 0);
  glRotatef(Angle.z, 0, 0, 1);
  glTranslatef(Tran.X,Tran.Y,Tran.Z);
end;

procedure DrawScene;
begin
  wglMakeCurrent(Form1.Canvas.Handle,RC);
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  MoveObject;
  DrawTriangles;
  glFlush;
  SwapBuffers(Form1.Canvas.Handle);
  wglMakeCurrent(0,0)
end;

procedure SetFullScreen(SizeX,SizeY,Bits:longint);
var dmScreenSettings: DEVMODE;
begin
  ZeroMemory( @dmScreenSettings, sizeof( DEVMODE ) );
  dmScreenSettings.dmSize := sizeof( DEVMODE );
  dmScreenSettings.dmPelsWidth  := SizeX; // Width
  dmScreenSettings.dmPelsHeight := SizeY; // Height
  dmScreenSettings.dmFields     := DM_PELSWIDTH or DM_PELSHEIGHT; // Color Depth
  dmScreenSettings.dmBitsPerPel := Bits;
  ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN); // Switch To Fullscreen Mode

  Form1.WindowState := wsMaximized;
end;

procedure RestoreMode;
begin
  ChangeDisplaySettings(DEVMODE(nil^), 0);
end;

procedure InitTexture;
var a:word;
    f:TGluint;
begin
     UniPicture:=TPicture.Create;
     for a:=1 to 256 do begin
         glGenTextures(1, @f);TextureBin[a]:=f;
     end;
     for a:=1 to 256 do begin
         with texture[a] do begin
            rgbacolor:=nil;
            rgbcolor:=nil;
            ColorSystem:=Gl_RGB;
            glBindTexture(GL_TEXTURE_2D,TextureBin[a]);
            glTexParameterf(GL_Texture_2D,GL_Texture_Wrap_S,gl_repeat);
            glTexParameterf(GL_Texture_2D,GL_Texture_Wrap_T,gl_repeat);
            glTexParameterf(GL_Texture_2D,GL_Texture_Mag_Filter,GL_Linear);
            glTexParameterf(GL_Texture_2D,GL_Texture_Min_Filter,GL_Linear);
            glTexEnvf(GL_Texture_Env, GL_Texture_Env_Mode, GL_MODULATE);
         end;
     end;
end;

procedure LoadTexture(Num:LongInt;FileName:string;Typ:word);
begin
  if (Typ=gl_rgba2) or (Typ=gl_rgba4) or (Typ=gl_rgba8) or (Typ=gl_rgba16) then texture[num].colorsystem:=gl_rgba else texture[num].colorsystem:=gl_rgb;
    LoadPicture(FileName,UniPicture);
    texture[num].filename:=ExtractFileName(FileName);
    StoreTexture(Num,UniPicture);
    SetTexture(Num,Typ);
end;

procedure LoadPicture(FileName:String;var Pic:TPicture);
var Y:TPicture;
    temp:boolean;
    searchrec:tsearchrec;
begin
  filename:=uppercase(filename);
  if findfirst(filename,$3f,searchrec)<>0 then begin
     MessageDlg('Picture '+filename+' not found !!!', mtError, [mbOK], 0);
     halt;
  end;
  if ExtractFileExt(FileName)='.JPG' then begin
     Y:=TPicture.Create;
     Y.LoadFromFile(FileName);
     temp:=y.Graphic is TJPEGImage;
     if temp then begin
        Pic.Bitmap.Width:=y.Graphic.Width;
        Pic.Bitmap.Height:=y.Graphic.Height;
        Pic.Bitmap.Canvas.draw(0,0,Y.Graphic);
     end;
     Y.Free;
  end;
  if ExtractFileExt(FileName)='.BMP' then begin
     Pic.LoadFromFile(FileName);
  end;
end;

procedure StoreTexture(Num:LongInt;Pic:TPicture);
var bih : TBitmapInfoHeader;
    bi : TBitmapInfo;
    poz,poz2:longint;
    i,j : longint;
begin
  with Texture[Num] do begin
      Width:=Pic.Bitmap.Width;Height:=Pic.Bitmap.Height;
      TextureH.rgbcolor:=AllocMem(Width*Height*sizeof(TRGBByte));
  end;
  with bih do begin
      biSize:=SizeOf(bih);
      biWidth:=Pic.width;biHeight:=Pic.height;
      biPlanes:=1;biBitCount:=24;biCompression:=BI_RGB;
      biSizeImage:=Pic.width;
      biXPelsPerMeter:=0;biYPelsPerMeter:=0;biClrImportant:=0;
      biClrUsed := 0;
  end;
  bi.bmiHeader := bih;
  GetDIBits(Pic.Bitmap.Canvas.Handle,Pic.Bitmap.Handle,0,Pic.width,textureH.rgbcolor,bi,dib_rgb_colors);
  with Texture[Num] do begin
    if ColorSystem=GL_RGB then begin
       rgbcolor:=AllocMem(Width*Height*sizeof(TRGBByte));
       for i := 0 to Pic.height-1 do begin
         for j := 1 to Pic.width do begin
           poz:=j+i*texture[num].width;
           poz2:=j+((pic.height-1)-i)*texture[num].width;
           with texture[num].rgbcolor^[poz2] do begin
             r:=textureH.rgbcolor^[poz].b;
             g:=textureH.rgbcolor^[poz].g;
             b:=textureH.rgbcolor^[poz].r;
           end;
         end;
       end;
    end else begin
       rgbacolor:=AllocMem(Width*Height*sizeof(TRGBAByte));
       for i := 0 to Pic.height-1 do begin
         for j := 1 to Pic.width do begin
           poz:=j+i*texture[num].width;
           poz2:=j+((pic.height-1)-i)*texture[num].width;
           with texture[num].rgbacolor^[poz2] do begin
             r:=textureH.rgbcolor^[poz].b;
             g:=textureH.rgbcolor^[poz].g;
             b:=textureH.rgbcolor^[poz].r;
             if r+g+b=0 then a:=0 else a:=255;
           end;
         end;
       end;
    end;
  end;
  FreeMem(TextureH.rgbcolor);
end;

procedure SetTexture(Num:Longint;Typ:word);
begin
  with Texture[Num] do begin
    Mip:=false;
    glBindTexture(GL_TEXTURE_2D,TextureBin[num]);
    if ColorSystem=GL_RGB then begin
       glTexImage2d(GL_Texture_2D,0,TYP,width,height,0,GL_RGB,GL_Unsigned_byte,rgbcolor);
    end else begin
       glTexImage2d(GL_Texture_2D,0,TYP,width,height,0,GL_RGBA,GL_Unsigned_byte,rgbacolor);
    end;
  end;
end;

procedure TForm1.ClearFace(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  wglDeleteContext(RC);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  DrawScene;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  wglMakeCurrent(Canvas.Handle,RC);
  InitArea;
  DrawScene;
  wglMakeCurrent(0,0);
end;


procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  case Key of
    VK_UP: begin  //Forward
       KeybUp := True;
    end;
  end;
  case Key of
    VK_DOWN: begin //Backward
      KeybDown := True;
    end;
  end;
  case Key of
    VK_RIGHT: begin //Rotate right
      KeybRight := True;
    end;
  end;
  case Key of
    VK_LEFT: begin //Rotate left
      KeybLeft := True;
    end;
  end;
  case Key of
    VK_Home: begin //Look up
      KeybHome := True;
    end;
  end;
  case Key of
    VK_END: begin //Look down
      KeybEnd := True;
    end;
  end;
  case Key of
    27: begin //Q - Quit
      Application.Terminate;
      RestoreMode;
    end;
  end;
  case Key of
    VK_Return: begin //Full Screen
      SetFullScreen(640,480,16);
    end;
  end;
  case Key of
    VK_Prior: begin //move up
      KeybMoveUp := True;
    end;
  end;
  case Key of
    VK_Next: begin //move down
      KeybMoveDown := True;
    end;
  end;
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  case Key of
    VK_UP: begin  //Forward
       KeybUp := False;
    end;
  end;
  case Key of
    VK_DOWN: begin //Backward
      KeybDown := False;
    end;
  end;
  case Key of
    VK_RIGHT: begin //Rotate right
      KeybRight := False;
    end;
  end;
  case Key of
    VK_LEFT: begin //Rotate left
      KeybLeft := False;
    end;
  end;
  case Key of
    VK_Home: begin //Look up
      KeybHome := False;
    end;
  end;
  case Key of
    VK_END: begin //Look down
      KeybEnd := False;
    end;
  end;
  case Key of
    VK_Prior: begin //move up
      KeybMoveUp := False;
    end;
  end;
  case Key of
    VK_Next: begin //move down
      KeybMoveDown := False;
    end;
  end;
end;

procedure ProcessKeyb;
begin
  if KeybUp then begin
    Tran.Z := Tran.Z + ((-sin((Angle.Y - 90) * (Pi/180))) *  MoveSpeed);
    Tran.X := Tran.X - ((sin((Angle.Y) * (Pi/180))) *  MoveSpeed);
  end;
  if KeybDown then begin
      Tran.Z := Tran.Z - ((-sin((Angle.Y - 90) * (Pi/180))) *  MoveSpeed);
      Tran.X := Tran.X + ((sin((Angle.Y) * (Pi/180))) *  MoveSpeed);
  end;
  if KeybRight then begin
      Angle.Y := Angle.Y + 5;
  end;
  if KeybLeft then begin
      Angle.Y := Angle.Y - 5;
  end;
  if KeybHome then begin
      Angle.X := Angle.X - 5;
  end;
  if KeybEnd then begin
      Angle.X := Angle.X + 5;
  end;
  if KeybMoveUp then begin
    Tran.Y := Tran.Y - MoveSpeed;
  end;
  if KeybMoveDown then begin
    Tran.Y := Tran.Y + MoveSpeed;
  end;
end;


procedure TForm1.N1x1Click(Sender: TObject);
begin
   MoveSpeed := 1;
   N1x1.Checked := True;
   N10x1.Checked := False;
   N20x1.Checked := False;
end;


procedure TForm1.N10x1Click(Sender: TObject);
begin
   MoveSpeed := 10;
   N1x1.Checked := False;
   N10x1.Checked := True;
   N20x1.Checked := False;
end;

procedure TForm1.N20x1Click(Sender: TObject);
begin
   MoveSpeed := 50;
   N1x1.Checked := False;
   N10x1.Checked := False;
   N20x1.Checked := True;
end;

procedure TForm1.ResetPosition1Click(Sender: TObject);
begin
  Tran.x := 0;
  Tran.y := 0;
  Tran.z := -30;
  Angle.x := 0;
  Angle.y := 0;
  Angle.z := 0;
end;

end.