+ FreeType font and freetype font library calls

+ test program for fonts

fcl/image/freetype.pp

@@ -0,0 +1,850 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    Basic canvas definitions.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+{$mode objfpc}{$h+}
+unit freetype;
+
+interface
+
+uses sysutils, classes, freetypeh, FPImgCmn;
+
+{ TODO : take resolution in account to find the size }
+{ TODO : speed optimization: search glyphs with a hash-function/tree/binary search/... }
+{ TODO : memory optimization: TStringBitmaps keeps for each differnet character
+         only 1 bitmap }
+{ TODO : load other files depending on the extention }
+{ possible TODO : different sizes/resolutions for x and y }
+{ possible TODO : TFontmanager can fill a list of all the fonts he can find
+              fontfiles and faces available in a fontfile }
+
+// determine if file comparison need to be case sensitive or not
+{$ifdef WIN32}
+  {$undef CaseSense}
+{$else}
+  {$define CaseSense}
+{$endif}
+
+type
+
+  FreeTypeException = class (exception);
+
+  TBitmapType = (btBlackWhite, bt256Gray);
+  TFontBitmap = record
+    height, width, pitch,
+    x,y, advanceX, advanceY : integer;
+    data : PByteArray;
+  end;
+  PFontBitmap = ^TFontBitmap;
+
+
+  TStringBitMaps = class
+    private
+      FList : TList;
+      FBounds : TRect;
+      FText : string;
+      FMode : TBitmapType;
+      function GetCount : integer;
+      function GetBitmap (index:integer) : PFontBitmap;
+      procedure CalculateGlobals;
+    public
+      constructor Create (ACount : integer);
+      destructor destroy; override;
+      procedure GetBoundRect (var aRect : TRect);
+      property Text : string read FText;
+      property Mode : TBitmapType read FMode;
+      property Count : integer read GetCount;
+      property Bitmaps[index:integer] : PFontBitmap read GetBitmap;
+  end;
+
+  TFontManager = class;
+
+  PMgrGlyph = ^TMgrGlyph;
+  TMgrGlyph = record
+    Character : char;
+    GlyphIndex : FT_UInt;
+    Glyph : PFT_Glyph;
+  end;
+
+  PMgrSize = ^TMgrSize;
+  TMgrSize = record
+    Resolution, Size : integer;
+    Glyphs : TList;
+  end;
+
+  TMgrFont = class
+    private
+      Mgr : TFontManager;
+      Font : PFT_Face;
+      FSizes : TList;
+      Filename : string;
+      LastSize : PMgrSize;
+      procedure FreeGlyphs;
+    public
+      constructor Create (aMgr:TFontManager; afilename:string; anindex:integer);
+      destructor destroy; override;
+  end;
+
+  TFontManager = class
+    private
+      FTLib : PFT_Library;
+      FList : TList;
+      FPaths : TStringList;
+      FExtention : string;
+      FResolution : integer;
+      CurFont : TMgrFont;
+      CurSize : PMgrSize;
+      CurRenderMode : FT_Render_Mode;
+      CurTransform : FT_Matrix;
+      UseKerning : boolean;
+      function GetSearchPath : string;
+      procedure SetSearchPath (AValue : string);
+      procedure SetExtention (AValue : string);
+    protected
+      function GetFontId (afilename:string; anindex:integer) : integer;
+      function CreateFont (afilename:string; anindex:integer) : integer;
+      function SearchFont (afilename:string) : string;
+      function GetFont (FontID:integer) : TMgrFont;
+      procedure GetSize (aSize, aResolution : integer);
+      function CreateSize (aSize, aResolution : integer) : PMgrSize;
+      procedure SetPixelSize (aSize, aResolution : integer);
+      function GetGlyph (c : char) : PMgrGlyph;
+      function CreateGlyph (c : char) : PMgrGlyph;
+      procedure MakeTransformation (angle:real; var Transformation:FT_Matrix);
+      procedure InitMakeString (FontID, Size:integer);
+      function MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+      function MakeString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+    public
+      constructor Create;
+      destructor destroy; override;
+      function RequestFont (afilename:string) : integer;
+      function RequestFont (afilename:string; anindex:integer) : integer;
+      function GetFreeTypeFont (aFontID:integer) : PFT_Face;
+      function GetString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+      // Black and white
+      function GetStringGray (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+      // Anti Aliased gray scale
+      function GetString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+      // Black and white, following the direction of the font (left to right, top to bottom, ...)
+      function GetStringGray (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+      // Anti Aliased gray scale, following the direction of the font (left to right, top to bottom, ...)
+      property SearchPath : string read GetSearchPath write SetSearchPath;
+      property DefaultExtention : string read FExtention write SetExtention;
+      property Resolution : integer read Fresolution write FResolution;
+  end;
+
+const
+  sErrErrorsInCleanup : string = '%d errors detected while freeing a Font Manager object';
+  sErrFontFileNotFound : string = 'Font file "%s" not found';
+  sErrFreeType : string = 'Error %d while %s';
+  sInitializing : string = 'initializing font engine';
+  sDestroying : string = 'destroying font engine';
+  sErrErrorInCleanup : string = 'freeing Font Manager object';
+  sErrSetPixelSize : string = 'setting pixel size %d (resolution %d)';
+  sErrSetCharSize : string = 'setting char size %d (resolution %d)';
+  sErrLoadingGlyph : string = 'loading glyph';
+  sErrKerning : string = 'determining kerning distance';
+  sErrMakingString : string = 'making string bitmaps';
+  sErrLoadFont : string = 'loading font %d from file %s';
+  sErrInitializing : string = 'initializing FreeType';
+  sErrDestroying : string = 'finalizing FreeType';
+
+  DefaultFontExtention : string = '.ttf';
+  DefaultSearchPath : string = '';
+  {$IFDEF MAC}
+  DefaultResolution : integer = 72;
+  {$ELSE}
+  DefaultResolution : integer = 97;
+  {$ENDIF}
+
+implementation
+
+{$IFDEF win32}uses dos;{$ENDIF}
+
+procedure FTError (Event:string; Err:integer);
+begin
+  raise FreeTypeException.CreateFmt (sErrFreeType, [Event,Err]);
+end;
+
+{ TMgrFont }
+
+constructor TMgrFont.Create (aMgr:TFontManager; afilename:string; anindex:integer);
+var e : integer;
+begin
+  inherited create;
+  Filename := afilename;
+  Mgr := aMgr;
+  FSizes := TList.create;
+  LastSize := nil;
+  e := FT_New_Face (aMgr.FTLib, pchar(afilename), anindex, font);
+  if e <> 0 then
+    begin
+    Font := nil;
+    FTError (format (sErrLoadFont,[afilename,anindex]), e);
+    end;
+end;
+
+destructor TMgrFont.destroy;
+begin
+  try
+    FreeGlyphs;
+  finally
+    FSizes.Free;
+    inherited Destroy;
+  end;
+end;
+
+procedure TMgrFont.FreeGlyphs;
+var r,t : integer;
+    S : PMgrSize;
+    G : PMgrGlyph;
+begin
+  for r := FSizes.count-1 downto 0 do
+    begin
+    with PMgrSize(FSizes[r])^ do
+      begin
+      for t := Glyphs.count-1 downto 0 do
+        begin
+        with PMgrGlyph(Glyphs[t])^ do
+          FT_Done_Glyph (Glyph);
+        G := PMgrGlyph(Glyphs[t]);
+        dispose (G);
+        end;
+      Glyphs.Free;
+      end;
+    S := PMgrSize(FSizes[r]);
+    dispose (S);
+    end;
+end;
+
+
+{ TFontManager }
+
+constructor TFontManager.Create;
+var r : integer;
+begin
+  inherited create;
+  FList := Tlist.Create;
+  FPaths := TStringList.Create;
+  r := FT_Init_FreeType(FTLib);
+  if r <> 0  then
+    begin
+    FTLib := nil;
+    FTError (sErrInitializing, r);
+    end;
+  SearchPath := DefaultSearchPath;
+  DefaultExtention := DefaultFontExtention;
+  Resolution := DefaultResolution;
+end;
+
+destructor TFontManager.Destroy;
+  procedure FreeFontObjects;
+  var r : integer;
+  begin
+    for r := FList.Count-1 downto 0 do
+      begin
+      GetFont(r).Free;
+      end;
+  end;
+  procedure FreeLibrary;
+  var r : integer;
+  begin
+    r := FT_Done_FreeType (FTlib);
+    if r <> 0 then
+      FTError (sErrDestroying, r);
+  end;
+begin
+  FreeFontObjects;
+  FList.Free;
+  FPaths.Free;
+  try
+    if assigned(FTLib) then
+      FreeLibrary;
+  finally
+    inherited Destroy;
+  end;
+end;
+
+function TFontManager.GetSearchPath : string;
+var r : integer;
+begin
+  if FPaths.count > 0 then
+    begin
+    result := FPaths[0];
+    for r := 1 to FPaths.count-1 do
+      result := result + ';' + FPaths[r];
+    end
+  else
+    result := '';
+end;
+
+procedure TFontManager.SetSearchPath (AValue : string);
+  procedure AddPath (apath : string);
+  begin
+    FPaths.Add (IncludeTrailingBackslash(Apath));
+  end;
+var p : integer;
+begin
+  while (AValue <> '') do
+    begin
+    p := pos (';', AValue);
+    if p = 0 then
+      begin
+      AddPath (AValue);
+      AValue := '';
+      end
+    else
+      begin
+      AddPath (copy(AValue,1,p-1));
+      delete (AVAlue,1,p);
+      end;
+    end;
+end;
+
+procedure TFontManager.SetExtention (AValue : string);
+begin
+  if AValue <> '' then
+    if AValue[1] <> '.' then
+      FExtention := '.' + AValue
+    else
+      FExtention := AValue
+  else
+    AValue := '';
+end;
+
+function TFontManager.SearchFont (afilename:string) : string;
+// returns full filename of font, taking SearchPath in account
+var p,fn : string;
+    r : integer;
+begin
+  if (pos('.', afilename)=0) and (DefaultFontExtention<>'') then
+    fn := afilename + DefaultFontExtention
+  else
+    fn := aFilename;
+  if FileExists(fn) then
+    result := ExpandFilename(fn)
+  else
+    begin
+    p := ExtractFilepath(fn);
+    if p = '' then
+      begin  // no path given, look in SearchPaths
+      r := FPaths.Count;
+      repeat
+        dec (r);
+      until (r < 0) or FileExists(FPaths[r]+fn);
+      if r < 0 then
+        raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [fn])
+      else
+        result := FPaths[r]+fn;
+      end
+    else
+      raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [afilename]);
+    end;
+end;
+
+function TFontManager.GetFontId (afilename:string; anindex:integer) : integer;
+begin
+  result := FList.count-1;
+  while (result >= 0) and
+        ( ({$ifdef CaseSense}CompareText{$else}CompareStr{$endif}
+              (TMgrFont(FList[anIndex]).Filename, afilename) <> 0) or
+          (anIndex <> TMgrFont(FList[anIndex]).font^.face_index)
+        ) do
+    dec (result);
+end;
+
+function TFontManager.CreateFont (afilename:string; anindex:integer) : integer;
+var f : TMgrFont;
+begin
+  writeln ('creating font ',afilename,' (',anindex,')');
+  f := TMgrFont.Create (self, afilename, anindex);
+  result := FList.Count;
+  Flist.Add (f);
+end;
+
+function TFontManager.GetFont (FontID:integer) : TMgrFont;
+begin
+  result := TMgrFont(FList[FontID]);
+  if result <> CurFont then  // set last used size of the font as current size
+    begin
+    CurSize := result.LastSize;
+    end;
+end;
+
+procedure TFontManager.GetSize (aSize, aResolution : integer);
+var r : integer;
+begin
+  if not ( assigned(CurSize) and
+          (CurSize^.Size = aSize) and (CurSize^.resolution = aResolution)) then
+    begin
+    r := CurFont.FSizes.count;
+    repeat
+      dec (r)
+    until (r < 0) or ( (PMgrSize(CurFont.FSizes[r])^.size = aSize) and
+                       (PMgrSize(CurFont.FSizes[r])^.resolution = FResolution) );
+    if r < 0 then
+      CurSize := CreateSize (aSize,aResolution)
+    else
+      CurSize := PMgrSize(CurFont.FSizes[r]);
+    CurFont.LastSize := CurSize;
+    end;
+end;
+
+function TFontManager.CreateSize (aSize, aResolution : integer) : PMgrSize;
+begin
+  new (result);
+  result^.Size := aSize;
+  result^.Size := aResolution;
+  result^.Glyphs := Tlist.Create;
+  SetPixelSize (aSize,aResolution);
+  CurFont.FSizes.Add (result);
+end;
+
+procedure TFontManager.SetPixelSize (aSize, aResolution : integer);
+
+  procedure CheckSize;
+  var r : integer;
+  begin
+    with Curfont.Font^ do
+      begin
+      r := Num_fixed_sizes;
+      repeat
+        dec (r);
+      until (r < 0) or
+         ( (available_sizes^[r].height=asize) and
+           (available_sizes^[r].width=asize) );
+      if r >= 0 then
+        raise FreeTypeException.CreateFmt ('Size %d not available for %s %s',
+                  [aSize, style_name, family_name]);
+      end;
+  end;
+
+var s : longint;
+    Err : integer;
+
+begin
+  with Curfont, Font^ do
+    if (face_flags and FT_Face_Flag_Fixed_Sizes) <> 0 then
+      begin
+      CheckSize;
+      Err := FT_Set_pixel_sizes (Font, aSize, aSize);
+      if Err <> 0 then
+        FTError (format(sErrSetPixelSize,[aSize,aResolution]), Err);
+      end
+    else
+      begin
+      s := aSize shl 6;
+      Err := FT_Set_char_size (Font, s, s, aResolution, aResolution);
+      if Err <> 0 then
+        FTError (format(sErrSetCharSize,[aSize,aResolution]), Err);
+      end;
+end;
+
+procedure TFontManager.MakeTransformation (angle:real; var Transformation:FT_Matrix);
+begin
+  with Transformation do
+    begin
+    xx := round( cos(angle)*$10000);
+    xy := round(-sin(angle)*$10000);
+    yx := round( sin(angle)*$10000);
+    yy := round( cos(angle)*$10000);
+    end;
+end;
+
+function TFontManager.CreateGlyph (c : char) : PMgrGlyph;
+var e : integer;
+begin
+  new (result);
+  result^.character := c;
+  result^.GlyphIndex := FT_Get_Char_Index (CurFont.font, ord(c));
+  e := FT_Load_Glyph (CurFont.font, result^.GlyphIndex, FT_Load_Default);
+  if e <> 0 then
+    begin
+    FTError (sErrLoadingGlyph, e);
+    end;
+  e := FT_Get_Glyph (Curfont.font^.glyph, result^.glyph);
+  if e <> 0 then
+    begin
+    FTError (sErrLoadingGlyph, e);
+    end;
+  CurSize^.Glyphs.Add (result);
+end;
+
+function TFontManager.GetGlyph (c : char) : PMgrGlyph;
+var r : integer;
+begin
+  With CurSize^ do
+    begin
+    r := FList.Count;
+    repeat
+      dec (r)
+    until (r < 0) or (PMgrGlyph(Flist[r])^.character = c);
+    if r < 0 then
+      result := CreateGlyph (c)
+    else
+      result := PMgrGlyph(Flist[r]);
+    end;
+end;
+
+procedure TFontManager.InitMakeString (FontID, Size:integer);
+begin
+  GetSize (size,Resolution);
+  UseKerning := ((Curfont.font^.face_flags and FT_FACE_FLAG_KERNING) <> 0);
+end;
+
+function TFontManager.MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+var g : PMgrGlyph;
+    bm : PFT_BitmapGlyph;
+    gl : PFT_Glyph;
+    e, prevIndex, prevx, c, r, rx : integer;
+    pre, adv, pos, kern : FT_Vector;
+    buf : PByteArray;
+    reverse : boolean;
+    trans : FT_Matrix;
+begin
+  CurFont := GetFont(FontID);
+  if  (Angle = 0) or   // no angle asked, or can't work with angles (not scalable)
+      ((CurFont.Font^.face_flags and FT_FACE_FLAG_SCALABLE)=0) then
+    result := MakeString (FontID, Text, Size)
+  else
+    begin
+    InitMakeString (FontID, Size);
+    c := length(text);
+    result := TStringBitmaps.Create(c);
+    if (CurRenderMode = FT_RENDER_MODE_MONO) then
+      result.FMode := btBlackWhite
+    else
+      result.FMode := bt256Gray;
+    MakeTransformation (angle, trans);
+    prevIndex := 0;
+    prevx := 0;
+    pos.x := 0;
+    pos.y := 0;
+    pre.x := 0;
+    pre.y := 0;
+    for r := 0 to c-1 do
+      begin
+      // retrieve loaded glyph
+      g := GetGlyph (Text[r+1]);
+      // check kerning
+      if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
+        begin
+        prevx := pre.x;
+        e := FT_Get_Kerning (Curfont.Font, prevIndex, g^.GlyphIndex, ft_kerning_default, kern);
+        if e <> 0 then
+          FTError (sErrKerning, e);
+        pre.x := pre.x + kern.x;
+        end;
+      // render the glyph
+      e := FT_Glyph_Copy (g^.glyph, gl);
+      if e <> 0 then
+        FTError (sErrMakingString, e);
+      //    placing the glyph
+      e := FT_Glyph_Transform (gl, nil, @pre);
+      if e <> 0 then
+        FTError (sErrMakingString, e);
+      adv := gl^.advance;
+      //    rotating the glyph
+      e := FT_Glyph_Transform (gl, @trans, nil);
+      if e <> 0 then
+        FTError (sErrMakingString, e);
+      //    rendering the glyph
+      e := FT_Glyph_To_Bitmap (gl, CurRenderMode, nil, true);
+      if e <> 0 then
+        FTError (sErrMakingString, e);
+      // Copy what is needed to record
+      bm := PFT_BitmapGlyph(gl);
+      with result.Bitmaps[r]^ do
+        begin
+        with gl^.advance do
+          begin
+          advanceX := x div 64;
+          advanceY := y div 64;
+          end;
+        with bm^ do
+          begin
+          height := bitmap.rows;
+          width := bitmap.width;
+          x := {(pos.x div 64)} + left;  // transformed bitmap has correct x,y
+          y := {(pos.y div 64)} - top;   // not transformed has only a relative correction
+          buf := PByteArray(bitmap.buffer);
+          reverse := (bitmap.pitch < 0);
+          if reverse then
+            begin
+            pitch := -bitmap.pitch;
+            getmem (data, pitch*height);
+            for rx := height-1 downto 0 do
+              move (buf^[rx*pitch], data^[(height-rx-1)*pitch], pitch);
+            end
+          else
+            begin
+            pitch := bitmap.pitch;
+            rx := pitch*height;
+            getmem (data, rx);
+            move (buf^[0], data^[0], rx);
+            end;
+          end;
+        end;
+      // place position for next glyph
+      with gl^.advance do
+        begin
+        pos.x := pos.x + (x div 1024);
+        pos.y := pos.y + (y div 1024);
+        end;
+      with adv do
+        pre.x := pre.x + (x div 1024);
+      if prevx > pre.x then
+        pre.x := prevx;
+      // finish rendered glyph
+      FT_Done_Glyph (gl);
+      end;
+    result.FText := Text;
+    result.CalculateGlobals;
+    end;
+end;
+
+function TFontManager.MakeString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+var g : PMgrGlyph;
+    bm : PFT_BitmapGlyph;
+    gl : PFT_Glyph;
+    e, prevIndex, prevx, c, r, rx : integer;
+    pos, kern : FT_Vector;
+    buf : PByteArray;
+    reverse : boolean;
+begin
+  CurFont := GetFont(FontID);
+  InitMakeString (FontID, Size);
+  c := length(text);
+  result := TStringBitmaps.Create(c);
+  if (CurRenderMode = FT_RENDER_MODE_MONO) then
+    result.FMode := btBlackWhite
+  else
+    result.FMode := bt256Gray;
+  prevIndex := 0;
+  prevx := 0;
+  pos.x := 0;
+  pos.y := 0;
+  for r := 0 to c-1 do
+    begin
+    // retrieve loaded glyph
+    g := GetGlyph (Text[r+1]);
+    // check kerning
+    if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
+      begin
+      prevx := pos.x;
+      e := FT_Get_Kerning (Curfont.Font, prevIndex, g^.GlyphIndex, ft_kerning_default, kern);
+      if e <> 0 then
+        FTError (sErrKerning, e);
+      pos.x := pos.x + kern.x;
+      end;
+    // render the glyph
+    e := FT_Glyph_Copy (g^.glyph, gl);
+    if e <> 0 then
+      FTError (sErrMakingString, e);
+    e := FT_Glyph_To_Bitmap (gl, CurRenderMode, @pos, true);
+    if e <> 0 then
+      FTError (sErrMakingString, e);
+    // Copy what is needed to record
+    bm := PFT_BitmapGlyph(gl);
+    with result.Bitmaps[r]^ do
+      begin
+      with gl^.advance do
+        begin
+        advanceX := x shr 6;
+        advanceY := y shr 6;
+        end;
+      with bm^ do
+        begin
+        height := bitmap.rows;
+        width := bitmap.width;
+        x := (pos.x shr 6) + left;   // transformed bitmap has correct x,y             
+        y := (pos.y shr 6) - top;    // not transformed has only a relative correction 
+        buf := PByteArray(bitmap.buffer);
+        reverse := (bitmap.pitch < 0);
+        if reverse then
+          begin
+          pitch := -bitmap.pitch;
+          getmem (data, pitch*height);
+          for rx := height-1 downto 0 do
+            move (buf^[rx*pitch], data^[(height-rx-1)*pitch], pitch);
+          end
+        else
+          begin
+          pitch := bitmap.pitch;
+          rx := pitch*height;
+          getmem (data, rx);
+          move (buf^[0], data^[0], rx);
+          end;
+        end;
+      end;
+    // place position for next glyph
+    pos.x := pos.x + (gl^.advance.x shr 10);
+    // pos.y := pos.y + (gl^.advance.y shr 6); // for angled texts also
+    if prevx > pos.x then
+      pos.x := prevx;
+    // finish rendered glyph
+    FT_Done_Glyph (gl);
+    end;
+  result.FText := Text;
+  result.CalculateGlobals;
+end;
+
+function TFontManager.GetString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+// Black and white
+begin
+  CurRenderMode := FT_RENDER_MODE_MONO;
+  result := MakeString (FontID, text, Size, angle);
+end;
+
+function TFontManager.GetStringGray (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+// Anti Aliased gray scale
+begin
+  CurRenderMode := FT_RENDER_MODE_NORMAL;
+  result := MakeString (FontID, text, Size, angle);
+end;
+
+{ Procedures without angle have own implementation to have better speed }
+
+function TFontManager.GetString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+// Black and white, following the direction of the font (left to right, top to bottom, ...)
+begin
+  CurRenderMode := FT_RENDER_MODE_MONO;
+  result := MakeString (FontID, text, Size);
+end;
+
+function TFontManager.GetStringGray (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+// Anti Aliased gray scale, following the direction of the font (left to right, top to bottom, ...)
+begin
+  CurRenderMode := FT_RENDER_MODE_NORMAL;
+  result := MakeString (FontID, text, Size);
+end;
+
+function TFontManager.RequestFont (afilename:string) : integer;
+begin
+  result := RequestFont (afilename,0);
+end;
+
+function TFontManager.RequestFont (afilename:string; anindex:integer) : integer;
+var s : string;
+begin
+  if afilename = '' then
+    result := -1
+  else
+    begin
+    s := SearchFont (afilename);
+    result := GetFontID (s,anindex);
+    if result < 0 then
+      result := CreateFont (s,anindex);
+    end;
+end;
+
+function TFontManager.GetFreeTypeFont (aFontID:integer) : PFT_Face;
+begin
+  result := GetFont(aFontID).font;
+end;
+
+{ TStringBitmaps }
+
+function TStringBitmaps.GetCount : integer;
+begin
+  result := FList.Count;
+end;
+
+function TStringBitmaps.GetBitmap (index:integer) : PFontBitmap;
+begin
+  result := PFontBitmap(FList[index]);
+end;
+
+constructor TStringBitmaps.Create (ACount : integer);
+var r : integer;
+    bm : PFontBitmap;
+begin
+  inherited create;
+  FList := Tlist.Create;
+  FList.Capacity := ACount;
+  for r := 0 to ACount-1 do
+    begin
+    new (bm);
+    FList.Add (bm);
+    end;
+end;
+
+destructor TStringBitmaps.destroy;
+var r : integer;
+    bm : PFontBitmap;
+begin
+  for r := 0 to Flist.count-1 do
+    begin
+    bm := PFontBitmap(FList[r]);
+    freemem (bm^.data);
+    dispose (bm);
+    end;
+  FList.Free;
+  inherited;
+end;
+
+procedure TStringBitmaps.CalculateGlobals;
+var r : integer;
+begin
+  if count = 0 then
+    Exit;
+  // check first 2 bitmaps for left side
+  // check last 2 bitmaps for right side
+  with BitMaps[0]^ do
+    begin
+    FBounds.left := x;
+    FBounds.top := y + height;
+    FBounds.bottom := y;
+    end;
+  with Bitmaps[count-1]^ do
+    FBounds.right := x + width;
+  if count > 1 then
+    begin
+    with Bitmaps[1]^ do
+      r := x;
+    if r < FBounds.left then
+      FBounds.left := r;
+    with Bitmaps[count-2]^ do
+      r := x + width;
+    if r > FBounds.right then
+      FBounds.right := r;
+    end;
+  // check top/bottom of other bitmaps
+  for r := 1 to count-1 do
+    with Bitmaps[r]^ do
+      begin
+      if FBounds.top < y + height then
+        FBounds.top := y + height;
+      if FBounds.bottom > y then
+        FBounds.bottom := y;
+      end;
+end;
+
+procedure TStringBitmaps.GetBoundRect (var aRect : TRect);
+begin
+  aRect := FBounds;
+end;
+
+{$ifdef win32}
+procedure SetWindowsFontPath;
+begin
+  DefaultSearchPath := includetrailingbackslash(GetEnv('windir')) + 'fonts';
+end;
+{$endif}
+
+initialization
+  {$ifdef win32}
+  SetWindowsFontPath;
+  {$endif}
+end.

fcl/image/freetypeh.pp

@@ -0,0 +1,336 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    Basic canvas definitions.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+{$mode objfpc}
+unit freetypeh;
+
+{ These are not all the availlable calls from the dll, but only those
+  I needed for the TStringBimaps }
+
+interface
+
+const
+{$ifdef win32}
+  freetypedll = 'freetype-6.dll';   // version 2.1.4
+  {$packrecords c}
+{$else}
+  // I don't know what it will be ??
+  freetypedll = 'freetype-6.dll';
+{$endif}
+
+type
+  FT_Encoding = array[0..3] of char;
+
+const
+  FT_FACE_FLAG_SCALABLE = 1 shl 0;
+  FT_FACE_FLAG_FIXED_SIZES = 1 shl 1;
+  FT_FACE_FLAG_FIXED_WIDTH = 1 shl 2;
+  FT_FACE_FLAG_SFNT = 1 shl 3;
+  FT_FACE_FLAG_HORIZONTAL = 1 shl 4;
+  FT_FACE_FLAG_VERTICAL = 1 shl 5;
+  FT_FACE_FLAG_KERNING = 1 shl 6;
+  FT_FACE_FLAG_FAST_GLYPHS = 1 shl 7;
+  FT_FACE_FLAG_MULTIPLE_MASTERS = 1 shl 8;
+  FT_FACE_FLAG_GLYPH_NAMES = 1 shl 9;
+  FT_FACE_FLAG_EXTERNAL_STREAM = 1 shl 10;
+
+  FT_STYLE_FLAG_ITALIC = 1 shl 0;
+  FT_STYLE_FLAG_BOLD = 1 shl 1;
+
+  FT_LOAD_DEFAULT =          $0000;
+  FT_LOAD_NO_SCALE =         $0001;
+  FT_LOAD_NO_HINTING =       $0002;
+  FT_LOAD_RENDER =           $0004;
+  FT_LOAD_NO_BITMAP =        $0008;
+  FT_LOAD_VERTICAL_LAYOUT =  $0010;
+  FT_LOAD_FORCE_AUTOHINT =   $0020;
+  FT_LOAD_CROP_BITMAP =      $0040;
+  FT_LOAD_PEDANTIC =         $0080;
+  FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = $0200;
+  FT_LOAD_NO_RECURSE =       $0400;
+  FT_LOAD_IGNORE_TRANSFORM = $0800;
+  FT_LOAD_MONOCHROME =       $1000;
+  FT_LOAD_LINEAR_DESIGN =    $2000;
+
+  ft_glyph_format_none      = $00000000;
+  ft_glyph_format_composite = $636F6D70; //comp 099 111 109 112
+  ft_glyph_format_bitmap    = $62697473; //bits 098 105 116 115
+  ft_glyph_format_outline   = $6F75746C; //outl 111 117 116 108
+  ft_glyph_format_plotter   = $706C6F74; //plot 112 108 111 116
+
+  FT_ENCODING_MS_SYMBOL : FT_Encoding = 'symb';
+  FT_ENCODING_UNICODE : FT_Encoding = 'unic';
+  FT_ENCODING_MS_SJIS : FT_Encoding = 'sjis';
+  FT_ENCODING_MS_GB2312 : FT_Encoding = 'gb  ';
+  FT_ENCODING_MS_BIG5 : FT_Encoding = 'big5';
+  FT_ENCODING_MS_WANSUNG : FT_Encoding = 'wans';
+  FT_ENCODING_MS_JOHAB : FT_Encoding = 'joha';
+  FT_ENCODING_ADOBE_STANDARD : FT_Encoding = 'ADOB';
+  FT_ENCODING_ADOBE_EXPERT : FT_Encoding = 'ADBE';
+  FT_ENCODING_ADOBE_CUSTOM : FT_Encoding = 'ADBC';
+  FT_ENCODING_ADOBE_LATIN_1 : FT_Encoding = 'lat1';
+  FT_ENCODING_OLD_LATIN_2 : FT_Encoding = 'lat2';
+  FT_ENCODING_APPLE_ROMAN : FT_Encoding = 'armn';
+
+  ft_glyph_bbox_unscaled  = 0; //* return unscaled font units           */
+  ft_glyph_bbox_subpixels = 0; //* return unfitted 26.6 coordinates     */
+  ft_glyph_bbox_gridfit   = 1; //* return grid-fitted 26.6 coordinates  */
+  ft_glyph_bbox_truncate  = 2; //* return coordinates in integer pixels */
+  ft_glyph_bbox_pixels    = 3; //* return grid-fitted pixel coordinates */
+
+  FT_KERNING_DEFAULT  = 0;
+  FT_KERNING_UNFITTED = 1;
+  FT_KERNING_UNSCALED = 2;
+
+
+type
+
+  FT_Bool = boolean;
+  FT_FWord = smallint;
+  FT_UFWord = word;
+  FT_Char = char;
+  FT_Byte = byte;
+  FT_String = char;
+  FT_Short = smallint;
+  FT_UShort = word;
+  FT_Int = longint;
+  FT_UInt = longword;
+  FT_Long = longint;
+  FT_ULong = longword;
+  FT_F2Dot14 = smallint;
+  FT_F26Dot6 = longint;
+  FT_Fixed = longint;
+  FT_Error = longint;
+  FT_Pointer = pointer;
+  FT_Pos = longint;
+  //FT_Offset = size_t;
+  //FT_PtrDist = size_t;
+
+  FT_Render_Mode = (FT_RENDER_MODE_NORMAL, FT_RENDER_MODE_LIGHT,
+      FT_RENDER_MODE_MONO, FT_RENDER_MODE_LCD, FT_RENDER_MODE_LCD_V,
+      FT_RENDER_MODE_MAX);
+
+  FT_UnitVector_ = record
+      x : FT_F2Dot14;
+      y : FT_F2Dot14;
+   end;
+  FT_UnitVector = FT_UnitVector_;
+
+  FT_Matrix = record
+      xx : FT_Fixed;
+      xy : FT_Fixed;
+      yx : FT_Fixed;
+      yy : FT_Fixed;
+   end;
+  PFT_Matrix = ^FT_Matrix;
+
+  FT_Data = record
+      pointer : ^FT_Byte;
+      length : FT_Int;
+   end;
+
+  FT_Generic_Finalizer = procedure (AnObject:pointer);cdecl;
+
+  FT_Generic = record
+      data : pointer;
+      finalizer : FT_Generic_Finalizer;
+   end;
+
+  FT_Glyph_Metrics = record
+    width : FT_Pos;
+    height : FT_Pos;
+    horiBearingX : FT_Pos;
+    horiBearingY : FT_Pos;
+    horiAdvance : FT_Pos;
+    vertBearingX : FT_Pos;
+    vertBearingY : FT_Pos;
+    vertAdvance : FT_Pos;
+  end;
+
+  FT_Bitmap_Size = record
+    height : FT_Short;
+    width : FT_Short;
+  end;
+  AFT_Bitmap_Size = array [0..1023] of FT_Bitmap_Size;
+  PFT_Bitmap_Size = ^AFT_Bitmap_Size;
+
+  FT_Vector = record
+    x : FT_Pos;
+    y : FT_Pos;
+  end;
+  PFT_Vector = ^FT_Vector;
+
+  FT_BBox = record
+    xMin, yMin : FT_Pos;
+    xMax, yMax : FT_Pos;
+  end;
+  PFT_BBox = ^FT_BBox;
+
+  FT_Bitmap = record
+    rows : integer;
+    width : integer;
+    pitch : integer;
+    buffer : pointer;
+    num_grays : shortint;
+    pixel_mode : char;
+    palette_mode : char;
+    palette : pointer;
+  end;
+
+  FT_Outline = record
+    n_contours,
+    n_points : smallint;
+    points : PFT_Vector;
+    tags : pchar;
+    contours : ^smallint;
+    flags : integer;
+  end;
+
+  FT_Size_Metrics = record
+    x_ppem : FT_UShort;
+    y_ppem : FT_UShort;
+    x_scale : FT_Fixed;
+    y_scale : FT_Fixed;
+    ascender : FT_Pos;
+    descender : FT_Pos;
+    height : FT_Pos;
+    max_advance : FT_Pos;
+  end;
+
+
+  PFT_Library = ^TFT_Library;
+  //PPFT_Library = ^PFT_Library;
+  PFT_Face = ^TFT_Face;
+  //PPFT_Face = ^PFT_Face;
+  PFT_Charmap = ^TFT_Charmap;
+  PPFT_Charmap = ^PFT_Charmap;
+  PFT_GlyphSlot = ^TFT_GlyphSlot;
+  PFT_Subglyph = ^TFT_Subglyph;
+  PFT_Size = ^TFT_Size;
+
+  PFT_Glyph = ^TFT_Glyph;
+  //PPFT_Glyph = ^PFT_Glyph;
+  PFT_BitmapGlyph = ^TFT_BitmapGlyph;
+  PFT_OutlineGlyph = ^TFT_OutlineGlyph;
+
+
+  TFT_Library = record
+  end;
+
+  TFT_Charmap = record
+    face : PFT_Face;
+    encoding : FT_Encoding;
+    platform_id, encoding_id : FT_UShort;
+  end;
+
+  TFT_Size = record
+    face : PFT_Face;
+    generic : FT_Generic;
+    metrics : FT_Size_Metrics;
+    //internal : FT_Size_Internal;
+  end;
+
+  TFT_Subglyph = record  // TODO
+  end;
+
+  TFT_GlyphSlot = record
+    alibrary : PFT_Library;
+    face : PFT_Face;
+    next : PFT_GlyphSlot;
+    flags : FT_UInt;
+    generic : FT_Generic;
+    metrics : FT_Glyph_Metrics;
+    linearHoriAdvance : FT_Fixed;
+    linearVertAdvance : FT_Fixed;
+    advance : FT_Vector;
+    format : longword;
+    bitmap : FT_Bitmap;
+    bitmap_left : FT_Int;
+    bitmap_top : FT_Int;
+    outline : FT_Outline;
+    num_subglyphs : FT_UInt;
+    subglyphs : PFT_SubGlyph;
+    control_data : pointer;
+    control_len : longint;
+    other : pointer;
+  end;
+
+  TFT_Face = record
+    num_faces : FT_Long;
+    face_index : FT_Long;
+    face_flags : FT_Long;
+    style_flags : FT_Long;
+    num_glyphs : FT_Long;
+    family_name : pchar;
+    style_name : pchar;
+    num_fixed_sizes : FT_Int;
+    available_sizes : PFT_Bitmap_Size;     // is array
+    num_charmaps : FT_Int;
+    charmaps : PPFT_CharMap;               // is array
+    generic : FT_Generic;
+    bbox : FT_BBox;
+    units_per_EM : FT_UShort;
+    ascender : FT_Short;
+    descender : FT_Short;
+    height : FT_Short;
+    max_advance_width : FT_Short;
+    max_advance_height : FT_Short;
+    underline_position : FT_Short;
+    underline_thickness : FT_Short;
+    glyph : PFT_GlyphSlot;
+    size : PFT_Size;
+    charmap : PFT_CharMap;
+  end;
+
+  TFT_Glyph = record
+    FTlibrary : PFT_Library;
+    clazz : pointer;
+    aFormat : longword;
+    advance : FT_Vector;
+  end;
+
+  TFT_BitmapGlyph = record
+    root : TFT_Glyph;
+    left, top : FT_Int;
+    bitmap : FT_Bitmap;
+  end;
+
+  TFT_OutlineGlyph = record
+    root : TFT_Glyph;
+    outline : FT_Outline;
+  end;
+
+
+function FT_Init_FreeType(var alibrary:PFT_Library) : integer; cdecl; external freetypedll name 'FT_Init_FreeType';
+function FT_Done_FreeType(alibrary:PFT_Library) : integer; cdecl; external freetypedll name 'FT_Done_FreeType';
+procedure FT_Library_Version(alibrary:PFT_Library; var amajor,aminor,apatch:integer); cdecl; external freetypedll name 'FT_Library_Version';
+
+function FT_New_Face(alibrary:PFT_Library; filepathname:pchar; face_index:integer; var aface:PFT_Face):integer; cdecl; external freetypedll name 'FT_New_Face';
+function FT_Set_Pixel_Sizes(face:PFT_Face; pixel_width,pixel_height:FT_UInt) : integer; cdecl; external freetypedll name 'FT_Set_Pixel_Sizes';
+function FT_Set_Char_Size(face:PFT_Face; char_width,char_height:FT_F26dot6;horz_res, vert_res:FT_UInt) : integer; cdecl; external freetypedll name 'FT_Set_Char_Size';
+function FT_Get_Char_Index(face:PFT_Face; charcode:FT_ULong):FT_UInt; cdecl; external freetypedll name 'FT_Get_Char_Index';
+function FT_Load_Glyph(face:PFT_Face; glyph_index:FT_UInt ;load_flags:longint):integer; cdecl; external freetypedll name 'FT_Load_Glyph';
+function FT_Get_Kerning(face:PFT_Face; left_glyph, right_glyph, kern_mode:FT_UInt; var akerning:FT_Vector) : integer; cdecl; external freetypedll name 'FT_Get_Kerning';
+
+function FT_Get_Glyph(slot:PFT_GlyphSlot; var aglyph:PFT_Glyph) : integer; cdecl; external freetypedll name 'FT_Get_Glyph';
+function FT_Glyph_Transform(glyph:PFT_Glyph; matrix:PFT_Matrix; delta:PFT_Vector) : integer; cdecl; external freetypedll name 'FT_Glyph_Transform';
+function FT_Glyph_Copy(source:PFT_Glyph; var target:PFT_Glyph): integer; cdecl; external freetypedll name 'FT_Glyph_Copy';
+procedure FT_Glyph_Get_CBox(glyph:PFT_Glyph;bbox_mode:FT_UInt;var acbox:FT_BBox); cdecl; external freetypedll name 'FT_Glyph_Get_CBox';
+function FT_Glyph_To_Bitmap(var the_glyph:PFT_Glyph;render_mode:FT_Render_Mode;origin:PFT_Vector; destroy:FT_Bool):integer; cdecl; external freetypedll name 'FT_Glyph_To_Bitmap';
+procedure FT_Done_Glyph (glyph:PFT_Glyph); cdecl; external freetypedll name 'FT_Done_Glyph';
+
+implementation
+
+end.

fcl/image/ftfont.pp

@@ -0,0 +1,307 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    Basic canvas definitions.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+{$mode objfpc}{$h+}
+unit ftfont;
+
+interface
+
+uses classes, FPCanvas, fpimgcmn, freetype, freetypeh;
+
+type
+
+  FreeTypeFontException = class (TFPFontException);
+
+  TFreeTypeFont = class (TFPCustomDrawFont)
+  private
+    FResolution : longword;
+    FAntiAliased : boolean;
+    FLastText : TStringBitmaps;
+    FIndex, FFontID : integer;
+    FFace : PFT_Face;
+    FAngle : real;
+    procedure DrawChar (x,y:integer; data:PByteArray; pitch, width, height:integer);
+    procedure DrawCharBW (x,y:integer; data:PByteArray; pitch, width, height:integer);
+    procedure ClearLastText;
+  protected
+    procedure SetName (AValue:string); override;
+    procedure SetIndex (AValue : integer);
+    procedure SetSize (AValue : integer); override;
+    function GetFlags (index:integer) : boolean; override;
+    procedure SetFlags (index:integer; AValue:boolean); override;
+    procedure DoAllocateResources; override;
+    procedure DoDeAllocateResources; override;
+    procedure DoCopyProps (From:TFPCanvasHelper); override;
+    procedure DoDrawText (atx,aty:integer; atext:string); override;
+    procedure DoGetTextSize (text:string; var w,h:integer); override;
+    function DoGetTextHeight (text:string) : integer; override;
+    function DoGetTextWidth (text:string) : integer; override;
+    procedure GetText (aText:string);
+    procedure GetFace;
+  public
+    constructor create; override;
+    property FontIndex : integer read FIndex write SetIndex;
+    property Resolution : longword read FResolution write FResolution;
+    property AntiAliased : boolean read FAntiAliased write FAntiAliased;
+    property Angle : real read FAngle write FAngle;
+  end;
+
+implementation
+
+uses sysutils, fpimage;
+
+var
+  FontMgr : TFontManager;
+
+procedure InitEngine;
+begin
+  if not assigned (FontMgr) then
+    FontMgr := TFontManager.create;
+end;
+
+procedure DoneEngine;
+begin
+  if assigned (FontMgr) then
+    FontMgr.Free;
+end;
+
+constructor TFreeTypeFont.Create;
+begin
+  inherited;
+  FFontID := -1;
+  FAntiAliased := True;
+  FResolution := DefaultResolution;
+end;
+
+procedure TFreeTypeFont.DoCopyProps (From:TFPCanvasHelper);
+var f : TFreeTypeFont;
+begin
+  inherited;
+  if from is TFreeTypeFont then
+    begin
+    f := TFreeTypeFont(from);
+    FIndex := F.Findex;
+    FAntiAliased := f.FAntiAliased;
+    FResolution := f.FResolution;
+    FAngle := f.FAngle;
+    end;
+end;
+
+procedure TFreeTypeFont.SetName (AValue:string);
+begin
+  inherited;
+  ClearLastText;
+  if allocated then
+    FFontID := FontMgr.RequestFont(Name, FIndex);
+end;
+
+procedure TFreeTypeFont.SetIndex (AValue : integer);
+begin
+  FIndex := AValue;
+  ClearLastText;
+  if allocated then
+    FFontID := FontMgr.RequestFont(Name, FIndex);
+end;
+
+procedure TFreeTypeFont.SetSize (AValue : integer);
+begin
+  ClearLastText;
+  inherited;
+end;
+
+procedure TFreeTypeFont.ClearLastText;
+begin
+  if assigned(FLastText) then
+    begin
+    FLastText.Free;
+    FlastText := nil;
+    end;
+end;
+
+procedure TFreeTypeFont.DoAllocateResources;
+begin
+  InitEngine;
+  FFontID := FontMgr.RequestFont(Name, FIndex);
+end;
+
+procedure TFreeTypeFont.DoDeAllocateResources;
+begin
+end;
+
+procedure TFreeTypeFont.DoGetTextSize (text:string; var w,h:integer);
+var r : TRect;
+begin
+  GetText (text);
+  FLastText.GetBoundRect (r);
+  with r do
+    begin
+    w := right - left;
+    h := top - bottom;
+    end;
+end;
+
+function TFreeTypeFont.DoGetTextHeight (text:string) : integer;
+var r : TRect;
+begin
+  GetText (text);
+  FLastText.GetBoundRect (r);
+  with r do
+    result := top - bottom;
+end;
+
+function TFreeTypeFont.DoGetTextWidth (text:string) : integer;
+var r : TRect;
+begin
+  GetText (text);
+  FLastText.GetBoundRect (r);
+  with r do
+    result := right - left;
+end;
+
+procedure TFreeTypeFont.SetFlags (index:integer; AValue:boolean);
+begin
+  if not (index in [5,6]) then   // bold,italic
+    inherited SetFlags (index, AValue);
+end;
+
+procedure TFreeTypeFont.GetFace;
+begin
+  if not assigned(FFace) then
+    FFace := FontMgr.GetFreeTypeFont (FFontID);
+end;
+
+function TFreeTypeFont.GetFlags (index:integer) : boolean;
+begin
+  if index = 5 then        //bold
+    begin
+    GetFace;
+    result := (FFace^.style_flags and FT_STYLE_FLAG_BOLD) <> 0;
+    end
+  else if index = 6 then    //italic
+    begin
+    GetFace;
+    result := (FFace^.style_flags and FT_STYLE_FLAG_ITALIC) <> 0;
+    end
+  else
+    result := inherited GetFlags (index);
+end;
+
+procedure TFreeTypeFont.GetText (aText:string);
+var b : boolean;
+begin
+  if assigned (FLastText) then
+    begin
+    if CompareStr(FLastText.Text,aText) <> 0 then
+      begin
+      FLastText.Free;
+      b := true;
+      end
+    else
+      begin
+      if FAntiAliased then
+        b := (FLastText.mode <> bt256Gray)
+      else
+        b := (FLastText.mode <> btBlackWhite);
+      if b then
+        FLastText.Free;
+      end;
+    end
+  else
+    b := true;
+  if b then
+    begin
+    FontMgr.Resolution := FResolution;
+    if FAntiAliased then
+      FLastText := FontMgr.GetStringGray (FFontId, aText, Size, Angle)
+    else
+      FLastText := FontMgr.GetString (FFontId, aText, Size, Angle);
+    end;
+end;
+
+procedure TFreeTypeFont.DoDrawText (atX,atY:integer; atext:string);
+var r,i : integer;
+    f : longint;
+begin
+  GetText (atext);
+  with FLastText do
+    for r := 0 to count-1 do
+      with Bitmaps[r]^ do
+        begin
+        if mode = btBlackWhite then
+          DrawCharBW (atX+x, atY+y, data, pitch, width, height)
+        else
+          DrawChar (atX+x, atY+y, data, pitch, width, height);
+        end;
+end;
+
+const
+  //bits : array[0..7] of byte = (1,2,4,8,16,32,64,128);
+  bits : array[0..7] of byte = (128,64,32,16,8,4,2,1);
+
+procedure TFreeTypeFont.DrawChar (x,y:integer; data:PByteArray; pitch, width, height:integer);
+
+  procedure Combine (canv:TFPCustomCanvas; x,y:integer; c : TFPColor; t:longword);
+  var a,r,g,b:longword;
+  begin
+    if t = 255 then
+      canv.colors[x,y] := c
+    else if t <> 0 then
+      begin
+      with canv.colors[x,y] do
+        begin
+        a := 255-t;
+        r := ((red * a) + (c.red * t)) div 255;
+        g := ((green * a) + (c.green * t)) div 255;
+        b := ((blue * a) + (c.blue * t)) div 255;
+        end;
+      canv.colors[x,y] := FPcolor(r,g,b,alphaOpaque);
+      end;
+  end;
+
+var b,rx,ry : integer;
+begin
+  b := 0;
+  for ry := 0 to height-1 do
+    begin
+    for rx := 0 to width-1 do
+      combine (canvas, x+rx, y+ry, color, data^[b+rx]);
+    inc (b, pitch);
+    end;
+end;
+
+procedure TFreeTypeFont.DrawCharBW (x,y:integer; data:PByteArray; pitch, width, height:integer);
+var rb : byte;
+    rx,ry,b,l : integer;
+begin
+  b := 0;
+  for ry := 0 to height-1 do
+    begin
+    l := 0;
+    for rx := 0 to width-1 do
+      begin
+      rb := rx mod 8;
+      if (data^[b+l] and bits[rb]) <> 0 then
+        canvas.colors[x+rx,y+ry] := color;
+      if rb = 7 then
+        inc (l);
+      end;
+    inc (b, pitch);
+    end;
+end;
+
+
+finalization
+  DoneEngine;
+end.