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 (defclass pixel-streamed-png (streamed-png)
  60   ((current-offset
  61     :initform 0
  62     :accessor current-offset)))
  63
  64 (defgeneric ihdr-color-type (png))
  65 (defgeneric samples-per-pixel (png))
  66 (defgeneric scanline-offset (png scanline))
  67 (defgeneric rowstride (png))
  68
  69 (defgeneric write-png-header (png stream))
  70 (defgeneric write-ihdr (png stream))
  71 (defgeneric write-idat (png stream))
  72 (defgeneric write-iend (png stream))
  73
  74 (defgeneric copy-png (png))
  75 (defgeneric png= (png1 png2))
  76
  77 (defgeneric write-png-stream (png stream))
  78 (defgeneric write-png (png pathname &key if-exists))
  79
  80 (defgeneric start-png (png stream))
  81 (defgeneric write-row (row png &key start end))
  82 (defgeneric finish-png (png))
  83 (defgeneric rows-left (png))
  84 (defgeneric reset-streamed-png (png))
  85
  86 (defgeneric write-pixel (pixel png))
  87 (defgeneric pixels-left-in-row (png))
  88
  89 (defmethod slot-unbound (class (png png) (slot (eql 'data-array)))
  90   (let ((array (make-array (list (height png)
  91                                  (width png)
  92                                  (samples-per-pixel png))
  93                            :displaced-to (image-data png)
  94                            :element-type '(unsigned-byte 8))))
  95     (setf (%data-array png) array)))
  96
  97 (defun check-size (png)
  98   (let ((width (width png))
  99         (height (height png)))
 100     (unless (and (plusp width) (plusp height))
 101       (error 'invalid-size
 102              :width width
 103              :height height))))
 104
 105 (defmethod initialize-instance :after ((png png) &rest args &key image-data)
 106   (declare (ignore args))
 107   (check-size png)
 108   (unless (or image-data (slot-boundp png 'image-data))
 109     (setf (%image-data png)
 110           (make-array (* (height png) (rowstride png))
 111                       :initial-element 0
 112                       :element-type '(unsigned-byte 8)))))
 113
 114 (defmethod ihdr-color-type (png)
 115   (cdr (assoc (color-type png) *color-types*)))
 116
 117 (defmethod samples-per-pixel (png)
 118   (ecase (color-type png)
 119     (:grayscale 1)
 120     (:truecolor 3)
 121     (:indexed-color 1)
 122     (:grayscale-alpha 2)
 123     (:truecolor-alpha 4)))
 124
 125 (defmethod rowstride (png)
 126   (* (width png) (samples-per-pixel png)))
 127
 128 (defmethod scanline-offset (png scanline)
 129   (* scanline (rowstride png)))
 130
 131
 132 (defmethod write-png-header (png stream)
 133   (write-sequence *png-signature* stream))
 134
 135 (defmethod write-ihdr (png stream)
 136   (let ((chunk (make-chunk 73 72 68 82 13)))
 137     (chunk-write-uint32 (width png) chunk)
 138     (chunk-write-uint32 (height png) chunk)
 139     (chunk-write-byte (bpp png) chunk)
 140     (chunk-write-byte (ihdr-color-type png) chunk)
 141     (chunk-write-byte +png-compression-method+ chunk)
 142     (chunk-write-byte +png-filtering+ chunk)
 143     (chunk-write-byte +png-interlace+ chunk)
 144     (write-chunk chunk stream)))
 145
 146 (defun make-idat-callback (stream)
 147   (let* ((idat (make-chunk 73 68 65 84 16384))
 148          (buffer (buffer idat)))
 149     (lambda (data end)
 150       (replace buffer data :start1 4 :end2 end)
 151       (setf (pos idat) (+ end 4))
 152       (write-chunk idat stream))))
 153
 154 (defmethod write-idat (png stream)
 155   (let ((callback (make-idat-callback stream)))
 156     (with-compressor (compressor 'zlib-compressor
 157                                  :callback callback)
 158       (dotimes (i (height png))
 159         (let* ((start-offset (scanline-offset png i))
 160                (end-offset (+ start-offset (rowstride png))))
 161           (compress-octet 0 compressor)
 162           (compress-octet-vector (image-data png)
 163                                  compressor
 164                                  :start start-offset
 165                                  :end end-offset))))))
 166
 167
 168 (defmethod write-iend (png stream)
 169   (let ((chunk (make-chunk 73 69 78 68 0)))
 170     (write-chunk chunk stream)))
 171
 172
 173 (defmethod write-png-stream (png stream)
 174   (check-size png)
 175   (write-png-header png stream)
 176   (write-ihdr png stream)
 177   (write-idat png stream)
 178   (write-iend png stream))
 179
 180 (defmethod write-png (png file &key (if-exists :supersede))
 181   (check-size png)
 182   (with-open-file (stream file
 183                    :direction :output
 184                    :if-exists if-exists
 185                    :if-does-not-exist :create
 186                    :element-type '(unsigned-byte 8))
 187     (write-png-stream png stream)
 188     (truename file)))
 189
 190 (defmethod copy-png (orig)
 191   (make-instance 'png
 192                  :width (width orig)
 193                  :height (height orig)
 194                  :color-type (color-type orig)
 195                  :bpp (bpp orig)
 196                  :image-data (copy-seq (image-data orig))))
 197
 198 (defmethod png= (png1 png2)
 199   (or (eq png1 png2)
 200       (and (= (width png1)  (width png2))
 201            (= (height png1) (height png2))
 202            (= (bpp png1) (bpp png2))
 203            (eq (color-type png1) (color-type png2))
 204            (let ((png1.data (image-data png1))
 205                  (png2.data (image-data png2)))
 206              (not (mismatch png1.data png2.data))))))
 207
 208
 209 ;;; Streamed PNG methods
 210
 211 (defmethod slot-unbound (class (png streamed-png) (slot (eql 'row-data)))
 212   (let ((data (make-array (rowstride png) :element-type '(unsigned-byte 8)
 213                           :initial-element 0)))
 214     (setf (row-data png) data)))
 215
 216 (defmethod start-png ((png streamed-png) stream)
 217   (setf (output-stream png) stream)
 218   (write-png-header png stream)
 219   (write-ihdr png stream)
 220   (setf (compressor png)
 221         (make-instance 'zlib-compressor
 222                        :callback (make-idat-callback stream)))
 223   stream)
 224
 225 (defmethod start-png ((png pixel-streamed-png) stream)
 226   (setf (current-offset png) 0)
 227   (call-next-method))
 228
 229 (defmethod write-row (row (png streamed-png) &key (start 0) end)
 230   (let ((rowstride (rowstride png)))
 231     (setf end (or end (+ start rowstride)))
 232     (let ((row-length (- end start)))
 233       (unless (= (- end start) (rowstride png))
 234         (error 'invalid-row-length
 235                :expected-length rowstride
 236                :actual-length row-length))
 237       (unless (< (rows-written png) (height png))
 238         (error 'too-many-rows :count (height png)))
 239       (let ((compressor (compressor png)))
 240         (compress-octet 0 compressor)
 241         (compress-octet-vector row compressor :start start :end end)
 242         (incf (rows-written png))))))
 243
 244 (defmethod reset-streamed-png ((png streamed-png))
 245   (setf (rows-written png) 0)
 246   (slot-makunbound png 'compressor)
 247   (slot-makunbound png 'output-stream)
 248   (fill (row-data png) 0))
 249
 250 (defmethod reset-streamed-png ((png pixel-streamed-png))
 251   (setf (current-offset png) 0)
 252   (call-next-method))
 253
 254 (defmethod finish-png ((png streamed-png))
 255   (when (/= (rows-written png) (height png))
 256     (error 'insufficient-rows
 257            :written (rows-written png)
 258            :needed (height png)))
 259   (finish-compression (compressor png))
 260   (write-iend png (output-stream png))
 261   (reset-streamed-png png)
 262   png)
 263
 264 (defmethod finish-png ((png pixel-streamed-png))
 265   (let* ((color-channels (samples-per-pixel png))
 266          (columns (/ (current-offset png) color-channels)))
 267     (unless (zerop columns)
 268       (error 'incomplete-row
 269              :written columns
 270              :needed (/ (length (row-data png)) color-channels))))
 271   (call-next-method))
 272
 273 (defmethod rows-left ((png streamed-png))
 274   (- (height png) (rows-written png)))
 275
 276 (defmethod write-pixel (pixel (png pixel-streamed-png))
 277   (let ((row-data (row-data png))
 278         (samples-per-pixel (length pixel))
 279         (samples-per-pixel-expected (samples-per-pixel png)))
 280     (unless (= samples-per-pixel samples-per-pixel-expected)
 281       (error 'color-type-mismatch
 282              :given samples-per-pixel
 283              :expected samples-per-pixel-expected))
 284     (replace row-data pixel :start1 (current-offset png))
 285     (when (= (incf (current-offset png) samples-per-pixel) (rowstride png))
 286       (write-row row-data png)
 287       (setf (current-offset png) 0)))
 288   png)
 289
 290 (defmethod pixels-left-in-row ((png pixel-streamed-png))
 291   (/ (- (current-offset png) (rowstride png)) (samples-per-pixel png)))