  Copyright ( c ) 2006   , All Rights Reserved
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  DIRECT , INDIRECT , INCIDENTAL , SPECIAL , EXEMPLARY , OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  INTERRUPTION ) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY ,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
  $ I d : load - gif.lisp , v 1.15 2007/01/05 14:48:11 xach Exp $

(in-package #:skippy)

(defvar *effective-graphic-control* nil
  "The graphic control extension in effect for the current image.")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +extension-introducer+ #x21)
  (defconstant +graphic-control-label+ #xF9)
  (defconstant +comment-label+ #xFE)
  (defconstant +application-label+ #xFF) 
  (defconstant +plain-text-label+ #x01))

(defclass graphic-control-extension ()
  ((delay-time
    :initarg :delay-time
    :reader delay-time)
   (disposal-method
    :initarg :disposal-method
    :reader disposal-method)
   (transparency-index
    :initarg :transparency-index
    :reader transparency-index)))

(defmacro bind-bits ((integer size) bindings &body body)
  (let ((value (gensym))
        (names (mapcar #'first bindings))
        (sizes (mapcar #'second bindings)))
    (let ((total-size (apply #'+ sizes)))
      (when (> total-size size)
        (error "Bitfield total size (~D) is larger than provided integer size (~D)"
               total-size size))
      `(let* ((,value ,integer)
              ,@(loop for offset = size then (- offset field-size)
                      for name in names
                      for field-size in sizes
                      when name
                      collect (list name
                                    `(ldb (byte ,field-size ,(- offset field-size)) ,value))))
         ,@body))))

(defun read-uint16 (stream)
  (logand #xFFFF (+ (ash (read-byte stream) 0)
                    (ash (read-byte stream) 8))))

(defun read-color (stream)
  (logand #xFFFFFF (+ (ash (read-byte stream) 16)
                      (ash (read-byte stream)  8)
                      (ash (read-byte stream)  0))))

(defun read-color-table (count stream)
  (let ((color-table (make-color-table)))
    (dotimes (i count color-table)
      (add-color (read-color stream) color-table))))

(defun stream-position (stream &key (offset 0))
  "FILE-POSITION may return NIL or may signal an error \(for e.g. Gray
streams); wrap it."
  (let ((pos (ignore-errors (file-position stream))))
    (when pos
      (+ pos offset))))

(defun advance-stream-position (stream count)
  "Skip past COUNT bytes of input in STREAM."
  (let ((pos (stream-position stream :offset count)))
    (if pos
        (file-position stream pos)
        (dotimes (i count)
          (read-byte stream)))))

(defun merge-graphic-control (image)
  (when *effective-graphic-control*
    (setf (delay-time image)
          (delay-time *effective-graphic-control*)
          (disposal-method image)
          (disposal-method *effective-graphic-control*)
          (transparency-index image)
          (transparency-index *effective-graphic-control*)
          *effective-graphic-control* nil)))

(defun read-image (context stream)
  (let ((left-position (read-uint16 stream))
        (top-position (read-uint16 stream))
        (width (read-uint16 stream))
        (height (read-uint16 stream))
        (flags (read-byte stream))
        (color-table nil))
    (bind-bits (flags 8)
        ((local-color-table-flag 1)
         (interlaced-flag        1)
         (sort-flag              1)
         (reserved               2)
         (color-table-size       3))
      (declare (ignore sort-flag reserved))
      (when (plusp local-color-table-flag)
        (let ((color-table-entry-count (expt 2 (1+ color-table-size))))
          (setf color-table (read-color-table color-table-entry-count
                                              stream))))
      (let* ((code-size (read-byte stream))
             (image-data (make-image-data width height)))
        (lzw-decompress image-data code-size context stream)
        (let ((image 
               (make-image :left-position left-position
                           :top-position top-position
                           :width width
                           :height height
                           :image-data image-data
                           :color-table color-table
                           :interlacedp (plusp interlaced-flag))))
          (when (plusp interlaced-flag)
            (replace image-data (deinterlaced-image-data image)))
          (merge-graphic-control image)
          image)))))

(defun disposal-method-keyword (method)
  (or (car (rassoc method *disposal-methods*))
      :unspecified))

(defun read-graphic-control-extension (stream)
  STREAM is positioned just after the Graphic Control Label
  (let ((block-size (read-byte stream)))
    (when (/= block-size 4)
      (error 'unexpected-value
             :description "block-size"
             :expected-value 4
             :actual-value block-size
             :source stream
             :source-position (stream-position stream :offset -1)))
    (let ((fields (read-byte stream))
          (delay-time (read-uint16 stream))
          (transparency-index (read-byte stream))
          (block-terminator (read-byte stream)))
      (when (/= block-terminator 0)
        (error 'unexpected-value
               :description "block-terminator"
               :actual-value block-terminator
               :expected-value 0
               :source stream
               :source-position (stream-position stream :offset -1)))
      (bind-bits (fields 8)
          ((reserved               3)
           (disposal-method        3)
           (user-input-flag        1)
           (transparent-color-flag 1))
        (declare (ignore reserved user-input-flag))
        (when (zerop transparent-color-flag)
          (setf transparency-index nil))
        (make-instance 'graphic-control-extension
                       :delay-time delay-time
                       :disposal-method (disposal-method-keyword disposal-method)
                       :transparency-index transparency-index)))))



(defun skip-data-blocks (stream)
  ;; Data blocks take the form of a series of (<size octet> <vector of
  < size octet > s of data > ) sequences . A size octet of zero
  ;; terminates a data block.
  (loop
   (let ((size (read-byte stream)))
     (when (zerop size)
       (return))
     (advance-stream-position stream size))))

(defun read-application-extension (stream data-stream)
  (let ((signature-length (read-byte stream)))
    (assert (= signature-length 11))
    (let ((identifier (make-array signature-length :element-type 'octet)))
      (read-sequence identifier stream)
      ;;; XXX If skippy ever supports more application extensions, it
      ;;; would make sense to put them in a table instead of
      ;;; hardcoding specific extension identifiers here.
      (when (equalp identifier *netscape-signature*)
        (setf (loopingp data-stream) t)))
    (skip-data-blocks stream)))

(defun read-comment-extension (stream)
  (flet ((ascii-char (code)
           ;;; FIXME: This assumes ASCII code-char mapping; could keep a table
           ;;; instead.
           (code-char (min code 127))))
    (with-output-to-string (output)
      (let ((block (make-array 255 :element-type 'octet)))
        (loop
         (let ((count (read-byte stream)))
           (when (zerop count)
             (return))
           (read-sequence block stream :end count)
           (loop for i below count
                 for octet across block
                 do (write-char (ascii-char octet) output))))))))

(defun read-extension-object (stream data-stream)
  (let ((label (read-byte stream)))
    (case label
      (#.+plain-text-label+
       (skip-data-blocks stream))
      (#.+graphic-control-label+
       (setf *effective-graphic-control*
             (read-graphic-control-extension stream)))
      (#.+application-label+
       (read-application-extension stream data-stream))
      (#.+comment-label+
       (when (comment data-stream)
         (skippy-warn "Multiple comments found; only the final comment ~
                       will be loaded"))
       (setf (comment data-stream) (read-comment-extension stream)))
      (t
       (skippy-warn "Skipping unrecognized extension with label #x~2,'0X" label)
       (skip-data-blocks stream)))))

(defun process-objects (data-stream stream)
  (let ((context (make-instance 'decompression-context)))
    (loop
     (let ((tag (read-byte stream nil)))
       (case tag
         ((nil)
          (return))
         (#.+gif-trailer-code+
          (return))
         (#.+image-separator-code+
          (add-image (read-image context stream) data-stream))
         (#.+extension-introducer+
          (read-extension-object stream data-stream))
         (t
          (skippy-warn "Unknown tag ~D in ~A~:[~; at position ~:*~D~]"
                       tag stream (stream-position stream :offset -1))))))))

(defvar *gif87a-signature*
  ;; The ASCII for string "GIF87a"
  (make-array 6 :element-type 'octet
              :initial-contents #(71 73 70 56 55 97)))

(defvar *gif89a-signature*
  ;; The ASCII for string "GIF89a"
  (make-array 6 :element-type 'octet
              :initial-contents #(71 73 70 56 57 97)))

(defun check-gif-signature (stream)
  "Check that STREAM starts with the ASCII string \"GIF89a\" or \"GIF87a\"."
  (let* ((pos (stream-position stream))
         (signature (make-array 6 :element-type 'octet))
         (count (read-sequence signature stream)))
    (when (/= count 6)
      (error 'short-signature
             :source stream
             :position pos))
    (when (and (mismatch signature *gif89a-signature*)
               (mismatch signature *gif87a-signature*))
      (error 'signature-mismatch
             :source stream
             :position pos))))

(defun read-data-stream (stream)
  (check-gif-signature stream)
  (let ((width (read-uint16 stream))
        (height (read-uint16 stream))
        (flags (read-byte stream))
        (background-color-index (read-byte stream))
        (pixel-aspect-ratio (read-byte stream))
        (color-table nil)
        (*effective-graphic-control* nil))
    (declare (ignore background-color-index pixel-aspect-ratio))
    (bind-bits (flags 8)
        ((global-color-table-flag 1)
         (color-resolution        3)
         (sorted-flag             1)
         (global-color-table-size 3))
      (declare (ignore color-resolution sorted-flag))
      (when (plusp global-color-table-flag)
        (let ((color-table-entry-count (expt 2 (1+ global-color-table-size))))
          (setf color-table (read-color-table color-table-entry-count
                                              stream))))
      (let ((data-stream (make-data-stream :height height
                                           :width width
                                           :color-table color-table)))
        (process-objects data-stream stream)
        data-stream))))
            
(defun load-data-stream (file)
  (with-open-file (stream file :direction :input :element-type 'octet)
    (read-data-stream stream)))


 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions
 are met:

   * Redistributions of source code must retain the above copyright
     notice, this list of conditions and the following disclaimer.

   * Redistributions in binary form must reproduce the above
     copyright notice, this list of conditions and the following
     disclaimer in the documentation and/or other materials
     provided with the distribution.

 THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
 OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
 GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 wrap it."
 Data blocks take the form of a series of (<size octet> <vector of
 terminates a data block.
 XXX If skippy ever supports more application extensions, it
 would make sense to put them in a table instead of
 hardcoding specific extension identifiers here.
 FIXME: This assumes ASCII code-char mapping; could keep a table
 instead.
 only the final comment ~
 The ASCII for string "GIF87a"
 The ASCII for string "GIF89a"
  Copyright ( c ) 2006   , All Rights Reserved
  DIRECT , INDIRECT , INCIDENTAL , SPECIAL , EXEMPLARY , OR CONSEQUENTIAL
  INTERRUPTION ) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY ,
  $ I d : load - gif.lisp , v 1.15 2007/01/05 14:48:11 xach Exp $

(in-package #:skippy)

(defvar *effective-graphic-control* nil
  "The graphic control extension in effect for the current image.")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +extension-introducer+ #x21)
  (defconstant +graphic-control-label+ #xF9)
  (defconstant +comment-label+ #xFE)
  (defconstant +application-label+ #xFF) 
  (defconstant +plain-text-label+ #x01))

(defclass graphic-control-extension ()
  ((delay-time
    :initarg :delay-time
    :reader delay-time)
   (disposal-method
    :initarg :disposal-method
    :reader disposal-method)
   (transparency-index
    :initarg :transparency-index
    :reader transparency-index)))

(defmacro bind-bits ((integer size) bindings &body body)
  (let ((value (gensym))
        (names (mapcar #'first bindings))
        (sizes (mapcar #'second bindings)))
    (let ((total-size (apply #'+ sizes)))
      (when (> total-size size)
        (error "Bitfield total size (~D) is larger than provided integer size (~D)"
               total-size size))
      `(let* ((,value ,integer)
              ,@(loop for offset = size then (- offset field-size)
                      for name in names
                      for field-size in sizes
                      when name
                      collect (list name
                                    `(ldb (byte ,field-size ,(- offset field-size)) ,value))))
         ,@body))))

(defun read-uint16 (stream)
  (logand #xFFFF (+ (ash (read-byte stream) 0)
                    (ash (read-byte stream) 8))))

(defun read-color (stream)
  (logand #xFFFFFF (+ (ash (read-byte stream) 16)
                      (ash (read-byte stream)  8)
                      (ash (read-byte stream)  0))))

(defun read-color-table (count stream)
  (let ((color-table (make-color-table)))
    (dotimes (i count color-table)
      (add-color (read-color stream) color-table))))

(defun stream-position (stream &key (offset 0))
  "FILE-POSITION may return NIL or may signal an error \(for e.g. Gray
  (let ((pos (ignore-errors (file-position stream))))
    (when pos
      (+ pos offset))))

(defun advance-stream-position (stream count)
  "Skip past COUNT bytes of input in STREAM."
  (let ((pos (stream-position stream :offset count)))
    (if pos
        (file-position stream pos)
        (dotimes (i count)
          (read-byte stream)))))

(defun merge-graphic-control (image)
  (when *effective-graphic-control*
    (setf (delay-time image)
          (delay-time *effective-graphic-control*)
          (disposal-method image)
          (disposal-method *effective-graphic-control*)
          (transparency-index image)
          (transparency-index *effective-graphic-control*)
          *effective-graphic-control* nil)))

(defun read-image (context stream)
  (let ((left-position (read-uint16 stream))
        (top-position (read-uint16 stream))
        (width (read-uint16 stream))
        (height (read-uint16 stream))
        (flags (read-byte stream))
        (color-table nil))
    (bind-bits (flags 8)
        ((local-color-table-flag 1)
         (interlaced-flag        1)
         (sort-flag              1)
         (reserved               2)
         (color-table-size       3))
      (declare (ignore sort-flag reserved))
      (when (plusp local-color-table-flag)
        (let ((color-table-entry-count (expt 2 (1+ color-table-size))))
          (setf color-table (read-color-table color-table-entry-count
                                              stream))))
      (let* ((code-size (read-byte stream))
             (image-data (make-image-data width height)))
        (lzw-decompress image-data code-size context stream)
        (let ((image 
               (make-image :left-position left-position
                           :top-position top-position
                           :width width
                           :height height
                           :image-data image-data
                           :color-table color-table
                           :interlacedp (plusp interlaced-flag))))
          (when (plusp interlaced-flag)
            (replace image-data (deinterlaced-image-data image)))
          (merge-graphic-control image)
          image)))))

(defun disposal-method-keyword (method)
  (or (car (rassoc method *disposal-methods*))
      :unspecified))

(defun read-graphic-control-extension (stream)
  STREAM is positioned just after the Graphic Control Label
  (let ((block-size (read-byte stream)))
    (when (/= block-size 4)
      (error 'unexpected-value
             :description "block-size"
             :expected-value 4
             :actual-value block-size
             :source stream
             :source-position (stream-position stream :offset -1)))
    (let ((fields (read-byte stream))
          (delay-time (read-uint16 stream))
          (transparency-index (read-byte stream))
          (block-terminator (read-byte stream)))
      (when (/= block-terminator 0)
        (error 'unexpected-value
               :description "block-terminator"
               :actual-value block-terminator
               :expected-value 0
               :source stream
               :source-position (stream-position stream :offset -1)))
      (bind-bits (fields 8)
          ((reserved               3)
           (disposal-method        3)
           (user-input-flag        1)
           (transparent-color-flag 1))
        (declare (ignore reserved user-input-flag))
        (when (zerop transparent-color-flag)
          (setf transparency-index nil))
        (make-instance 'graphic-control-extension
                       :delay-time delay-time
                       :disposal-method (disposal-method-keyword disposal-method)
                       :transparency-index transparency-index)))))



(defun skip-data-blocks (stream)
  < size octet > s of data > ) sequences . A size octet of zero
  (loop
   (let ((size (read-byte stream)))
     (when (zerop size)
       (return))
     (advance-stream-position stream size))))

(defun read-application-extension (stream data-stream)
  (let ((signature-length (read-byte stream)))
    (assert (= signature-length 11))
    (let ((identifier (make-array signature-length :element-type 'octet)))
      (read-sequence identifier stream)
      (when (equalp identifier *netscape-signature*)
        (setf (loopingp data-stream) t)))
    (skip-data-blocks stream)))

(defun read-comment-extension (stream)
  (flet ((ascii-char (code)
           (code-char (min code 127))))
    (with-output-to-string (output)
      (let ((block (make-array 255 :element-type 'octet)))
        (loop
         (let ((count (read-byte stream)))
           (when (zerop count)
             (return))
           (read-sequence block stream :end count)
           (loop for i below count
                 for octet across block
                 do (write-char (ascii-char octet) output))))))))

(defun read-extension-object (stream data-stream)
  (let ((label (read-byte stream)))
    (case label
      (#.+plain-text-label+
       (skip-data-blocks stream))
      (#.+graphic-control-label+
       (setf *effective-graphic-control*
             (read-graphic-control-extension stream)))
      (#.+application-label+
       (read-application-extension stream data-stream))
      (#.+comment-label+
       (when (comment data-stream)
                       will be loaded"))
       (setf (comment data-stream) (read-comment-extension stream)))
      (t
       (skippy-warn "Skipping unrecognized extension with label #x~2,'0X" label)
       (skip-data-blocks stream)))))

(defun process-objects (data-stream stream)
  (let ((context (make-instance 'decompression-context)))
    (loop
     (let ((tag (read-byte stream nil)))
       (case tag
         ((nil)
          (return))
         (#.+gif-trailer-code+
          (return))
         (#.+image-separator-code+
          (add-image (read-image context stream) data-stream))
         (#.+extension-introducer+
          (read-extension-object stream data-stream))
         (t
          (skippy-warn "Unknown tag ~D in ~A~:[~; at position ~:*~D~]"
                       tag stream (stream-position stream :offset -1))))))))

(defvar *gif87a-signature*
  (make-array 6 :element-type 'octet
              :initial-contents #(71 73 70 56 55 97)))

(defvar *gif89a-signature*
  (make-array 6 :element-type 'octet
              :initial-contents #(71 73 70 56 57 97)))

(defun check-gif-signature (stream)
  "Check that STREAM starts with the ASCII string \"GIF89a\" or \"GIF87a\"."
  (let* ((pos (stream-position stream))
         (signature (make-array 6 :element-type 'octet))
         (count (read-sequence signature stream)))
    (when (/= count 6)
      (error 'short-signature
             :source stream
             :position pos))
    (when (and (mismatch signature *gif89a-signature*)
               (mismatch signature *gif87a-signature*))
      (error 'signature-mismatch
             :source stream
             :position pos))))

(defun read-data-stream (stream)
  (check-gif-signature stream)
  (let ((width (read-uint16 stream))
        (height (read-uint16 stream))
        (flags (read-byte stream))
        (background-color-index (read-byte stream))
        (pixel-aspect-ratio (read-byte stream))
        (color-table nil)
        (*effective-graphic-control* nil))
    (declare (ignore background-color-index pixel-aspect-ratio))
    (bind-bits (flags 8)
        ((global-color-table-flag 1)
         (color-resolution        3)
         (sorted-flag             1)
         (global-color-table-size 3))
      (declare (ignore color-resolution sorted-flag))
      (when (plusp global-color-table-flag)
        (let ((color-table-entry-count (expt 2 (1+ global-color-table-size))))
          (setf color-table (read-color-table color-table-entry-count
                                              stream))))
      (let ((data-stream (make-data-stream :height height
                                           :width width
                                           :color-table color-table)))
        (process-objects data-stream stream)
        data-stream))))
            
(defun load-data-stream (file)
  (with-open-file (stream file :direction :input :element-type 'octet)
    (read-data-stream stream)))
