unit fontautl;
{$IFDEF VER2}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF VER3}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF NEWFPC}{$CALLING OLDFPCCALL}{$ENDIF}
{$I-}
interface
uses {Fnfont3,}VnmFnHlp,Vnm_FU,Vnm_FV;


type
PExtFontFU = ^TExtFontFU;

TExtFontFU = object(TFontFU)
popisek1:string[255];
popisek2:string[255];
defzns:byte;    {defaultni sirka novotvorenych znaku}

Constructor Init;
Function ZalozNovyZnak(z:longint):PZnak;
Function DeleteChar(z:longint;vcetnebitmapy:boolean):byte;
Function DeleteChar(z:longint):byte;
Procedure ZjistiBoundingBox(var maxsir,maxvys,minxpoz,minypoz:longint);
Procedure VynulujBitmapuZnaku(z:longint);
Procedure Nakopiruj_data_fontu_odjinud(f:PBitmapovyFont);
Procedure Proved_Import_z_PFontFU(fu:PFontFU;odstran_z_fu:boolean);
Function SaveFont_FU(s:string):byte;
Function SaveFont_FN(s:string):byte;
Function SaveFont_FNT(s:string;var p1,p2:string):byte;
Function SaveFont_FNT_GRX(s:string;var p1,p2:string):byte;
Function SaveFont_V8F(var s,pop:string;optim1,optim2:boolean;var po:longint):byte;
Function SaveFont_BDF(s:string;var p1,p2,p3,p4,p5:string):byte;
Procedure SaveHeader_V8F(var f:file;var pop:string;cp:word);
Function Zda_lze_nahrat_do_VGA_test1:boolean;
Destructor Done;virtual;
end;

const kas_fu_dbg:byte = 0;

var prazdny_vga_znak:array[0..31] of byte;

Function Zkontroluj_Format_FU(s:string):boolean;
Function DetekujVelikostFontu(s:string;var typfontu:byte):longint;
Function VytvorKontejner_WFV_ci_WFN(s:string;fl:pointer;num:longint;zamena_temp_souboru:boolean):byte;
Function VytvorKontejner_CPI(s:string;cp_seznam,vel_seznam:pchar;subf:byte;fl:pointer):byte;

Function Zda_lze_nahrat_do_VGA_test2(f:PFontFV):boolean;

implementation
uses GrpFile,Vnm_V8FI,VenomGFX,FnFont3,Lacrt,dos;

type

TUnifont_header = packed record
   magic:array[1..4] of char;
   first:word;
   version:byte;
   {prapuvodni byly 0, ted zde ma byt 1}
   flags:byte;
   {0.bit: 0 = soubor neobsahuje popisek}
   {       1 = soubor obsahuje popisek}

   last:word;
   reserved1:byte;
   public_vel:byte;
   nahore:word;
   dole:word;
   end;


Tv8fblok16 = packed record
   typ:byte;
   vel:word;
   podtyp:byte;
   codepage:word;
   end;

Pv8fblok1 = ^Tv8fblok1;
Tv8fblok1 = packed record
   typ:byte;
   vel:word;
   first:word;
   count:word;
   width:word;
   height:word;
   end;


pFNTsave_header = ^tFNTsave_header;
tFNTsave_header = packed record
{00}  version:word;
{02}  size:longint;
{06}  popisek:packed array[0..59] of char;
{66}  typ:word;
{68}  points:word;
{70}  vertres:word;
{72}  horzres:word;
{74}  ascend:word;
{76}  intleading:word; {byte}
{78}  extleading:word; {byte}
{80}  is_italic:byte;
{81}  is_underline:byte;
{82}  is_strikeout:byte;
{83}  weight:word;
{85}  charset:byte;
{86}  pixwidth:word;
{88}  pixheight:word;
{90}  family:byte;
{91}  avgwidth:word;
{93}  maxwidth:word;
{95}  firstchar:byte;
{96}  lastchar:byte;
{97}  defaultchar:byte;
{98}  breakchar:byte;
{99}  widthbytes:word;
{101} device:longint;
{105} facestr:longint;
{109} bitspointer:longint;
{113} bitoffset:longint;
{117} reserved1:byte;
{Zbytek polozek je jenom pro format 300h, nikoliv 200h}
{To znamena, ze pro format 200h je to tak, ze na offsetu 118 zacina pole s CharInfo}
{118} flags:longint;
{122} a_space:word;
{124} b_space:word;
{126} c_space:word;
{128} colorpointer:longint;
{132} reserved2:packed array[0..15] of byte;
end;


pGRX_FNT_header = ^tGRX_FNT_header;
tGRX_FNT_header = packed record
{00}  magic:dword;
{04}  bmpsize:longint;             {character bitmap size}
{08}  width:word;                  {width (average for proportional)}
{10}  height:word;                 {font height}
{12}  minchar:word;                {lowest character code in font}
{14}  maxchar:word;                {highest character code in font}
{16}  isfixed:word;                {nonzero if fixed font}
{18}  reserved:word;               {???}
{20}  baseline:word;               {baseline from top of font}
{22}  undwidth:word;               {underline width (at bottom)}
{24}  fnname:packed array[0..15] of char; {font file name (w/o path)}
{40}  family:packed array[0..15] of char; {font family name}
{56}
end;



{Structures in the CPI file format}
type
PCPI_header = ^TCPI_header;
TCPI_header = packed record
{0}  id:byte;
{1}  id7:array[0..6] of char;
{8}  reserved:array[0..7] of char;
{16} pnum:word;
{18} ptyp:byte;
{19} fih_offset:longint;
{23}
end;


{FontInfoHeader = num_codepages = word}
PCodePageEntryHeader = ^TCodePageEntryHeader;
TCodePageEntryHeader = packed record
{0}  cpeh_size:word;
{2}  next_cpeh_offset:longint;
{6}  device_type:word;
{8}  device_name:array[0..7] of char;
{16} codepage:word;
{18} reserved:array[0..5] of char;
{24} cpih_offset:longint;
{28}
end;


PCodePageInfoHeader = ^TCodePageInfoHeader;
TCodePageInfoHeader = packed record
{0} version:word;
{2} num_fonts:word;
{4} size:word;
{6}
end;


