unit vnm_ttf;
{****************************************************************************}
{Unit VNM_TTF - it is a addon unit for graphics library VenomGFX.            }
{It brings a loader for .TTF vector font files.                              }
{Written by Laaca.                                                           }
{   (depends on library Freetype (ver. 1.x)                                  }
{****************************************************************************}

{$IFDEF VER2}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF VER3}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF NEWFPC}{$CALLING OLDFPCCALL}{$ENDIF}


{$ASMMODE INTEL}
interface
uses VnmFnHlp;

const
TTF_MAX_BITMAP_EXPORT  = 32;

TTF_err_Init_FreeType_failed = 1;
TTF_err_New_Face_failed = 2; {there is probably a problem with your font file}
TTF_err_Get_Face_Properties_failed = 3;
TTF_err_New_Instance_failed = 4;
TTF_err_Set_Instance_Resolutions_failed = 5;
TTF_err_Set_Instance_CharSizes_failed = 6;
TTF_err_New_Glyph_failed = 7;
TTF_err_Load_Glyph_failed = 8;
TTF_err_Get_Glyph_Metrics_failed = 9;

ttf_unit_error:byte = 0;
ttf_konverze_pres_bitmapu_ci_pixmapu:byte=0;
{0=pres bitmapu, 1=pres pixmapu}

ttf_konverze_pres_pixmapu_prahova_hodnota:byte=8;


var global_ttf_loader_popisek:string;

type

PTTFznaky = ^TTTFznaky;
TTTFznaky = object(TBitmapovyFont)
   ZBlok:array[0..255] of PBlok256p;  { TBlok256p = ^array[0..255] of PZnak;}

  {Font bude ulozen v blocich po 256 znacich. To nam umozni uspornou alokaci
   pameti pro fonty, ktere maji definovany jen maly pocet z 65535 moznych znaku.
   U kazdeho fontu budeme aktivovat blok pro znaky 0..255 a dal se uvidi...}

   Constructor Init;

   Function OdemkniBlok(a:longint):byte;
   Procedure VclenZnak(z:PZnak;i:longint);
   Function PrepChar(znak:longint):pointer;virtual;

   Destructor Done;virtual;
   end;


Function CheckFormat_TTF(nazev:string):byte;



{Vektorove fonty mam ulozene podobne jako kontejnery s bitmapovymi fonty.
 Pracuje s PObecnyFont, ktery obsahuje:<fdata:PTTFZnaky> a
                                       <odkaz_na_pointer:PTTF_kontejner>


Prvni nahravani fontu probehne pres TTF_Font_LoadFont.
Toto volani nahraje vektorovy format, ale netvori z neho bitmapove sady.

Bitmapove sady pro dane velikosti se vytvori az pozdeji,
pri volani TTF_Font_SetParams
}




Function TTF_Font_LoadFont(s:string;size:longint):pointer;
Function TTF_Font_SetStyle(fnt:pointer;podfunkce,param1,param2:longint):pointer;
Function TTF_Font_Delete(fnt:pointer;mode:byte):boolean;

implementation

uses VenomGFX,VenomMng, FreeType, TTTypes;

const is_ttf_engine_loaded:boolean = false;

type

PTTF_kontejner=^TTTF_kontejner;
TTTF_kontejner=object

       rez:string;
       face       : TT_Face;
       face_props : TT_Face_Properties;
       charmap    : TT_CharMap;

       BitmapExport :Array[1..TTF_MAX_BITMAP_EXPORT] of record ptr:pointer;size:longint;end;
       BitmapExportNum:byte;
       TTFloaded:boolean;
       PocetZnaku:longint;

       Constructor Init;
       Function LoadFont(nazev:string):boolean;
       Function Pretvor_do_bitmapove_sady(velikost:longint):PTTFznaky;
       Function Pretvor_do_bitmapove_sady_krok_2(instance: TT_Instance;bf:PTTFZnaky;var maxnad,maxpod:longint):boolean;
       Procedure RegisterBitmapExport(fnt:PObecnyFont;size:longint);
       Function FindExportedBitmap(size:longint):pointer;
       Procedure RemoveExportedBitmapRecord(size:longint);
       Procedure RemoveFont;
       Destructor Done;
       end;


