unit vnm_fon;

{****************************************************************************}
{Unit VNM_FON - it is a addon unit for graphics library VenomGFX.            }
{It brings a loader for fonts in Microsoft FON format.                       }
{FON format is technicaly collection of FNT fonts stored in the same         }
{way as resources in NE executables from 16-bit windows versions             }
{****************************************************************************}

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

function FON_container_extraction(var s,kam:string):longint;

type TFON_container_extraction_report = procedure(var s:string);
var FON_container_extraction_report:TFON_container_extraction_report;

implementation
uses Objects,GrpFile,GrpUtil,VenomGFX,VenomMng,VnmFnHlp,VNM_FNT;

const
    MAX_FON_ZAZN = 40;

type
     PFontFON = ^TFontFON;
     TFontFON = object
     {mapa:PfonMapa;}
     zaznamu:byte;
     pozice:array[1..MAX_FON_ZAZN] of longint;
     velikost:array[1..MAX_FON_ZAZN] of longint;
     vels:array[1..MAX_FON_ZAZN] of longint;
     odkaz:array[1..MAX_FON_ZAZN] of pointer;
     rez:string[24];   {nazev bez cesty}
     zdroj:string;     {nazev s cestou nebo bez cesty}
     Constructor Init;
     Function PocetSad:byte;
     {Function Analyza_FON_hack:byte;}
     Function Analyza_FON:byte;
     Function Vrat_Retezec_s_velikostmi:string;
     Function Nejblizsi_k_oznaceni(hodnota:longint):longint;
     Function Index_podle_oznaceni(i:longint):byte;
     Destructor Done;virtual;
     end;


Function MyStr(i:longint):string;
var s:string;
begin
Str(i,s);
MyStr:=s;
end;

(*
Function String_Up(s:string):string;
var a:byte;
begin
for a:=1 to Length(s) do s[a]:=UpCase(s[a]);
String_Up:=s;
end;


Function Buffer_Prohledej(adresa:pointer;data_length:longint;co:string;velpism:boolean):longint;
{pokud nenajde, tak vraci -1}
var a,cl:longint;
    p:pchar;
    ps:string;
begin
p:=adresa;
if velpism=false then co:=String_Up(co);
cl:=Length(co);
ps[0]:=co[0];
for a:=0 to data_length-cl do
    begin
    Move(p[a],ps[1],cl);
    if velpism=false then ps:=String_Up(ps);
    if ps=co then begin Buffer_Prohledej:=a;Exit;end;
    end;
Buffer_Prohledej:=-1;
end;


Function Buffer_Za_Konec_Retezce(buffer:pointer;ukazatel:longint):longint;
{Predpoklada, ze adresa miri na pascalovsky ShortString (na nulty bajt, t.j.
 na specifikator delky).
 Vraci ukazatel za timto retezcem.
 V pripade, ze inicialne ukazuje na #0, tak popoleze o jeden bajt
 }
var p:pchar;
    b:byte;
begin
p:=buffer;
b:=byte(p[ukazatel]);
Buffer_Za_Konec_Retezce:=ukazatel+b+1;
end;


Function Align_Up(i,a:longint):longint;
begin
Align_Up:=(i+a-1) div a*a;
end;


Function Align_Down(i,a:longint):longint;
begin
Align_Down:=i div a*a;
end;*)


Constructor TFontFON.Init;
var i:byte;
begin
rez:='';
zdroj:='';
zaznamu:=0;
for i:=1 to MAX_FON_ZAZN do
    begin
    odkaz[i]:=nil;
    pozice[i]:=0;
    end;
end;


Function TFontFON.Vrat_Retezec_s_velikostmi:string;
var a:byte;
    s,t:string;
begin
if zaznamu=0 then Exit('');
s:='';
for a:=1 to zaznamu do
    begin
    Str(velikost[a],t);
    s:=s+t+',';
    end;
dec(byte(s[0]));
Vrat_Retezec_s_velikostmi:=s;
end;


