!**************************************************************************
!*                                                                        *
!*    IFFUTILS: Routines for handling run-length encoded IFF plus files   *
!*                                                                        *
!*                   JHB:  Version 1.6    2 Feb 1987                      *
!*                                                                        *
!**************************************************************************

! You'll find documentation in UTILS.DOC

%include "inc:util.imp"

%constinteger iff not magic=16_81, iff no file = 16_82, iff wrong length = 16_83
%constinteger iff read=0, iff write=1
%conststring (31) %array iff error(iff not magic:iff wrong length)= %c
   "File has wrong magic number",
   "File does not exist",
   "File length inconsistent"

%recordformat context fm( %c
%integer filstart, filptr, readwrite, imaddr, colour, xoff, yoff)
%constinteger context size = 28

%recordformat app fm(%integer appno, satellite, instrument, channel, data,
fp year, fp month, fp day, fp hour, fp min, fp sec, fp msec,
scan_dir, proj)

%recordformat iffhdr fm(%integer  hlen, datatype, ht, wid, 
signed, fov ht, fov wid, stereo, baseline, vergence, gaze, id, processed,
fstop, focus, mapaddr, sets, subs, xoff, yoff, aspect, mapwid, maplen,
%record (context fm) %name context, %record (*) %name app,
%string (255) title, %string (8) date, time)

%externalintegerfn iff open file %alias "IFF_OPEN_FILE" %c
(%string (255) filename,%record (iffhdr fm) %name iffh, %integer readwrite)
   %integer filelen, magic, ht, wid, hlen, filptr
   %string (255) s1, s2
   %record (context fm) %name context

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

   iffh=0
   iffh_context == record(heapget(context size))
   context == iffh_context
   context=0
   context_readwrite = readwrite
   %if readwrite = iff read %start

      %result = iff no file %if filename = ""
      filename = filename.".iff" %if exists(filename.".iff")
      %result = iff no file %unless exists(filename)
      connectfile(filename,0,context_filstart,filelen)

      !Basic consistency checks
      filptr = context_filstart;    rshort(hlen); rshort(ht); rshort(wid)
      %result = iff wrong length %if filelen < hlen*2

      filptr = context_filstart+46; rshort(magic)
      %if magic = 16_8516 %start
         context_filptr = context_filstart
         %result=0
      %else
         heapput(context_filstart); context_filstart=0
         %result = iff not magic
      %finish

   %else ;!Output
      filename = filename.".iff" %unless filename -> s1.(".").s2
      openoutput(1, filename); selectoutput(1)
      context_filptr = 1
      %result=0
   %finish
%end

%externalroutine iff close file %alias "IFF_CLOSE_FILE" %c
(%record (iffhdr fm) iffh)
   %if iffh_context_readwrite = iff read %start
      %if iffh_context_filstart # 0 %then heapput(iffh_context_filstart)
   %else
      selectoutput(iffh_context_filptr); close output
   %finish
   dispose(iffh_context)
%end

%externalintegerfn iff read header %alias "IFF_READ_HEADER" %c
(%record (iffhdr fm) %name iffh)
   %integer i, hlen, magic, junk, mapaddr, filstart, filptr
   %record (context fm) %name context
   %shortarrayname map(0:*)

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

   %routine rshort(%integername i)
      i=byteinteger(filptr)<<8+byteinteger(filptr+1); filptr=filptr+2
      i=i&16_FFFF
   %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

   context == iffh_context
   map == array(iffh_mapaddr)
   filstart=context_filstart; filptr=filstart
                            !Fld Byt Description
   rshort(iffh_hlen);       !1    0  Header length in 16-bit words
   rshort(iffh_datatype);   !2    2  Image type
   rshort(iffh_ht);         !3    4  Image height (pixels)
   rshort(iffh_wid);        !4    6  Image width  (pixels)
   rshort(iffh_signed);     !5    8  Signed/Unsigned data
   rshort(iffh_fov ht);     !6   10  field of view height (mrad)
   rshort(iffh_fov wid);    !7   12  field of view width (mrad)
   rshort(iffh_stereo);     !8   14  stereo pair/mono image
   rshort(iffh_baseline);   !9   16  optical centres separation (mm)
   rshort(iffh_vergence);   !10  18  vergence angle (mrad)
   rshort(iffh_gaze);       !11  20  gaze angle (mrad)
   rshort(iffh_id);         !12  22  i.d. of camera or synthesizer
   rshort(iffh_processed);  !13  24  true if image not directly from
                            !        source - i.e. processed since.
   rstring(iffh_date,8);    !14  26  date of generation (dd/mm/yy)
   rstring(iffh_time,8);    !15  34  time of generation (hh:mm:ss)
   rshort(iffh_fstop);      !16  42  lens stop (f no. x 100)
   rshort(iffh_focus);      !17  44  lens focal length (mm)
   rshort(magic);           !18  46  magic number
   rstring(iffh_title,255); !19  48  image title

   hlen = iffh_hlen * 2 ;!Bytes

   %if hlen>512 %start
      filptr=filstart+506

      rshort(iffh_aspect)
      rshort(iffh_mapwid)
      rshort(iffh_maplen)

      %if iffh_maplen#0 %and iffh_mapaddr#0 %start
         %for i=0,1,iffh_maplen-1 %cycle
            rshort(junk); map(i)<-junk
         %repeat
      %finish

   %else
      iffh_maplen=0
   %finish

   context_filptr=context_filstart+hlen
   %result=0
