%option "-nocheck-nodiag-nostack"
!****************************************************************
!*                                                              *
!*      IFFDISP:    Program displays JHB-modded IFF files       *
!*                                                              *
!*                  Version 1.1   22 Nov 1986                   *
!*                                                              *
!****************************************************************

%include ":l:src:util.imp"

!Takes a run-length encoded IFF' file, expands it, rearranges it and displays it.
!Expects correct header length (words not bytes)

!Encoding is...
!<char> {<repeat>}   repeated indefinitely
!<char> = 0  encodes as 0, 0
!<char> = 10 encodes as 0, 1
!e.o.f.      encoded as 0, 3
!<repeat>    encoded as 0, <count>, 4<=<count><=127
!            or         0 <count>>8> ! 128, <count>&255

!Header is uncompressed and is 1024 bytes long.  Format is IFF format published
!by Andrew Blake but extended by 512 bytes to include colour map.

!J. Butler Dec 85

%begin
%include ":l:level1:graphinc.imp"
%integer xo, yo, factor, max factor {!}
%string (255) param,infile,outfile, gendate,gentime, title
%bytearray a(0:1024*1024-1)
%integer hlen, wid, ht, junk, magic, type, cval, maplen
%owninteger i,j,k,r,c,cno,b,rl,rtot,d,plen,hptr,junkb
%integer max
%half %array CM (0:255)
%half %name CMp
%integer XOff,YOff,filelen,filstart,filptr,x,y,filend,filmark,rlleft,rlno,no
%byte Maps,Dump

%label eof,cycle,incycle
%bytefn next
!!   filptr=filptr+1 %if byteinteger(filptr)=10
!!   filptr=filptr+1
!!   %result=byteinteger(filptr-1)

   %label nonl

   *MOVEA.L filptr,A0
   *CMP.B  #10,0(A0)
   *BNE     nonl
   *ADDQ.L  #1,filptr
   *ADDQ.L  #1,A0

nonl:
   *ADDQ.L  #1,filptr
   *MOVE.B  0(A0),D0
   *rts

%end

%integerfn get byte
   !Uses globals RLNO, RLLEFT, FILPTR
   !Get the next character.  If it's in the middle of a run, decrement rlleft
   !and return. If it's the start of a new run, grab the new run count and
   !store char in rlno and run length (-1) in rlleft.   Remeber...
   !<char> = 0  encodes as 0, 0
   !<char> = 10 encodes as 0, 1
   !e.o.f.      encoded as 0, 3
   !<repeat>    encoded as 0, <count>, 4<=<count><=127
   !            or         0 <count>>8> ! 128, <count>&255

!!   %integer rl,no,k,filmark
!!   %if rlleft#0 %then rlleft=rlleft-1 %and %result=rlno
!!   no=next
!!   filmark=filptr
!!   %if no = 0 %start
!!      !next char. is 2nd byte of encoded char. or 1st byte K of run length
!!      no=next
!!      %if no=1 %start
!!         no=10
!!         filmark=filptr
!!         k=next
!!      %elseif no=0
!!         filmark=filptr
!!         k=next
!!      %elseif no=3
!!         %result=-1
!!      %else
!!         %signal 15,1 ;!We're in a twist
!!      %finish
!!   %else
!!      k=next
!!   %finish
!!   rl=next
!!   %if k=0 %and rl>=4 %start
!!      %if rl>127 %then rl=(rl&127)<<8+next
!!      rlleft=rl-1; rlno=no; %result=rlno
!!   %else
!!      filptr=filmark
!!      %result=no
!!   %finish

%label nonl1,nonl2,nonl3,nonl6,nonl7
%label noneleft,notone,notzero,notthree,nonzero,nolen,onelen

   *MOVE.L  rlleft,D0    ;!%if rlleft#0 %then rlleft=rlleft-1 %and %result=rlno
   *BEQ     noneleft 
   *SUBQ.L  #1,rlleft
   *MOVE.L  rlno,D0
   *rts

noneleft:
   *clr.l d0
   *movea.l filptr,a0

   *move.b (a0)+,d0
   *cmp.b #10,d0     ;!Get 1st character, ignoring linefeeds.
   *bne nonl1
   *move.b (a0)+,d0
nonl1:

   *MOVEa.L  a0,a1    ;!mark place immediately after it

   *MOVE.L  d0,d0        ;!If it's not zero, go see if a count follows
   *BNE     nonzero 

   !If it is zero, get next character
   *move.b (a0)+,d0
   *cmp.b #10,d0
   *bne nonl2
   *move.b (a0)+,d0
nonl2:

   *CMP.b   #1,d0       ;!Is it 00,01  (encoded LF)?
   *BNE     notone 

   *MOVE.b   #10,d0      ;!Yes.  Set to 10, mark place and look for count
   *MOVEa.L  a0,a1    ;!filmark=filptr
   *BRA     nonzero

