;****************************************************************************
;
;                     Tag Image File Format (TIFF)
;
;
; Tiff tag definitions were borrowed from:
;      > Copyright (c) 1988, 1990 by Sam Leffler.
;      > All rights reserved.
;      >
;      > This file is provided for unrestricted use provided that this
;      > legend is included on all tape media and as a part of the
;      > software program in whole or part.  Users may copy, modify or
;      > distribute this file at will.
;      >
;      > Based on Rev 5.0 from:
;      > Developer's Desk              Window Marketing Group
;      > Aldus Corporation             Microsoft Corporation
;      > 411 First Ave. South          16011 NE 36th Way
;      > Suite 200                     Box 97017
;      > Seattle, WA  98104            Redmond, WA  98073-9717
;      > 206-622-5500                  206-882-8080
;
; Now updated for TIFF 6
; http://www.wotsit.org/download.asp?f=tiff6
;
; We rely on an ENDIAN-PORT
; A port with the following operations
;   endian-port-set-bigendian!::   PORT -> UNSPECIFIED
;   endian-port-set-littlendian!:: PORT -> UNSPECIFIED
;   endian-port-read-int1:: PORT -> UINTEGER (byte)
;   endian-port-read-int2:: PORT -> UINTEGER
;   endian-port-read-int4:: PORT -> UINTEGER
;   endian-port-setpos PORT INTEGER -> UNSPECIFIED
;
; Also needed SRFIs: SRFI-4 (uniform vectors), SRFI-9 (records)
; Actually, we're using structures, which can be translated to SRFI-9
; records.
;
; Derived from Oleg Kiselyov's tiff.scm 2.0 2003/09/29 20:05:12
; Changes:
;   make-define-env, define-macro --> explicit-renaming


;------------------------------------------------------------------------
;                              TIFF file header
; It is always written at the very beginning of the TIFF file

;  unsigned short magic;         // magic number (defines byte order)
;  unsigned short version;       // TIFF version number
;  unsigned long  diroffset;     // byte offset to the first directory

