1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators io io.encodings.binary io.files
4 kernel pack endian tools.hexdump constructors sequences arrays
5 sorting.slots math.order math.parser prettyprint classes
6 io.binary assocs math math.bitwise byte-arrays grouping
10 TUPLE: tiff-image < image ;
12 TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
13 CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
15 TUPLE: ifd count ifd-entries next
16 processed-tags strips buffer ;
17 CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
19 TUPLE: ifd-entry tag type count offset/value ;
20 CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
22 SINGLETONS: photometric-interpretation
23 photometric-interpretation-white-is-zero
24 photometric-interpretation-black-is-zero
25 photometric-interpretation-rgb
26 photometric-interpretation-palette-color ;
27 ERROR: bad-photometric-interpretation n ;
28 : lookup-photometric-interpretation ( n -- singleton )
30 { 0 [ photometric-interpretation-white-is-zero ] }
31 { 1 [ photometric-interpretation-black-is-zero ] }
32 { 2 [ photometric-interpretation-rgb ] }
33 { 3 [ photometric-interpretation-palette-color ] }
34 [ bad-photometric-interpretation ]
37 SINGLETONS: compression
41 compression-pack-bits ;
42 ERROR: bad-compression n ;
43 : lookup-compression ( n -- compression )
45 { 1 [ compression-none ] }
46 { 2 [ compression-CCITT-2 ] }
47 { 5 [ compression-lzw ] }
48 { 32773 [ compression-pack-bits ] }
52 SINGLETONS: resolution-unit
55 resolution-unit-centimeter ;
56 ERROR: bad-resolution-unit n ;
57 : lookup-resolution-unit ( n -- object )
59 { 1 [ resolution-unit-none ] }
60 { 2 [ resolution-unit-inch ] }
61 { 3 [ resolution-unit-centimeter ] }
62 [ bad-resolution-unit ]
67 predictor-horizontal-differencing ;
68 ERROR: bad-predictor n ;
69 : lookup-predictor ( n -- object )
71 { 1 [ predictor-none ] }
72 { 2 [ predictor-horizontal-differencing ] }
76 SINGLETONS: planar-configuration
77 planar-configuration-chunky
78 planar-configuration-planar ;
79 ERROR: bad-planar-configuration n ;
80 : lookup-planar-configuration ( n -- object )
82 { 1 [ planar-configuration-chunky ] }
83 { 2 [ planar-configuration-planar ] }
84 [ bad-planar-configuration ]
87 SINGLETONS: sample-format
88 sample-format-unsigned-integer
89 sample-format-signed-integer
90 sample-format-ieee-float
91 sample-format-undefined-data ;
92 ERROR: bad-sample-format n ;
93 : lookup-sample-format ( sequence -- object )
96 { 1 [ sample-format-unsigned-integer ] }
97 { 2 [ sample-format-signed-integer ] }
98 { 3 [ sample-format-ieee-float ] }
99 { 4 [ sample-format-undefined-data ] }
100 [ bad-sample-format ]
104 SINGLETONS: extra-samples
105 extra-samples-unspecified-alpha-data
106 extra-samples-associated-alpha-data
107 extra-samples-unassociated-alpha-data ;
108 ERROR: bad-extra-samples n ;
109 : lookup-extra-samples ( sequence -- object )
111 { 0 [ extra-samples-unspecified-alpha-data ] }
112 { 1 [ extra-samples-associated-alpha-data ] }
113 { 2 [ extra-samples-unassociated-alpha-data ] }
114 [ bad-extra-samples ]
117 SINGLETONS: image-length image-width x-resolution y-resolution
118 rows-per-strip strip-offsets strip-byte-counts bits-per-sample
119 samples-per-pixel new-subfile-type orientation
120 unhandled-ifd-entry ;
122 ERROR: bad-tiff-magic bytes ;
123 : tiff-endianness ( byte-array -- ? )
125 { B{ CHAR: M CHAR: M } [ big-endian ] }
126 { B{ CHAR: I CHAR: I } [ little-endian ] }
130 : read-header ( tiff -- tiff )
131 2 read tiff-endianness [ >>endianness ] keep
133 2 read endian> >>the-answer
134 4 read endian> >>ifd-offset
137 : push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
139 : read-ifd ( -- ifd )
143 4 read endian> <ifd-entry> ;
145 : read-ifds ( tiff -- tiff )
146 dup ifd-offset>> seek-absolute seek-input
148 dup [ read-ifd ] replicate
150 [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
152 ERROR: no-tag class ;
154 : ?at ( key assoc -- value/key ? )
155 dupd at* [ nip t ] [ drop f ] if ; inline
157 : find-tag ( idf class -- tag )
158 swap processed-tags>> ?at [ no-tag ] unless ;
160 : read-strips ( ifd -- ifd )
162 [ strip-byte-counts find-tag ]
163 [ strip-offsets find-tag ] bi
164 2dup [ integer? ] both? [
165 seek-absolute seek-input read 1array
167 [ seek-absolute seek-input read ] { } 2map-as
170 ERROR: unknown-ifd-type n ;
172 : bytes>bits ( n/byte-array -- n )
173 dup byte-array? [ byte-array>bignum ] when ;
175 : value-length ( ifd-entry -- n )
176 [ count>> ] [ type>> ] bi {
192 ERROR: bad-small-ifd-type n ;
194 : adjust-offset/value ( ifd-entry -- obj )
195 [ offset/value>> 4 >endian ] [ type>> ] bi
197 { 1 [ 1 head endian> ] }
198 { 3 [ 2 head endian> ] }
200 { 6 [ 1 head endian> 8 >signed ] }
201 { 8 [ 2 head endian> 16 >signed ] }
202 { 9 [ endian> 32 >signed ] }
203 { 11 [ endian> bits>float ] }
204 [ bad-small-ifd-type ]
207 : offset-bytes>obj ( bytes type -- obj )
210 { 2 [ ] } ! read c strings here
211 { 3 [ 2 <sliced-groups> [ endian> ] map ] }
212 { 4 [ 4 <sliced-groups> [ endian> ] map ] }
213 { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
214 { 6 [ [ 8 >signed ] map ] }
216 { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
217 { 9 [ 4 <sliced-groups> [ endian> 32 >signed ] map ] }
218 { 10 [ 8 group [ "ii" unpack first2 / ] map ] }
219 { 11 [ 4 group [ "f" unpack ] map ] }
220 { 12 [ 8 group [ "d" unpack ] map ] }
224 : ifd-entry-value ( ifd-entry -- n )
225 dup value-length 4 <= [
228 [ offset/value>> seek-absolute seek-input ]
229 [ value-length read ]
230 [ type>> ] tri offset-bytes>obj
233 : process-ifd-entry ( ifd-entry -- value class )
234 [ ifd-entry-value ] [ tag>> ] bi {
235 { 254 [ new-subfile-type ] }
236 { 256 [ image-width ] }
237 { 257 [ image-length ] }
238 { 258 [ bits-per-sample ] }
239 { 259 [ lookup-compression compression ] }
240 { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
241 { 273 [ strip-offsets ] }
242 { 274 [ orientation ] }
243 { 277 [ samples-per-pixel ] }
244 { 278 [ rows-per-strip ] }
245 { 279 [ strip-byte-counts ] }
246 { 282 [ x-resolution ] }
247 { 283 [ y-resolution ] }
248 { 284 [ planar-configuration ] }
249 { 296 [ lookup-resolution-unit resolution-unit ] }
250 { 317 [ lookup-predictor predictor ] }
251 { 338 [ lookup-extra-samples extra-samples ] }
252 { 339 [ lookup-sample-format sample-format ] }
253 [ nip unhandled-ifd-entry ]
256 : process-ifd ( ifd -- ifd )
258 [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
260 : strips>buffer ( ifd -- ifd )
261 dup strips>> concat >>buffer ;
263 : ifd>image ( ifd -- image )
265 [ image-width find-tag ]
266 [ image-length find-tag ]
267 [ bits-per-sample find-tag sum ]
269 } cleave tiff-image new-image ;
271 : parsed-tiff>images ( tiff -- sequence )
272 ifds>> [ ifd>image ] map ;
274 ! tiff files can store several images -- we just take the first for now
275 M: tiff-image load-image* ( path tiff-image -- image )
278 read-header dup endianness>> [
280 dup ifds>> [ process-ifd read-strips strips>buffer drop ] each
283 parsed-tiff>images first ;