;;;; -*- Mode: Lisp; Package: User; -*-
;;;; --------------------------------------------------------------------------
;;;; File:          png.cl
;;;; Description:   A program to decode and encode PNG files
;;;; Author:        Harald Musum <musum@pvv.org>
;;;; Created:       2001-01-17
;;;; Distribution:  See the accompanying file COPYING.
;;;; --------------------------------------------------------------------------
;;;;  (c) copyright 2001 by Harald Musum
;;;;
;;;; $Id: png.cl,v 1.6 2001/05/21 20:43:32 musum Exp $
;;;;
;;;; DOCUMENTATION
;;;;
;;;; See the file README.
;;;; 



(in-package "PNG")


(eval-when (compile)
  (declaim (optimize (speed 0) (safety 3) (space 1) (debug 3) #+cmu (ext:inhibit-warnings 3))))
;  (declaim (optimize (speed 3) (safety 0) (space 1) (debug 1) #+cmu (ext:inhibit-warnings 3))))



(defparameter *debug-level* 0)
(defparameter *debug-stream* t)


(defmacro debug-format-1 (&body body)
  `(case *debug-level*
     (0 nil)
     (1 (format *debug-stream* ,@body))
     (2 (format *debug-stream* ,@body))))


(defmacro debug-format-2 (&body body)
  `(case *debug-level*
     (0 nil)
     (1 nil)
     (2 (format *debug-stream*,@body))))



(defconstant +png-major-version+ 0)
(defconstant +png-minor-version+ 1)

(defconstant +png-signature+ #(137 80 78 71 13 10 26 10))


(defconstant +crc-table+
  (loop with array = (make-array 256 :element-type '(unsigned-byte 32))
	for i from 0 below 256
	for c = i
	do
	(loop for k from 0 below 8
	      do
	      (if (= (logand c 1) 1)
		  (setq c (logxor (ash c -1) #xedb88320))
		(setq c (ash c -1))))
	(setf (aref array i) c)
	finally (return array)))



(deftype bit-depth () '(member 1 2 4 8 16))
(deftype color-type () '(member 0 2 3 4 6))
(defconstant +bit-depth-and-color-type-combination+ '((0 1) (0 2) (0 4) (0 8) (0 16)
						      (2 8) (2 16)
						      (3 1) (3 2) (3 4) (3 8)
						      (4 8) (4 16)
						      (6 8) (6 16)))


(defstruct png-image
  ihdr
  idat
  plte
  text)


(defstruct ihdr
  width
  height
  bit-depth
  color-type
  compression-method
  filter-method
  interlace-method)

(defstruct text
  keywords
  strings)




(defun read-32-bits (stream)
  "Read a 32-bit word from STREAM, MSB first"
  (loop with length = 0
        for i from 0 below 4 do
        (incf length (ash (read-byte stream nil nil) (* 8 (- 3 i))))
        finally (return length)))



(defun read-32-bits-from-array (array)
  "Read a 32-bit word from ARRAY, MSB first"
  (loop with length = 0
        for i from 0 below 4 do
        (incf length (ash (aref array i) (* 8 (- 3 i))))
        finally (return length)))


(defun read-n-bytes-from-array (array n)
  "Read N octets from ARRAY, MSB first"
  (loop with length = 0
        for i from 0 below n do
        (incf length (ash (aref array i) (* 8 (- 1 i))))
        finally (return length)))



;;; CRC-32 functions

(defun update-crc (crc buffer)
  (declare (type (unsigned-byte 32) crc)
           (type (simple-array (unsigned-byte 8)) buffer)
           (optimize speed))
  (setq crc (logxor crc #xffffffff))
  (loop for n from 0 below (length buffer)
	for i = (logand #xff (logxor crc (aref buffer n)))
	do	
	(setq crc (logxor (aref +crc-table+ i) (ash crc -8)))
	finally (return (logxor crc #xffffffff))))

(defun crc (buffer)
  (update-crc 0 buffer))




;;; Functions that operate on PNG chunks

(defun read-chunk-length (stream)
  "Read 4 bytes from STREAM and return length, else return nil"
  (loop with length = 0
        for i from 0 below 4
        for byte = (read-byte stream nil nil)
        do
        (if byte
            (incf length (ash byte (* 8 (- 3 i))))
          (return nil))
        finally (return length)))



(defun read-chunk-type (stream)
  (let ((type (make-array 4 :element-type '(unsigned-byte 8))))
    (read-sequence type stream)
    (print type)
    (map 'string #'code-char type)))



(defun read-chunk (stream length)
  "Read a chunk from STREAM, calculate CRC and compare with supplied CRC.  Return
data if the CRCs are equal, else return an error"
  ;; We have to calculate the CRC of both chunk data and chunk type
  ;; (which is 4 bytes long, so we add 4 bytes to the data array)
  (let ((data (make-array (+ length 4) :element-type '(unsigned-byte 8)))
        data-crc crc chunk-type)
;    (format t "~&chunk-length is ~D~%" length)
    (read-sequence data stream)
    (setq chunk-type (map 'string #'code-char (subseq data 0 4)))
    (debug-format-2 "~&chunk-type is ~a.~%" chunk-type)
    (setq data-crc (crc data))
    (setq crc (read-32-bits stream))
    (if (equal crc data-crc)
        (values chunk-type (subseq data 4))
      (error "CRC error"))))



;;; Chunk decoding functions


(defun decode-idat (idat size)
  "Decode IDAT chunk and return a vector with the result"
  (debug-format-2 "~&IDAT processing. Length of data: ~D.~%" (length idat))
  (decode-buffer idat size))



(defun decode-plte (plte)
  "Decode PLTE chunk and return a vector palette"
  (let* ((length (length plte))
	 (palette (make-array length)))
    (assert (zerop (mod length 3)))
    (debug-format-2 "~&PLTE processing. Length of plte: ~D.~%" length)
    (loop for i from 0 below (floor length 3)
	  do
	  (setf (aref palette i) (vector (aref plte (* i 3))
					 (aref plte (+ (* i 3) 1))
					 (aref plte (+ (* i 3) 2))))
	  finally (return palette))))


(defun decode-ihdr (ihdr)
  "Decode IHDR chunk and return an ihdr struct"
  (debug-format-2 "~&IHDR processing.~%")
  (make-ihdr :width (read-32-bits-from-array (subseq ihdr 0 4))
             :height (read-32-bits-from-array (subseq ihdr 4 8))
             :bit-depth (aref ihdr 8)
             :color-type (aref ihdr 9)
             :compression-method (aref ihdr 10)
             :filter-method (aref ihdr 11)
             :interlace-method (aref ihdr 12)))


(defun decode-gama (gama)
  "Decode gAMA chunk.  Not implemented"
  (debug-format-1 "~&gAMA processing not implemented. Gamma: ~D.~%"
		  (read-32-bits-from-array gama)))



(defun decode-text (text)
  "Decode TEXT chunk and return keyword and string"
  (debug-format-2 "~&tEXt processing")
  (let* ((position (position (code-char 0)
			     (map 'string #'code-char text) :test #'equal))
	 (keyword (map 'string #'code-char (subseq text 0 position)))
	 (string (map 'string #'code-char (subseq text (1+ position)))))
    (values keyword string)))




;;; Filtering functions

    
(defun paeth-predictor (a b c)
  (declare (type (unsigned-byte 8) a b c)
	   (optimize speed))
  (let* ((p (+ a (- b c )))
         (pa (abs (- p a)))
         (pb (abs (- p b)))
         (pc (abs (- p c))))
    (cond ((and (<= pa pb) (<= pa pc)) a)
	  ((<= pb pc) b)
	  (t c))))
    

;; Remove filter line for line, since filter method can be changed for
;; each scanline and we may want to display line by line anyway
(defun remove-filter (data filter-type index previous-line-index
		 length bytes-per-pixel)
  "Remove filtering of FILTER-TYPE for a scanline"
  (declare (type fixnum index length filter-type bytes-per-pixel)
	   (type (vector (unsigned-byte 8)) data)
;	   (type (unsigned-byte 8) filter-type bytes-per-pixel)
	   (optimize speed))
  (loop for i fixnum from 0 below length
	for raw fixnum = (aref data (+ index i))
	for above fixnum = (if previous-line-index
			       (aref data (+ previous-line-index i))
			     0)
	for left fixnum = (if (>= (- i bytes-per-pixel) 1)
			      (aref data (+ index (- i bytes-per-pixel)))
			    0)
	for upper-left fixnum = (if (and previous-line-index
					 (>= (- i bytes-per-pixel) 1))
				    (aref data (+ previous-line-index
						  (- i bytes-per-pixel)))
				  0)
	do
;      (format t "~&index: ~D~%" index)
;      (format t "~&previous-line-index: ~D~%" previous-line-index)
;      (format t "~&i: ~D~%" i)
;      (format t "~&raw: ~D~%" raw)
;      (format t "~&above: ~D~%" above)
;      (format t "~&left: ~D~%" left)
;      (format t "~&upper-left: ~D~%" upper-left)
	(setf (aref data (+ index i))
	      (ecase filter-type
		(0 raw)
		(1 (logand 255 (+ raw left)))
		(2 (logand 255 (+ raw above)))
		(3 (logand 255 (+ raw (floor (+ left above) 2))))
		(4 (logand 255 (+ raw (paeth-predictor left above upper-left))))))))


(defun apply-filter (data filtered-line filter-type index previous-line-index
		     length bytes-per-pixel)
  "Apply FILTER-TYPE filter to a scanline"
  (declare (type (vector (unsigned-byte 8)) data filtered-line)
	   (type fixnum index length)
	   (type (unsigned-byte 8) filter-type bytes-per-pixel)
	   (optimize speed))
  (loop for i fixnum from 1 below length
	;; left-index is the index of the pixel to the left of the
	;; current one
	for left-index fixnum = (- i bytes-per-pixel)
	for raw of-type (unsigned-byte 8) = (aref data (+ index i))
	for left of-type (unsigned-byte 8) = (if (>= left-index 1)
						 (aref data (+ index left-index))
					       0)
	for above of-type (unsigned-byte 8) = (if previous-line-index
						  (aref data (+ previous-line-index i))
						0)
	for upper-left of-type (unsigned-byte 8) = (if (and previous-line-index
							    (>= left-index 1))
						       (aref data
							     (+ previous-line-index left-index))
						     0)
	do
;      (format t "~&index: ~D~%" index)
;      (format t "~&previous-line-index: ~D~%" previous-line-index)
;      (format t "~&i: ~D~%" i)
;      (format t "~&raw: ~D~%" raw)
;      (format t "~&above: ~D~%" above)
;      (format t "~&left: ~D~%" left)
;      (format t "~&upper-left: ~D~%" upper-left)
	(setf (aref filtered-line i)
	      (ecase filter-type
		(0 raw)
		(1 (mod (- raw left) 256))
		(2 (mod (- raw above) 256))
		(3 (mod (- raw (floor (+ left above) 2)) 256))
		(4 (mod (- raw (paeth-predictor left above upper-left)) 256))))))



;;; Output to file (PGM and PNM pictures)

(defun write-pgm (image filename width height comment &optional (16-bit t))
  (debug-format-1 "~&Writing PNG image to PGM file: ~A.~%" filename)
  (with-open-file (stream filename :direction :output :if-exists :supersede)
    (format stream "P2~%#~A~%~D ~D~%" comment width height)
    (if 16-bit
	(progn (write-string "65536" stream)
	       (dotimes (i height)
		 (dotimes (j width)
		   (when (zerop (mod j 4))
		     (terpri stream))
		   (write (ldb (byte 16 0) (aref image i j)) :stream stream)
		   (write-string " " stream))))
      (progn (write-string "255" stream)
	     (dotimes (i height)
	       (dotimes (j width)
		 (when (zerop (mod j 4))
		   (terpri stream))
		 (write (ldb (byte 8 0) (aref image i j)) :stream stream)
		 (write-string " " stream)))))))


(defun write-raw-pgm (image filename width height comment)
  (debug-format-1 "~&Writing PNG image to raw PGM file: ~A.~%" filename)
  (with-open-file (stream filename
			  :direction :output
			  :if-exists :supersede
			  :element-type '(unsigned-byte 8))
    (format stream "P5~%#~A~%~D ~D~%~d~%" comment width height 255)
    (dotimes (i height)
      (dotimes (j width)
	(write-byte (ldb (byte 8 0) (aref image i j)) stream)))))



(defun write-ppm (image filename width height comment &optional (16-bit t))
  (debug-format-1 "~&Writing PNG image to PPM file: ~A.~%" filename)
  (with-open-file (stream filename :direction :output :if-exists :supersede)
    (format stream "P3~%#~A~%~D ~D~%" comment width height)
    (if 16-bit
	(progn (write-string "65536" stream)
      	       (dotimes (i height)
		 (dotimes (j width)
		   (when (zerop (mod j 4))
		     (terpri stream))
		   (write (ldb (byte 16 0) (aref image i j)) :stream stream)
		   (write-string " " stream)
		   (write (ldb (byte 16 16) (aref image i j)) :stream stream)
		   (write-string " " stream)
		   (write (ldb (byte 16 32) (aref image i j)) :stream stream)
		   (write-string " " stream))))
      (progn (write-string "255" stream)
	     (dotimes (i height)
	       (dotimes (j width)
		 (when (zerop (mod j 4))
		   (terpri stream))
		 (write (ldb (byte 8 0) (aref image i j)) :stream stream)
		 (write-string " " stream)
		 (write (ldb (byte 8 8) (aref image i j)) :stream stream)
		 (write-string " " stream)
		 (write (ldb (byte 8 16) (aref image i j)) :stream stream)
		 (write-string " " stream)))))))


(defun write-raw-ppm (image filename width height comment)
  (debug-format-1 "~&Writing PNG image to raw PPM file: ~A.~%" filename)
  (with-open-file (stream filename
			  :direction :output
			  :if-exists :supersede
			  :element-type '(unsigned-byte 8))
    (format stream "P6~%#~A~%~D ~D~%~d~%" comment width height 255)
    (dotimes (i height)
      (dotimes (j width)
	(write-byte (ldb (byte 8 0) (aref image i j)) stream)
	(write-byte (ldb (byte 8 8) (aref image i j)) stream)
	(write-byte (ldb (byte 8 16) (aref image i j)) stream)))))


(defun write-pnm (image output-file width height comment color-type bit-depth)
  (let ((comment (concatenate 'string "Source file: " (file-namestring comment)))
	(16-bit (= bit-depth 16)))
    (if (or (= color-type 0) (= color-type 4))
        (write-pgm image (if (stringp output-file) output-file "pgm") width
                   height comment 16-bit)
;        (write-raw-pgm image (if (stringp output-file) output-file "pgm") width
;                       height comment)
      (write-ppm image (if (stringp output-file) output-file "ppm") width
                 height comment 16-bit))))
;        (write-raw-ppm image (if (stringp output-file) output-file "ppm") width
;                       height comment))))





(defun read-signature (stream)
  "Read PNG signature and return t if correct, else return nil"
  (dotimes (i (length +png-signature+) t)
    (unless (eql (read-byte stream nil nil) (aref +png-signature+ i))
      (return nil))))



(defun result-array-size (ihdr)
  "Compute the size of the array to store the IDAT chunks in."
  (if (= (ihdr-interlace-method ihdr) 0)
      (* (ihdr-height ihdr) (line-length ihdr))
      ;; FIXME.  Is this correct for 16 bit images too?
    (+ (* (ihdr-height ihdr) (line-length ihdr)) (* (ceiling (ihdr-height ihdr) 8) 15))))


(defun line-length (ihdr)
  "Return the length of a scanline"
  ;; Add one because the first byte in each line represents the filter type
  (+ 1
     (ceiling
      (* (ihdr-width ihdr)
         (bits-per-pixel ihdr))
      8)))


(defun bits-per-pixel (ihdr)
  (ecase (ihdr-color-type ihdr)
    (0 (ihdr-bit-depth ihdr))
    (2 (* (ihdr-bit-depth ihdr) 3))
    (3 (ihdr-bit-depth ihdr))
    (4 (* (ihdr-bit-depth ihdr) 2))
    (6 (* (ihdr-bit-depth ihdr) 4))))


(defun bytes-per-pixel (ihdr)
  (ceiling (bits-per-pixel ihdr) 8))



(defun write-pixel-16-bits (target x y red green blue alpha)
  (setf (aref target y x)
	(dpb red (byte 16 0)
	     (dpb green (byte 16 16)
		  (dpb blue (byte 16 32)
		       (dpb (- 255 alpha) (byte 16 48) 0))))))



;; FIXME: Should be able to write pixels that have greater width and
;; height than 1 (when the image is interlaced)
(defun write-pixel (target x y red green blue alpha)
  "Write each pixel to target array as a 32-bit value"
  (declare (type fixnum x y red green blue alpha)
	   (optimize speed))
  (setf (aref target y x)
	(dpb red (byte 8 0)
	     (dpb green (byte 8 8)
		  (dpb blue (byte 8 16)
		       (dpb (- 255 alpha) (byte 8 24) 0))))))



(defun raw-component-value (source byte-index bit-index bit-depth)
  (declare (type (unsigned-byte 32) byte-index bit-index)
	   (type (unsigned-byte 8) bit-depth)
	   (type (vector (unsigned-byte 8)) source)
	   (optimize speed))
  (ecase bit-depth
    (1 (ldb (byte 1 (- 7 (mod bit-index 8)))
	    (aref source (+ byte-index (ash bit-index -3)))))
    (2 (ldb (byte 2 (* 2 (- 3 (mod bit-index 4))))
	    (aref source (+ byte-index (ash bit-index -2)))))
    (4 (ldb (byte 4 (* 4 (- 1 (mod bit-index 2))))
	    (aref source (+ byte-index (ash bit-index -1)))))
    (8 (aref source (+ byte-index bit-index)))
    (16 (logior (ash (aref source byte-index) 8)
		(aref source (+ byte-index 1))))))


(defun component-value (source byte-index bit-index bit-depth)
  (ecase bit-depth
    (1 (* 255 (raw-component-value source byte-index bit-index bit-depth)))
    (2 (* 85 (raw-component-value source byte-index bit-index bit-depth)))
    (4 (* 17 (raw-component-value source byte-index bit-index bit-depth)))
    (8 (raw-component-value source byte-index bit-index bit-depth))
    (16 (raw-component-value source byte-index bit-index bit-depth))))



(defun write-scanline (image image-data target x0 dx y index
			     width pixel-width pixel-height bit-depth color-type)
  ;; pixel-width and pixel-height might be used later if we implement
  ;; rendering of interlaced picture. Ignored for now.
  (declare (ignore pixel-width pixel-height)
	   (type (unsigned-byte 32) x0 dx y index width)
	   (type (unsigned-byte 8) bit-depth color-type)
	   (optimize speed))
  (loop for x of-type (unsigned-byte 32) from x0 by dx
	;; i is the index sample, which means that if bit-depth is 1
	;; it counts bits, if bit-depth is 8 it counts octets
	for i of-type (unsigned-byte 32) from 0
	until (>= x width)
	do
	(ecase color-type
	  (0
	   (let ((value (component-value image-data
					 (if (= bit-depth 16)
					     (+ index (* 2 i))
					   index)
					 i
					 bit-depth)))
	     (if (= bit-depth 16)
		 (write-pixel-16-bits target x y value value value 255)
	       (write-pixel target x y value value value 255))))
	  (2
	   (let ((red (component-value image-data
				       (+ index (* 3 i (ash bit-depth -3)))
				       0
				       bit-depth))
		 (green (component-value image-data
					 (+ index (* 3 i (ash bit-depth -3))
					    (ash bit-depth -3))
					 0
					 bit-depth))
		 (blue (component-value image-data
					(+ index (* 3 i (ash bit-depth -3))
					   (* 2 (ash bit-depth -3)))
					0
					bit-depth)))
	     (if (= bit-depth 16)
		 (write-pixel-16-bits target x y red green blue 255)
               (write-pixel target x y red green blue 255))))
	  (3
	   (let* ((palette-index (raw-component-value image-data index i bit-depth))
		  (plte (png-image-plte image))
		  (red (aref (aref plte palette-index) 0))
		  (green (aref (aref plte palette-index) 1))
		  (blue (aref (aref plte palette-index) 2)))
	     (write-pixel target x y red green blue 255)))
	  (4
	   (let ((value (component-value image-data
					 (+ index (* 2 i (ash bit-depth -3)))
					 0
					 bit-depth))
		 (alpha (component-value image-data
					 (+ index (* 2 i (ash bit-depth -3))
					    (ash bit-depth -3))
					 0
					 bit-depth)))
	     (if (= bit-depth 16)
		 (write-pixel-16-bits target x y value value value alpha)
	       (write-pixel target x y value value value alpha))))
	  (6
	   (let ((red (component-value image-data
				       (+ index (* 4 i (ash bit-depth -3)))
				       0
				       bit-depth))
		 (green (component-value image-data
					 (+ index (* 4 i (ash bit-depth -3))
					    (ash bit-depth -3))
					 0
					 bit-depth))
		 (blue (component-value image-data
					(+ index (* 4 i (ash bit-depth -3))
					   (* (ash bit-depth -3)) 2)
					0
					bit-depth))
		 (alpha (component-value image-data
					 (+ index (* 4 i (ash bit-depth -3))
					    (* (ash bit-depth -3) 3))
					 0
					 bit-depth)))
	     (if (= bit-depth 16)
		 (write-pixel-16-bits target x y red green blue alpha)
               (write-pixel target x y red green blue alpha)))))))


(defun decode-image (stream)
  (declare (optimize speed))
  (if (read-signature stream)
      (debug-format-2 "~&PNG signature OK.~%")
    (error "~A is not a PNG file." stream))
  (loop for chunk-length  = (read-chunk-length stream)
	with idat = (make-array 0 :element-type '(unsigned-byte 8))
	with ihdr
	with plte
	with text
	with width
	with height
	when chunk-length
	do
	(multiple-value-bind (chunk-type data)
	    (read-chunk stream chunk-length)
	  (cond ((string= chunk-type "IHDR")
		 (debug-format-1 "~&Processing IHDR chunk.~%")
		 (setq ihdr (decode-ihdr data))
		 ;; FIXME. Should also check that the combinations of
		 ;; the different parameters are valid.
		 (check-type (ihdr-bit-depth ihdr) bit-depth)
		 (check-type (ihdr-color-type ihdr) color-type)
		 (check-type (ihdr-compression-method ihdr) (integer 0))
		 (check-type (ihdr-compression-method ihdr) (integer 0))
		 (check-type (ihdr-filter-method ihdr) (integer 0))
		 (check-type (ihdr-interlace-method ihdr) (integer 0 1))
		 (setq width (ihdr-width ihdr))
		 (setq height (ihdr-height ihdr))
		 (assert (> width 0))
		 (assert (> height 0))
		 (when (>= *debug-level* 1) (print ihdr)))
		((string= chunk-type "gAMA")
		 (debug-format-1 "~&Processing gAMA chunk.~%")
		 (decode-gama data))
		((string= chunk-type "PLTE")
		 (debug-format-1 "~&Processing PLTE chunk.~%")
		 (setq plte (decode-plte data)))
		 ;;(print plte))
		((string= chunk-type "IDAT")
		 (debug-format-1 "~&Processing IDAT chunk.~%")
		 (setq idat (concatenate '(vector (unsigned-byte 8) *) idat data)))
		((string= chunk-type "tEXt")
                 (debug-format-1 "~&Processing tEXt chunk.~%")
                 (multiple-value-bind (keyword string) (decode-text data)
                   (if text
                       (progn
                         (push keyword (text-keywords text))
                         (push string (text-strings text)))
                     (setq text (make-text :keywords (list keyword) :strings (list string)))))
		 (when (>= *debug-level* 1) (print text)))
		((string= chunk-type "IEND")
		 (debug-format-1 "~&IEND chunk found.  End of processing.~%")
		 (return (make-png-image
			  :ihdr ihdr
			  :idat (decode-idat idat
					     (result-array-size ihdr))
			  :plte plte
			  :text text)))
		(t (debug-format-1 "~&Unsupported chunk type found.  Skipping chunk.~%"))))))




;; FIXME.  Much common code with decode-image
(defun image-size (file)
  (with-open-file (stream file :direction :input :element-type '(unsigned-byte 8))
    (if (read-signature stream)
	(debug-format-2 "~&PNG signature OK.~%")
      (error "~A is not a PNG file." stream))
    (let ((chunk-length (read-chunk-length stream))
	  ihdr width height)
      (when chunk-length
	(multiple-value-bind (chunk-type data)
	    (read-chunk stream chunk-length)
	  (cond ((string= chunk-type "IHDR")
		 (debug-format-1 "~&Processing IHDR chunk.~%")
		 (setq ihdr (decode-ihdr data))
		 ;; FIXME. Should also check that the combinations of
		 ;; the different parameters are valid.
		 (check-type (ihdr-bit-depth ihdr) bit-depth)
		 (check-type (ihdr-color-type ihdr) color-type)
		 (check-type (ihdr-compression-method ihdr) (integer 0))
		 (check-type (ihdr-compression-method ihdr) (integer 0))
		 (check-type (ihdr-filter-method ihdr) (integer 0))
		 (check-type (ihdr-interlace-method ihdr) (integer 0 1))
		 (setq width (ihdr-width ihdr))
		 (setq height (ihdr-height ihdr))
		 (assert (> width 0))
		 (assert (> height 0))
		 (when (>= *debug-level* 1) (print ihdr)))))
	 (return-from image-size (values width height))))))



(defun decode-stream (stream &key output-file)
  (let* ((image (decode-image stream))
	   (image-data (png-image-idat image))
	   (line-length (line-length (png-image-ihdr image)))
	   (previous-line-index nil)
	   (width (ihdr-width (png-image-ihdr image)))
	   (height (ihdr-height (png-image-ihdr image)))
	   (bit-depth (ihdr-bit-depth (png-image-ihdr image)))
	   (color-type (ihdr-color-type (png-image-ihdr image)))
	   (target (make-array (list height width))))
      (declare (type (vector (unsigned-byte 8)) image-data)
	       (optimize speed))
      (debug-format-1 "~&Decoding stream: ~A.~%" stream)
      (case (ihdr-interlace-method (png-image-ihdr image))
	(0
	 (debug-format-2 "~&Interlace method 0.~%")
	 (loop for y from 0 below height
	       with index = 0
	       with dx = 1
	       do
;               (format t "~&Line ~D~%" y)
;               (format t "~&index ~D~%" index)
;               (format t "~&line-length ~D~%" line-length)
;               (format t "~&Filter type ~D~%" (aref image-data index))
	       (remove-filter image-data (aref image-data index) index previous-line-index
			      line-length (bytes-per-pixel (png-image-ihdr image)))
	       (setq previous-line-index index)
;               (format t "~&Line filtered: ~A~%"
;                       (subseq image-data index (+ index line-length)))
	       (write-scanline image image-data target 0 dx y (1+ index)
			       width 1 1 bit-depth color-type)
	       (incf index line-length)))
	(1
	 (debug-format-2 "~&Interlace method 1.~%")
	 (loop for j fixnum from 1 to 7
	       for x0 fixnum in '(0 4 0 2 0 1 0)
	       for dx fixnum in '(8 8 4 4 2 2 1)
	       for y0 fixnum in '(0 0 4 0 2 0 1)
	       for dy fixnum in '(8 8 8 4 4 2 2)
	       for pixel-width fixnum in '(8 4 4 2 2 1 1)
	       for pixel-height fixnum in '(8 4 4 2 2 1 1)
	       ;; Add one because the first byte represents filter method
	       for line-length = (+ 1 (ceiling
				       (* (bits-per-pixel (png-image-ihdr image))
					  (ceiling (- width x0) dx)) 8))
	       for previous-line-index = nil
	       with index fixnum = y0
	       do
	       (when (= j 1)
		 (setq index y0))
;               (format t "~&Pass no. ~D~%" j)
;               (format t "~&x0: ~D~%" x0)
;               (format t "~&dx: ~D~%" dx)
;               (format t "~&y0: ~D~%" y0)
;               (format t "~&dy: ~D~%" dy)
;               (format t "~&pixel-width: ~D~%" pixel-width)
;               (format t "~&pixel-height: ~D~%" pixel-height)
	       (loop for y from y0 by dy
		     until (>= y height)
		     when (> line-length 1)
		     do
;                     (format t "~&Line ~D~%" y)
;                     (format t "~&index ~D~%" index)
;                     (format t "~&line-length ~D~%" line-length)
;                     (format t "~&Filter type ~D~%" (aref image-data index))
		     (remove-filter image-data (aref image-data index) index
				    previous-line-index line-length
				    (bytes-per-pixel (png-image-ihdr image)))
		     (setq previous-line-index index)
;                     (format t "~&Line filtered: ~A~%" (subseq image-data index
;                                                             (+ index line-length)))
		     (write-scanline image image-data target x0 dx
				     y (1+ index) width pixel-width
				     pixel-height bit-depth color-type)
		     (incf index line-length))))
	(t (error "Unknown interlace method")))
;      (format t "~&idat array length ~D~%" (length image-data))
;      (format t "~&idat array written to target arrray")
      (when output-file
	(write-pnm target output-file width height (pathname stream) color-type bit-depth))
      target))


(defun decode-file (file &key (output-file nil))
  (with-open-file (stream file :direction :input :element-type '(unsigned-byte 8))
    (debug-format-1 "~&Decoding file: ~A.~%" file)
    (decode-stream stream :output-file output-file)))




;;; Writing PNG files


(defun encode-stream (source stream &key (filter-type 4) (btype 1)
		      (bit-depth 8) (color-type 2) (source-bit-depth 8))
  (let* ((compression-method 0)
	   (filter-method 0)
	   (interlace-method 0)
	   (height (array-dimension source 0))
	   (width (array-dimension source 1))
	   (ihdr (make-ihdr :width width
			    :height height
			    :bit-depth bit-depth
			    :color-type color-type
			    :compression-method compression-method
			    :filter-method filter-method
			    :interlace-method interlace-method))
	   (text (list "Software"
		       (format nil "CL PNG library, version ~D.~D."
			       +png-major-version+
			       +png-minor-version+)))
	   (plte-hash-table nil)
	   (line-length (line-length ihdr))
	   ;; Add one byte per line to for the filter type
	   (idat (make-array (* height line-length)
			     :initial-element 0
			     :element-type '(unsigned-byte 8)))
	   (line (make-array line-length :element-type '(unsigned-byte 8))))
      (check-type (ihdr-bit-depth ihdr) bit-depth)
      (check-type (ihdr-color-type ihdr) color-type)
      (check-type (ihdr-compression-method ihdr) (integer 0))
      (check-type (ihdr-compression-method ihdr) (integer 0))
      (check-type (ihdr-filter-method ihdr) (integer 0))
      (check-type (ihdr-interlace-method ihdr) (integer 0 1))

      (when (= source-bit-depth 16)
	(loop for i from 0 below (* width height)
	      for red = (ldb (byte 16 0) (row-major-aref source i))
	      for green = (ldb (byte 16 16) (row-major-aref source i))
	      for blue = (ldb (byte 16 32) (row-major-aref source i))
	      for alpha = (ldb (byte 16 48) (row-major-aref source i))
	      for result = 0
	      do
;              (debug-format-1 "~&red ~D.~%" (ash red -8))
;              (debug-format-1 "~&green ~D.~%" (ash green -8))
;              (debug-format-1 "~&blue ~D.~%" (ash blue -8))
;              (debug-format-1 "~&alpha ~D.~%" (ash alpha -8))
              (setq result (dpb (ash red -8) (byte 8 0)
				(dpb (ash green -8) (byte 8 8)
				     (dpb (ash blue -8) (byte 8 16)
					  (dpb (ash alpha -8) (byte 8 24) result)))))
;	      (debug-format-1 "~&result ~D.~%" result)
	      (setf (row-major-aref source i) result)))

      
      (unless (member (list color-type bit-depth)
		      +bit-depth-and-color-type-combination+ :test #'equal)
	(error "~&This combination of color-type (~A) and bit-depth (~A) is illegal."
	       color-type bit-depth))
      (debug-format-1 "~&Encoding image.~%")
      (when (>= *debug-level* 1) (print ihdr))
;      (format t "~&line-length: ~A~%" line-length)
;      (print (type-of idat))
      (when (= color-type 3)
	(setq plte-hash-table (make-plte-hash-table source)))
;	(print plte-hash-table))
      (loop for i from 0 below height
	    do
;            (format t "~&Indices: ~D,~D,~D~%"
;                      (1+ (* j 3)) (+ (* j 3) 2) (+ (* j 3) 3))
	    (setf (subseq idat (* i line-length) (* (1+ i) line-length))
		  (if plte-hash-table
		      (read-pixel source line i width filter-type
				  color-type bit-depth plte-hash-table)
		    (read-pixel source line i width filter-type
				color-type bit-depth))))
;	    (format t "~&Line: ~8b" (subseq idat (* i line-length) (* (1+ i) line-length))))
;      (print idat)
      (loop for i from 0 below height
	    with previous-line-index = nil
	    with index = 0
	    with filtered-line1 = (make-array line-length
					      :element-type '(unsigned-byte 8)
					      :initial-element filter-type)
	    with filtered-line2 = (make-array line-length
					      :element-type '(unsigned-byte 8)
					      :initial-element filter-type)
	    do
;            (format t "~&Line ~D before filtering: ~A~%"
;                    i (subseq idat index (+ index line-length)))
	    (apply-filter idat filtered-line1 filter-type index previous-line-index
			  line-length (bytes-per-pixel ihdr))
;	    (format t "~&Line ~D after filtering: ~A~%" i filtered-line1)
	    (when (> i 0)
	      (replace idat filtered-line2 :start1 (- index  (* 1 line-length))
		       :end1 (+ line-length (- index (* 1 line-length))))
	      ;; Special case for the last line
	      (when (= i (1- height))
		(replace idat filtered-line1 :start1 index
			 :end1 (+ line-length index))))
	    (replace filtered-line2 filtered-line1)
	    (setq previous-line-index index)
      	    (incf index line-length))
      (debug-format-1 "~&Writing PNG signature.~%")
      (write-sequence +png-signature+ stream)
      (debug-format-1 "~&Writing IHDR chunk.~%")
      (write-ihdr stream ihdr)
      (when (= color-type 3)
	(debug-format-1 "~&Writing PLTE chunk.~%")
	(write-plte stream plte-hash-table))
      (debug-format-1 "~&Writing IDAT chunk.~%")
      (encode-idat idat btype #'write-idat stream)
      (debug-format-1 "~&Writing tEXt chunk.~%")
      (write-text stream text)
      (debug-format-1 "~&Writing IEND chunk.~%")
      (write-iend stream)
      (debug-format-1 "~&Image written to file ~A.~%" (pathname stream))))


(defun encode-file (source output-file &key (filter-type 4) (btype 1)
			   (bit-depth 8) (color-type 2) (source-bit-depth 8))
  (with-open-file (stream output-file
			  :direction :output
			  :if-exists :supersede
			  :element-type '(unsigned-byte 8))
    (encode-stream source stream :filter-type filter-type :btype btype
		   :bit-depth bit-depth :color-type color-type
		   :source-bit-depth source-bit-depth)))



(defun write-32-bits-value (stream value)
  (write-byte (ldb (byte 8 24) value) stream)
  (write-byte (ldb (byte 8 16) value) stream)
  (write-byte (ldb (byte 8 8) value) stream)
  (write-byte (ldb (byte 8 0) value) stream))


(defun write-32-bits-to-array (array value &optional (start 0))
  (loop for i from 0 to 3
	do
	(setf (aref array (+ start i)) (ldb (byte 8 (* 8 (- 3 i))) value))))


(defun write-chunk (stream data)
  (write-32-bits-value stream (- (length data) 4))
  (write-sequence data stream)
  (write-32-bits-value stream (crc data)))



(defun write-idat (stream idat)
  (let ((array (concatenate '(vector (unsigned-byte 8) *)
			    (map 'vector #'char-code "IDAT")
			    idat)))
    (write-chunk stream array)))


(defun write-ihdr (stream ihdr)
  ;; Make an array consisting of the values in ihdr plus (13 bytes)
  ;; the chunk type (4 bytes)a
  (let ((ihdr-array (make-array (+ 13 4) :element-type '(unsigned-byte 8))))
    (setf (subseq ihdr-array 0 4) (map 'vector #'char-code "IHDR"))
    (write-32-bits-to-array ihdr-array (ihdr-width ihdr) 4)
    (write-32-bits-to-array ihdr-array (ihdr-height ihdr) 8)
    (setf (aref ihdr-array 12) (ihdr-bit-depth ihdr))
    (setf (aref ihdr-array 13) (ihdr-color-type ihdr))
    (setf (aref ihdr-array 14) (ihdr-compression-method ihdr))
    (setf (aref ihdr-array 15) (ihdr-filter-method ihdr))
    (setf (aref ihdr-array 16) (ihdr-interlace-method ihdr))
    (write-chunk stream ihdr-array)))


(defun write-iend (stream)
  (write-chunk stream (make-array 4
				  :element-type '(unsigned-byte 8)
				  :initial-contents (map 'vector #'char-code "IEND"))))


(defun write-plte (stream plte-hash-table)
  (let* ((entries (hash-table-count plte-hash-table))
	 (plte (make-array (+ (* 3 entries) 4) :element-type '(unsigned-byte 8))))
    (setf (subseq plte 0 4) (map 'vector #'char-code "PLTE"))
    (loop for value being the hash-values of plte-hash-table
	  for index = (first value)
	  for pixel-value = (second value)
	  do
;          (format t "~&index, pixel-value: ~D, ~D~%" index pixel-value)
;          (format t "~&R,G,B: ~D, ~D, ~D~%" (ldb (byte 8 0) pixel-value)
;                  (ldb (byte 8 8) pixel-value) (ldb (byte 8 16) pixel-value))
	  (setf (aref plte (+ 4 (* index 3))) (ldb (byte 8 0) pixel-value))
    	  (setf (aref plte (+ 5 (* index 3))) (ldb (byte 8 8) pixel-value))
       	  (setf (aref plte (+ 6 (* index 3))) (ldb (byte 8 16) pixel-value)))
    (write-chunk stream plte)))


(defun write-text (stream text)
  (let* ((keyword (first text))
	 (string (second text))
	 (length (+ (length keyword) 1 (length string)))
	 (text (make-array (+ length 4) :element-type '(unsigned-byte 8)
			   :initial-contents
    			   (concatenate '(vector (unsigned-byte 8) *)
					(map 'vector #'char-code "tEXt")
					(map 'vector #'char-code keyword)
                                        (make-array 1 :initial-element 0)
					(map 'vector #'char-code string)))))
    ;; FIXME. Check that keyword and string does not contain the null
    ;; character and that the length of them are not too large.
    (write-chunk stream text)))




(defun encode-idat (idat btype writer-function stream)
  (encode-buffer idat btype writer-function stream))




(defun read-pixel (source line i width filter-type color-type
		   bit-depth &optional plte-hash-table)
  "Read each pixel from source array and write it to a scanline,
applying a byte for the filter-type as the first byte in the line"
;  (declare (type fixnum x y red green blue alpha)
;           (optimize speed))
;  (format t "~&width in read-pixel: ~D~%" width)
  (setf (aref line 0) filter-type)
  (ecase color-type
    (0 (loop for j from 0 below (floor width (floor 8 bit-depth))
	     do
	     (setf (aref line (1+ j)) (pixel-value source i j bit-depth 0))))
    (2 (loop for j from 0 below (floor width (floor 8 bit-depth))
	     do
    	     (setf (aref line (1+ (* j 3))) (pixel-value source i j bit-depth 0))
	     (setf (aref line (+ (* j 3) 2)) (pixel-value source i j bit-depth 8))
	     (setf (aref line (+ (* j 3) 3)) (pixel-value source i j bit-depth 16))))
    (3 (loop for j from 0 below (floor width (floor 8 bit-depth))
	     do
	     (setf (aref line (1+ j))
		   (first (gethash (ldb (byte 24 0) (aref source i j)) plte-hash-table)))))
    (4 (loop for j from 0 below (floor width (floor 8 bit-depth))
	     do
    	     (setf (aref line (1+ (* j 2))) (pixel-value source i j bit-depth 0))
    	     (setf (aref line (+ (* j 2) 2)) (pixel-value source i j bit-depth 24))))
    (6 (loop for j from 0 below (floor width (floor 8 bit-depth))
	     do
  	     (setf (aref line (1+ (* j 4))) (pixel-value source i j bit-depth 0))
	     (setf (aref line (+ (* j 4) 2)) (pixel-value source i j bit-depth 8))
	     (setf (aref line (+ (* j 4) 3)) (pixel-value source i j bit-depth 16))
	     (setf (aref line (+ (* j 4) 4)) (pixel-value source i j bit-depth 24)))))
  line)
    


(defun pixel-value (source i j bit-depth weight)
;  (format t "~&items-per-byte: ~D~%" (floor 8 bit-depth))
;  (format t "~&i,j: ~D,~D~%" i j)
  (declare (type fixnum i j)
           (type (unsigned-byte 8) bit-depth weight)
           (optimize speed))
  (loop with result of-type (unsigned-byte 8) = 0
        with items-per-byte of-type (unsigned-byte 8) = (floor 8 bit-depth)
	for l of-type (unsigned-byte 32) from (* j items-per-byte) below (* (1+ j) items-per-byte)
	do
;        (format t "~&l: ~D~%" l)
;        (format t "~&byte-weight: ~D~%" (* bit-depth (mod l items-per-byte)))
;        (format t "~&source-value: ~D~%" (ldb (byte 8 weight) (aref source i l)))
	(setq result (dpb (ldb (byte 8 weight) (aref source i l))
			  (byte bit-depth
				(- 8 (* (mod l items-per-byte) bit-depth) bit-depth))
			  result))
	finally (return result)))



(defun make-plte-hash-table (source)
;  (debug-format-2 "~&height: ~D~%" (array-dimension source 0))
;  (debug-format-2 "~&widht: ~D~%" (array-dimension source 1))
  (loop with hash-table = (make-hash-table :test #'equal)
	with index = 0
	for i from 0 below (* (array-dimension source 0) (array-dimension source 1))
	for key = (ldb (byte 24 0) (row-major-aref source i))
	do
	(unless (gethash key hash-table)
	  (setf (gethash key hash-table) (list index key))
	  (incf index))
	finally (progn
		  (debug-format-1 "~&Number of entries in PLTE: ~D~%" index)
		  (when (> index 255)
		    (error "Sorry. Too many entries in PLTE palette. You cannot use a PLTE chunk for this picture."))
		  (return
		    hash-table))))
	


(defun decode-test-png (input-file &optional (output-file t))
  (format t "~&")
  (format t "~&---------------------------------------------------------")
  (format t "~&Testing PNG file decoding with file: ~A.~%" input-file)
  (decode-file input-file :output-file output-file))
    


(defun decode-test-all ()
  (let ((output-file-number1 97)
	(output-file-number2 97))
    (dolist (k (directory "pictures/*.png"))
      (unless (char= (char (pathname-name k) 0) #\0)
	(format t "~&Now processing ~A.~%" k)
	(decode-test-png k
		  (concatenate
		   'string "test"
		   (make-string 1 :initial-element (code-char output-file-number1))
		   (make-string 1 :initial-element (code-char output-file-number2))
		   ".pnm"))
;	(sleep 10)
	(if (= output-file-number2 122)	    
	    (progn
	      (incf output-file-number1)
	      (setq output-file-number2 97))
	  (incf output-file-number2))))))



(defun encode-test-png (input-file &optional (output-file t))
  (format t "~&")
  (format t "~&---------------------------------------------------------")
  (format t "~&Testing PNG file encoding with input file: ~A.~%" input-file)
  (format t "~&Output to file: ~A.~%" output-file)
  (encode-file (decode-file input-file) output-file))


(defun encode-test-all ()
  (let ((output-file-number1 97)
	(output-file-number2 97))
    ;; Lispworks and Clisp lists the file in opposite order and when
    ;; testing I have files with errors in them as the last files ...
    (dolist (k #-(or lispworks clisp) (directory "pictures/*.png")
	       #+(or lispworks clisp) (reverse(directory "pictures/*.png")))
      (unless (char= (char (pathname-name k) 0) #\0)
	(format t "~&Now processing ~A.~%" k)
	(encode-test-png k
			 (concatenate
			  'string "test"
			  (make-string 1 :initial-element (code-char output-file-number1))
			  (make-string 1 :initial-element (code-char output-file-number2))
			  ".png"))
	(if (= output-file-number2 122)
	    (progn
	      (incf output-file-number1)
	      (setq output-file-number2 97))
	  (incf output-file-number2))))))