; A Minimal GIF Decoder
;

(defparameter *last-file* nil)
(defparameter *buf* 0)
(defparameter *nbuf* 0)
(defparameter *width* 0)
(defparameter *x* 0)
(defparameter *y* 0)
(defparameter *block* 0)

(defun get-n-bits (n str)
  (loop
   (unless (< *nbuf* n) (return))
   ;; Enough left in block?
   (when (zerop *block*)
     (setq *block* (read-byte str)))
   (setq *buf* (logior (ash (read-byte str) *nbuf*) *buf*))
   (decf *block*)
   (incf *nbuf* 8))
  (let ((result (logand *buf* (1- (ash 1 n)))))
    (setq *buf* (ash *buf* (- n)))
    (decf *nbuf* n)
    result))

(defun first-pixel (table c)
  (let ((rest (aref table c 0))
        (this (aref table c 1)))
    (cond
     ((= -1 rest) this)
     (t (first-pixel table rest)))))

(defun plot-sequence (table c)
  (let ((rest (aref table c 0))
        (this (aref table c 1)))
    (unless (= -1 rest) (plot-sequence table rest))
    (plot this)))

(defun plot (c)
  (format t "~a " c)
  (incf *x*)
  (when (= *x* *width*) (setq *x* 0) (incf *y*) (format t "~%")))

(defun rgb (r g b)
 (logior (ash (logand r #xf8) 8) (ash (logand g #xfc) 3) (ash b -3)))

(defun skip-n-bytes (n str)
  (dotimes (x n) (read-byte str)))

(defun power-2-p (x)
  (zerop (logand x (1- x))))

(defun parse-gif ()
  (let ((file (capi:prompt-for-file "GIF File" :pathname *last-file*)))
    (setq *last-file* file)
    (with-open-file (str file :element-type '(unsigned-byte 8))
      (skip-n-bytes 6 str) ; id and version
      (let* ((width (+ (read-byte str) (ash (read-byte str) 8)))
             (height (+ (read-byte str) (ash (read-byte str) 8)))
             (fld (read-byte str))
             (bk (read-byte str))
             (aspect (read-byte str))
             (colbits (max (1+ (logand fld 7)) 2))
             (colours (expt 2 colbits))
             (colour-table (make-array colours))
             (clr colours)
             (end (1+ colours))
             (free (1+ end))
             (bits (1+ colbits)))
        (format t "width: ~a height: ~a fld: ~b bk: ~a aspect: ~a colours: ~a~%"
                width height fld bk aspect colours)
        (setq *width* width)
        ;; Parse colour table
        (dotimes (colour colours)
          (setf (aref colour-table colour)
                (rgb (read-byte str) (read-byte str) (read-byte str))))
        ;; Make and initialise the compression table
        (let ((table (make-array '(4096 2))))
          (dotimes (n colours) (setf (aref table n 0) -1 (aref table n 1) n))
          ;; Parse blocks
          (loop
           (let ((header (read-byte str)))
             (cond
              ((eq header #x2c)
               ;; Parse image descriptor
               (skip-n-bytes 10 str)
               (setq *nbuf* 0)
               (setq *buf* 0)
               (setq *block* 0)
               (setq *x* 0)
               (let (code last)
                 (loop                  
                  (setq last code)
                  (setq code (get-n-bits bits str))
                  (cond
                   ((= code clr)
                    (setq free (1+ end))
                    (setq bits (1+ colbits))
                    (setq code nil))
                   ((= code end) (return))
                   ((null last)
                    (plot-sequence table code))
                   ((< code free) ; Found in table              
                    (setf (aref table free 0) last
                          (aref table free 1) (first-pixel table code))
                    (plot-sequence table code)
                    (incf free)
                    (when (power-2-p free) (incf bits)))
                   ((= code free) ; Not found in table
                    (setf (aref table free 0) last
                          (aref table free 1) (first-pixel table last))
                    (plot-sequence table free)
                    (incf free)
                    (when (power-2-p free) (incf bits)))
                   (t nil)))
                 (skip-n-bytes 1 str)
                 (format t "Free: ~a~%" free)))
              ((eq header #x21)
               ;; Skip extension block
               (let ((gce (read-byte str))
                     (length (read-byte str)))
                 (skip-n-bytes (1+ length) str)))
              ((eq header #x3b)
               (return))
              ;; Unknown header
              (t nil)))))))))