Constructor TTTFznaky.Init;
var i:longint;
begin
inherited Init;
unicode:=true;
kodova_stranka:=65535;
format:=FNFMT_TTF;
vel:=0;
prop:=true;
{vnitrnijmeno:='';}
for i:=0 to 255 do ZBlok[i]:=nil;
end;


Function TTTFznaky.OdemkniBlok(a:longint):byte;
var b:longint;
begin
if (a<0) or (a>255) then Exit(0);
if ZBlok[a]=nil then
   begin
   New(ZBlok[a]);  {pamet pro pozadovany blok}
   for b:=0 to 255 do    {ted vynuluju vsecny znaky v bloku}
       ZBlok[a]^[b]:=nil;  {vynulovani ukazatele pro konkretni znak}
   OdemkniBlok:=2;
   end
   else OdemkniBlok:=1;
end;



Function TTTFznaky.PrepChar(znak:longint):pointer;
var zd,zm:longint;
begin
if (znak>$FFFF) or (znak<0) then Exit(nil);
zd:=znak div 256;
if ZBlok[zd]=nil then Exit(nil)
   else begin
   zm:=znak mod 256;
   PrepChar:=ZBlok[zd]^[zm];  {muze byt NIL nebo platny ukazatel}
   end;
end;


Procedure TTTFznaky.VclenZnak(z:PZnak;i:longint);
var ablokdiv,ablokmod:longint;
begin
if (i>=0) and (i<=65535) then
   begin
   ablokdiv:=i div 256;
   ablokmod:=i mod 256;
   OdemkniBlok(ablokdiv);
   ZBlok[ablokdiv]^[ablokmod]:=z;
   end;
end;


Destructor TTTFznaky.Done;
begin
inherited Done;
end;



Function CheckFormat_TTF(nazev:string):byte;
var nazev_djf:string;
    temp_face:TT_Face;
begin
if is_ttf_engine_loaded=false then
   if TT_Init_FreeType <> TT_Err_Ok
      then begin TTF_unit_error:=TTF_err_Init_FreeType_failed;Exit(TTF_err_Init_FreeType_failed);end
      else is_ttf_engine_loaded:=true;

nazev_djf:=DoplnJmenoFontu(nazev);
if TT_Open_Face(nazev_djf,temp_face) <> TT_Err_Ok then
   begin
   ttf_unit_error:=TTF_err_New_Face_failed;
   Exit(TTF_err_New_Face_failed);
   end;
TT_Close_Face(temp_face);
CheckFormat_TTF:=0;
end;


Constructor TTTF_Kontejner.Init;
var a:byte;
begin
TTFloaded:=false;
for a:=1 to TTF_MAX_BITMAP_EXPORT do
    begin
    BitmapExport[a].ptr:=nil;
    BitmapExport[a].size:=0;
    end;
BitmapExportNum:=0;
end;




Function TTTF_kontejner.LoadFont(nazev:string):boolean;
{inicializuje kontejner s vektorovymi daty, ale zatim nedela prepocet na bitmapy}
var
    i,j,k,l:longint;
    s,t:string;
    nazev_djf:string;
    te:TT_error;

Begin
nazev_djf:=DoplnJmenoFontu(nazev);
if TT_Open_Face(nazev_djf,face) <> TT_Err_Ok then
   begin
   ttf_unit_error:=TTF_err_New_Face_failed;
   Exit(false);
   end;
{mame nactenou vektorovou hlavicku fontu}


if TT_Get_Face_Properties(face, face_props) <> TT_Err_OK then
   begin
   ttf_unit_error:=TTF_err_Get_Face_Properties_failed;
   Exit(false);
   end;
{nactena nejaka obecna data}

PocetZnaku:=face_props.Num_glyphs;

rez:=NazevBezCesty(nazev);
for i:=1 to Length(rez) do rez[i]:=UpCase(rez[i]);
TTFloaded:=true;
Loadfont:=true;

l:=-1;
for i:=0 to TT_Get_CharMap_Count(face)-1 do
    begin  {preferujeme mapovani Windows Unicode (platform 3, encoding 1)}
    te:=TT_Get_CharMap_ID(face,i,j,k);
    if (j=3) and (k=1) then begin l:=i;Break;end;
    end;
if l=-1 then l:=0;

