%include "i:util.inc"
%begin
%constant %shortinteger newfont=20,pagehight=3000,
                        pagewidth=3000
%constant %byteinteger ESC=27,SP=32
%byteinteger character,symbol,white,black
%integer i,x,y
%byte %array characters(0:127),pixels(1:6,1:6),picture(0:255,0:255),scale(0:36)
%string (50) 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(6,2);printsymbol(';');write(0,2);printsymbol(';');write(6,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
%shortinteger accum,xcoor,ycoor,bitcnt
  %for ycoor=1,1,6 %cycle
     accum=0
     %for xcoor=1,1,6 %cycle
          accum=(accum<<1)+pixels(xcoor,ycoor)
     %repeat
     phex2(accum);newline
  %repeat
%end

%routine fillraster                    {starts after char NL and halts before :}
%integer xcoor,ycoor
%byteinteger sym
  %for xcoor=1,1,6 %cycle                   {clear pixel array}
    %for ycoor=1,1,6 %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

%integer %function greymap(%integer intens)
  %integer a=0
  %own %byteinteger %array ranges(0:37)=%c
       0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14,%c
      15, 16, 17, 18, 19, 20, 22, 24, 26, 28, 30, 33, 36, 39, 42,%c
      46, 50, 55, 65, 80,100,145,255
  %while intens>ranges(a+1) %cycle
    a=a+1
  %repeat
  %result=a
%end

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

{declare base font}
printsymbol(ESC);printsymbol(SP);write(0,2);printsymbol(';')
write(6,2);printsymbol(';');write(0,2);printsymbol(';');write(6,2)
printsymbol(SP);printsymbol('S');printsymbol(SP);printstring(filenam);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);sendbitarray
  characters(character)=1
%repeat

{declare derived font}
printsymbol(ESC);printsymbol(SP);write(newfont,2);printsymbol(';')
write(6,0);printsymbol(';');write(0,2);printsymbol(';');write(6,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(filenam);newline
  %finish
%repeat

{text file}
select output(0);select input(0)
prompt("picture file: ");read(filenam);skipsymbol
open input(1,filenam);select input(1);select output(1)
{startpage
moveup(6*48)
selectfont(newfont)
black=nextsymbol;white=nextsymbol
%for y=0,1,255 %cycle
  %for x=0,1,255 %cycle
    readsymbol(picture(x,y))
    %if picture(x,y)>white %then %start
      white=picture(x,y)
    %finish
    %if picture(x,y)<black %then %start
      black=picture(x,y)
    %finish
  %repeat
%repeat
%for x=0,1,36 %cycle
  scale(x)=x+65
%repeat
%for y=0,1,255 %cycle
  %for x=0,1,255 %cycle
    printsymbol(scale(greymap(picture(x,y))))
  %repeat
  newline
%repeat
{endpage
close output
%stop
%endofprogram
                                                                                                                                                                                                                                                                                                                                                                                                                                                                           