(*Function TFontFON.Analyza_FON_hack:byte;
var grp:TGrpStream;
    buf,buf_f:pchar;
    alig:longint;
    res_id:longint;
    ne:^longint;
    wo:^word;
    a,i,bv,f,ff,kt:longint;
    predbezne_zaznamu:longint;

begin
if zdroj='' then Exit(1);
{nejsme napojeni na zdrojovy soubor?}
grp.Init(zdroj,grpOpenRead);
if grp.status<>grpOK then begin Grp.Done;Exit(2);end;
{chyba pri itevirani souboru?}

bv:=grp.GetSize;
if bv<300 then Exit(3);
{soubor je podezrele maly?}

GetMem(buf,bv);
grp.Read(buf^,bv);
grp.Done;

if (buf[0]<>'M') or (buf[1]<>'Z') then begin FreeMem(buf);Exit(4);end;
{chybi navesti MZ?}

ne:=@buf[$3c];
if (buf[ne^+0]<>'N') or (buf[ne^+1]<>'E') then begin FreeMem(buf);Exit(5);end;
{chybi navesti NE?}

predbezne_zaznamu:=0;
zaznamu:=0;

f:=Buffer_Prohledej(buf,bv,#7'FONTDIR',true);
if f=-1 then begin FreeMem(buf);Exit(6);end;
{chybi zdroj FONTDIR?}

for a:=1 to 11 do
    begin
    ff:=Buffer_Za_Konec_Retezce(buf,f);
    f:=ff;
    end;
f:=Align_Up(f,16);

wo:=@buf[f];
if (wo^=0) or (wo^>30) then begin FreeMem(buf);Exit(6);end;
predbezne_zaznamu:=wo^;

buf_f:=@buf[f+4];

for i:=1 to predbezne_zaznamu do
    begin
    ff:=Buffer_Prohledej(buf_f,bv,'(c)',false)+1;
    inc(buf_f,ff);

    ff:=Buffer_Prohledej(buf_f,bv,#0,true)+1;
    inc(buf_f,ff);
    end;
{jsem za prehledem vsech vlozenych FNT fontu}

{A ted budu prohlizet vnitrky tech fontu a spoleham na to, ze kazdy popisek
 ma prave jeden copyright}
for i:=1 to predbezne_zaznamu do
    begin
    ff:=Buffer_Prohledej(buf_f,bv,'(c)',false)+1; {spolehame na to, ze v komentari fontu se vyskytne znak copyrightu}
    f:=0;
    for a:=1 to 30 do  {a nekde pred copyrightem by mela byt sekvence uvodu FNT fontu}
        begin
        if (buf_f[ff-a]=#0) and (buf_f[ff-a+1]=#2) and    {verze $200?}
           (buf_f[ff-a+4]=#0) and (buf_f[ff-a+5]=#0) and
           (buf_f[ff-a+66]=#0)           {rastrovy?}
           then begin f:=ff-a;Break;end;
        end;

    if f<>0 then
       begin
       inc(zaznamu);
       kt:=f+longint(buf_f)-longint(buf);
       pozice[zaznamu]:=kt;
       wo:=@buf_f[f+88];
       velikost[zaznamu]:=wo^;
       ne:=@buf_f[f+2];
       vels[zaznamu]:=ne^;
       end;

    inc(buf_f,ff);
    ff:=Buffer_Prohledej(buf_f,bv,#0,true)+1;
    inc(buf_f,ff);
    end;
FreeMem(buf);
if zaznamu=0 then Analyza_FON_hack:=7 else Analyza_FON_hack:=0;
end;*)


Function TFontFON.Analyza_FON:byte;
var grp:TGrpStream;
    buf:pchar;
    nn:^longint;
    ne,res:longint;
    ww,w2:^word;
    wo:word;
    a,i,bv,f,ff,vv,kt,st:longint;
    align,res_id:longint;

begin
if zdroj='' then Exit(1);
{nejsme napojeni na zdrojovy soubor?}
grp.Init(zdroj,grpOpenRead);
if grp.status<>grpOK then begin Grp.Done;Exit(2);end;
{chyba pri itevirani souboru?}

bv:=grp.GetSize;
if bv<300 then Exit(3);
{soubor je podezrele maly?}

GetMem(buf,bv);
grp.Read(buf^,bv);
grp.Done;

if (buf[0]<>'M') or (buf[1]<>'Z') then begin FreeMem(buf);Exit(4);end;
{chybi navesti MZ?}

nn:=@buf[$3c];
ne:=nn^;
if (buf[ne+0]<>'N') or (buf[ne+1]<>'E') then begin FreeMem(buf);Exit(5);end;
{chybi navesti NE?}

ww:=@buf[ne+36];         {pozice sekce RESOURCES}
wo:=ww^;
res:=ne+wo;              {Ta nezapocitava velikost DOS pahylu. Nutno pricist}

ww:=@buf[res+0];         {Najedeme na zacatek sekce resources}
align:=ww^;              {prvni 2 bajty je ALIGN...}

a:=2;                    {A dal nasleduji zaznamy resources}
repeat
ww:=@buf[res+a+0];       {typ zdroje?}
res_id:=ww^;
ww:=@buf[res+a+2];       {a kolik polozek tohoto typu mame?}
f:=ww^;

if res_id=$8008 then  {zdroj FONT}
   begin
   for i:=0 to f-1 do
       begin
       ww:=@buf[res+a+8+i*12];
       bv:=ww^;
       st:=bv shl align;
       nn:=@buf[st+2];
       vv:=nn^;

       inc(zaznamu);
       pozice[zaznamu]:=st;
       w2:=@buf[st+88];
       velikost[zaznamu]:=w2^;
       vels[zaznamu]:=vv;

       {writeln('poz: ',pozice[zaznamu],'  vel: ',velikost[zaznamu],'  vels: ',vels[zaznamu]);}
       end;
   end;

inc(a,8+f*12);     {skocime na dalsi typ resources}
until res_id=0;    {typ je 0? Tak koncime}

FreeMem(buf);
if zaznamu=0 then Analyza_FON:=5 else Analyza_FON:=0;
end;



Function TFontFON.Nejblizsi_k_oznaceni(hodnota:longint):longint;
{vrati index zaznamu s veliosti, ktera je nejblize k pozadovane}
var a,b,d,i:longint;
begin
if zaznamu=0 then Exit(0);
if zaznamu=1 then Exit(1);
i:=maxlongint div 2;
b:=0;
for a:=1 to zaznamu do
    begin
    if velikost[a]=hodnota then Exit(a);
    d:=abs(hodnota-velikost[a]);
    if d<i then b:=a;
    end;
Nejblizsi_k_oznaceni:=b;
end;


Function TFontFON.Index_podle_oznaceni(i:longint):byte;
var a:longint;
begin
for a:=1 to zaznamu do
    if velikost[a]=i then Exit(a);
Index_podle_oznaceni:=0;
end;


Function TFontFON.PocetSad:byte;
begin
PocetSad:=zaznamu;
end;


Destructor TFontFON.Done;
begin
{dummy}
end;


Function FON_font_setstyle(fnt:pointer;podfunkce,param1,param2:longint):pointer;
var hf,nhf:PObecnyFont;
    pw:PFontFON;
    pf:PFontFNT;
    s2:string;
    l,okindex,okvelikost,okpozice,okvels:longint;

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);

{Podfunkce 1:  PARAM1 zde znaci velikost}

hf:=fnt;
pw:=hf^.odkaz_na_kontejner;
if pw=nil then Exit(nil);

s2:=pw^.zdroj;
okindex:=pw^.Nejblizsi_k_oznaceni(param1);
okvelikost:=pw^.velikost[okindex];
okpozice:=pw^.pozice[okindex];
okvels:=pw^.vels[okindex];

nhf:=Load_FNT_font_z_FON(s2,okpozice,okvels); {Nacte do PObecnyFont/PFontFNT}
{jsou vyplnene FDATA=... a TYPZDROJE=2}

nhf^.typzdroje:=3;     {opravime, protoze jsem z bitmapoveho kontejneru}
nhf^.typ_kontejneru_detail:=2; {FON}
nhf^.odkaz_na_kontejner:=pw;   {vazba na zastresujici strukturu FON}
pf:=PFontFNT(nhf^.fdata);
pw^.odkaz[okindex]:=nhf;
pf^.rukojet:=nhf;
FON_font_setstyle:=nhf;
end;



Function Load_FON_font(s:string;size:longint):pointer;
var a,b,e:byte;
    grp:TGrpStream;
    s2,n:string;

    temphf:PObecnyFont;

    temppf:PFontFNT;
    pw:PFontFON;
    p:pointer;

begin
for a:=1 to Length(s) do s[a]:=UpCase(s[a]);
s2:=DoplnJmenoFontu(s);
grp.Init(s2,grpOpenRead);
if grp.status<>grpOK then begin Grp.Done;Exit(nil);end;
grp.Done;


{Zde vime, ze FON soubor existuje}
pw:=New(PFontFON,Init);    {inicializace "skorapky"}
pw^.zdroj:=s2;
pw^.rez:=NazevBezCesty(s);
e:=pw^.Analyza_FON;    {mimo jine vyplni promennou <zaznamu>}

if e<>0 then  {Analyza_FON zjistila nejakou chybu?}
   begin
   Dispose(pw,Done);
   Exit(nil);
   end;

temphf:=New(PObecnyFont,Init);          {inicializuji pahyl fontu...}
temphf^.odkaz_na_kontejner:=pw;         {...ktery napojim na nasi skorapku}
{nicmene, neobtezuju se s napojovanim na zadne PFontFNT}


p:=FON_font_setstyle(temphf,1,size,0);
{pomoci pahylu se propojime s Mapou a nahrajeme pozadovanou velikost}
Dispose(temphf,Done);                   {a tento pahyl nyni smazu}
Load_FON_font:=p;
end;


Function FON_Font_PrepChar(fnt:pointer;znak:word):pointer;
var hf:PObecnyFont;
begin
hf:=fnt;
FON_Font_PrepChar:=hf^.fdata^.PrepChar(znak);
end;



Procedure FON_font_OutText(kam:pointer;x,y:longint;s:string;fnt:pointer;color:word);
var hf:PObecnyFont;
    pf:PFontFNT;

begin
if fnt<>nil then
   begin
   hf:=fnt;
   pf:=PFontFNT(hf^.fdata);
   VnmFnHlp_OutText(kam,x,y,s,pf,color);
   end;
end;



Function FON_Font_GetInfo(fnt:pointer;param1,param2:longint):longint;
var hf,hf2:PObecnyFont;
    pw:PFontFON;
    i,j:longint;
    s:string;

begin
hf:=fnt;

if param1=101 then   {funkce Dej nejblizsi velikost k Param2}
   begin
   pw:=hf^.odkaz_na_kontejner;
   i:=pw^.Nejblizsi_k_oznaceni(byte(param2));
   j:=pw^.velikost[i];
   Exit(j);
   end;

if param1=102 then   {funkce Dej odkaz na font s oznacenim Param2}
   begin
   pw:=hf^.odkaz_na_kontejner;
   i:=pw^.Index_podle_oznaceni(byte(param2));
   hf2:=pw^.odkaz[i];
   Exit(longint(hf2));
   end;

if param1=3 then     {vygeneruj retezec, ktery obsahuje vsechny dostupne}
   begin             {velikosti fontu}
   pw:=hf^.odkaz_na_kontejner;
   s:=pw^.Vrat_retezec_s_velikostmi;
   Move(s,pointer(param2)^,Length(s)+1);
   Exit(-1);
   end;

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




Function FON_Font_delete(fnt:pointer;mode:byte):boolean;
var hf:PObecnyFont;
    pf:PFontFON;
begin
hf:=fnt;
if mode=0
   then Dispose(hf,Done)    {Smaze i hf^.FData  (typu PFontFV), ale nikoliv kontejner}
   else begin {mode 1}
   pf:=hf^.odkaz_na_kontejner;
   Dispose(pf,Done);        {smaze mapu...}
   hf^.odkaz_na_kontejner:=nil;
   Dispose(hf,Done);        {...i vlastni data}
   end;
FON_Font_delete:=true;
end;



Function FON_container_extraction(var s,kam:string):longint;
var h:PObecnyFont;
    pw:PFontFON;
     i:longint;
     b:pointer;
    gr:TGRPstream;
    bf:TBufStream;
    s5:string;
    ss:string;

begin

h:=Load_FON_font(s,16);
if h=nil then Exit(1);

pw:=h^.odkaz_na_kontejner;

gr.Init(s,grpOpenRead);
s5:=Copy(pw^.rez,1,5);
for i:=1 to pw^.zaznamu do
    begin
    GetMem(b,pw^.vels[i]);
    gr.Seek(pw^.pozice[i]);
    gr.ReadStream(b^,pw^.vels[i]);

    ss:={kam+}s5+MyStr(pw^.velikost[i])+'.FNT';

    if FON_container_extraction_report<>nil
       then FON_container_extraction_report(ss);

    bf.Init(kam+ss,stCreate,pw^.vels[i]);
    bf.Write(b^,pw^.vels[i]);
    bf.Done;

    FreeMem(b);
    end;

gr.Done;

FON_Font_delete(h,1);
FON_container_extraction:=0;
end;


Procedure Register_FON_Loader;
begin
RegisterFontEngine('FON',
                   @Load_FON_font,
                   @FON_Font_PrepChar,
                   @FON_Font_OutText,
                   @FON_Font_setstyle,
                   @FON_Font_GetInfo,
                   @FON_Font_delete);

end;




begin
FON_container_extraction_report:=nil;
Register_FON_Loader;
end.
