Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 291 lines (264 sloc) 13.095 kb
374afbb @slyrus fix check for bits-per-sample
authored
1 ;;; Copyright (c) 2011 Cyrus Harmon, All rights reserved.
2 ;;; See COPYRIGHT file for details.
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
3
4 (in-package :opticl)
5
6 ;;;
7 ;;; Reading TIFF files
8 (defun read-tiff-stream (stream)
9 "reads a TIFF image from a stream and returns either a 32-bit ARGB
10 image or an 8-bit grayscale image"
11 (let ((tiff-image (tiff:read-tiff-stream stream)))
12 (with-accessors ((image-length tiff:tiff-image-length)
13 (image-width tiff:tiff-image-width)
14 (samples-per-pixel tiff:tiff-image-samples-per-pixel)
15 (bits-per-sample tiff:tiff-image-bits-per-sample)
1443e3b @slyrus support for reading indexed TIFF images
authored
16 (image-data tiff:tiff-image-data)
5381afb @slyrus export do-pixels and friends, clean up :: usage, get rid of some magic n...
authored
17 (color-map tiff:tiff-image-color-map)
18 (min-is-white tiff:tiff-image-min-is-white))
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
19 tiff-image
1443e3b @slyrus support for reading indexed TIFF images
authored
20 (cond
7e5b51a @slyrus add support for dealing with 1-bit tiff images and white-is-zero bitmap ...
authored
21
1443e3b @slyrus support for reading indexed TIFF images
authored
22 (color-map ;; indexed RGB
23 (let ((image (make-8-bit-rgb-image image-length image-width)))
24 (declare (type 8-bit-rgb-image image))
25 (loop for i below image-length
26 do
27 (loop for j below image-width
28 do
29 (let ((pixoff (+ (* i image-width) j)))
30 (setf (pixel* image i j)
31 (mapcar (lambda (x) (ash x -8))
32 (aref color-map
33 (aref image-data pixoff)))))))
34 image))
7e5b51a @slyrus add support for dealing with 1-bit tiff images and white-is-zero bitmap ...
authored
35
36 ((and (= samples-per-pixel 1)
37 (equalp bits-per-sample 1)) ;; black and white
38 (let ((image (make-1-bit-gray-image image-length image-width)))
39 (declare (type 1-bit-gray-image image))
40 (loop for i below image-length
41 do
42 (loop for j below image-width
43 do (setf (pixel image i j)
44 (if min-is-white
45 (ldb (byte 1 (- 7 (mod (+ (* i image-width) j) 8)))
46 (lognot (aref image-data (ash (+ (* i image-width) j) -3))))
47 (ldb (byte 1 (- 7 (mod (+ (* i image-width) j) 8)))
48 (aref image-data (ash (+ (* i image-width) j) -3)))))))
49 image))
50
1443e3b @slyrus support for reading indexed TIFF images
authored
51 ((and (= samples-per-pixel 1)
52 (equalp bits-per-sample 8)) ;; 8-bit Grayscale
53 (let ((image (make-8-bit-gray-image image-length image-width)))
54 (declare (type 8-bit-gray-image image))
55 (loop for i below image-length
56 do
57 (loop for j below image-width
58 do
59 (let ((pixoff (+ (* i image-width) j)))
60 (setf (pixel image i j)
61 (aref image-data pixoff)))))
62 image))
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
63
1443e3b @slyrus support for reading indexed TIFF images
authored
64 ((and (= samples-per-pixel 3)
65 (equalp bits-per-sample #(8 8 8))) ;; 8-bit RGB
66 (let ((image (make-8-bit-rgb-image image-length image-width)))
67 (declare (type 8-bit-rgb-image image))
68 (loop for i below image-length
69 do
70 (loop for j below image-width
71 do
72 (let ((pixoff (* 3 (+ (* i image-width) j))))
73 (setf (pixel image i j)
74 (values (aref image-data pixoff)
75 (aref image-data (incf pixoff))
76 (aref image-data (incf pixoff)))))))
77 image))
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
78
1443e3b @slyrus support for reading indexed TIFF images
authored
79 ((and (= samples-per-pixel 4)
7e5b51a @slyrus add support for dealing with 1-bit tiff images and white-is-zero bitmap ...
authored
80 (equalp bits-per-sample #(8 8 8 8))) ;; 8-bit RGBA
1443e3b @slyrus support for reading indexed TIFF images
authored
81 (let ((image (make-8-bit-rgba-image image-length image-width)))
82 (declare (type 8-bit-rgba-image image))
83 (loop for i below image-length
84 do
85 (loop for j below image-width
86 do
87 (let ((pixoff (* 4 (+ (* i image-width) j))))
88 (setf (pixel image i j)
89 (values (aref image-data pixoff)
90 (aref image-data (incf pixoff))
91 (aref image-data (incf pixoff))
92 (aref image-data (incf pixoff)))))))
93 image))
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
94
95
1443e3b @slyrus support for reading indexed TIFF images
authored
96 ((and (= samples-per-pixel 3)
97 (equalp bits-per-sample #(16 16 16))) ;; 16-bit RGB
98 (let ((image (make-16-bit-rgb-image image-length image-width)))
99 (declare (type 16-bit-rgb-image image))
100 (loop for i below image-length
101 do
102 (loop for j below image-width
103 do
104 (let ((pixoff (* 6 (+ (* i image-width) j))))
105 (setf (pixel image i j)
106 (values (+ (ash (aref image-data pixoff) 8)
107 (aref image-data (incf pixoff)))
108 (+ (ash (aref image-data (incf pixoff)) 8)
109 (aref image-data (incf pixoff)))
110 (+ (ash (aref image-data (incf pixoff)) 8)
111 (aref image-data (incf pixoff))))))))
112 image))
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
113
1443e3b @slyrus support for reading indexed TIFF images
authored
114 ((and (= samples-per-pixel 4)
7e5b51a @slyrus add support for dealing with 1-bit tiff images and white-is-zero bitmap ...
authored
115 (equalp bits-per-sample #(16 16 16 16))) ;; 16-bit RGBA
1443e3b @slyrus support for reading indexed TIFF images
authored
116 (let ((image (make-16-bit-rgba-image image-length image-width)))
117 (declare (type 16-bit-rgba-image image))
118 (loop for i below image-length
119 do
120 (loop for j below image-width
121 do
122 (let ((pixoff (* 8 (+ (* i image-width) j))))
123 (setf (pixel image i j)
124 (values (+ (ash (aref image-data pixoff) 8)
125 (aref image-data (incf pixoff)))
126 (+ (ash (aref image-data (incf pixoff)) 8)
127 (aref image-data (incf pixoff)))
128 (+ (ash (aref image-data (incf pixoff)) 8)
129 (aref image-data (incf pixoff)))
130 (+ (ash (aref image-data (incf pixoff)) 8)
131 (aref image-data (incf pixoff))))))))))
132 (t
133 (error "TIFF decoding error"))))))
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
134
135 (defun read-tiff-file (pathname)
136 (with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8))
137 (read-tiff-stream stream)))
138
139
140 ;;;
141 ;;; Writing TIFF files
142 (defun make-tiff-image (image)
143 (typecase image
374afbb @slyrus fix check for bits-per-sample
authored
144 (8-bit-gray-image
145 (destructuring-bind (height width)
146 (array-dimensions image)
147 (let ((tiff-image (make-instance 'tiff:tiff-image
148 :width width
149 :length height
150 :bits-per-sample 8
151 :samples-per-pixel 1
152 :data (make-array (* width height)
153 :initial-element 255))))
154 (with-accessors ((image-data tiff:tiff-image-data))
155 tiff-image
156 (let ((pixoff 0))
157 (loop for i below height
158 do
159 (loop for j below width
160 do
814def4 @slyrus use new pixel instead of of old type-specific pixel functions in tiff, j...
authored
161 (setf (aref image-data pixoff) (pixel image i j))
374afbb @slyrus fix check for bits-per-sample
authored
162 (incf pixoff)))))
163 tiff-image)))
164
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
165 (8-bit-rgb-image
166 (destructuring-bind (height width channels)
167 (array-dimensions image)
168 (declare (ignore channels))
169 (let ((tiff-image (make-instance 'tiff:tiff-image
170 :width width
171 :length height
172 :bits-per-sample '(8 8 8)
173 :samples-per-pixel 3
174 :data (make-array (* width height 3)))))
175 (with-accessors ((image-data tiff:tiff-image-data))
176 tiff-image
177 (loop for i below height
178 do
179 (loop for j below width
180 do
181 (let ((pixoff (* 3 (+ (* i width) j))))
182 (multiple-value-bind
183 (r g b)
814def4 @slyrus use new pixel instead of of old type-specific pixel functions in tiff, j...
authored
184 (pixel image i j)
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
185 (setf (aref image-data pixoff) r
186 (aref image-data (incf pixoff)) g
187 (aref image-data (incf pixoff)) b))))))
188 tiff-image)))
189
190 (8-bit-rgba-image
191 (destructuring-bind (height width channels)
192 (array-dimensions image)
193 (declare (ignore channels))
194 (let ((tiff-image (make-instance 'tiff:tiff-image
195 :width width
196 :length height
197 :bits-per-sample '(8 8 8 8)
198 :samples-per-pixel 4
199 :data (make-array (* width height 4)))))
200 (with-accessors ((image-data tiff:tiff-image-data))
201 tiff-image
202 (loop for i below height
203 do
204 (loop for j below width
205 do
206 (let ((pixoff (* 4 (+ (* i width) j))))
207 (multiple-value-bind
208 (r g b a)
814def4 @slyrus use new pixel instead of of old type-specific pixel functions in tiff, j...
authored
209 (pixel image i j)
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
210 (setf (aref image-data pixoff) r
211 (aref image-data (incf pixoff)) g
212 (aref image-data (incf pixoff)) b
213 (aref image-data (incf pixoff)) a))))))
214 tiff-image)))
215
216 (16-bit-rgb-image
217 (destructuring-bind (height width channels)
218 (array-dimensions image)
219 (declare (ignore channels))
220 (let ((tiff-image (make-instance 'tiff:tiff-image
221 :width width
222 :length height
223 :bits-per-sample '(16 16 16)
224 :samples-per-pixel 3
225 :data (make-array (* width height 3 2)))))
226 (with-accessors ((image-data tiff:tiff-image-data))
227 tiff-image
228 (loop for i below height
229 do
230 (loop for j below width
231 do
232 (let ((pixoff (* 3 2 (+ (* i width) j))))
233 (multiple-value-bind
234 (r g b)
814def4 @slyrus use new pixel instead of of old type-specific pixel functions in tiff, j...
authored
235 (pixel image i j)
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
236 (setf (aref image-data pixoff) (ash r -8)
237 (aref image-data (incf pixoff)) (logand r #xff)
238
239 (aref image-data (incf pixoff)) (ash g -8)
240 (aref image-data (incf pixoff)) (logand g #xff)
241
242 (aref image-data (incf pixoff)) (ash b -8)
243 (aref image-data (incf pixoff)) (logand b #xff)))))))
244 tiff-image)))
245
246 (16-bit-rgba-image
247 (destructuring-bind (height width channels)
248 (array-dimensions image)
249 (declare (ignore channels))
250 (let ((tiff-image (make-instance 'tiff:tiff-image
251 :width width
252 :length height
253 :bits-per-sample '(16 16 16 16)
254 :samples-per-pixel 4
255 :data (make-array (* width height 4 2)))))
256 (with-accessors ((image-data tiff:tiff-image-data))
257 tiff-image
258 (loop for i below height
259 do
260 (loop for j below width
261 do
262 (let ((pixoff (* 4 2 (+ (* i width) j))))
263 (multiple-value-bind
264 (r g b a)
814def4 @slyrus use new pixel instead of of old type-specific pixel functions in tiff, j...
authored
265 (pixel image i j)
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
266 (setf (aref image-data pixoff) (ash r -8)
267 (aref image-data (incf pixoff)) (logand r #xff)
268
269 (aref image-data (incf pixoff)) (ash g -8)
270 (aref image-data (incf pixoff)) (logand g #xff)
271
272 (aref image-data (incf pixoff)) (ash b -8)
273 (aref image-data (incf pixoff)) (logand b #xff)
274
275 (aref image-data (incf pixoff)) (ash a -8)
276 (aref image-data (incf pixoff)) (logand a #xff)))))))
277 tiff-image)))
278
279 (t (error "Cannot write a TIFF image from ~A" (type-of image)))))
280
04c6b7a @slyrus add &key byte-order to write-tiff-{file,stream}
authored
281 (defun write-tiff-stream (stream image &key byte-order)
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
282 (let ((tiff-image (make-tiff-image image)))
04c6b7a @slyrus add &key byte-order to write-tiff-{file,stream}
authored
283 (apply #'tiff:write-tiff-stream stream tiff-image
284 (when byte-order `(:byte-order ,byte-order)))))
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
285
04c6b7a @slyrus add &key byte-order to write-tiff-{file,stream}
authored
286 (defun write-tiff-file (pathname image &key byte-order)
6aedaa1 @slyrus added preliminary support for reading and writing TIFF and JPEG files
authored
287 (let ((tiff-image (make-tiff-image image)))
04c6b7a @slyrus add &key byte-order to write-tiff-{file,stream}
authored
288 (apply #'tiff:write-tiff-file pathname tiff-image
289 (when byte-order `(:byte-order ,byte-order)))))
374afbb @slyrus fix check for bits-per-sample
authored
290
Something went wrong with that request. Please try again.