{ This software is in the public domain. }
unit FNT;

{$MODE OBJFPC}
{$ASSERTIONS ON}
{$PACKRECORDS C}
{$M+}

interface

uses classes, type_fixes, sysutils;

type
  // private
  TWIN16_2CharacterInfo = packed record
    Width : TUINT16;
    Offset : TUINT16; // from the beginning of the FONTINFO structure (?).
  end;

  // private C
  TCharacterInfo = record
    Width : TUINT16;
    Offset : TUINT32;
  end;

{
  // private
  TWIN16_3_ABC = packed record
    Width : TUINT16;
    Offset : TUINT32;
    ASpace : TUINT32; // fractional pixels "16.16".
    BSpace : TUINT32; // fractional pixels "16.16".
    CSpace : TUINT16; // fractional pixels "16.16". WTF.
  end;
}

  // public.  
  TBitmap = array of TByte;
  // public.
  TGlyph = class
  public
    Code : TByte;
    
    Width : TUINT16;
    ASpace : TUINT32; // fractional pixels "16.16".
    BSpace : TUINT32; // fractional pixels "16.16".
    CSpace : TUINT16; // fractional pixels "16.16". WTF.
    Bitmap : TBitmap;
  end;

  // private. TODO expose all that stuff.
  THeader = packed record { C }
    Version : TUINT16; { $0200 or $0300. }
    Size : TUINT32;
    Copyright : array[0..59] of Char;

    Type1 : TUINT16; { low-order byte:
                          bit 0: vector font? (otherwise bitmap font).
                          bit 1: reserved, 0.
                          bit 2: dfBitsOffset valid? }

    PointSize : TUINT16; { the point size at which this character set looks best. }
    VerticalResolution : TUINT16; // dots per inch at which this character set was digitized.
    HorizontalResolution : TUINT16; // dots per inch at which this character set was digitized.
    Ascent : TUINT16; // baseline - top.
    InternalLeading : TUINT16; // amount of leading inside the bounds set by dfPixHeight. Accent marks may occur in this area. can be 0.
    ExternalLeading : TUINT16; // outside of the text area. Not honored by GDI.
    BItalic : TByte;
    BUnderline : TByte;
    BStrikeOut : TByte;
    Weight : TUINT16; { 1 to 1000. 400 = regular. }
    Charset : TByte;
    CommonWidth : TUINT16; { (vector fonts...) bitmap fonts: if <> 0, represents the width of all the characters in the bitmap. Otherwise see charTable array. }
    CommonHeight : TUINT16;  // the height of the character bitmap.
    PitchAndFamily : TByte; { bits:
                                0 variable_pitch?
                                high 4 bits = family name:
                                         0 dont_care.
                                         1 roman (proportionally spaced with serifs).
                                         2 swiss (proportionally spaced without serifs).
                                         3 modern (fixed-pitch).
                                         4 script.
                                         5 decorative. }
    AverageWidth : TUINT16; // width of the character 'X'. (fixed-pitch: AverageWidth = CommonWidth }
    MaximumWidth : TUINT16; // maximum width in pixels.
    FirstCode : TByte; // first character code defined by this font (base for both dfBits and dfCharOffsets).
    LastCode : TByte; // last char defined.
    DefaultCode : TByte; // substitution character (relative to FirstCode, so value = actual - FirstChar). Should NOT be a space.
    BreakCode : TByte; // normally (32 - FirstChar), which is ASCII space.
    WidthBytes : TUINT16; // number of bytes in each row of the bitmap. always even (WORD boundaries). For bitmap fonts only.
    DeviceNameOffset : TUINT32; // offset in file to the string giving the device name or 0.
    FaceNameOffset : TUINT32; // offset to the face name.
    BitsPointer : TUINT32; // "absolute machine address" of the bitmap. Set at load time.
    BitsOffset : TUINT32; // if the 04H bit in dfType is set, then this is an absolute address of the bitmap (in ROM).
    Reserved : TByte;
  end;
    
  TWIN16_3HeaderAdditions = packed record { C } // FIXME.
    Flags : TUINT32; { format of the Glyph bitmap:
               DFF_FIXED            equ  0001h ; font is fixed pitch
               DFF_PROPORTIONAL     equ  0002h ; font is proportional
                                               ; pitch
               DFF_ABCFIXED         equ  0004h ; font is an ABC fixed
                                               ; font
               DFF_ABCPROPORTIONAL  equ  0008h ; font is an ABC pro-
                                               ; portional font
               DFF_1COLOR           equ  0010h ; font is one color
               DFF_16COLOR          equ  0020h ; font is 16 color
               DFF_256COLOR         equ  0040h ; font is 256 color
               DFF_RGBCOLOR         equ  0080h ; font is RGB color }

    ASpace : TUINT16; // the A space, if any. definition: distance from the current position to the left edge of the bitmap.
    BSpace : TUINT16; // B space, if any. The width of the character.
    CSpace : TUINT16; // C space, if any. The distance from the right edge of the bitmap to the new current position. (for DFF_ABCFIXED).
    ColorTableOffset : TUINT32; // 0 or the offset to the color table. like a DIB, without header.
    Reserved_2 : TUINT32;
    Reserved_3 : TUINT32;
    Reserved_4 : TUINT32;
    Reserved_5 : TUINT32;
  end;

  // CharTable : {(LastCode - FirstCode) + 2} of TWIN16_2 | TWIN16_3; the last entry describes an absolute space character.

  // for vector fonts, 2-byte|4-byte entry.

  // <facename> // 0 terminated.
  // <devicename> // 0 terminated.
  // <bitmaps> // 0 terminated.

  { bitmap:
      (first 8 bits of first scanline, first 8 bits of the second scanline, ...,
       next 8 bits of first scanline, next 8 bits of the second scanline, ...).

      the character bitmaps are stored contiguously and arranged in ascending order.

               The following is a single-character example, in which
               are given the bytes for a 12 x 14 pixel character, as
               shown here schematically.

                  76543210
                  ............
                  .....**.....
                  ....*..*....
                  ...*....*...
                  ..*......*..
                  ..*......*..
                  ..*......*..
                  ..********..
                  ..*......*..
                  ..*......*..
                  ..*......*..
                  ............
                  ............
                  ............

               The bytes are given here in two sets, because the
               character is less than 17 pixels wide.

                  00 06 09 10 20 20 20 3F 20 20 20 00 00 00
                  00 00 00 80 40 40 40 C0 40 40 40 00 00 00 }


  TLoader = class
  private
    fInputStream : TStream;
    fBOwnsInputStream : Boolean;
    fFaceName : TString;
    fDeviceName : TString;
    fGlyphs : array[0..255] of TGlyph;
    //fGlyphCount : Word;
    fMainHeader : THeader;
  public
    destructor Destroy(); override;
  protected
    procedure LoadHeader();
  published
    constructor Create(aInputStream : TStream; aBOwnsInputStream : Boolean);
    
    property FaceName : TString read fFaceName;
    property DeviceName : TString read fDeviceName;
    
    //property GlyphCount : Word read fGlyphCount; use FirstCode..LastCode.
    function GetHeader() : THeader; inline;
    class function GetCharacterName(aCode : TByte) : TString;
  public
    property Header : THeader read GetHeader;
  public
    function GetGlyph(aCode : TByte) : TGlyph; inline;
    property Glyphs[aCode : TByte] : TGlyph read GetGlyph; // item can be nil.
  end;

