%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:4,1:4),picture(0:255,0:255)
%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(4,2);printsymbol(';');write(0,2);printsymbol(';');write(4,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 x1,dx,x2,y1,dy,y2)
%shortinteger accum,xcoor,ycoor
  %for ycoor=y1,dy,y2 %cycle
     accum=0
     %for xcoor=x1,dx,x2 %cycle
          accum=(accum<<1)+pixels(xcoor,ycoor)
     %repeat
     phex1(accum);newline
  %repeat
%end

%routine fillraster                    {starts after char NL and halts before :}
%integer xcoor,ycoor
%byteinteger sym
  %for xcoor=1,1,4 %cycle                   {clear pixel array}
    %for ycoor=1,1,4 %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:17)=%c
{    0,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30,40,255
    { 0,14,21,28,35,42,49,56,63,70,77,84,91,98,108,120,135,255
{  %while intens>ranges(a+1) %cycle
{    a=a+1
{  %repeat
{  %result=a
  %result=intens>>4
%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(4,2);printsymbol(';');write(0,2);printsymbol(';');write(4,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(1,1,4,1,1,4)
  characters(character)=1
  sendhead(character+17);sendbitarray(4,-1,1,1,1,4)
  characters(character+17)=1
%repeat

{declare derived font}
printsymbol(ESC);printsymbol(SP);write(newfont,2);printsymbol(';')
write(4,0);printsymbol(';');write(0,2);printsymbol(';');write(4,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)
selectfont(newfont)
black=nextsymbol;white=nextsymbol
%for y=0,1,255 %cycle
  %for x=0,1,255 %cycle
    readsymbol(picture(x,y))
  %repeat
%repeat
%for y=0,1,255 %cycle
  %for x=0,1,255 %cycle
    printsymbol(greymap(picture(x,y))+33+17*((x+y)-2*((x+y)//2)))
  %repeat
  newline
%repeat
close output
%stop
%endofprogram