!****************************************************************
!*                                                              *
!*      IFFDOT:   Program translates 255 grey level IFF files   *
!*                to {CLAN or} APM laser printer format         *
!*                                                              *
!*                  Version 1.2   23 Feb 1988                   *
!*                                                              *
!****************************************************************

%conststring version = "V1.2"
!Parameters are <iff file>/<output file>
!This is the "dot" program (GJB/AB) translated to IMP by JHB and cut down.
%include "inc:util.imp"
%include "iffinc.imp"
%include "inc:fs.imp"
%include "inc:fsutil.imp"
%begin

%integer layout, orientation, warn
%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

%integerfn grey(%halfinteger val)
   %integer red, green, blue
   red   = val & 31; val=val>>5
   green = val & 31; val=val>>5
   blue  = val & 31
   %result=green<<3 %if red=green %and green=blue
   %result=green<<3 ;!Hook
%end

%routine readmap(%record (iffhdr fm) %name iffhdr)
  %integer i, a
   
%if iffhdr_mapaddr=0 %start ;!No map
   printline("using 0-255 linear map")
   %for i=0,1,TABLEWIDTH-1 %cycle
      conv(i)=i
   %repeat

%elseif iffhdr_maplen#0 ;!Map in IFF file
   printline("using supplied map")
   %for i=0,1,iffhdr_maplen-1 %cycle
      conv(i) = grey(halfinteger(iffhdr_mapaddr+i+i))
   %repeat

%elseif exists(mapfile) ;!Bum map supplied but there's a map file.  <??????>
   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 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 protoprint(%integer scaleX,scaleY,ad)
   %integer s, d count, j, gptr, aptr

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

   %routine send header(%integer x,y); ! GRAPHICAL BITMAP REPRESENTATION
     %integer i
     %routine leadin
        printsymbol(27); printsymbol('[')
     %end {of leadin in send header in protoprint}

!!   %for i=1,1,3 %cycle;     printstring("$b0 ".banstring); newline;  %repeat
     leadin; printstring(" 0D")
     leadin; printstring(" 0A")
     leadin; printstring(" 0;"); write(iffhdr_ht*scaleY,-1)
     printstring(";0;"); write(iffhdr_wid*scaleX,-1)
     printstring(";0G"); newline
   %end {of send header in protoprint}

   %routine send trailer
      newline; ! end of last line 
   %end
   
  %routine dot line(%integer dp, %bytearrayname bufp)
      %integer d1p, d count, b count, bptr, dot pattern,bufsize
      bufsize = iffhdr_wid * scaleX
      d1p=dp; d count=0
      dot pattern=0; bcount=0
      %for bptr=0,1,bufsize-1 %cycle
        dot pattern=dot pattern<<1
        dot pattern = dot pattern ! 1 %if bufp(bptr) >= dither(dp) & 16_FF
        
        %if dcount<MAXD-1 %then dp=dp+1 %and dcount=dcount+1 %else %c
        d count=0 %and dp=d1p 
        bcount=bcount+1
        %if bcount=8 %start
           printsymbol(hex(dotpattern&16_0F))
           printsymbol(hex(dotpattern>>4))
           bcount=0; dot pattern=0
        %finish
      %repeat
      %if bcount#0 %start
         bcount=bcount+1 %and dot pattern = dot pattern<<1 %while b count#8
         printsymbol(hex(dot pattern&16_0F))
         printsymbol(hex(dot pattern>>4))
      %finish
      newline
%end {in protoprint}

!!%routine getbuf(%bytearrayname buf)
!!   %integer i,j,c,p
!!   p=0
!!   %for i=0,1,iffhdr_wid-1 %cycle
!!      c = conv(byteinteger(a+aptr)); aptr=aptr+1
!!      %for j=0,1,scaleX-1 %cycle
!!         buf(p) = c; p=p+1
!!      %repeat
!!   %repeat
!!%end


%routine getbuf(%integer ad, %bytearrayname buf)
   %integer i,j,p
   p=0
   %for i=0, 1, iffhdr_wid-1 %cycle
      %for j=0, 1, scaleX-1 %cycle
         buf(p) = conv(byteinteger(ad+i)); p=p+1
      %repeat
   %repeat
%end {in protoprint}

%integer d count,dp,j,s
%bytearray buf(0:4095)

send header(0,0)
d count=0; dp=0
%for j=0,1,iffhdr_ht-1 %cycle
  %if j&31=31 %start; selectoutput(0); printsymbol('.'); selectoutput(2); %finish
  getbuf(ad, buf); ad=ad+iffhdr_wid
  %for s=0,1,scaleY-1 %cycle
    dot line(dp,buf)
    %if d count<MAXD-1 %then d count=d count+1 %and dp=dp+MAXD %else %c
    d count=0 %and dp=0
  %repeat
