png.lisp

   1 ;;;
   2 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
   3 ;;;
   4 ;;; Redistribution and use in source and binary forms, with or without
   5 ;;; modification, are permitted provided that the following conditions
   6 ;;; are met:
   7 ;;;
   8 ;;;   * Redistributions of source code must retain the above copyright
   9 ;;;     notice, this list of conditions and the following disclaimer.
  10 ;;;
  11 ;;;   * Redistributions in binary form must reproduce the above
  12 ;;;     copyright notice, this list of conditions and the following
  13 ;;;     disclaimer in the documentation and/or other materials
  14 ;;;     provided with the distribution.
  15 ;;;
  16 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  17 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  19 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  20 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  21 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  22 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  23 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  25 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  26 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27 ;;;
  28
  29 (in-package #:zpng)
  30
  31 (defclass base-png ()
  32   ((width :initarg :width :reader width)
  33    (height :initarg :height :reader height)
  34    (color-type :initform :truecolor :initarg :color-type :reader color-type)
  35    (bpp :initform 8 :initarg :bpp :reader bpp)))
  36
  37 (defclass png (base-png)
  38   ((image-data :initarg :image-data :reader image-data
  39                :writer (setf %image-data))
  40    (data-array :reader data-array
  41                :writer (setf %data-array))))
  42
  43 (defclass streamed-png (base-png)
  44   ((rows-written
  45     :initarg :rows-written
  46     :accessor rows-written)
  47    (row-data
  48     :initarg :row-data
  49     :accessor row-data)
  50    (compressor
  51     :initarg :compressor
  52     :accessor compressor)
  53    (output-stream
  54     :initarg :output-stream
  55     :accessor output-stream))
  56   (:default-initargs
  57    :rows-written 0))
  58
  59 (defgeneric ihdr-color-type (png))
  60 (defgeneric samples-per-pixel (png))
  61 (defgeneric scanline-offset (png scanline))
  62 (defgeneric rowstride (png))
  63
  64 (defgeneric write-png-header (png stream))
  65 (defgeneric write-ihdr (png stream))
  66 (defgeneric write-idat (png stream))
  67 (defgeneric write-iend (png stream))
  68
  69 (defgeneric copy-png (png))
  70 (defgeneric png= (png1 png2))
  71
  72 (defgeneric write-png-stream (png stream))
  73 (defgeneric write-png (png pathname &key if-exists))
  74
  75 (defgeneric start-png (png stream))
  76 (defgeneric write-row (row png &key start end))
  77 (defgeneric finish-png (png))
  78 (defgeneric rows-left (png))
  79
  80 (defmethod slot-unbound (class (png png) (slot (eql 'data-array)))
  81   (let ((array (make-array (list (height png)
  82                                  (width png)
  83                                  (samples-per-pixel png))
  84                            :displaced-to (image-data png)
  85                            :element-type '(unsigned-byte 8))))
  86     (setf (%data-array png) array)))
  87
  88 (defun check-size (png)
  89   (let ((width (width png))
  90         (height (height png)))
  91     (unless (and (plusp width) (plusp height))
  92       (error 'invalid-size
  93              :width width
  94              :height height))))
  95
  96 (defmethod initialize-instance :after ((png png) &rest args &key image-data)
  97   (declare (ignore args))
  98   (check-size png)
  99   (unless (or image-data (slot-boundp png 'image-data))
 100     (setf (%image-data png)
 101           (make-array (* (height png) (rowstride png))
 102                       :initial-element 0
 103                       :element-type '(unsigned-byte 8)))))
 104
 105 (defmethod ihdr-color-type (png)
 106   (cdr (assoc (color-type png) *color-types*)))
 107
 108 (defmethod samples-per-pixel (png)
 109   (ecase (color-type png)
 110     (:grayscale 1)
 111     (:truecolor 3)
 112     (:indexed-color 1)
 113     (:grayscale-alpha 2)
 114     (:truecolor-alpha 4)))
 115
 116 (defmethod rowstride (png)
 117   (* (width png) (samples-per-pixel png)))
 118
 119 (defmethod scanline-offset (png scanline)
 120   (* scanline (rowstride png)))
 121
 122
 123 (defmethod write-png-header (png stream)
 124   (write-sequence *png-signature* stream))
 125
 126 (defmethod write-ihdr (png stream)
 127   (let ((chunk (make-chunk 73 72 68 82 13)))
 128     (chunk-write-uint32 (width png) chunk)
 129     (chunk-write-uint32 (height png) chunk)
 130     (chunk-write-byte (bpp png) chunk)
 131     (chunk-write-byte (ihdr-color-type png) chunk)
 132     (chunk-write-byte +png-compression-method+ chunk)
 133     (chunk-write-byte +png-filtering+ chunk)
 134     (chunk-write-byte +png-interlace+ chunk)
 135     (write-chunk chunk stream)))
 136
 137 (defun make-idat-callback (stream)
 138   (let* ((idat (make-chunk 73 68 65 84 16384))
 139          (buffer (buffer idat)))
 140     (lambda (data end)
 141       (replace buffer data :start1 4 :end2 end)
 142       (setf (pos idat) (+ end 4))
 143       (write-chunk idat stream))))
 144
 145 (defmethod write-idat (png stream)
 146   (let ((callback (make-idat-callback stream)))
 147     (with-compressor (compressor 'zlib-compressor
 148                                  :callback callback)
 149       (dotimes (i (height png))
 150         (let* ((start-offset (scanline-offset png i))
 151                (end-offset (+ start-offset (rowstride png))))
 152           (compress-octet 0 compressor)
 153           (compress-octet-vector (image-data png)
 154                                  compressor
 155                                  :start start-offset
 156                                  :end end-offset))))))
 157
 158
 159 (defmethod write-iend (png stream)
 160   (let ((chunk (make-chunk 73 69 78 68 0)))
 161     (write-chunk chunk stream)))
 162
 163
 164 (defmethod write-png-stream (png stream)
 165   (check-size png)
 166   (write-png-header png stream)
 167   (write-ihdr png stream)
 168   (write-idat png stream)
 169   (write-iend png stream))
 170
 171 (defmethod write-png (png file &key (if-exists :supersede))
 172   (check-size png)
 173   (with-open-file (stream file
 174                    :direction :output
 175                    :if-exists if-exists
 176                    :if-does-not-exist :create
 177                    :element-type '(unsigned-byte 8))
 178     (write-png-stream png stream)
 179     (truename file)))
 180
 181 (defmethod copy-png (orig)
 182   (make-instance 'png
 183                  :width (width orig)
 184                  :height (height orig)
 185                  :color-type (color-type orig)
 186                  :bpp (bpp orig)
 187                  :image-data (copy-seq (image-data orig))))
 188
 189 (defmethod png= (png1 png2)
 190   (or (eq png1 png2)
 191       (and (= (width png1)  (width png2))
 192            (= (height png1) (height png2))
 193            (= (bpp png1) (bpp png2))
 194            (eq (color-type png1) (color-type png2))
 195            (let ((png1.data (image-data png1))
 196                  (png2.data (image-data png2)))
 197              (not (mismatch png1.data png2.data))))))
 198
 199
 200 ;;; Streamed PNG methods
 201
 202 (defmethod slot-unbound (class (png streamed-png) (slot (eql 'row-data)))
 203   (let ((data (make-array (rowstride png) :element-type '(unsigned-byte 8)
 204                           :initial-element 0)))
 205     (setf (row-data png) data)))
 206
 207 (defmethod start-png ((png streamed-png) stream)
 208   (setf (output-stream png) stream)
 209   (write-png-header png stream)
 210   (write-ihdr png stream)
 211   (setf (compressor png)
 212         (make-instance 'zlib-compressor
 213                        :callback (make-idat-callback stream)))
 214   stream)
 215
 216 (defmethod write-row (row (png streamed-png) &key (start 0) end)
 217   (let ((rowstride (rowstride png)))
 218     (setf end (or end (+ start rowstride)))
 219     (let ((row-length (- end start)))
 220       (unless (= (- end start) (rowstride png))
 221         (error 'invalid-row-length
 222                :expected-length rowstride
 223                :actual-length row-length))
 224       (unless (< (rows-written png) (height png))
 225         (error 'too-many-rows :count (height png)))
 226       (let ((compressor (compressor png)))
 227         (compress-octet 0 compressor)
 228         (compress-octet-vector row compressor :start start :end end)
 229         (incf (rows-written png))))))
 230
 231 (defun reset-streamed-png (png)
 232   (setf (rows-written png) 0)
 233   (slot-makunbound png 'compressor)
 234   (slot-makunbound png 'output-stream)
 235   (fill (row-data png) 0))
 236
 237 (defmethod finish-png ((png streamed-png))
 238   (when (/= (rows-written png) (height png))
 239     (error 'insufficient-rows
 240            :written (rows-written png)
 241            :needed (height png)))
 242   (finish-compression (compressor png))
 243   (write-iend png (output-stream png))
 244   (reset-streamed-png png)
 245   png)
 246
 247 (defmethod rows-left ((png streamed-png))
 248   (- (height png) (rows-written png)))