aggcanvas: adds preliminary font support

- moved fpg_fontcache unit to corelib/render/software/
- added fpg_fontcache unit to x11 fpgui_toolkit.lpk package
- translates FontDesc to FontCache item.

Tested under X11 only.

3 files changed, 440 insertions, 10 deletions

diff --git a/src/corelib/render/software/Agg2D.pas b/src/corelib/render/software/Agg2D.pas
index d729e4fb..13860ffd 100644
--- a/src/corelib/render/software/Agg2D.pas
+++ b/src/corelib/render/software/Agg2D.pas
@@ -2670,7 +2670,7 @@ begin
  m_fontEngine.hinting_(m_textHints );
 
  if cache = AGG_VectorFontCache then
-  m_fontEngine.height_(height )
+  m_fontEngine.height_(height{ * 1.3333} ) // 9pt = ~12px so that is a ration of 1.3333
  else
   m_fontEngine.height_(worldToScreen(height ) );
 {$ENDIF}
@@ -3555,18 +3555,24 @@ begin
 end;
 
 procedure TAgg2D.DoSetFontRes(fntres: TfpgFontResourceBase);
+{$IFDEF WINDOWS}
 begin
-  {$NOTE This is only temporary until I can correctly query font names }
-  {$IFDEF WINDOWS}
   Font('Arial', 13);
-  {$ELSE}
-    {$IFDEF BSD}
-    Font('/usr/local/lib/X11/fonts/Liberation/LiberationSans-Regular.ttf', 13);
-    {$ELSE}
-    Font('/usr/share/fonts/truetype/ttf-liberation/LiberationSans-Regular.ttf', 13);
-    {$ENDIF}
-  {$ENDIF}
 end;
+{$ENDIF}
+{$IFDEF UNIX}
+var
+  s: TfpgString;
+  i: integer;
+  fnt: TFontCacheItem;
+  lSize: double;
+begin
+  fnt := FontCacheItemFromFontDesc(TfpgFontResource(fntres).FontDesc, lSize);
+  i := gFontCache.Find(fnt);
+  if i > 0 then
+    Font(gFontCache.Items[i].FileName, lSize, fnt.IsBold, fnt.IsItalic);
+end;
+{$ENDIF}
 
 procedure TAgg2D.DoSetTextColor(cl: TfpgColor);
 var
diff --git a/src/corelib/render/software/agg_platform_x11.inc b/src/corelib/render/software/agg_platform_x11.inc
index 331b572e..0b070713 100644
--- a/src/corelib/render/software/agg_platform_x11.inc
+++ b/src/corelib/render/software/agg_platform_x11.inc
@@ -18,6 +18,7 @@
 
 {$ifdef uses_implementation}
   fpg_x11,
+  fpg_fontcache,
 {$endif}
 
 
@@ -27,6 +28,86 @@ type
   // to get access to protected methods (seeing that FPC doesn't support Friend-classes)
   TImageHack = class(TfpgImage);
 
