/
ifd.lisp
153 lines (131 loc) · 5.8 KB
/
ifd.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
(in-package :retrospectiff.ifd)
(defun get-ifd-values (ifd key)
(let ((field (find key ifd :key 'tag :test '=)))
(when field
(data field))))
(defun get-ifd-value (ifd key)
(let ((values (get-ifd-values ifd key)))
(when values (elt values 0))))
(defun add-ifd-entry (ifd entry)
(push entry (entries ifd))
(incf (entry-count ifd))
ifd)
(defun vectorize (data)
(etypecase data
(vector data)
(list (apply #'vector data))
(nil nil)
(atom (vector data))))
(defun make-ifd-entry-short (tag data)
(let ((data (vectorize data)))
(make-instance 'short-ifd-entry
:tag tag
:field-type +field-type-short+
:data data
:value-count (length data))))
(defun make-ifd-entry-long (tag data)
(let ((data (vectorize data)))
(make-instance 'long-ifd-entry
:tag tag
:field-type +field-type-long+
:data data
:value-count (length data))))
(defun make-ifd-entry-rational (tag data)
(let ((data (vectorize data)))
(make-instance 'rational-ifd-entry
:tag tag
:field-type +field-type-rational+
:data (map 'vector
(lambda (x)
(make-instance 'rational :numerator (car x)
:denominator (cdr x)))
data)
:value-count (length data))))
(defun ifd-entry-out-of-line-bytes (entry)
(let ((bytes (entry-bytes entry)))
(if (> bytes 4) bytes 0)))
;; we should return the number of strips (and possibly the length of
;; each strip (uncompressed), but not yet)..
(defun compute-rows-per-strip (image-length
bytes-per-row
&key (strip-size #x40000))
(let ((strip-rows (truncate strip-size bytes-per-row)))
(min image-length strip-rows)))
(defun make-tiff-fields (image)
(with-accessors
((image-width tiff-image-width)
(image-length tiff-image-length)
(image-data tiff-image-data)
(bits-per-sample tiff-image-bits-per-sample)
(samples-per-pixel tiff-image-samples-per-pixel))
image
(let* ((num-bits-per-sample (if (typep bits-per-sample 'sequence)
(elt bits-per-sample 0)
bits-per-sample))
(bytes-per-row (ceiling (* image-width (* samples-per-pixel num-bits-per-sample)) 8))
(rows-per-strip (compute-rows-per-strip image-length bytes-per-row))
(fields (make-instance 'tiff-fields
:byte-order *byte-order*
:magic 42
:ifd-list nil))
(ifd (make-instance 'ifd
:entry-count 0
:entries nil
:next-ifd-offset 0)))
(destructuring-bind (strip-offsets strip-byte-counts)
(apply #'mapcar #'list
(loop for i below image-length by rows-per-strip
for byte-offset from i by (* rows-per-strip
bytes-per-row)
collect (list byte-offset
(* bytes-per-row
(- (min (+ i rows-per-strip)
image-length) i)))))
(reduce #'add-ifd-entry
(list (make-ifd-entry-long +image-length-tag+ image-length)
(make-ifd-entry-long +image-width-tag+ image-width)
(make-ifd-entry-short +bits-per-sample-tag+ bits-per-sample)
(make-ifd-entry-short +samples-per-pixel-tag+ samples-per-pixel)
(make-ifd-entry-rational +x-resolution-tag+ (vector (cons 72 1)))
(make-ifd-entry-rational +y-resolution-tag+ (vector (cons 72 1)))
(make-ifd-entry-short +resolution-unit-tag+ 2))
:initial-value ifd)
(cond
((= samples-per-pixel 1)
(add-ifd-entry
ifd
(make-ifd-entry-short +photometric-interpretation-tag+
+photometric-interpretation-black-is-zero+)))
((member samples-per-pixel '(3 4))
(add-ifd-entry
ifd
(make-ifd-entry-short +photometric-interpretation-tag+
+photometric-interpretation-rgb+))))
(add-ifd-entry ifd
(make-ifd-entry-long +rows-per-strip-tag+ rows-per-strip))
(add-ifd-entry ifd
(make-ifd-entry-long +strip-byte-counts-tag+ strip-byte-counts))
(setf (ifd-list fields) (list ifd))
(incf *tiff-file-offset* 8)
(setf (ifd-offset fields) *tiff-file-offset*)
(let ((num-entries (entry-count ifd)))
(incf *tiff-file-offset* (+ 2 (* num-entries 12))))
(let ((out-of-line-data-size
(* 4 (length strip-offsets))))
(loop for entry in (entries ifd)
do (incf out-of-line-data-size
(ifd-entry-out-of-line-bytes entry)))
;; skip one more ifd-entry
(incf *tiff-file-offset* 12)
(incf *tiff-file-offset* 4)
;; *file-offset* to the strip-offsets
(add-ifd-entry
ifd
(make-ifd-entry-long
+strip-offsets-tag+
(map 'vector
(lambda (x) (+ x
*tiff-file-offset*
out-of-line-data-size))
strip-offsets)))
(values fields out-of-line-data-size strip-offsets strip-byte-counts))))))