%repeat
send trailer

%end {of protoprint}


%routine clanprint(%integer scaleX,scaleY,ad)

  %routine send header(%string (255) header, %integer x,y)
    printline(header)
    %if orientation#0 %start ;!Landscape
       printstring("$m>"); newline
    %finish
    printstring("$g1"); newline
    printstring("X("); write(x,-1); printstring(""")"); newline
    printstring("Y("); write(y,-1); printstring(""")"); newline
    printstring("B(")
    write(iffhdr_wid*scaleX,-1); printsymbol(','); write(iffhdr_ht*scaleY,-1)
    printsymbol(')'); newline
  %end {send header in clanprint}

  %routine send trailer
     newline; ! end of last line 
     printstring("$e*"); newline
  %end {send trailer in clanprint}

  %routine dot line(%integer dp, %bytearrayname bufp)
      %integer d1p, d count, b count, bptr, dot pattern,bufsize,cache

      %routine drop cache
         %integer c
         !Only one of these loops should be entered
         %while cache>0 %cycle ;!white space cached
             %if cache>=11 %then c=11 %else c=cache
             cache=cache-c
             %if c=1 %start
               printsymbol('0')
             %elseif c=3 ;!avoid printing '$'
               printstring("000")
             %else
               printsymbol(c+33)
             %finish
         %repeat

         %while cache<0 %cycle ;!Black space cached
             %if cache<=-8 %then c=8 %else c=-cache
             cache=cache+c
             %if c=1 %then printsymbol('o') %else printsymbol(c+110)
         %repeat         
      %end

      bufsize = iffhdr_wid * scaleX
      d1p=dp; d count=0; cache=0
      dot pattern=0; bcount=0
      %for bptr=0,1,bufsize-1 %cycle
        dot pattern=dot pattern<<1
        dot pattern = dot pattern ! 1 %if bufp(bptr) >= dither(dp) & 16_FF
        
        %if dcount<MAXD-1 %then dp=dp+1 %and dcount=dcount+1 %else %c
        d count=0 %and dp=d1p 
        bcount=bcount+1
        %if bcount=6 %start
           %if dotpattern=0 %start
              drop cache %if cache<0
              cache=cache+1
           %elseif dotpattern=16_3F
              drop cache %if cache>0
              cache=cache-1
           %else
              drop cache
              printsymbol(dotpattern+'0')
           %finish
           bcount=0; dot pattern=0
        %finish
      %repeat

      drop cache
      %if bcount#0 %start
         bcount=bcount+1 %and dot pattern = dot pattern<<1 %while b count#6
         printsymbol(dotpattern+'0')
      %finish
      newline
%end

%routine getbuf(%integer ad, %bytearrayname buf)
   %integer i,j,p
   p=0
   %for i=0, 1, iffhdr_wid-1 %cycle
      %for j=0, 1, scaleX-1 %cycle
         buf(p) = conv(byteinteger(ad+i)); p=p+1
      %repeat
   %repeat
%end {in clanprint}