TT_Get_CharMap(face, l, charmap);
{pripravime mapovani kodu znaku}
end;


Function TTTF_kontejner.Pretvor_do_bitmapove_sady(velikost:longint):PTTFznaky;
var bf:PTTFZnaky;
    instance: TT_Instance;
    a,maxnad,maxpod:longint;
    z:PZnak;

begin
bf:=New(PTTFZnaky,Init);


if TT_New_Instance(face, instance) <> TT_Err_Ok then
   begin
   ttf_unit_error:=TTF_err_New_Instance_failed;
   Dispose(bf,Done);
   Exit(nil);
   end;
{priprava pred prevodem z vektoru na bitmapy}


if TT_Set_Instance_Resolutions(instance, 96{horiz}, 96{vert}) <> TT_Err_OK then
   begin
   ttf_unit_error:=TTF_err_Set_Instance_Resolutions_failed;
   Dispose(bf,Done);
   Exit(nil);
   end;

if TT_Set_Instance_CharSizes(instance,velikost * 64,velikost * 64) <> TT_Err_OK then
   begin
   ttf_unit_error:=TTF_err_Set_Instance_CharSizes_failed;
   Dispose(bf,Done);
   Exit(nil);
   end;


if Pretvor_do_bitmapove_sady_krok_2(instance,bf,maxnad,maxpod)=false then
   begin
   Dispose(bf,Done);
   Exit(nil);
   end;

bf^.vel:=velikost;
bf^.rez:=rez;
bf^.so:=-maxnad;   {ze zaporne hodnoty udelam kladnou}
bf^.su:=maxpod;
bf^.sosu:=bf^.so+bf^.su;

TT_Done_Instance(instance);
Pretvor_do_bitmapove_sady:=bf;
End;



Function TTTF_kontejner.Pretvor_do_bitmapove_sady_krok_2(instance: TT_Instance;bf:PTTFZnaky;var maxnad,maxpod:longint):boolean;
var
  x, y: longint;
  glyph: TT_Glyph;
  col: dword;
  metrics: TT_Glyph_Metrics;
  Bit: TT_Raster_Map;
  ft_charnum: dword;
  curchar: dword;
  i,j,t,n,m,oo,dd: longint;
  b: byte;
  z:PZnak;
  dpp:^byte;
  bitbuffer:array[0..$7FFF] of byte;
  pracbuf:array[0..4095] of byte;
  zpr:pointer;

begin
maxnad:=maxlongint div 2;
maxpod:=-maxnad;

if TT_New_Glyph(face, glyph) <> TT_Err_Ok then
   begin
   ttf_unit_error:=TTF_err_New_Glyph_failed;
   Exit(false);
   end;

bf^.first:=-1;
Bit.buffer:=@bitbuffer;

