2 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
4 ;;; Redistribution and use in source and binary forms, with or without
5 ;;; modification, are permitted provided that the following conditions
8 ;;; * Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
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
)))
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
))))
43 (defclass streamed-png
(base-png)
45 :initarg
:rows-written
46 :accessor rows-written
)
54 :initarg
:output-stream
55 :accessor output-stream
))
59 (defclass pixel-streamed-png
(streamed-png)
62 :accessor current-offset
)))
64 (defgeneric ihdr-color-type
(png))
65 (defgeneric samples-per-pixel
(png))
66 (defgeneric scanline-offset
(png scanline
))
67 (defgeneric rowstride
(png))
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
))
74 (defgeneric copy-png
(png))
75 (defgeneric png
= (png1 png2
))
77 (defgeneric write-png-stream
(png stream
))
78 (defgeneric write-png
(png pathname
&key if-exists
))
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))
86 (defgeneric write-pixel
(pixel png
))
87 (defgeneric pixels-left-in-row
(png))
89 (defmethod slot-unbound (class (png png
) (slot (eql 'data-array
)))
90 (let ((array (make-array (list (height png
)
92 (samples-per-pixel png
))
93 :displaced-to
(image-data png
)
94 :element-type
'(unsigned-byte 8))))
95 (setf (%data-array png
) array
)))
97 (defun check-size (png)
98 (let ((width (width png
))
99 (height (height png
)))
100 (unless (and (plusp width
) (plusp height
))
105 (defmethod initialize-instance :after
((png png
) &rest args
&key image-data
)
106 (declare (ignore args
))
108 (unless (or image-data
(slot-boundp png
'image-data
))
109 (setf (%image-data png
)
110 (make-array (* (height png
) (rowstride png
))
112 :element-type
'(unsigned-byte 8)))))
114 (defmethod ihdr-color-type (png)
115 (cdr (assoc (color-type png
) *color-types
*)))
117 (defmethod samples-per-pixel (png)
118 (ecase (color-type png
)
123 (:truecolor-alpha
4)))
125 (defmethod rowstride (png)
126 (* (width png
) (samples-per-pixel png
)))
128 (defmethod scanline-offset (png scanline
)
129 (* scanline
(rowstride png
)))
132 (defmethod write-png-header (png stream
)
133 (write-sequence *png-signature
* stream
))
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
)))
146 (defun make-idat-callback (stream)
147 (let* ((idat (make-chunk 73 68 65 84 16384))
148 (buffer (buffer idat
)))
150 (replace buffer data
:start1
4 :end2 end
)
151 (setf (pos idat
) (+ end
4))
152 (write-chunk idat stream
))))
154 (defmethod write-idat (png stream
)
155 (let ((callback (make-idat-callback stream
)))
156 (with-compressor (compressor 'zlib-compressor
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
)
165 :end end-offset
))))))
168 (defmethod write-iend (png stream
)
169 (let ((chunk (make-chunk 73 69 78 68 0)))
170 (write-chunk chunk stream
)))
173 (defmethod write-png-stream (png stream
)
175 (write-png-header png stream
)
176 (write-ihdr png stream
)
177 (write-idat png stream
)
178 (write-iend png stream
))
180 (defmethod write-png (png file
&key
(if-exists :supersede
))
182 (with-open-file (stream file
185 :if-does-not-exist
:create
186 :element-type
'(unsigned-byte 8))
187 (write-png-stream png stream
)
190 (defmethod copy-png (orig)
193 :height
(height orig
)
194 :color-type
(color-type orig
)
196 :image-data
(copy-seq (image-data orig
))))
198 (defmethod png= (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
))))))
209 ;;; Streamed PNG methods
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
)))
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
)))
225 (defmethod start-png ((png pixel-streamed-png
) stream
)
226 (setf (current-offset png
) 0)
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
))))))
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))
250 (defmethod reset-streamed-png ((png pixel-streamed-png
))
251 (setf (current-offset png
) 0)
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
)
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
270 :needed
(/ (length (row-data png
)) color-channels
))))
273 (defmethod rows-left ((png streamed-png
))
274 (- (height png
) (rows-written png
)))
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)))
290 (defmethod pixels-left-in-row ((png pixel-streamed-png
))
291 (/ (- (current-offset png
) (rowstride png
)) (samples-per-pixel png
)))