!****************************************************************
!*                                                              *
!*      IFFDOT:   Program translates 255 grey level IFF files   *
!*                to {CLAN or} APM laser printer format         *
!*                                                              *
!*                  Version 1.1   23 Jan 1987                   *
!*                                                              *
!****************************************************************

!Parameters are <iff file>/<output file>
!This is the "dot" program (GJB/AB) translated to IMP
%include "inc:util.imp"
%include "iffinc.imp"
%begin

%constinteger layout15=15, layout20=20
%record (iffhdr fm) iffhdr
%integer a
%constinteger TABLEWIDTH=256;  ! conversion map
%ownstring (255) DEFMAPFILE ="ab:map.dat"
!!Const array is the above file, included to reduce dependencies
%ownbytearray conv(0:TABLEWIDTH-1) = %c
16_00,16_FF,16_FF,16_FE,16_FE,16_FD,16_FD,16_FC,
16_FC,16_FB,16_FB,16_FA,16_FA,16_F9,16_FC,16_FB,
16_FB,16_FB,16_FB,16_FA,16_FA,16_FA,16_FA,16_F9,
16_F9,16_F9,16_F8,16_F8,16_F8,16_F8,16_F7,16_F7,
16_F7,16_F7,16_F6,16_F6,16_F6,16_F6,16_F5,16_F5,
16_F5,16_F5,16_F4,16_F4,16_F4,16_F4,16_F3,16_F3,
16_F3,16_F3,16_F2,16_F2,16_F2,16_F1,16_F1,16_F1,
16_F1,16_F1,16_F0,16_F0,16_F0,16_EF,16_EF,16_EF,
16_EE,16_EE,16_EE,16_ED,16_ED,16_ED,16_EC,16_EC,
16_EC,16_EB,16_EB,16_EB,16_EA,16_EA,16_EA,16_EA,
16_E9,16_E9,16_E9,16_E8,16_E8,16_E8,16_E7,16_E7,
16_E7,16_E6,16_E6,16_E6,16_E5,16_E5,16_E5,16_E4,
16_E4,16_E4,16_E3,16_E3,16_E5,16_E5,16_E5,16_E4,
16_E4,16_E4,16_E4,16_E3,16_E3,16_E3,16_E3,16_E2,
16_E2,16_E2,16_E2,16_E1,16_E1,16_E1,16_E1,16_E0,
16_E0,16_E0,16_E0,16_DF,16_DF,16_DF,16_DE,16_DE,
16_DE,16_DE,16_DD,16_DD,16_DD,16_DD,16_DC,16_DC,
16_DC,16_DC,16_DB,16_DB,16_DB,16_DB,16_DA,16_DA,
16_DA,16_DA,16_D9,16_D9,16_D9,16_D9,16_D8,16_D8,
16_D8,16_D7,16_D7,16_D7,16_D7,16_D6,16_D6,16_D6,
16_D6,16_D5,16_D5,16_D5,16_D5,16_D4,16_D4,16_D4,
16_D4,16_D3,16_D3,16_D3,16_D3,16_D2,16_D2,16_D1,
16_D0,16_CF,16_CE,16_CD,16_CC,16_CB,16_CA,16_C9,
16_C8,16_C7,16_C6,16_C5,16_C4,16_C3,16_C2,16_C1,
16_C0,16_BF,16_BE,16_BD,16_BC,16_BB,16_BA,16_B9,
16_B8,16_B7,16_B6,16_B5,16_B4,16_B3,16_B2,16_B1,
16_B0,16_AF,16_AE,16_AD,16_AC,16_AB,16_AA,16_A9,
16_A8,16_A7,16_A6,16_A5,16_A4,16_A3,16_A2,16_A1,
16_A0,16_9F,16_9E,16_9D,16_9C,16_9B,16_9A,16_99,
16_98,16_97,16_96,16_95,16_94,16_93,16_92,16_91,
16_87,16_7E,16_74,16_6A,16_61,16_57,16_4D,16_44,
16_3A,16_30,16_27,16_1D,16_13,16_0A,16_00,16_1F
%constinteger PATTERNSIZE=8
%string (255) mapfile,root,infile, outfile, param, extn, s1, s2, sscale

%owninteger lflag       = 0; ! direct output to laserprinter dir
%owninteger screen flag = 0; ! output meant for doc:lg1 program display
%owninteger dflag       = 0; ! Debugging/displaying
%owninteger xsize       = 0; ! pic file size                         
%owninteger mflag       = 0; ! Default (linear) map or external map

%owninteger argc=0, argv=0
%integer hlen,i,j,arg,rc

%routine error(%string (255) s)
  selectoutput(0)
  printline("Dot: ".s)
  %stop
%end

%routine showmap
 %integer i

  printstring("conv(0:"); write(TABLEWIDTH-1,-1); printstring(")"); newline
  %for i=0,1,TABLEWIDTH-1 %cycle
     write(conv(i), 3)
     %if i&15=15 %then newline
  %repeat
  newline