for i:=0 to $ffff do
    begin
    ft_charnum:= TT_Char_Index(charmap,i);
    if ft_charnum = 0 then continue;
    if TT_Load_Glyph(instance, glyph, ft_charnum, TT_Load_Scale_Glyph or TT_Load_Hint_Glyph ) <> TT_Err_Ok
       then begin
       ttf_unit_error:=TTF_err_Load_Glyph_failed;
       Continue;
       end;

    if TT_Get_Glyph_Metrics(glyph, metrics) <> TT_Err_Ok then
       begin
       ttf_unit_error:=TTF_err_Get_Glyph_Metrics_failed;
       Continue;
       end;

    {Uvnitr FreeType uz by melo byt vse pripravene na export znaky}

    bit.width := (metrics.bbox.xMax - metrics.bbox.xMin) div 64 + 3;
    bit.rows := (metrics.bbox.yMax - metrics.bbox.yMin) div 64 + 1;
    bit.flow := TT_Flow_Down;

    if ttf_konverze_pres_bitmapu_ci_pixmapu=0
       then bit.cols := (bit.width + 7) div 8
       else bit.cols := bit.width;

    bit.size := bit.cols * bit.rows;
    fillchar(Bit.buffer^, Bit.size, 0);

    if ttf_konverze_pres_bitmapu_ci_pixmapu=0
       then TT_Get_Glyph_Bitmap(glyph, Bit,-metrics.bbox.xmin,-metrics.bbox.ymin)
       else TT_Get_Glyph_Pixmap(glyph, Bit,-metrics.bbox.xmin,-metrics.bbox.ymin);

    if bf^.first=-1 then bf^.first:=i;
    bf^.last:=i;
    inc(bf^.pocetzn);
    z:=New(PZnak,Init);  {inicializace dat. struktury znaku}

    z^.sirka:=bit.width;
    z^.vyska:=bit.rows;
    z^.relx:=(metrics.bearingX + 63) div 64;

    {if i=65 then
       begin
       writeln('rors: ',bit.rows);
       writeln('bearingY div 64: ',metrics.bearingY div 64);
       writeln('(bearingY+63) div 64: ',((metrics.bearingY + 63) div 64));
       readln;
       end;}

    {z^.rely:=-((metrics.bearingY + 63) div 64)-1;}
    z^.rely:=((0 - bit.rows) - (round(metrics.bearingY / 64) - bit.rows))-1;
    z^.shift:=(metrics.advance + 63) div 64;
    z^.ready:=2;

    if z^.rely<maxnad then maxnad:=z^.rely;

    j:=z^.rely+z^.vyska;
    if j>0 then
       if j>maxpod then maxpod:=j;

    if z^.sirka*z^.vyska>0 then
          begin
          z^.dp:=z^.sirka*z^.vyska;
          GetMem(z^.data,z^.dp);
          dpp:=z^.data;

          if ttf_konverze_pres_bitmapu_ci_pixmapu=0
             then begin
             n:=bit.cols;      {v kolika bajtech je radek?}
             for oo:=0 to bit.rows-1 do
                 begin
                 zpr:=@pracbuf;
                 for m:=0 to n-1 do
                     begin
                     ZnakBuf_Expand(bitbuffer[oo*n+m],zpr);
                     inc(zpr,8);
                     end;
                 Move(pracbuf,dpp^,bit.width);
                 inc(dpp,bit.width);
                 end;
             end
             else begin
             for y:=0 to bit.rows-1 do
                 for x:=0 to bit.cols-1 do
                     begin
                     b:=byte((pointer(bit.buffer) + y * bit.width + x)^);
                     if b<ttf_konverze_pres_pixmapu_prahova_hodnota
                        then dpp^:=0
                        else dpp^:=1;
                     inc(dpp);
                     end;
             end;
          z^.Komprimuj;
          end;
    bf^.VclenZnak(z,i);
    end;

TT_Done_Glyph(glyph);
Pretvor_do_bitmapove_sady_krok_2:=true;
end;



Procedure TTTF_Kontejner.RegisterBitmapExport(fnt:PObecnyFont;size:longint);
begin
inc(BitmapExportNum);
BitmapExport[BitmapExportNum].ptr:=fnt;
BitmapExport[BitmapExportNum].size:=size;
end;


Procedure TTTF_Kontejner.RemoveExportedBitmapRecord(size:longint);
var a,b:longint;
begin
for a:=1 to BitmapExportNum do
    if BitmapExport[a].size=size then
       begin
       for b:=a to BitmapExportNum do
           BitmapExport[b]:=BitmapExport[b+1];

       dec(BitmapExportNum);
       end;
end;


Function TTTF_Kontejner.FindExportedBitmap(size:longint):pointer;
var a:byte;
begin
for a:=1 to TTF_MAX_BITMAP_EXPORT do
    if BitmapExport[a].size=size then Exit(BitmapExport[a].ptr);
FindExportedBitmap:=nil;
end;


Procedure TTTF_Kontejner.RemoveFont;
BEGIN
  IF TTFloaded then
    begin
      TT_Close_Face(face);
      TTFloaded:=false;
      {fontdatasize:=0;}
    end;
END;


Destructor TTTF_kontejner.Done;
begin
RemoveFont;
end;



Function TTF_Font_LoadFont(s:string;size:longint):pointer;
{Provede prvonacteni a dekodovani vektorove casti a pote zavola
 TTF_Font_SetParams, ktery vektorovou cast predela na bitmapovou sadu}

var a:byte;
    TTF:PTTF_kontejner;
    hf,nhf:PObecnyFont;
    pf:PTTFZnaky;

begin

