!****************************************************************
!*                                                              *
!*      IFFSPLAT:   Program translates 2 grey level IFF files   *
!*                  to CLAN or APM laser printer format         *
!*                                                              *
!*                  Version 1.3   29 Jan 1987                   *
!*                                                              *
!****************************************************************

!1.2 more error-tolerant    1.3 heap-gobbling stopped
!Parameters are <iff file>,<iff file>,..../<output file>
!Currently set up for LAYOUT 2.0

%include "inc:util.imp"
%include "iffinc.imp"
%include "inc:fs.imp"
%include "inc:fsutil.imp"
%begin

%constinteger layout15 = 15, layout20 = 20
%record (iffhdr fm) iffhdr
%string (255) mapfile,root,infiles,infile, outfile, param, extn, s1, s2, sscale
%string (255) banstring

%integer scaleX,scaleY,x,y,a,xc,yc

%routine error(%string (255) s)
  %integer o
  o = outstream
  selectoutput(0)
  printline("Iffsplat: ".s)
  selectoutput(o)
%end

%constintegerarray hex(0:15) = %c
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'

%routine display(%record (iffhdr fm) %name iffhdr, %integer bufp, layout)
   %integer i,j,k,l,p,wid,bp,bc,mask,c,rl,lastc
   %bytearray bx(0:255)
   %bytearray buff(0:2047)

   %routine flush
      !!printsymbol('['); write(rl, -1); printsymbol(',');write(lastc,-1); printsymbol(']')
      !JHB limits runs to 64.  Note this generates characters >=128.
      %while rl>=64 %cycle
         rl=rl-64
         printsymbol('w'+64-3); printsymbol(lastc)
      %repeat
      %if rl<=0 %start
         !Do nothing
      %elseif rl=1
         printsymbol(lastc)
      %elseif rl=2
         printsymbol(lastc); printsymbol(lastc)
      %else
         printsymbol('w'+rl-3); printsymbol(lastc)
      %finish
      lastc=c; rl=1
   %end

%if layout = layout15 %start ;! ********************* PROTOTYPE **************
   !For each line..
   !Pack each set of 8 bits scaleX times into an array then unscramble it
   !nibble at a time
   wid = (iffhdr_wid+15)&(\15)
   %if iffhdr_ht & 15 # 0 %start
      %for i=1,1,16 - (iffhdr_ht & 15) %cycle
         %for j = 0, 1, wid>>2-1 %cycle
            printsymbol('0')
         %repeat
         newline
      %repeat
   %finish

   wid = iffhdr_wid>>3 ;!Width of bit-image in nibbles
   %for i=0, 1, iffhdr_ht-1 %cycle
      bp=0
      %for j=0, 1, wid-1 %cycle
         %for k=0, 1, scaleX-1 %cycle; bx(k)=0; %repeat
         bc=0;mask=128
         %for k=1, 1, 8 %cycle ;!8 pixels at a time
            %if byteinteger(bufp) # 0 %start
              %for l=1, 1, scaleX %cycle
                 bx(bc) = bx(bc) + mask
                 mask=mask>>1; %if mask=0 %then bc=bc+1 %and mask=128
              %repeat
            %else
              %for l=1, 1, scaleX %cycle
                 mask=mask>>1; %if mask=0 %then bc=bc+1 %and mask=128
              %repeat
            %finish
            bufp=bufp+1
         %repeat
         %for k=0, 1, scaleX-1 %cycle
            buff(bp) = hex(bx(k)&15); bp=bp+1
            buff(bp) = hex(bx(k)>>4&15); bp=bp+1
         %repeat
      %repeat
      !and any fragment at end of line..
      %if iffhdr_wid&7 # 0 %start
         %for k=0, 1, scaleX-1 %cycle; bx(k)=0; %repeat
         bc=0;mask=128
         %for k=1, 1, iffhdr_wid&7 %cycle
            %if byteinteger(bufp) # 0 %start
              %for l=1, 1, scaleX %cycle
                 bx(bc) = bx(bc) + mask
                 mask=mask>>1; %if mask=0 %then bc=bc+1 %and mask=128
              %repeat
            %else
              %for l=1, 1, scaleX %cycle
                 mask=mask>>1; %if mask=0 %then bc=bc+1 %and mask=128
              %repeat
            %finish
            bufp=bufp+1
         %repeat
         %for k=0, 1, scaleX-1 %cycle
            buff(bp) = hex(bx(k)&15); bp=bp+1
            buff(bp) = hex(bx(k)>>4&15); bp=bp+1
         %repeat
      %finish
      %if iffhdr_wid & 15 < 8 %start
         buff(bp)='0'; bp=bp+1
         buff(bp)='0'; bp=bp+1
      %finish

      %for j=0, 1,scaleY-1 %cycle
         %for k=0, 1, bp-1 %cycle
            printsymbol(buff(k))
         %repeat
         newline
      %repeat
   %repeat
   newline