notone:
   *MOVE.b  D0,D0        ;!Is it 00,00 (encoded 00)?
   *BNE     notzero 

   *MOVEa.L  a0,a1    ;!Yes. mark place and look for count
   *BRA     nonzero

notzero:
   *CMP.b   #3,D0       ;!Is it 00,03 (eof) ?
   *BNE     notthree 
   *MOVEQ   #-1,D0       ;!Yes. Result = -1.
   *move.l  a0,filptr
   *rts

notthree:
   *MOVE.L   #-2,D0      ;!Funny
   *rts

nonzero:
   *move.b (a0)+,d1
   *cmp.b #10,d1     ;!Get next byte.  Might be 0, leading to count
   *bne nonl3
   *move.b (a0)+,d1
nonl3:

   *MOVE.b  d1,D1        ;!Not 0 so not count.  Backpedal pointer & return
   *bne     nolen

   *clr.l  d2
   *move.b (a0)+,d2
   *cmp.b #10,d2     ;!Get one after that. If true count, will be >=4
   *bne nonl6
   *move.b (a0)+,d2
nonl6:

   *CMP.l   #4,D2       ;! >=4?
   *BLT     nolen        ;!No. Not a length

   *CMP.l   #127,D2
   *BLE     onelen       ;! <=127 = one-byte count.
   *AND.l   #127,d2     ;! > 127 = two-byte count.  And with 127, ..
   *LSL.L   #8,D2        ;!..shift up one byte

   *move.b (a0)+,d2
   *cmp.b #10,d2     ;! and read the bottom byte
   *bne nonl7
   *move.b (a0)+,d2
nonl7:

onelen:
   *SUBQ.L  #1,D2        ;!rlleft=rl-1; rlno=no; %result=rlno
   *MOVE.L  D2,rlleft
   *MOVE.b  d0,rlno
   *move.l a0,filptr    ;!update filptr
   *RTS        
nolen:
   *move.l a1,filptr
   *rts
%end

%routine Set Up
%integer i
%integer zero = 0
  %on 0 %start
    Print String ("Software requires a graphics system")
    Newlines (2)
    %stop
  %finish
  Offset (0,0)
  enable(16_FF)
  Colour (White)
  %for i = 0, 8, 248 %cycle
     Colour Map (i) = zero
     Colour Map (i+1) = 31
     Colour Map (i+2) = 31<<5
     Colour Map (i+3) = 31<<5+31
     Colour Map (i+4) = 31<<10
     Colour Map (i+5) = 31<<10+31
     Colour Map (i+6) = 31<<10+31<<5
     Colour Map (i+7) = 31<<10+31<<5+31
  %repeat
  Set Terminal Mode (Nopage)
%end

%routine Mix Colour (%byte Col, %integer Red, Green, Blue)
   Colour Map(Col)=Red+Green<<5+Blue<<10
%end

%routine rsymbol(%integername i)
   i=byteinteger(filptr); filptr=filptr+1
%end

%routine rshort(%integername i)
   i=byteinteger(filptr)<<8+byteinteger(filptr+1); filptr=filptr+2
%end

%routine rstring(%string (*) %name s, %integer maxlen)
   %integer c
   s=""
   %cycle
      c=byteinteger(filptr); filptr=filptr+1
      %exit %if c=0
      s=s.tostring(c)
   %repeatuntil length(s)=maxlen
%end

%routine zoom(%bytearrayname a(0:*), %integer factor)
   %integer i, j, k, l, ix, ifw, iw, jw
   %begin
      %label lp1
      %bytearray b(0:factor*factor*ht*wid-1)
      %for i=ht-1, -1, 0 %cycle
          
         ifw = i*factor*wid; iw = i*wid
 write(i, 5); newline
         %for j=factor-1, -1, 0 %cycle
            jw=j*wid
 
            %for k=0,1,wid-1 %cycle
                ix = (ifw+jw+k)*factor
                %for l=factor-1, -1, 0 %cycle
                   b(ix+l) = a(iw+k)
                %repeat
!!!   D2 is cycle variable (L) running from FACTOR-1 down to 0
!!    *MOVE.L  factor,D2
!!    *SUB.L   #1,d2
!!!   D1 is address we are copying to (IX+L) offset against B (A1)
!!    *MOVE.L  ix,D1
!!    *ADD.L   D2,D1
!!!   D0 is address we are copying from (IW+K) offset against A (A0)
!!    *MOVE.L  iw,D0
!!    *ADD.L   k,D0
!!!   No idea what this is for
!!    *MOVEA.L 8(A5),A3
!!!   Set up A and B base pointers
!!    *MOVEA.L a,A0
!!    *MOVEA.L b,A1
!!!   and copy...
lp1:
!!    *MOVE.B  0(A0,D0.L),0(A1,D1.L)
!!    *SUBQ.L  #1,D1
!!    *SUBQ.L  #1,D2
!!    *BGE     lp1

            %repeat
         %repeat
      %repeat
      col fill(0,0, 0+wid*factor-1, 0+ht*factor-1, b(0))
   %end
