unit vnm_chr;
{****************************************************************************}
{Unit VNM_CHR - it is a addon unit for graphics library VenomGFX.            }
{It brings a loader for .CHR vector font files                               }
{      written by Jean-Pierre Planas and Michael Knapp, adjusted by Laaca    }
{****************************************************************************}
{$IFDEF VER2}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF VER3}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF NEWFPC}{$CALLING OLDFPCCALL}{$ENDIF}

{$ASMMODE INTEL}
interface
uses VenomGFX,VenomMng;

Function CheckFormat_CHR(name:string):byte;

type
PFontCHR=^TFontCHR;
TFontCHR=object
       Org_to_cap   :longint; {* Height from origin to top of capitol      *}
       Org_to_base  :longint; {* Height from origin to baseline            *}
       Org_to_dec   :longint; {* Height from origin to bot of decender     *}
       Num_chrs     :longint;
       First        :Byte;    {* First character in file                   *}
       italic       :boolean;
       fontorigin   :byte;
       Char_Width   :Array[0..255] of byte;  {* Character Width Table	   *}
       Offset       :Array[0..255] of word;

       Chrloaded    : Boolean;
       charbuf:pointer;
       divider:longint;
       fontdir:longint;
       fontsize:longint;
       sinus,cosinus:longint;
       fontbufsize:longint;
       fontbufptr:pointer;
       rez:string;

       Procedure LoadFont(name:string);
       Procedure Draw_char(var virt:virtualwindow;x,y:longint;i:Byte;color:word);
       Procedure outtext(var virt:virtualwindow;x,y:longint;s:string;color:word);
       FUNCTION textlength(s:string):longint;
       FUNCTION fontheight:longint;
       Procedure RemoveFont;
end;


Function CHR_mngr_LoadFont(s:string;size:byte):pointer;
Procedure CHR_mngr_OutText(kam:pointer;x,y:longint;s:string;fnt:pointer;color:word);
Procedure CHR_mngr_SetParams(fnt:pointer;size,flags:byte);
Procedure CHR_mngr_RemoveFont(fnt:pointer);

implementation
uses GRPfile,VnmFNhlp;

type
TCHRHeader = PACKED RECORD        {Zahlavi CHR fontu}
       id1,ids:longint;
       info:Array[1..$50] of Char; {zahlavi}
       b1,b2,b3:byte;
       fontid:array[0..3] of char;
       a1:Array[1..$20] of Char; {zahlavi}
       b4:byte;
       Sig         :char;	{* signatura (podpis)                    *}
       Nchrs       :smallint;	{* pocet definivanych znaku              *}
       Mystery     :char;       {* rezervovano                           *}
       First	   :byte;    	{* prvni znak v souboru                  *}
       Cdefs	   :smallint;   {* offset k definicim znaku              *}
       Scan_Flag   :char;	{* TRUE je-li zvetsovaci                 *}
       Org_To_Cap  :Shortint;	{* Vyska z pocatku na vrsek vel. pismen  *}
       Org_To_Base :Shortint;	{* Vyska z pocatku na zakladni linku     *}
       Org_To_Dec  :Shortint;	{* Vyska z pocatku na spodky nozicek     *}
       FntName     :Array[0..3] of char;{* 4 znaky jmena fontu           *}
       Unused      :char;       {* nedefinovano                          *}
End;


Function CheckFormat_CHR(name:string):byte;
var a:longint;
    grp:TGRPStream;
    n1,n2:string;
begin
grp.Init(name,grpOpenRead);   {otevru soubor}
if grp.status<>grpOK then
   begin
   grp.Done;
   CheckFormat_CHR:=2;
   Exit;
   end;

if grp.GetSize<sizeof(TCHRheader) then
   begin
   grp.Done;
   CheckFormat_CHR:=3;
   Exit;
   end;

n1:='PK'#8#8'BGI ';
grp.ReadStream(n2[1],8);n2[0]:=#8;
grp.Done;
if n1=n2 then CheckFormat_CHR:=0 else CheckFormat_CHR:=3;
end;



Procedure TFontCHR.LoadFont(name:string);
VAR grp:tGRPstream;
    Header:TCHRHeader;
    i:longint;

Begin
NUM_chrs:=0;  {zatim mame definovanych 0 znaku}
fontbufsize:=0;
fontbufptr:=nil;
charbuf:=nil;

grp.Init(NormalizujJmenoFontu(name),grpOpenRead);   {otevru soubor}
if grp.status<>grpOK then
   begin
   grp.Done;
   chrloaded:=false;
   Exit;
   end;

For i:=0 to 255 do   {pro vsech 256 znaku...}
    Begin
    Offset[i]:=0;      {vynuluju offset na definici znaku}
    Char_Width[i]:=0;  {vynuluje sirku znaku}
    End;

grp.ReadStream(header,sizeof(header)); {nacte zahlavi}


