Program Test;

{$I B:vdpcmd.inc }
{$I B:color.inc }
{$I B:screen.inc }
{$I B:pset.inc }
{$I B:msxdos2.inc }
{$I B:savegrap.inc }
{$I B:copy_y.inc }
{$I B:gprint57.inc }

{ Used by Filesel.inc }

 {$I B:readvram.inc }
 {$I B:wrtvram.inc  }
 {$I B:fillvram.inc }
 {$I B:blink.inc   }
 {$I B:txtwin.inc  }
 {$I B:readstr.inc }
 {$I B:filename.inc }
 {$I B:Filesel.inc }

Var i,bufaddr,counter,x,y,c :Integer;
    buf                     :Array[0..511] Of Byte;
    Handle2                 :Byte;
    FontHeight              :Byte;
    FileName,NFileName      :StringType ;
    Ch                      :Char;

Function ParseFilename(Fn:StringType):StringType;
 Var SourceSt,DestinationSt :StringType;
 Begin
    SourceSt := Fn;
    Inline(
        $11/ SourceSt+1 /$0e/$5B/$6/$0/$CD/$5/$0/$DD/$21/ DestinationSt /
        $DD/$36/$0/$0/$11/ DestinationSt+1 /
        $7E/$B7/$28/$8/$12/$13/$23/$DD/$34/$0/$18/$F4
        );
    ParseFileName := Copy(DestinationSt,1,Pos('.',DestinationSt)-1);
 End;

Procedure Menu;
 Begin

 ClrScr;
 Writeln('****************** Dynamic Publisher font to FONTWRITE font ****************');
 Writeln;
 Writeln('This program converts  Dynamic Publisher font to the font used by FontWrite - ');
 Writeln('routine in FONT7.inc by Kari Lammassaari/ACADEMY/Finland .');
 Writeln;
 Writeln('Dynamic Publisher Font will be converted into two files: ');
 Writeln;
 Writeln(' - *.fn7, which is a standard msx basic copy graphic block file containing');
 Writeln('          character patterns for ascii chars 32 - 128 . It can be viewed');
 Writeln('          by basic command COPY "font.fn7" to (0,0) in screen 7 ');
 Writeln;
 Writeln(' - *.ps7, which is 97 bytes long. First byte   contains the font height');
 Writeln('          Following bytes contain the width of chars. The first width byte');
 Writeln('          is the width for ascii char #32 (= space ).');
 Writeln;
 Writeln('REM ! The files will be created on the current drive/directory !');
 Writeln;
 Writeln('                          Kari Lammassaari 1998 ');
 Writeln;
 Writeln(' PRESS A KEY ......');

 Repeat Until KeyPressed; Read(Kbd,Ch);
 End;
Procedure PsetByte(B:Byte);

 Const Bits :Array[0..7] Of Byte = (128,64,32,16,8,4,2,1);
 Var i :Byte;
     a :Integer;
 Begin
   a := b * 16;
   b := Lo(a)+Hi(a);

   For i := 0 To 7 Do If (B And Bits[i]) = 0 Then
    Begin
     x := x +1;
     If x = 512 Then
      Begin
       x := 0; Y := y+1;
      End;
    End
   Else
    Begin
     Pset(x,y,0,15,0);
     x := x +1;
     If x = 512 Then
      Begin
        x := 0; Y := y+1;
      End;
    End;
  End; {PsetByte}

Begin
 Menu;
 Filename := FileSelect(10);

 BufAddr := Addr(Buf);Counter := 512;
 Handle := MsxFileOpen(Filename);
 MsxFileRead(Handle,BufAddr,counter);
 FontHeight := Buf[$80];

 NFileName := ParseFileName(Filename);

 Handle2 := MsxFileCreate(NFileName + '.ps7');
 Counter := 1;
 MsxFileWrite(Handle2,Addr(FontHeight),Counter);
 Counter := 96 ;
 MsxFileWrite(Handle2,Addr(Buf[256+32]),Counter) ;

 MsxFileClose(Handle2);

 Color(15,0,1);
 screen(7);
 GraphicPrint57('This is font '+NFileName+'.fn7',30,200,15,1);
 y := 0;x :=0;

 While y < 160 Do
  Begin
   Counter := 1;
   MsxFileRead(handle,bufaddr,counter);
   If Buf[0] < $80 Then     {ByteString }
    Begin
     Counter := Buf[0]+1; c := Buf[0];
     MsxFileRead(Handle,bufaddr,Counter);
     For i := 0 To c Do PsetByte(Buf[i]);
    End
   Else                  {ByteRun}
    Begin
      c:= (Buf[0] And 127);
      Counter := 1;
      MsxFileRead(Handle,bufaddr,Counter);
      For i := 0 to c Do PsetByte(Buf[0]);
    End;
  End;
 Copy_y(0,20,0, 0,FontHeight,0,0);
 Copy_y(0,40,0, FontHeight,FontHeight,0,0);
 Copy_y(0,60,0, FontHeight*2,FontHeight,0,0);

 SaveGraphicBlock(NFileName + '.fn7',0,0,0,512,3*FontHeight);
 Screen(0);
End.