TextSuite/utsFontCreatorGDI.pas

unit utsFontCreatorGDI;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, syncobjs, dynlibs,
  utsTextSuite, utsTypes;

type
  HDC = Cardinal;

  TFixed = packed record
    fract: Word;
    value: Smallint;
  end;

  TMat2 = packed record
    eM11: TFixed;
    eM12: TFixed;
    eM21: TFixed;
    eM22: TFixed;
  end;
  PMat2 = ^TMat2;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TtsFontGDI = class(TtsFont)
  private
    fHandle: THandle;
    fMat2: TMat2;
  protected
    constructor Create(const aRenderer: TtsRenderer; const aCreator: TtsFontGenerator; const aProperties: TtsFontProperties; const aHandle: THandle);
  public
    destructor Destroy; override;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TtsFontRegistration = class(TObject)
  protected
    fIsRegistered: Boolean;
    fFontname: String;
    procedure UnregisterFont; virtual; abstract;
  public
    property IsRegistered: Boolean read fIsRegistered;
    property Fontname:     String  read fFontname;

    destructor Destroy; override;
  end;

  TtsFontRegistrationFile = class(TtsFontRegistration)
  private
    fFilename: String;
  protected
    procedure UnregisterFont; override;
  public
    constructor Create(const aFilename: String);
  end;

  TtsFontRegistrationStream = class(TtsFontRegistration)
  private
    fHandle: THandle;
  protected
    procedure UnregisterFont; override;
  public
    constructor Create(const aStream: TStream);
  end;

  TtsRegistredFontGDI = class(TtsFontGDI)
  private
    fRegistration: TtsFontRegistration;
  public
    constructor Create(const aRenderer: TtsRenderer; const aCreator: TtsFontGenerator;
      const aRegistration: TtsFontRegistration; const aProperties: TtsFontProperties; const aHandle: THandle);
    destructor Destroy; override;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TtsFontGeneratorGDI = class(TtsFontGenerator)
  private
    function ConvertFont(const aFont: TtsFont): TtsFontGDI;
    function GetGlyphIndex(const aFont: TtsFontGDI; const aCharCode: WideChar): Integer;
    procedure GetCharImageAANone(const aDC: HDC; const aFont: TtsFontGDI; const aCharCode: WideChar; const aImage: TtsImage);
    procedure GetCharImageAANormal(const aDC: HDC; const aFont: TtsFontGDI; const aCharCode: WideChar; const aImage: TtsImage);

    function CreateFont(const aFontname: String; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing; out aProperties: TtsFontProperties): THandle;
  protected
    function GetGlyphMetrics(const aFont: TtsFont; const aCharCode: WideChar; out aGlyphOrigin, aGlyphSize: TtsPosition; out aAdvance: Integer): Boolean; override;
    procedure GetCharImage(const aFont: TtsFont; const aCharCode: WideChar; const aCharImage: TtsImage); override;
  public
    function GetFontByName(const aFontname: String; const aRenderer: TtsRenderer; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload;
    function GetFontByFile(const aFilename: String; const aRenderer: TtsRenderer; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload;
    function GetFontByStream(const aStream: TStream;  const aRenderer: TtsRenderer; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload;

    constructor Create(const aContext: TtsContext);
    destructor Destroy; override;
  end;

implementation

uses
  math, utsTtfUtils;

const
  LIB_GDI32    = 'gdi32.dll';
  LIB_KERNEL32 = 'kernel32.dll';

  GDI_ERROR = DWORD($FFFFFFFF);

  FW_NORMAL = 400;
  FW_BOLD = 700;

  DEFAULT_CHARSET = 1;

  NONANTIALIASED_QUALITY = 3;
  ANTIALIASED_QUALITY = 4;

  GGO_METRICS = 0;
  GGO_BITMAP = 1;
  GGO_GRAY8_BITMAP = 6;
  GGO_GLYPH_INDEX = $80;

  FR_PRIVATE = $10;
  FR_NOT_ENUM = $20;

  LOCALE_USER_DEFAULT = $0400;
  LOCALE_ILANGUAGE = $1;

  GCP_MAXEXTENT = $100000;

  TMPF_FIXED_PITCH = 1;

type
  HFONT = Cardinal;
  HGDIOBJ = Cardinal;

  TLogFontA = record
    lfHeight: Longint;
    lfWidth: Longint;
    lfEscapement: Longint;
    lfOrientation: Longint;
    lfWeight: Longint;
    lfItalic: Byte;
    lfUnderline: Byte;
    lfStrikeOut: Byte;
    lfCharSet: Byte;
    lfOutPrecision: Byte;
    lfClipPrecision: Byte;
    lfQuality: Byte;
    lfPitchAndFamily: Byte;
    lfFaceName: array[0..31] of AnsiChar;
  end;
  PLogFontA = ^TLogFontA;

  TTextMetricW = record
    tmHeight: Longint;
    tmAscent: Longint;
    tmDescent: Longint;
    tmInternalLeading: Longint;
    tmExternalLeading: Longint;
    tmAveCharWidth: Longint;
    tmMaxCharWidth: Longint;
    tmWeight: Longint;
    tmOverhang: Longint;
    tmDigitizedAspectX: Longint;
    tmDigitizedAspectY: Longint;
    tmFirstChar: WideChar;
    tmLastChar: WideChar;
    tmDefaultChar: WideChar;
    tmBreakChar: WideChar;
    tmItalic: Byte;
    tmUnderlined: Byte;
    tmStruckOut: Byte;
    tmPitchAndFamily: Byte;
    tmCharSet: Byte;
  end;
  PTextMetricW = ^TTextMetricW;

  TGlyphMetrics = record
    gmBlackBoxX: Cardinal;
    gmBlackBoxY: Cardinal;
    gmptGlyphOrigin: TtsPosition;
    gmCellIncX: Smallint;
    gmCellIncY: Smallint;
  end;
  PGlyphMetrics = ^TGlyphMetrics;

  TGCPResultsW = record
    lStructSize: DWORD;
    lpOutString: PWideChar;
    lpOrder: PDWORD;
    lpDx: PInteger;
    lpCaretPos: PInteger;
    lpClass: PChar;
    lpGlyphs: PCardinal;
    nGlyphs: Cardinal;
    nMaxFit: Cardinal;
  end;
  PGCPResultsW = ^TGCPResultsW;

  TPanose = record
    bFamilyType: Byte;
    bSerifStyle: Byte;
    bWeight: Byte;
    bProportion: Byte;
    bContrast: Byte;
    bStrokeVariation: Byte;
    bArmStyle: Byte;
    bLetterform: Byte;
    bMidline: Byte;
    bXHeight: Byte;
  end;
  PPanose = ^TPanose;

  TOutlineTextmetricW = record
    otmSize: LongWord;
    otmTextMetrics: TTextMetricW;
    otmFiller: Byte;
    otmPanoseNumber: TPanose;
    otmfsSelection: LongWord;
    otmfsType: LongWord;
    otmsCharSlopeRise: Integer;
    otmsCharSlopeRun: Integer;
    otmItalicAngle: Integer;
    otmEMSquare: LongWord;
    otmAscent: Integer;
    otmDescent: Integer;
    otmLineGap: LongWord;
    otmsCapEmHeight: LongWord;
    otmsXHeight: LongWord;
    otmrcFontBox: TtsRect;
    otmMacAscent: Integer;
    otmMacDescent: Integer;
    otmMacLineGap: LongWord;
    otmusMinimumPPEM: LongWord;
    otmptSubscriptSize: TtsPosition;
    otmptSubscriptOffset: TtsPosition;
    otmptSuperscriptSize: TtsPosition;
    otmptSuperscriptOffset: TtsPosition;
    otmsStrikeoutSize: LongWord;
    otmsStrikeoutPosition: Integer;
    otmsUnderscoreSize: Integer;
    otmsUnderscorePosition: Integer;
    otmpFamilyName: PWideChar;
    otmpFaceName: PWideChar;
    otmpStyleName: PWideChar;
    otmpFullName: PWideChar;
  end;
  POutlineTextmetricW = ^TOutlineTextmetricW;

  TCreateFontIndirectA = function (const p1: TLogFontA): HFONT; stdcall;

  TAddFontResourceA = function(Filename: PAnsiChar): Integer; stdcall;
  TAddFontResourceExA = function(Filename: PAnsiChar; Flag: DWORD; pdv: Pointer): Integer; stdcall;
  TAddFontMemResourceEx = function(pbFont: Pointer; cbFont: DWORD; pdv: Pointer; pcFonts: PDWORD): THandle; stdcall;
  TRemoveFontResourceA = function(Filename: PAnsiChar): Boolean; stdcall;
  TRemoveFontResourceExA = function(filename: PAnsiChar; Flag: DWORD; pdv: Pointer): Boolean; stdcall;
  TRemoveFontMemResourceEx = function(fh: THandle): Boolean; stdcall;

  TGetTextMetricsW = function(DC: HDC; var TM: TTextMetricW): Boolean; stdcall;
  TGetGlyphOutlineA = function(DC: HDC; uChar, uFormat: Cardinal; lpgm: PGlyphMetrics; cbBuffer: DWORD; lpvBuffer: Pointer; lpmat2: PMat2): DWORD; stdcall;

  TGetCharacterPlacementW = function(DC: HDC; Str: PWideChar; Count, MaxExtent: Integer; Result: PGCPResultsW; Flags: DWORD): DWORD; stdcall;
  TGetFontData = function(DC: HDC; TableName, Offset: DWORD; Buffer: Pointer; Data: DWORD): DWORD; stdcall;

  TCreateCompatibleDC = function(DC: HDC): HDC; stdcall;
  TDeleteDC = function(DC: HDC): Boolean; stdcall;
  TSelectObject = function(DC: HDC; p2: HGDIOBJ): HGDIOBJ; stdcall;
  TDeleteObject = function(p1: HGDIOBJ): Boolean; stdcall;

  TGetOutlineTextMetricsW = function(DC: HDC; p2: LongWord; var OTMetricStructs: TOutlineTextmetricW): LongWord; stdcall;

  TGetLocaleInfoA = function(Locale: DWORD; LCType: DWORD; lpLCData: pAnsiChar; cchData: Integer): Integer; stdcall;

var
  gdiRefCount: Integer;
  gdiCritSec: TCriticalSection;
  gdiInitialized: Boolean;
  gdiLibHandle: TLibHandle = 0;
  kernel32LibHandle: TLibHandle = 0;

  CreateFontIndirectA: TCreateFontIndirectA;
  AddFontResourceA: TAddFontResourceA;
  AddFontResourceExA: TAddFontResourceExA;
  AddFontMemResourceEx: TAddFontMemResourceEx;
  RemoveFontResourceA: TRemoveFontResourceA;
  RemoveFontResourceExA: TRemoveFontResourceExA;
  RemoveFontMemResourceEx: TRemoveFontMemResourceEx;
  GetTextMetricsW: TGetTextMetricsW;
  GetGlyphOutlineA: TGetGlyphOutlineA;
  GetCharacterPlacementW: TGetCharacterPlacementW;
  GetFontData: TGetFontData;
  CreateCompatibleDC: TCreateCompatibleDC;
  DeleteDC: TDeleteDC;
  SelectObject: TSelectObject;
  DeleteObject: TDeleteObject;
  GetOutlineTextMetricsW: TGetOutlineTextMetricsW;

  GetLocaleInfoA: TGetLocaleInfoA;

procedure InitGDI;

  function GetProcAddr(const aLibHandle: TLibHandle; const aName: String): Pointer;
  begin
    result := GetProcAddress(aLibHandle, aName);
    if not Assigned(result) then
      raise EtsException.Create('unable to load procedure from library: ' + aName);
  end;

begin
  try
    if (gdiLibHandle = 0) then begin
      gdiLibHandle := LoadLibrary(LIB_GDI32);
      if (gdiLibHandle = 0) then
        raise EtsException.Create('unable to load gdi lib: ' + LIB_GDI32);
    end;

    if (kernel32LibHandle = 0) then begin
      kernel32LibHandle := LoadLibrary(LIB_KERNEL32);
      if (kernel32LibHandle = 0) then
        raise EtsException.Create('unable to load kernel lib: ' + LIB_KERNEL32);
    end;

    CreateFontIndirectA     := TCreateFontIndirectA(    GetProcAddr(gdiLibHandle, 'CreateFontIndirectA'));
    AddFontResourceA        := TAddFontResourceA(       GetProcAddr(gdiLibHandle, 'AddFontResourceA'));
    AddFontResourceExA      := TAddFontResourceExA(     GetProcAddr(gdiLibHandle, 'AddFontResourceExA'));
    AddFontMemResourceEx    := TAddFontMemResourceEx(   GetProcAddr(gdiLibHandle, 'AddFontMemResourceEx'));
    RemoveFontResourceA     := TRemoveFontResourceA(    GetProcAddr(gdiLibHandle, 'RemoveFontResourceA'));
    RemoveFontResourceExA   := TRemoveFontResourceExA(  GetProcAddr(gdiLibHandle, 'RemoveFontResourceExA'));
    RemoveFontMemResourceEx := TRemoveFontMemResourceEx(GetProcAddr(gdiLibHandle, 'RemoveFontMemResourceEx'));
    GetTextMetricsW         := TGetTextMetricsW(        GetProcAddr(gdiLibHandle, 'GetTextMetricsW'));
    GetGlyphOutlineA        := TGetGlyphOutlineA(       GetProcAddr(gdiLibHandle, 'GetGlyphOutlineA'));
    GetCharacterPlacementW  := TGetCharacterPlacementW( GetProcAddr(gdiLibHandle, 'GetCharacterPlacementW'));
    GetFontData             := TGetFontData(            GetProcAddr(gdiLibHandle, 'GetFontData'));
    CreateCompatibleDC      := TCreateCompatibleDC(     GetProcAddr(gdiLibHandle, 'CreateCompatibleDC'));
    DeleteDC                := TDeleteDC(               GetProcAddr(gdiLibHandle, 'DeleteDC'));
    SelectObject            := TSelectObject(           GetProcAddr(gdiLibHandle, 'SelectObject'));
    DeleteObject            := TDeleteObject(           GetProcAddr(gdiLibHandle, 'DeleteObject'));
    GetOutlineTextMetricsW  := TGetOutlineTextMetricsW( GetProcAddr(gdiLibHandle, 'GetOutlineTextMetricsW'));

    GetLocaleInfoA := TGetLocaleInfoA(GetProcAddr(kernel32LibHandle, 'GetLocaleInfoA'));

    gdiInitialized := true;
  except
    gdiInitialized := false;
    FreeLibrary(gdiLibHandle);
    FreeLibrary(kernel32LibHandle);
  end;
end;

procedure QuitGDI;
begin
  CreateFontIndirectA := nil;
  AddFontResourceA := nil;
  AddFontResourceExA := nil;
  RemoveFontResourceA := nil;
  RemoveFontResourceExA := nil;
  GetTextMetricsW := nil;
  GetGlyphOutlineA := nil;
  GetCharacterPlacementW := nil;
  GetFontData := nil;
  CreateCompatibleDC := nil;
  DeleteDC := nil;
  SelectObject := nil;
  DeleteObject := nil;

  GetLocaleInfoA := nil;

  if (gdiLibHandle <> 0) then begin
    FreeLibrary(gdiLibHandle);
    gdiLibHandle := 0;
  end;

  if (kernel32LibHandle <> 0) then begin
    FreeLibrary(kernel32LibHandle);
    kernel32LibHandle := 0;
  end;

  gdiInitialized := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontGDI////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsFontGDI.Create(const aRenderer: TtsRenderer; const aCreator: TtsFontGenerator; const aProperties: TtsFontProperties; const aHandle: THandle);
begin
  inherited Create(aRenderer, aCreator, aProperties);
  FillByte(fMat2, SizeOf(fMat2), 0);
  fMat2.eM11.value := 1;
  fMat2.eM22.value := 1;
  fHandle          := aHandle;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsFontGDI.Destroy;
begin
  DeleteObject(fHandle);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontRegistration///////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsFontRegistration.Destroy;
begin
  if fIsRegistered then
    UnregisterFont;
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontRegistrationFile///////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontRegistrationFile.UnregisterFont;
begin
  if Assigned(RemoveFontResourceExA) then
    RemoveFontResourceExA(PAnsiChar(fFilename), 0, nil)
  else if Assigned(RemoveFontResourceA) then
    RemoveFontResourceA(PAnsiChar(fFilename));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsFontRegistrationFile.Create(const aFilename: String);
var
  lang: AnsiString;
begin
  inherited Create;
  fFilename := aFilename;

  // get Fontname
  SetLength(lang, 4);
  GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @lang[1], 4);
  fFontname := GetTTFontFullNameFromFile(aFilename, StrToInt('$' + String(lang)));

  // register font
  if Assigned(AddFontResourceExA) then
    fIsRegistered := (AddFontResourceExA(PAnsiChar(fFilename), 0, nil) > 0)
  else if Assigned(AddFontResourceA) then
    fIsRegistered := (AddFontResourceA(PAnsiChar(fFilename)) > 0)
  else
    fIsRegistered := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontRegistrationStream/////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontRegistrationStream.UnregisterFont;
begin
  if Assigned(RemoveFontMemResourceEx) then
    RemoveFontMemResourceEx(fHandle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsFontRegistrationStream.Create(const aStream: TStream);
var
  lang: AnsiString;
  ms: TMemoryStream;
  cnt: DWORD;
begin
  inherited Create;
  fHandle       := 0;
  fIsRegistered := false;

  // get Fontname
  SetLength(Lang, 4);
  GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @lang[1], 4);
  fFontname := GetTTFontFullNameFromStream(aStream, StrToInt('$' + String(Lang)));

  // register font
  ms := TMemoryStream.Create;
  try
    ms.CopyFrom(aStream, 0);
    if Assigned(AddFontMemResourceEx) then
      fHandle := AddFontMemResourceEx(ms.Memory, ms.Size, nil, @cnt);
    fIsRegistered := (fHandle > 0);
  finally
    FreeAndNil(ms);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsRegistredFontGDI///////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsRegistredFontGDI.Create(const aRenderer: TtsRenderer; const aCreator: TtsFontGenerator;
  const aRegistration: TtsFontRegistration; const aProperties: TtsFontProperties; const aHandle: THandle);
begin
  inherited Create(aRenderer, aCreator, aProperties, aHandle);
  fRegistration := aRegistration;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsRegistredFontGDI.Destroy;
begin
  FreeAndNil(fRegistration);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontCreatorGDIFontFace/////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.ConvertFont(const aFont: TtsFont): TtsFontGDI;
begin
  if not (aFont is TtsFontGDI) then
    raise EtsException.Create('aFont need to be a TtsFontGDI object');
  result := (aFont as TtsFontGDI);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetGlyphIndex(const aFont: TtsFontGDI; const aCharCode: WideChar): Integer;
var
  DC: HDC;
  GCPRes: TGCPResultsW;
begin
  result := -1;
  DC := CreateCompatibleDC(0);
  try
    SelectObject(DC, aFont.fHandle);
    if Assigned(GetCharacterPlacementW) then begin
      FillByte(GCPRes, SizeOf(GCPRes), 0);
      GetMem(GCPRes.lpGlyphs, SizeOf(Cardinal));
      try
        GCPRes.lStructSize := SizeOf(GCPRes);
        GCPRes.lpGlyphs^   := 0;
        GCPRes.nGlyphs     := 1;
        if (GetCharacterPlacementW(DC, @aCharCode, 1, GCP_MAXEXTENT, @GCPRes, 0) <> GDI_ERROR) and
           (GCPRes.nGlyphs = 1) and
           (GCPRes.lpGlyphs <> nil) then
        begin
          result := GCPRes.lpGlyphs^;
        end;
      finally
        FreeMem(GCPRes.lpGlyphs);
      end;
    end;
  finally
    DeleteDC(DC);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontGeneratorGDI.GetCharImageAANone(const aDC: HDC; const aFont: TtsFontGDI; const aCharCode: WideChar; const aImage: TtsImage);
var
  Metric: TGlyphMetrics;
  GlyphIndex, srcW, srcX, w, h, x, y: Integer;
  Size, OutlineRes: Cardinal;
  Buffer, pSrc, pDst: PByte;

  procedure ExpandByte;
  var
    i, cnt, srcCnt: Integer;
    c: TtsColor4f;
  begin
    srcCnt := min(8, srcX);
    cnt    := min(8, x);
    for i := 1 to cnt do begin
      c := tsColor4f(1, 1, 1, 1);
      if ((pSrc^ and $80) > 0) then
        c.a := 1.0
      else
        c.a := 0.0;
      pSrc^ := (pSrc^ and not $80) shl 1;
      tsFormatMap(aFont.Renderer.Format, pDst, c);
    end;
    dec(srcX, srcCnt);
    dec(x, cnt);
    inc(pSrc);
  end;

begin
  if (aFont.fMat2.eM11.value <> 1) then
    raise EtsException.Create('invalid value');
  FillByte(Metric, SizeOf(Metric), 0);

  GlyphIndex := GetGlyphIndex(aFont, aCharCode);
  if (GlyphIndex < 0) then
    exit;

  Size := GetGlyphOutlineA(aDC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @aFont.fMat2);
  if (Size = GDI_ERROR) or (Size = 0) then
    exit;

  GetMem(Buffer, Size);
  try
    OutlineRes := GetGlyphOutlineA(aDC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, Size, Buffer, @aFont.fMat2);
    if (OutlineRes = GDI_ERROR) then
      exit;
    w    := Metric.gmBlackBoxX;
    h    := Metric.gmBlackBoxY;
    srcW := (Size div h) * 8;
    if (w <= 0) or (h <= 0) then
      exit;
    aImage.CreateEmpty(aFont.Renderer.Format, w, h);
    pSrc := Buffer;
    for y := 0 to h-1 do begin
      pDst := aImage.Scanline[y];
      srcX := srcW;
      x    := w;
      while (srcX > 0) do
        ExpandByte;
    end;
  finally
    Freemem(Buffer);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontGeneratorGDI.GetCharImageAANormal(const aDC: HDC; const aFont: TtsFontGDI; const aCharCode: WideChar; const aImage: TtsImage);
var
  Metric: TGlyphMetrics;
  GlyphIndex, OutlineRes, tmp, Spacer, x, y, w, h: Integer;
  Size: Cardinal;
  Buffer, pSrc, pDst: PByte;

  procedure CopyPixel;
  var
    i: Integer;
    tmp, cnt: Cardinal;
    c: TtsColor4f;
  begin
    cnt := min(x, aFont.fMat2.eM11.value);
    tmp := 0;
    for i := 0 to cnt-1 do begin
      tmp := tmp + pSrc^;
      inc(pSrc, 1);
    end;
    dec(x, cnt);
    c := tsColor4f(1, 1, 1, tmp / $40);
    tsFormatMap(aFont.Renderer.Format, pDst, c);
  end;

begin
  FillByte(Metric, SizeOf(Metric), 0);

  GlyphIndex := GetGlyphIndex(aFont, aCharCode);
  if (GlyphIndex < 0) then
    exit;

  Size := GetGlyphOutlineA(aDC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @aFont.fMat2);
  if (Size = GDI_ERROR) or (Size = 0) then
    exit;

  GetMem(Buffer, Size);
  try
    OutlineRes := GetGlyphOutlineA(aDC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, Size, Buffer, @aFont.fMat2);
    if (OutlineRes = GDI_ERROR) then
      exit;
    w   := Integer(Metric.gmBlackBoxX) div aFont.fMat2.eM11.value;
    h   := Metric.gmBlackBoxY;
    tmp := Integer(Metric.gmBlackBoxX) mod aFont.fMat2.eM11.value;
    if (tmp <> 0) then
      w := w + aFont.fMat2.eM11.value - tmp;
    if (w <= 0) or (h <= 0) then
      exit;

    // spacer
    Spacer := Metric.gmBlackBoxX mod 4;
    if (Spacer <> 0) then
      Spacer := 4 - Spacer;

    // copy image
    aImage.CreateEmpty(aFont.Renderer.Format, w, h);
    pSrc := Buffer;
    for y := 0 to h-1 do begin
      pDst := aImage.Scanline[y];
      x    := Metric.gmBlackBoxX;
      while (x > 0) do
        CopyPixel;
      inc(pSrc, Spacer);
    end;
  finally
    FreeMem(Buffer);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.CreateFont(const aFontname: String; const aSize: Integer; const aStyle: TtsFontStyles;
  const aAntiAliasing: TtsAntiAliasing; out aProperties: TtsFontProperties): THandle;
var
  LogFont: TLogFontA;
  i: Integer;
  DC: HDC;
  TableName, BufSize: Cardinal;
  Buffer: PByte;
  Lang: AnsiString;
  TextMetric: TTextMetricW;
  OutlineMetric: TOutlineTextmetricW;

  function _(e: Boolean; a, b: Integer): Integer;
  begin
    if e then
      result := a
    else
      result := b;
  end;

begin
  result := 0;

  FillByte(aProperties, SizeOf(aProperties), 0);
  aProperties.Size         := aSize;
  aProperties.Style        := aStyle;
  aProperties.AntiAliasing := aAntiAliasing;
  aProperties.Fontname     := aFontname;

  // prepare font attribs
  FillByte(LogFont, SizeOf(LogFont), 0);
  for i := 1 to min(Length(aFontname), Length(LogFont.lfFaceName)) do
    LogFont.lfFaceName[i-1] := aFontname[i];
  LogFont.lfCharSet   := DEFAULT_CHARSET;
  LogFont.lfHeight    := -aSize;
  LogFont.lfWeight    := _(tsStyleBold      in aStyle, FW_BOLD, FW_NORMAL);
  LogFont.lfItalic    := _(tsStyleItalic    in aStyle, 1, 0);
  LogFont.lfUnderline := _(tsStyleUnderline in aStyle, 1, 0);
  LogFont.lfQuality   := _(aAntiAliasing = tsAANormal, ANTIALIASED_QUALITY, NONANTIALIASED_QUALITY);

  result := CreateFontIndirectA(LogFont);
  DC     := CreateCompatibleDC(0);
  try try
    SelectObject(DC, result);
    TableName := MakeTTTableName('n', 'a', 'm', 'e');
    BufSize   := GetFontData(DC, TableName, 0, nil, 0);
    if (BufSize <> GDI_ERROR) then begin
      GetMem(Buffer, BufSize);
      try
        if (GetFontData(DC, TableName, 0, Buffer, BufSize) <> GDI_ERROR) then begin
          SetLength(Lang, 4);
          GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @Lang[1], 4);

          GetTTString(Buffer, BufSize, NAME_ID_COPYRIGHT,  StrToInt('$' + String(Lang)), aProperties.Copyright);
          GetTTString(Buffer, BufSize, NAME_ID_FACE_NAME,  StrToInt('$' + String(Lang)), aProperties.FaceName);
          GetTTString(Buffer, BufSize, NAME_ID_STYLE_NAME, StrToInt('$' + String(Lang)), aProperties.StyleName);
          GetTTString(Buffer, BufSize, NAME_ID_FULL_NAME,  StrToInt('$' + String(Lang)), aProperties.FullName);
        end;
      finally
        FreeMem(Buffer);
      end;
    end;

    if GetTextMetricsW(DC, TextMetric) then begin
      aProperties.Ascent          := TextMetric.tmAscent;
      aProperties.Descent         := TextMetric.tmDescent;
      aProperties.ExternalLeading := TextMetric.tmExternalLeading;
      aProperties.DefaultChar     := TextMetric.tmDefaultChar;
    end;

    if (GetOutlineTextMetricsW(DC, SizeOf(OutlineMetric), OutlineMetric) > 0) then begin
      aProperties.UnderlinePos  := OutlineMetric.otmsUnderscorePosition;
      aProperties.UnderlineSize := Min(1, OutlineMetric.otmsUnderscoreSize);
      aProperties.StrikeoutPos  := OutlineMetric.otmsStrikeoutPosition;
      aProperties.StrikeoutSize := Min(1, OutlineMetric.otmsStrikeoutSize);
    end;
  except
    DeleteObject(result);
    result := 0;
  end;
  finally
    DeleteDC(DC);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetGlyphMetrics(const aFont: TtsFont; const aCharCode: WideChar; out aGlyphOrigin, aGlyphSize: TtsPosition; out aAdvance: Integer): Boolean;
