anchor.diff:    (with-open-file (stream pathname :direction :input :element-type :default)
       (read-tiff-stream stream)))
   
  -(defun write-tiff-stream (stream image)
  -  (declare (ignore stream image))
  -  (error "Not yet!"))
  -
  -(defun write-tiff-file (pathname image)
  -  (with-open-file (stream pathname :direction :output :element-type :default)
  -    (write-tiff-stream stream image)))
  +(defun make-ifd-entry (tag field-type value-count values)
  +  )
  +
  +;; we should return the number of strips (and possibly the length of
  +;; each strip (uncompressed), but not yet)..
  +(defun compute-rows-per-strip (image-length
  +                               bytes-per-row
  +                               &key (strip-size #x40000))
  +  (let ((strip-rows (truncate strip-size bytes-per-row)))
  +    (min image-length strip-rows)))
  +
  +(defclass ifd-entry ()
  +  ((tag :accessor ifd-entry-tag :initarg :tag)
  +   (field-type :accessor ifd-entry-field-type :initarg :field-type)
  +   (count :accessor ifd-entry-count :initarg :count)
  +   (values :accessor ifd-entry-values :initarg :values)
  +   (extra-data :accessor ifd-entry-extra-data :initarg :extra-data)))
  +;;;
  +;;; To write a TIFF file to a stream we need to make some
  +;;; decisions. If we can randomly seek into the file, then we can
  +;;; start writing as we go, seek to the end, retun back to where we
  +;;; were before and write the address of the data we just stored. This
  +;;; isn't such a good idea if we're trying to write to a stream where
  +;;; we can't read (or set) the file-position. Let's see if we can
  +;;; figure out how to write the file without using file-position.
  +(defun write-tiff-stream (image stream &key (byte-order
  +                                             (or *byte-order* :big-endian)))
  +  (declare (optimize (debug 2)))
  +  (with-accessors
  +        ((image-width tiff-image-width)
  +         (image-length tiff-image-length)
  +         (samples-per-pixel tiff-image-samples-per-pixel))
  +      image
  +    (let ((*byte-order* byte-order)
  +          (data-offset 0)
  +          ifd-entries
  +          out-of-line-ifd-values)
  +      (let* ((header-start 0)
  +             (header-end 8)
  +             (directory-start header-end)
  +             (directory-pointer directory-start)
  +             out-of-line-data-start
  +             out-of-line-data-pointer
  +             (bytes-per-row (* image-width samples-per-pixel))
  +             (rows-per-strip
  +              (compute-rows-per-strip image-length bytes-per-row)))
  +        (declare (ignore header-start
  +                         directory-pointer
  +                         out-of-line-data-start
  +                         out-of-line-data-pointer))
  +        (destructuring-bind (strip-offsets strip-byte-counts)
  +            (apply #'mapcar #'list
  +                   (loop for i below image-length by rows-per-strip
  +                      for byte-offset from i by (* rows-per-strip bytes-per-row)
  +                      collect (list byte-offset 
  +                                    (- (min (+ i rows-per-strip) image-length) i))))
  +          (flet ((add-ifd-entry (tag field-type values)
  +                   (push (make-instance 'ifd-entry
  +                                        :tag tag
  +                                        :field-type field-type
  +                                        :values values) ifd-entries))
  +                 (write-ifd-entry (ifd-entry)
  +                   (with-accessors ((tag ifd-entry-tag)
  +                                    (field-type ifd-entry-field-type)
  +                                    (values ifd-entry-values))
  +                       ifd-entry
  +                     (write-int-16 stream tag)
  +                     (write-int-16 stream field-type)
  +                     (let* ((field-count (if (atom values)
  +                                             1
  +                                             (length values)))
  +                            (field-size
  +                             (* (field-length field-type) field-count)))
  +                       (write-int-32 stream field-count)
  +
  +                       ;; if the tag is strip-offsets, we need to fix up
  +                       ;; the location of offsets to point to where the
  +                       ;; will actually be, which we only know once we
  +                       ;; start writing out the data.
  +                       
  +                       (if (<= field-size 4)
  +                           (cond
  +                             ((= field-type +field-type-short+)
  +                              (write-int-16-sequence stream values))
  +                             ((= field-type +field-type-ascii+)
  +                              (error "Can't write inline (<= 4 byte) asciis yet!"))
  +                             ((= field-type +field-type-long+)
  +                              (write-int-32-sequence stream values)))
  +                           (progn
  +                             (push (list tag field-type values)
  +                                   out-of-line-ifd-values)
  +                             (write-int-32 stream field-count)
  +                             (incf data-offset field-size)
  +                             (when (oddp data-offset)
  +                               (incf data-offset)))))))
  +                 (write-out-of-line-data (list)
  +                   (destructuring-bind (tag field-type values)
  +                       list
  +                     (print (list 'out-of-line-data tag field-type
  +                                  values))
  +                     (when (eql tag +strip-offsets-tag+)
  +                       (setf values
  +                             (mapcar
  +                              (lambda (x) (+ x data-offset))
  +                              strip-offsets))
  +                       (incf data-offset
  +                             (reduce #'+ strip-byte-counts))))))
  +
  +            ;; 1. Write the byte-order bytes (either #x4949 for
  +            ;; big-endian, or #4d4d for little-endian).
  +            (ecase byte-order
  +              (:little-endian (write-int-16 stream #x4949))
  +              (:big-endian (write-int-16 stream #x4d4d)))
  +            (incf data-offset 2)
  +      
  +            ;; 2. Write the magic 16-bit integer 42.
  +            (write-int-16 stream 42)
  +            (incf data-offset 2)
  +
  +            ;; 3. Write the offset of the first directory entry.
  +            (write-int-32 stream 8)
  +            (incf data-offset 4)
  +
  +            ;; 4. Write the first IFD (Image File Directory)
  +            ;;
  +            ;; 4a. compute and write the number of directory entries
  +            (add-ifd-entry
  +             +image-width-tag+ +field-type-long+ image-width)
  +            (add-ifd-entry
  +             +image-length-tag+ +field-type-long+ image-width)
  +
  +            ;; now we need RowsPerStrip
  +            ;; FIXME! assume 8 bits per sample for the moment!
  +            (add-ifd-entry +rows-per-strip-tag+
  +                           +field-type-long+
  +                           rows-per-strip)
  +          
  +            (print (cons 'moose strip-offsets))
  +            (print (cons 'moose strip-byte-counts))
  +            ;; StripByteCounts and StripOffsets
  +
  +            (add-ifd-entry 
  +             +strip-byte-counts-tag+ +field-type-long+ strip-offsets)
  +          
  +            (add-ifd-entry 
  +             +strip-offsets-tag+ +field-type-long+ strip-offsets)
  +          
  +            ;; Finally, reverse the ifd-entries list
  +            (setf ifd-entries (nreverse ifd-entries))
  +            
  +            (write-int-16 stream (length ifd-entries))
  +            (incf data-offset (+ 2 (* (length ifd-entries) 12)))
  +
  +            (setf out-of-line-data-start 
  +)
  +            ;; 5. Write the directory entries
  +            (loop for entry in ifd-entries
  +               do 
  +                 (print entry)
  +                 (write-ifd-entry entry))
  +            (setf out-of-line-ifd-values
  +                  (nreverse out-of-line-ifd-values))
  +          
  +            ;; 6. Write 0 to indicate that there are no more IFDs
  +            (write-int-32 stream 0)
  +            (incf data-offset 4)
  +            
  +            ;; 7. Write the data for each out-of-line directory entry
  +            (loop for list in out-of-line-ifd-values
  +               do 
  +               (write-out-of-line-data list))))))))
  +
  +(defmacro write-tiff-file (image pathname &rest args)
  +  `(with-open-file (stream ,pathname
  +                           :direction :output
  +                           :element-type :default
  +                           ,@args)
  +     (write-tiff-stream ,image stream)))
  +
  +(defparameter *image-info-attributes*
  +  `((,+image-width-tag+ "Image Width")
  +    (,+image-length-tag+ "Image Length")
  +    (,+x-resolution-tag+ "X Resolution")
  +    (,+y-resolution-tag+ "Y Resolution")
  +    (,+samples-per-pixel-tag+ "Samples per Pixel")
  +    (,+bits-per-sample-tag+ "Bits per Sample")
  +    (,+rows-per-strip-tag+ "Rows per Strip")
  +    (,+strip-offsets-tag+ "Strip Offsets")
  +    (,+compression-tag+
  +     "Compression" 
  +     ,(lambda (description values)
  +              (cons description 
  +                    (cdr (assoc
  +                          (elt values 0)
  +                          `((,+packbits-compression+ . "Packbits")
  +                            (,+lzw-compression+ . "LZW")))))))))
  +
  +(defun image-info (stream ifd)
  +  (declare (optimize (debug 2)))
  +  (let ((rows-per-strip (get-ifd-value ifd +rows-per-strip-tag+))
  +        (strip-offsets (get-ifd-values ifd +strip-offsets-tag+))
  +        (strip-byte-counts (get-ifd-values ifd +strip-byte-counts-tag+))
  +        (compression (get-ifd-value ifd +compression-tag+))
  +        (planar-configuration (get-ifd-value ifd +planar-configuration-tag+))
  +        (predictor (get-ifd-value ifd +predictor-tag+)))
  +    (append
  +     (list (cons "Byte Order: " *byte-order*))
  +     (loop for attr in *image-info-attributes*
  +        collect
  +        (destructuring-bind (tag description &optional fn)
  +            attr
  +          (if fn
  +              (funcall fn description (get-ifd-values ifd tag))
  +              (cons description (get-ifd-values ifd tag))))))))
  +
  +(defun read-tiff-stream-info (stream)
  +  (let ((*byte-order*))
  +    (let ((byte-order (read-int-16 stream)))
  +      (ecase byte-order
  +        (#x4949 (setf *byte-order* :little-endian))
  +        (#x4d4d (setf *byte-order* :big-endian))))
  +    (let ((tiff-magic (read-int-16 stream)))
  +      (unless (= tiff-magic 42)
  +        (error "Error reading TIFF file. ~S is not 42." tiff-magic)))
  +    (let ((ifds (read-ifds stream)))
  +      (image-info stream (car ifds)))))
  +
  +(defun read-tiff-file-info (pathname)
  +  (with-open-file (stream pathname :direction :input :element-type :default)
  +    (read-tiff-stream-info stream)))
  +
  
positive.code: (defun get-ifd-values (ifd key)
    (let ((field (find key ifd :key 'car :test '=)))
      (when field
        (ifd-entry-values field))))
  
  (defun get-ifd-value (ifd key)
    (let ((values (get-ifd-values ifd key)))
      (when values (car values))))
  
  (defun read-grayscale-image (stream ifd photometric-interpretation)
    (declare (ignore stream ifd photometric-interpretation))
  
negative.code:   (defconstant +field-type-sbyte+ 6)
    (defconstant +field-type-undefined+ 7)
    (defconstant +field-type-sshort+ 8)
    (defconstant +field-type-slong+ 9)
    (defconstant +field-type-srational+ 10)
    (defconstant +field-type-float+ 11)
    (defconstant +field-type-double+ 12))
  
  (defun field-length (tag)
    (case tag
      ((#.+field-type-byte+
        #.+field-type-ascii+
        #.+field-type-sbyte+)
       1)
      ((#.+field-type-short+
        #.+field-type-sshort+)
       2)
      ((#.+field-type-long+
        #.+field-type-slong+
        #.+field-type-float+)
       4)
      ((#.+field-type-rational+
        #.+field-type-srational+
        #.+field-type-double+)
       8)))
  
  (defparameter *byte-order* nil)
  
  (defun vectorize (sequence)
    (if (vectorp sequence)
        sequence
        (map 'vector #'identity sequence)))
  
  (defun listize (sequence)
    (if (listp sequence)
        sequence
        (map 'list #'identity sequence)))
  
  (defun read-bytes (stream count)
    (let ((buf (make-array count :element-type '(unsigned-byte 8))))
      (read-sequence buf stream)
      buf))
  
  (defun read-signed-bytes (stream count)
    (let ((buf (make-array count :element-type '(signed-byte 8))))
      (read-sequence buf stream)
      buf))
  
  