unit RFreeType;

{$mode objfpc}{$H+}

interface

uses

  GlobalConfig,
  Platform,
  Threads,
  Ultibo,

  Classes,
  SysUtils,
  GlobalTypes,
  GlobalConst,

  Console,
  GraphicsConsole,

  freetypeh;


const
  DPI = 72;    // dots per inch


type


  {TRFonts specific clases}
  TRFonts = class(TObject)
    private
      {Internal Variables}
      aFace : PFT_Face;
      Font_Console : TWindowHandle;
      Buffer : PLongWord;
      BufferSize : Integer;
      {Internal Methods}
      procedure DrawChar(DC_Char : Char; x, y: integer; Font_Color, BackGround_Colour : LongWord);

    public
      {Public Properties}
      System_Bar_Top,
      Margin_Left,
      Margin_Top,
      Margin_Right,
      Margin_Button,
      System_Bar_Button : LongWord;

      Font_Size, Font_Width, Font_Height : Integer;
      {Public Methods}
      constructor Create;
      procedure calculate_Font_Width;
      function open_Font(G_Console : TWindowHandle; FontFile : string; FontSize : Integer) : Integer;
      procedure FT_DrawChar(DC_Char : Char; DC_Pos_X,DC_Pos_Y,Forecolor,Backcolor : LongWord);
      procedure FT_DrawText(DT_Text : String; DT_Pos_X,DT_Pos_Y,Forecolor,Backcolor : LongWord);
      procedure FT_Clear_Screen;
      procedure FT_close_Font;
      destructor Destroy;

    protected
      {Internal Variables}

      {Internal Methods}

   end; { TRFonts }



var
  FTLib : PFT_Library;                // handle to FreeType library
  res : integer;



implementation






{==============================================================================}
{==============================================================================}
{TRFonts}
constructor TRFonts.Create;
begin
  {}
  inherited Create;

  FTLib := nil;
  res := FT_Init_FreeType (FTLib);    // initialise library

  System_Bar_Top:=0;
  Margin_Left:=0;
  Margin_Top:=0;
  Margin_Right:=0;
  Margin_Button:=0;
  System_Bar_Button:=0;

  Font_Width:=0;
  Font_Height:=10;

end; { constructor TRFonts.Create }













{==============================================================================}
{==============================================================================}
{TRFonts}

procedure TRFonts.calculate_Font_Width;
var
  i, tx, ty : integer;
  kerning : boolean;
  glyph_index,
  prev : cardinal;
  delta : FT_Vector;

begin

  if Font_Console = INVALID_HANDLE_VALUE then exit;

  tx := 0;
  ty := 0;
  delta.x := 0;
  delta.y := 0;

  prev := 0;    // no previous char

  kerning := FT_HAS_KERNING (aFace);

  glyph_index := FT_Get_Char_Index (aFace, cardinal ('M'));

  // load glyph image into the slot (erase previous one)
  FT_Load_Glyph (aFace, glyph_index, FT_LOAD_RENDER);

  prev := glyph_index;

  glyph_index := FT_Get_Char_Index (aFace, cardinal ('M'));

  FT_Get_Kerning (aFace, prev, glyph_index, FT_KERNING_DEFAULT, &delta);

  Font_Width:=aFace^.glyph^.advance.x div 64;

end; { procedure TRFonts.calculate_Font_Width }






{==============================================================================}
{==============================================================================}
{TRFonts}