%end

%routine invertmap
  %integer i
  %for i=0,1,TABLEWIDTH-1 %cycle
     conv(i) <- \conv(i)
  %repeat
%end

%routine readmap
  %integer i, a

  %if mflag=0 %start
     !Linear map
     %for i=0,1,TABLEWIDTH-1 %cycle
        conv(i)=i
     %repeat
  %elseif mapfile=""
     !Default is in CONV already

  %elseif exists(mapfile)
     openinput(1, mapfile); selectinput(1)
     printstring("reading map file...")
     %for i=0,1, TABLEWIDTH-1 %cycle
        readsymbol(conv(i))
     %repeat
     closeinput
     printline("read")
  %else
     error("can't read map file ".mapfile) 
  %finish

  invertmap %if screen flag = 0
  showmap   %if dflag       # 0
%end

%constinteger MAXBUF=2048
%bytearray buf(0:MAXBUF-1)
%integer bufsize
%owninteger scaleY=1, scaleX=1;       ! blow up scale


%constinteger MAXD=16
%constinteger MAXDSQR=256
%bytearray dither(0:MAXDSQR-1)
%constintegerarray hex(0:15) = %c
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'

! The two char arrays below are combined to form the dither matrix. 
! 16 submatrices similar to "dithfont" are combined as a 4 by 4 set
! To produce a 16 by 16 matrix. Each submatrix in the matrix has a
! positional correspondence with an element in the matrix "random".
! For each submatrix every element it contains is incremented by
! the value held in the "corresponding" element of the matrix "random"

! From Foley & Van Dam
%constintegerarray random(0:15) = %c
   0, 8, 2,10,
  12, 4,14, 6,
   3,11, 1, 9,
  15, 7,13, 5

! designed to clump dots
%constintegerarray dithfont(0:15) = %c
   0, 1, 4, 9,
   2, 3, 5,10,
   6, 7, 8,11,
  12,13,14,15

! DITHER MATRIX PRODUCTION
%routine make dith;             ! writen for clarity rather than speed 
  %integer r,c,row,col
  %for r=0,1,3 %cycle
    %for c=0,1,3 %cycle
      %for row=0,1,3 %cycle
        %for col=0,1,3 %cycle
          dither(4*(c+r*MAXD)+col+row*MAXD) = %c
                                         16*dithfont(row*4+col)+random(r*4+c)
        %repeat
      %repeat
    %repeat
  %repeat
%end

%routine show dither
%integer i,j
  
  printstring("Dither(0:"); write(MAXD*MAXD-1,-1); printstring(")"); newline
  %for j=0,1,MAXD-1 %cycle
     %for i=0,1,MAXD-1 %cycle
        write(dither(j*MAXD+i)&16_FF, 3)
     %repeat
     newline
  %repeat
  newline
%end

%routine report
  selectoutput(0)
  printline("Your options were :")
  %if screen flag#0 %then printline %c
                 ("inversed dot pattern for screen viewing.")
  %if lflag#0 %then printline("output sent to laser printer directory")
  %if mflag=0 %start
     printstring("linear map")
  %elseif mapfile=""
     printstring("internal map (".mapfile.")")
  %else
     printstring(mapfile)
  %finish
  printline(" used to scale grey levels")
  printline("  picture file  size = ".itos(iffhdr_wid,-1))
  printline("  scaling factors = ".itos(scaleX,-1)."/".itos(scaleY,-1))
  printline("Output file is called ".outfile)
%end

%routine display
 %integer s, d count, j, gptr, aptr

 %on 3,9 %start
    error("can't open output file ".outfile." ".event_message)
 %finish

%routine dot line(%integer gptr, %bytearrayname bufp)
  %integer i,k,dot pattern, bptr, dptr, d count

  dptr=0; bptr=0
  d count=0; i=0
  %while i<bufsize %cycle
    dot pattern=0
    %for k=0,1,PATTERNSIZE-1 %cycle
      dot pattern=dot pattern<<1
      %if i<bufsize %start;  i=i+1
         dot pattern = dot pattern ! 1 %if bufp(bptr) >= dither(gptr+dptr) & 16_FF
         bptr=bptr+1
         %if d count<MAXD-1 %then d count=d count+1 %and dptr=dptr+1 %c
         %else d count=0 %and dptr=0
      %finish
    %repeat
    printsymbol(hex(dot pattern&16_0F))
    printsymbol(hex(dot pattern>>4))
 %repeat
 space
%end

%routine send header(%integer layout, x,y); ! GRAPHICAL BITMAP REPRESENTATION
  %integer i
  %routine leadin
     printsymbol(27); printsymbol('[')
  %end

