%include "inc:util.imp"
%begin
%constant %shortinteger xsize=48,ysize=48,newfont=20,pagehight=3000,
                        pagewidth=3000
%constant %byteinteger black=1,grey=2
%constant %byteinteger ESC=27,SP=32
%byteinteger character,symbol
%integer i,cx,cy
%byte %array characters(0:127),pixels(1:50,1:50)
%own %byte %integer %array pattern(0:3)=99,108,97,110
%string (50) fontnam,filenam

%routine getafter(%byte %integer a)
%byteinteger b
  %cycle
    readsymbol(b)
  %repeat %until b=a
%end

%routine sendhead(%byte %integer a)
  printsymbol(ESC);write(a,4);printsymbol(';');
  write(ysize,2);printsymbol(';');write(0,2);printsymbol(';');write(xsize,2);
  printsymbol(';');write(0,2);printsymbol(SP);printsymbol('K');newline
%end

%routine startpage
  printsymbol(ESC);write(pagehight,5);printsymbol(';');write(pagewidth,5)
  printsymbol(SP);printsymbol('P');newline
%end

%routine endpage
  printsymbol(ESC);printstring(" E");newline
%end

%routine selectfont(%shortinteger font)
  printsymbol(ESC);write(font,5);printstring(" F")
%end

%routine moveup(%shortinteger move)
  printsymbol(ESC);write(move,5);printstring(" A")
%end

%routine sendbitarray(%byteinteger greyscale)
%shortinteger accum,xcoor,ycoor,bitcnt
  %for ycoor=1,1,ysize %cycle
     %for xcoor=0,1,(xsize>>4)-1 %cycle
       accum=0
       %for bitcnt=1,1,16 %cycle
          accum <- (accum<<1)+pixels((xcoor<<4)+bitcnt,ycoor)
       %repeat
       phex4(accum)
     %repeat
     newline
  %repeat
%end

%routine fillraster                    {starts after char NL and halts before :}
%integer xcoor,ycoor
%byteinteger sym
  %for xcoor=1,1,50 %cycle                   {clear pixel array}
    %for ycoor=1,1,50 %cycle
       pixels(xcoor,ycoor)=0
    %repeat
  %repeat
  xcoor=1;ycoor=1                            {read in pixel array}
  %cycle
    %exit %if nextsymbol=':'
    readsymbol(sym)
    %if sym='*' %then %start
      pixels(xcoor,ycoor)=1;xcoor=xcoor+1
    %finish %else %if sym=' ' %then %start
      xcoor=xcoor+1
    %finish %else %if sym=NL %then %start
      ycoor=ycoor+1;xcoor=1
    %finish
  %repeat
%end

prompt("Font file: ")           {main program}
read(fontnam);skipsymbol
open input (1,fontnam.".FNT") ;open output(1,"protocol")
select input(1);select output(1)

{declare base font}
printsymbol(ESC);printsymbol(SP);write(0,2);printsymbol(';')
write(ysize,2);printsymbol(';');write(0,2);printsymbol(';');write(xsize,2)
printsymbol(SP);printsymbol('S');printsymbol(SP);printstring(fontnam);newline

{read and declare consecutive characters}
%for i=0,1,127 %cycle
   characters(i)=0
%repeat
%cycle
  getafter(':')
  %exit %if nextsymbol=':'
  readsymbol(character)
  getafter(NL)
  fillraster
  sendhead(character)               {send character}
  sendbitarray(black)
  characters(character)=1
%repeat
close input

{declare derived font}
printsymbol(ESC);printsymbol(SP);write(newfont,2);printsymbol(';')
write(ysize,0);printsymbol(';');write(0,2);printsymbol(';');write(xsize,2)
printsymbol(SP);printsymbol('T');newline
{send derived characters}
%for i=0,1,127 %cycle
  %if characters(i)#0 %then %start
    printsymbol(ESC);write(i,3);printsymbol(';');write(1,2);printsymbol(';')
    write(i,3);printsymbol(';');write(1,2);printsymbol(';');write(1,2);
    printsymbol(';');write(0,2);printsymbol(SP);printsymbol('I');
    printsymbol(SP);printstring(fontnam);newline
  %finish
%repeat

{text file}
select output(0);select input(0)
prompt("Text file: ");read(filenam);skipsymbol
open input(1,filenam)
select output(1);select input(1)
selectfont(newfont)
%while nextsymbol#':' %cycle
  startpage
  moveup(6*48)
  %for cy=1,1,50 %cycle
    %for cx=1,1,50 %cycle
      pixels(cx,cy)=pattern((cx+cy)&3)
    %repeat
  %repeat
  readsymbol(character)
  open input(2,fontnam.".FNT");select input(2)
  getafter(character);readsymbol(symbol)
  cx=1;cy=1
  %cycle
    %exit %if nextsymbol=':'
    readsymbol(symbol)
    %if symbol='*' %then %start
      pixels(cx,cy)=pixels(cx,cy)-32;cx=cx+1
    %finish %else %if symbol=' ' %then %start
      cx=cx+1
    %finish %else %if symbol=NL %then %start
      cy=cy+1;cx=1
    %finish
  %repeat
  close input
  %for cy=1,1,50 %cycle
    %for cx=1,1,50 %cycle
      printsymbol(pixels(cx,cy))
    %repeat
    newline
  %repeat
  select input(1)
%repeat
close output
%stop
%endofprogram