uses Dos, Objects, Strings, Memory, WinRes, ttf;

{ Write a font file
}

var
  fnt: PStream;
  tt: PStream;
  ttfont: PTTFont;
  Header: TFontInfo;
  Fill: array[0..1000] of Char;
  CharTable: array[0..256] of TNewRasterInfo;
  c: Char;

{ Parameters
}
  ttfile: PathStr;
  fntfile: PathStr;
  ResX, ResY: Integer;
  Pt: Integer;
  DosTable: Boolean;
  FontCopyright: array[0..59] of Char;
  FaceName: array[0..32] of Char;
  DeviceName: array[0..32] of Char;
  FirstChar, LastChar: Char;

procedure Error(txt: string);
begin
  WriteLn(txt);
  Halt(1)
end;

procedure createHeader;
var
  os2: tos2;
  FontBounds: TRectInt;

	function ScX(eulav: Word): Integer;
	begin
	  ScX := (ttf.Scale(SwapWord(eulav), ttfont^.Scaling.x) + $8000) shr 16;
	end;

	function ScY(eulav: Word): Integer;
	begin
	  ScY := (ttf.Scale(SwapWord(eulav), ttfont^.Scaling.y) + $8000) shr 16;
	end;

Begin
  ttfont^.GetOs2(os2);
  ttfont^.GetFontBounds(FontBounds);
  FillChar(Header, SizeOf(Header), 0);
  with Header do
  begin
    dfVersion := $300;
    {dfSize}
    Move(FontCopyright, dfCopyright, StrLen(FontCopyright));
    {dfType := 0;}
    dfPoints := Pt;
    dfVertRes := ResY;
    dfHorizRes := ResX;
    dfAscent := ScY(os2.usWinAscent);
    {dfInternalLeading := 0;}
    {dfExternalLeading := 0;}
    {dfItalic := 0;}
    {dfUnderline := 0;}
    {dfStrikeOut := 0;}
    dfWeight := 400;
    If DosTable
    then dfCharSet := 255 {OEM}
    else dfCharSet := 0; {ANSI}
    {dfPixWidth := 0; {variable-pitch}
    dfPixHeight := FontBounds.B.y - FontBounds.A.y + 1;
    {dfPitchAndFamily := 0; {don't care}
    dfAvgWidth := ScX(os2.xAvgCharWidth);
    dfMaxWidth := FontBounds.B.x - FontBounds.A.x;
    dfFirstChar := Ord(FirstChar);
    dfLastChar := Ord(LastChar);
    dfDefaultChar := Ord(' ') - dfFirstChar;
    dfBreakChar := dfDefaultChar;
    dfWidthBytes := 0;
    dfFlags := 1; {Fixed}


  end;
End;

procedure writeHeader;
var
  l: LongInt;
begin
  Header.dfSize := fnt^.GetSize;
  fnt^.Seek(0);
  fnt^.write(Header.dfVersion, SizeOf(Header) - SizeOf(Word) + 16);
end;

procedure writeCharTable;
begin
  fnt^.Write(CharTable[Header.dfFirstChar],
    (Header.dfLastChar - Header.dfFirstChar + 2) * SizeOf(TNewRasterInfo))
end;

procedure MakeBitmap(ch: Char; at: Integer);
var
  bit: pointer;
  P, size: LongInt;
  index: Integer;
  Hmtx: THMtx;
  GlyphBounds: TRectInt;
  Width, Height: TRectInt;
  A, B, C: Integer;
  Buf: array[0..1] of Char;
begin
  P := fnt^.GetPos;
  If DosTable
  then begin
    Buf[0] := ch;
    Buf[1] := #0;
    AnsiFrom437(Buf);
    ch := Buf[0]
  end;
  index := ttfont^.GetIndexOf(ch);
  ttfont^.GetHMtx(Index, HMtx);
  ttfont^.glyphLeft := HMtx.lsb.x;
  ttfont^.glyphAdvance := HMtx.AdvanceWidth.x;

  size := ttfont^.GetBitmap(index, bit);
  fnt^.Write(bit^, size);
  fnt^.Write(fill, Header.dfPixHeight);
  DisposeCache(bit);
  ttfont^.GetGlyphBounds(GlyphBounds);
  ttfont^.GetGlyphExtent(Width, Height);

  B := GlyphBounds.B.x - GlyphBounds.A.x + 1;
  with CharTable[at] do
  begin
    dcOffset := P;
    dcWidth := B;
  end;
  Inc(Header.dfWidthBytes, (B + 7) div 8 + 1 {??});
end;

begin
  ttfile := 'c:\windows\system\cyril1.ttf';
  fntfile := 'ar.fnt';
  ResX := 204; ResY := 196; {low: 98}
  Pt := 12;
  StrLCopy(FontCopyright,
    'TrueType Scan-Converter is copr. 1996 Matthias Koeppe', 59);
  StrLCopy(FaceName, 'XXX', 32);
  StrLCopy(DeviceName, '', 32);
  DosTable := false;
  FirstChar := ' '; LastChar := #255;

  InitMemory;
  tt := New(PBufStream, Init(ttfile, stOpenRead, 4096));
  ttfont := New(PTTFont, Init(tt));
  if ttfont = nil
  then Error('Error opening TTF file.');
  with ttfont^ do
  begin
    SetResolution(ResX, ResY);
    SetPointSize(Pt, Pt);
  end;

  fnt := New(PBufStream, Init(fntfile, stCreate, 4096));
  createHeader;

  { Make room for header and char table
  }
  writeHeader;
  writeCharTable;

  Header.dfBitsOffset := fnt^.GetPos;
  For c := FirstChar to LastChar do
  begin
    Write('[', Ord(c));
    MakeBitmap(c, Ord(c));
    Write('] ')
  end;

  MakeBitmap(' ', Ord(LastChar) + 1);

  { Write device and face name
  }
  Header.dfDevice := fnt^.GetPos;
  fnt^.Write(DeviceName, StrLen(DeviceName) + 1);
  Header.dfFace := fnt^.GetPos;
  fnt^.Write(FaceName, StrLen(FaceName) + 1);
  { Write the updated header and char table
  }
  writeHeader;
  writeCharTable;
  Dispose(fnt, Done);
  Dispose(tt, Done);
  DoneMemory
end.