(define TIFF:BIGENDIAN-magic    #x4d4d)		; 'MM'
(define TIFF:LITTLEENDIAN-magic #x4949)		; 'II'
(define TIFF:VERSION 42)

; procedure: TIFF:read-header ENDIAN-PORT -> OFFSET
;
; Reads and checks the TIFF header, sets the reader to
; the appropriate little/big endian mode and returns the byte
; offset to the first TIFF directory
(define (TIFF:read-header eport)
  (let ((magic-word (endian-port-read-int2 eport)))
    (cond
      ((= magic-word TIFF:BIGENDIAN-magic)
       (endian-port-set-bigendian! eport))
      ((= magic-word TIFF:LITTLEENDIAN-magic)
       (endian-port-set-littlendian! eport))
      (else (error "invalid magic word 0x" (number->string magic-word 16)
     	       "of the TIFF file"))))
  (let ((version (endian-port-read-int2 eport)))
    (if (not (= version TIFF:VERSION))
      (error "TIFF file version " version "differs from the standard "
      	    TIFF:VERSION)))
  (endian-port-read-int4 eport))

;------------------------------------------------------------------------
; 		    TIFF tags: codes and values
;
; A tag dictionary, tagdict, structure helps translate between
; tag-symbols and their numerical values.
;
; procedure: tagdict-get-by-name TAGDICT TAG-NAME -> INT
; where TAG-NAME is a symbol.
; Translate a symbolic representation of a TIFF tag into a numeric
; representation.
; An error is raised if the lookup fails.
;
; procedure: tagdict-get-by-num TAGDICT INT -> TAG-NAME or #f
; Translate from a numeric tag value to a symbolic representation,
; if it exists. Return #f otherwise.
;
; procedure: tagdict-tagval-get-by-name TAGDICT TAG-NAME VAL-NAME -> INT
; where VAL-NAME is a symbol.
; Translate from the symbolic representation of a value associated
; with TAG-NAME in the TIFF directory, into the numeric representation.
; An error is raised if the lookup fails.
;
; procedure: tagdict-tagval-get-by-num TAGDICT TAG-NAME INT -> VAL-NAME or #f
; Translate from a numeric value associated with TAG-NAME in the TIFF
; directory to a symbolic representation, if it exists. Return #f
; otherwise.
;
; procedure: make-tagdict ((TAG-NAME INT (VAL-NAME . INT) ...) ...)
; Build a tag dictionary
;
; procedure: tagdict? TAGDICT -> BOOL
;
; procedure: tagdict-add-all DEST-DICT SRC-DICT -> DEST-DICT
; Join two dictionaries
;
; The variable tiff-standard-tagdict is initialized to the dictionary
; of standard TIFF tags.

; Usage scenario:
;    (tagdict-get-by-name  tiff-standard-tagdict 'TIFFTAG:IMAGEWIDTH) => 256
;    (tagdict-get-by-num   tiff-standard-tagdict 256) => 'TIFFTAG:IMAGEWIDTH
;    (tagdict-tagval-get-by-name tiff-standard-tagdict
;       'TIFFTAG:COMPRESSION 'LZW) => 5
;    (tagdict-tagval-get-by-num  tiff-standard-tagdict
;       'TIFFTAG:COMPRESSION 5) => 'LZW
;
;    (define extended-tagdict
;       (tagdict-add-all tiff-standard-tagdict
;          (make-tagdict
;		'((WAupper_left_lat 33004)
;		  (WAhemisphere 33003 (North . 1) (South . 2))))))

(define-structure p-tiff-tag-dict table)


(define tagdict? p-tiff-tag-dict?)

(define (make-tagdict args)
  (for-each				; error-check each dict association
    (lambda (arg)
      (or
	(and
	  (pair? arg)
	  (list? arg)
	  (symbol? (car arg))
	  (integer? (cadr arg)))
	(error "make-tagdict: bad association to add: " arg))
      (for-each
	(lambda (val-assoc)
	  (or
	    (and
	      (pair? val-assoc)
	      (symbol? (car val-assoc))
	      (integer? (cdr val-assoc)))
	    (error "make-tagdict: bad tag value association: " val-assoc)))
	(cddr arg)))
    args)
  (make-p-tiff-tag-dict args))


; procedure: tagdict-add-all DEST-DICT SRC-DICT -> DEST-DICT
; Join two dictionaries
(define (tagdict-add-all dest-dict src-dict)
  (assert (tagdict? dest-dict) (tagdict? src-dict))
  (make-p-tiff-tag-dict
    (append (p-tiff-tag-dict-table dest-dict)
            (p-tiff-tag-dict-table src-dict))))

; procedure: tagdict-get-by-name TAGDICT TAG-NAME -> INT
; An error is raised if the lookup fails.

(define (tagdict-get-by-name dict tag-name)
  (assert (tagdict? dict))
  (cond
    ((assq tag-name (p-tiff-tag-dict-table dict))
      => cadr)
    (else
      (error "tagdict-get-by-name: can't translate: " tag-name))))


; procedure: tagdict-get-by-num TAGDICT INT -> TAG-NAME or #f
(define (tagdict-get-by-num dict tag-int)
  (assert (tagdict? dict))
  (any?
    (lambda (table-row)
      (and (= (cadr table-row) tag-int) (car table-row)))
    (p-tiff-tag-dict-table dict)))


; procedure: tagdict-tagval-get-by-name TAGDICT TAG-NAME VAL-NAME -> INT
; An error is raised if the lookup fails.
(define (tagdict-tagval-get-by-name dict tag-name val-name)
  (assert (tagdict? dict))
  (cond
    ((assq tag-name (p-tiff-tag-dict-table dict))
      => (lambda (table-row)
	   (cond
	     ((assq val-name (cddr table-row)) => cdr)
	     (else
	       (error "tagdict-tagval-get-by-name: can't translate "
		 tag-name val-name)))))
    (else
      (error "tagdict-tagval-get-by-name: unknown tag: " tag-name))))


; procedure: tagdict-tagval-get-by-num TAGDICT TAG-NAME INT -> VAL-NAME or #f
; Translate from a numeric value associated with TAG-NAME in the
; TIFF directory.
(define (tagdict-tagval-get-by-num dict tag-name val-int)
  (assert (tagdict? dict))
  (cond
    ((assq tag-name (p-tiff-tag-dict-table dict))
      => (lambda (table-row)
	   (any?
	     (lambda (assc)
	       (and (= val-int (cdr assc)) (car assc)))
	     (cddr table-row))))
    (else
      (error "tagdict-tagval-get-by-num: unknown tag: " tag-name))))

(define tiff-standard-tagdict
  (make-tagdict
    '(
       (TIFFTAG:SUBFILETYPE 254	        ; subfile data descriptor
	 (TIFFTAG:REDUCEDIMAGE . #x1)	  ; reduced resolution version
	 (TIFFTAG:PAGE . #x2)		  ; one page of many
	 (TIFFTAG:MASK . #x4))
       (TIFFTAG:OSUBFILETYPE 255	; +kind of data in subfile
         (TIFFTAG:IMAGE . 1)		  ; full resolution image data
	 (TIFFTAG:REDUCEDIMAGE . 2)	  ; reduced size image data
	 (TIFFTAG:PAGE . 3))		  ; one page of many
       (TIFFTAG:IMAGEWIDTH 256)	        ; image width in pixels
       (TIFFTAG:IMAGELENGTH 257)	; image height in pixels
       (TIFFTAG:BITSPERSAMPLE 258)	; bits per channel (sample)

       (TIFFTAG:COMPRESSION 259	        ; data compression technique
	 (NONE . 1)			  ; dump mode
	 (CCITTRLE . 2)		          ; CCITT modified Huffman RLE
	 (CCITTFAX3 . 3)		  ; CCITT Group 3 fax encoding
	 (CCITTFAX4 . 4)		  ; CCITT Group 4 fax encoding
	 (LZW . 5)			  ; Lempel-Ziv  & Welch
	 (NEXT . 32766)		          ; NeXT 2-bit RLE
	 (CCITTRLEW . 32771)		  ; #1 w/ word alignment
	 (PACKBITS . 32773)		  ; Macintosh RLE
	 (THUNDERSCAN . 32809)		  ; ThunderScan RLE
	 (PICIO . 32900)		  ; old Pixar picio RLE
	 (SGIRLE . 32901))		  ; Silicon Graphics RLE

       (TIFFTAG:PHOTOMETRIC 262	        ; photometric interpretation
	 (MINISWHITE . 0)		  ; min value is white
	 (MINISBLACK . 1)		  ; min value is black
	 (RGB . 2)			  ; RGB color model
	 (PALETTE . 3)			  ; color map indexed
	 (MASK . 4)			  ; holdout mask
	 (DEPTH . 32768))		  ; z-depth data

       (TIFFTAG:THRESHOLDING 263	; +thresholding used on data
	 (BILEVEL . 1)			  ; b&w art scan
	 (HALFTONE . 2)		          ; or dithered scan
	 (ERRORDIFFUSE . 3))		  ; usually floyd-steinberg

       (TIFFTAG:CELLWIDTH 264)		; +dithering matrix width
       (TIFFTAG:CELLLENGTH 265)	        ; +dithering matrix height
       (TIFFTAG:FILLORDER 266		; +data order within a byte
	 (MSB2LSB . 1)			  ; most significant -> least
	 (LSB2MSB . 2))		          ; least significant -> most

       (TIFFTAG:DOCUMENTNAME 269)	; name of doc. image is from
       (TIFFTAG:IMAGEDESCRIPTION 270)	; info about image
       (TIFFTAG:MAKE 271)		; scanner manufacturer name
       (TIFFTAG:MODEL 272)		; scanner model name/number
       (TIFFTAG:STRIPOFFSETS 273)	; offsets to data strips

       (TIFFTAG:ORIENTATION 274	        ; +image orientation
	 (TOPLEFT . 1)			  ; row 0 top, col 0 lhs
	 (TOPRIGHT . 2)		          ; row 0 top, col 0 rhs
	 (BOTRIGHT . 3)		          ; row 0 bottom, col 0 rhs
	 (BOTLEFT . 4)			  ; row 0 bottom, col 0 lhs
	 (LEFTTOP . 5)			  ; row 0 lhs, col 0 top
	 (RIGHTTOP . 6)		          ; row 0 rhs, col 0 top
	 (RIGHTBOT . 7)		          ; row 0 rhs, col 0 bottom
	 (LEFTBOT . 8))		          ; row 0 lhs, col 0 bottom

       (TIFFTAG:SAMPLESPERPIXEL 277)	; samples per pixel
       (TIFFTAG:ROWSPERSTRIP 278)	; rows per strip of data
       (TIFFTAG:STRIPBYTECOUNTS 279)	; bytes counts for strips
       (TIFFTAG:MINSAMPLEVALUE 280)	; +minimum sample value
       (TIFFTAG:MAXSAMPLEVALUE 281)	; maximum sample value
       (TIFFTAG:XRESOLUTION 282)	; pixels/resolution in x
       (TIFFTAG:YRESOLUTION 283)	; pixels/resolution in y

       (TIFFTAG:PLANARCONFIG 284	; storage organization
	 (CONTIG . 1)			  ; single image plane
	 (SEPARATE . 2))		  ; separate planes of data

       (TIFFTAG:PAGENAME 285)		; page name image is from
       (TIFFTAG:XPOSITION 286)		; x page offset of image lhs
       (TIFFTAG:YPOSITION 287)		; y page offset of image lhs
       (TIFFTAG:FREEOFFSETS 288)	; +byte offset to free block
       (TIFFTAG:FREEBYTECOUNTS 289)	; +sizes of free blocks

       (TIFFTAG:GRAYRESPONSEUNIT 290	; gray scale curve accuracy
	 (S10 . 1)			  ; tenths of a unit
	 (S100 . 2)			  ; hundredths of a unit
	 (S1000 . 3)			  ; thousandths of a unit
	 (S10000 . 4)			  ; ten-thousandths of a unit
	 (S100000 . 5))		          ; hundred-thousandths
       (TIFFTAG:GRAYRESPONSECURVE 291)	; gray scale response curve

       (TIFFTAG:GROUP3OPTIONS 292	; 32 flag bits
	 (ENCODING2D . #x1)		  ; 2-dimensional coding
	 (UNCOMPRESSED . #x2)		  ; data not compressed
	 (FILLBITS . #x4))		  ; fill to byte boundary
       (TIFFTAG:GROUP4OPTIONS 293	; 32 flag bits
	 (UNCOMPRESSED . #x2))		; data not compressed

       (TIFFTAG:RESOLUTIONUNIT 296	; units of resolutions
	 (NONE . 1)			  ; no meaningful units
	 (INCH . 2)			  ; english
	 (CENTIMETER . 3))		  ; metric

       (TIFFTAG:PAGENUMBER 297)	        ; page numbers of multi-page

       (TIFFTAG:COLORRESPONSEUNIT 300	; color scale curve accuracy
	 (S10 . 1)			  ; tenths of a unit
	 (S100 . 2)			  ; hundredths of a unit
	 (S1000 . 3)			  ; thousandths of a unit
	 (S10000 . 4)			  ; ten-thousandths of a unit
	 (S100000 . 5))			  ; hundred-thousandths

       (TIFFTAG:COLORRESPONSECURVE 301); RGB response curve
       (TIFFTAG:SOFTWARE 305)		; name & release
       (TIFFTAG:DATETIME 306)		; creation date and time
       (TIFFTAG:ARTIST 315)		; creator of image
       (TIFFTAG:HOSTCOMPUTER 316)	; machine where created
       (TIFFTAG:PREDICTOR 317)		; prediction scheme w/ LZW
       (TIFFTAG:WHITEPOINT  318)	; image white point
       (TIFFTAG:PRIMARYCHROMATICITIES 319) ; primary chromaticities
       (TIFFTAG:COLORMAP 320)		; RGB map for pallette image
       (TIFFTAG:BADFAXLINES 326)	; lines w/ wrong pixel count

       (TIFFTAG:CLEANFAXDATA 327	; regenerated line info
	 (CLEAN . 0)			  ; no errors detected
	 (REGENERATED . 1)		  ; receiver regenerated lines
	 (UNCLEAN . 2))		          ; uncorrected errors exist

       (TIFFTAG:CONSECUTIVEBADFAXLINES 328); max consecutive bad lines

       (TIFFTAG:MATTEING 32995)	        ; alpha channel is present
)))

;------------------------------------------------------------------------
; 			TIFF directory entry
; a descriptor of a TIFF "item", which can be image data, document description,
; time stamp, etc, depending on the tag. Thus an entry has the following
; structure:
;  unsigned short tag;
;  unsigned short type;          // data type: byte, short word, etc.
;  unsigned long  count;         // number of items; length in spec
;  unsigned long  val_offset;    // byte offset to field data
;
; The values associated with each entry are disjoint and may appear anywhere
; in the file (so long as they are placed on a word boundary).
;
; Note, If the value takes 4 bytes or less, then it is placed in the offset
; field to save space.  If the value takes less than 4 bytes, it is
; *left*-justified in the offset field.
; Note, that it's always *left* justified (stored in the lower bytes)
; no matter what the byte order (big- or little- endian) is!
; Here's the precise quote from the TIFF 6.0 specification:
; "To save time and space the Value Offset contains the Value instead of
; pointing to the Value if and only if the Value fits into 4 bytes. If
; the Value is shorter than 4 bytes, it is left-justified within the
; 4-byte Value Offset, i.e., stored in the lower- numbered
; bytes. Whether the Value fits within 4 bytes is determined by the Type
; and Count of the field."


; Could be easily implemented as a syntax-rule
(define-syntax make-define-env
  (lambda (form rename name=)
    (let ((env-name (cadr form))
          (associations (cddr form))
          (%begin (rename 'begin))
          (%define (rename 'define)))
      `(,%begin
        (,%define ,env-name ',associations)
        ,@(map
           (lambda (assc)			; (name val . other fields)
             `(,%define ,(car assc) ,(cadr assc)))
           associations)))))

			; values of the 'data type' field
(make-define-env
  TIFF:types
  (TIFF:type-byte  1 "byte")	        ; 8-bit unsigned integer
  (TIFF:type-ascii 2 "ascii str")	; 8-bit bytes w/ last byte null
  (TIFF:type-short 3 "short")	        ; 16-bit unsigned integer
  (TIFF:type-long  4 "long")	        ; 32-bit unsigned integer
  (TIFF:type-rational  5 "rational")    ; 64-bit fractional (numer+denominator)
    				; The following was added in TIFF 6.0
  (TIFF:type-sbyte     6 "signed byte") ; 8-bit signed (2s-complement) integer
  (TIFF:type-undefined 7 "8-bit chunk") ; An 8-bit byte
  (TIFF:type-sshort    8 "signed short"); 16-bit signed (2s-complement) integer
  (TIFF:type-slong     9 "signed long")	; 32-bit signed (2s-complement) integer
  (TIFF:type-srational 10 "signed rational")    ; two SLONGs (num+denominator)
  (TIFF:type-float     11 "IEEE 32-bit float")	; single precision (4-byte)
  (TIFF:type-double    12 "IEEE 64-bit double") ; double precision (8-byte)
)

(define-structure tiff-dir-entry tag type count val-offset value)

; procedure: TIFF:read-dir-entry EPORT -> TIFF-DIR-ENTRY
;
; This procedure parses the current directory entry and
; returns a tiff-dir-entry structure. EPORT must point to the beginning
; of the entry in the TIFF directory. On exit, EPORT points to the
; next entry or the end of the directory.
; TIFF-DIR-ENTRY contains all the data of the entry, plus a promise
; of entry's value.
; The promise is forced only when the value is specifically requested
; by an object's user. That is, we won't rush to read and make the
; value (which may be pretty big: say the pixel matrix, etc).
;
; The promise closes over the EPORT!
;
; The value of an entry corresponds to its type: character, string,
; exact integer, floating-point number, or a uniform
; (u8, u16, or u32) vector. SRFI-4 is implied.

(define (TIFF:read-dir-entry eport)
  (let*
    ((tag        (endian-port-read-int2 eport))
     (type       (endian-port-read-int2 eport))
     (count      (endian-port-read-int4 eport))
      ; we read the val-offset later. We need to check the size and the type
      ; of the datum, because val-offset may contain the value itself,
      ; in its lower-numbered bytes, regardless of the big/little endian
      ; order!
    )
				; Some conversion procedures
    (define (u32->float x)		; unsigned 32-bit int -> IEEE float
      (error "u32->float is not yet implemented"))
    (define (u32->s32 x)		; unsigned 32-bit int -> signed 32 bit
      (if (>= x #x80000000)
	(- x #x100000000)
	x))
    ; (= (u32->s32 #x7fffffff) #x7fffffff)
    ; (= (u32->s32 #xffffffff) -1)

    (define (u16->s16 x)		; unsigned 16-bit int -> signed 16 bit
      (if (>= x #x8000)
	(- x #x10000) x))
    ; (= (u16->s16 32767) 32767)
    ; (= (u16->s16 32768) -32768)
    ; (= (u16->s16 65535) -1)

    (define (u8->s8 x)			; unsigned 8-bit int -> signed 8-bit
      (if (>= x #x80)
	(- x #x100) x))
    ; (= (u8->s8 127) 127)
    ; (= (u8->s8 128) -128)
    ; (= (u8->s8 255) -1)

    (define (read-double val-offset)
      (error "read-double: not yet implemented"))

            		; read an ascii string. Note, the last byte of
            		; an ascii string is always zero, which is
            		; included in 'count'
            		; but we don't need to read it
    (define (read-string val-offset)
      (assert (= TIFF:type-ascii type) (positive? count))
      (let ((str (make-string (- count 1))))
	(endian-port-setpos eport val-offset)
	(do ((i 0 (+ 1 i))) ((>= i (- count 1)) str)
	  (string-set! str i
	    (ascii->char (endian-port-read-int1 eport))))))


               		; read an array of 'count' items
               		; return a *uniform* vector of read data:
			; u8vector, u16vector or u32vector
			; We roll-out the code for efficiency
    (define (read-array val-offset)
      (endian-port-setpos eport val-offset)
      (cond
	((or (= type TIFF:type-byte) (= type TIFF:type-undefined))
	  (let ((array (make-u8vector count)))
	    (do ((i 0 (+ 1 i))) ((>= i count) array)
	      (u8vector-set! array i (endian-port-read-int1 eport)))))
	((= type TIFF:type-short)
	  (let ((array (make-u16vector count)))
	    (do ((i 0 (+ 1 i))) ((>= i count) array)
	      (u16vector-set! array i (endian-port-read-int2 eport)))))
	((= type TIFF:type-long)
	  (let ((array (make-u32vector count)))
	    (do ((i 0 (+ 1 i))) ((>= i count) array)
	      (u32vector-set! array i (endian-port-read-int4 eport)))))
	(else (error "don't know how to read an array "
		"of type " type))))

    ; Now we need to figure out if val-offset contains the offset
    ; or the value (or a part of the value). If val-offset contains the
    ; value, we read it in val-offset and make the value a trivial promise
    ; (delay val-offset).
    ; If val-offset is an offset, then value is a non-trivial promise
    ; (which closes over EPORT).
    (assert (positive? count))
    (let*-values
      (((val-offset value)
	 (cond
	   ((> count 4) 		; for sure, val-offset is an offset
	     (let ((offset (endian-port-read-int4 eport)))
	       (if (= type TIFF:type-ascii)
		 (values offset (delay (read-string offset)))
		 (values offset (delay (read-array offset))))))
	   ((> count 1)			; the iffy case
	     (cond
	       ((and (= count 2) (= type TIFF:type-short))
		 (let* ((v1 (endian-port-read-int2 eport))
			(v2 (endian-port-read-int2 eport))
			(v  (u16vector v1 v2)))
		   (values v (delay v))))
	       ((and (= count 2) (= type TIFF:type-ascii)) ; 1-char string
		 (let ((v
			 (string (ascii->char (endian-port-read-int1 eport)))))
		   (endian-port-read-int1 eport) ; don't read '\0'
		   (endian-port-read-int1 eport) ; skip two more zeros:
		   (endian-port-read-int1 eport) ; padding
		   (values v (delay v))))
	       ((and (= count 2) (or (= type TIFF:type-byte)
				     (= type TIFF:type-undefined)))
		 (let* ((v1 (endian-port-read-int1 eport))
			(v2 (endian-port-read-int1 eport))
			(v  (u8vector v1 v2)))
		   (endian-port-read-int1 eport) ; skip two more zeros:
		   (endian-port-read-int1 eport) ; padding
		   (values v (delay v))))
	       ((and (= count 3) (= type TIFF:type-ascii)) ; 2-char string
		 (let* ((v1 (endian-port-read-int1 eport))
			(v2 (endian-port-read-int1 eport))
			(v  (string (ascii->char v1) (ascii->char v2))))
		   (endian-port-read-int1 eport) ; skip two more zeros:
		   (endian-port-read-int1 eport) ; padding
		   (values v (delay v))))
	       ((and (= count 3) (or (= type TIFF:type-byte)
				     (= type TIFF:type-undefined)))
		 (let* ((v1 (endian-port-read-int1 eport))
			(v2 (endian-port-read-int1 eport))
			(v3 (endian-port-read-int1 eport))
			(v  (u8vector v1 v2 v3)))
		   (endian-port-read-int1 eport) ; skip padding
		   (values v (delay v))))
	       ((and (= count 4) (= type TIFF:type-ascii)) ; 3-char string
		 (let* ((v1 (endian-port-read-int1 eport))
			(v2 (endian-port-read-int1 eport))
			(v3 (endian-port-read-int1 eport))
			(v  (string (ascii->char v1) (ascii->char v2)
			      (ascii->char v3))))
		   (endian-port-read-int1 eport) ; skip padding
		   (values v (delay v))))
	       ((and (= count 4) (or (= type TIFF:type-byte)
				     (= type TIFF:type-undefined)))
		 (let* ((v1 (endian-port-read-int1 eport))
			(v2 (endian-port-read-int1 eport))
			(v3 (endian-port-read-int1 eport))
			(v4 (endian-port-read-int1 eport))
			(v  (u8vector v1 v2 v3 v4)))
		   (values v (delay v))))
	       (else
		 (let ((offset (endian-port-read-int4 eport)))
		   (if (= type TIFF:type-ascii)
		     (values offset (delay (read-string offset)))
		     (values offset (delay (read-array offset))))))))
	   ; Now count is 1
	   ((or (= type TIFF:type-byte) (= type TIFF:type-undefined)
	        (= type TIFF:type-sbyte))
	     (let ((v1 (endian-port-read-int1 eport)))
	       (endian-port-read-int1 eport) ; skip the padding
	       (endian-port-read-int1 eport)
	       (endian-port-read-int1 eport)
	       (values v1 (delay
			   (if (= type TIFF:type-sbyte) (u8->s8 v1) v1)))))
	   ((= type TIFF:type-ascii)	; 0-byte string: count=1 for terminator
	     (endian-port-read-int1 eport) ; skip the padding
	     (endian-port-read-int1 eport)
	     (endian-port-read-int1 eport)
	     (endian-port-read-int1 eport)
	     (values "" (delay "")))
	  ((or (= type TIFF:type-short) (= type TIFF:type-sshort))
	    (let ((v1 (endian-port-read-int2 eport)))
	      (endian-port-read-int1 eport) ; skip the padding
	      (endian-port-read-int1 eport)
	      (values v1 (delay
			  (if (= type TIFF:type-sshort) (u16->s16 v1) v1)))))
	   ((= type TIFF:type-long)
	     (let ((v1 (endian-port-read-int4 eport)))
	       (values v1 (delay v1))))
	   ((= type TIFF:type-slong)
	     (let ((v1 (endian-port-read-int4 eport)))
	       (values v1 (delay (u32->s32 v1)))))
	   ((= type TIFF:type-float)
	     (let ((v1 (endian-port-read-int4 eport)))
	       (values v1 (delay (u32->float v1)))))
	   ((= type TIFF:type-double)
	     (let ((offset (endian-port-read-int4 eport)))
	       (values offset (delay (read-double offset)))))
	   ((or (= type TIFF:type-rational) (= type TIFF:type-srational))
	     (let ((offset (endian-port-read-int4 eport)))
	       (values offset
		 (delay
		   (let* ((_  (endian-port-setpos eport offset))
			  (v1 (endian-port-read-int4 eport))
			  (v2 (endian-port-read-int4 eport)))
		     (if (= type TIFF:type-srational)
		       (/ (u32->s32 v1) (u32->s32 v2))
		       (/ v1 v2)))))))
	   (else (delay (error "unknown data type: " type))))))
      (make-tiff-dir-entry tag type count val-offset value)
    )))

; procedure: print-tiff-dir-entry TIFF-DIR-ENTRY TAGDICT OPORT -> UNSPECIFIED
;
; Print the contents of TIFF-DIR-ENTRY onto the output port OPORT
; using TAGDICT to convert tag identifiers to symbolic names
(define (print-tiff-dir-entry tiff-dir-entry tagdict oport)
  (define (dspl . args) (for-each (lambda (item) (display item oport)) args))
  (let* ((tag-num (tiff-dir-entry-tag tiff-dir-entry))
	 (tag-symbol (tagdict-get-by-num tagdict tag-num)))
    (dspl
      (or tag-symbol
	(string-append "private tag " (number->string tag-num))))
    (dspl  ", count " (tiff-dir-entry-count tiff-dir-entry)
           ", type ")
    (let ((type-str
	    (any?
	      (lambda (elem)
		(and (= (cadr elem) (tiff-dir-entry-type tiff-dir-entry))
		  (caddr elem)))
	      TIFF:types)))
      (if type-str
	(dspl type-str)
	(dspl "unknown (" (tiff-dir-entry-type tiff-dir-entry) ")")))
    (let ((val-offset (tiff-dir-entry-val-offset tiff-dir-entry)))
      (dspl ", value-offset " val-offset)
      (if (integer? val-offset)
	(dspl " (0x" (number->string val-offset 16) ")")))
    (dspl nl)))


;------------------------------------------------------------------------
;                      TIFF Image File Directory
; TIFF directory is a collection of TIFF directory entries. The entries
; are sorted in an ascending order by tag.
; Note, a TIFF file can contain more than one directory (chained together).
; We handle only the first one.
;
; We treat a TIFF image directory somewhat as an ordered, immutable,
; dictionary collection, see SRFI-44.

; http://srfi.schemers.org/srfi-44/srfi-44.html

(define-structure tiff-directory entries tagdict)

; ; procedure: collection-name collection => symbol ('%)
; (define (collection-name coll)
;   (and (tiff-directory? coll) 'tiff-directory))

; ; collection? value => value
; (define collection? tiff-directory?)

; ; procedure: tiff-directory? value => bool
; ; implied by the define-structure

; ; *-size collection => integer
(define (tiff-directory-size coll)
  (vector-length (tiff-directory-entries coll)))

; (define (mutable-collection? coll) #f)
; (define (dictionary? coll) #t)

(define (tiff-directory-empty? coll)
  (zero? (vector-length (tiff-directory-entries coll))))


; tiff-directory-fold-left tiff-directory fold-function seed-value
;             ... => seed-value ...
; The fold function receives a tiff-directory-entry as a value

(define (tiff-directory-fold-left coll fn . seeds)
  (let ((entries (tiff-directory-entries coll)))
    (let loop ((i 0) (seeds seeds))
      (if (>= i (vector-length entries))
	(apply values seeds)
	(let*-values
	  (((proceed? . seeds) (apply fn (vector-ref entries i) seeds)))
	  (loop (if proceed? (+ 1 i) (vector-length entries))
	    seeds))))))

;             procedure: collection-fold-keys-left collection fold-function
;             seed-value ... => seed-value ...
; *-keys->list dictionary => list


; read-tiff-file EPORT [PRIVATE-TAGDICT] => TIFF-DIRECTORY
(define (read-tiff-file eport . tag-dict-opt)
  (endian-port-setpos eport (TIFF:read-header eport))
  (let ((entries (make-vector (endian-port-read-int2 eport)))
	(tagdict (if (null? tag-dict-opt)
		   tiff-standard-tagdict
		   (tagdict-add-all tiff-standard-tagdict
		     (car tag-dict-opt)))))
    (do ((i 0 (+ 1 i))) ((>= i (vector-length entries)))
      (vector-set! entries i (TIFF:read-dir-entry eport)))
    (if (not (zero? (endian-port-read-int4 eport)))
      (cerr "The TIFF file contains several images, only the first one "
	"will be considered" nl))
    (make-tiff-directory entries tagdict)))


; print-tiff-directory TIFF-DIRECTORY OPORT -> UNSPECIFIED
(define (print-tiff-directory tiff-directory oport)
  (let*
    ((entries (tiff-directory-entries tiff-directory))
     (nentries (vector-length entries))
     (tagdict (tiff-directory-tagdict tiff-directory)))
    (for-each (lambda (item) (display item oport))
      (list
	"There are " nentries " entries in the TIFF directory" nl
	"they are" nl))
    (do ((i 0 (+ 1 i))) ((>= i nentries))
      (print-tiff-dir-entry (vector-ref entries i) tagdict oport))))


; *-get dictionary key [absence-thunk] => value
; key can be either a symbol or an integer
; tiff-directory-get TIFF-DIRECTORY KEY [ABSENCE-THUNK] -> VALUE
; If the lookup fails, ABSENCE-THUNK, if given, is evaluated and its value
; is returned. If ABSENCE-THUNK is omitted, the return value on failure
; is #f.
(define (tiff-directory-get coll key . default-val)
  (let*
    ((key
       (cond
	 ((symbol? key)
	   (tagdict-get-by-name (tiff-directory-tagdict coll) key))
	 ((integer? key) key)
	 (else (error "tiff-directory-get: bad type of key: " key))))
      (entry
             ; look up the entry in the directory of entries
             ; We could have used a binary search... On the other hand,
             ; the directory is usually not that big, so that binary
             ; search is kind of overkill
	(any?
	  (lambda (curr-elem)
	    (and (= (tiff-dir-entry-tag curr-elem) key) curr-elem))
	  (tiff-directory-entries coll)))
      )
    (if entry
      (force (tiff-dir-entry-value entry))
      (and (not (null? default-val)) ((car default-val))))))


; tiff-directory-get-as-symbol TIFF-DIRECTORY KEY [ABSENCE-THUNK] -> VALUE
; KEY must be a symbol
; If it is possible, the VALUE is returned as a symbol, as translated
; by the tagdict.
(define (tiff-directory-get-as-symbol coll key . default-val)
  (let ((val (tiff-directory-get coll key)))
    (if val
      (if (integer? val)
	(let ((val-symbol
		(tagdict-tagval-get-by-num
		  (tiff-directory-tagdict coll) key val)))
	  (or val-symbol val))
	val)			; val is not an integer: don't translate
      (and (not (null? default-val)) ((car default-val)))
      )))