procedure DumpGlyph(const aBitmap : TBitmap; aWidth : Cardinal; aHeight : Cardinal);

  
implementation

procedure DumpGlyph(const aBitmap : TBitmap; aWidth : Cardinal; aHeight : Cardinal);
var
  rowIndex : Integer;
  columnIndex : Integer;
  columnByteIndex : Integer;
  cell : TByte;
begin
  for rowIndex := 0 to aHeight - 1 do begin
    for columnByteIndex := 0 to ((aWidth + 7) div 8) - 1 do begin
      cell := aBitmap[columnByteIndex * aHeight + rowIndex];
      for columnIndex := 7 downto 0 do begin
        if (cell and (1 shl columnIndex)) <> 0 then
          Write('**')
        else
          Write('  ');
      end;
    end;
    Writeln('|');
  end;
end;

// WARNING: this function seeks like a madman.
function GetASCIIZName(aInputStream : TStream; aOffset : Cardinal) : TString;
var
  VName : array of char;
  count : Integer;
  VPreviousPosition : Cardinal;
begin
  if aOffset = 0 then begin
    Result := '';
    Exit;
  end;
  
  // FIXME this function will not read arbitrary-length strings.

  VPreviousPosition := aInputStream.Position;

  SetLength(VName, 255);
    
  aInputStream.Seek(aOffset, soBeginning);
  count := aInputStream.Read(VName[0], 255);
  if count >= 0 then
    SetLength(VName, count)
  else
    SetLength(VName, 0);

  aInputStream.Position := VPreviousPosition;
  Result := PChar(VName); // 0-terminated.