%end

!!%routine zoom(%bytearrayname a(0:*), %integer factor)
!!    %integer i, j, k, l, ix, ifw, iw, jw
!!    %begin
!!       %bytearray b(0:factor*factor*ht*wid-1)
!!       %label L2,L3,L4,L6,L8
!!    *MOVEQ   #1,D0
!!    *MOVEQ   #0,D1
!!    *MOVE.L  D0,-(A7)
!!    *MOVE.L  D1,-(A7)
!!    *MOVE.L  factor,D0
!!    *MOVE.L  D0,D1
!!    *JSR     IMUL
!!    *MOVE.L  ht,D1
!!    *JSR     IMUL
!!    *MOVE.L  wid,D1
!!    *JSR     IMUL
!!    *MOVE.L  D0,D2
!!    *MOVE.L  (A7)+,D1
!!    *MOVE.L  (A7)+,D0
!!    *SUBQ.L  #1,D2
!!    *MOVE.L  D0,-(A7)
!!    *MOVE.L  D1,-(A7)
!!    *MOVE.L  D2,-(A7)
!!    *BSR     ASIZE
!!    *MOVE.L  D0,-(A7)
!!       %for i=ht-1, -1, 0 %cycle
!!    *MOVEA.L 8(A5),A3
!!    *MOVE.L  b,D0
!!    *BSR     AGET
!!    *MOVE.L  A7,b
!!    *MOVE.L  ht,i
!!L1: *MOVE.L  i,D0
!!    *BEQ     L2
!!    *SUBQ.L  #1,i
!!          ifw = i*factor*wid; iw = i*wid
!!    *MOVE.L  i,D0
!!    *MOVE.L  factor,D1
!!    *JSR     IMUL
!!    *MOVE.L  wid,D1
!!    *JSR     IMUL
!!    *MOVE.L  D0,ifw
!!    *MOVE.L  i,D0
!!    *MOVE.L  wid,D1
!!    *JSR     IMUL
!!    *MOVE.L  D0,iw
!!          %for j=factor-1, -1, 0 %cycle
!!    *MOVE.L  factor,j
!!L3: *MOVE.L  j,D0
!!    *BEQ     L4
!!    *SUBQ.L  #1,j
!!             jw=j*wid
!!    *MOVE.L  j,D0
!!    *MOVE.L  wid,D1
!!    *JSR     IMUL
!!    *MOVE.L  D0,jw
!!             %for k=0,1,wid-1 %cycle
!!    *MOVE.L  wid,D1
!!    *SUBQ.L  #1,D1
!!    *MOVE.L  D1,232
!!    *MOVEQ   #-1,D2
!!    *MOVE.L  D2,k
!!L5: *MOVE.L  k,D0
!!    *CMP.L   232,D0
!!    *BEQ     L6
!!    *ADDQ.L  #1,k
!!                 ix = (ifw+jw+k)*factor
!!    *MOVE.L  ifw,D0
!!    *ADD.L   jw,D0
!!    *ADD.L   k,D0
!!    *MOVE.L  factor,D1
!!    *JSR     IMUL
!!    *MOVE.L  D0,ix
!!
!!   %for l=factor-1, -1, 0 %cycle
!!      b(ix+l) = a(iw+k)
!!   %repeat

!!!   D2 is cycle variable (L) running from FACTOR down to 0
!!    *MOVE.L  factor,D2
!!!   D1 is address we are copying to (IX+L) offset against B (A1)
!!    *MOVE.L  ix,D1
!!    *ADD.L   D2,D1
!!!   D0 is address we are copying from (IW+K) offset against A (A0)
!!    *MOVE.L  iw,D0
!!    *ADD.L   k,D0
!!!   No idea what this is for
!!    *MOVEA.L 8(A5),A3
!!!   Set up A and B base pointers
!!    *MOVEA.L a,A0
!!    *MOVEA.L b,A1
!!!   and copy...
!!L7: *MOVE.B  0(A0,D0.L),0(A1,D1.L)
!!    *SUBQ.L  #1,D1
!!    *SUBQ.L  #1,D2
!!    *BNE     L7

!!             %repeat
!!          %repeat
!!       %repeat
!!    *BRA     L5
!!L6: *ADDQ.L  #4,A7
!!    *BRA     L3
!!L4: *BRA     L1
!!L2:
!!      col fill(0,0, 0+wid*factor-1, 0+ht*factor-1, b(0))
!!    %end
!!%end