NUM_chrs:=HEADER.nchrs;
org_to_cap :=Header.org_to_cap ;
org_to_base:=Header.org_to_base;
org_to_dec :=Header.org_to_dec ;
first      :=header.first;
italic:=false;
fontsize:=16;
fontorigin:=0;

{Nacte tabulku offsetu k jednotlivym znakum}
grp.ReadStream(OFFSET[header.first],2*NUM_chrs);

{Nacte tabulku sirek k jednotlivym znakum}
grp.ReadStream(CHAR_WIDTH[header.first],1*NUM_chrs);


fontbufsize:=grp.GetSize-grp.GetPos; {Spocita velikost nutneho bloku pameti}

getmem(fontbufptr,fontbufsize);

grp.ReadStream(fontbufptr^,fontbufsize);
grp.Done;

rez:=name;
for i:=1 to Length(rez) do rez[i]:=UpCase(rez[i]);

getmem(charbuf,32768 div 2);

divider:=abs(org_to_cap)+abs(org_to_dec);
fontdir:=0;
chrloaded:=true;
end;


PROCEDURE Decode(w:word;var action:byte;var x,y:longint);assembler;
{nacte WORD a desifruje z neho ACTION a hodnoty X a Y}
{Format:
 bity 1.bajtu = Azxxxxxx
 bity 2.bajtu = Bzyyyyyy

 kombinace A a B urcuje operator
 "z" je v obou bajtech znamenko
 "x" a "y" jsou ostatni bity X a Y souradnice

        A=0  B=0  konec definice znaku
        A=0  B=1  Do scan
        A=1  B=0  posun ukazatel na (x,y)
        A=1  B=1  kresli z momentalni pozice do (x,y)
 }
  asm
    MOV BL,0
    MOV AX,w
    SHL AL,1
    ADC BL,0   {byl predtim nejvyssi bit AL 1? Tak v tom pripade bude BL 1}
    SHL BL,1   {jestli byl predstm BL 1, tak ted bude BL 2, jinak BL=0}
    SHL AH,1         {nejvyssi bit AH je 1?}
    ADC BL,0   {tak zase eventualne pricti k BL 1}
    MOV EDI,action
    MOV [EDI],BL     {action:=bl}

    MOV BL,AH  {7 bitu Y-souradnice schovej do BL (porad je SHL-nute o 1}
    CBW        {je AL (tedy X-souradnice) zaporne? V tom pripade bude AH=FFh (jinak AH=0h)}
    SAR AX,1   {posuneme AX doprava, ale udrzime znamenko}
    CWDE       {podle znamenka rozsir AX do EAX}
    MOV EDI,x
    MOV [EDI],EAX

    MOV AL,BL       {stejny postup pro Y-souradnici, ktera byla predtim v BL}
    CBW
    SAR AX,1
    CWDE
    MOV EDI,y
    MOV [EDI],EAX
  END;


Procedure TFontCHR.Draw_char(var virt:virtualwindow;x,y:longint;i:Byte;color:word);
Var p_w     :^word;
    Action  :byte;
    xd,yd   :longint;
    Centrage:longint;
    sizebuf,polybuf:^longint;
    polynr:word;

    PROCEDURE lt(x,y:longint);  {pridej bod do polygonu}
    BEGIN
      inc(sizebuf^);    {poznamename si zvetseni polygonu o 4 bajty}
      polybuf^:=x;              {vloz X}
      inc(polybuf);
      polybuf^:=y;              {vloz Y}
      inc(polybuf);
    END;

    PROCEDURE mt(x,y:longint);  {zaloz novy polygon}
    BEGIN
      inc(polynr);       {zvys pocet polygonu o jeden}
      sizebuf:=polybuf;   {pocitadlo bodu nastavime na zacatek polyg. bufferu}
      sizebuf^:=1;        {velikost = 1, t.j. definovan jeden bod}
      inc(polybuf);  {v 1.bajtu je pocet bodu, proto prejdu na dalsi bajt}

      polybuf^:=x;      {a donoveho polygonu vlozime X}
      inc(polybuf);
      polybuf^:=y;      {a Y}
      inc(polybuf);
    END;

    PROCEDURE Poly(var p;z:word);
    VAR q:^longint;
        x,y,a,b,c,ox,oy:longint;
    BEGIN
      q:=addr(p);         {nastavime se na zacatek bufferu}
      FOR a:=1 TO z DO    {zpracuj 1. az Z-ty polygon}
        BEGIN
          b:=q^;          {nacti pocet bodu v polygonu}
          inc(q);

          x:=q^;          {nacti zakladni X}
          inc(q);
          y:=q^;
          inc(q);         {a zakladni Y}
          ox:=x;
          oy:=y;     {z aktualnich souradnic udelej stare souradnice}
          FOR c:=2 TO b DO
            BEGIN
              x:=q^;      {nacti nove X}
              inc(q);
              y:=q^;      {a nove Y}
              inc(q);
              line(virt,ox,oy,x,y,color);  {nakresli caru ze starych do novych souradnic}
              ox:=x;
              oy:=y; {z aktualnich souradnic udelej stare souradnice}
            END;
        END;
    END;

Begin
polybuf:=charbuf;
polynr:=0;

If First+Num_chrs<i Then Exit; {neni definovan znak I ?}

If (OFFSET[i]<>0) or (i=First) Then
   Begin
   CASE fontorigin OF
      0:Centrage:=org_to_cap;
      1:Centrage:=0;
   END;

   mt(x,y);             {zaloz novy polygon, prvni bod bude zadana X,Y pozice}
   p_w:=fontbufptr;     {ukazovatko v nactenem souboru}

   inc(p_w,OFFSET[i] div 2);   {ukazovatko posunu na zacatek definice znaku}
   {div 2 je tu nebot p_w je typova promenna}

   Decode(p_w^,Action,xd,yd);   {dekoduje prvni word}

   IF italic THEN inc(xd,yd DIV 4);
   yd:=yd-centrage;

   While (Action<>0) do
      Begin
      Case Action of
         2:Mt(x+((xd*cosinus+yd*sinus) DIV 65536), {presunuti na novy polygon}
              y+((xd*sinus-yd*cosinus) DIV 65536));

         3:LT(x+((xd*cosinus+yd*sinus) DIV 65536), {novy bod polygonu}
              y+((xd*sinus-yd*cosinus) DIV 65536));
      End;{Case}
      inc(p_w);                  {presun se na dalsi bajt bufferu}
      Decode(p_w^,Action,Xd,Yd); {a dekoduj ho}

      IF italic THEN inc(xd,yd DIV 4);
      yd:=yd-centrage;

      End;

   End; {if (C_Font.OFFSET[i]<>0) or (i=C_Font.First)...}


poly(charbuf^,polynr);
End;



PROCEDURE TFontCHR.outtext(var virt:virtualwindow;x,y:longint;s:string;color:word);
VAR i,akku:longint;
BEGIN
  sinus:=trunc(((sin((fontdir*2*pi)/65536)*fontsize)/divider)*65536);
  cosinus:=trunc(((cos((fontdir*2*pi)/65536)*fontsize)/divider)*65536);
  akku:=0;
  For i:=1 to Length(s) do
    Begin
      Draw_Char(virt,x+((akku*cosinus) SHR 16),y+((akku*sinus) SHR 16),ord(s[i]),color);
      inc(akku,Char_Width[ord(s[i])]);
    End;
End;


Procedure TFontCHR.RemoveFont;
BEGIN
  IF chrloaded THEN
    BEGIN
      freemem(charbuf,32768 div 2);
      freemem(fontbufptr,fontbufsize);
    END;
END;


FUNCTION TFontCHR.textlength(s:string):longint;
Var i:Byte;
    total:Word;
Begin
  Total:=0;
  For i:=1 to Length(S) do
    inc(Total,Char_Width[ord(s[i])]);
  textlength:=(Total*fontsize) DIV divider;
End;


FUNCTION TFontCHR.fontheight:longint;
BEGIN
  fontheight:=((org_to_cap-org_to_dec)*fontsize) DIV divider;
END;


Function CHR_mngr_LoadFont(s:string;size:byte):pointer;
var a:byte;
    chr:PFontCHR;
begin
a:=CheckFormat_CHR(s);
if a<>0 then Exit(nil);
New(chr);
chr^.LoadFont(s);
if chr^.chrloaded=false then
   begin
   chr^.RemoveFont;
   Dispose(chr);
   Exit(nil);
   end;

CHR_mngr_LoadFont:=chr;
end;


Function CHT_mngr_PrepChar(fnt:pointer;znak:word):pointer;
begin
{dummy}
end;


Procedure CHR_mngr_OutText(kam:pointer;x,y:longint;s:string;fnt:pointer;color:word);
var virt:Pvirtualwindow;
    chr:PFontCHR;
begin
virt:=kam;
chr:=fnt;
chr^.outtext(virt^,x,y,s,color);
end;


Procedure CHR_mngr_SetParams(fnt:pointer;size,flags:byte);
var chr:PFontCHR;
begin
chr:=fnt;
chr^.fontsize:=size;
chr^.italic:=(flags and 1)<>0;
end;


Function CHR_mngr_FontInfo(fnt:pointer;param:longint):longint;
var chr:PFontChr;
begin
chr:=fnt;
CHR_mngr_FontInfo:=0;
if param=1 {velikost} then CHR_mngr_FontInfo:=chr^.fontsize;
end;


Procedure CHR_mngr_RemoveFont(fnt:pointer);
var chr:PFontCHR;
begin
chr:=fnt;
chr^.RemoveFont;
Dispose(chr);
end;

begin
RegisterFontEngine('CHR',@CHR_mngr_LoadFont,@CHT_mngr_PrepChar,
                         @CHR_mngr_OutText,@CHR_mngr_SetParams,
                         @CHR_mngr_FontInfo,
                         @CHR_mngr_RemoveFont);
end.