%routine do bool line(%integer ad)
   %integer i,j,k,b,d,dot pattern,bcount,mask,cache

   %routine drop cache
      %integer c
      !Only one of these loops should be entered
      %while cache>0 %cycle ;!white space cached
          %if cache>=11 %then c=11 %else c=cache
          cache=cache-c
          %if c=1 %start
            printsymbol('0')
          %elseif c=3 ;!avoid printing '$'
            printstring("000")
          %else
            printsymbol(c+33)
          %finish
      %repeat

      %while cache<0 %cycle ;!Black space cached
          %if cache<=-8 %then c=8 %else c=-cache
          cache=cache+c
          %if c=1 %then printsymbol('o') %else printsymbol(c+110)
      %repeat         
   %end

   bcount=0; dot pattern=0; cache=0
   %for i=0, 1, (iffhdr_wid-1)>>3 %cycle
      b = byteinteger(ad+i)
      mask=128
      %for j=0,1,7 %cycle
         d=b&mask; mask=mask>>1
         %for k=0, 1, scaleX-1 %cycle
           dot pattern=dot pattern<<1
           dot pattern = dot pattern ! 1 %if d#0
           bcount=bcount+1
           %if bcount=6 %start
              %if dotpattern=0 %start
                 drop cache %if cache<0
                 cache=cache+1
              %elseif dotpattern=16_3F
                 drop cache %if cache>0
                 cache=cache-1
              %else
                 drop cache
                 printsymbol(dotpattern+'0')
              %finish
              bcount=0; dot pattern=0
           %finish
         %repeat
      %repeat
   %repeat

   drop cache
   %if bcount#0 %start
      bcount=bcount+1 %and dot pattern = dot pattern<<1 %while b count#6
      printsymbol(dotpattern+'0')
   %finish
   newline

   %if scaleY>1 %start
     %for i=1,1,scaleY-1 %cycle
        printline("""")
     %repeat
   %finish

%end

%integer d count,dp,j,s
%bytearray buf(0:4095)
%string (255) banstring

banstring=date." ".time."   User: ".current fs(0)."::".current user. %c
" - file: ".outfile." - generated from ".infile." using IFF:DOT ".version
send header(banstring, 0,1)
%if iffhdr_datatype & 7 = 2 %start ;!Packed boolean image
   %for j=0,1,iffhdr_ht-1 %cycle
      do bool line(ad); ad=ad+(iffhdr_wid-1)>>3+1
   %repeat
%else
   d count=0; dp=0
   %for j=0,1,iffhdr_ht-1 %cycle
     %if j&31=31 %start; selectoutput(0); printsymbol('.'); selectoutput(2); %finish
     getbuf(ad, buf); ad=ad+iffhdr_wid
     %for s=0,1,scaleY-1 %cycle
       dot line(dp,buf)
       %if d count<MAXD-1 %then d count=d count+1 %and dp=dp+MAXD %else %c
       d count=0 %and dp=0
     %repeat
   %repeat
%finish
send trailer

%end {of clanprint}

infile=cli param
!First split into infile and outfile (if specified)
outfile="" %unless infile -> infile.("/").outfile

!First infile.  Assume it has extension ".IFF" unless he specifies something
!else.  If <file>.IFF doesn't exist, use <file>.
root=infile %unless infile -> root.(".").extn
!use the <file> part, minus  directory.
%if root -> extn.(":").root %then %start; %finish
infile = infile.".iff" %if exists(infile.".iff")

!Now the outfile.  Add .LAY extension if no extension supplied
outfile=root %if outfile=""
outfile=outfile.".lay" %unless outfile -> root.(".").extn
to upper(outfile)

mapfile=defmapfile
prompt("Scale(s):")
%cycle
   readline(sscale)
   s1=sscale %and s2=sscale %unless sscale -> s1.("/").s2
   scaleX = stoi(s1); scaleY = stoi(s2)
   %if scaleX<1 %or scaleY<1 %then error("negative scaling factor")
%repeatuntil scaleX>=1 %and scaleY>=1

prompt("Invert (0/1):"); read(screen flag)
screen flag=1 %if screen flag#0

a=0
rc = iff readin(infile, iffhdr, a)
iff show header(iffhdr, 0)

%if outfile -> ("LP1:").s1 %start
  layout=1
%elseif outfile -> ("LP2:").s1 %or outfile -> ("LP3:").s1
  layout=2
%else
  prompt("1 for LP1 (Layout 1.5) format, 2 for LP2/3 (Layout 2.0) format:")
  read(layout) %until layout=1 %or layout=2
%finish

warn=0; orientation=0
%if layout=1 %start
   scaleX=2400//iffhdr_wid  %and warn=1 %if scaleX>2400//iffhdr_wid
   scaleY=3000//iffhdr_ht  %and warn=1 %if scaleY>3000//iffhdr_ht
%else
   %if scaleX>2400//iffhdr_wid %or scaleY>3000/iffhdr_ht %start
      orientation=1 ;!Try landscape
      scaleX=3000//iffhdr_wid  %and warn=1 %if scaleX>3000//iffhdr_wid
      scaleY=2400//iffhdr_ht  %and warn=1 %if scaleY>2400//iffhdr_ht
   %finish
%finish

%if warn#0 %start
   printstring("**** Warning:  Scales adjusted to ")
   write(scaleX,-1); printstring("/"); write(scaleY,-1)
   printstring(" to fit onto A4 paper ****")
   newline
%finish
printline("**** Image will be landscape ****") %if orientation#0
readmap(iffhdr);      ! placed here to avoid using fp twice
make dith
show dither %if dflag # 0
printline("Generating ".outfile)
openoutput(2, outfile); selectoutput(2)
%if layout=1 %then protoprint(scaleX,scaleY,a) %else clanprint(scaleX,scaleY,a)
close output; selectoutput(0)
newline
report
printsymbol(7);       ! BEEP
heapput(a)

%end
  
%endofprogram

%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