+function FontCacheItemFromFontDesc(const desc: string; var asize: double): TFontCacheItem;
+var
+  facename: string;
+  cp: integer;
+  c: char;
+  token: string;
+  prop, propval: string;
+
+  function NextC: char;
+  begin
+    Inc(cp);
+    if cp > length(desc) then
+      c := #0
+    else
+      c := desc[cp];
+    Result := c;
+  end;
+
+  procedure NextToken;
+  begin
+    token := '';
+    while (c <> #0) and (c in [' ', 'a'..'z', 'A'..'Z', '_', '0'..'9']) do
+    begin
+      token := token + c;
+      NextC;
+    end;
+  end;
+
+begin
+  Result := TFontCacheItem.Create('');
+
+  cp := 0;
+  NextC;
+  NextToken;
+
+  facename := token;
+  // Add known substites
+  if lowercase(facename) = 'times' then
+    facename := 'Times New Roman'
+  else if lowercase(facename) = 'courier' then
+    facename := 'Courier New'
+  else if lowercase(facename) = 'monospace' then
+    facename := 'Courier New';
+  Result.FamilyName := facename;
+
+  if c = '-' then
+  begin
+    NextC;
+    NextToken;
+    asize := StrToIntDef(token, 0);
+  end;
+
+  while c = ':' do
+  begin
+    NextC;
+    NextToken;
+
+    prop    := UpperCase(token);
+    propval := '';
+
+    if c = '=' then
+    begin
+      NextC;
+      NextToken;
+      propval := UpperCase(token);
+    end;
+
+    if prop = 'BOLD' then
+      Result.IsBold := True
+    else if prop = 'ITALIC' then
+      Result.IsItalic := True;
+//    else if prop = 'ANTIALIAS' then
+//      if propval = 'FALSE' then
+//        lf.lfQuality := NONANTIALIASED_QUALITY else
+//      if propval = 'DEFAULT' then
+//        lf.lfQuality := DEFAULT_QUALITY;
+  end;
+end;
+
+
 procedure TAgg2D.DoPutBufferToScreen(x, y, w, h: TfpgCoord);
 var
   drawgc: Tgc;
diff --git a/src/corelib/render/software/fpg_fontcache.pas b/src/corelib/render/software/fpg_fontcache.pas
new file mode 100644
index 00000000..46681938
--- /dev/null
+++ b/src/corelib/render/software/fpg_fontcache.pas
@@ -0,0 +1,343 @@
+{
+    fpGUI  -  Free Pascal GUI Toolkit
+
+    Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this
+    distribution, for details of the copyright.
+
+    See the file COPYING.modifiedLGPL, included in this distribution,
+    for details about redistributing fpGUI.
+
+    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.
+
+    Description:
+      This is a homegrown font cache, or font translation system. AggPas
+      references font files (eg: *.ttf) directly, whereas the rest
+      of fpGUI doesn't. Under X11 for example, the translation of
+      'Aria-12' to the actual *.ttf file will be done by the fontconfig
+      library. Unfortunately fontconfig doesn't have an API to give
+      use that *.ttf font file it resolved too. So for AggPas (or rather
+      the AggPas backend in fpGUI) we had to implement our own
+      font translation system.
+}
+
+unit fpg_fontcache;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, contnrs, fpg_base;
+
+type
+  TFontCacheItem = class(TObject)
+  private
+    FFamilyName: TfpgString;
+    FFileName: TfpgString;
+    FFixedWidth: boolean;
+    FStyleFlags: Integer;
+    function    GetIsBold: boolean;
+    function    GetIsFixedWidth: boolean;
+    function    GetIsItalic: boolean;
+    function    GetIsRegular: boolean;
+    procedure   SetIsBold(AValue: boolean);
+    procedure   SetIsFixedWidth(AValue: boolean);
+    procedure   SetIsItalic(AValue: boolean);
+    procedure   SetIsRegular(AValue: boolean);
+  public
+    constructor Create(const AFilename: TfpgString);
+    property    FileName: TfpgString read FFileName write FFileName;
+    property    FamilyName: TfpgString read FFamilyName write FFamilyName;
+    property    StyleFlags: Integer read FStyleFlags write FStyleFlags;
+    property    IsFixedWidth: boolean read GetIsFixedWidth write SetIsFixedWidth;
+    property    IsRegular: boolean read GetIsRegular write SetIsRegular;
+    property    IsItalic: boolean read GetIsItalic write SetIsItalic;
+    property    IsBold: boolean read GetIsBold write SetIsBold;
+  end;
+
+
+  TFontCacheList = class(TObject)
+  private
+    FList: TObjectList;
+    procedure   SearchForFont(const AFontPath: TfpgString);
+    function    BuildFontCacheItem(const AFontFile: TfpgString): TFontCacheItem;
+    procedure   SetStyleIfExists(var AText: Ansistring; var AStyleFlags: integer; const AStyleName: AnsiString; const AStyleBit: integer);
+  protected
+    function    GetCount: integer; virtual;
+    function    GetItem(AIndex: Integer): TFontCacheItem; virtual;
+    procedure   SetItem(AIndex: Integer; AValue: TFontCacheItem); virtual;
+  public
+    constructor Create;
+    destructor  Destroy; override;
+    procedure   BuildFontCache;
+    function    Add(const AObject: TFontCacheItem): integer;
+    procedure   Clear;
+    property    Count: integer read GetCount;
+    function    IndexOf(const AObject: TFontCacheItem): integer;
+    function    Find(const AFontCacheItem: TFontCacheItem): integer;
+    property    Items[AIndex: Integer]: TFontCacheItem read GetItem write SetItem; default;
+  end;
+
+
+function gFontCache: TFontCacheList;
+
+implementation
+
+uses
+  fpg_utils,
+  agg_font_freetype_lib;
+
+const
+  FPG_FONT_STYLE_REGULAR = 1 shl 0;     { Regular, Plain, Book }
+  FPG_FONT_STYLE_ITALIC = 1 shl 1;      { Itelic }
+  FPG_FONT_STYLE_BOLD = 1 shl 2;        { Bold }
+  FPG_FONT_STYLE_CONDENSED = 1 shl 3;   { Condensed }
+  FPG_FONT_STYLE_EXTRALIGHT = 1 shl 4;  { ExtraLight }
+  FPG_FONT_STYLE_LIGHT = 1 shl 5;       { Light }
+  FPG_FONT_STYLE_SEMIBOLD = 1 shl 6;    { Semibold }
+  FPG_FONT_STYLE_MEDIUM = 1 shl 7;      { Medium }
+  FPG_FONT_STYLE_BLACK = 1 shl 8;       { Black }
+  FPG_FONT_STYLE_FIXEDWIDTH = 1 shl 9;  { Fixedwidth }
+
+var
+  m_library: FT_Library_ptr;
+  uFontCacheList: TFontCacheList;
+
+function gFontCache: TFontCacheList;
+begin
+ if not Assigned(uFontCacheList) then
+ begin
+   uFontCacheList := TFontCacheList.Create;
+   uFontCacheList.BuildFontCache;
+ end;
+ Result := uFontCacheList;
+end;
+
+{ TFontCacheItem }
+
+function TFontCacheItem.GetIsBold: boolean;
+begin
+  Result := (FStyleFlags and FPG_FONT_STYLE_BOLD) <> 0;
+end;
+
+function TFontCacheItem.GetIsFixedWidth: boolean;
+begin
+  Result := (FStyleFlags and FPG_FONT_STYLE_FIXEDWIDTH) <> 0;
+end;
+
+function TFontCacheItem.GetIsItalic: boolean;
+begin
+  Result := (FStyleFlags and FPG_FONT_STYLE_ITALIC) <> 0;
+end;
+
+function TFontCacheItem.GetIsRegular: boolean;
+begin
+  Result := (FStyleFlags and FPG_FONT_STYLE_REGULAR) <> 0;
+end;
+
+procedure TFontCacheItem.SetIsBold(AValue: boolean);
+begin
+  FStyleFlags := FStyleFlags or FPG_FONT_STYLE_BOLD;
+end;
+
+procedure TFontCacheItem.SetIsFixedWidth(AValue: boolean);
+begin
+  FStyleFlags := FStyleFlags or FPG_FONT_STYLE_FIXEDWIDTH;
+  FStyleFlags := FStyleFlags and (not FPG_FONT_STYLE_REGULAR);
+end;
+
+procedure TFontCacheItem.SetIsItalic(AValue: boolean);
+begin
+  FStyleFlags := FStyleFlags or FPG_FONT_STYLE_ITALIC;
+end;
+
+procedure TFontCacheItem.SetIsRegular(AValue: boolean);
+begin
+  FStyleFlags := FStyleFlags or FPG_FONT_STYLE_REGULAR;
+  FStyleFlags := FStyleFlags and (not FPG_FONT_STYLE_FIXEDWIDTH);
+end;
+
+constructor TFontCacheItem.Create(const AFilename: TfpgString);
+begin
+  inherited Create;
+  FFileName := AFilename;
+  FStyleFlags := FPG_FONT_STYLE_REGULAR;
+end;
+
+{ TFontCacheList }
+
+procedure TFontCacheList.SearchForFont(const AFontPath: TfpgString);
+var
+  sr: TSearchRec;
+  lFont: TFontCacheItem;
+  s: TfpgString;
+begin
+  // The extra 'or' includes Normal attribute files under Windows. faAnyFile doesn't return those.
+  // Reported to FPC as bug 9440 in Mantis.
+  if fpgFindFirst(AFontPath + AllFilesMask, faAnyFile or $00000080, sr) = 0 then
+  begin
+    repeat
+      // check if special files to skip
+      if (sr.Name = '.') or (sr.Name = '..') or (sr.Name = '') then
+        Continue;
+      // We got something, so lets continue
+      s := fpgFromOSEncoding(sr.Name);
+      if (sr.Attr and faDirectory) <> 0 then // found a directory
+        SearchForFont(fpgAppendPathDelim(AFontPath + s))
+      else
+      begin // we have a file
+        if (lowercase(fpgExtractFileExt(s)) = '.ttf') or
+           (lowercase(fpgExtractFileExt(s)) = '.otf') then
+        begin
+          lFont := BuildFontCacheItem(AFontPath + s);
+          Add(lFont);
+        end;
+      end;
+    until fpgFindNext(sr) <> 0;
+  end;
+end;
+
+function TFontCacheList.BuildFontCacheItem(const AFontFile: TfpgString): TFontCacheItem;
+var
+  face_ptr: FT_Face_ptr;
+  s: Ansistring;
+  i: integer;
+  flags: integer;
+begin
+  FT_New_Face(m_library, PChar(AFontFile), 0, face_ptr);
+  Result := TFontCacheItem.Create(AFontFile);
+  Result.FamilyName := face_ptr^.family_name;
+
+  // extract simple styles first
+//  if (face_ptr^.face_flags and FT_FACE_FLAG_FIXED_WIDTH) <> 0 then
+//    Result.StyleFlags := FPG_FONT_STYLE_FIXEDWIDTH; // this should overwrite Regular style
+
+  if (face_ptr^.style_flags and FT_STYLE_FLAG_ITALIC) <> 0 then
+    Result.StyleFlags := Result.StyleFlags or FPG_FONT_STYLE_ITALIC;
+
+  if (face_ptr^.style_flags and FT_STYLE_FLAG_BOLD) <> 0 then
+    Result.StyleFlags := Result.StyleFlags or FPG_FONT_STYLE_BOLD;
+
+  // Now to more complex styles stored in StyleName field. eg: 'Condensed Medium'
+  s := face_ptr^.style_name;
+  flags := Result.StyleFlags;
+  SetStyleIfExists(s, flags, 'Condensed', FPG_FONT_STYLE_CONDENSED);
+  SetStyleIfExists(s, flags, 'ExtraLight', FPG_FONT_STYLE_EXTRALIGHT);
+  SetStyleIfExists(s, flags, 'Light', FPG_FONT_STYLE_LIGHT);
+  SetStyleIfExists(s, flags, 'Semibold', FPG_FONT_STYLE_SEMIBOLD);
+  SetStyleIfExists(s, flags, 'Medium', FPG_FONT_STYLE_MEDIUM);
+  SetStyleIfExists(s, flags, 'Black', FPG_FONT_STYLE_BLACK);
+  Result.StyleFlags := flags;
+
+  FT_Done_Face(face_ptr);
+end;
+
+procedure TFontCacheList.SetStyleIfExists(var AText: Ansistring; var AStyleFlags: integer;
+  const AStyleName: AnsiString; const AStyleBit: integer);
+var
+  i: integer;
+begin
+  i := Pos(AStyleName, AText);
+  if i > 0 then
+  begin
+    AStyleFlags := AStyleFlags or AStyleBit;
+    Delete(AText, Length(AStyleName), i);
+  end;
+end;
+
+function TFontCacheList.GetCount: integer;
+begin
+  Result := FList.Count;
+end;
+
+function TFontCacheList.GetItem(AIndex: Integer): TFontCacheItem;
+begin
+  Result := TFontCacheItem(FList.Items[AIndex]);
+end;
+
+procedure TFontCacheList.SetItem(AIndex: Integer; AValue: TFontCacheItem);
+begin
+  FList.Items[AIndex] := AValue;
+end;
+
+constructor TFontCacheList.Create;
+begin
+  inherited Create;
+  FList := TObjectList.Create;
+end;
+
+destructor TFontCacheList.Destroy;
+begin
+  FList.Free;
+  inherited Destroy;
+end;
+
+procedure TFontCacheList.BuildFontCache;
+var
+  lPath: TfpgString;
+  lPathList: TStringList;
+  i: integer;
+begin
+  try
+    m_library := nil;
+    FT_Init_FreeType(m_library);
+
+    lPathList := TStringList.Create;
+    lPathList.Add('/usr/share/cups/fonts/');
+    lPathList.Add('/usr/share/fonts/truetype/');
+    lPathList.Add('/usr/local/lib/X11/fonts/');
+    lPathList.Add(GetUserDir + '.fonts/');
+    for i := 0 to lPathList.Count-1 do
+    begin
+      lPath := lPathList[i];
+      SearchForFont(lPath);
+    end;
+  finally
+    FT_Done_FreeType(m_library);
+    m_library := nil;
+    lPathList.Free;
+  end;
+end;
+
+function TFontCacheList.Add(const AObject: TFontCacheItem): integer;
+begin
+  Result := FList.Add(AObject);
+end;
+
+procedure TFontCacheList.Clear;
+begin
+  FList.Clear;
+end;
+
+function TFontCacheList.IndexOf(const AObject: TFontCacheItem): integer;
+begin
+  Result := FList.IndexOf(AObject);
+end;
+
+function TFontCacheList.Find(const AFontCacheItem: TFontCacheItem): integer;
+var
+  i: integer;
+begin
+  Result := -1; // nothing found
+  for i := 0 to Count-1 do
+  begin
+    if (Items[i].FamilyName = AFontCacheItem.FamilyName) and
+       (Items[i].StyleFlags = AFontCacheItem.StyleFlags) then
+    begin
+      Result := i;
+      exit;
+    end;
+  end;
+end;
+
+
+initialization
+  uFontCacheList := nil;
+
+finalization
+  uFontCacheList.Free;
+
+end.
+