end;

  
// reads a *bitmap* glyph.
function ReadGlyph(aInputStream : TStream; aWidth : Cardinal; const aHeader : THeader) : TBitmap;
var
  VWidth : TCardinal;
  VHeight : TCardinal; 
begin
  VWidth := (aWidth + 7) div 8;
  VHeight := aHeader.CommonHeight;
  SetLength(Result, VWidth * VHeight);
  
  aInputStream.ReadBuffer(Result[0], VWidth * VHeight);
end;


const
  characterNames : array[0..32] of TString = ( '<NUL>', '<SOH>', '<STX>', '<ETX>', '<EOT>', '<ENQ>', '<ACK>', '<BEL>', '<BS>', '<TAB>', '<LF>', '<VT>', '<FF>', '<CR>', '<SO>', '<SI>', 
                                        '<DLE>', '<DC1>', '<DC2>', '<DC3>', '<DC4>', '<NAK>', '<SYN>', '<ETB>', '<CAN>', '<EM>', '<SUB>', '<ESC>', '<FS>', '<GS>', '<RS>', '<US>',
                                        '<SPC>');

const
  highCharacterNames : array[128..255] of TString = (
    {#$80} '<unused_$80>',
    {#$81} '<unused_$81>',
    {#$82} '<baseline_single_quote>',
    {#$83} '<florin>',
    {#$84} '<baseline_double_quote>',
    {#$85} '<ellipsis>',
    {#$86} '<dagger_(single)>',
    {#$87} '<dagger_(double)>',
    {#$88} '<circumflex>',
    {#$89} '<per_mil>',
    {#$8A} '<S_caron>',
    {#$8B} '<left_single_guillemet>',
    {#$8C} '<OE_ligature>',
    {#$8D} '<unused_$8D>',
    {#$8E} '<unused_$8E>',
    {#$8F} '<unused_$8F>',
    {#$90} '<unused_$90>',
    {#$91} '<open_single_quote>',
    {#$92} '<close_single_quote>',
    {#$93} '<open_double_quote>',
    {#$94} '<close_double_quote>',
    {#$95} '<bullet_(large)>',
    {#$96} '<en_dash>',
    {#$97} '<em_dash>',
    {#$98} '<tilde>',
    {#$99} '<unregistered_trademark>',
    {#$9A} '<s_caron>',
    {#$9B} '<right_single_guillemet>',
    {#$9C} '<oe_ligature>',
    {#$9D} '<unused_$9D>',
    {#$9E} '<unused_$9E>',
    {#$9F} '<Y_diaeresis>',
    {#$A0} '<non-breaking_space>',
    {#$A1} '<Spanish_inverted_!>',
    {#$A2} '<cents>',
    {#$A3} '<pounds>',
    {#$A4} '<intl._monetary_symbol>',
    {#$A5} '<yen>',
    {#$A6} '<broken_bar>',
    {#$A7} '<section_symbol>',
    {#$A8} '<diaeresis>',
    {#$A9} '<copyright>',
    {#$AA} '<feminine_ordinal>',
    {#$AB} '<left_double_guillemet>',
    {#$AC} '<not>',
    {#$AD} '<soft_hyphen>',
    {#$AE} '<registered_trademark>',
    {#$AF} '<macron>',
    {#$B0} '<ring_(also_degrees)>',
    {#$B1} '<plus/minus>',
    {#$B2} '<superscript_2>',
    {#$B3} '<superscript_3>',
    {#$B4} '<acute>',
    {#$B5} '<micro_symbol_(or_mu)>',
    {#$B6} '<pilcrow_(paragraph_symbol)>',
    {#$B7} '<bullet_(small)>',
    {#$B8} '<cedilla>',
    {#$B9} '<superscript_1>',
    {#$BA} '<masculine_ordinal>',
    {#$BB} '<right_double_guillemet>',
    {#$BC} '<one-fourth>',
    {#$BD} '<one-half>',
    {#$BE} '<three-fourths>',
    {#$BF} '<Spanish_inverted_?>',
    {#$C0} '<A_grave>',
    {#$C1} '<A_acute>',
    {#$C2} '<A_circumflex>',
    {#$C3} '<A_tilde>',
    {#$C4} '<A_diaeresis>',
    {#$C5} '<A_ring>',
    {#$C6} '<AE_ligature>',
    {#$C7} '<C_cedilla>',
    {#$C8} '<E_grave>',
    {#$C9} '<E_acute>',
    {#$CA} '<E_circumflex>',
    {#$CB} '<E_diaeresis>',
    {#$CC} '<I_grave>',
    {#$CD} '<I_acute>',
    {#$CE} '<I_circumflex>',
    {#$CF} '<I_diaeresis>',
    {#$D0} '<Icelandic_Eth>',
    {#$D1} '<N_tilde>',
    {#$D2} '<O_grave>',
    {#$D3} '<O_acute>',
    {#$D4} '<O_circumflex>',
    {#$D5} '<O_tilde>',
    {#$D6} '<O_diaeresis>',
    {#$D7} '<multiply_symbol>',
    {#$D8} '<O_with_oblique_stroke>',
    {#$D9} '<U_grave>',
    {#$DA} '<U_acute>',
    {#$DB} '<U_circumflex>',
    {#$DC} '<U_diaeresis>',
    {#$DD} '<Y_acute>',
    {#$DE} '<Icelandic_Thorn>',
    {#$DF} '<German_sharp_s>',
    {#$E0} '<a_grave>',
    {#$E1} '<a_acute>',
    {#$E2} '<a_circumflex>',
    {#$E3} '<a_tilde>',
    {#$E4} '<a_diaeresis>',
    {#$E5} '<a_ring>',
    {#$E6} '<ae_ligature>',
    {#$E7} '<c_cedilla>',
    {#$E8} '<e_grave>',
    {#$E9} '<e_acute>',
    {#$EA} '<e_circumflex>',
    {#$EB} '<e_diaeresis>',
    {#$EC} '<i_grave>',
    {#$ED} '<i_acute>',
    {#$EE} '<i_circumflex>',
    {#$EF} '<i_diaeresis>',
    {#$F0} '<Icelandic_eth>',
    {#$F1} '<n_tilde>',
    {#$F2} '<o_grave>',
    {#$F3} '<o_acute>',
    {#$F4} '<o_circumflex>',
    {#$F5} '<o_tilde>',
    {#$F6} '<o_diaeresis>',
    {#$F7} '<divide_symbol>',
    {#$F8} '<o_with_oblique_stroke>',
    {#$F9} '<u_grave>',
    {#$FA} '<u_acute>',
    {#$FB} '<u_circumflex>',
    {#$FC} '<u_diaeresis>',
    {#$FD} '<y_acute>',
    {#$FE} '<Icelandic_thorn>',
    {#$FF} '<y_diaeresis>');
  
class function TLoader.GetCharacterName(aCode : TByte) : TString;
begin
  if aCode <= High(characterNames) then
    Result := characterNames[aCode]
  else if (aCode >= Low(highCharacterNames)) and (aCode <= High(highCharacterNames)) then
    Result := highCharacterNames[aCode]
  else
    Result := Chr(aCode);
end;

procedure TLoader.LoadHeader();
var
  VWIN16_2CharacterInfo : TWIN16_2CharacterInfo; // OLD!
  VWIN16_3HeaderAdditions : TWIN16_3HeaderAdditions;
  VCharacterInfo : TCharacterInfo;
  VCharacterInfos : array of TCharacterInfo;
  VCode : Cardinal;
  VGlyphBitmap : TBitmap;
  VGlyph : TGlyph;
begin
  assert(sizeof(THeader) = $76);
  assert(sizeof(TWIN16_3HeaderAdditions) = 30);

  fInputStream.ReadBuffer(fMainHeader, Sizeof(fMainHeader));
  if fInputStream.Size < fMainHeader.Size then { can have a little bit of padding... }
    raise EFormatError.Create('file is damaged.');

  if (fMainHeader.Type1 and $1) <> 0 then
    raise EFormatError.Create('vector fonts are not supported.');
    
  fFaceName := GetASCIIZName(fInputStream, fMainHeader.FaceNameOffset);
  fDeviceName := GetASCIIZName(fInputStream, fMainHeader.DeviceNameOffset);

  if fMainHeader.Version = $300 then
    fInputStream.ReadBuffer(VWIN16_3HeaderAdditions, Sizeof(VWIN16_3HeaderAdditions))
  else begin
   with VWIN16_3HeaderAdditions do begin
     Flags := $11; // fixed pitch, 1 color.
     ASpace := 0;
     BSpace := 0;
     CSpace := 0;
     ColorTableOffset := 0;
   end;
  end;

  if (fMainHeader.LastCode < fMainHeader.FirstCode) then 
    raise EFormatError.Create('font is damaged (LastCode < FirstCode).');
  
  SetLength(VCharacterInfos, fMainHeader.LastCode - fMainHeader.FirstCode + 2);

  for VCode := fMainHeader.FirstCode to fMainHeader.LastCode do begin { note: + 1 sentinel. }
    if fMainHeader.Version = $200 then begin
      fInputStream.ReadBuffer(VWIN16_2CharacterInfo, Sizeof(VWIN16_2CharacterInfo));
      VCharacterInfo.Width := VWIN16_2CharacterInfo.Width;
      VCharacterInfo.Offset := VWIN16_2CharacterInfo.Offset;
    end else if fMainHeader.Version = $300 then begin
      fInputStream.ReadBuffer(VCharacterInfo, Sizeof(VCharacterInfo));
    end else
      raise EFormatError.Create(Format('unsupported FNT version %X', [fMainHeader.Version]));
      
    VCharacterInfos[VCode - fMainHeader.FirstCode] := VCharacterInfo;
  end;

  for VCode := fMainHeader.FirstCode to fMainHeader.LastCode do begin { note: + 1 sentinel. }
    VCharacterInfo := VCharacterInfos[VCode - fMainHeader.FirstCode];
    // VWIN16_3HeaderAdditions.ASpace, BSpace, CSpace.
 
    fInputStream.Position := VCharacterInfo.Offset;
    
    VGlyphBitmap := ReadGlyph(fInputStream, VCharacterInfo.Width, fMainHeader);
    
    VGlyph := TGlyph.Create();
    VGlyph.Code := VCode;
    VGlyph.Width := VCharacterInfo.Width;
    VGlyph.ASpace := VWIN16_3HeaderAdditions.ASpace; // or new character info ^.ASpace.
    VGlyph.BSpace := VWIN16_3HeaderAdditions.BSpace;
    VGlyph.CSpace := VWIN16_3HeaderAdditions.CSpace;
    VGlyph.Bitmap := VGlyphBitmap;

    if Assigned(fGlyphs[VCode]) then begin
      // duplicate?!?! warn('');
      FreeAndNil(fGlyphs[VCode]);
    end;
        
    fGlyphs[VCode] := VGlyph;
  end;
end;

destructor TLoader.Destroy();
begin
  if fBOwnsInputStream then
    FreeAndNil(fInputStream);
end;

constructor TLoader.Create(aInputStream : TStream; aBOwnsInputStream : Boolean);
begin
  fInputStream := aInputStream;
  fBOwnsInputStream := aBOwnsInputStream;
  LoadHeader();
end;

function TLoader.GetGlyph(aCode : TByte) : TGlyph; inline;
begin
  Result := fGlyphs[aCode];
end;

function TLoader.GetHeader() : THeader; inline;
begin 
  Result := fMainHeader;
end;

end.