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

unit Font_f;


interface

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


type
  TForm1 = class(TForm)
    Label1: TLabel;
    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;

  end;

    procedure InitScene;
    procedure InitFont;                //Init Font
    procedure glPrint(text : pchar);   //Print Font
    procedure InitLight;
    procedure InitWindow;
    procedure PixelFormat(DC : HDC);
    procedure InitArea;
    procedure InitFontTexture;        //Init Font Texture
    procedure DrawFont;
    procedure CalcFPS(Step: integer);
    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;

//Font
base:  TGLuint;

//FPS
StartFreq: TLargeInteger;
StartCount,Count1, Count2, FPS: double;
FPSi: integer=2;

//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: double=0.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 := -4;
  Angle.Y := 18;
  InitWindow;
  InitArea;
  CalcFPS(1);
  Handles := BeginThread(nil, 0, Thread, nil, 0, ThreadID);
end;

procedure InitFont;                                     // Build Our Bitmap Font
var font: HFONT;                                        // Windows Font ID
    gmf : array [0..255] of GLYPHMETRICSFLOAT;          // Address Buffer For Font Storage
begin
  base := glGenLists(256);                              // Storage For 256 Characters
  font := CreateFont(-12,                               // Height Of Font
                     0,                                 // Width Of Font
                     0,                                 // Angle Of Escapement
                     0,                                 // Orientation Angle
                     FW_BOLD,                           // Font Weight
                     0,                                 // Italic
                     0,                                 // Underline
                     0,                                 // Strikeout
                     ANSI_CHARSET,                      // Character Set Identifier
                     OUT_TT_PRECIS,                     // Output Precision
                     CLIP_DEFAULT_PRECIS,               // Clipping Precision
                     ANTIALIASED_QUALITY,               // Output Quality
                     FF_DONTCARE or DEFAULT_PITCH,      // Family And Pitch
                     'Comic Sans MS');                  // Font Name

  SelectObject(Form1.Canvas.Handle, font);              // Selects The Font We Want

  wglUseFontOutlines(Form1.Canvas.Handle,               // Select The Current DC
                        0,                              // Starting Character
                        255,                            // Number Of Display Lists To Build
                        base,                           // Starting Display Lists
                        0.0,                            // Deviation From The True Outlines
                        0.3,                            // Font Thickness In The Z Direction
                        WGL_FONT_POLYGONS,              // Use Polygons, Not Lines
                        @gmf);                          // Address Of Buffer To Recieve Data
end;


procedure glPrint(text : pchar);                        // Custom GL "Print" Routine
begin
  if (text = '') then                                   // If There's No Text
          Exit;                                         // Do Nothing

  glPushAttrib(GL_LIST_BIT);                            // Pushes The Display List Bits
  glListBase(base);                                     // Sets The Base Character
  glCallLists(length(text), GL_UNSIGNED_BYTE, text);    // Draws The Display List Text
  glPopAttrib();                                        // Pops The Display List Bits
end;

procedure InitLight;
const
  glfLightAmbient : Array[0..3] of TGLfloat = (0.1, 0.1, 0.1, 1.0);  //GL_AMBIENT = ambientní svitlo, svitlo které záoí i když jsou svitla vypnuta
  glfLightDiffuse : Array[0..3] of TGLfloat = (1.0, 1.0, 1.0, 1.0);  //GL_DIFFUSE = barva svitla, které zdroj vyzaouje do okolí
  glfLightSpecular: Array[0..3] of TGLfloat = (0.5, 0.5, 0.5, 1.0);  //GL_SPECULAR = zrcadlový odraz svitla
  glfLightShininess: TGLFloat = 127;                                 //GL_SHININESS = intenzita svitelného odlesku
  glflightPosition: Array[0..3] of TGLfloat = (-500.0,500.0,1000.0,1.0);   //GL_Position = pozice svitelného bodu v prostoru
  glfSpotDirection: Array[0..3] of TGLfloat = (0.0,0.0,0.0,1.0);    // GL_SPOT_DIRECTION = zadání smiru svitelného kužele
  glfLightEmission: Array[0..3] of TGLfloat = (0.0,0.0,0.0,1.0);     // svitlo, které vyzaouje ureitý objekt, nepusobí jako zdroj svitla
  glfLinearAttenuation: TGLFloat = 0;                                // GL_LINEAR_ATTENUATION = lineární slábnutí intenzity svitla
  glfSpotExponent: TGLFloat = 1;                                     //GL_SPOT_EXPONENT = charakterizuje zpusob rozptylu svitla poi odrazu
  glfSpotCutoff:TGLFloat = 180;                                       //GL_SPOT_CUTOFF = úhel, nímž se kužel svitla rozevírá od své osy