%end

%externalintegerfn iff write header %alias "IFF_WRITE_HEADER" %c
(%record (iffhdr fm) %name iffh)
   %integer hptr,hlen,i,n
   %record (context fm) %name context

   %routine psymbol(%integer c)
     printsymbol(c); hptr=hptr+1
   %end

   %routine pstring(%string (255) s)
      %integer i
      %if length(s)#0 %start
         %for i=1,1,length(s) %cycle
            psymbol(charno(s, i))
         %repeat
      %finish
   %end

   %routine pshort(%integer i)
      psymbol(i>>8); psymbol(i&255)
   %end
   
   !Set defaults.
   !Default date and time are now.
   !Default header length is minimum >= 128 words
   !Note these values will be returned to IFFHDR.

   iffh_date = date %if iffh_date = ""
   %if iffh_time = "" %start
      iffh_time=time; iffh_time=iffh_time.":00" %if length(iffh_time)=5
   %finish
   %if iffh_hlen=0 %start ;!He's left it to us
      iffh_hlen=256
   %else ;!He wants header a specific length
      %stop %if iffh_mapaddr # 0 %and iffh_hlen < iffh_maplen+128
   %finish

   hptr=0
   pshort(iffh_hlen);                  ! 1: Header length (16-bit words)
   pshort(iffh_datatype);              ! 2: Image type
   pshort(iffh_ht);                    ! 3: Height/Pixels
   pshort(iffh_wid);                   ! 4: Width/Pixels
   pshort(iffh_signed);                ! 5: Unsigned
   pshort(iffh_fov ht);                ! 6: field of view ht = 0
   pshort(iffh_fov wid);               ! 7: field of view wid =0
   pshort(iffh_stereo);                ! 8: mono
   pshort(iffh_baseline);              ! 9: baseline sep=0
   pshort(iffh_vergence);              !10: vergence=0
   pshort(iffh_gaze);                  !11: gaze=0
   pshort(iffh_id);                    !12: source id=0
   pshort(iffh_processed);             !13: unprocessed
   pstring(iffh_date);                 !14: date
   pstring(iffh_time);                 !15: time
   pshort(iffh_fstop);                 !16: f/stop
   pshort(iffh_focus);                 !17: focal length/mm
   pshort(16_8516);                    !18: magic no.
   pstring(iffh_title); psymbol(0);    !19: title

   %if iffh_hlen>=256 %start
      %for i=1,1,498-hptr %cycle; psymbol(0); %repeat
      pshort(iffh_sets);               !498:image_sets
      pshort(iffh_subs);               !500:subheaders used
      pshort(iffh_xoff);               !502:x offset
      pshort(iffh_yoff);               !504:y offset
      pshort(iffh_aspect);             !506:aspect ratio
      pshort(iffh_mapwid)
      pshort(iffh_maplen)
      %if iffh_maplen#0 %start
         %for i=0,1,iffh_maplen-1 %cycle
            pshort(shortinteger(iffh_mapaddr+i<<1))
         %repeat
      %finish
   %finish
   %if hptr#iffh_hlen*2 %start
      %for i=1,1,iffh_hlen*2-hptr %cycle; psymbol(0); %repeat ;!Padding
   %finish
   %result=0
%end