if is_ttf_engine_loaded=false then
   if TT_Init_FreeType <> TT_Err_Ok
      then begin TTF_unit_error:=TTF_err_Init_FreeType_failed;Exit(nil);end
      else is_ttf_engine_loaded:=true;

New(TTF);
TTF:=New(PTTF_kontejner,Init);
TTF^.LoadFont(s);
if TTF^.TTFloaded=false then
   begin
   TTF^.RemoveFont;
   Dispose(TTF);
   {Tady by bylo dobre zkontrolovat, aby se nenechaly opustene alokovane bloky
    uvnitr FreeType}
   Exit(nil);
   end;

hf:=New(PObecnyFont,Init);
hf^.odkaz_na_kontejner:=TTF;

nhf:=pointer(TTF_Font_SetStyle(hf,1,size,0));

Dispose(hf,Done);

TTF_Font_LoadFont:=nhf;
end;


Function TTF_Font_PrepChar(fnt:pointer;znak:word):pointer;
var hf:PObecnyFont;
    pf:PTTFZnaky;

begin
hf:=fnt;
pf:=pointer(hf^.fdata);
if pf=nil
   then TTF_Font_PrepChar:=nil
   else TTF_Font_PrepChar:=pf^.PrepChar(znak);
end;



Function TTF_Font_SetStyle(fnt:pointer;podfunkce,param1,param2:longint):pointer;
var hf,nhf:PObecnyFont;
    {pf:PFontVGA;}
    TTF:PTTF_Kontejner;
    pf:PTTFznaky;
    s2,sv:string;
    n,nn,m:byte;
    italic:boolean;


begin
if podfunkce=2 then
   if (param1 and prop_fn)<>0
      then VNMFN_PROP_MODE:=true
      else VNMFN_PROP_MODE:=false;

if podfunkce<>1 then Exit(nil);

{Dale budeme resit pouze podfunkci 1}

hf:=fnt;
TTF:=hf^.odkaz_na_kontejner;

pf:=TTF^.Pretvor_do_bitmapove_sady(param1 {velikost});
{Tato funkce z vektorovych dat vytvorila bitmapova data}

nhf:=New(PObecnyFont,Init);
nhf^.odkaz_na_kontejner:=TTF;
TTF^.RegisterBitmapExport(nhf,param1 {velikost});
nhf^.fdata:=pf;
nhf^.typzdroje:=4;   {vektorovy zdroj}
pf^.rukojet:=nhf;

TTF_Font_SetStyle:=nhf;
end;



Function UTF82longint(s:pchar;delka,poz:longint;var posun:byte):longint;assembler;
asm
dec poz
mov edi,posun
mov esi,s
add esi,poz

movzx eax,byte [esi]
cmp al,128
jae @vetsi_nebo_rovno128
    {jednobajtovy}
    mov bl,1
    mov [edi],bl   {posun:=1}
    movzx eax,al
    jmp @konec
@vetsi_nebo_rovno128:

cmp al,240
jae @vetsi_nebo_rovno240

cmp al,224
jae @vetsi_nebo_rovno224
    {dvojbajtovy}
    mov bl,2
    mov [edi],bl
    mov ecx,poz
    inc ecx
    cmp ecx,delka
    jbe @neni_vetsi_nez_delka
    mov eax,63       {UTF82word:=63 (znak ?) - ochrana pred nekorektnimi daty}
    jmp @konec
@neni_vetsi_nez_delka:
    and eax,63
    shl eax,6
    inc esi
    mov bl,[esi]
    and bl,63
    add al,bl
    jmp @konec

@vetsi_nebo_rovno224:
    {trojbajtovy}
    mov bl,3
    mov [edi],bl
    mov ecx,poz
    add ecx,2
    cmp ecx,delka
    jbe @neni_vetsi_nez_delka2
    mov eax,21       {UTF82word:=21 (znak ) - ochrana pred nekorektnimi daty}
    jmp @konec
@neni_vetsi_nez_delka2:
    and eax,15
    shl eax,12
    inc esi
    movzx ebx,byte [esi]
    and ebx,63
    shl ebx,6
    add eax,ebx
    inc esi
    mov bl,[esi]
    and bl,63
    add al,bl
    jmp @konec