var
  GlyphIndex: Integer;
  font: TtsFontGDI;
  DC: HDC;
  Metric: TGlyphMetrics;
  Size: Cardinal;
begin
  result := false;

  aGlyphOrigin.x := 0;
  aGlyphOrigin.x := 0;
  aGlyphSize.x   := 0;
  aGlyphSize.y   := 0;
  aAdvance       := 0;

  font := ConvertFont(aFont);
  GlyphIndex := GetGlyphIndex(font, aCharCode);
  if (GlyphIndex < 0) then
    exit;

  DC := CreateCompatibleDC(0);
  try
    SelectObject(DC, font.fHandle);
    case font.Properties.AntiAliasing of
      tsAANone: begin
        Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @font.fMat2);
      end;
      tsAANormal: begin
        Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @font.fMat2);
      end;
    else
      Size := GDI_ERROR;
    end;

    if (Size = GDI_ERROR) then
      Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_METRICS or GGO_GLYPH_INDEX, @Metric, 0, nil, @font.fMat2);

    if (Size <> GDI_ERROR) then begin
      aGlyphOrigin.x := Round(Metric.gmptGlyphOrigin.x / font.fMat2.eM11.value);
      aGlyphOrigin.y := Metric.gmptGlyphOrigin.y;
      aGlyphSize.x   := Round(Metric.gmBlackBoxX / font.fMat2.eM11.value);
      aGlyphSize.y   := Metric.gmBlackBoxY;
      aAdvance       := Round(Metric.gmCellIncX / font.fMat2.eM11.value);
      result         := true;
    end;
  finally
    DeleteDC(DC);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontGeneratorGDI.GetCharImage(const aFont: TtsFont; const aCharCode: WideChar; const aCharImage: TtsImage);