%routine quick move(%integer bytes, %bytename from, to)
   !Clever dicks who think *dbra is better here should remember it has
   !a 16 bit argument.   (I didn't).  Note it won't move overlapping areas.
f loop:
   *move.b (a0)+, (a1)+
   *Subq.l #1, d0
   *bne    f loop
%end

%externalroutine iff show header %alias "IFF_SHOW_HEADER" %c
(%record (iffhdr fm) iffh, %integer detail)
   %integer i
   printstring(iffh_date." ".iffh_time.": ")
   printstring(iffh_title); newline
   write(iffh_stereo+1, -1)
   PrintString (" Image"); %if iffh_stereo#0 %then printsymbol('s')
   printstring(": ");Write(iffh_wid,0)
   PrintString (" pixels wide by ");Write(iffh_ht,0)
   PrintString (" pixels high.");Newline
   write(iffh_hlen, -1); printstring("-word header.  ")
   %if iffh_mapaddr=0 %or iffh_maplen=0 %start
      printstring("No colour map")
   %else
      printstring("Colour map: "); write(iffh_maplen,-1)
      printstring(" entries of "); write(iffh_mapwid,-1)
      printstring(" bits"); newline

      %if detail&1#0 %start
        %for i=0, 1, iffh_maplen-1 %cycle
           phex4(shortinteger(iffh_mapaddr+i<<1))
           %if i&15=15 %then newline %else space
        %repeat
      %finish
   %finish
   newline
   %if iffh_aspect#0 %start
      printstring("Aspect ratio: "); write(iffh_aspect>>8,-1)
      printstring(":"); write(iffh_aspect&255,-1); newline
   %finish
%end

%externalintegerfn iff read image %alias "IFF_READ_IMAGE" %c
(%record (iffhdr fm) %name iffh, %integer address)
%label eof,cycle,incycle
%record (context fm) %name context
%integer i, j, rlleft, rlno, k, x, no, filptr

%integerfn get byte
   !Get the next character
   !Uses globals RLNO, RLLEFT, FILPTR

!!%bytefn next
!!   filptr=filptr+1 %if byteinteger(filptr)=10
!!   filptr=filptr+1
!!   %result=byteinteger(filptr-1)
!!%end

!!   %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=0
!!      %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   
!!!   *movea.l (a0),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.
                         !  *movea.l filptr,a1;  *move.l  a0,(a1)   instead of..
   *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
                          !  *movea.l filptr,a1;   *move.l a0,(a1)
   *move.l a0,filptr     ;!update filptr   
   *RTS        
nolen:
                          !  *movea.l filptr,a0;   *move.l a1,(a0)
   *move.l a1,filptr
   *rts
%end

context == iffh_context
filptr = context_filptr
context_imaddr = address ;!Used by IFFEXT utilities
rlleft=0; rlno=0
x=0
%if iffh_datatype&16_c0 # 0 %start
!!   %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
!!          byteinteger(address+x)=no; x=x+1
!!      %repeat
!!      rlleft=0
!!   %repeat {until filptr>=filend}
   
       *MOVEA.L address,a2

cycle:
       *BSR     getbyte    ;!no in d0
       *MOVE.L  D0,d0
       *BLT     eof
       *MOVE.L  rlleft,d2  ;!count <= 15 bits

incycle:
       *MOVE.B  d0,(a2)+    ;!a(x)=no
       *dbra    d2,incycle

       *CLR.L   rlleft       ;!rlleft=0
       *bra     cycle        ;!"trusting" loop - relies on EOF in file.
   !%repeatuntil filptr>=filend
eof:
       *move.l  d0,no        ;!Leave end condition where we can get at it
       no=0 %if no=-1

%else
   quick move(iffh_wid*iffh_ht, byteinteger(filptr), byteinteger(address))
   filptr = filptr + iffh_wid*iffh_ht
   no=0
%finish

context_filptr = filptr
%result = no
%end

%externalintegerfn iff write image %alias "IFF_WRITE_IMAGE" %c
(%record (iffhdr fm) iffh, %integer imaddr)
   %integer i, ix, rl, lastc, c, ct=0
   %routine pchar(%integer char, count)
      %integer i
   
      %routine pch(%integer char)
         %if char=0 %start
            printsymbol(0); ct=ct+1
         %finishelseif char=10 %start
            printsymbol(0); char=1; ct=ct+1
         %finish
         printsymbol(char); ct=ct+1
      %end

      %routine prl(%integer count)
         %integer i
         pch(char)
         %if count=1 %start
            !No action
         %finishelseif count<4 %start
            %for i=1,1,count-1 %cycle; pch(char); %repeat
         %finishelseif count<=127 %start
            %if count=10 %then pch(char) %and count=count-1
            printsymbol(0); printsymbol(count); ct=ct+2
         %finishelsestart
            %if count&255=10 %then pch(char) %and count=count-1
            printsymbol(0); printsymbol((count>>8)!16_80); printsymbol(count); ct=ct+3
         %finish
      %end
   
      %while count > 16_7FFF %cycle
         prl(16_7FFF); count=count - 16_7FFF
      %repeat
      prl(count) %if count # 0
         
      %if ct>=256 %then newline %and ct=0
   %end

   ix = imaddr
   %if iffh_datatype & 16_c0 = 0 %start
      %for i=0, 1 ,iffh_ht*iffh_wid-1 %cycle
         printsymbol(byteinteger(ix)); ix=ix+1
      %repeat
   %else
      lastc=byteinteger(ix); ix=ix+1; ct=0; rl=1
      %for i=0,1,iffh_ht*iffh_wid-1 %cycle
         c = byteinteger(ix); ix=ix+1
         %if c=lastc %then rl=rl+1 %elsestart
            pchar(lastc,rl)
            rl=1; lastc=c
         %finish
      %repeat

      %if rl>0 %then pchar(c,rl)
      printsymbol(0); printsymbol(3)
      newline
   %finish
   %result=0
%end

%endoffile