begin
  glEnable(GL_DEPTH_TEST);

  glLightfv(GL_LIGHT0, GL_AMBIENT, @glfLightAmbient);
  glLightfv(GL_LIGHT0, GL_DIFFUSE, @glfLightDiffuse);
  glLightfv(GL_LIGHT0, GL_SPECULAR, @glfLightSpecular);
  glLightfv(GL_LIGHT0, GL_SHININESS, @glfLightShininess);
  glLightfv(GL_LIGHT0, GL_POSITION,@glfLightPosition);
  glLightfv(GL_LIGHT0, GL_SPOT_DIRECTION, @glfSpotDirection);
  glLightfv(GL_LIGHT0, GL_EMISSION, @glfLightEmission);
  glLightfv(GL_LIGHT0, GL_LINEAR_ATTENUATION, @glfLinearAttenuation);
  glLightfv(GL_LIGHT0, GL_SPOT_EXPONENT, @glfSpotExponent);
  glLightfv(GL_LIGHT0, GL_SPOT_CUTOFF, @glfSpotCutoff);

  glEnable(GL_LIGHTING);
  glEnable(GL_LIGHT0);  // první svitlo

end;

procedure InitWindow;
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);
  InitFontTexture;
  InitFont;
  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 InitFontTexture;
var
  Path: string;
begin
  Path := ExtractFilePath(Application.ExeName);
  InitTexture;
  LoadTexture(1,Path + 'glass.jpg',gl_rgb8);
end;

procedure DrawFont;
var
st: string;
ch: pchar;
begin
    //Call calculate FPS
    if FPSi = 2 then begin
      CalcFPS(2);
      FPSi := 3;
    end else begin
      CalcFPS(3);
      FPSi := 2;
    end;
    st := 'FPS:' +IntToStr(Round(FPS));
    Form1.Label1.Caption := st;     //show string in Label1
    ch := PChar(st);

    //Draw 3D Font
    glPrint(ch);
    glBindTexture(GL_TEXTURE_2D, TextureBin[1]);
    glEnable(GL_TEXTURE_2D);
end;



procedure CalcFPS(Step: integer);
var
  i: TLargeInteger;
  FrameTime: double;
begin
  //Calculate start Frequency and start Counter
  if Step = 1 then begin
    QueryPerformanceCounter(i);
    StartCount := i;
    QueryPerformanceFrequency(i);
    StartFreq := i;
    StartCount := StartCount / StartFreq;
  end;

  //Calculate Counter before draw scene
  if Step = 2 then begin
    QueryPerformanceCounter(i);
    Count1 := i / StartFreq;
  end;

  //Calculate Counter after draw scene
  if Step = 3 then begin
    QueryPerformanceCounter(i);
    Count2 := i / StartFreq;
    //calculate FPS
    FrameTime := (Count2 / StartCount) - (Count1 / StartCount);
    FPS :=  1 / FrameTime;
    FPS := FPS / StartCount;
  end;
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);
  InitLight;
end;

procedure DrawScene;
begin
  wglMakeCurrent(Form1.Canvas.Handle,RC);
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  MoveObject;
  DrawFont;
  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);

            glTexGeni(GL_S, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR);
            glTexGeni(GL_T, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR);
            glEnable(GL_TEXTURE_GEN_S);
            glEnable(GL_TEXTURE_GEN_T);

         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 + 3;
  end;
  if KeybLeft then begin
      Angle.Y := Angle.Y - 3;
  end;
  if KeybHome then begin
      Angle.X := Angle.X - 3;
  end;
  if KeybEnd then begin
      Angle.X := Angle.X + 3;
  end;
  if KeybMoveUp then begin
    Tran.Y := Tran.Y - MoveSpeed;
  end;
  if KeybMoveDown then begin
    Tran.Y := Tran.Y + MoveSpeed;
  end;
end;


end.