@vetsi_nebo_rovno240:
    {ctyrbajtovy}
    mov bl,4
    mov [edi],bl
    mov ecx,poz
    add ecx,3
    cmp ecx,delka
    jbe @neni_vetsi_nez_delka3
    mov eax,126       {UTF82word:=126 (znak ~) - ochrana pred nekorektnimi daty}
    jmp @konec
@neni_vetsi_nez_delka3:
    and eax,7
    shl eax,18
    inc esi
    movzx ebx,byte [esi]
    and ebx,63
    shl ebx,12
    add eax,ebx
    inc esi
    movzx ebx,byte [esi]
    and ebx,63
    shl ebx,6
    add eax,ebx
    inc esi
    movzx ebx,byte [esi]
    and ebx,63
    add eax,ebx

@konec:
end;




Procedure TTF_font_OutText(kam:pointer;x,y:longint;s:string;fnt:pointer;color:word);
{Pracujeme s Unicode fontem. Vstupni retezec ocekava v kodovani UTF-8}
var i,ds,e,ox:longint;
    p:pchar;
    c:char;
    ii:byte;
    cr:boolean;
    virt:PVirtualWindow;
    hf:PObecnyFont;
    pf:PTTFznaky;
    z:PZnak;

begin
ds:=Length(s);
s:=s+#0;
p:=@s[1];
ox:=x;
cr:=false;
virt:=kam;
hf:=fnt;
pf:=PTTFZnaky(hf^.fdata);


i:=1;
while i<=ds do
   begin
   e:=UTF82longint(p,ds,i,ii);
   inc(i,ii);
   if e=13 then
      begin
      x:=ox;
      inc(y,pf^.sosu);
      cr:=true;
      end
      else
   if (e=10) and (cr=true) then cr:=false
      else
      begin
      z:=TTF_Font_PrepChar(fnt,e);
      if z<>nil then
         begin
         PutChar_FN(virt^,
                    z^.data,
                    x+z^.relX,
                    y+z^.relY,
                    z^.sirka,
                    z^.vyska,
                    z^.dp,
                    color);
         inc(x,z^.shift);
         end;
      cr:=false;
      end;
   end;
end;


Function TTF_Font_GetInfo(fnt:pointer;param1,param2:longint):longint;
var hf,hfc:PObecnyFont;
    TTF:PTTF_Kontejner;
    i:longint;
    s:string;

begin
hf:=fnt;

if param1=102 then   {funkce Dej odkaz na font s oznacenim Param2}
   begin
   TTF:=hf^.odkaz_na_kontejner;
   hfc:=TTF^.FindExportedBitmap(byte(param2));
   Exit(longint(hfc));
   end;


if param1=3 then     {vygeneruj retezec, ktery obsahuje vsechny dostupne}
   begin             {velikosti fontu}
   s:='-1'; {bavime se o vektorovem fontu, tak vratime treba toto}
   Move(s,pointer(param2)^,Length(s)+1);
   Exit(-1);
   end;


i:=hf^.GetInfo(param1,param2);
TTF_Font_GetInfo:=i;
end;


Function TTF_Font_Delete(fnt:pointer;mode:byte):boolean;
var hf,hf2:PObecnyFont;
    pf:PTTFZnaky;
    TTF:PTTF_Kontejner;
    a,vel:longint;

begin

hf:=fnt;
TTF:=hf^.odkaz_na_kontejner;
pf:=PTTFZnaky(hf^.fdata);
if pf=nil then Exit(true);
vel:=pf^.vel;

if mode=0
   then begin
   TTF^.RemoveExportedBitmapRecord(vel); {smazeme zaznam o export. bitmape}
   Dispose(hf,Done)    {i samotnou bitmapu, se vsim vsudy}
   end
   else begin {mode 1}
   for a:=1 to TTF^.BitmapExportNum do
       begin
       hf2:=TTF^.BitmapExport[a].ptr;
       Dispose(hf2,Done);
       end;
   Dispose(TTF,Done);       {smaze vektorova data}
   end;

TTF_Font_Delete:=true;
end;




begin
RegisterFontEngine('TTF',@TTF_Font_LoadFont,
                         @TTF_Font_PrepChar,
                         @TTF_Font_OutText,
                         @TTF_Font_SetStyle,
                         @TTF_Font_GetInfo,
                         @TTF_Font_Delete);
end.
