unit Fonts;

interface

uses Windows, SysUtils, GL, GLu, GLext, WGLext, GLtools;

var
  GL_ARB_window_pos_loaded: boolean = false;

type
  TOutlineFont = class
  protected
    FListBase           : cardinal;
    FFont               : HFont;
    FBold               : integer;
    FItalic             : integer;
    FUnderline          : integer;
    FStrikeOut          : integer;
    FDetail             : single;
    FDepth              : single;
    FDC                 : HDC;
    function GetBold: boolean; virtual;
    procedure SetBold(onoff: boolean); virtual;
    function GetItalic: boolean; virtual;
    procedure SetItalic(onoff: boolean); virtual;
    function GetUnderline: boolean; virtual;
    procedure SetUnderline(onoff: boolean); virtual;
    function GetStrikeOut: boolean; virtual;
    procedure SetStrikeOut(onoff: boolean); virtual;
    function GetDetail: single; virtual;
    procedure SetDetail(det: single); virtual;
  public
    constructor Create(DC: HDC); virtual;
    destructor Destroy; override;
    procedure Load(filename, fontname: PChar); virtual;
    procedure TextOut(text: PChar); virtual;
    property Bold: boolean read GetBold write SetBold;
    property Italic: boolean read GetItalic write SetItalic;
    property Underline: boolean read GetUnderline write SetUnderline;
    property StrikeOut: boolean read GetStrikeOut write SetStrikeOut;
    property Detail: single read GetDetail write SetDetail;
    property Depth: single read FDepth write FDepth;
  end;

  TBitmapFont = class
  protected
    FListBase           : cardinal;
    FFont               : HFont;
    FBold               : integer;
    FItalic             : integer;
    FUnderline          : integer;
    FStrikeOut          : integer;
    FSize               : integer;
    FDC                 : HDC;
    function GetBold: boolean; virtual;
    procedure SetBold(onoff: boolean); virtual;
    function GetItalic: boolean; virtual;
    procedure SetItalic(onoff: boolean); virtual;
    function GetUnderline: boolean; virtual;
    procedure SetUnderline(onoff: boolean); virtual;
    function GetStrikeOut: boolean; virtual;
    procedure SetStrikeOut(onoff: boolean); virtual;
  public
    constructor Create(DC: HDC); virtual;
    destructor Destroy; override;
    procedure Load(fontname: PChar); virtual;
    procedure TextOut(x, y: integer; text: PChar); virtual;
    property Bold: boolean read GetBold write SetBold;
    property Italic: boolean read GetItalic write SetItalic;
    property Underline: boolean read GetUnderline write SetUnderline;
    property StrikeOut: boolean read GetStrikeOut write SetStrikeOut;
    property Size: integer read FSize write FSize;
  end;

implementation

constructor TOutlineFont.Create;
begin
  inherited Create;

  FDC              := DC;

  FListBase        := glGenLists(256);

  FBold            := 400;
  FItalic          := 0;
  FUnderline       := 0;
  FStrikeOut       := 0;

  FDetail          := 0;
  FDepth           := 0.2;
end;

procedure TOutlineFont.Load;
begin
  FFont := CreateFont(0, 0, 0, 0,
                      FBold,      { Bold       = 700,  Regular    = 400 }
                      FItalic,    { Italic     = 1   }
                      FUnderline, { Underline  = 1   }
                      FStrikeOut, { StrikeOut  = 1   }
                      ANSI_CHARSET,
                      OUT_DEFAULT_PRECIS,
                      CLIP_DEFAULT_PRECIS,
                      DEFAULT_QUALITY,
                      DEFAULT_PITCH,
                      fontname);
  SelectObject(FDC, FFont);
  if not wglUseFontOutlines(FDC, 0, 255, FListBase,
                            FDetail, { Sample tolerance }
                            FDepth,  { Extrusion depth }
                            WGL_FONT_POLYGONS, nil) then
    raise Exception.Create('Unable to load outline font: ' + filename);
end;

destructor TOutlineFont.Destroy;
begin
  glDeleteLists(FListBase, 256);
  DeleteObject(FFont);

  inherited Destroy;
