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

{$MODE OBJFPC}
{$M+}

interface
uses fonts, classes, type_fixes, images;

{ TODO use fixed point? floating point? }

// TODO implement a IWindowsFNT which exposes copyright, font name, ... ?

type
  TFont = class(TInterfacedObject, IFont, IInterface)
  private
    fGlyphs : TGlyphArray; // indexed by ANSI code.
  published
    class function Load(aInputStream : TStream) : TFont;
  protected
    procedure AddBitmapGlyph(aCode : Cardinal; const aBitmap : IImage; const aBox : TGlyphBox); // aCode in ANSI.
  published
    constructor Create();
    function GetGlyph(aCode : Cardinal) : TGlyphP{or nil};
    // GetGlyphOrFallback = GetGlyph or FallbackGlyph
    function GetFallbackGlyph() : TGlyphP; // not nil. // (can't be published in the interface by FPC so exposed as a function, not a property).
  end;

implementation

uses FNT, sysutils, framebuffers, Windows_1252;

function UnpackGlyph(const aBitmap : FNT.TBitmap; aWidth : TCardinal; aHeight : TCardinal) : IImage;
var
  rowIndex : TCardinal;
  //columnIndex : Integer;
  columnByteIndex : TCardinal; // Integer;
  cell : TByte;
  VFramebuffer : TFramebufferInfoP;
  VPosition : PByte;
  VRowStart : PByte;
  VRowStride : TCardinal;
begin
  Result := TFramebufferImage.Allocate(pbAlpha1, aWidth, aHeight);
  VFramebuffer := Result.GetFramebuffer();
  VRowStart := PByte(VFramebuffer^.Start);
  VRowStride := VFramebuffer^.RowStride;

  // TODO optimize?

  if (((aWidth + 7) div 8) > 0) and (aHeight > 0) then
  for rowIndex := 0 to aHeight - 1 do begin
    VPosition := VRowStart;
    for columnByteIndex := 0 to ((aWidth + 7) div 8) - 1 do begin
      cell := aBitmap[columnByteIndex * aHeight + rowIndex];
      
      VPosition^ := cell;
      {
      for columnIndex := 7 downto 0 do begin
        if (cell and (1 shl columnIndex)) <> 0 then
          VPosition^ := $FF
        else
          VPosition^ := 0;
        Inc(VPosition);
      end;
      }
      Inc(VPosition);
    end;
    Inc(VRowStart, VRowStride);
  end;
end;

constructor TFont.Create();
begin
  inherited Create();
  SetLength(fGlyphs, 256);
end;

// TODO support non-ANSI codepages?
class function TFont.Load(aInputStream : TStream) : TFont;
var
  VLoader : FNT.TLoader;
  VCode : TByte;
  VBox : TGlyphBox;
begin
  Result := TFont.Create();
  try
    VLoader := FNT.TLoader.Create(aInputStream, False);
    try
      //Writeln(Format('Copyright: "%s"', [VLoader.Header.Copyright]));
      //Writeln(Format('Face Name: "%s"', [VLoader.FaceName]));
      //Writeln(Format('Device Name: "%s"', [VLoader.DeviceName]));
      // VLoader.Header.PointSize
  
      for VCode := VLoader.Header.FirstCode to VLoader.Header.LastCode do begin
        with VLoader.Glyphs[VCode] do begin
          FillChar(VBox, Sizeof(VBox), 0);
          VBox.Ascent := VLoader.Header.Ascent;
          
          VBox.LeftSideBearing := ASpace; // FIXME CSpace is fractional 16:16.
          VBox.AdvanceWidth := Width + CSpace; // FIXME CSpace is fractional 16:16.
          
          AddBitmapGlyph(VCode, UnpackGlyph(Bitmap, Width, VLoader.Header.CommonHeight), VBox); // FIXME what to do when UnpackGlyph succeeds but AddBitmapGlyph fails?
          // FIXME convert bitmap to a IPixmap (framebufferinfo).
          //Writeln(Format('%s = """', [VLoader.GetCharacterName(VCode)]));
          DumpGlyph(Bitmap, Width, VLoader.Header.CommonHeight);
          //Writeln('""",');
        end;
      end;
    finally
      FreeAndNil(VLoader);
    end;
  except
    FreeAndNil(Result);
    raise;
  end;
end;

procedure TFont.AddBitmapGlyph(aCode : Cardinal; const aBitmap : IImage; const aBox : TGlyphBox); // aCode in ANSI.
begin
  with fGlyphs[aCode] do
    Boxes[AddBitmap(aBitmap)] := aBox;
end;

function TFont.GetGlyph(aCode : TCardinal) : TGlyphP{or nil};
var
  VANSICode : Integer;
begin
  VANSICode := Windows_1252.ANSIFromUnicode(aCode);
  if VANSICode <> -1 then
    Result := @fGlyphs[VANSICode]
  else
    Result := nil;
end;

function TFont.GetFallbackGlyph() : TGlyphP; // not nil. // (can't be published in the interface by FPC so exposed as a function, not a property).
begin
  Result := nil;
end;

end.