%include "i:util.inc"
%begin
%constant %shortinteger newfont=20
%constant %byteinteger ESC=27,SP=32
%byteinteger fwidth,fheight,character,symbol,white,black,large,basedith
%integer i,j,x,y,bottom,top,left,right,acc,inten
%byte %array characters(0:127),pixels(1:10,1:10),picture(0:255,0:255)
%integerarray intens(0:255)
%string (50) filenam


%routine scolon
  printsymbol(';')
%end

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

%routine chardefhead(%byte %integer a)
  printsymbol(ESC);write(a,4);scolon;
  write(fheight,2);scolon;write(0,2);scolon;write(fwidth,2);
  scolon;write(0,2);printsymbol(SP);printsymbol('K');newline
%end

%routine selectfont(%shortinteger font)
  printsymbol(ESC);write(font,5);printstring(" F")
%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
     phex2(accum<<3);newline
  %repeat
%end

%routine fillraster                    {starts after char NL and halts before :}
%integer xcoor,ycoor
%byteinteger sym
  %for xcoor=1,1,fwidth %cycle                   {clear pixel array}
    %for ycoor=1,1,fheight %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 shade)
  %integer a=0
  %result=0 %if shade <= black
  a=shade; a=white %if shade>=white
  %result=(21*(a-black))//(white-black+1) %if large=0
  %result=(80*(a-black))//(white-black+1)
%end

fheight=4;fwidth=5
open input (1,"GREY21.FNT") ;open output(1,"protocol")
select input(1);select output(1)

{declare base font}
printsymbol(ESC);printsymbol(SP);write(0,2);scolon
write(fheight,2);scolon;write(0,2);scolon;write(fwidth,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
  chardefhead(character);sendbitarray(1,1,fwidth,1,1,fheight)
  characters(character)=1
  chardefhead(character+21);sendbitarray(fwidth,-1,1,1,1,fheight)
  characters(character+21)=1
%repeat

{declare derived font}
printsymbol(ESC);printsymbol(SP);write(newfont,2);scolon
write(fheight,0);scolon;write(0,2);scolon;write(fwidth,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);scolon;write(1,2);scolon
    write(i,3);scolon;write(1,2);scolon;write(1,2);
    scolon;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
close input; select input(0); select output(0)
{ do the clipping
prompt("left   :");read(left);skipsymbol
prompt("right  :");read(right);skipsymbol
prompt("bottom :");read(bottom);skipsymbol
prompt("top    :");read(top);skipsymbol
%for i=0,1,255 %cycle; intens(i)=0;%repeat
{work out intensities
%for y=255-top,1,255-bottom %cycle
  %for x=left,1,right %cycle
    intens(picture(x,y))=intens(picture(x,y))+1
  %repeat
%repeat
%for i=0,1,31 %cycle
  phex2(i<<3);acc=0
  %for j=0,1,7 %cycle; acc=acc+intens(8*i+j);%repeat
  %for j=1,1,acc>>7 %cycle;printsymbol('*');%repeat
  newline
%repeat
prompt("black: ");read(black);skipsymbol
prompt("white: ");read(white);skipsymbol
prompt("size : ");read(large);skipsymbol
select output(1)
%for y=255-top,1,255-bottom %cycle
  %if large=0 %then %start
    %for x=left,1,right %cycle
      printsymbol(greymap(picture(x,y))+33+21*((x+y)-2*((x+y)//2)))
    %repeat
    newline
  %finish %else %start
    %for i=0,1,1 %cycle
      %for x=left,1,right %cycle
        inten=greymap(picture(x,y))
        basedith=(inten//4+33)&255   {base dither
        symbol=basedith+i*21
        symbol=symbol+1 %if inten&3 > 2*i+1
        printsymbol(symbol)
        symbol=basedith+(1-i)*21
        symbol=symbol+1 %if inten&3 > 2*i
        printsymbol(symbol)
      %repeat
      newline
    %repeat
  %finish
%repeat
close output
%stop
%endofprogram