var
  DC: HDC;
  font: TtsFontGDI;
begin
  font := ConvertFont(aFont);
  DC := CreateCompatibleDC(0);
  try
    SelectObject(DC, font.fHandle);
    case font.Properties.AntiAliasing of
      tsAANone:
        GetCharImageAANone(DC, font, aCharCode, aCharImage);
      tsAANormal:
        GetCharImageAANormal(DC, font, aCharCode, aCharImage);
    end;
  finally
    DeleteDC(DC);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetFontByName(const aFontname: String; const aRenderer: TtsRenderer;
  const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
var
  handle: THandle;
  prop: TtsFontProperties;
begin
  handle := CreateFont(aFontname, aSize, aStyle, aAntiAliasing, prop);
  if (handle = 0) then
    raise EtsException.Create('unable to create font from name: ' + aFontname);
  result := TtsFontGDI.Create(aRenderer, self, prop, handle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetFontByFile(const aFilename: String; const aRenderer: TtsRenderer;
  const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
var
  reg: TtsFontRegistrationFile;
  handle: THandle;
  prop: TtsFontProperties;
begin
  reg := TtsFontRegistrationFile.Create(aFilename);
  if not reg.IsRegistered then
    raise EtsException.Create('unable to register font file: ' + aFilename);
  handle := CreateFont(reg.Fontname, aSize, aStyle, aAntiAliasing, prop);
  if (handle = 0) then
    raise EtsException.Create('unable to create font from file: ' + aFilename);
  result := TtsRegistredFontGDI.Create(aRenderer, self, reg, prop, handle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetFontByStream(const aStream: TStream; const aRenderer: TtsRenderer;
  const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
var
  reg: TtsFontRegistrationStream;
  handle: THandle;
  prop: TtsFontProperties;
begin
  reg := TtsFontRegistrationStream.Create(aStream);
  if not reg.IsRegistered then
    raise EtsException.Create('unable to register font from stream');
  handle := CreateFont(reg.Fontname, aSize, aStyle, aAntiAliasing, prop);
  if (handle = 0) then
    raise EtsException.Create('unable to create font from stream: ' + reg.Fontname);
  result := TtsRegistredFontGDI.Create(aRenderer, self, reg, prop, handle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsFontGeneratorGDI.Create(const aContext: TtsContext);
begin
  inherited Create(aContext);
  gdiCritSec.Enter;
  try
    inc(gdiRefCount, 1);
    if not gdiInitialized then
      InitGDI;
  finally
    gdiCritSec.Leave;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsFontGeneratorGDI.Destroy;
begin
  inherited Destroy; // first free all fonts (managed by parent class)
  gdiCritSec.Enter;
  try
    dec(gdiRefCount, 1);
    if (gdiRefCount <= 0) then
      QuitGDI;
  finally
    gdiCritSec.Leave;
  end;
end;

initialization
  gdiRefCount    := 0;
  gdiInitialized := false;
  gdiCritSec     := TCriticalSection.Create;

finalization
  if gdiInitialized then
    QuitGDI;
  FreeAndNil(gdiCritSec);

end.