Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 676 lines (616 sloc) 27.485 kb
4db97cd3 »
2008-11-05 update README. add copyright notices to source files.
1 ;;; file: retrospectiff.lisp
2 ;;; author: cyrus harmon
3 ;;;
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
4 ;;; Copyright (c) 2008-2011 Cyrus Harmon (ch-lisp@bobobeach.com)
4db97cd3 »
2008-11-05 update README. add copyright notices to source files.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Redistribution and use in source and binary forms, with or without
8 ;;; modification, are permitted provided that the following conditions
9 ;;; are met:
10 ;;;
11 ;;; * Redistributions of source code must retain the above copyright
12 ;;; notice, this list of conditions and the following disclaimer.
13 ;;;
14 ;;; * Redistributions in binary form must reproduce the above
15 ;;; copyright notice, this list of conditions and the following
16 ;;; disclaimer in the documentation and/or other materials
17 ;;; provided with the distribution.
18 ;;;
19 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
20 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
21 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
23 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
24 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
25 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
27 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
28 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
29 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2bb016a0 »
2008-10-23 genesis
30
d49deb86 »
2008-10-24 add tiff-image class
31 (in-package :retrospectiff)
32
e25a526b »
2011-03-09 begin work writing TIFF files
33 (defparameter *byte-order* :big-endian)
34 (defvar *tiff-file-offset*)
2bb016a0 »
2008-10-23 genesis
35
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
36 ;;; Perhaps the next few types should be moved to a
37 ;;; binary-data-extensions file or some such?
38
39 (define-binary-type array (type size)
40 (:reader (in)
41 (let ((arr (make-array size :element-type type)))
42 (dotimes (i size)
43 (setf (elt arr i)
44 (read-value type in)))
45 arr))
46 (:writer (out value)
47 (dotimes (i (length value))
48 (write-value type out (elt value i)))))
49
50 (define-binary-type unsigned-integer* (bytes bits-per-byte)
51 (:reader (in)
52 (case *byte-order*
53 (:big-endian
54 (loop with value = 0
55 for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do
56 (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
57 finally (return value)))
58 (:little-endian
59 (loop with value = 0
60 for low-bit to (* bits-per-byte (1- bytes)) by bits-per-byte do
61 (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
62 finally (return value)))))
63 (:writer (out value)
64 (case *byte-order*
65 (:big-endian
66 (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte
67 do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))
68 (:little-endian
68d92f20 »
2011-03-09 progress on TIFF writing:
69 (loop for low-bit to (* bits-per-byte (1- bytes)) by bits-per-byte
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
70 do (write-byte (ldb (byte bits-per-byte low-bit) value) out))))))
71
72 (define-binary-type u2* () (unsigned-integer* :bytes 2 :bits-per-byte 8))
73 (define-binary-type u4* () (unsigned-integer* :bytes 4 :bits-per-byte 8))
74 (define-binary-type u8* () (unsigned-integer* :bytes 8 :bits-per-byte 8))
75
76 (defun convert-to-signed-integer (num bits)
77 (let ((max (1- (ash 1 (1- bits)))))
78 (if (> num max)
79 (lognot (- (1- (ash 1 bits)) num))
80 num)))
81
82 (defun convert-to-unsigned-integer (num bits)
83 (if (minusp num)
84 (+ (ash 1 bits) num)
85 num))
86
87 (define-binary-type signed-integer* (bytes bits-per-byte)
88 (:reader (in)
89 (convert-to-signed-integer
90 (case *byte-order*
91 (:big-endian
92 (loop with value = 0
93 for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do
94 (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
95 finally (return value)))
96 (:little-endian
97 (loop with value = 0
98 for low-bit to (* bits-per-byte (1- bytes)) by bits-per-byte do
99 (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
100 finally (return value))))
101 (* bytes bits-per-byte)))
102 (:writer (out value)
103 (let ((value (convert-to-unsigned-integer value (* bytes bits-per-byte))))
104 (case *byte-order*
105 (:big-endian
106 (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte
107 do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))
108 (:little-endian
109 (loop for low-bit to (* bits-per-byte (1- bytes)) by bits-per-byte
110 do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))))))
111
112 (define-binary-type s1* () (signed-integer* :bytes 1 :bits-per-byte 8))
113 (define-binary-type s2* () (signed-integer* :bytes 2 :bits-per-byte 8))
114 (define-binary-type s4* () (signed-integer* :bytes 4 :bits-per-byte 8))
115
116 (define-binary-type f4* ()
117 (:reader (in)
118 (ieee-floats:decode-float32 (read-value 'u4* in)))
119 (:writer (out value)
120 (write-value 'u4* out (ieee-floats:encode-float32 value))))
121
122 (define-binary-type f8* ()
123 (:reader (in)
124 (ieee-floats:decode-float64 (read-value 'u8* in)))
125 (:writer (out value)
126 (write-value'u8* out (ieee-floats:encode-float64 value))))
127
128 ;;; end binary-data-extensions section
129 ;;;
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
130
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
131 (define-binary-type tiff-byte-order ()
132 (:reader (in)
133 (let ((val (read-value 'u2 in)))
134 (case val
135 (#x4949 (setf *byte-order* :little-endian))
136 (#x4D4D (setf *byte-order* :big-endian))
137 (t (error "unknown byte order")))))
138 (:writer (out value)
139 (case (or *byte-order* value)
140 (:little-endian
141 (write-value 'u2 out #x4949))
142 (:big-endian
143 (write-value 'u2 out #x4d4d)))))
144
145 (define-tagged-binary-class ifd-entry ()
146 ((tag u2*)
147 (field-type u2*)
148 (value-count u4*))
149 (:dispatch (case field-type
150 (1 'byte-ifd-entry)
151 (2 'ascii-ifd-entry)
152 (3 'short-ifd-entry)
153 (4 'long-ifd-entry)
154 (5 'rational-ifd-entry)
155 (6 'sbyte-ifd-entry)
156 (8 'sshort-ifd-entry)
157 (9 'slong-ifd-entry)
158 (10 'srational-ifd-entry)
159 (11 'float-ifd-entry)
160 (12 'double-ifd-entry)
161 (t 'unknown-ifd-entry))))
162
163 (define-binary-class unknown-ifd-entry (ifd-entry)
164 ((value-offset u4*)))
165
166 (defparameter *binary-type-sizes*
167 `((iso-8859-1-char . 1)
168 (u1 . 1)
169 (u2 . 2)
170 (u4 . 4)
171 (u2* . 2)
172 (u4* . 4)
173 (s1* . 1)
174 (s2* . 2)
175 (s4* . 4)
176 (rational . 8)
177 (srational . 8)
178 (f4* . 4)
179 (f8* . 8)))
180
181 (define-binary-type ifd-array (type size element-type)
182 (:reader (in)
183 (let* ((bytes-per-element (cdr (assoc type *binary-type-sizes*))))
184 (let ((pad (- (/ 4 bytes-per-element) size))
185 (v (apply #'make-array size
186 (when element-type `(:element-type ,element-type)))))
187 (if (minusp pad)
188 (let ((position (read-value 'u4* in))
189 (cur (file-position in)))
190 (file-position in position)
191 (loop for i below size
192 do (setf (elt v i) (read-value type in)))
193 (file-position in cur))
194 (progn
195 (loop for i below size
196 do (setf (elt v i) (read-value type in)))
197 (loop for i below pad do (read-value type in))))
198 v)))
199 (:writer (out value)
200 (let* ((bytes-per-element (cdr (assoc type *binary-type-sizes*))))
201 (let ((pad (- (/ 4 bytes-per-element) size)))
202 (if (minusp pad)
68d92f20 »
2011-03-09 progress on TIFF writing:
203 (let ((cur (file-position out))
204 (offset *tiff-file-offset*))
205 (progn (file-position out offset)
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
206 (loop for x across value
68d92f20 »
2011-03-09 progress on TIFF writing:
207 do (write-value type out x))
e25a526b »
2011-03-09 begin work writing TIFF files
208 ;; need to make sure this is word aligned!
209 (setf *tiff-file-offset*
210 (ash (ash (1+ (file-position out)) -1) 1))
68d92f20 »
2011-03-09 progress on TIFF writing:
211 (file-position out cur)
212 (write-value 'u4* out offset)))
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
213 (progn (loop for x across value
68d92f20 »
2011-03-09 progress on TIFF writing:
214 do (write-value type out x))
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
215 (loop for i below pad
68d92f20 »
2011-03-09 progress on TIFF writing:
216 do (write-value type out 0))))))))
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
217
218 ;; 1 - byte
219 (define-binary-class byte-ifd-entry (ifd-entry)
220 ((data (ifd-array :type 'u1 :size value-count))))
221
222 ;; 2 - ascii
223 (define-binary-class ascii-ifd-entry (ifd-entry)
224 ((data (ifd-array :type 'iso-8859-1-char :size value-count :element-type 'character))))
225
226 ;; 3 -- short
227 (define-binary-class short-ifd-entry (ifd-entry)
228 ((data (ifd-array :type 'u2* :size value-count))))
229
230 ;; 4 -- long
231 (define-binary-class long-ifd-entry (ifd-entry)
232 ((data (ifd-array :type 'u4* :size value-count))))
233
234 ;; 5 -- rational
235 (define-binary-class rational ()
236 ((numerator u4*)
237 (denominator u4*)))
238
239 (define-binary-class rational-ifd-entry (ifd-entry)
240 ((data (ifd-array :type 'rational :size value-count))))
241
242 ;; 6 -- signed byte
243 (define-binary-class sbyte-ifd-entry (ifd-entry)
244 ((data (ifd-array :type 's1* :size value-count))))
245
246 ;; 7 -- undefined (and unused, at least for now)
247 #+nil
248 (define-binary-class undefined-ifd-entry (ifd-entry)
249 ((value-offset u4*)))
250
251 ;; 8 -- signed short
252 (define-binary-class sshort-ifd-entry (ifd-entry)
253 ((data (ifd-array :type 's2* :size value-count))))
254
255 ;; 9 -- signed long
256 (define-binary-class slong-ifd-entry (ifd-entry)
257 ((data (ifd-array :type 's4* :size value-count))))
258
259 ;; 10 -- signed rational
260 (define-binary-class srational ()
261 ((numerator s4*)
262 (denominator s4*)))
263
264 (define-binary-class srational-ifd-entry (ifd-entry)
265 ((data (ifd-array :type 'srational :size value-count))))
266
267 ;; 11
268 (define-binary-class float-ifd-entry (ifd-entry)
269 ((data (ifd-array :type 'f4* :size value-count))))
270
271 ;; 12
272 (define-binary-class double-ifd-entry (ifd-entry)
273 ((data (ifd-array :type 'f8* :size value-count))))
274
275
276 (define-binary-type tiff-ifd-offset ()
277 (:reader (in)
278 (let ((val (read-value 'u4* in)))
279 (prog1 val
280 (if (plusp val)
281 (file-position in val)))))
282 (:writer (out value)
283 (write-value 'u4* out value)
284 (if (plusp value)
285 (file-position out value))))
286
287 (define-binary-class ifd ()
288 ((entry-count u2*)
289 (entries (array :type 'ifd-entry :size entry-count))
290 (next-ifd-offset tiff-ifd-offset)))
291
292 (define-binary-type ifd-list ()
293 (:reader (in)
294 (loop for ifd = (read-value 'ifd in)
295 collect ifd
296 while (plusp (next-ifd-offset ifd))))
297 (:writer (out value)
298 (loop for ifd in value
299 do (write-value 'ifd out ifd))))
300
301 (define-binary-class tiff-fields ()
302 ((byte-order tiff-byte-order)
303 (magic u2*)
304 (ifd-offset tiff-ifd-offset)
305 (ifd-list ifd-list)))
306
307 (defmethod read-value :around ((type (eql 'tiff)) stream &key)
308 (let (*byte-order*)
309 (call-next-method)))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
310
2bb016a0 »
2008-10-23 genesis
311
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
312 (defclass tiff-image ()
313 ((length :accessor tiff-image-length :initarg :length)
314 (width :accessor tiff-image-width :initarg :width)
315 (bits-per-sample :accessor tiff-image-bits-per-sample :initarg :bits-per-sample)
316 (samples-per-pixel :accessor tiff-image-samples-per-pixel :initarg :samples-per-pixel)
317 (data :accessor tiff-image-data :initarg :data)
318 (byte-order :accessor tiff-image-byte-order :initarg :byte-order)))
2bb016a0 »
2008-10-23 genesis
319
320
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
321 (defun get-ifd-values (ifd key)
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
322 (let ((field (find key ifd :key 'tag :test '=)))
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
323 (when field
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
324 (data field))))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
325
d49deb86 »
2008-10-24 add tiff-image class
326 (defun get-ifd-value (ifd key)
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
327 (let ((values (get-ifd-values ifd key)))
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
328 (when values (elt values 0))))
d49deb86 »
2008-10-24 add tiff-image class
329
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
330 (defun read-bytes (stream count)
331 (let ((buf (make-array count :element-type '(unsigned-byte 8))))
332 (read-sequence buf stream)
333 buf))
0f749c23 »
2009-04-29 support for grayscale image I/O
334
335 (defun read-grayscale-strip (stream
336 array
337 start-row
338 strip-offset
339 strip-byte-count
340 width
341 compression)
342 (file-position stream strip-offset)
343 (ecase compression
344 (1
345 (let ((strip-length (/ strip-byte-count width))
346 ;; FIXME: bytes-per-sample will need to change for 1- or
347 ;; 4-bit images!
348 (bytes-per-pixel 1))
349 (loop for i from start-row below (+ start-row strip-length)
350 do
351 (let ((rowoff (* i width bytes-per-pixel)))
352 (loop for j below width
353 do
354 (setf (aref array (+ rowoff j))
355 (read-byte stream)))))))
356 (#.+packbits-compression+
357 (error "Not yet!")
358 #+nil
359 (let ((packed-bits (read-bytes stream strip-byte-count)))
360 (let ((decoded (packbits-decode packed-bits))
361 (decoded-offset 0))
362 (let ((strip-length (/ (length decoded) width samples-per-pixel))
363 (bytes-per-sample (/ bytes-per-pixel samples-per-pixel)))
364 (loop for i from start-row below (+ start-row strip-length)
365 do
366 (let ((rowoff (* i width bytes-per-pixel)))
367 (loop for j below width
368 do
369 (let ((pixoff (+ rowoff (* bytes-per-pixel j))))
370 (loop for k below samples-per-pixel
371 for bits across bits-per-sample
372 do
373 (case bits
374 (8
375 (setf (aref array (+ pixoff (* k bytes-per-sample)))
376 (aref decoded decoded-offset))
377 (incf decoded-offset))
378 (16
379 (error "Not yet!"))))))))))))))
380
381 (defun read-grayscale-image (stream ifd)
382 (let ((image-width (get-ifd-value ifd +image-width-tag+))
383 (image-length (get-ifd-value ifd +image-length-tag+))
384 (bits-per-sample (or (get-ifd-value ifd +bits-per-sample-tag+) 1))
385 (compression (get-ifd-value ifd +compression-tag+))
386 (photometric-interpretation (get-ifd-value ifd +photometric-interpretation-tag+))
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
387 (strip-offsets (get-ifd-values ifd +strip-offsets-tag+))
0f749c23 »
2009-04-29 support for grayscale image I/O
388 (rows-per-strip (get-ifd-value ifd +rows-per-strip-tag+))
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
389 (strip-byte-counts (get-ifd-values ifd +strip-byte-counts-tag+)))
0f749c23 »
2009-04-29 support for grayscale image I/O
390 (declare (ignore photometric-interpretation))
391 (unless (eql bits-per-sample 8)
392 (error "I can only read 8-bit grayscale images at the moment."))
393 (let* ((bytes-per-pixel 1)
394 (data (make-array (* image-width image-length bytes-per-pixel))))
395 (loop for strip-offset across strip-offsets
396 for strip-byte-count across strip-byte-counts
397 for row-offset = 0 then (+ row-offset rows-per-strip)
59286c2a »
2011-02-04 add +no-compression+ constant and cleanup code a little bit
398 do (read-grayscale-strip stream data row-offset
399 strip-offset strip-byte-count
400 image-width compression))
0f749c23 »
2009-04-29 support for grayscale image I/O
401 (make-instance 'tiff-image
59286c2a »
2011-02-04 add +no-compression+ constant and cleanup code a little bit
402 :length image-length :width image-width
0f749c23 »
2009-04-29 support for grayscale image I/O
403 :bits-per-sample bits-per-sample
59286c2a »
2011-02-04 add +no-compression+ constant and cleanup code a little bit
404 :samples-per-pixel 1 :data data
36f678b3 »
2011-02-03 support for 16-bit RGB images, making retrospectiff play nicer with o…
405 :byte-order *byte-order*))))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
406
59286c2a »
2011-02-04 add +no-compression+ constant and cleanup code a little bit
407 (defun read-rgb-strip (stream array start-row strip-offset
408 strip-byte-count width bits-per-sample samples-per-pixel
409 bytes-per-pixel compression)
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
410 (file-position stream strip-offset)
411 (ecase compression
59286c2a »
2011-02-04 add +no-compression+ constant and cleanup code a little bit
412 (#.+no-compression+
36f678b3 »
2011-02-03 support for 16-bit RGB images, making retrospectiff play nicer with o…
413 (let ((strip-length (/ strip-byte-count width bytes-per-pixel))
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
414 (bytes-per-sample (/ bytes-per-pixel samples-per-pixel)))
55ba0aad »
2008-10-23 cl-tiff -> retrospectiff
415 (loop for i from start-row below (+ start-row strip-length)
416 do
59286c2a »
2011-02-04 add +no-compression+ constant and cleanup code a little bit
417 (let ((rowoff (* i width bytes-per-pixel)))
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
418 (loop for j below width
419 do
420 (let ((pixoff (+ rowoff (* bytes-per-pixel j))))
421 (loop for k below samples-per-pixel
422 for bits across bits-per-sample
423 do
424 (case bits
425 (8
426 (setf (aref array (+ pixoff (* k bytes-per-sample)))
427 (read-byte stream)))
428 (16
36f678b3 »
2011-02-03 support for 16-bit RGB images, making retrospectiff play nicer with o…
429 ;; FIXME! This assumes big-endian data!!!!
430 (setf (aref array (+ pixoff (* k bytes-per-sample)))
431 (read-byte stream)
432 (aref array (+ 1 pixoff (* k bytes-per-sample)))
433 (read-byte stream)))))))))))
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
434 (#.+lzw-compression+
435 (let ((lzw (read-bytes stream strip-byte-count)))
436 (let ((decoded (lzw-decode lzw))
437 (decoded-offset 0))
438 (let ((strip-length (/ (length decoded) width samples-per-pixel))
439 (bytes-per-sample (/ bytes-per-pixel samples-per-pixel)))
440 (loop for i from start-row below (+ start-row strip-length)
441 do
442 (let ((rowoff (* i width bytes-per-pixel)))
443 (loop for j below width
444 do
55ba0aad »
2008-10-23 cl-tiff -> retrospectiff
445 (let ((pixoff (+ rowoff (* bytes-per-pixel j))))
446 (loop for k below samples-per-pixel
447 for bits across bits-per-sample
448 do
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
449 (case bits
450 (8
451 (setf (aref array (+ pixoff (* k bytes-per-sample)))
452 (aref decoded decoded-offset))
453 (incf decoded-offset))
454 (16
455 (error "Not yet!"))))))))))))
4e519763 »
2008-11-05 fix constant typos.
456 (#.+packbits-compression+
457 (let ((packed-bits (read-bytes stream strip-byte-count)))
458 (let ((decoded (packbits-decode packed-bits))
459 (decoded-offset 0))
460 (let ((strip-length (/ (length decoded) width samples-per-pixel))
461 (bytes-per-sample (/ bytes-per-pixel samples-per-pixel)))
462 (loop for i from start-row below (+ start-row strip-length)
463 do
464 (let ((rowoff (* i width bytes-per-pixel)))
465 (loop for j below width
466 do
467 (let ((pixoff (+ rowoff (* bytes-per-pixel j))))
468 (loop for k below samples-per-pixel
469 for bits across bits-per-sample
470 do
471 (case bits
472 (8
473 (setf (aref array (+ pixoff (* k bytes-per-sample)))
474 (aref decoded decoded-offset))
475 (incf decoded-offset))
476 (16
477 (error "Not yet!"))))))))))))))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
478
479 (defun read-rgb-image (stream ifd)
d49deb86 »
2008-10-24 add tiff-image class
480 (let ((image-width (get-ifd-value ifd +image-width-tag+))
481 (image-length (get-ifd-value ifd +image-length-tag+))
482 (samples-per-pixel (get-ifd-value ifd +samples-per-pixel-tag+))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
483 (bits-per-sample (get-ifd-values ifd +bits-per-sample-tag+))
d49deb86 »
2008-10-24 add tiff-image class
484 (rows-per-strip (get-ifd-value ifd +rows-per-strip-tag+))
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
485 (strip-offsets (get-ifd-values ifd +strip-offsets-tag+))
486 (strip-byte-counts (get-ifd-values ifd +strip-byte-counts-tag+))
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
487 (compression (get-ifd-value ifd +compression-tag+))
488 (planar-configuration (get-ifd-value ifd +planar-configuration-tag+))
489 (predictor (get-ifd-value ifd +predictor-tag+)))
490 (declare (ignore planar-configuration))
491 ;; FIXME
0f749c23 »
2009-04-29 support for grayscale image I/O
492 ;; 1. we need to support predictors for lzw encoded images.
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
493 ;; 2. Presumably we'll want planar images as well at some point.
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
494 (let* ((bytes-per-pixel
55ba0aad »
2008-10-23 cl-tiff -> retrospectiff
495 (* samples-per-pixel
496 (1+ (ash (1- (apply #'max
497 (map 'list #'identity
498 bits-per-sample)))
499 -3))))
d49deb86 »
2008-10-24 add tiff-image class
500 (data (make-array (* image-width image-length bytes-per-pixel))))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
501 (loop for strip-offset across strip-offsets
502 for strip-byte-count across strip-byte-counts
503 for row-offset = 0 then (+ row-offset rows-per-strip)
55ba0aad »
2008-10-23 cl-tiff -> retrospectiff
504 do (read-rgb-strip stream
d49deb86 »
2008-10-24 add tiff-image class
505 data
55ba0aad »
2008-10-23 cl-tiff -> retrospectiff
506 row-offset
507 strip-offset
508 strip-byte-count
509 image-width
510 bits-per-sample
511 samples-per-pixel
512 bytes-per-pixel
513 compression))
31c48094 »
2008-10-30 * eval-when constants so that we can use them in case constructs
514 (case predictor
515 (#.+horizontal-differencing+
516 (loop for i below image-length
517 do
518 (loop for j from 1 below image-width
519 do
520 (let ((offset (+ (* i image-width samples-per-pixel)
521 (* samples-per-pixel j))))
522 (loop for k below samples-per-pixel
523 do (setf (aref data (+ offset k))
524 (logand
525 (+ (aref data (+ offset k))
526 (aref data (- (+ offset k) samples-per-pixel)))
527 #xff))))))))
d49deb86 »
2008-10-24 add tiff-image class
528 (make-instance 'tiff-image
59286c2a »
2011-02-04 add +no-compression+ constant and cleanup code a little bit
529 :length image-length :width image-width
4e519763 »
2008-11-05 fix constant typos.
530 :bits-per-sample bits-per-sample
d49deb86 »
2008-10-24 add tiff-image class
531 :samples-per-pixel samples-per-pixel
59286c2a »
2011-02-04 add +no-compression+ constant and cleanup code a little bit
532 :data data :byte-order *byte-order*))))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
533
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
534 (defun read-tiff-stream (stream)
535 (let* ((fields (read-value 'tiff-fields stream))
536 (ifd (entries (first (ifd-list fields)))))
537 (let ((photometric-interpretation
15476ae2 »
2009-04-29 cleaned up read-image. don't need to check for vector anymore.
538 (get-ifd-value ifd +photometric-interpretation-tag+)))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
539 (ecase photometric-interpretation
0f749c23 »
2009-04-29 support for grayscale image I/O
540 ((0 1) (read-grayscale-image stream ifd))
e7b665b0 »
2011-02-03 New retrospectiff that uses Peter Siebel's binary-data package
541 (2 (read-rgb-image stream ifd))))))
2bb016a0 »
2008-10-23 genesis
542
543 (defun read-tiff-file (pathname)
94b7cfad »
2008-12-01 use :element-type '(unsigned-byte 8) instead of :default to make ccl …
544 (with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8))
0864b7fa »
2008-10-23 first working-ish version. works for uncompressed 8-bit RGB images an…
545 (read-tiff-stream stream)))
546
68d92f20 »
2011-03-09 progress on TIFF writing:
547 (defun add-ifd-entry (ifd entry)
548 (push entry (entries ifd))
549 (incf (entry-count ifd))
550 ifd)
551
552 (defun vectorize (data)
553 (etypecase data
554 (vector data)
555 (list (apply #'vector data))
556 (nil nil)
557 (atom (vector data))))
e25a526b »
2011-03-09 begin work writing TIFF files
558
559 (defun make-ifd-entry-long (tag data)
68d92f20 »
2011-03-09 progress on TIFF writing:
560 (let ((data (vectorize data)))
561 (make-instance 'long-ifd-entry
562 :tag tag
563 :field-type +field-type-long+
564 :data data
565 :value-count (length data))))
e25a526b »
2011-03-09 begin work writing TIFF files
566
567 (defun make-ifd-entry-short (tag data)
68d92f20 »
2011-03-09 progress on TIFF writing:
568 (let ((data (vectorize data)))
569 (make-instance 'short-ifd-entry
570 :tag tag
571 :field-type +field-type-short+
572 :data data
573 :value-count (length data))))
e25a526b »
2011-03-09 begin work writing TIFF files
574
575 ;; we should return the number of strips (and possibly the length of
576 ;; each strip (uncompressed), but not yet)..
577 (defun compute-rows-per-strip (image-length
578 bytes-per-row
579 &key (strip-size #x40000))
580 (let ((strip-rows (truncate strip-size bytes-per-row)))
581 (min image-length strip-rows)))
582
583 (defun make-tiff-fields (image)
584 (with-accessors
585 ((image-width tiff-image-width)
586 (image-length tiff-image-length)
587 (image-data tiff-image-data)
588 (bits-per-sample tiff-image-bits-per-sample)
589 (samples-per-pixel tiff-image-samples-per-pixel))
590 image
68d92f20 »
2011-03-09 progress on TIFF writing:
591 (let* ((num-bits-per-sample (if (typep bits-per-sample 'sequence)
592 (elt bits-per-sample 0)
e25a526b »
2011-03-09 begin work writing TIFF files
593 bits-per-sample))
594 (bytes-per-row (ash (* image-width samples-per-pixel num-bits-per-sample)
595 -3))
596 (rows-per-strip (compute-rows-per-strip image-length bytes-per-row))
597 (fields (make-instance 'tiff-fields
598 :byte-order *byte-order*
599 :magic 42
68d92f20 »
2011-03-09 progress on TIFF writing:
600 :ifd-list nil))
601 (ifd (make-instance 'ifd
602 :entry-count 0
603 :entries nil
604 :next-ifd-offset 0)))
e25a526b »
2011-03-09 begin work writing TIFF files
605
606 (destructuring-bind (strip-offsets strip-byte-counts)
607 (apply #'mapcar #'list
608 (loop for i below image-length by rows-per-strip
609 for byte-offset from i by (* rows-per-strip
610 bytes-per-row)
611 collect (list byte-offset
612 (* bytes-per-row
613 (- (min (+ i rows-per-strip)
614 image-length) i)))))
615 (reduce #'add-ifd-entry
616 (list (make-ifd-entry-long +image-length-tag+ image-length)
617 (make-ifd-entry-long +image-width-tag+ image-width)
618 (make-ifd-entry-short +bits-per-sample-tag+ bits-per-sample)
619 (make-ifd-entry-short +samples-per-pixel-tag+ samples-per-pixel))
68d92f20 »
2011-03-09 progress on TIFF writing:
620 :initial-value ifd)
e25a526b »
2011-03-09 begin work writing TIFF files
621 (cond
622 ((= samples-per-pixel 1)
623 (add-ifd-entry
68d92f20 »
2011-03-09 progress on TIFF writing:
624 ifd
e25a526b »
2011-03-09 begin work writing TIFF files
625 (make-ifd-entry-short +photometric-interpretation-tag+
626 +photometric-interpretation-black-is-zero+)))
627 ((= samples-per-pixel 3)
628 (add-ifd-entry
68d92f20 »
2011-03-09 progress on TIFF writing:
629 ifd
e25a526b »
2011-03-09 begin work writing TIFF files
630 (make-ifd-entry-short +photometric-interpretation-tag+
68d92f20 »
2011-03-09 progress on TIFF writing:
631 +photometric-interpretation-rgb+)))))
632 (setf (ifd-list fields)
633 (list ifd))
634 (fixup-ifd-entries fields))))
e25a526b »
2011-03-09 begin work writing TIFF files
635
636 (defun fixup-ifd-entries (fields)
637 (incf *tiff-file-offset* 8)
68d92f20 »
2011-03-09 progress on TIFF writing:
638 (setf (ifd-offset fields) *tiff-file-offset*)
639 (let ((ifd (car (ifd-list fields))))
640 (let ((num-entries (entry-count ifd)))
641 (incf *tiff-file-offset* (+ 2 (* num-entries 12)))))
642 fields)
e25a526b »
2011-03-09 begin work writing TIFF files
643
644 ;;;
645 ;;; The general strategy here is to:
646 ;;;
647 ;;; 1. make the TIFF Image File Directory (we're only going to deal
648 ;;; with single images per TIFF file for the moment)
649 ;;;
650 ;;; 2. Compute the offsets of the first (and only IFD -- probably 8)
651 ;;;
652 ;;; 3. Compute the offset of the various IFD arrays that aren't
653 ;;; represented inline -- starting at the offset of the IFD + (2 +
654 ;;; number of directory entries * 12)
655 ;;;
656 ;;; 4. Compute the offset of the strip/sample data
657 ;;;
658 ;;; 5. Write the TIFF Header
659 ;;;
660 ;;; 6. Write the IFD directory entries (inline portions), then write
661 ;;; the non-inline values
662 ;;;
663 ;;; 7. Write the sample (strip) data
664 (defun write-tiff-stream (stream obj &key byte-order)
665 (let ((*byte-order* (or byte-order *byte-order*))
666 (*tiff-file-offset* 0))
667 (let ((fields (make-tiff-fields obj)))
668 (write-value 'tiff-fields stream fields))))
0f749c23 »
2009-04-29 support for grayscale image I/O
669
ab7ee6c6 »
2009-04-29 write-tiff-file is now a function instead of a macro.
670 (defun write-tiff-file (pathname image)
671 (with-open-file (stream pathname
672 :direction :output
673 :element-type '(unsigned-byte 8)
674 :if-exists :supersede)
675 (write-tiff-stream stream image)
676 pathname))
Something went wrong with that request. Please try again.