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

const
   ADRESAR_S_FONTY:string = '';
   DEFAULTNI_KODOVA_STRANKA_FONTU:longint = 852;

   VNMFN_PROP_MODE:boolean = true;

   FNFMT_nic    = 0;
   FNFMT_zaklad = 1;
   FNFMT_FV     = 2;
   FNFMT_FN     = 3;
   FNFMT_FU     = 4;
   FNFMT_FNT    = 5;
   FNFMT_V8F    = 6;
   FNFMT_BDF    = 7;
   FNFMT_CHR    = 8;
   FNFMT_TTF    = 9;
   FNFMT_GRXFNT = 10;

   prop_fn   = 1;   {bude psat defaultnim, t.j proporcionalnim zpusobem}
   unprop_fn = 0;   {bude psat neproporcionalni zpusobem (lze-li)}

type

PZnak = ^TZnak;
TZnak = object
  relx:shortint;  {X posun zacatku znaku proti kurzoru}
  rely:shortint;
  korX_np:shortint; {pro neproporcionalni mod - pricte se k RelX}
  sirka:word;
  vyska:word;
  shift:shortint;     {posun kurzoru}
  korSh_np:shortint;  {pro neproporcionalni mod - pricte se k Shift}
  bunek_np:shortint;  {kolik bunek v neprop. modu zabira - vetsinou 1}
  ready:byte;     {0=neni a nebude k dispozici, 1=neni, ale lze donahrat,}
                  {2=je k dispozici}
                  {Pozor, i kdyz je k dispozici, tak nemusi byt nahrana}
                  {bitmapa. Tzn. znak je definovan jen rozmery (napr. znak mezera)}

  dp:longint;     {pocet bajtu v definici znaku}
  data:pointer;   {data definice znaku. Normalne v komprimovane podobe, ale}
                  {obcas docasne mohou byt dekomprimovana}
  {------------------}
  Constructor Init;
  Function IsReady:boolean;
  Function HasBitmap:boolean;
  Function HasBitmapAndBitmapIsNotEmpty:boolean;
  Procedure Komprimuj;
  {z nenormalniho (docasneho) znaku udela normalni komprimovany znak}
  Procedure Dekomprimuj(pridejbod,duplikovat:boolean);
  {dekomprimovany muze byt jen prechodne}
  Procedure Udelej_Proporcni;
  {vyrobi z neproporcniho DEKOMPRIMOVANEHO znaku proporcni}
  Procedure LoadCompressedData(zdroj:pointer;bajtu,isirka,ivyska:longint);
  Procedure PrekopirujPolozky(cil:PZnak;idata:boolean);
  Destructor Done;
end;


TBlok256z = array[0..255] of TZnak;
TBlok256p = array[0..255] of PZnak;
PBlok256p = ^TBlok256p;


PBitmapovyFont = ^TBitmapovyFont;
TBitmapovyFont = object
first,last,pocetzn:longint;
{prvni a posledni znak fontu a pocet definovanych znaku}
vel:byte;
{velikost, podle ktere bude font vyhledavany a registrovany.}
{neni garantovano, ze to bude SO+SU}
so,su,sosu:shortint;
{space over, space under, oboje dohromady}
add:shortint;
{pevna cast mezery mezi znaky}
sbunky:byte;
{velikost bunky - vyuziva se v neproporcionalnim modu}
max_sirka_bitmapy:longint;
{rez:^string;}
rez:string;
prop:boolean;
{proporcionalni font?}
format:byte;
{v jakem formatu je teto znakova sada? Viz konstanty FNFMT}
kodova_stranka:word;
{kodova stranka (pro unicode zde bude 65535)}
unicode:boolean;
{unicode font?}
vzdy_komplet_nahrany:boolean;
{je zaruceno, ze vsechny znak fontu jsou vzdy okamzite v pameti?}
rukojet:pointer;
{odkaz na vlastnika ve formatu PObecnyFont (je deklarovany nize)}
dalsi_data:pointer;
{volitelna dalsi data}
dalsi_data_vel:longint;
{jejich velikost}