function TRFonts.open_Font(G_Console : TWindowHandle; FontFile : string; FontSize : Integer) : Integer;
var
  err : Integer;
  FullFontFile : String;
  b : FT_Bitmap;


  procedure WaitForSDDrive;
  begin
    while not DirectoryExists ('C:\') do sleep (500);
  end; { procedure WaitForSDDrive }



begin

  if not Assigned (FTLib) then exit;

  aFace := nil;

  Font_Console:=G_Console;
  Font_Size:=FontSize;
  Font_Height:=FontSize;

  WaitForSDDrive;

  if ExtractFileExt (FontFile) = '' then
    FullFontFile := FontFile + '.ttf'
  else
    FullFontFile := FontFile;

  err := FT_New_Face (FTLib, PChar (FullFontFile), 0, aFace);

  // if font face loaded ok
  if err = 0 then begin

    err := FT_Set_Char_Size (aFace,                   // handle to face object
           0,                                         // char_width in 1/64th of points - Same as height
           FontSize * 64,                             // char_height in 1/64th of points
           DPI,                                       // horizontal device resolution
           0);                                        // vertical device resolution

    calculate_Font_Width;

  end;

  b:=aFace^.glyph^.bitmap;

  BufferSize := (b.width * b.rows * SizeOf (LongWord) * 2) + 500;
  if BufferSize = 0 then exit;
  GetMem (Buffer, BufferSize);

  Result:=err;

end; { function TRFonts.open_Font }







{==============================================================================}
{==============================================================================}
{TRFonts}

procedure TRFonts.DrawChar (DC_Char : Char; x, y: integer; Font_Color, BackGround_Colour : LongWord);
var
  glyph_index,
  prev : cardinal;
  y2 : integer;


  function GetRValue (c : cardinal) : byte; inline;
  begin
    Result := (c and $ff0000) shr 16;
  end;


  function GetGValue (c : cardinal) : byte; inline;
  begin
    Result :=  (c and $ff00) shr 8;
  end;


  function GetBValue (c : cardinal) : byte; inline;
  begin
    Result := c and $ff;
  end;


  function rgb (r, g, b : byte)  : cardinal; inline;
  begin
    Result := $ff000000 + (r shl 16) + (g shl 8) + b;
  end;


  procedure Draw_BMP_Char (b : FT_Bitmap; dx, dy : integer);
  var
    i , j : LongWord;
    fm : PByte;
    rd, gn, bl : Byte;
    BufferPos : PLongWord;
  begin
    if BufferSize = 0 then exit;
    FillChar (Buffer^, BufferSize, 0);
    BufferPos := Buffer;
    for j := 0 to b.rows - 1 do
      for i := 0 to b.width - 1 do
        begin
          LongWord (fm) := LongWord (b.buffer) + j * Longword (b.width) + i; // read alpha value of font char
          rd := ((GetRValue (Font_Color) * fm^) + (GetRValue (BackGround_Colour) * (255 - fm^))) div 255;
          gn := ((GetGValue (Font_Color) * fm^) + (GetGValue (BackGround_Colour) * (255 - fm^))) div 255;
          bl := ((GetBValue (Font_Color) * fm^) + (GetBValue (BackGround_Colour) * (255 - fm^))) div 255;
          BufferPos^ := rgb (rd, gn, bl);
          Inc (BufferPos, 1);
        end;


    y2:=Font_Height * 40 div 5;
    y2:=y - (y2 div 10);


    GraphicsWindowDrawBlock(Font_Console, x, y2,
                            x+Font_Width, y2+Font_Height, BackGround_Colour);


    GraphicsWindowDrawImage (Font_Console, dx, dy, Buffer, b.width, b.rows, COLOR_FORMAT_ARGB32);

  end; { Draw_BMP_Char }

begin

  if Font_Console = INVALID_HANDLE_VALUE then exit;

  FT_HAS_KERNING (aFace);

  // convert character code to glyph index
  glyph_index := FT_Get_Char_Index (aFace, cardinal (DC_Char));

  // load glyph image into the slot (erase previous one)
  FT_Load_Glyph (aFace, glyph_index, FT_LOAD_RENDER);

  // now draw to our target surface
  Draw_BMP_Char (aFace^.glyph^.bitmap, x + aFace^.glyph^.bitmap_left,
                 y - aFace^.glyph^.bitmap_top);

end; { procedure TRFonts.DrawChar }



{==============================================================================}
{==============================================================================}
{TRFonts}

procedure TRFonts.FT_DrawChar(DC_Char : Char; DC_Pos_X,DC_Pos_Y,Forecolor,Backcolor : LongWord);
var
  x_pos, y_pos : LongWord;
  y3 : Integer;



  procedure DrawSpaceChar(DSC_Char : Char; DSC_X, DSC_Y: integer; Font_Color, BackGround_Colour : LongWord);
  var
    DSC_Y2 : Integer;
  begin

    DSC_Y2:=Font_Height * 40 div 5;
    DSC_Y2:=DSC_Y - (DSC_Y2 div 10);

    GraphicsWindowDrawBlock(Font_Console, DSC_X, DSC_Y2,
                            DSC_X+Font_Width, DSC_Y2+Font_Height, BackGround_Colour);

  end; { procedure DrawSpaceChar }



begin

  x_pos:=Margin_Left+(DC_Pos_X*Font_Width);

  y3:=Font_Height * 40 div 5;
  y3:=y3 div 10;

  y_pos:=System_Bar_Top+Margin_Top+y3+(DC_Pos_Y*Font_Height);

  if DC_Char=' ' then
    DrawSpaceChar(DC_Char, x_pos, y_pos, Forecolor, Backcolor)
  else
    DrawChar(DC_Char, x_pos, y_pos, Forecolor, Backcolor);

end; { procedure TRFonts.TXT_DrawChar }




{==============================================================================}
{==============================================================================}
{TRFonts}

procedure TRFonts.FT_DrawText(DT_Text : String; DT_Pos_X,DT_Pos_Y,Forecolor,Backcolor : LongWord);
var
  DT_counter : LongWord;
  DT_Char : Char;
begin

  for DT_counter:=1 to Length(DT_Text) do begin
    DT_Char:=DT_Text[DT_counter];
    FT_DrawChar(DT_Char, DT_Pos_X+DT_counter-1, DT_Pos_Y, Forecolor, Backcolor);
  end;

end; { procedure TRFonts.TXT_DrawText }




{==============================================================================}
{==============================================================================}
{TRFonts}

procedure TRFonts.FT_Clear_Screen;
begin

  GraphicsWindowSetBackcolor(Font_Console,COLOR_WHITE);
  GraphicsWindowClear(Font_Console);

end; { procedure TRFonts.FT_Clear_Screen }








{==============================================================================}
{==============================================================================}
{TRFonts}

procedure TRFonts.FT_close_Font;
begin

  FT_Done_Face (aFace);
  FreeMem (Buffer);

end; { procedure TRFonts.FF_close_Font }



{==============================================================================}
{==============================================================================}
{TRFonts}
destructor TRFonts.Destroy;
begin

  FT_Done_FreeType (FTLib);       // close library

  inherited Destroy;
end; { destructor TRFonts.Destroy }






end.

