(in-package :zpb-exif)

(defparameter *data-sizes*
  ;; 0 1 2 3 4 5 6 7 8 9 10
  #( 0 1 1 2 4 8 0 1 0 4  8))

(defun data-size (type)
  (assert (<= 1 type 10))
  (aref *data-sizes* type))

(defun padded-data-size (type count)
  "How much space in the IFD data area will COUNT items of type TYPE
consume?"
  (let ((size (* (data-size type) count)))
    (if (<= size 4)
        0
        (+ size (logand 1 size)))))

;;;
;;; When writing out the IFDs
;;;

(defun put-8 (pos value vector)
  (setf (aref vector pos) (ldb (byte 8 0) value)))

(defun put-16 (pos value vector)
  (setf (aref vector (+ pos 0)) (ldb (byte 8 8) value)
        (aref vector (+ pos 1)) (ldb (byte 8 0) value)))

(defun put-32 (pos value vector)
  (setf (aref vector (+ pos 0)) (ldb (byte 8 24) value)
        (aref vector (+ pos 1)) (ldb (byte 8 16) value)
        (aref vector (+ pos 2)) (ldb (byte 8  8) value)
        (aref vector (+ pos 3)) (ldb (byte 8  0) value)))

(defun put-byte (pos value vector)
  (put-8 pos value vector))

(defun put-ascii (pos value vector)
  (loop for i from pos
        for j from 0 below (length value)
        do (put-8 i (char-code (char value j)) vector))
  (put-8 (+ pos (length value)) 0 vector))

(defun put-short (pos value vector)
  (put-16 pos value vector))

(defun put-long (pos value vector)
  (put-32 pos value vector))

(defun put-rational (pos value vector)
  (put-32 (+ pos 0) (numerator   value) vector)
  (put-32 (+ pos 4) (denominator value) vector))

(defun put-undefined (pos value vector)
  (replace vector value :start1 pos))

(defun put-slong (pos value vector)
  (put-32 pos value vector))

(defun put-srational (pos value vector)
  (put-32 (+ pos 0) (numerator   value) vector)
  (put-32 (+ pos 4) (denominator value) vector))

(defun ifd-base-size (ifd)
  (let ((entry-count-size 2)
        (next-ifd-entry-pointer-size 4)
        (entries-size (* (length (entries ifd)) 12)))
    (+ entry-count-size entries-size next-ifd-entry-pointer-size)))

(defun ifd-total-size (ifd)
  (+ (ifd-base-size ifd)
     (loop for e across (entries ifd)
           summing (padded-data-size (type e) (count e)))))


(defparameter *type-writers*
  #(put-unknown-type          ; 0
    put-byte                  ; 1
    put-ascii                 ; 2
    put-short                 ; 3
    put-long                  ; 4
    put-rational              ; 5
    put-unknown-type          ; 6
    put-undefined             ; 7
    put-unknown-type          ; 8
    put-slong                 ; 9
    put-srational             ;10
    put-unknown-type          ;11
    put-unknown-type          ;12
    put-unknown-type          ;13
    put-unknown-type          ;14
    put-unknown-type          ;15
    ))

(defun put-unknown-type (&rest args)
  (declare (ignore args))
  (error "uknown type"))

(defun put-some-type (pos type value vector)
  (funcall (aref *type-writers* type) pos value vector))

(defun put-ifd-value (pos type count value vector)
  (if (or (= count 1) (= type 2))
      (put-some-type pos type value vector)
      (loop for i from pos by (data-size type)
            for v across value
            do (put-some-type i type v vector))))

(defun put-ifd-entry (pos data-pos ifd-entry vector)
  (with-slots (tag type count value value-offset)
      ifd-entry
    (put-16 (+ pos 0) tag vector)
    (put-16 (+ pos 2) type vector)
    (put-32 (+ pos 4) count vector)
    (let ((size (* count (data-size type))))
      (cond ((<= size 4)
             (put-ifd-value (+ pos 8) type count value vector))
            (t
             (put-ifd-value data-pos type count value vector)
             (put-32 (+ pos 8) data-pos vector))))))

(defun put-ifd (pos ifd vector)
  (with-slots (entries next-ifd-offset)
      ifd
    (put-16 0 (length entries) vector)
    (incf pos 2)
    (let ((data-pos (+ pos (ifd-base-size ifd))))
      (dotimes (i (length entries))
        (let ((entry (aref entries i)))
          (put-ifd-entry pos data-pos entry vector)
          (incf pos 12)
          (incf data-pos (padded-data-size (type entry)
                                           (count entry))))))
    (put-32 pos next-ifd-offset vector)))

(defun histogram (vector)
  (let ((counts (make-array 256)))
    (loop for i across vector do
          (incf (aref counts i)))
    (loop for i across counts
          for j from 0
          unless (zerop i) do
          (format t "~4,' D: ~D~%" j i))))

(defun ifd-offsets (exif)
  "Return the Image, Exif, GPS, Interoperability, and Thumbnail IFD
locations as multiple values."
  (with-slots (image-ifd exif-ifd gps-ifd interoperability-ifd thumbnail-ifd)
      exif
    (values (offset image-ifd)
            (and exif-ifd (offset exif-ifd))
            (and interoperability-ifd (offset interoperability-ifd))
            (and gps-ifd (offset gps-ifd))
            (and thumbnail-ifd (offset thumbnail-ifd)))))

(defun predicted-ifd-sizes (exif)
  (with-slots (image-ifd exif-ifd gps-ifd interoperability-ifd thumbnail-ifd)
      exif
    (let ((image-size (ifd-total-size image-ifd))
          (exif-size (or (and exif-ifd (ifd-total-size exif-ifd)) 0))
          (interoperability-size (or (and interoperability-ifd
                                          (ifd-total-size interoperability-ifd))
                                     0))
          (gps-size (or (and gps-ifd (ifd-total-size gps-ifd)) 0))
          (thumbnail-size (or (and thumbnail-ifd (ifd-total-size thumbnail-ifd))
                              0)))
      (values image-size
              exif-size
              interoperability-size
              gps-size
              thumbnail-size))))
              
(defun predicted-ifd-offsets (exif)
  (multiple-value-bind (image-size
                        exif-size
                        interoperability-size
                        gps-size
                        thumbnail-size)
      (predicted-ifd-sizes exif)
    (values 8
            (+ 8 image-size)
            (+ 8 image-size exif-size)
            (+ 8 image-size exif-size interoperability-size)
            (+ 8 image-size exif-size interoperability-size gps-size))))