Constructor Init;
Procedure PrvotniPrirazeni;
Function PrepChar(znak:longint):pointer;virtual;
{da odkaz na PZnak prislusneho znaku}
Function IsChReady(znak:longint):boolean;virtual;
Function IsChReadyZ(znak:longint;var z:PZnak):boolean;virtual;
Destructor Done;virtual;
end;



PBitMapZnaky256 = ^TBitMapZnaky256;
TBitMapZnaky256 = object(TBitmapovyFont)
  znaky256:TBlok256z;
  Constructor Init(velikost:word);
  Function PrepChar(znak:longint):pointer;virtual;
  Procedure NastavVelikost(velikost:word);virtual;
  Procedure NastavVelikostExt(velikost,porce_su:word);virtual;
  Destructor Done;virtual;
end;



PObecnyFont = ^TObecnyFont;
TObecnyFont = object
  fdata:PBitmapovyFont;  {v praxi nektery z potomku PBitmapovyFont}
  typzdroje:byte;
   {0 = nevyplneno/neznamo
    1 = VGA
    2 = samostatne nacteno (nikoliv v kontejneru)
    3 = bitmapovy kontejner (napr. GRP soubor)
    4 = vektorovy kontejner
   }
  typ_kontejneru_detail:byte;
  {
    0 = neni relevantni nebo nespecifikovano
    1 = archiv v GRP formatu a s MAPA.DAT
    2 = FON format
  }
  odkaz_na_kontejner:pointer;  {u bitmapovych odkaz typu PGRPmapa}

  {dale formatove specificka data pro potomky}
  Constructor Init;
  Function GetInfo(param1,param2:longint):longint;
  Destructor Done;virtual;
end;


Function NazevBezCesty(s:string):string;
Procedure ZnakBuf_Expand(a:byte;p:pointer);
{Procedure ZnakBuf_Shrink(p:pointer;var a:byte);}
Procedure ZnakBuf_Shrink(p:pointer;modbitu:byte;var a:byte);
Function DoplnJmenoFontu(s:string):string;
Procedure Preved_Font_na_proporcni(prop_font:PBitMapZnaky256;p:PBitMapZnaky256;size:byte);
Procedure Preved_Font_bez_konverze_na_proporcni(prop_font:PBitMapZnaky256;p:PBitMapZnaky256;size:byte);
Procedure VnmFnHlp_OutText(kam:pointer;x,y:longint;s:string;fnt:PBitmapovyFont;color:word);

type
vnmfnhlp_outtext_drawchartype = function(var dest;p:pointer;x,y,xd,yd:longint;charbytes:byte;c:word):byte;

var
vnmfnhlp_outtext_drawcharproc:vnmfnhlp_outtext_drawchartype;
vnmfnhlp_outtext_drawcharPtr:pointer;


{----------------------------------------------------------------------------}
implementation
{----------------------------------------------------------------------------}


Function NazevBezCesty(s:string):string;
var a,b:byte;
begin
b:=Length(s);
for a:=b downto 1 do
    if s[a]='\' then
       begin
       NazevBezCesty:=Copy(s,a+1,255);
       Exit;
       end;
NazevBezCesty:=s;
end;



Procedure ZnakBuf_Expand(a:byte;p:pointer);
var b:byte;
    q:pbyte;
begin
q:=p;
for b:=7 downto 0 do
    begin
    if odd(a) then q[b]:=1 else q[b]:=0;
    a:=a shr 1;
    end;
end;


{
Procedure ZnakBuf_Shrink(p:pointer;var a:byte);
var q:pbyte;
begin
q:=p;
a:=(q[0] and 1) shl 7 + (q[1] and 1) shl 6 + (q[2] and 1) shl 5 +
   (q[3] and 1) shl 4 + (q[4] and 1) shl 3 + (q[5] and 1) shl 2 +
   (q[6] and 1) shl 1 + (q[7] and 1);
end;
}