%if layout = layout15 %start ;! ********************* PROTOTYPE *************
!!  %for i=1,1,3 %cycle
!!     printstring("$b0 ".banstring); newline
!!  %repeat
  leadin; printstring(" 0D")
  leadin; printstring(" 0A")
  leadin; printstring(" 0;"); write(bufsize,-1)
  printstring(";0;"); write(bufsize,-1)
  printstring(";0G"); newline
%else ;! ***************************** CLAN **********************
   printstring("X("); write(x,-1); printsymbol(')'); newline
   printstring("Y("); write(y,-1); printsymbol(')'); newline
   printstring("B(")
   write(iffhdr_wid*scaleX,-1); printsymbol(','); write(iffhdr_ht*scaleY,-1)
   printsymbol(')'); newline
%finish
%end

%routine getbuf(%bytearrayname buf)
   !JHB 24/8/87 - increment bufp from 0 not decrement from scaleX*iffhdr_wid-1
   %integer i,s,c,bufp
!! bufp=scaleX*iffhdr_wid-1
{} bufp=0
   %for i=0,1,iffhdr_wid-1 %cycle
      c = conv(byteinteger(a+aptr)); aptr=aptr+1
      %for s=0,1,scaleX-1 %cycle
{}       buf(bufp) = c; bufp=bufp+1
!!       buf(bufp) = c; bufp=bufp-1
      %repeat
   %repeat
%end

  %if iffhdr_wid<1 %then error("negative picture size")
  bufsize=scaleX*iffhdr_wid
  error("picture too wide at this scale") %if bufsize>MAXBUF
  aptr=0
  openoutput(2, outfile); selectoutput(2)

  send header(layout15,0,0)
  d count=0
  gptr=0
  %for j=0,1,iffhdr_wid-1 %cycle
    getbuf(buf)
    %for s=0,1,scaleY-1 %cycle
      dot line(gptr,buf)
      %if d count<MAXD-1 %then d count=d count+1 %and gptr=gptr+MAXD %c
      %else d count=0 %and gptr=0
    %repeat
  %repeat
  selectoutput(2); newline; ! end of last line 
  close output
  selectoutput(0)

%end

%routine check grey levels
   %real scale
   %integer p,q,r,from,blue,green,red,i,cval,ix
   %integerarray tot,intensity(0:255)

!!   !Compute a histogram of grey values
!!   %for p=0,1,255 %cycle; tot(p)=0; %repeat
!!   ix=a
!!   %for q=0,1,iffhdr_wid*iffhdr_ht-1 %cycle
!!      tot(byteinteger(ix)) = tot(byteinteger(ix))+1
!!      ix=ix+1
!!   %repeat

   %if iffhdr_mapaddr#0 %start ;!There's a map
      scale = 255/(31*31*3)
      %for i=0, 1, iffhdr_maplen-1 %cycle
         cval = halfinteger(iffhdr_mapaddr+i<<1)
         blue = (cval>>10)&31; green = (cval>>5)&31; red = cval&31
         intensity(i) = int(sqrt(scale*(blue*blue + green*green + red*red)))
         !Intensity = R-M-S of gun values (empirical). Scale intensities to 0-255
      %repeat

      ix=a
      %for i=0, 1, iffhdr_ht*iffhdr_wid-1 %cycle
         byteinteger(ix) = intensity(byteinteger(ix)); ix=ix+1
      %repeat
   %finish

%end

infile=cli param
outfile="" %unless infile -> infile.("/").outfile
root=infile %unless infile -> root.(".").extn
%if root -> extn.(":").root %then %start; %finish
infile = infile.".iff" %if exists(infile.".iff")
%if outfile="" %then outfile=root.".dot"
mapfile=defmapfile
prompt("Scale(s):"); readline(sscale)
s1=sscale %and s2=sscale %unless sscale -> s1.("/").s2
scaleX = stoi(s1); scaleY = stoi(s2)
prompt("Invert (0/1):"); read(screen flag)

%if scaleX<1 %or scaleY<1 %then error("negative scaling factor")
!!    %elseif arg = 'i'             {i for inverse }
screen flag=1 %if screen flag#0
!!    %elseif arg = 'l'
!!      lflag=1

%if mflag=0 %start
   printline("using linear map")
%elseif mapfile=""
   printline("using internal map")
%else
   printline("using ".mapfile.".")
%finish

!Not interested in colour map if present
a=0
rc = iff readin(infile, iffhdr, a)
iff show header(iffhdr, 0)
check grey levels

  readmap;      ! placed here to avoid using fp twice
  %if argc=2 %start
    %if lflag#0 %then error("no output filename if sending direct to laser printer")
  %finish

  %if lflag#0 %and screen flag#0 %start
    selectoutput(0)
    printline("warning : you are sending screen inverted output to the printer")
  %finish
  make dith
  show dither %if dflag # 0
  {test} printline("Displaying")
  display
  newline
  report
  printsymbol(7);       ! BEEP
  heapput(a)
%end
  
%endofprogram