%else ;! ******************** CLAN PRINTER **************************
   !Clan format is six bits at a time, with '0' added. Incorporates compression.
   ! ('w'+n), (c)  is a run of <n+3> times character <c>.
   ! " (ditto) means this line is the same as the one before.

   %for i=0, 1, iffhdr_ht-1 %cycle ;!for all lines..
      lastc=-1; rl=0
      bc=0;mask=0
      %for j=0, 1, iffhdr_wid-1 %cycle ;!for all pixels in line..
         !Threshhold: 0 prints black, #0 prints white. Inverse of video.
         %if byteinteger(bufp) = 0 %then p=1 %else p=0; bufp=bufp+1
         %for l=1, 1, scaleX %cycle ;!pack in scaleX of the appropriate bit..
            bc = bc<<1 + p
            mask=mask+1
            %if mask=6 %start  ;!..and record the character every six bits.
                               ;!Just count runs - FLUSH prints the run at end.
               c='0'+(bc&63)
               %if c=lastc %then rl=rl+1 %else flush
               mask=0; bc=0
           %finish
         %repeat
      %repeat
      !Do any left-over fragment at the end of a line
      %while mask#0 %cycle ;!shift any bits to top of byte
         bc=bc<<1; mask=mask+1; %if mask=6 %then mask=0
      %repeat
      c='0'+(bc&63)
      %if c=lastc %then rl=rl+1
      flush  ;!..and terminate any unfinished run
      newline
      %if scaleY>1 %start  ;!we've printed the line so can follow up with dittos
         %for j=0, 1,scaleY-2 %cycle
            printsymbol('"'); newline
         %repeat
      %finish
   %repeat
   newline
%finish
%end

%routine send header(%integer layout,x,y); ! GRAPHICAL BITMAP REPRESENTATION
  %constinteger bufsize=256
  %integer wid, ht, i
  %routine leadin
     printsymbol(27); printsymbol('[')
  %end

%if layout = layout15 %start ;! ********************* PROTOTYPE *************

  wid = (iffhdr_wid+15)&(\15)
  ht =  (iffhdr_ht+15)&(\15)
  %for i=1,1,3 %cycle
     printstring("$b0 ".banstring); newline
  %repeat
  leadin; printstring(" 0D")
  leadin; printstring(" 0A")
  leadin; printstring(" 0;")
  write(ht*scaleY,-1)
  printstring(";0;")
  write(wid*scaleX,-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 do file(%string (255) file)
   %integer rc, i
   rc = iff open file(file, iffhdr, iff read)
   %if rc=0 %start
      rc = iff read header(iffhdr)
      %if rc=0 %start
         selectoutput(0)
         iff show header(iffhdr, 0)
         selectoutput(2)

         !We keep a cursor at the bottom RH corner (+ a margin) from the last frame.
         !We keep putting frames across the page till we run out (advancing the x
         !cursor after each move and advancing the y cursor if the new frame reaches
         !further down the page than the last one).  We then plot the next frame
         !at the y cursor (with x=0) and advance the x and y cursors as before.

         %for i = 0, 1, iffhdr_stereo %cycle
            a = heapget(iffhdr_wid*iffhdr_ht)
            rc = iff read image(iffhdr, a)
            error(file." Image ".itos(i,-1)." read")
            %if xc+iffhdr_wid*scaleX<=2048 %then x=xc %elsestart
              y=yc; x=0
            %finish
            send header(layout20, x, y)
            xc=x+iffhdr_wid*scaleX+150
            %if y+iffhdr_ht*scaleY+150>yc %then yc=y+iffhdr_ht*scaleY+150
            display(iffhdr, a, layout20)
            error(file." Image ".itos(i,-1)." of ".itos(iffhdr_stereo,-1)." at (".%c
            itos(x,-1).",".itos(y,-1).")")
            heapput(a)
         %repeat
      %finishelse error("Iffsplat ".file." fails - ".iff error(rc))
      iff close file(iffhdr)
   %finishelse error("Iffsplat ".file." fails - ".iff error(rc))
%end

%routine strip spaces(%string (255) %name s)
   %integer i, j
   %return %if s=""
   j=1
   %for i=1,1,length(s) %cycle
      charno(s,j) = charno(s,i) %and j=j+1 %if charno(s,i)#' '
   %repeat
   length(s) = j-1
%end

infiles=cli param
outfile="" %unless infiles -> infiles.("/").outfile
root=infiles %unless infiles -> root.(".").extn
%if root -> extn.(":").root %then %start; %finish
%if outfile="" %then outfile=root
outfile = outfile.".lay" %unless outfile -> s1.(".").s2

prompt("Scale(s):"); 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") %and %stop

openoutput(2, outfile); selectoutput(2)

banstring = "*** User:".current user
banstring = banstring." " %while length(banstring) < %c
60-length(outfile)
banstring = banstring."   File:".outfile."     ".date."  ".time." ***"
printline(banstring); newlines(2)

xc=0; yc=0; x=0; y=100
printstring("$g1"); newline ;!LAYOUT20

%while infiles -> infile.(",").infiles %cycle
   strip spaces(infile)
   do file(infile)
%repeat
do file(infiles)

printstring("$e*"); newline ;!LAYOUT20
close output
%end
  
%endofprogram