Procedure ZnakBuf_Shrink(p:pointer;modbitu:byte;var a:byte);
var b:byte;
    q:pbyte;
begin
a:=0;
q:=p;
for b:=1 to modbitu do
    begin
    a:=a+((q^ and 1) shl (8-b));
    inc(q);
    end;
end;



Function DoplnJmenoFontu(s:string):string;
begin
if Pos('\',s)=0 then DoplnJmenoFontu:=ADRESAR_S_FONTY+s
              else DoplnJmenoFontu:=s;
end;


Procedure Preved_Font_na_proporcni(prop_font:PBitMapZnaky256;p:PBitMapZnaky256;size:byte);
var a:byte;
    z,n:PZnak;
begin
prop_font^.prop:=true;  {oznacime, ze font je proporcionalni}
for a:=0 to 255 do
    begin
    z:=p^.PrepChar(a);          {originalni neproporcni znak}
    if z<>nil then
       begin
       n:=@prop_font^.znaky256[a]; {ukazatel na misto, ktere zaplnime daty}
       n^.Init;
       n^.LoadCompressedData(z^.data,z^.dp,z^.sirka,size);
       n^.Dekomprimuj(false,false);
       n^.Udelej_Proporcni;
       n^.Komprimuj;
       n^.shift:=n^.sirka+2; {vypada to lepe nez "n^.sirka+1"}
       n^.ready:=2;
       n^.rely:=-prop_font^.so;
       end;
    end;
end;


Procedure Preved_Font_bez_konverze_na_proporcni(prop_font:PBitMapZnaky256;p:PBitMapZnaky256;size:byte);
var a:byte;
    z,n:PZnak;
begin
for a:=0 to 255 do
    begin
    z:=p^.PrepChar(a);          {originalni neproporcni znak}
    if z<>nil then
       begin
       n:=@prop_font^.znaky256[a]; {ukazatel na misto, ktere zaplnime daty}
       n^.Init;
       n^.LoadCompressedData(z^.data,z^.dp,z^.sirka,size);
       n^.rely:=-prop_font^.so;
       end;
    end;
end;




Constructor TZnak.Init;
begin
data:=nil;
dp:=0;
relx:=0;
rely:=0;
shift:=0;
sirka:=0;
vyska:=0;
korX_np:=-128;  {specialni hodnota, ktera znamena "nedefinovano"}
korSh_np:=0;
bunek_np:=1;   {v neproporcionalnim modu zabira jednu bunku}
ready:=0;
end;


Procedure TZnak.LoadCompressedData(zdroj:pointer;bajtu,isirka,ivyska:longint);
begin
dp:=bajtu;
sirka:=isirka;
vyska:=ivyska;
GetMem(data,dp);
Move(zdroj^,data^,dp);
ready:=2;
end;


Procedure TZnak.Komprimuj;
{Zkomprimuje znak}
var a,b,c,d,odp:longint;
    p,g,pp:pbyte;
    j:byte;
begin
if HasBitmap=false then Exit;
b:=sirka*vyska;
odp:=b;
d:=b mod 8;
a:=b div 8;

c:=(b+7) div 8;       {v kolika bajtech bude definice znaku}

{if d=0 then
   c:=a else c:=a+1;} {v kolika bajtech bude definice znaku}

GetMem(p,c);
pp:=p;
g:=data;
for b:=0 to a-1 do {projedu vsechny cele zaplnene bajty}
    begin
    ZnakBuf_Shrink(g,8,j);
    p[b]:=j;
    inc(g,8);
    end;


{a ted jeste co zbylo (jestli neco zbylo)}
if d<>0 then
   begin
   ZnakBuf_Shrink(g,d,j);
   p[a]:=j;
   inc(g,d);
   end;

FreeMem(data,odp);
dp:=c;
data:=p;
end;


Procedure TZnak.Dekomprimuj(pridejbod,duplikovat:boolean);
{Dekomprese znaku}
{Pokud je "pridejbod9" true, tak kazdy znak rozsiri o jeden bod. Pouziti
 nejspise pri rozsirovani osmibitovych VGA znaku do devitibodove "hardwarove"
 reprezentace.
 Pokud je "duplikovat" true, tak do posledniho bodu zduplikuje predposledni
 bod. V opacnem pripade ponecha posledni bod prazdny}
var a,c:longint;
    p,q:pbyte;
    prac:array[0..4095] of byte;
    m:byte;

begin
if HasBitmap=false then Exit;
if pridejbod then inc(sirka);
c:=sirka*vyska;
p:=data;               {stary buffer}
q:=@prac;
{Komprimovana data expanduju pres mezibuffer. To je absolutne nutne a pokud se
 to neudela, tak to vede k velmi tezko odhalitelnym chybam. Pricinou je to,
 ze SIRKA*VYSKA < DP div 8  --> nasledkem je prepsani nekolika bajtu za
 bufferem, coz vede k divnym vecem}
for a:=0 to dp-1 do
    begin
    ZnakBuf_Expand(p[a],q);
    inc(q,7);
    if pridejbod then
       begin
       if duplikovat then m:=q^ else m:=0;
       inc(q);
       q^:=m;
       end;
    inc(q);
    end;

dp:=c;
FreeMem(data);         {smazu komprimovany blok}

GetMem(data,dp);       {a rovnou pripravim novy pro dekompimovana data}
Move(prac,data^,dp);   {a prekopiruju je z pracovniho bufferu}
end;


Procedure TZnak.Udelej_Proporcni;
{Pozor! Font vstupujici do teto procedury musi byt dekomprimovany.}
{Nikde to neni kontrolovano!}
var a,c,d,l,odp,osirka,vlevo,vpravo:longint;
    p,nove:pbyte;
    h,ch:^byte;
    bod:boolean;

begin
if HasBitmap=false then Exit;
vlevo:=0;
vpravo:=0;
korX_np:=0;
korSh_np:=0;

p:=data;
odp:=dp;
osirka:=sirka;

{1.faze - budu zleva doprava hledat nejaky bod}
bod:=false;
for d:=0 to sirka-1 do
    begin
    h:=p;
    inc(h,d);
    for c:=1 to vyska do
        begin
        if h^<>0 then begin bod:=true;Break;end;
        inc(h,sirka);
        end;
    if bod then Break else inc(vlevo);
    end;

if bod=false then Exit; {nenasel jsem zadny bod, tudiz jde o prazdny znak}

{2.faze - mam najity nejlevejsi bod a ted budu hledat nepravejsi}
bod:=false;

for d:=0 to sirka-1 do
    begin
    h:=p;
    inc(h,sirka-1);
    dec(h,d);
    for c:=1 to vyska do
        begin
        if h^<>0 then begin bod:=true;Break;end;
        inc(h,sirka);
        end;
    if bod then Break else inc(vpravo);
    end;

{3. faze - znak vlevo orizneme o VLEVO a vpravo o VPRAVO}
korX_np:=vlevo;
korSh_np:=vlevo+vpravo;
bunek_np:=1;

dec(sirka,vpravo+vlevo);
if vpravo+vlevo<>0 then dec(shift,vpravo+vlevo-2);

dp:=vyska*sirka;
GetMem(nove,dp);
ch:=nove;

h:=p;
inc(h,vlevo);

for c:=0 to vyska-1 do
    begin
    move(h^,ch^,sirka);
    inc(h,osirka);
    inc(ch,sirka);
    end;

FreeMem(data);
data:=nove;
end;


Function TZnak.IsReady:boolean;
begin
IsReady:=ready=2;
end;


Function TZnak.HasBitmap:boolean;
begin
if IsReady then HasBitmap:=data<>nil else HasBitmap:=false;
end;


Function TZnak.HasBitmapAndBitmapIsNotEmpty:boolean;
var b:byte;
    a:longint;
    p:pchar;

begin
if HasBitmap=false then Exit(false);
p:=data;
for a:=1 to dp do
    if p^<>#0 then Exit(true) else inc(p);
HasBitmapAndBitmapIsNotEmpty:=false;
end;


Procedure TZnak.PrekopirujPolozky(cil:PZnak;idata:boolean);
begin
cil^.relx:=relx;
cil^.rely:=rely;
cil^.korX_np:=korX_np;
cil^.sirka:=sirka;
cil^.vyska:=vyska;
cil^.shift:=shift;
cil^.korSh_np:=korSh_np;
cil^.bunek_np:=bunek_np;
cil^.ready:=ready;
cil^.dp:=dp;
if idata=true
   then cil^.data:=data   {pozor - muze byt nebezpecne pri dealokaci}
   else begin end;     {zapiseme to takhle polopaticky}
end;

Destructor TZnak.Done;
begin
if data<>nil then FreeMem(data);
data:=nil;
dp:=0;
ready:=0;
sirka:=0;
vyska:=0;
end;



Constructor TBitmapovyFont.Init;
begin
PrvotniPrirazeni;
end;


Procedure TBitmapovyFont.PrvotniPrirazeni;
begin
first:=0;
last:=0;
pocetzn:=0;
so:=0;
su:=0;
sosu:=0;
add:=0;
max_sirka_bitmapy:=0;
sbunky:=0;
{rez:=nil;}
rez:='';
prop:=false;
kodova_stranka:=DEFAULTNI_KODOVA_STRANKA_FONTU;
unicode:=false;
vzdy_komplet_nahrany:=false;
rukojet:=nil;
dalsi_data:=nil;
dalsi_data_vel:=0;
format:=FNFMT_nic;
end;


Function TBitmapovyFont.PrepChar(znak:longint):pointer;
{informuje, zda existuje definice znaku. Neni ale jiste, zda je i definice
 bitmapy}
begin
PrepChar:=nil;
end;


Function TBitmapovyFont.IsChReadyZ(znak:longint;var z:PZnak):boolean;
{TODO - zde by event. mohl byt nejaky figl, jak znaky co nejsou nahrane, ale
 lze je donahrat rovnou donahrany byly}
begin
z:=PrepChar(znak);
if z=nil
   then IsChReadyZ:=false
   else IsChReadyZ:=z^.IsReady;
end;



Function TBitmapovyFont.IsChReady(znak:longint):boolean;
var zz:PZnak;
     b:boolean;
begin
{debug}
{writeln('TBitmapovyFont.IsChReady: znak: ',znak);
writeln('self.format',format);
writeln('self.rez',rez);
readln;}
{/debug}
b:=IsChReadyZ(znak,zz);
IsChReady:=b;
end;


Procedure VnmFnHlp_OutText(kam:pointer;x,y:longint;s:string;fnt:PBitmapovyFont{PBitMapZnaky256};color:word);
var i,ox:longint;
    c:char;
    cr:boolean;
    z:PZnak;
    PutCharProc:vnmfnhlp_outtext_drawchartype;

begin
ox:=x;
cr:=false;
pointer(PutCharProc):=pointer(vnmfnhlp_outtext_drawcharPtr^);
for i:=1 to Length(s) do
    begin
    c:=s[i];
    if c=#13 then
       begin
       x:=ox;
       inc(y,fnt^.sosu);
       cr:=true;
       end
       else
    if (c=#10) and (cr=true) then cr:=false
       else
       begin
       z:=fnt^.PrepChar(byte(c));
       PutCharProc(kam^,
                  z^.data,
                  x+z^.relX,
                  y+z^.relY,
                  z^.sirka,
                  z^.vyska,
                  z^.dp,
                  color);

       if c='p' then
          c:=c;
       inc(x,z^.shift);
       cr:=false;
       end;
    end;
end;


Destructor TBitmapovyFont.Done;
begin
{if rez<>nil then FreeMem(rez);}
PrvotniPrirazeni;
end;


Constructor TBitMapZnaky256.Init(velikost:word);
var a:byte;
begin
Inherited Init;
first:=0;
last:=255;
pocetzn:=256;
vzdy_komplet_nahrany:=true;
for a:=0 to 255 do znaky256[a].init;
NastavVelikost(velikost);
format:=FNFMT_zaklad;
end;


Procedure TBitMapZnaky256.NastavVelikost(velikost:word);
begin
NastavVelikostExt(velikost,0);
end;


Procedure TBitMapZnaky256.NastavVelikostExt(velikost,porce_su:word);
{nastavi jen udaje o vysce. Udaje samotnych znaku nijak nemeni, natoz aby
 nejak modofikoval jednotlive bitmapy}
begin
vel:=velikost;
sosu:=velikost;
su:=porce_su;
so:=sosu-su;
end;


Function TBitMapZnaky256.PrepChar(znak:longint):pointer;
{informuje, zda existuje definice znaku. Neni ale jiste, zda je i definice
 bitmapy}
begin
if (znak<0) or (znak>255)
   then PrepChar:=nil
   else PrepChar:=@znaky256[znak];
end;


Destructor TBitMapZnaky256.Done;
var a:byte;
begin
for a:=0 to 255 do Znaky256[a].Done;
Inherited Done;
end;



Constructor TObecnyFont.Init;
begin
fdata:=nil;
typzdroje:=0;
{0 = nevyplneno/neznamo
 1 = VGA
 2 = samostatne nacteno (nikoliv v kontejneru)
 3 = bitmapovy kontejner (napr. GRP soubor)
 4 = vektorovy kontejner
}
typ_kontejneru_detail:=0;
odkaz_na_kontejner:=nil;
end;


Function TObecnyFont.GetInfo(param1,param2:longint):longint;
var k:longint;
    s:string;

begin
case param1 of
1:begin   {vyjadri se, jsou-li k dispozici ruzne velikosti fontu}
  if typzdroje in [0,2] then k:=1 else    {0=neznamo, 2=samostatne}
  if typzdroje in [1,3] then k:=2 else    {1=VGA, 3=archiv}
     k:=3;                                {vektorovy font}
  end;


2:begin {jakou velikost uvadi font?}
  k:=fdata^.vel;
  end;


3:begin {dej retezec, kde jsou zakodovany vsechny velikosti fontu}
        {<param2> je v tomto pripade ukazatel na promennou <string>, kterou}
        {vyplnime.}
        {U kontejnerovych formatu bude tato funkce predefinovana}

  Str(fdata^.vel,s);
  Move(s,pointer(param2)^,Length(s)+1);
  k:=-1;
  end;

4:begin {dej retezec, kde jsou zakodovany vsechny znakove sady fontu}
        {<param2> je v tomto pripade ukazatel na promennou <string>, kterou}
        {vyplnime.}
        {U kontejnerovych formatu bude tato funkce predefinovana}

  Str(fdata^.kodova_stranka,s);
  Move(s,pointer(param2)^,Length(s)+1);
  k:=-1;
  end;


else k:=0;
end; {case}
GetInfo:=k;
end;


Destructor TObecnyFont.Done;
begin
if fdata<>nil then
   Dispose(fdata,Done);  {smaze font, ale neresi prip. odkazy na kontejnery}
end;


Function vnmfnhlp_outtext_dummyproc(var dest;p:pointer;x,y,xd,yd:longint;charbytes:byte;c:word):byte;
begin
{dummy}
end;


begin
vnmfnhlp_outtext_drawcharproc:=@vnmfnhlp_outtext_dummyproc;
vnmfnhlp_outtext_drawcharPtr:=pointer(vnmfnhlp_outtext_drawcharproc);
end.