end;

function TOutlineFont.GetBold;
begin
  result := (FBold = 700);
end;

procedure TOutlineFont.SetBold;
begin
  if onoff then FBold := 700
           else FBold := 400;
end;

function TOutlineFont.GetItalic;
begin
  result := (FItalic = 1);
end;

procedure TOutlineFont.SetItalic;
begin
  if onoff then FItalic := 1
           else FItalic := 0;
end;

function TOutlineFont.GetUnderline;
begin
  result := (FUnderline = 1);
end;

procedure TOutlineFont.SetUnderline;
begin
  if onoff then FUnderline := 1
           else FUnderline := 0;
end;

function TOutlineFont.GetStrikeOut;
begin
  result := (FStrikeOut = 1);
end;

procedure TOutlineFont.SetStrikeOut;
begin
  if onoff then FStrikeOut := 1
           else FStrikeOut := 0;
end;

function TOutlineFont.GetDetail;
begin
  result := 10 - FDetail;
end;

procedure TOutlineFont.SetDetail;
begin
  FDetail := 10 - det;
  if FDetail < 0 then FDetail := 0;
end;

procedure TOutlineFont.TextOut;
begin
  glListBase(FListBase);
  glCallLists(Length(text), GL_UNSIGNED_BYTE, text);
  glListBase(0);
end;

function LoadWindowPos: boolean;
begin
  if not GL_ARB_window_pos_loaded then
  begin
    if not Load_GL_ARB_window_pos then
      raise Exception.Create('GL_ARB_window_pos required!');
    GL_ARB_window_pos_loaded := true;
  end;
  result := GL_ARB_window_pos_loaded;
end;

constructor TBitmapFont.Create;
begin
  LoadWindowPos;

  inherited Create;

  FDC              := DC;

  FListBase        := glGenLists(256);

  FBold            := 400;
  FItalic          := 0;
  FUnderline       := 0;
  FStrikeOut       := 0;

  FSize            := 0;
end;

procedure TBitmapFont.Load;
begin
  FFont := CreateFont(-size, 0, 0, 0,
                      FBold,      { Bold       = 700,  Regular    = 400 }
                      FItalic,    { Italic     = 1   }
                      FUnderline, { Underline  = 1   }
                      FStrikeOut, { StrikeOut  = 1   }
                      ANSI_CHARSET,
                      OUT_TT_PRECIS,
                      CLIP_DEFAULT_PRECIS,
                      ANTIALIASED_QUALITY,
                      DEFAULT_PITCH,
                      fontname);
  SelectObject(FDC, FFont);
  if not wglUseFontBitmaps(FDC, 0, 256, FListBase) then
    raise Exception.Create('Unable to load bitmap font: ' + fontname);
end;

destructor TBitmapFont.Destroy;
begin
  glDeleteLists(FListBase, 256);
  DeleteObject(FFont);

  inherited Destroy;
end;

function TBitmapFont.GetBold;
begin
  result := (FBold = 700);
end;

procedure TBitmapFont.SetBold;
begin
  if onoff then FBold := 700
           else FBold := 400;
end;

function TBitmapFont.GetItalic;
begin
  result := (FItalic = 1);
end;

procedure TBitmapFont.SetItalic;
begin
  if onoff then FItalic := 1
           else FItalic := 0;
end;

function TBitmapFont.GetUnderline;
begin
  result := (FUnderline = 1);
end;

procedure TBitmapFont.SetUnderline;
begin
  if onoff then FUnderline := 1
           else FUnderline := 0;
end;

function TBitmapFont.GetStrikeOut;
begin
  result := (FStrikeOut = 1);
end;

procedure TBitmapFont.SetStrikeOut;
begin
  if onoff then FStrikeOut := 1
           else FStrikeOut := 0;
end;

procedure TBitmapFont.TextOut;
begin
  glWindowPos2fARB(x, y);
  glListBase(FListBase);
  glCallLists(Length(text), GL_UNSIGNED_BYTE, text);
  glListBase(0);
end;

end.
