;;; Portable EXIF info parser, based on code written by Kevin Layer
;;; (http://www.lispwire.com/entry-photog-exifinfo-des).
;;;
;;; EXIF info in TIFF files can be parsed and most of EXIF-2.2 and
;;; TIFF-6.0 tags have been added. Exporting EXIF data to files is not
;;; implemeted (yet).
;;;
;;; This code is in the public domain.  You may do with it what you
;;; want.
;;;
;;;
;;; How does this stuff work?
;;; 
;;; CL-USER> (use-package :cl-exif)
;;; T
;;; CL-USER> (setq x (parse-exif-data #p"~/Desktop/IMG_0013.JPG"))
;;; #S(EXIF :FILE #P"/Users/bernd/Desktop/IMG_0013.JPG"...)
;;; CL-USER> (exif-model x)
;;; "Canon PowerShot S80"
;;; CL-USER> (exif-date-time-original x)
;;; "2008:07:17 19:18:35"
;;; CL-USER> (exif-flash x)
;;; 24
;;; CL-USER> (exif-focal-length x)
;;; 207/10
;;; 
;;; $Id: cl-exif.lisp,v 1.5 2008/08/19 16:53:40 bernd Exp $

(defpackage :cl-exif
  (:use :common-lisp)
  (:export
   :parse-exif-data

   :exif
   :make-exif
   :exif-file
   :exif-image-width
   :exif-image-length
   :exif-bits-per-sample
   :exif-compression
   :exif-photometric-interpretation
   :exif-image-description
   :exif-make
   :exif-model
   :exif-strip-offsets
   :exif-orientation
   :exif-samples-per-pixel
   :exif-rows-per-strip
   :exif-strip-byte-counts
   :exif-x-resolution
   :exif-y-resolution
   :exif-planar-configuration
   :exif-resolution-unit
   :exif-transfer-function
   :exif-software
   :exif-date-time
   :exif-artist
   :exif-host-computer
   :exif-white-point
   :exif-primary-chromaticities
   :exif-jpeg-interchange-format
   :exif-jpeg-interchange-format-length
   :exif-y-cb-cr-coefficients
   :exif-y-cb-cr-sub-sampling
   :exif-y-cb-cr-positioning
   :exif-reference-black-white
   :exif-copyright
   :exif-exposure-time
   :exif-f-number
   :exif-exposure-program
   :exif-spectral-sensitivity
   :exif-iso-speed-ratings
   :exif-oecf
   :exif-exif-version
   :exif-date-time-original
   :exif-date-time-digitized
   :exif-components-configuration
   :exif-compressed-bits-per-pixel
   :exif-shutter-speed-value
   :exif-aperture-value
   :exif-brightness-value
   :exif-exposure-bias-value
   :exif-max-aperture-value
   :exif-subject-distance
   :exif-metering-mode
   :exif-light-source
   :exif-flash
   :exif-focal-length
   :exif-subject-area
   :exif-maker-note
   :exif-user-comment
   :exif-sub-sec-time
   :exif-sub-sec-time-original
   :exif-sub-sec-time-digitized
   :exif-flash-pix-version
   :exif-color-space
   :exif-pixel-x-dimension
   :exif-pixel-y-dimension
   :exif-related-sound-file
   :exif-flash-energy
   :exif-spatial-frequency-response
   :exif-focal-plane-x-resolution
   :exif-focal-plane-y-resolution
   :exif-focal-plane-resolution-unit
   :exif-subject-location
   :exif-exposure-index
   :exif-sensing-method
   :exif-file-source
   :exif-scene-type
   :exif-cfa-pattern
   :exif-custom-rendered
   :exif-exposure-method
   :exif-white-balance
   :exif-digital-zoom-ratio
   :exif-focal-length-in-35mm-film
   :exif-scene-capture-type
   :exif-gain-control
   :exif-contrast
   :exif-saturation
   :exif-sharpness
   :exif-device-setting-description
   :exif-subject-distance-range
   :exif-image-unique-id))

(in-package :cl-exif)


(defstruct exif
  file

  ;; Exif tags:
  image-width				; #x0100 image width
  image-length				; #x0101 image height
  (bits-per-sample #(8 8 8))		; #x0102 number of bits per component
  compression				; #x0103 compression scheme
  photometric-interpretation		; #x0106 pixel composition
  image-description			; #x010e image title
  make					; #x010f manufacturer of image input equipment
  model					; #x0110 model of image input equipment
  strip-offsets				; #x0111 image data location
  (orientation 1)			; #x0112 orientation of the image
  (samples-per-pixel 3)			; #x0115 number of components
  rows-per-strip			; #x0116 number of rows per strip
  strip-byte-counts			; #x0117 bytes per compressed strip
  (x-resolution 72)			; #x011a image resolution in width direction
  (y-resolution 72)			; #x011b image resolution in height direction
  (planar-configuration 1)		; #x011c image data arrangement
  (resolution-unit 2)			; #x0128 unit of X and Y resolution 
  transfer-function			; #x012d transfer function
  software				; #x0131 software used
  date-time				; #x0132 file change date and time
  artist				; #x013b person who created the image
  host-computer				; #x013c the computer and/or operating system in use at time of image creation
  white-point				; #x013e white point chromaticity
  primary-chromaticities		; #x013f chromaticities of primaries
  jpeg-interchange-format		; #x0201 offset to JPEG SOI
  jpeg-interchange-format-length	; #x0202 bytes of JPEG data
  y-cb-cr-coefficients			; #x0211 color space transformation matrix
  y-cb-cr-sub-sampling			; #x0212 subsampling ratio of Y to C
  (y-cb-cr-positioning 1)		; #x0213 Y and C positioning
  reference-black-white			; #x0214 pair of black and white reference values

  copyright				; #x8298 copyright holder
  exposure-time				; #x829a exposure time
  f-number				; #x829d F number
  (exposure-program 0)			; #x8822 exposure program
  spectral-sensitivity			; #x8824 spectral sensitivitiy
  iso-speed-ratings			; #x8827 ISO speed ratings
  oecf					; #x8828 optoelectronic coefficient
  
  exif-version				; #x9000 Exif version
  date-time-original			; #x9003 date and time original image was generated
  date-time-digitized			; #x9004 date and time image was made digital data
  components-configuration		; #x9101 meaning of each component
  compressed-bits-per-pixel		; #x9102 image compression mode
  shutter-speed-value			; #x9201 shutter speed
  aperture-value			; #x9202 aperture
  brightness-value			; #x9203 brightness
  exposure-bias-value			; #x9204 exposure bias
  max-aperture-value			; #x9205 maximum lens aperture
  subject-distance			; #x9206 subject distance
  (metering-mode 0)			; #x9207 metering mode
  (light-source 0)			; #x9208 light source
  flash					; #x9209 flash
  focal-length				; #x920a lens focal length
  subject-area				; #x9214 subject area
  maker-note				; #x927c manufacturer notes
  user-comment				; #x9286 user comments
  sub-sec-time				; #x9290 DateTime subseconds
  sub-sec-time-original			; #x9291 DateTimeOriginal subseconds
  sub-sec-time-digitized		; #x9292 DateTimeDigitized subseconds

  flash-pix-version			; #xa000 supported Flashpix version
  color-space				; #xa001 color space information
  pixel-x-dimension			; #xa002 valid image width
  pixel-y-dimension			; #xa003 valid image height
  related-sound-file			; #xa004 related audio file
  flash-energy				; #xa20b flash energy
  spatial-frequency-response		; #xa20c spatial frequency response
  focal-plane-x-resolution		; #xa20e focal plane X resolution
  focal-plane-y-resolution		; #xa20f focal plane Y resolution
  (focal-plane-resolution-unit 2)	; #xa210 focal plane resolution unit
  subject-location			; #xa214 subject location
  exposure-index			; #xa215 exposure index
  sensing-method			; #xa217 sensing method
  file-source				; #xa300 file source
  scene-type				; #xa301 scene type
  cfa-pattern				; #xa302 CFA pattern
  (custom-rendered 0)			; #xa401 custom image processing
  exposure-method			; #xa402 exposure mode
  white-balance				; #xa403 white balance
  digital-zoom-ratio			; #xa404 digital zoom ratio
  focal-length-in-35mm-film		; #xa405 focal length in 35 mm film
  (scene-capture-type 0)		; #xa406 scene capture type
  gain-control				; #xa407 gain control
  (contrast 0)				; #xa408 contrast
  (saturation 0)			; #xa409 saturation
  (sharpness 0)				; #xa40a sharpness
  device-setting-description		; #xa40b device settingss description
  subject-distance-range		; #xa40c subject distance range
  image-unique-id)			; #xa420 Unique image ID


(defun parse-exif-data (file-name)
  "Return EXIF structure from file FILE-NAME. If the file contains
no valid EXIF data return NIL."
  (with-open-file (stream file-name :direction :input :element-type '(unsigned-byte 8))
	 (let ((exif (make-exif :file file-name))
	       (app1 (read-stream-app1 stream)))
	   (process-app1 exif app1))))

;;; Stream
(defun read-stream-app1 (stream)
  "Parse STREAM as TIFF or JPEG file. Return APP1 structure."
  (let ((tag (read-stream-unsigned-byte-16 stream))
	len app1)
    (case tag
      ((#x4949 #x4d4d) ;; TIFF, read complete file because IFD can be
		       ;; stored at the end
                       (file-position stream 0)
                       (setf app1 (make-array (file-length stream) :element-type '(unsigned-byte 8)))
                       (read-sequence app1 stream)
                      app1)
      (#xffd8          ;; JPEG file 
		       ;; search for APP1 tag
		       (loop
			  (setf tag (read-stream-unsigned-byte-16 stream))
			  (setf len (- (read-stream-unsigned-byte-16 stream) 2))
			  (if (= tag #xffe1) ; APP1 found
			      (return)
			      (loop repeat len do (read-byte stream)))) ; jump over directory
			 ;; check for ID code "Exif#\Null" (plus padding byte = 6 bytes)
			 (let ((buf (make-array 6 :element-type '(unsigned-byte 8))))
			   (read-sequence buf stream)
			   (assert (equalp (subseq buf 0 5) #.(map 'vector #'char-code #(#\E #\x #\i #\f #\Null)))
				   nil "No Exif ID code")			   
			   ;; read APP1 structure
			   (setf app1 (make-array (- len 6) :element-type '(unsigned-byte 8)))
			   (read-sequence app1 stream)
			   app1))
      (t                 nil))))

(defun read-stream-unsigned-byte-16 (stream)
  "Read two bytes from STREAM and convert it to a 16-bit unsigned number
\(Big Endian)."
  (let ((n 0))
    (setf (ldb (byte 8 8) n) (read-byte stream))
    (setf (ldb (byte 8 0) n) (read-byte stream))
    n))


;;;; APP1
(defvar *big-endian* nil "Byte order")

(defun process-app1 (exif app1)
  "Fill in EXIF structure from APP1."
  (and app1
       (let ((ifd (process-tiff-header app1)))
	 (process-ifd exif app1 ifd)
	 exif)))

(defun process-tiff-header (app1)
  "Process TIFF header. Set *BIG-ENDIAN* to byte order and return
offset to IFD."
  ;; Little Endian="II", Big Endian="MM"
  (setf *big-endian* (equalp (subseq app1 0 2) #(#.(char-code #\M) #.(char-code #\M))))
  (if (/= (get-unsigned-byte-16 app1 2) 42)
      (warn "TIFF header has not the value 42."))
  (get-unsigned-byte-32 app1 4))

(defun process-ifd (exif app1 ifd)
  "Parse every entry in IFD and update EXIF accordingly."
  (let ((num-interop (get-unsigned-byte-16 app1 ifd)))
    (dotimes (i num-interop)
      (let* ((offset  (+ ifd 2 (* 12 i)))
	     (tag     (get-unsigned-byte-16 app1 offset))
	     (type    (get-unsigned-byte-16 app1 (+ offset 2)))
	     (count   (get-unsigned-byte-32 app1 (+ offset 4)))
	     (val-off (get-unsigned-byte-32 app1 (+ offset 8)))
	     (tag-val (get-value app1 type count val-off)))
	#+or(format t "~&~2D: tag=#X~4,'0X type=~D count=~D val-off=~D: ~S~%"
		i tag type count val-off tag-val)
	(case tag
	  (#x0100 (setf (exif-image-width exif) tag-val))
	  (#x0101 (setf (exif-image-length exif) tag-val))
	  (#x0102 (setf (exif-bits-per-sample exif) tag-val))
	  (#x0103 (setf (exif-compression exif) tag-val))
	  (#x0106 (setf (exif-photometric-interpretation exif) tag-val))
	  (#x010e (setf (exif-image-description exif) tag-val))
	  (#x010f (setf (exif-make exif) tag-val))
	  (#x0110 (setf (exif-model exif) tag-val))
	  (#x0111 (setf (exif-strip-offsets exif) tag-val))
	  (#x0112 (setf (exif-orientation exif) tag-val))
	  (#x0115 (setf (exif-samples-per-pixel exif) tag-val))
	  (#x0116 (setf (exif-rows-per-strip exif) tag-val))
	  (#x0117 (setf (exif-strip-byte-counts exif) tag-val))
	  (#x011a (setf (exif-x-resolution exif) tag-val))
	  (#x011b (setf (exif-y-resolution exif) tag-val))
	  (#x011c (setf (exif-planar-configuration exif) tag-val))
	  (#x0128 (setf (exif-resolution-unit exif) tag-val))
	  (#x012d (setf (exif-transfer-function exif) tag-val))
	  (#x0131 (setf (exif-software exif) tag-val))
	  (#x0132 (setf (exif-date-time exif) tag-val))
	  (#x013b (setf (exif-artist exif) tag-val))
	  (#x013c (setf (exif-host-computer exif) tag-val))
	  (#x013e (setf (exif-white-point exif) tag-val))
	  (#x013f (setf (exif-primary-chromaticities exif) tag-val))
	  (#x0201 (setf (exif-jpeg-interchange-format exif) tag-val))
	  (#x0202 (setf (exif-jpeg-interchange-format-length exif) tag-val))
	  (#x0211 (setf (exif-y-cb-cr-coefficients exif) tag-val))
	  (#x0212 (setf (exif-y-cb-cr-sub-sampling exif) tag-val))
	  (#x0213 (setf (exif-y-cb-cr-positioning exif) tag-val))
	  (#x0214 (setf (exif-reference-black-white exif) tag-val))

	  (#x8298 (setf (exif-copyright exif) tag-val))
	  (#x829a (setf (exif-exposure-time exif) tag-val))
	  (#x829d (setf (exif-f-number exif) tag-val))
	  (#x8822 (setf (exif-exposure-program exif) tag-val))
	  (#x8824 (setf (exif-spectral-sensitivity exif) tag-val))
	  (#x8827 (setf (exif-iso-speed-ratings exif) tag-val))
	  (#x8828 (setf (exif-oecf exif) tag-val))

	  (#x9000 (setf (exif-exif-version exif) tag-val))
	  (#x9003 (setf (exif-date-time-original exif) tag-val))
	  (#x9004 (setf (exif-date-time-digitized exif) tag-val))
	  (#x9101 (setf (exif-components-configuration exif) tag-val))
	  (#x9102 (setf (exif-compressed-bits-per-pixel exif) tag-val))
	  (#x9201 (setf (exif-shutter-speed-value exif) tag-val))
	  (#x9202 (setf (exif-aperture-value exif) tag-val))
	  (#x9203 (setf (exif-brightness-value exif) tag-val))
	  (#x9204 (setf (exif-exposure-bias-value exif) tag-val))
	  (#x9205 (setf (exif-max-aperture-value exif) tag-val))
	  (#x9206 (setf (exif-subject-distance exif) tag-val))
	  (#x9207 (setf (exif-metering-mode exif) tag-val))
	  (#x9208 (setf (exif-light-source exif) tag-val))
	  (#x9209 (setf (exif-flash exif) tag-val))
	  (#x920a (setf (exif-focal-length exif) tag-val))
	  (#x9214 (setf (exif-subject-area exif) tag-val))
	  (#x927c (setf (exif-maker-note exif) tag-val))
	  (#x9286 (setf (exif-user-comment exif) tag-val))
	  (#x9290 (setf (exif-sub-sec-time exif) tag-val))
	  (#x9291 (setf (exif-sub-sec-time-original exif) tag-val))
	  (#x9292 (setf (exif-sub-sec-time-digitized exif) tag-val))

	  (#xa000 (setf (exif-flash-pix-version exif) tag-val))
	  (#xa001 (setf (exif-color-space exif) tag-val))
	  (#xa002 (setf (exif-pixel-x-dimension exif) tag-val))
	  (#xa003 (setf (exif-pixel-y-dimension exif) tag-val))
	  (#xa004 (setf (exif-related-sound-file exif) tag-val))
	  (#xa20b (setf (exif-flash-energy exif) tag-val))
	  (#xa20c (setf (exif-spatial-frequency-response exif) tag-val))
	  (#xa20e (setf (exif-focal-plane-x-resolution exif) tag-val))
	  (#xa20f (setf (exif-focal-plane-y-resolution exif) tag-val))
	  (#xa210 (setf (exif-focal-plane-resolution-unit exif) tag-val))
	  (#xa214 (setf (exif-subject-location exif) tag-val))
	  (#xa215 (setf (exif-exposure-index exif) tag-val))
	  (#xa217 (setf (exif-sensing-method exif) tag-val))
	  (#xa300 (setf (exif-file-source exif) tag-val))
	  (#xa301 (setf (exif-scene-type exif) tag-val))
	  (#xa302 (setf (exif-cfa-pattern exif) tag-val))
	  (#xa401 (setf (exif-custom-rendered exif) tag-val))
	  (#xa402 (setf (exif-exposure-method exif) tag-val))
	  (#xa403 (setf (exif-white-balance exif) tag-val))
	  (#xa404 (setf (exif-digital-zoom-ratio exif) tag-val))
	  (#xa405 (setf (exif-focal-length-in-35mm-film exif) tag-val))
	  (#xa406 (setf (exif-scene-capture-type exif) tag-val))
	  (#xa407 (setf (exif-gain-control exif) tag-val))
	  (#xa408 (setf (exif-contrast exif) tag-val))
	  (#xa409 (setf (exif-saturation exif) tag-val))
	  (#xa40a (setf (exif-sharpness exif) tag-val))
	  (#xa40b (setf (exif-device-setting-description exif) tag-val))
	  (#xa40c (setf (exif-subject-distance-range exif) tag-val))
	  (#xa420 (setf (exif-image-unique-id exif) tag-val))
	  
	  ;; Exif-, GPS Info- and Interoperability IFD Pointer
	  ((#x8769 #x8825 #xa005) (process-ifd exif app1 val-off)))))))

(defun get-value (seq type count val-off)
  "Return tag values (single value or array)."
  (and (> count 0)
       (case type
	 ;; ASCII
	 (2 (let ((s (make-string (1- count))))
	      (if (<= count 4) 
		  (dotimes (i (1- count) s)
		    (setf (aref s i) (code-char (ldb (byte 8 (* (- 3 i) 8)) val-off))))
		  (dotimes (i (1- count) s)
		    (setf (aref s i) (code-char (aref seq (+ val-off i))))))))
	 ;; SHORT
	 (3 (case count 
	      (1 (if *big-endian*
		     (ldb (byte 16 16) val-off)
		     (ldb (byte 16 0) val-off)))
	      (2 (let ((a (make-array 2 :element-type '(unsigned-byte 16))))
		   (if *big-endian*
		       (setf (aref a 0) (ldb (byte 16 16) val-off)
			     (aref a 1) (ldb (byte 16  0) val-off))
		       (setf (aref a 0) (ldb (byte 16  0) val-off)
			     (aref a 1) (ldb (byte 16 16) val-off)))))
	      (t (let ((a (make-array count :element-type '(unsigned-byte 16))))
		   (dotimes (i count a)
		     (setf (aref a i) (get-unsigned-byte-16 seq (+ val-off (* 2 i)))))))))
	 ;; LONG
	 (4 (if (= count 1)
		val-off
		(let ((a (make-array count :element-type '(unsigned-byte 32))))
		  (dotimes (i count a)
		    (setf (aref a i) (get-unsigned-byte-32 seq (+ val-off (* 4 i))))))))
	 ;; RATIONAL
	 (5 (let ((n (get-unsigned-byte-32 seq val-off))
		  (d (get-unsigned-byte-32 seq (+ val-off 4))))
	      (/ n d)))
	 ;; UNDEFINED
	 (7 (if (<= count 4)
		val-off
		(subseq seq val-off (+ val-off count))))
	 ;; LONG
	 (9 (if (= count 1)
		(unsigned-signed-byte-32 val-off)
		(let ((a (make-array count :element-type '(signed-byte 32))))
		  (dotimes (i count a)
		    (setf (aref a i) (get-signed-byte-32 seq (+ val-off (* 4 i))))))))
	 ;; SRATIONAL
	 (10 (let ((n (get-signed-byte-32 seq val-off))
		   (d (get-signed-byte-32 seq (+ val-off 4))))
	       (/ n d))))))

(defun get-unsigned-byte-16 (seq offset)
  "Get two bytes from SEQ and convert it to a 16-bit unsigned number."
  (let ((n 0))
    (if *big-endian*
	(setf
	  (ldb (byte 8 8) n) (aref seq offset)
	  (ldb (byte 8 0) n) (aref seq (1+ offset)))
	(setf
	  (ldb (byte 8 0) n) (aref seq offset)
	  (ldb (byte 8 8) n) (aref seq (1+ offset))))
    n))

(defun get-unsigned-byte-32 (seq offset)
  "Get four bytes from SEQ and convert it to a 32-bit unsigned number."
  (let ((n 0))
    (if *big-endian*
	(setf
	  (ldb (byte 8 24) n) (aref seq offset)
	  (ldb (byte 8 16) n) (aref seq (+ offset 1))
	  (ldb (byte 8  8) n) (aref seq (+ offset 2))
	  (ldb (byte 8  0) n) (aref seq (+ offset 3)))
	(setf
	  (ldb (byte 8  0) n) (aref seq offset)
	  (ldb (byte 8  8) n) (aref seq (+ offset 1))
	  (ldb (byte 8 16) n) (aref seq (+ offset 2))
	  (ldb (byte 8 24) n) (aref seq (+ offset 3))))
    n))

(defun get-signed-byte-32 (seq offset)
  "Get four bytes from SEQ and convert it to a 32-bit signed number."
  (unsigned-signed-byte-32 (get-unsigned-byte-32 seq offset)))


(defun unsigned-signed-byte-32 (n)
  "Convert a unsigned 32-bit integer to signed 32-bit."
  (if (logbitp 31 n)
      (- n #x100000000)
      n))