PScreenFontHeader = ^TScreenFontHeader;
TScreenFontHeader = packed record
{0} height:byte;
{1} width:byte;
{2} yaspect:byte;
{3} xaspect:byte;
{4} num_chars:word;
{6}
end;


PFlist = ^TFlist;
TFList = array[0..50000] of string;


type TcharsetVGA = record
     vyska:byte;
     data:Array[0..255,1..32] of Byte;
     end;
     PcharsetVGA = ^TcharsetVGA;


const unimagic:pchar = 'öaö';
      fnmagic:pchar  = 'ëmÕonç ';
      fnmagic2:pchar = ' çnoÕmë';
      vf8magic:pchar = 'V8FONT'#13#10;


      MAGIC_GRP = 'KenSilverman';
      VELIKOSTZAHLAVI_GRP = 12+4;

      HexDigits:array[0..15] of char = '0123456789ABCDEF';

var gl_v8f_b1:Tv8fblok1;


function MyStr (Cislo: longint): string;
var
  Vysledek : string;
begin { MyStr }
  Str (Cislo, Vysledek);
  MyStr := Vysledek;
end;  { MyStr }


{$IFDEF NEWFPC}
Function PLength(p:pchar):longint;
begin
PLength:=Length(p);
end;
{$ELSE}
Function PLength(p:pchar):longint;assembler;
asm
xor eax,eax
mov esi,p
@znova:
cmp byte [esi],0
je @konec
inc esi
inc eax
jmp @znova
@konec:
end;
{$ENDIF}

Function PHmasis(p:pchar;z:char):longint;
var a,b:longint;
begin
b:=0;
for a:=0 to 10000 do
    if p[a]=z then inc(b) else
    if p[a]=#0 then Break;

PHmasis:=b;
end;


Function HexStr(l:longint):string;
var a,b:longint;
    c,d:byte;
    s:string[32];
    p:^string;

begin
p:=@s[32];
a:=32;
repeat
s[a]:=HexDigits[l and 15];
dec(a);
l:=l div 16;
until l=0;
b:=32-a;
case b of
  1:c:=1;
  3:c:=1;
  5:c:=3;
  6:c:=2;
  7:c:=1;
  else c:=0;
end; {case}
for d:=a downto a-c+1 do s[d]:='0';
dec(a,c);
inc(b,c);
s[a]:=char(b);
p:=@s[a];
HexStr:=p^;
end;


Function Zkontroluj_Format_FU(s:string):boolean;
var grp:TGrpStream;
    p:array[1..4] of byte;
    q:pchar;
begin
grp.Init(DoplnJmenoFontu(s),grpOpenRead);
if grp.GetSize<5 then
   begin
   grp.Done;
   Exit(false);
   end;
q:=@p;
grp.Read(p,4);
grp.Done;
Zkontroluj_Format_FU:=comparebyte(q^,unimagic^,4)=0;
end;



Constructor TExtFontFU.Init;
begin
inherited Init;
format:=FNFMT_FU+128;
popisek1:='';
popisek2:='';
defzns:=8;
end;



Function TExtFontFU.ZalozNovyZnak(z:longint):PZnak;
var b:byte;
    aamod,aadiv:longint;
    zs,zn:PZnak;

begin
{debug}{if kas_fu_dbg>0 then
   b:=b;}
aadiv:=z div 256;
aamod:=z mod 256;

b:=OdemkniBlok(aadiv);

zs:=ZBlok[aadiv]^[aamod];

if zs<>nil then
   begin
   dispose(zs,Done);           {Nejaky znak tu uz je? Tak ho zrusime...}
   ZBlok[aadiv]^[aamod]:=nil;
   end;

zn:=New(PZnak,Init);        {inicializace dat. struktury znaku}
ZBlok[aadiv]^[aamod]:=zn;   {a prirazeni fontu}
ZalozNovyZnak:=zn;
inc(pocetzn);
end;


Function TExtFontFU.DeleteChar(z:longint;vcetnebitmapy:boolean):byte;
{Pozor - resi pocet znaku, ale neresi first a last}
var zd,zm:longint;
    zz:PZnak;
begin
if (z>$FFFF) or (z<0) then Exit(1);
zd:=z div 256;
if ZBlok[zd]=nil then Exit(2)
   else begin
   zm:=z mod 256;
   zz:=ZBlok[zd]^[zm];
   if zz=nil then Exit(3);
   if vcetnebitmapy=false then zz^.data:=nil;
   {Ochrana bitmapy pred smazanim. Hodi se v rutinach, kde se odkaz na bitmapu
    preda jinemu znaku.}
   Dispose(zz,Done);
   ZBlok[zd]^[zm]:=nil;
   dec(pocetzn);
   DeleteChar:=0;
   end;
end;


Function TExtFontFU.DeleteChar(z:longint):byte;
begin
DeleteChar(z,true);
end;