infile=cliparam
printline("Parameter?") %and %stop %if infile=""
infile = infile.".iff" %if exists(infile.".iff")

printline("Can't access file") %and %stop %unless exists(infile)
printstring("Reading ".infile."...")
connectfile(infile,0,filstart,filelen); filptr=filstart; filend=filstart+filelen


rshort(hlen);       !1
rshort(type);       !2
rshort(ht);         !3
rshort(wid);        !4
rshort(junk);       !5
rshort(junk);       !6
rshort(junk);       !7
rshort(junk);       !8
rshort(junk);       !9
rshort(junk);       !10
rshort(junk);       !11
rshort(junk);       !12
rshort(junk);       !13
rstring(gendate,8); !14
rstring(gentime,8); !15
rshort(junk);       !16
rshort(junk);       !17
rshort(magic);      !18
rstring(title,255); !19

printstring(title); newline
printstring(gendate."  ".gentime); newline
PrintString ("File is ");Write(wid,0)
PrintString (" pixels wide by ");Write(ht,0)
PrintString (" pixels high.");Newlines(2)

hlen = hlen * 2 ;!Convert to bytes

Setup

%if hlen>512 %start
   %for i=1,1,510-(filptr-filstart) %cycle
      rsymbol(junkb)
   %repeat

   rshort(maplen)
   maplen = maplen * 2

   %for i=0,1,255 %cycle
      rshort(cval); cm(i)<-cval
   %repeat

%else
   printline("No colour map - grey scale assumed")
   %for i=1,1,hlen-(filptr-filstart) %cycle
      rsymbol(junkb)
   %repeat
   %for i=0,1,255 %cycle; c = i>>3; CM(i) = (c<<5 + c)<<5 + c; %repeat
%finish

CMp == CM(0)
Update Colour Map (CMp)
   
Clear

max=wid*ht
XOff = 0; YOff = 0
!XOff = (688-Wid)>>1 {%if Wid < 688}
!YOff = (512-Ht)>>1 {%if Ht < 512}
xo=0; yo=0
xo=(wid-688)>>1; yo=(ht-512)>>1
x=0; y=0; rlleft=0
   
%if type&16_c0 # 0 %start
   printline("Expanding file... ")
   printline("Dubious data") %unless filptr-filstart = hlen
   
!!   %cycle
!!   
!!      !Read in the next run
!!   
!!      no = get byte; %exit %if no<0
!!   
!!      !write the run to the array
!!   
!!      !rlleft = run length - 1.  Note bottom bound of cycle is 0 not 1.
!!      %for k=rlleft,-1,0 %cycle
!!          a(x)=no; x=x+1
!!      %repeat
!!      rlleft=0
!!   %repeatuntil filptr>=filend
   
       *clr.l  d3   ;!x.   <=1023
       *MOVEA.L a,a2
cycle:
       *BSR     getbyte    ;!no in d0
       *MOVE.L  D0,d0
       *BLT     eof
       *MOVE.L  rlleft,d2  ;!count <= 15 bits
       *addq.w  #1,d2
   
incycle:
       *MOVE.L  d3,d1
       *MOVE.B  d0,0(a2,d1.L)    ;!a(x+y)=no
   
       *ADD.L   #1,d3     ;!x=x+1

       *subq.w  #1,d2
       *bne     incycle
       *CLR.L   rlleft       ;!rlleft=0
       *bra     cycle        ;!"trusting" loop - relies on EOF in file.
   !%repeatuntil filptr>=filend
eof:

   printline("Displaying")
%else
   %for i=ht-1,-1,0 %cycle
     %for j=0,1,wid-1 %cycle
        a(i*wid+j)=byteinteger(filptr); filptr=filptr+1
     %repeat
   %repeat
%finish
col fill(xoff, yoff, xoff+wid-1, yoff+ht-1, a(0))

printline("Hit cursor keys to pan image, <return> to exit")

%cycle
   offset(xo, yo)
   %cycle; c=testsymbol; %repeatuntil c=27 %or c=10
   %exit %if c=10
   %cycle; c=testsymbol; %repeatuntil c>0
   %if c=67 %start
      xo=xo-16
   %elseif c=65
      yo=yo-1
   %elseif c=68
      xo=xo+16
   %elseif c=66
      yo=yo+1
   %elseif c=72 ;!Home
      i = 512//wid; j = 512//ht
      %if i<j %then max factor=i %else max factor=j
      xo=0; yo=0; offset(xo, yo)
      prompt("Zoom factor:"); read(factor)
      factor = max factor %if factor> max factor
      printline("Zoom factor = ".itos(factor, -1))
      zoom(a, factor)
   %else
      %exit
   %finish
%repeat
%endofprogram
      
