castle-game-engine-src 5.0.0-3 / usr / src / castle-game-engine-5.0.0 / fonts / windows / castlewinfontconvert.pas

{
  Copyright 2002-2014 Michalis Kamburelis.

  This file is part of "Castle Game Engine".

  "Castle Game Engine" is free software; see the file COPYING.txt,
  included in this distribution, for details about the copyright.

  "Castle Game Engine" 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.

  ----------------------------------------------------------------------------
}

{ Convert fonts available on Windows to TOutlineFontData.

  This unit heavily depends on GetGlpyhOutline WinAPI function.
  This function is our "core" of converting Windows fonts to
  TOutlineFontData. Unfortunately, this makes this unit Windows-only.

  TODO: Rewrite it using FreeType library, or maybe just resign
  from using outline fonts.
}

unit CastleWinFontConvert;

interface

uses Windows, CastleOutlineFontData;

{ Create our font from a Windows font handle.
  Remeber to free resulting font later by FreeAndNilFont.
  @groupBegin }
function Font2OutlineFont(WinFont: HFont): TOutlineFontData;
{ @groupEnd }

{ Free and nil Font instance, freeing also all characters by FreeMem.
  Use this only on fonts with characters created by Font2OutlineFont.
  @groupBegin }
procedure FreeAndNilFont(var Font: TOutlineFontData); overload;
{ @groupEnd }

implementation

uses SysUtils, CastleUtils, CastleGenericLists;

{ Note about "underline" and "strikeout": it does not matter whether
  Window font was created as underline or strikeout (e.g. what values for
  fdwUnderline/StrikeOut were set when calling CreateFont).
  Fonts converted by these functions are NEVER underlined or strikeout.

  On the other hand, "bold" (actually "weight") and "italic" matter.
  That is, fonts created by this functions reflect the weight and italic settings
  of the font. This works regardless if there are separate TTF files for
  bold/italic or versions not (in the latter case,
  I assume that Windows automatically synthesizes bold/italic versions).

  This is an effect of how Windows.GetGlyphOutline works,
  although it doesn't seem documented anywhere.
}

const
  IdentityMat2:Mat2= { identity matrix }
    (eM11:(fract:0; value:1); eM12:(fract:0; value:0);    { 1.0  0.0 }
     eM21:(fract:0; value:0); eM22:(fract:0; value:1));   { 0.0  1.0 }

type
  TOutlineCharItemList = specialize TGenericStructList<TOutlineCharItem>;

{ Create an outline font character
  from a currently selected Windows font on device context DC. }
function Font2OutlineChar_HDc(dc: HDC; c: char): POutlineChar;
var
  GlyphMetrics: TGlyphMetrics;
  GlyphDataSize: Dword;
  Buffer : Pointer;
  BufferEnd, PolygonEnd : PtrUInt;
  PolHeader : PTTPolygonHeader;
  PolCurve : PTTPolyCurve;
  i, j: integer;
type
  TArray_PointFX = packed array [0..High(Word)] of TPointFX;
  PArray_PointFX = ^TArray_PointFX;
var
  PointsFX: PArray_PointFX;
  ResultItems: TOutlineCharItemList;
  ResultInfo: TOutlineCharInfo;
  lastPunkt: record x, y: Single end;
  Dlug: Cardinal;

  procedure ResultItemsAdd(Kind: TPolygonKind; Count: Cardinal{ = 0}); overload;
  { use only with Kind <> pkPoint }
  var
    Item: POutlineCharItem;
  begin
    Item := ResultItems.Add;
    Assert(Kind <> pkPoint);
    Item^.Kind := Kind;
    Item^.Count := Count;
  end;

  procedure ResultItemsAdd(Kind: TPolygonKind {Count: Cardinal = 0 }); overload;
  begin
    ResultItemsAdd(Kind, 0);
  end;

  procedure ResultItemsAdd(x, y: Single); overload;
  var
    Item: POutlineCharItem;
  begin
    Item := ResultItems.Add;
    Item^.Kind := pkPoint;
    Item^.x := x;
    Item^.y := y;
  end;

  function ToFloat(const Val: TFixed): Extended;
  begin
    result := Val.value + (Val.fract / Dword(High(Val.fract))+1 );
  end;