Function TExtFontFU.SaveFont_FU(s:string):byte;
var t:file;
    u:Tunifont_header;
    a,b,k,wdp,wdpa,i,j:longint;
    r:packed record b:word;w:word;end;
    w:packed record flags_a_dp:word;sirka:byte;end;
      {vyznam slova flags_a_dp
       bity 13-0: DP (pocet bajtu definice znaku
       bit 14:    budou nastedovat 3 bajty rozsireneho info o rozmerech
                  (relX, relY, shift)
       bit 15:    bude nasledovat bajt korX_np (pozicovani bitmapy pro neproporc. mod)
       je-li nastaven zaroven 14. i 15. bit, pak je napred uveden bajt korX_np
       a az pote 3 bajty rozsireneho infa
      }
    w2:packed record korX_np:shortint;relx:shortint;rely:shortint;shift:byte;end;
    pw2:pchar;
    zzf:PZnak;
    pop:string;

begin
Assign(t,DoplnJmenoFontu(s));
Rewrite(t,1);
move(unimagic^,u.magic,4);
u.version:=2;

{popisek1:='VGA like Unicode font, height 16px';}

if popisek1<>'' then u.flags:=1 else u.flags:=0;
u.first:=first;
u.last:=last;
u.nahore:=so;
u.dole:=su;
u.public_vel:=vel;
BlockWrite(t,u,sizeof(Tunifont_header));


if popisek1<>'' then
   begin
   pop:=popisek1+#0;
   BlockWrite(t,pop[1],Length(pop));
   end;

b:=0;
pw2:=@w2;
for a:=first to last do
    begin
    zzf:=PrepChar(a);
    if IsChReadyZ(a,zzf)=false then inc(b)
       else begin
       if b<>0 then
          begin
          r.b:=0;  {tento znak je prazdny}
          r.w:=b;  {prazdnych znaku je tolik a tolik}
          BlockWrite(t,r,sizeof(r));
          b:=0;
          end;

       {writeln(a);readln;
       b:=b;}

       wdpa:=zzf^.dp and $3FFF;   {word s vycistenymi dvema nejvyznamnejsimi bity}
       w.flags_a_dp:=wdpa+1;      {pocet bajtu bitmapy zde inkrementuju}
       w.sirka:=zzf^.sirka;       {a pak v loaderu budu naopak dekrementovat}
       if zzf^.korX_np<>0
          then w.flags_a_dp:=w.flags_a_dp or $8000;  {nastavi 15.bit}
       if (zzf^.rely<>-so) or (zzf^.relx<>0) or (zzf^.shift<>zzf^.sirka+2)
          then w.flags_a_dp:=w.flags_a_dp or $4000;  {nastavi 14.bit}
       BlockWrite(t,w,{sizeof(w)}3); {ulozime priznaky+pocet bajtu bitmapy a sirku}

       wdp:=w.flags_a_dp shr 14;
       if wdp<>0 then
          begin
          w2.korX_np:=zzf^.korX_np;
          w2.relx:=zzf^.relx;
          w2.rely:=zzf^.rely;
          w2.shift:=zzf^.shift;
          if wdp=1 then i:=1 else i:=0;       {01b  - jen rozs. rozmery}
          if wdp=2 then j:=1 else             {10b  - jen korX_np}
             if wdp=1 then j:=3 else j:=4;    {11b  - korX_np i rozs. rozmery}
          BlockWrite(t,pw2[i],j);  {pw2 miri na @w2}
          end;
       BlockWrite(t,zzf^.data^,wdpa);
       end;
   end;

if b<>0 then
   begin
   r.b:=0;  {tento znak je prazdny}
   if b=65536 then r.w:=0 else r.w:=b; {prazdnych znaku je tolik a tolik}
      {pokud neni definovany ani jeden znak, tak je zde nula}
   BlockWrite(t,r,sizeof(r));
   end;
Close(t);
SaveFont_FU:=0;
end;


Procedure TextFontFU.Nakopiruj_data_fontu_odjinud(f:PBitmapovyFont);
begin
so:=f^.so;
su:=f^.su;
sosu:=so+su;
vel:=f^.vel;
add:=f^.add;
sbunky:=f^.sbunky;
unicode:=f^.unicode;
kodova_stranka:=f^.kodova_stranka;
{format:=f^.format;}
first:=f^.first;
last:=f^.last;
pocetzn:=f^.pocetzn;
vzdy_komplet_nahrany:=f^.vzdy_komplet_nahrany;
end;


Procedure TextFontFU.Proved_Import_z_PFontFU(fu:PFontFU;odstran_z_fu:boolean);
var a:longint;
begin
Nakopiruj_data_fontu_odjinud(fu);
for a:=0 to 255 do Zblok[a]:=fu^.Zblok[a];
if odstran_z_fu=true then
   begin
   for a:=0 to 255 do fu^.Zblok[a]:=nil;
   fu^.pocetzn:=0;
   end;
end;


Procedure TExtFontFU.VynulujBitmapuZnaku(z:longint);
var zzf:PZnak;
begin
if IsChReady(z) then
   begin
   zzf:=PrepChar(z);
   FillChar(zzf^.data,zzf^.dp,0);
   end;
end;


Function TExtFontFU.SaveFont_FN(s:string):byte;
var t:file;
    mgl:longint;
    aa,a3,a3b,a,b,k,l,bl,x,y,mbfn,zfirst,zlast,korX_fpoz:longint;
    firstkx,lastkx:longint;
    _l:^longint;
    _w:^word;
    _b:^byte;
    a4:word;
    j:byte;
    ddiv,dmod:byte;
    zzo,zzf,zzmez:PZnak;

    mbf:pbyte;

    pb:packed array[0..4097] of byte;
    pc:packed array[0..255] of longint;
    konczah:packed array[0..255] of byte;
    korX_tbl:packed array[0..255] of shortint;
    korXFin:packed array[0..4097] of byte;
    g:pbyte;
    ff:PExtFontFU;
    f:PExtFontFU;
    bylospec_korX,defblok:boolean;
    defpop:string;

begin
GetMem(mbf,$20000);
FillChar(korX_tbl,256,byte(-128));
korX_fpoz:=0;
firstkx:=-1;
lastkx:=-2;
a3b:=0;
bylospec_korX:=false;
mgl:=PLength(fnmagic);
move(fnmagic[0],pb[0],mgl);    {"magic" signatura}

{defpop:='<CP='+MyStr(kodova_stranka)+'>'+popisek1;}
defpop:=popisek1;

if last<0
   then begin zlast:=0;zfirst:=255;end
   else begin zlast:=last;zfirst:=first;end;

a:=Length(defpop);
move(defpop[1],pb[mgl],a);    {popisek}
inc(a,mgl);
pb[a+0]:=0;
pb[a+1]:=zfirst;
pb[a+2]:=zlast;
pb[a+3]:=byte(so);
pb[a+4]:=byte(su);
pb[a+5]:=byte(add);
pb[a+6]:=0;   {"Future" musi byt bohuzel 0, coz velmi komplikuje situaci}



aa:=a+7;
if zlast>=zfirst
   then begin
   a3:=aa+(zlast-zfirst+1)*7;
   {TODO - reseni tabulky korX_np}
   {t.j. tez uprava A3 a korX_fpoz}
   end
   else a3:=aa;
mbfn:=0;
f:=@self;

ff:=New(PExtFontFU,Init);

kas_fu_dbg:=1;

ff^.Nakopiruj_data_fontu_odjinud(f);

zzmez:=New(PZnak,Init);  {zastupny znak pro nedefinovane}

if IsChReadyZ(32,zzo) and (zzo^.hasbitmap=false)
{je definovana mezera a ta mezera je skutecne "prazdna"?}
   then zzo^.PrekopirujPolozky(zzmez,false)
           {v tom pripade ji povazuj za placeholder}

   else begin  {mezeru za placeholder pouzit nemuzeme...}
   zzmez^.ready:=2;
   zzmez^.shift:=so; {dejme nejakou alespon vzdalene primerenou hodnotu pro posun}
   zzmez^.rely:=-so; {a neco smysluplneho pro RelY}
   {ostatni muzeme nechat na nulach}
   end;

for b:=zfirst to zlast do
    if IsChReady(b) then
       begin
       zzo:=PrepChar(b);
       ff^.ZalozNovyZnak(b);
       zzf:=ff^.PrepChar(b);
       zzo^.PrekopirujPolozky(zzf,false);

       {if zzo^.HasBitmap then}  {pokud ma znak definovanou bitmapu}

       if zzo^.HasBitmapAndBitmapIsNotEmpty then  {optimalizace}
          begin
          GetMem(zzf^.data,zzf^.dp);    {pripravime prostor pro bitmapu}
          Move(zzo^.data^,zzf^.data^,zzo^.dp);

          zzf^.Dekomprimuj(false,false);
          ddiv:=zzf^.sirka div 8;
          dmod:=zzf^.sirka mod 8;

          pc[b]:=mbfn;
          g:=zzf^.data;

          if zzf^.korX_np<>-128 then
             begin
             korX_tbl[b]:=zzf^.korX_np;
             if firstkx=-1 then firstkx:=b;
             lastkx:=b;
             bylospec_korX:=true;
             end;

          for y:=1 to zzf^.vyska do
              begin
              for x:=0 to ddiv-1 do
                  begin
                  ZnakBuf_Shrink(g,8,j);
                  inc(g,8);
                  mbf[mbfn]:=j;
                  inc(mbfn);
                  end;
              if dmod<>0 then
                 begin
                 ZnakBuf_Shrink(g,dmod,j);
                 inc(g,dmod);
                 mbf[mbfn]:=j;
                 inc(mbfn);
                 end;
             end;
          end
          else                 {pokud nema definovanou bitmapu}
          begin
          zzf^.sirka:=0;
          pc[b]:=0;            {hodnota zde je irelevantni, ale lepe je}
          end;                 {vlozit nejake definovane cislo}
       end
       else begin              {nedefinovany znak v bloku of FIRST do LAST}
       ff^.ZalozNovyZnak(b);       {presto zalozime "prazdny" znak}
       zzf:=ff^.PrepChar(b);
       zzf^.ready:=2;               {zvalidnime pristup ke znaku (nadale je ale bitmapa=NIL)}
       {zzmez^.PrekopirujPolozky(zzf,false);}    {pouzijeme placeholder}
       {UPDATE: nebudeme pouzivat placeholder, loader si poradi}
       pc[b]:=0;
       end;

{TODO: pokud nebyla definovana mezera, tak ji doplnime?...}

if bylospec_korX=true then
   begin
   korXfin[0]:=firstkx;
   korXfin[1]:=lastkx;
   a:=2;
   for b:=firstkx to lastkx do
       begin
       korXfin[a]:=byte(korX_tbl[b]);
       inc(a);
       end;
   a3b:=a;
   end;


for b:=zfirst to zlast do
    begin
    zzf:=ff^.PrepChar(b);
    pb[aa+0]:=byte(zzf^.relx);
    pb[aa+1]:=byte(zzf^.rely);
    pb[aa+2]:=byte(zzf^.sirka);
    pb[aa+3]:=byte(zzf^.vyska);
    pb[aa+4]:=byte(zzf^.shift);
    a4:=a3+a3b+pc[b];
    pb[aa+5]:=Lo(a4);
    pb[aa+6]:=Hi(a4);
    inc(aa,7);
    end;


Assign(t,DoplnJmenoFontu(s));
Rewrite(t,1);

BlockWrite(t,pb[0],a3);

if bylospec_korX then
   BlockWrite(t,korXfin[0],a3b);  {pridatna tabulka korX_np}

BlockWrite(t,mbf[0],mbfn);  {pokud je MBFN 0, tak se sem neulozi nic}

{A ted ulozime extra datove bloky, ktere nejsou definovany v puvodni
 specifikaci FN formatu od D.menta. Jelikoz puvodni zahlavi nema zadny
 prostor, jak je ulozit v zahlavi na zacatku souboru, tak je ulozim na konec
 souboru}

b:=SizeOf(konczah)-mgl;
Move(fnmagic2[0],konczah[b],mgl);  {uplne na konec "zadni magic"}

_l:=@konczah[b-4];
_l^:=1+2+1+4;            {feature, cp, sbunky, odkaz na tab. s korX_np}
                         {b-4..b-1: pocet predchazejicich bajtu zahlavi}
j:=1 or 2;
if bylospec_korX then j:=j or 4;
konczah[b-5]:=j;                    {def. kodova stranka + sbunky + event. tabulka s korX_np}

_w:=@konczah[b-7];
a4:=kodova_stranka;    {at mame prevod word-word}
_w^:=a4;

konczah[b-8]:=sbunky;  {velikost bunky pro neproporc. mod}


_l:=@konczah[b-12];    {pozice tabulky pro neproporc. mod}
if bylospec_korX
   then _l^:=a3-mgl
   else _l^:=0;

BlockWrite(t,konczah[b-12],12+mgl); {ulozime zadni header}

Close(t);
Dispose(zzmez,Done);
Dispose(ff,Done);
FreeMem(mbf);
SaveFont_FN:=0;
end;


Function TExtFontFU.SaveFont_FNT(s:string;var p1,p2:string):byte;
var h:tFNTsave_header;
    f:file;
    z:PZnak;
    sloupce,obmpp,bmpp,zss:longint;
    a,b,c,x,y:longint;
    g,gg:byte;
    df_table:packed array[0..256] of packed record sirka,offset:word;end;
    pole1d:array[0..31] of byte;
    vw:virtualwindow;
    bitmapy:pchar;

begin
h.version:=$200;
{h.size:= ...}
FillChar(h.popisek,60,0);
Move(p1[1],h.popisek,Length(p1));
p2:=p2+#0;
h.typ:=0;
h.points:=vel;
h.vertres:=75;
h.horzres:=75;
h.ascend:=so;
h.intleading:=0;
h.extleading:=0;
h.is_italic:=0;
h.is_underline:=0;
h.is_strikeout:=0;
h.weight:=400;
h.charset:=0;
h.pixwidth:=0;
h.pixheight:=sosu;
h.family:=0;

Init_VW(vw,120,120,true);
GetMem(bitmapy,$20000);


b:=0;
c:=0;
for a:=first to last do
    if IsChReadyZ(a,z) then
       begin
       b:=b+z^.shift;
       if z^.shift>c then c:=z^.shift;
       end;
b:=b div pocetzn;
h.avgwidth:=b;
h.maxwidth:=c;
h.firstchar:=first;
h.lastchar:=last;

a:=byte('?')-first;
if a<0 then a:=0;
h.defaultchar:=a;

a:=byte(' ')-first;
if a<0 then a:=0;
h.defaultchar:=a;

h.widthbytes:=(c div 8)+1;
if odd(h.widthbytes) then inc(h.widthbytes);
h.device:=0;
h.bitspointer:=0;
h.bitoffset:=118+(pocetzn+1)*4;
h.reserved1:=0;

{Ted mame poresene polozky do offsetu [117]. Od offsetu 118 je pole dfCharTable}

bmpp:=0;

for a:=first to last+1 do
{proc last+1 a ne last+0? Protoze na konci ma byt extra zaznam pro prazdny znak}
    begin
    obmpp:=bmpp;
    z:=PrepChar(a);
    if z=nil then
       begin
       df_table[a].sirka:=0;
       df_table[a].offset:=118;     {ukazuje na zacatek dfCharTable}
       end
       else begin

       if z^.shift<z^.sirka then zss:=z^.sirka else zss:=z^.shift;

       if zss<1 then sloupce:=0 else
          sloupce:=(zss-1) div 8;

       Clr(vw,0);

       if z^.relX<0 then b:=0 else b:=z^.relX;
       c:=so+z^.relY;

       if z^.data<>nil then
          PutChar_FN(vw,z^.data,b,c,z^.sirka,z^.vyska,z^.dp,65535);
          {takto jsme vyresili dekompresi i pozicovani}
       for c:=0 to sloupce do
           begin
           for y:=0 to sosu-1 do
               begin
               for x:=0 to 7 do
                   begin
                   if GetPixel(vw,x+(c*8),y)=0 then gg:=0 else gg:=1;
                   pole1d[x]:=gg;
                   end;
               ZnakBuf_Shrink(@pole1d[0],8,g);
               bitmapy[bmpp]:=char(g);
               inc(bmpp);
               end;

           end;
       df_table[a-first].sirka:=zss;
       df_table[a-first].offset:=h.bitoffset+obmpp;
       end;
    obmpp:=bmpp;
    end;

h.size:=h.bitoffset+bmpp+Length(p2);
h.facestr:=h.bitoffset+bmpp;

Assign(f,DoplnJmenoFontu(s));
Rewrite(f,1);
BlockWrite(f,h,118);  {ulozeni 0..117 bajtu zahlavi}
BlockWrite(f,df_table,(pocetzn+1)*4);
BlockWrite(f,bitmapy[0],bmpp);
BlockWrite(f,p2[1],Length(p2));

if IOresult<>0 then SaveFont_FNT:=1;
Close(f);

FreeMem(bitmapy);
Kill_VW(vw);
SaveFont_FNT:=0;
end;


Function TExtFontFU.SaveFont_FNT_GRX(s:string;var p1,p2:string):byte;
var hdr:tGRX_FNT_header;
    mbf:pchar;
    fu:file;
    f,ff:PExtFontFU;
    g,gg:byte;
    x,y,a,b,c,d,n,zss,mbfp,prums,prumsn:longint;
    z:PZnak;
    vw:virtualwindow;
    b2b:array[0..7] of byte;
    pole1d:array[0..63] of byte;
    tvel:packed array[0..255] of word;

begin
Init_VW(vw,120,120,true);
GetMem(mbf,$20000);

Assign(fu,DoplnJmenoFontu(s));
Rewrite(fu,1);


prums:=0;
prumsn:=0;
mbfp:=0;
for a:=first to last do
    begin
    z:=PrepChar(a);
    if z=nil then               {nedefinovany znak?}
       begin
       for b:=0 to sosu-1 do
           begin
           mbf[mbfp]:=#0;
           inc(mbfp);
           end;
       tvel[a]:=1;
       end
       else begin
       if z^.shift<z^.sirka then zss:=z^.sirka else zss:=z^.shift;
       Clr(vw,0);

       if z^.relX<0 then b:=0 else b:=z^.relX;
       c:=so+z^.relY;

       if z^.data<>nil then
          PutChar_FN(vw,z^.data,b,c,z^.sirka,z^.vyska,z^.dp,65535);
          {takto jsme vyresili dekompresi i pozicovani}

       n:=(zss+7) div 8;      {v kolika bajtech je definovany kazdy radek}

       for y:=0 to sosu-1 do
           begin
           FillChar(pole1d,64,0);
           for x:=0 to zss-1 do
               begin
               if GetPixel(vw,x,y)=0 then gg:=0 else gg:=1;
               pole1d[x]:=gg;
               end;

           for d:=0 to n-1 do
               begin
               ZnakBuf_Shrink(@pole1d[d*8],8,g);
               mbf[mbfp]:=char(g);
               inc(mbfp);
               end;
           end;


       tvel[a]:=zss;
       inc(prums,zss);
       inc(prumsn);
       end;
    end;

c:=1;   {fixed}
for a:=first+1 to last do
    if tvel[a]<>tvel[a-1] then begin c:=0;Break;end;  {proportional}

d:=prums div prumsn;        {prumerna sirka}

hdr.magic:=$19590214;

hdr.bmpsize:=mbfp;             {velikost bitmapy}
hdr.width:=d;               {width (average for proportional)}
hdr.height:=sosu;                 {font height}
hdr.minchar:=first;                {lowest character code in font}
hdr.maxchar:=last;                {highest character code in font}
hdr.isfixed:=c;                {nonzero if fixed font}
hdr.reserved:=0;               {???}
hdr.baseline:=so;              {baseline from top of font}
hdr.undwidth:=d;               {underline width (at bottom)}

FillChar(hdr.fnname,16,0);
Move(p1[1],hdr.fnname,Length(p1));


FillChar(hdr.family,16,0);
Move(p2[1],hdr.family,Length(p2));
BlockWrite(fu,hdr,{SizeOf(tGRX_FNT_header)}56);

if c=0 then
   begin
   a:=(last-first+1)*2;
   {Tady jsem mel osklivy bug. Puvodne jsem zde pouzival PocetZn, ale to
    selhavalo, pokud byl nejaky znak nedefinovany a byla tedy dira v definici.
    Format totiz musi alespon formalne ulozit i ty nedefinovane znaky}
   BlockWrite(fu,tvel[first],a);
   end;

BlockWrite(fu,mbf[0],mbfp);

Close(fu);
Kill_VW(vw);
FreeMem(mbf);
SaveFont_FNT_GRX:=0;
end;


Procedure TExtFontFU.SaveHeader_V8F(var f:file;var pop:string;cp:word);
var s:string;
    mgl:longint;
    popk:string;
    blok10h:Tv8fblok16;

begin
mgl:=PLength(vf8magic);
popk:=#0#13#10#26;

blok10h.typ:=$10;
blok10h.vel:=5;
blok10h.podtyp:=0;
blok10h.codepage:=cp;

BlockWrite(f,vf8magic^,mgl);
BlockWrite(f,pop[1],Length(pop));
BlockWrite(f,popk[1],4);
BlockWrite(f,blok10h,blok10h.vel+1);
end;


Procedure Inicializuj_Blok1_V8F(bl1:Pv8fblok1;vel:longint);
begin
bl1^.typ:=1;
bl1^.vel:=0;
bl1^.first:=0;
bl1^.count:=1;
bl1^.width:=8;
bl1^.height:=vel;
end;


Function TExtFontFU.SaveFont_V8F(var s,pop:string;optim1,optim2:boolean;var po:longint):byte;
var f:file;
    a,b,i:longint;
    pp:pchar;
    zz:PZnak;
    blok1:Tv8fblok1;
    prac:array[0..12000] of byte;
    mn:set of byte;
    uvnitr:boolean;

begin
Assign(f,DoplnJmenoFontu(s));
Rewrite(f,1);

SaveHeader_V8F(f,pop,kodova_stranka);

if sosu=16 then pp:=@BIOS_FONT_16_DATA else
if sosu=14 then pp:=@BIOS_FONT_14_DATA else
if sosu=8 then pp:=@BIOS_FONT_8_DATA else pp:=nil;

mn:=[];
po:=0;
for a:=0 to 255 do
    begin
    zz:=PrepChar(a);
    if zz=nil then
       if optim2=true
          then Move(pp[a*sosu],prac[a*sosu],sosu)
          else begin Move(prazdny_vga_znak,prac[a*sosu],sosu);mn:=mn+[a];end
              else begin
              Move(zz^.data^,prac[a*sosu],sosu);
              if optim1=true then
                 begin
                 i:=CompareByte(prac[a*sosu],pp[a*sosu],sosu);
                 if i<>0 then mn:=mn+[a];
                 end
                 else begin
                 mn:=mn+[a];
                 end;
              end;
    end;

uvnitr:=false;
Inicializuj_Blok1_V8F(@blok1,sosu);

for a:=0 to 255 do
    begin
    if a in mn then
       if uvnitr
          then inc(blok1.count)  {pokracuje blok znaku, ktere budeme kopirovat}
          else begin             {vstupujeme do noveho bloku znaku}
               uvnitr:=true;
               blok1.first:=a;
               end
       else begin  {not (a in mn)}
       if uvnitr=true then       {ukoncujeme blok znaku, ktere se budou kopirovat}
          begin
          b:=SizeOf(Tv8fblok1)+blok1.count*sosu-1;
          blok1.vel:=b;
          BlockWrite(f,blok1,SizeOf(Tv8fblok1));
          BlockWrite(f,prac[blok1.first*sosu],blok1.count*sosu);
          uvnitr:=false;
          Inicializuj_Blok1_V8F(@blok1,sosu);
          end;
       inc(po);
       end;
    end;

if uvnitr=true then
   BlockWrite(f,prac[blok1.first*sosu],blok1.count*sosu);

Close(f);

SaveFont_V8F:=0;
end;


Procedure TExtFontFU.ZjistiBoundingBox(var maxsir,maxvys,minxpoz,minypoz:longint);
var mld2:longint;
    a,b,ry:longint;
    z:PZnak;

begin
if pocetzn=0 then begin maxsir:=0;maxvys:=0;minxpoz:=0;minypoz:=0;Exit;end;
mld2:=maxlongint div 2;
maxsir:=-mld2;
maxvys:=-mld2;
minxpoz:=mld2;
minypoz:=mld2;
for a:=first to last do
    if IsChReadyZ(a,z) then
       begin
       if z^.sirka>maxsir then maxsir:=z^.sirka;
       if z^.vyska>maxvys then maxvys:=z^.vyska;
       if z^.relX<minxpoz then minxpoz:=z^.relX;
       ry:=-z^.relY-z^.vyska;
       if ry<minypoz then minypoz:=ry;
       end;
end;


Function TExtFontFU.SaveFont_BDF(s:string;var p1,p2,p3,p4,p5:string):byte;
var t:text;
    u:string;
    a,b,c,d,e:longint;
    g,h:byte;
    ch:string;
    buf:array[1..1024] of byte;
    bufp:pointer;
    z:PZnak;
    ddd:Pchar;
    maxsir,maxvys,minxpoz,minypoz:longint;

begin
Assign(t,s);
Rewrite(t);
if IOresult<>0 then Exit(1);

writeln(t,'STARTFONT 2.1');
writeln(t,p5);
writeln(t,'FONT ',p1);

u:='SIZE '+MyStr(vel)+' 75 75';
writeln(t,u);

ZjistiBoundingBox(maxsir,maxvys,minxpoz,minypoz);
writeln(t,'FONTBOUNDINGBOX ',maxsir,' ',maxvys,' ',minxpoz,' ',minypoz);
writeln(t,'STARTPROPERTIES 11');

writeln(t,'FACE_NAME ',p2);
writeln(t,'FAMILY_NAME ',p3);
writeln(t,'FOUNDRY ',p4);

writeln(t,'FAMILY_NAME ',p3);
writeln(t,'WEIGHT_NAME "Medium"');
writeln(t,'FONT_ASCENT ',so);
writeln(t,'FONT_DESCENT ',su);
writeln(t,'PIXEL_SIZE ',sosu);
writeln(t,'POINT_SIZE ',sosu*10);
writeln(t,'RESOLUTION_X 75');
writeln(t,'RESOLUTION_Y 75');
writeln(t,'ENDPROPERTIES');

writeln(t,'CHARS ',pocetzn);

for a:=first to last do
    if IsChReadyZ(a,z) then
       begin
       writeln(t,'STARTCHAR char',a);
       writeln(t,'ENCODING ',a);
       writeln(t,'SWIDTH ',z^.shift*60,' 0');
       writeln(t,'DWIDTH ',z^.shift,' 0');
       writeln(t,'BBX ',z^.sirka,' ',z^.vyska,' ',z^.relX,' ',-z^.relY-z^.vyska);
       writeln(t,'BITMAP');

       z^.Dekomprimuj(false,false);

       d:=z^.sirka mod 8;
       c:=z^.sirka div 8;
       if d>0 then inc(c);   {v kolika bajtech bude definice radku}
       ddd:=z^.data;
       for b:=1 to z^.vyska do
           begin
           FillChar(buf,z^.sirka*2,0);
           Move(ddd^,buf,z^.sirka);
           u:='';
           bufp:=@buf;
           for d:=1 to c do       {pro kazdy bajt z definice radku...}
               begin
               ZnakBuf_Shrink(bufp,8,g);
               u:=u+HexStr(g);
               inc(bufp,8);
               {inc(e,8);}
               end;
           writeln(t,u);
           inc(ddd,z^.sirka);
           end;

       z^.Komprimuj;
       writeln(t,'ENDCHAR');
       end;

writeln(t,'ENDFONT');

if IOresult<>0 then begin Close(t);Exit(2);end;
Close(t);
SaveFont_BDF:=0;
end;


Function TExtFontFU.Zda_lze_nahrat_do_VGA_test1:boolean;
begin
if unicode=true then Exit(false);
if first>32 then Exit(false);
if last<126 then Exit(false);
Zda_lze_nahrat_do_VGA_test1:=true;
end;


Destructor TExtFontFU.Done;
begin
inherited Done;
end;


Function DetekujVelikostFontu(s:string;var typfontu:byte):longint;
var f:pfont;
    i:longint;
begin
typfontu:=0;
f:=Nacti_FNSLR(s);
if f=nil then Exit(0);
i:=f^.vel;
typfontu:=f^.format;
{Odpoj_FN_z_FNSLR(f);}  {asi neni treba, melo by byt poreseno v Znic_FN}
Znic_FN(f);
DetekujVelikostFontu:=i;
end;


Function ZjistiVelSouboru(s:string):longint;
var f:file;
begin
Assign(f,s);
Reset(f,1);
ZjistiVelSouboru:=FileSize(f);
Close(f);
end;


Function VytvorKontejner_WFV_ci_WFN(s:string;fl:pointer;num:longint;zamena_temp_souboru:boolean):byte;
var flist:pflist;
    i,j:longint;
    t,t2,t3:string;
    f,fz:file;
    buf:pointer;

begin
flist:=fl;

Assign(f,s);
Rewrite(f,1);
if IOresult<>0 then Exit(1);
BlockWrite(f,MAGIC_GRP,12);
BlockWrite(f,num,4);

for i:=0 to num-1 do
    begin
    t:=flist^[i];
    GetShortName(t);     {Format nezvlada dlouhe nazvy souboru}
    t2:=StripNameExt(t);
    if zamena_temp_souboru then
       if t2='TEMP.TMP' then t2:='MAPA.DAT';
    FillChar(t3,13,0);
    Move(t2[1],t3[0],Length(t2));
    BlockWrite(f,t3[0],12);
    j:=ZjistiVelSouboru(t);
    BlockWrite(f,j,4);
    end;

for i:=0 to num-1 do
    begin
    t:=flist^[i];
    Assign(fz,t);
    Reset(fz,1);
    j:=FileSize(fz);
    GetMem(buf,j);
    BlockRead(fz,buf^,j);
    BlockWrite(f,buf^,j);
    FreeMem(buf);
    if IOresult<>0 then begin close(fz);close(f);Exit(2);end;
    Close(fz);
    end;

Close(f);
VytvorKontejner_WFV_ci_WFN:=0;
end;


Function Nacti_soubor_pro_CPI(t:string;var vels:longint):pointer;
var f:file;
    p:pointer;
begin
Assign(f,t);
Reset(f,1);
vels:=FileSize(f);
GetMem(p,vels);
BlockRead(f,p^,vels);
Close(f);
if IOresult<>0 then Exit(nil);
Nacti_soubor_pro_CPI:=p;
end;



Function VytvorKontejner_CPI(s:string;cp_seznam,vel_seznam:pchar;subf:byte;fl:pointer):byte;
{CP_seznam = retezec, ktery vyjmenovava kodove stranky, napriklad takto:
             "852,866,850,#0"
 Vel_seznam = retezec popisujici velikosti, ve stejnem formatu jako CP_seznam,
              t.j.: "8,14,16,#0"
 Subf = 1: MS-DOS/FreeDOS
        2: WinNT
 FL = ^array[0..??] of String -- kde Stringy jsou nazvy jednotlivych FV souboru,
                                 i s cestami}

var f:file;
    a,b,c:longint;
    oo,oonext,nn,velsada,vels:longint;
    cp_desc:pchar;
    t,u:string;
    cpi_header:TCPI_header;
    cpi_poc_cp:word;
    cpi_cp_entry:TCodePageEntryHeader;
    poc_vel,nt:longint;
    vel_fn:array[1..20] of byte;
    vel_idx:byte;
    cpinfh:TCodePageInfoHeader;
    scrhdr:array[1..20] of TScreenFontHeader;
    fls:PFlist;
    buf:array[1..20] of pointer;

begin
fls:=fl;
{cp_desc:=SkipAllSpaces(cp_seznam);
if cp_desc[length(cp_desc)]<>',' then cp_desc:=cp_desc+',';}
cpi_poc_cp:=PHmasis(cp_seznam,',');

{t:=SkipAllSpaces(vel_seznam);
if t[length(t)]<>',' then t:=t+',';}

velsada:=0;
poc_vel:=0;
nt:=0;

a:=0;
b:=0;
u:='';
while vel_seznam[b]<>#0 do
   begin
   if vel_seznam[b]=',' then
      begin
      inc(poc_vel);
      vel_fn[poc_vel]:=MyVal(u);
      inc(velsada,vel_fn[poc_vel]*256);
      u:='';
      end
      else begin
      u:=u+vel_seznam[b];
      end;
   inc(b);
   end;


with cpi_header do
   begin
   id:=255;
   id7:='FONT   ';
   reserved:=#0#0#0#0#0#0#0#0;
   pnum:=1;
   ptyp:=1;
   fih_offset:=$17;
   end; {with}
if subf=2       {korekce pro subformat WinNT}
   then begin cpi_header.id7:='FONT.NT';nt:=1;end;


nn:=0;       {ukazatel na nazev souboru}
oo:=$17+2;   {ukazatel offsetu}


Assign(f,s);
Rewrite(f,1);
BlockWrite(f,cpi_header,sizeof(TCPI_header));  {uvodni zahlavi}
BlockWrite(f,cpi_poc_cp,2);                    {pocet definovanych kodovych stranek}

cp_desc:=@cp_seznam[0];

for a:=1 to cpi_poc_cp do
    begin
    b:=Pos(',',cp_desc);
    s:=Copy(cp_desc,0,b-1);
    inc(cp_desc,b);

    {delete(cp_desc,1,b);}
    c:=MyVal(s);             {separace oznaceni kodove stranky}
    if subf=1
       then oonext:=oo+$1c+sizeof(TCodePageInfoHeader)+velsada+poc_vel*(sizeof(TScreenFontHeader))
       else oonext:=$1c+sizeof(TCodePageInfoHeader)+velsada+poc_vel*(sizeof(TScreenFontHeader));
    with cpi_cp_entry do
       begin
       cpeh_size:=$1C;  {28}
       next_cpeh_offset:=oonext;
       device_type:=1;      {Obrazovkovy font. Pro tiskarnovy by tu bylo 2}
       device_name:='EGA     ';
       codepage:=c;         {kodova stranka}
       reserved:=#0#0#0#0#0#0;
       if subf=1
          then cpih_offset:=oo+$1C     {miri hned za tento blok cpi_co_entry}
          else cpih_offset:=$1C;       {podformat WinNT to uklada jako rel. hodnotu}
       end;

    cpinfh.version:=1;
    cpinfh.num_fonts:=poc_vel;
    cpinfh.size:=velsada+poc_vel*sizeof(TScreenFontHeader);
    for b:=1 to 20 do buf[b]:=nil;
    for vel_idx:=1 to poc_vel do
        begin
        scrhdr[vel_idx].height:=vel_fn[vel_idx];
        scrhdr[vel_idx].width:=8;
        scrhdr[vel_idx].yaspect:=0;
        scrhdr[vel_idx].xaspect:=0;
        scrhdr[vel_idx].num_chars:=256;
        t:=fls^[nn];           {nazev souboru ze seznamu}
        buf[vel_idx]:=Nacti_soubor_pro_CPI(t,vels);
        inc(nn);

        {if nn=284 then
           nn:=nn;}

        {FV soubor nacte do P, velikost vrati ve VELS}
        if (buf[vel_idx]=nil) or (vels<>vel_fn[vel_idx]*256)
           then {chybovy stav}
           begin
           for b:=1 to vel_idx do
               if buf[b]<>nil then FreeMem(buf[b] {??- drive tu bylo "buf[a]"});
           Close(f);
           Erase(f);
           Exit(1);
           end;
         end;

    BlockWrite(f,cpi_cp_entry,sizeof(TCodePageEntryHeader));
    BlockWrite(f,cpinfh,sizeof(TCodePageInfoHeader));
    for b:=1 to poc_vel do
        begin
        BlockWrite(f,scrhdr[b],sizeof(TScreenFontHeader));
        BlockWrite(f,buf[b]^,vel_fn[b]*256);
        FreeMem(buf[b]);
        end;
    oo:=oonext;
    if subf<>2 then         {Subformat WinNT muze byt vetsi nez 64KB}
       if oo>65535 then     {subformat MSDOS nikoliv}
          begin
          Close(f);
          Erase(f);
          Exit(2);
          end;
    end;

Close(f);

VytvorKontejner_CPI:=0;
end;


Function bitmapa_znaku_je_prazdna(z:PZnak):boolean;
var a:longint;
    p:pchar;
    c:char;

begin
p:=z^.data;
for a:=1 to z^.dp do
    begin
    c:=p^;
    inc(p);
    if c<>#0 then Exit(false);
    end;
bitmapa_znaku_je_prazdna:=true;
end;


Function Zda_lze_nahrat_do_VGA_test2(f:PFontFV):boolean;
var a:byte;
    z:PZnak;

begin
if f^.IsChReadyZ(32,z)=false then Exit(false);
if f^.sosu>32 then Exit(false);
for a:=33 to 122 do
    if f^.IsChReadyZ(a,z)=false then Exit(false)
       else begin
       if z^.hasbitmap=false then Exit(false);
       if bitmapa_znaku_je_prazdna(z) then Exit(false);
       end;
Zda_lze_nahrat_do_VGA_test2:=true;
end;


Procedure Inicializace_jednotky;
begin
FillChar(prazdny_vga_znak,32,0);
{pripravi prazdny blok pro pripadne nedefinovane VGA znaky}
end;

begin
Inicializace_jednotky;

end.
