Unit FTObjs;

interface

uses FTLib, HPool, FreeType;

const
  Assert = True;      (* Define this to false to disable assertion checks *)

  FT_Resource_FNT_File            = 0;
  FT_Resource_TrueType_File       = 1;
  FT_Resource_TrueType_Collection = 2;
  FT_Resource_Type1_File          = 3;
  FT_Resource_DLL                 = 4;

type

  TFamilyString   = string[64];
  TStyleString    = string[64];
  TTypeFaceString = string[128];

  (****************************************************************)
  (*  Base Class : provides list links and reference count        *)
  (*                                                              *)
  (*                                                              *)
  PFontRoot = ^TFontRoot;

  (* simple doubly-linked list structure *)
  TFontList = record
      head : PFontRoot;
      tail : PFontRoot;
  end;

  (* simple base class fields for linking and reference counting *)
  TFontRoot = object

      prev, next : PFontRoot;
      refCount   : integer;

      constructor Init;
      destructor  Done;  virtual;

      procedure   Add   ( var list : TFontList );
      procedure   Remove( var list : TFontList );

      procedure   Flush;  virtual;  (* called when refCount reaches 0 *)

      procedure   IncRef;
      procedure   DecRef;
  end;

  PFontResource = ^TFontResource;
  PFontFace     = ^TFontFace;
  PFontSize     = ^TFontSize;

  (****************************************************************)
  (*  Font Resource record                                        *)
  (*                                                              *)
  (*  A resource is a container used to store one or more fonts.  *)
  (*  It can typically be a simple font file, a font collection,  *)
  (*  a DLL, wathever..                                           *)
  (*                                                              *)
  (*  Right now, the only containers that we support are          *)
  (*  TrueType files and collections                              *)
  (*                                                              *)
  TFontResource = object( TFontRoot )

    filepathname : string;         (* file's path name                  *)
    count        : integer;        (* number of fonts in file           *)
    format       : integer;        (* see FT_Resource_xxxx              *)
    faces        : TFontList;      (* list of font faces                *)

    constructor Init;
    procedure   Flush; virtual;
    destructor  Done;  virtual;
  end;

  (****************************************************************)
  (*  Font Face record                                            *)
  (*                                                              *)
  (*  A font face record maps a single font, as found in a font   *)
  (*  resource. It is independent of transform or scale. a face   *)
  (*  is 'opened' when the corresponding TrueType or Type1        *)
  (*  object is loaded in memory. It is 'closed' when the object  *)
  (*  has been closed                                             *)
  (*                                                              *)
  TFontFace = object( TFontRoot )

      resource   : PFontResource;  (* resource containing this face    *)
      childIndex : integer;        (* index of face within resource    *)
      format     : integer;        (* see FT_Format_xxxx constants     *)

      opened     : boolean;        (* indicates wether the record is   *)
                                   (* loaded in memory or not..        *)

      sizes      : TFontList;      (* list of font sizes - only valid  *)
                                   (* for opened font faces            *)

      numGlyphs  : integer;        (* number of glyphs in font face         *)
      styles     : integer;        (* face's common styles                  *)
      familyName : TFamilyString;  (* font's family name, e.g. "Courier"    *)
      styleName  : TStyleString;   (* face's style name, e.g. "Bold Italic" *)
      fullName   : TTypeFaceString;(* face's full name, e.g. "Arial Italic" *)

      constructor Init( parentResource : PFontResource;
                        subIndex       : integer );
      procedure   Flush;  virtual;
      destructor  Done;   virtual;

      function    Activate : FT_Error;  virtual;
      procedure   Deactivate;           virtual;

      function    New_FontSize( var descr : FT_Font_Description;
                                var size  : PFontSize ) : FT_Error; virtual;
  end;

  (****************************************************************)
  (*  Font Size record                                            *)
  (*                                                              *)
  (*  A font size record maps all the scaling and transform       *)
  (*  dependent data of a font point size. This includes glyph    *)
  (*  outlines caches, as well as all sorts of metrics.           *)
  (*                                                              *)
  TFontSize = object( TFontRoot )

      face    : PFontFace;       (* parent font face record              *)
      x_scale : FT_Fixed;  (* used to scale from EM units to frac pixels *)
      y_scale : FT_Fixed;  (* used to scale from EM units to frac pixels *)

      constructor Init( parentFace : PFontFace );
      procedure   Flush;  virtual;

      function    scalex( x : integer ) : FT_Pos;
      function    scaley( y : integer ) : FT_Pos;

      function    getMetrics
                    ( var m : FT_Text_Metrics ) : FT_Error; virtual;

      function    getOutlineMetrics
                    ( var m : FT_Outline_Text_Metrics ) : FT_Error; virtual;

      function    getWidths( first  : integer;
                             last   : integer;
                             widths : FT_Widths ) : FT_Error; virtual;

      function    getABCWidths( first  : integer;
                                last   : integer;
                                widths : FT_ABC_Widths ) : FT_Error; virtual;

      function    getOutline( glyph   : integer;
                              var out : FT_Outline ) : FT_Error; virtual;
  end;

  (****************************************************************)
  (*  TrueType Font Face record                                   *)
  (*                                                              *)
  (*  A font face record maps a single TrueType font.             *)
  (*                                                              *)
  PTrueTypeFontFace = ^TTrueTypeFontFace;
  TTrueTypeFontFace = object(TFontFace)

      (* the following fields are only valid when the 'opened' field *)
      (* is set to true.                                             *)

      face  : TT_Face;             (* handle to the FreeType face object *)
      props : TT_Face_Properties;  (* TrueType face properties           *)

      constructor Init( parentResource : PFontResource;
                        subIndex       : integer;
                        ttFace         : TT_Face );

      function    Activate : FT_Error;  virtual;
      procedure   Deactivate;           virtual;

      function    New_FontSize( var descr : FT_Font_Description;
                                var size  : PFontSize ) : FT_Error; virtual;
  end;

  (****************************************************************)
  (*  TrueType Font Size record                                   *)
  (*                                                              *)
  (*  Maps a single FreeType instance object                                                            *)
  (*                                                              *)
  PTrueTypeFontSize = ^TTrueTypeFontSize;
  TTrueTypeFontSize = object(TFontSize)

      valid    : Boolean;      (* indicates wether the glyph and instance   *)
                               (* handles are valid                         *)

      tt_instance : TT_Instance;          (* handle to FreeType instance    *)
      tt_metrics  : TT_Instance_Metrics;  (* FreeType instance metrics      *)
      tt_glyph    : TT_Glyph;             (* FreeType glyph container       *)

      outlines : PPool;                   (* outlines cache                 *)

      (* note that the bitmap cache, if any, is located in the font object. *)
      (* this is due to the fact that a single font size can be shared by   *)
      (* several font objects (e.g. a normal one, and a 'rotated' one),that *)
      (* only differ by their transform field. It is easy to apply a        *)
      (* transform to an outline, however, you can't do that to bitmaps !!  *)
      (* Moreover, the decision of wether to cache a bitmap depends on the  *)
      (* transform used (e.g. it is a bad idea for rotated text which needs *)
      (* sub-pixel precision to display correctly..)                        *)

      function  InitPixelSizes( width     : integer;
                                height    : integer;
                                pointsize : integer ) : FT_Error;

      function  InitPointSizes( charWidth  : integer;
                                charHeight : integer;
                                resx, resy : integer ) : FT_Error;

      function  getMetrics( var m : FT_Text_Metrics ) : FT_Error; virtual;

      function  getOutlineMetrics
                    ( var m : FT_Outline_Text_Metrics ) : FT_Error; virtual;

      function  getWidths( first  : integer;
                           last   : integer;
                           widths : FT_Widths ) : FT_Error; virtual;

      function  getABCWidths( first  : integer;
                              last   : integer;
                              widths : FT_ABC_Widths ) : FT_Error; virtual;

      function  getOutline( glyph   : integer;
                            var out : FT_Outline ) : FT_Error; virtual;

      destructor Done; virtual;
  end;

  (****************************************************************)
  (*  Font object class                                           *)
  (*                                                              *)
  (*  The font objects as seen by the client application.         *)
  (*                                                              *)
  PFontObject = ^TFontObject;
  TFontObject = object( TFontRoot )

      fontface    : PFontFace;         (* font face               *)
      fontsize    : PFontSize;         (* font size               *)

      flags       : integer;           (* type flag for font      *)
      resX, resY  : integer;           (* output resolutions      *)
      transform   : FT_Transform;      (* transform               *)

      constructor Init;

      function    Create_TrueType( var descr : FT_Font_Description
                                 ) : FT_Error;
      destructor  Done; virtual;
  end;


  function Load_TrueType_File( ttfile  : string;
                               load    : Boolean;
                               var res : PFontResource ) : FT_Error;

  (*****************************************************)
  (*  Find a given resource by filepathname            *)
  (*                                                   *)
  function Find_FontResource_By_Filename( filepath : string
                                        ) : PFontResource;


const
  empty_list : TFontList = ( head:nil; tail:nil );

var
  (*****************************************************)
  (*  The library instance data is defined here        *)
  (*                                                   *)
  lib : record
      (* TrueType engine instance handle *)
      (* tt_engine     : TT_Engine;     -- only for the C version *)

      (* internal error := error class | engine/library error *)
      error : integer;

      (* linked list of font resources currently 'installed' *)
      resources : TFontList;

      (* linked list of font objects currently 'used' *)
      fontObjs  : TFontList;
  end;

implementation

uses TTCalc, FTOutln;

  procedure Panic( message : string );
  begin
    Writeln( Output, message );
    Halt(1);
  end;

  procedure Check( condition : Boolean;
                   message   : string ); {$IFDEF INLINE} inline; {$ENDIF}
  begin
    if not condition then
      Panic( message );
  end;

  (****************************************************************)
  (*  Test pathname equality                                      *)
  (*                                                              *)
  (*  This function tests that two resource pathnames point to    *)
  (*  the same resource file. For now, it only compares strings,  *)
  (*  without even bothering with case. It could be refined in    *)
  (*  the future for subtler comparisons                          *)
  (*                                                              *)
  function Equal_Files( path1, path2 : string ) : Boolean;
  begin
    Equal_Files := (path1 = path2);
  end;

  (****************************************************************)
  (*  Font Root Functions                                         *)
  (*                                                              *)
  (*  Support for linking and reference counting in a simple      *)
  (*  base class. Each sub-class must define a 'flush' method     *)
  (*  which will be called when the reference count reaches 0     *)
  (*                                                              *)
  (****************************************************************)

  (****************************************************************)
  (*  Initialise a font root                                      *)
  (*                                                              *)
  constructor TFontRoot.Init;
  begin
    prev     := nil;
    next     := nil;
    refCount := 0;
  end;

  (****************************************************************)
  (*  destroy a font root                                         *)
  (*                                                              *)
  destructor  TFontRoot.Done;
  begin
    prev     := nil;
    next     := nil;
    refCount := 0;
  end;

  (****************************************************************)
  (*  abstract font root flush                                    *)
  (*                                                              *)
  procedure TFontRoot.Flush;
  begin
    (* nothing - a normal flush should remove the object from its *)
    (* list, if any, then deletes the object                      *)
    if assert then Panic('Abstract method called');
  end;


  (****************************************************************)
  (*  add a font root to a doubly-linked list                     *)
  (*                                                              *)
  procedure TFontRoot.Add( var list : TFontList );
  begin
    if assert then
      Check( (prev = nil) and (next = nil), 'Adding a listed element' );

    next := nil;
    prev := list.tail;
    if prev <> nil then list.tail^.next := PFontRoot(@self)
                   else list.head       := PFontRoot(@self);
  end;

  (****************************************************************)
  (*  remove a font root from a doubly-linked list                *)
  (*                                                              *)
  procedure TFontRoot.Remove( var list : TFontList );
  begin
    if assert then
      Check( (list.head <> nil) or (list.tail <> nil),
             'Removing from an empty list' );

    if list.tail <> nil then list.tail^.next := next
                        else list.head       := next;

    if prev <> nil then prev^.next := next
                   else list.head  := next;

    if next <> nil then next^.prev := prev
                   else list.tail  := prev;
  end;

  (****************************************************************)
  (*  Font Root reference count increment                         *)
  (*                                                              *)
  procedure TFontRoot.IncRef;
  begin
    inc( refCount );
  end;

  (****************************************************************)
  (*  Font Root reference count decrement and flushing            *)
  (*                                                              *)
  procedure TFontRoot.DecRef;
  begin
    dec( refCount );
    if refCount <= 0 then
      Flush;
  end;

  (****************************************************************)
  (*  Font Resource record                                        *)
  (*                                                              *)
  (*  A resource is a container used to store one or more fonts.  *)
  (*  It can typically be a simple font file, a font collection,  *)
  (*  a DLL, wathever..                                           *)
  (*                                                              *)
  (*  Right now, the only containers that we support are          *)
  (*  TrueType files and collections                              *)
  (*                                                              *)
  (****************************************************************)

  (*****************************************************)
  (*  Font Resource flushing                           *)
  (*                                                   *)
  procedure TFontResource.Flush;
  begin
    (* a font resource's reference count is used to indicate the *)
    (* number of clients that have installed/loaded the resource *)
    (* in the library                                            *)

    (* Flushing should only occur when the RemoveFontResource API is *)
    (* called                                                        *)
    Remove(lib.resources);
    Dispose( PFontResource(@self), Done );
  end;

  (*****************************************************)
  (*  Font Resource construction                       *)
  (*                                                   *)
  constructor TFontResource.Init;
  begin
    inherited Init;
    (* By default, a resource object is created with no data, as a *)
    (* constructor doesn't return an error code, and isn't able to *)
    (* dispose the object in case of failure at load time.         *)
    (* One a font resource is created, it must be loaded with a    *)
    (* specific API. We only provide Load_TrueType_File for the    *)
    (* moment, see below..                                         *)
    filepathname := '';
    count        := 0;
    format       := 0;
    faces        := empty_list;
  end;

  (*****************************************************)
  (*  Resource finalisation                            *)
  (*                                                   *)
  destructor TFontResource.Done;
  var
    curface, nextface : PFontFace;
  begin
    (* destroy all resource's faces - if any *)
    curface := PFontFace(faces.head);
    while curface <> nil do
      begin
        nextface := PFontFace(curface^.next);
        Dispose( curface, Done );
        curface  := nextface;
      end;

    inherited Done;
  end;

  (*****************************************************)
  (*  TrueType Resource loader                         *)
  (*                                                   *)
  (*  loads a TrueType file or collection into a new   *)
  (*  resource. The returned resource is added to the  *)
  (*  library's list.                                  *)
  (*                                                   *)
  function Load_TrueType_File( ttfile  : string;
                               load    : Boolean;
                               var res : PFontResource ) : FT_Error;
  var
    error   : TT_Error;
    face    : TT_Face;
    props   : TT_Face_Properties;
    n_fonts : integer;  (* number of fonts *)
    curface : PFontFace;
    n       : integer;
  label
    Fail_Open, Fail_Face;
  begin
    res := nil;

    error := TT_Open_Face( ttfile, face );
    if error <> TT_Err_Ok then goto Fail_Open;

    error := TT_Get_Face_Properties( face, props );
    if error <> TT_Err_Ok then goto Fail_Face;

    New( res, Init );
    res^.filepathname := ttfile;

    (* check wether it's a single font file or a collection *)
    if props.max_faces > 0 then
      res^.format := FT_Resource_TrueType_Collection
    else
      res^.format := FT_Resource_TrueType_File;

    (* create first font face *)
    New( PTrueTypeFontFace(curface), Init( res, 0, face ) );

    (* deactivate face if we're just installing the font *)
    (* otherwise, it will be kept opened                 *)
    if not load then
      curface^.deactivate;

    TT_Set_Face_Pointer( face, Pointer(curface) );

    for n := 1 to props.max_faces do
    begin
      error := TT_Open_Collection( ttfile, n, face );
      if error <> TT_Err_Ok then goto Fail_Open;

      (* create each other embedded font *)
      curface := New( PTrueTypeFontFace, Init( res, n, face ) );
      curface^.deactivate;
    end;

    res^.add( lib.resources );
    res^.incRef;
    exit;

  Fail_Face :
    TT_Close_Face( face );

  Fail_Open:
    if res <> nil then
      Dispose( res, Done );

    Load_TrueType_File := error;
  end;

  (*****************************************************)
  (*  Find a given resource by filepathname            *)
  (*                                                   *)
  function Find_FontResource_By_Filename( filepath : string
                                        ) : PFontResource;
  var
    cur : PFontResource;
  begin
    cur := PFontResource(lib.resources.head);
    while cur <> nil do
      if Equal_Files( cur^.filepathname, filepath ) then
        begin
          Find_FontResource_By_Filename := cur;
          exit;
        end
      else
        cur := PFontResource(cur^.next);

    Find_FontResource_By_Filename := nil;
  end;

  (*****************************************************)
  (*  Find a given font face by its fullname           *)
  (*                                                   *)
  function Find_FontFace_By_Fullname( fullname : string ) : PFontFace;
  var
    res : PFontResource;
    cur : PFontFace;
  begin
    res := PFontResource(lib.resources.head);
    while res <> nil do
    begin
      cur := PFontFace(res^.faces.head);
      while cur <> nil do
        if Equal_Files( cur^.fullname, fullname ) then
          begin
            Find_FontFace_By_Fullname := cur;
            exit;
          end
        else
          cur := PFontFace(cur^.next);

      res := PFontResource(res^.next);
    end;

    Find_FontFace_By_Fullname := nil;
  end;

  (****************************************************************)
  (*  Font Face record                                            *)
  (*                                                              *)
  (*  A font face record maps a single font, as found in a font   *)
  (*  resource. It concerns the                                   *)
  (*                                                              *)
  (*                                                              *)
  (****************************************************************)

  (****************************************************************)
  (*  Base Font Face construction                                 *)
  (*                                                              *)
  constructor TFontFace.Init( parentResource : PFontResource;
                              subIndex       : integer );
  begin
    inherited Init;
    resource   := parentResource;
    childIndex := subIndex;
    format     := 0;
    opened     := false;
    sizes      := empty_list;
    styles     := 0;
    familyName := '';
    styleName  := '';
    fullName   := '';

    (* insert into resource list *)
    Add( resource^.faces );
  end;

  (****************************************************************)
  (*  Base Font Face flush                                        *)
  (*                                                              *)
  procedure TFontFace.Flush;
  begin
    (* flushing means that no font size remains in the face's list *)
    (* and that we can simply deactivate it                        *)
    if assert then
      Check( (sizes.head = nil) and (sizes.tail = nil),
             'Flushed font face still has font sizes' );

    (* There is no need to remove a font face from its parent      *)
    (* resource list when flushing, we simply deactivate it.       *)
    deactivate;
  end;

  (****************************************************************)
  (*  Base Font Face activation                                   *)
  (*                                                              *)
  function TFontFace.Activate : FT_Error;
  begin
    if assert then
      Panic( 'Base font face activated' );
  end;

  (****************************************************************)
  (*  Base Font Face deactivation                                 *)
  (*                                                              *)
  procedure TFontFace.Deactivate;
  var
    cursize, nextsize : PFontSize;
  begin
    (* destroy all child fontsizes *)
    cursize := PFontSize(sizes.head);
    while cursize <> nil do
      begin
        nextsize := PFontSize(cursize^.next);
        Dispose( cursize, Done );
        cursize  := nextsize;
      end;
    sizes  := empty_list;
    (* nothing more for base font face *)
  end;

  (****************************************************************)
  (*  Base Font Face destruction                                  *)
  (*                                                              *)
  destructor TFontFace.Done;
  var
    cursize, nextsize : PFontSize;
  begin
    deactivate;

    (* clear fields *)
    styles     := 0;
    familyName := '';
    styleName  := '';
    fullName   := '';
    sizes      := empty_list;
    resource   := nil;
    childIndex := 0;
    format     := 0;
    opened     := false;
  end;

  (****************************************************************)
  (*  Font Size Creation or Referencing                           *)
  (*                                                              *)
  function TFontFace.New_FontSize( var descr : FT_Font_Description;
                                   var size  : PFontSize ) : FT_Error;
  begin
    if assert then
      Panic( 'Base font face New_FontSize called' );

    size         := nil;
    New_FontSize := FT_Err_Invalid_Font_Object;
  end;

  (****************************************************************)
  (*  Font Size record                                            *)
  (*                                                              *)
  (*  A font size record maps all the scaling and transform       *)
  (*  dependent data of a font point size. This includes glyph    *)
  (*  outlines and bitmap caches, as well as all sort of metrics  *)
  (*                                                              *)
  (****************************************************************)

  (****************************************************************)
  (*  Font Size Construction                                      *)
  (*                                                              *)
  constructor TFontSize.Init( parentFace : PFontFace );
  begin
    inherited Init;
    face    := parentFace;
    x_scale := $10000;
    y_scale := $10000;
  end;

  (****************************************************************)
  (*  scale a distance in EM units to fractional pixels (26.6)    *)
  (*                                                              *)
  function TFontSize.scalex( x : integer ) : FT_Pos;
  begin
    scalex := MulDiv_Round( x, x_scale, $400 );
  end;

  (****************************************************************)
  (*  scale a distance in EM units to fractional pixels (26.6)    *)
  (*                                                              *)
  function TFontSize.scaley( y : integer ) : FT_Pos;
  begin
    scaley := MulDiv_Round( y, y_scale, $400 );
  end;

  (****************************************************************)
  (*  Font Size Flushing                                          *)
  (*                                                              *)
  procedure TFontSize.Flush;
  var
    parent : PFontFace;
  begin
    (* Flushing a font size means removing it from its parent list *)
    (* then deleting it, simply.                                   *)
    parent := face;
    face   := nil;
    if assert then
      Check( parent <> nil, 'Flushing an unlisted font size' );

    Remove( parent^.sizes );
    Dispose( PFontSize(@self), Done );
    parent^.decRef;
  end;

  (****************************************************************)
  (*  Font Size Query Metrics                                     *)
  (*                                                              *)
  function TFontSize.getMetrics;
  begin
    if assert then
      Panic( 'TFontSize.getMetrics: abstract method called' );

    getMetrics := FT_Err_Unsupported_Feature;
  end;

  (****************************************************************)
  (*  Font Size Query Outline Metrics                             *)
  (*                                                              *)
  function TFontSize.getOutlineMetrics;
  begin
    if assert then
      Panic( 'TFontSize.getOutlineMetrics: abstract method called' );

    getOutlineMetrics := FT_Err_Unsupported_Feature;
  end;

  (****************************************************************)
  (*  Font Size Query Glyph Widths                                *)
  (*                                                              *)
  function TFontSize.getWidths( first  : integer;
                                last   : integer;
                                widths : FT_Widths ) : FT_Error;
  begin
    if assert then
      Panic( 'TFontSize.getWidths : abstract method called' );
    getWidths := FT_Err_Unsupported_Feature;
  end;

  (****************************************************************)
  (*  Font Size Query Glyph ABC Widths                            *)
  (*                                                              *)
  function TFontSize.getABCWidths( first  : integer;
                                   last   : integer;
                                   widths : FT_ABC_Widths ) : FT_Error;
  begin
    if assert then
      Panic( 'TFontSize.getABCWidths : abstract method called' );
    getABCWidths := FT_Err_Unsupported_Feature;
  end;


  (****************************************************************)
  (*  Font Size Query Outline                                     *)
  (*                                                              *)
  function TFontSize.getOutline( glyph   : integer;
                                 var out : FT_Outline ) : FT_Error;
  begin
    if assert then
      Panic( 'TFontSize.getOutline : abstract method called' );
    getOutline := FT_Err_Unsupported_Feature;
  end;

  (****************************************************************)
  (*  TrueType Font Face record                                   *)
  (*                                                              *)
  (*  A font face record that maps a single TrueType font         *)
  (*                                                              *)
  (****************************************************************)

  (****************************************************************)
  (*  Right now, the name table support is still pretty weak in   *)
  (*  the high-level library. Here we simply look for Unicode     *)
  (*  english names and copy their lowest byte to a string        *)
  (*                                                              *)
  function Lookup_TT_Name( face   : TT_Face;
                           nameid : integer ) : string;
  var
    tempstr   : string;
    i, n, len : integer;

    platform,
    encoding,
    language,
    id        : integer;

    strBuff : ^string;
    strLen  : integer;
  begin
    n := TT_Get_Name_Count(face);
    for i := 0 to n-1 do
    begin
      TT_Get_Name_ID( face, i, platform, encoding, language, id );
      if id = nameid then
      begin
        if ((platform = 3) and             (* Windows english name *)
            (encoding = 1) and
            (language and $3FF = 9))   or
           ((platform = 0) and             (* Apple Unicode *)
            (language = 0))            then
        begin
          TT_Get_Name_String( face, i, Pointer(strBuff), strLen );
          if strLen > 512 then strLen := 512;

          len := 0;
          i   := 1;
          while ( i < strLen ) do
          begin
            inc(len);
            tempstr[len] := strBuff^[i];
            inc( i, 2 );
          end;
          tempstr[0] := chr(len);

          LookUp_TT_Name := tempStr;
          exit;
        end;
      end;
    end;

    LookUp_TT_Name := '';
  end;


  (****************************************************************)
  (*  Compute text dimensions from a font description             *)
  (*                                                              *)
  (*  This functions computes a given font's pixel dimensions     *)
  (*  a its pointsize.                                            *)
  (*                                                              *)
  function  Compute_Dimensions( var descr       : FT_Font_Description;
                                var pixelHeight : integer;
                                var pixelWidth  : integer;
                                var pointSize   : integer ) : FT_Error;
  var
    resx, resy, dimx, dimy, sizex, sizey : integer;
  label
    Fail_Resolutions;
  begin
    if descr.queryType and FT_Flag_Non_Square_Sizes = 0 then
      descr.dimx := descr.dimy;

    if descr.queryType and FT_Flag_Non_Square_Resolutions = 0 then
      descr.resx := descr.resy;

    dimy := descr.dimy;
    dimx := descr.dimx;

    resy := descr.resy;
    resx := descr.resx;

    if (resx < 72) or (resy < 72) then
      goto Fail_Resolutions;

    if descr.queryType and FT_Flag_Pixel_Sizes <> 0 then
      begin
        (* dimensions are already in pixels, compute charsizes *)
        sizex := 64*72*dimx div resx;
        sizey := 64*72*dimy div resy;
      end
    else
      begin
        (* dimensions are already in point sizes, compute pixel dims *)
        sizex := dimx;
        sizey := dimy;
        dimx  := (dimx*resx+36*64) div (72*64);
        dimy  := (dimy*resy+36*64) div (72*64);
      end;

    if dimx < 1 then dimx := 1;
    if dimy < 1 then dimy := 1;

    pixelHeight := dimy;
    pixelWidth  := dimx;

    if sizex >= sizey then pointSize := sizex
                      else pointSize := sizey;

    Compute_Dimensions := FT_Err_Ok;
    exit;

  Fail_Resolutions:
    Compute_Dimensions := FT_Err_DPIs_Must_Be_Over_72;
  end;

  (****************************************************************)
  (*  Compute the 'charmap' field in text metrics for a TT font   *)
  (*                                                              *)
  function  Compute_CharSet( face : TT_Face ) : integer;
  var
    n, i     : integer;
    charset  : integer;
    platform : system.integer;
    encoding : system.integer;
  begin
    charset := 0;

    n := TT_Get_CharMap_Count( face );
    for i := 0 to n-1 do
    begin
      TT_Get_CharMap_ID( face, i, platform, encoding );
      case platform of
        (* apple unicode platform id *)
        0 : charset := charset or FT_Charset_Unicode;

        (* apple script platform id *)
        1 : if encoding = 32 then
              charset := charset or FT_CharSet_Symbol;

        2 : case encoding of
              0 : charset := charset or FT_CharSet_ASCII;
              2 : charset := charset or FT_CharSet_Latin1;
            end;

        (* windows platform id *)
        3 : case encoding of
              0, 1 : charset := charset or FT_Charset_Unicode;
            end;
      end
    end;

    Compute_CharSet := charset;
  end;

  {
  TTrueTypeFontFace = object(TFontFace)

      (* the following fields are only valid when the 'opened' field *)
      (* is set to true.                                             *)

      face  : TT_Face;             (* handle to the FreeType face object *)
      props : TT_Face_Properties;  (* TrueType face properties           *)

      constructor Init( parentResource : PFontResource;
                        subIndex       : integer;
                        ttFace         : TT_Face );

      destructor  Done; virtual;

      function    New_FontSize( var descr : FT_Font_Description;
                                var size  : PFontSize ) : FT_Error; virtual;

      procedure   Done_FontSize  ( size : PFontSize );              virtual;
  end;
  }

  (****************************************************************)
  (*  The TrueType font face constructor                          *)
  (*                                                              *)
  constructor TTrueTypeFontFace.Init( parentResource : PFontResource;
                                      subIndex       : integer;
                                      ttFace         : TT_Face );
  var
    tempstr : string;
  begin
    inherited Init( parentResource, subIndex );
    face   := ttface;
    opened := true;
    TT_Get_Face_Properties( face, props );

    (* fill the names fields *)
    (*                       *)
    familyName := LookUp_TT_Name( face, 1 );
    styleName  := LookUp_TT_Name( face, 2 );
    fullName   := LookUp_TT_Name( face, 4 );

    (* fill styles field. We can either read the font header, and *)
    (* the mac flags, or the OS/2 table, and the Windows flags..  *)
    (* here, we take the font header :                            *)
    (*                                                            *)
    (* Note that currently, only two styles are supported..       *)
    (*                                                            *)
    styles := FT_Style_Regular; (* 0 *)

    if props.header^.mac_style and 2 <> 0 then
      styles := styles or FT_Style_Italic;

    if props.header^.mac_style and 1 <> 0 then
      styles := styles or FT_Style_Bold;

    (* the equivalent code for the Windows metrics would be : *)
    (*                                                        *)
    (*  if props.os2^.fsSelection and 1 <> 0 then             *)
    (*    styles := styles or FT_Style_Italic;                *)
    (*                                                        *)
    (*  if props.os2^.fsSelection and 32 <> 0 then            *)
    (*    styles := styles or FT_Style_Bold                   *)
    (*                                                        *)

    numGlyphs := props.num_Glyphs;
  end;

  (****************************************************************)
  (*  The TrueType font face activation                           *)
  (*                                                              *)
  function TTrueTypeFontFace.Activate : FT_Error;
  var
    error : TT_Error;
  begin
    activate := FT_Err_Ok;

    if opened then
      if assert then
        Panic('Activating an opened TT font face')
      else
        exit;

    (* re-open TrueType face *)
    if childIndex > 0 then
      error := TT_Open_Collection( resource^.filepathname,
                                   childIndex, face )
    else
      error := TT_Open_Face( resource^.filepathname, face );

    (* for now, don't do anything special in case of errors *)
    opened := (error = TT_Err_Ok);

    if opened then
      (* update face properties - important because of changed pointers *)
      TT_Get_Face_Properties( face, props )
    else
      activate := FT_Error(FT_Error_Class_TrueType + error);
  end;

  (****************************************************************)
  (*  The TrueType font face deactivation                         *)
  (*                                                              *)
  procedure TTrueTypeFontFace.Deactivate;
  begin
    (* this will delete all child fontsizes - if any *)
    inherited deactivate;

    if opened then
    begin
      (* discard pointers in face properties - just in case *)
      props.header      := nil;
      props.horizontal  := nil;
      props.os2         := nil;
      props.postscript  := nil;

      (* close TT face *)
      TT_Close_Face( face );

      opened := false;
    end;
  end;

  (****************************************************************)
  (*  Registering a new font size                                 *)
  (*                                                              *)
  function   TTrueTypeFontFace.New_FontSize( var descr : FT_Font_Description;
                                             var size  : PFontSize
                                           ) : FT_Error;
  var
    error                   : FT_Error;
    height, width, charsize : integer;
    curSize, foundSize      : PTrueTypeFontSize;
  label
    Fail;
  begin
    (* first of all, compute requested dimensions/metrics *)
    error := Compute_Dimensions( descr, height, width, charsize );
    if error <> FT_Err_Ok then goto Fail;

    foundSize := nil;

    if not opened then
      activate
    else
      begin
        (* look in current fontsize list if we already have one instance *)
        (* with these metrics..                                          *)
        curSize   := PTrueTypeFontSize(sizes.head);
        while curSize <> nil do
          if (curSize^.tt_metrics.x_ppem    = width)  and
             (curSize^.tt_metrics.y_ppem    = height) and
             (curSize^.tt_metrics.pointsize = charsize ) then
            begin
             foundSize := curSize;
             curSize   := nil;
            end
          else
            curSize := PTrueTypeFontSize(curSize^.next);
      end;

    (* create a new font size if none matched the requested size *)
    if foundSize = nil then
      begin
        New( curSize, Init(@self) );

        if descr.queryType and FT_Flag_Pixel_Sizes <> 0 then
          error := curSize^.InitPixelSizes( width, height, charsize )
        else
          error := curSize^.InitPointSizes( descr.dimx, descr.dimy,
                                            descr.resx, descr.resy );
        if error <> FT_Err_Ok then
          begin
            Dispose( curSize, Done );
            goto Fail;
          end;

        curSize^.Add( self.sizes );
        incRef;
      end
    else
      curSize := foundSize;

    curSize^.incRef;

    size         := curSize;
    New_FontSize := FT_Err_Ok;
    exit;
  Fail:
    size         := nil;
    New_FontSize := error;
  end;

  (****************************************************************)
  (*  TrueType Font Size record                                   *)
  (*                                                              *)
  (*  Maps a single FreeType instance object                      *)
  (*                                                              *)
  (****************************************************************)
  {
  TTrueTypeFontSize = object(TFontSize)

      valid    : Boolean;      (* indicates wether the glyph and instance *)
                               (* handles are valid                       *)

      instance : TT_Instance;             (* handle to FreeType instance *)
      metrics  : TT_Instance_Metrics;     (* FreeType instance metrics   *)
      glyph    : TT_Glyph;                (* FreeType glyph container    *)

      outlines : integer;                 (* outlines cache              *)

      function  InitPixelSizes( width     : integer;
                                height    : integer;
                                pointsize : integer ) : FT_Error;

      function  InitPointSizes( charWidth  : integer;
                                charHeight : integer;
                                resx, resy : integer ) : FT_Error;

      destructor Done; virtual;
  end;
  }

  (****************************************************************)
  (*  The TrueType font size initialisation by pixels             *)
  (*                                                              *)
  function  TTrueTypeFontSize.InitPixelSizes(
                                   width     : integer;
                                   height    : integer;
                                   pointsize : integer ) : FT_Error;
  var
    parent : PTrueTypeFontFace;
    error  : TT_Error;
  label
    Fail_Instance, Fail_Glyph, Fail_Metrics;
  begin
    parent := PTrueTypeFontFace(face);

    valid := false;

    error  := TT_New_Instance(parent^.face, tt_instance);
    if error <> TT_Err_Ok then goto Fail_Instance;

    error  := TT_New_Glyph(parent^.face, tt_glyph);
    if error <> TT_Err_Ok then goto Fail_Glyph;

    error := TT_Set_Instance_PixelSizes(
                  tt_instance, width, height, pointsize );

    if error <> TT_Err_Ok then goto Fail_Metrics;

    error := TT_Get_Instance_Metrics( tt_instance, tt_metrics );
    if error <> TT_Err_Ok then goto Fail_Metrics;

    x_scale := tt_metrics.x_scale;
    y_scale := tt_metrics.y_scale;

    New( outlines, Init( nil ) );

    valid          := true;
    InitPixelSizes := FT_Err_Ok;
    exit;

  Fail_Metrics:
    TT_Done_Glyph( tt_glyph );

  Fail_Glyph:
    TT_Done_Instance( tt_instance );

  Fail_Instance:
    InitPixelSizes := FT_Error( error + FT_Error_Class_TrueType );
  end;


  (****************************************************************)
  (*  The TrueType font size by point sizes                       *)
  (*                                                              *)
  function  TTrueTypeFontSize.InitPointSizes(
                                charWidth  : integer;
                                charHeight : integer;
                                resx, resy : integer ) : FT_Error;
  var
    parent : PTrueTypeFontFace;
    error  : TT_Error;
  label
    Fail_Instance, Fail_Glyph, Fail_Metrics;
  begin
    parent := PTrueTypeFontFace(face);

    valid := false;

    error  := TT_New_Instance(parent^.face, tt_instance);
    if error <> TT_Err_Ok then goto Fail_Instance;

    error  := TT_New_Glyph(parent^.face, tt_glyph);
    if error <> TT_Err_Ok then goto Fail_Glyph;

    error := TT_Set_Instance_Resolutions( tt_instance, resx, resy );
    if error <> TT_Err_Ok then goto Fail_Metrics;

    error := TT_Set_Instance_CharSizes( tt_instance, charWidth, charHeight );
    if error <> TT_Err_Ok then goto Fail_Metrics;

    error  := TT_Get_Instance_Metrics( tt_instance, tt_metrics );
    if error <> TT_Err_Ok then goto Fail_Metrics;

    (* XXXX : No caching support for now *)
    New( outlines, Init( nil ) );

    valid          := true;
    InitPointSizes := FT_Err_Ok;
    exit;

  Fail_Metrics:
    TT_Done_Glyph( tt_glyph );

  Fail_Glyph:
    TT_Done_Instance( tt_instance );

  Fail_Instance:
    InitPointSizes := FT_Error( error + FT_Error_Class_TrueType );
  end;

  (****************************************************************)
  (*  TT Font size query metrics                                  *)
  (*                                                              *)
  function TTrueTypeFontSize.getMetrics( var m : FT_Text_Metrics ) : FT_Error;
  var
    header : ^TT_Header;
    horiz  : ^TT_Horizontal_Header;
    os2    : ^TT_OS2;
    post   : ^TT_Postscript;

  begin
    m.fontType  := FT_Format_TrueType;
    m.height    := tt_metrics.y_ppem;
    m.width     := tt_metrics.x_ppem;
    m.ptSize    := tt_metrics.pointSize;

    (* ????? *)

    header := @PTrueTypeFontFace(face)^.props.header;
    horiz  := @PTrueTYpeFontFace(face)^.props.horizontal;
    os2    := @PTrueTypeFontFace(face)^.props.os2;
    post   := @PTrueTypeFontFace(face)^.props.postscript;

    m.ascender  := scaley( os2^.sTypoAscender  );
    m.descender := scaley( os2^.sTypoDescender );
    m.linegap   := scaley( os2^.sTypoLineGap   );

    m.winAscender  := scaley( os2^.usWinAscent );
    m.winDescender := scaley( os2^.usWinDescent );

    m.macAscender  := scaley( horiz^.Ascender );
    m.macDescender := scaley( horiz^.Descender );
    m.macLinegap   := scaley( horiz^.Line_gap );

    m.avgCharWidth := scalex( os2^.xAvgCharWidth );
    m.maxCharWidth := scalex( horiz^.xMax_Extent );
    m.weight       := os2^.usWeightClass;  (* XXX : we use the same mapping *)

    m.charSet      := Compute_CharSet( PTrueTypeFontFace(face)^.face );

    m.numGlyphs    := PTrueTypeFontFace(face) ^.props.num_Glyphs;

    (* the following comes from the parent font face *)
    m.styles       := face^.styles;
    m.familyName   := face^.familyName;
    m.styleName    := face^.styleName;
    m.fullName     := face^.fullName;

    getMetrics := FT_Err_Ok;
  end;

  (****************************************************************)
  (*  TT Font size query outline metrics                          *)
  (*                                                              *)
  function TTrueTypeFontSize.getOutlineMetrics(
             var m : FT_Outline_Text_Metrics ) : FT_Error;
  var
    error  : FT_Error;
    header : ^TT_Header;
    horiz  : ^TT_Horizontal_Header;
    os2    : ^TT_OS2;
    post   : ^TT_Postscript;
  label
    Fail;

  begin
    (* get normal text metrics *)
    error := getOutlineMetrics(m);
    if error <> FT_Err_Ok then goto Fail;

    header := @PTrueTypeFontFace(face)^.props.header;
    horiz  := @PTrueTYpeFontFace(face)^.props.horizontal;
    os2    := @PTrueTypeFontFace(face)^.props.os2;
    post   := @PTrueTypeFontFace(face)^.props.postscript;

    m.unitsPerEM := header^.units_per_Em;

    m.fontBox.xMin := scalex( header^.xMin );
    m.fontBox.xMax := scalex( header^.xMax );
    m.fontBox.yMin := scaley( header^.yMin );
    m.fontBox.yMax := scaley( header^.yMax );

    m.minimumPPEM  := header^.lowest_rec_PPEM;

    m.subScriptSize     := os2^.ySubscriptYSize;
    m.subScriptOffset   := os2^.ySubscriptYOffset;

    m.superScriptSize   := os2^.ySuperScriptYSize;
    m.superScriptOffset := os2^.ySuperScriptYOffset;

    m.strikeOutSize     := os2^.yStrikeOutSize;
    m.strikeOutPosition := os2^.yStrikeOutPosition;

    m.underlineSize     := post^.underlineThickness;
    m.underlinePosition := post^.underlinePosition;

    error := FT_Err_Ok;
  Fail:
    getOutlineMetrics := error;
  end;

  (****************************************************************)
  (*  TrueType Font Size query glyph widths                       *)
  (*                                                              *)
  function TTrueTypeFontSize.getWidths( first  : integer;
                                        last   : integer;
                                        widths : FT_Widths ) : FT_Error;
  begin
    (* XXX : still unsupported *)
    getWidths := FT_Err_Unsupported_Feature;
  end;

  (****************************************************************)
  (*  Font Size Query Glyph ABC Widths                            *)
  (*                                                              *)
  function TTrueTypeFontSize.getABCWidths(
                                  first  : integer;
                                  last   : integer;
                                  widths : FT_ABC_Widths ) : FT_Error;
  begin
    (* XXX : still unsupported *)
    getABCWidths := FT_Err_Unsupported_Feature;
  end;

  (****************************************************************)
  (*  TrueType Font Size query glyph outline                      *)
  (*                                                              *)
  function TTrueTypeFontSize.getOutline( glyph   : integer;
                                         var out : FT_Outline ) : FT_Error;
  var
    error : FT_Error;
    cur   : FT_Outline;
  label
    Fail;
  begin
    (* first, look for outline in the cache *)
    cur := FT_Outline( outlines^.retrieve( glyph ) );
    if cur = nil then
      begin
        (* not in the cache - try to load it from the file *)
        error := TT_Load_Glyph( tt_instance,
                                tt_glyph,
                                glyph,
                                TT_Load_Default );
        if error <> TT_Err_Ok then
          goto Fail;

        FT_Create_TT_Outline( tt_glyph, cur );
        if cur = nil then
          goto Fail;

        (* add new outline to cache *);
        outlines^.add( glyph, Pointer(cur) );
      end;

    out := cur;
    getOutline := FT_Err_Ok;
    exit;

  Fail:
    out := nil;
    getOutline := FT_Error( FT_Error_Class_TrueType + error );
  end;

  (****************************************************************)
  (*  The TrueType font size destructor                           *)
  (*                                                              *)
  destructor  TTrueTypeFontSize.Done;
  begin
    (* close TT face instance and glyph container *)
    if valid then
      begin
        Dispose( outlines, Done );
        outlines := nil;

        TT_Done_Glyph( tt_glyph );
        TT_Done_Instance( tt_instance );
        valid := false;
      end;

    inherited Done;
  end;


  (****************************************************************)
  (*  Font object class                                           *)
  (*                                                              *)
  (*  The font objects as seen by the client application.         *)
  (*                                                              *)
  (****************************************************************)
  {
  TFontObject = object( TFontRoot )

      fontface    : PFontFace;         (* font face               *)
      fontsize    : PFontSize;         (* font size               *)

      flags       : integer;           (* type flag for font      *)
      resX, resY  : integer;           (* output resolutions      *)
      transform   : FT_Matrix;         (* transform               *)

      constructor Init( descr : FT_Font_Description );
      destructor  Done;
  end;

  FT_Text_Metrics = object
      fontType        : integer;  (* the font's internal format *)

      height          : integer;  (* height in pixels               *)
      width           : integer;  (* width in pixels                *)
      ptSize          : integer;  (* point size in 26.6 fixed float *)

      ascender        : integer;  (* ascender in pixels  *)
      descender       : integer;  (* descender in pixels *)
      linegap         : integer;  (* linegap in pixels   *)

      internalLeading : integer;
      externalLeading : integer;

      avgCharWidth    : integer;  (* average char width in pixels *)
      maxCharWidth    : integer;  (* maximum char width in pixels *)

      weight          : integer;
      styles          : integer;  (* styles flag *)

      charSet         : integer;  (* 'common' character sets supported *)
      overhang        : integer;  (* overhang in pixels                *)

      familyName        : string;   (* e.g. "Times New Roman"        *)
      styleName         : string;   (* e.g. "Italic"                 *)
      fullName          : string;   (* e.g. "Times New Roman Italic" *)
  end;
  }

  (****************************************************************)
  (*  Font Object construction                                    *)
  (*                                                              *)
  constructor TFontObject.Init;
  begin
    inherited Init;
    fontface := nil;
    fontsize := nil;
    flags    := 0;

    (* set minimal resolutions *)
    resX     := 72;
    resY     := 72;

    (* set identity transform *)
    with transform.matrix do begin
      xx := 1 shl 16;  xy := 0; yx := 0; yy := 1 shl 16;
    end;
    transform.x_ofs := 0;
    transform.y_ofs := 0;
  end;

  (****************************************************************)
  (*  Font Object destructor                                      *)
  (*                                                              *)
  destructor  TFontObject.Done;
  begin
    if fontsize <> nil then
    begin
      fontsize^.decRef;
      fontsize := nil;
    end;
    fontface := nil;
  end;

  (****************************************************************)
  (*  Font Object construction                                    *)
  (*                                                              *)
  function TFontObject.Create_TrueType(
                           var descr : FT_Font_Description ) : FT_Error;
  var
    res      : PFontResource;
    error    : FT_Error;
    tmetrics : ^FT_Outline_Text_Metrics;

    head     : ^TT_Header;
    horiz    : ^TT_Horizontal_Header;
    os2      : ^TT_OS2;
    ins      : TT_Instance;
    xpixel   : TT_F26dot6;
    ypixel   : TT_F26dot6;
  label
    Fail_Resource, Fail_Size;

  begin
    res := Find_FontResource_By_Filename( descr.facename );

    if res = nil then
      begin
       (* XXX : now, we always look for a TrueType file in the "facename" *)
       (* field, and ignore style and subIndex                            *)
        error := Load_TrueType_File( descr.facename, true, res );
        if error <> FT_Err_Ok then goto Fail_Resource;
      end;

    (* for now, we only load the first embedded font in collections *)
    fontface := PFontFace(res^.faces.head);

    (* create new fontsize *)
    error := fontface^.New_FontSize( descr, fontsize );
    if error <> FT_Err_Ok then goto Fail_Size;

    flags       := descr.queryType;
    resx        := descr.resx;
    resy        := descr.resy;
    transform   := descr.transform;

    (* adjust transform offsets if necessary *)
    if flags and FT_Flag_Use_Transform <> 0 then
    begin
      transform.x_ofs := fontsize^.scalex( transform.x_ofs );
      transform.y_ofs := fontsize^.scaley( transform.y_ofs );
    end;

    exit;

  Fail_Size:
    fontface^.decRef;
    fontface := nil;
    fontsize := nil;

  Fail_Resource:
    lib.error := FT_Error(FT_Error_Class_TrueType + error);
  end;


end.