begin
  Result := nil; { <- only to avoid Delphi warning }

  ResultItems := TOutlineCharItemList.Create;
  try
    Buffer := nil;
    try
      { get Buffer }
      GlyphDataSize := GetGlyphOutline(dc, Ord(c), GGO_NATIVE, GlyphMetrics, 0, nil,
        IdentityMat2);
      OSCheck( GlyphDataSize <> GDI_ERROR, 'GetGlyphOutline');
      Buffer := GetMem(GlyphDataSize);
      Check( GetGlyphOutline(dc, Ord(c), GGO_NATIVE, GlyphMetrics, GlyphDataSize,
        Buffer, identityMat2) <> GDI_ERROR, 'GetGlyphOutline');

      { convert GlyphMetrics to ResultInfo (ResultInfo.Polygons/ItemsCount will be
        calculated later) }
      ResultInfo.MoveX := GlyphMetrics.gmCellIncX;
      ResultInfo.MoveY := GlyphMetrics.gmCellIncY;
      ResultInfo.Height := GlyphMetrics.gmptGlyphOrigin.y + Integer(GlyphMetrics.gmBlackBoxY);

      { wskazniki na BufferEnd lub dalej wskazuja ZA Bufferem }
      BufferEnd := PtrUInt(Buffer)+GlyphDataSize;

      { calculate ResultItems. Only "Count" fields are left not initialized. }
      PolHeader := Buffer; { pierwszy PolHeader }
      while PtrUInt(PolHeader) < BufferEnd do
      begin
        { czytaj PolHeader }
        ResultItemsAdd(pkNewPolygon);
        PolygonEnd := PtrUInt(PointerAdd(PolHeader, PolHeader^.cb));
        lastPunkt.x := ToFloat(PolHeader^.pfxStart.x);
        lastPunkt.y := ToFloat(PolHeader^.pfxStart.y);

        { czytaj PolCurves }
        PolCurve := PointerAdd(PolHeader, SizeOf(TTPolygonHeader)); { pierwszy PolCurve }
        while PtrUInt(PolCurve) < PolygonEnd do
        begin
          case PolCurve^.wType of
            TT_PRIM_LINE : ResultItemsAdd(pkLines);
            TT_PRIM_QSPLINE : ResultItemsAdd(pkBezier);
            else raise Exception.Create('UNKNOWN PolCurve^.wType !!!!');
          end;
          ResultItemsAdd(lastPunkt.x, lastPunkt.y);
          PointsFX := @PolCurve^.apfx[0];
          for i := 0 to PolCurve^.cpfx-1 do
          begin
            lastPunkt.x := ToFloat(PointsFX^[i].x);
            lastPunkt.y := ToFloat(PointsFX^[i].y);
            ResultItemsAdd(lastPunkt.x, lastPunkt.y);
          end;
          { nastepny PolCurve: }
          PolCurve := PointerAdd(PolCurve, SizeOf(TTPolyCurve) +
            (PolCurve^.cpfx-1)*SizeOf(TPointFX));
        end;

        { zakoncz ten polygon }
        with PolHeader^.pfxStart do ResultItemsAdd(ToFloat(x), ToFloat(y));

        { nastepny PolHeader: }
        PolHeader := Pointer(PolCurve);
      end;
    finally FreeMemNiling(Buffer) end;

    { calculate "Count" fields for items with Kind <> pkPoint in ResultItems }
    for i := 0 to ResultItems.Count - 1 do
      case ResultItems.L[i].Kind of
        pkNewPolygon:
          begin
            dlug := 0;
            for j := i+1 to ResultItems.Count - 1 do
              case ResultItems.L[j].Kind of
                pkLines, pkBezier : Inc(dlug);
                pkNewPolygon : break;
              end;
            ResultItems.L[i].Count := dlug;
          end;
        pkLines, pkBezier:
          begin
            dlug := 0;
            for j := i+1 to ResultItems.Count - 1 do
              if ResultItems.L[j].Kind = pkPoint then Inc(dlug) else break;
            ResultItems.L[i].Count := dlug;
          end;
      end;

    { calculate Result^.Info.PolygonsCount/ItemsCount }
    ResultInfo.ItemsCount := ResultItems.Count;
    ResultInfo.PolygonsCount := 0;
    for i := 0 to ResultItems.Count - 1 do
      if ResultItems.L[i].Kind = pkNewPolygon then Inc(ResultInfo.PolygonsCount);

    { get mem for Result and fill Result^ with calculated data }
    Result := GetMem(SizeOf(TOutlineCharInfo) +
      ResultInfo.ItemsCount*SizeOf(TOutlineCharItem));
    try
      Result^.Info := ResultInfo;
      Move(ResultItems.L[0], Result^.Items,
        ResultInfo.ItemsCount*SizeOf(TOutlineCharItem));
    except FreeMem(Result); raise end;

  finally ResultItems.Free end;
end;

{ Font2XxxFont_HDc ----------------------------------------------- }

function Font2OutlineFont_HDc(dc: HDC): TOutlineFontData;
var
  c: char;
begin
  Result := TOutlineFontData.Create;
  try
    for c := Low(char) to High(char) do
      Result.Data[c] := Font2OutlineChar_HDc(dc, c);
  except FreeAndNilFont(Result); raise end;
end;

{ versions without _HDc ------------------------------------------- }

function Font2OutlineFont(WinFont: HFont): TOutlineFontData;
var
  dc: HDc;
  PreviousObject: HGdiObj;
begin
  dc := GetDC(0);
  Check(dc <> 0, 'GetDC(0) failed');
  try
    PreviousObject := SelectObject(dc, WinFont);
    try
      Result := Font2OutlineFont_HDc(dc);
    finally SelectObject(dc, PreviousObject) end;
  finally ReleaseDC(0, dc) end;
end;

{ FreeAndNilFont ------------------------------------------------------------- }

procedure FreeAndNilFont(var Font: TOutlineFontData);
var
  c: char;
begin
  for c := Low(char) to High(char) do FreeMem(Pointer(Font.Data[c]));
  FreeAndNil(Font);
end;

end.