1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs byte-arrays combinators
4 combinators.short-circuit compression.lzw endian fry grouping
5 images images.loader io io.encodings.ascii
6 io.encodings.string io.encodings.utf8 io.streams.throwing kernel
7 math math.bitwise math.vectors pack sequences ;
12 TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
14 : <loading-tiff> ( -- tiff )
16 H{ } clone >>ifds ; inline
18 ! offset, next-offset, and count are not strictly necessary here
19 ! count is just the length of ifd-entries
20 TUPLE: ifd offset next-offset count
21 ifd-entries processed-tags strips bitmap ;
23 : <ifd> ( offset count ifd-entries next-offset -- ifd )
30 TUPLE: ifd-entry tag type count offset/value ;
32 : <ifd-entry> ( tag type count offset/value -- ifd-entry )
39 SINGLETONS: photometric-interpretation
40 photometric-interpretation-white-is-zero
41 photometric-interpretation-black-is-zero
42 photometric-interpretation-rgb
43 photometric-interpretation-palette-color
44 photometric-interpretation-transparency-mask
45 photometric-interpretation-separated
46 photometric-interpretation-ycbcr
47 photometric-interpretation-cielab
48 photometric-interpretation-icclab
49 photometric-interpretation-itulab
50 photometric-interpretation-logl
51 photometric-interpretation-logluv ;
53 ERROR: bad-photometric-interpretation n ;
54 : lookup-photometric-interpretation ( n -- singleton )
56 { 0 [ photometric-interpretation-white-is-zero ] }
57 { 1 [ photometric-interpretation-black-is-zero ] }
58 { 2 [ photometric-interpretation-rgb ] }
59 { 3 [ photometric-interpretation-palette-color ] }
60 { 4 [ photometric-interpretation-transparency-mask ] }
61 { 5 [ photometric-interpretation-separated ] }
62 { 6 [ photometric-interpretation-ycbcr ] }
63 { 8 [ photometric-interpretation-cielab ] }
64 { 9 [ photometric-interpretation-icclab ] }
65 { 10 [ photometric-interpretation-itulab ] }
66 { 32844 [ photometric-interpretation-logl ] }
67 { 32845 [ photometric-interpretation-logluv ] }
68 [ bad-photometric-interpretation ]
71 SINGLETONS: compression
79 compression-adobe-deflate
86 compression-thunderscan
98 ERROR: bad-compression n ;
99 : lookup-compression ( n -- compression )
101 { 1 [ compression-none ] }
102 { 2 [ compression-CCITT-2 ] }
103 { 3 [ compression-CCITT-3 ] }
104 { 4 [ compression-CCITT-4 ] }
105 { 5 [ compression-lzw ] }
106 { 6 [ compression-jpeg-old ] }
107 { 7 [ compression-jpeg-new ] }
108 { 8 [ compression-adobe-deflate ] }
109 { 9 [ compression-9 ] }
110 { 10 [ compression-10 ] }
111 { 32766 [ compression-next ] }
112 { 32771 [ compression-ccittrlew ] }
113 { 32773 [ compression-pack-bits ] }
114 { 32809 [ compression-thunderscan ] }
115 { 32895 [ compression-it8ctpad ] }
116 { 32896 [ compression-it8lw ] }
117 { 32897 [ compression-it8mp ] }
118 { 32898 [ compression-it8bl ] }
119 { 32908 [ compression-pixarfilm ] }
120 { 32909 [ compression-pixarlog ] }
121 { 32946 [ compression-deflate ] }
122 { 32947 [ compression-dcs ] }
123 { 34661 [ compression-jbig ] }
124 { 34676 [ compression-sgilog ] }
125 { 34677 [ compression-sgilog24 ] }
126 { 34712 [ compression-jp2000 ] }
130 SINGLETONS: resolution-unit
133 resolution-unit-centimeter ;
134 ERROR: bad-resolution-unit n ;
135 : lookup-resolution-unit ( n -- object )
137 { 1 [ resolution-unit-none ] }
138 { 2 [ resolution-unit-inch ] }
139 { 3 [ resolution-unit-centimeter ] }
140 [ bad-resolution-unit ]
143 SINGLETONS: predictor
145 predictor-horizontal-differencing ;
146 ERROR: bad-predictor n ;
147 : lookup-predictor ( n -- object )
149 { 1 [ predictor-none ] }
150 { 2 [ predictor-horizontal-differencing ] }
154 SINGLETONS: planar-configuration
155 planar-configuration-chunky
156 planar-configuration-planar ;
157 ERROR: bad-planar-configuration n ;
158 : lookup-planar-configuration ( n -- object )
160 { 1 [ planar-configuration-chunky ] }
161 { 2 [ planar-configuration-planar ] }
162 [ bad-planar-configuration ]
165 SINGLETONS: sample-format
167 sample-format-unsigned-integer
168 sample-format-signed-integer
169 sample-format-ieee-float
170 sample-format-undefined-data ;
171 ERROR: bad-sample-format n ;
172 : lookup-sample-format ( sequence -- object )
175 { 0 [ sample-format-none ] }
176 { 1 [ sample-format-unsigned-integer ] }
177 { 2 [ sample-format-signed-integer ] }
178 { 3 [ sample-format-ieee-float ] }
179 { 4 [ sample-format-undefined-data ] }
180 [ bad-sample-format ]
184 SINGLETONS: extra-samples
185 extra-samples-unspecified-alpha-data
186 extra-samples-associated-alpha-data
187 extra-samples-unassociated-alpha-data ;
188 ERROR: bad-extra-samples n ;
189 : lookup-extra-samples ( sequence -- object )
191 { 0 [ extra-samples-unspecified-alpha-data ] }
192 { 1 [ extra-samples-associated-alpha-data ] }
193 { 2 [ extra-samples-unassociated-alpha-data ] }
194 [ bad-extra-samples ]
197 SINGLETONS: image-length image-width x-resolution y-resolution
198 rows-per-strip strip-offsets strip-byte-counts bits-per-sample
199 samples-per-pixel new-subfile-type subfile-type orientation
200 software date-time photoshop exif-ifd sub-ifd inter-color-profile
201 xmp iptc fill-order document-name page-number page-name
202 x-position y-position host-computer copyright artist
203 min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
204 gray-response-unit gray-response-curve color-map threshholding
205 image-description free-offsets free-byte-counts tile-width tile-length
206 matteing data-type image-depth tile-depth
207 ycbcr-subsampling gdal-metadata
208 tile-offsets tile-byte-counts jpeg-qtables jpeg-dctables jpeg-actables
209 ycbcr-positioning ycbcr-coefficients reference-black-white halftone-hints
210 jpeg-interchange-format
211 jpeg-interchange-format-length
212 jpeg-restart-interval jpeg-tables
213 t4-options clean-fax-data bad-fax-lines consecutive-bad-fax-lines
214 sto-nits print-image-matching-info
215 unhandled-ifd-entry ;
217 SINGLETONS: jpeg-proc
221 ERROR: bad-jpeg-proc n ;
223 : lookup-jpeg-proc ( sequence -- object )
225 { 1 [ jpeg-proc-baseline ] }
226 { 14 [ jpeg-proc-lossless ] }
230 ERROR: bad-tiff-magic bytes ;
231 : tiff-endianness ( byte-array -- ? )
233 { B{ CHAR: M CHAR: M } [ big-endian ] }
234 { B{ CHAR: I CHAR: I } [ little-endian ] }
238 : read-header ( tiff -- tiff )
239 2 read tiff-endianness [ >>endianness ] keep
241 2 read endian> >>the-answer
242 4 read endian> >>ifd-offset
245 : store-ifd ( tiff ifd -- tiff )
246 dup offset>> pick ifds>> set-at ;
248 : read-ifd-entry ( -- ifd )
252 4 read endian> <ifd-entry> ;
254 : read-ifd ( offset -- ifd )
255 dup seek-absolute seek-input
257 dup [ read-ifd-entry ] replicate
259 ! next ifd offset, 0 for stop
263 : read-ifds ( tiff offset -- tiff )
267 next-offset>> dup { [ 0 > ] [ pick ifds>> key? not ] } 1&& [
274 ERROR: no-tag class ;
276 : find-tag* ( ifd class -- tag/class ? )
277 swap processed-tags>> ?at ;
279 : find-tag ( ifd class -- tag )
280 find-tag* [ no-tag ] unless ;
282 : tag? ( ifd class -- tag )
283 swap processed-tags>> key? ;
285 : read-strips ( ifd -- ifd )
287 [ strip-byte-counts find-tag ]
288 [ strip-offsets find-tag ] bi
289 2dup [ integer? ] both? [
290 seek-absolute seek-input read 1array
292 [ seek-absolute seek-input read ] { } 2map-as
295 ERROR: unknown-ifd-type n where ;
297 : bytes>bits ( n/byte-array -- n )
298 dup byte-array? [ le> ] when ;
300 ! TODO: Should skip entire ifd-entry instead of throwing
301 ! if type is unknown (e.g. type 0 from the AFL american fuzzy loop test cases)
302 : value-length ( ifd-entry -- n )
303 [ count>> ] [ type>> ] bi {
317 [ "value-length" unknown-ifd-type ]
320 ERROR: bad-small-ifd-type n ;
322 : adjust-offset/value ( ifd-entry -- obj )
323 [ offset/value>> 4 >endian ] [ type>> ] bi
325 { 1 [ 1 head endian> ] }
326 { 3 [ 2 head endian> ] }
328 { 6 [ 1 head endian> 8 >signed ] }
329 { 8 [ 2 head endian> 16 >signed ] }
330 { 9 [ endian> 32 >signed ] }
331 { 11 [ endian> bits>float ] }
332 { 13 [ endian> 32 >signed ] }
333 [ bad-small-ifd-type ]
336 : offset-bytes>obj ( bytes type -- obj )
339 { 2 [ ] } ! read c strings here
340 { 3 [ 2 <groups> [ endian> ] map ] }
341 { 4 [ 4 <groups> [ endian> ] map ] }
342 { 5 [ 8 <groups> [ "II" unpack first2 / ] map ] }
343 { 6 [ [ 8 >signed ] map ] }
345 { 8 [ 2 <groups> [ endian> 16 >signed ] map ] }
346 { 9 [ 4 <groups> [ endian> 32 >signed ] map ] }
347 { 10 [ 8 group [ "ii" unpack first2 / ] map ] }
348 { 11 [ 4 group [ "f" unpack ] map ] }
349 { 12 [ 8 group [ "d" unpack ] map ] }
350 [ "offset-bytes>obj" unknown-ifd-type ]
353 : ifd-entry-value ( ifd-entry -- n )
354 dup value-length 4 <= [
357 [ offset/value>> seek-absolute seek-input ]
358 [ value-length read ]
359 [ type>> ] tri offset-bytes>obj
362 : process-ifd-entry ( ifd-entry -- value class )
363 [ ifd-entry-value ] [ tag>> ] bi {
364 { 254 [ new-subfile-type ] }
365 { 255 [ subfile-type ] }
366 { 256 [ image-width ] }
367 { 257 [ image-length ] }
368 { 258 [ bits-per-sample ] }
369 { 259 [ lookup-compression compression ] }
370 { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
371 { 263 [ threshholding ] }
372 { 264 [ cell-width ] }
373 { 265 [ cell-length ] }
374 { 266 [ fill-order ] }
375 { 269 [ ascii decode document-name ] }
376 { 270 [ ascii decode image-description ] }
377 { 271 [ ascii decode tiff-make ] }
378 { 272 [ ascii decode tiff-model ] }
379 { 273 [ strip-offsets ] }
380 { 274 [ orientation ] }
381 { 277 [ samples-per-pixel ] }
382 { 278 [ rows-per-strip ] }
383 { 279 [ strip-byte-counts ] }
384 { 280 [ min-sample-value ] }
385 { 281 [ max-sample-value ] }
386 { 282 [ first x-resolution ] }
387 { 283 [ first y-resolution ] }
388 { 284 [ lookup-planar-configuration planar-configuration ] }
389 { 285 [ page-name ] }
390 { 286 [ x-position ] }
391 { 287 [ y-position ] }
392 { 288 [ free-offsets ] }
393 { 289 [ free-byte-counts ] }
394 { 290 [ gray-response-unit ] }
395 { 291 [ gray-response-curve ] }
396 { 292 [ t4-options ] }
397 { 296 [ lookup-resolution-unit resolution-unit ] }
398 { 297 [ page-number ] }
399 { 305 [ ascii decode software ] }
400 { 306 [ ascii decode date-time ] }
401 { 315 [ ascii decode artist ] }
402 { 316 [ ascii decode host-computer ] }
403 { 317 [ lookup-predictor predictor ] }
404 { 320 [ color-map ] }
405 { 321 [ halftone-hints ] }
406 { 322 [ tile-width ] }
407 { 323 [ tile-length ] }
408 { 324 [ tile-offsets ] }
409 { 325 [ tile-byte-counts ] }
410 { 326 [ bad-fax-lines ] }
411 { 327 [ clean-fax-data ] }
412 { 328 [ consecutive-bad-fax-lines ] }
414 { 338 [ lookup-extra-samples extra-samples ] }
415 { 339 [ lookup-sample-format sample-format ] }
416 { 347 [ jpeg-tables ] }
417 { 512 [ lookup-jpeg-proc jpeg-proc ] }
418 { 513 [ jpeg-interchange-format ] }
419 { 514 [ jpeg-interchange-format-length ] }
420 { 515 [ jpeg-restart-interval ] }
421 { 519 [ jpeg-qtables ] }
422 { 520 [ jpeg-dctables ] }
423 { 521 [ jpeg-actables ] }
424 { 529 [ ycbcr-coefficients ] }
425 { 530 [ ycbcr-subsampling ] }
426 { 531 [ ycbcr-positioning ] }
427 { 532 [ reference-black-white ] }
428 { 700 [ utf8 decode xmp ] }
429 { 32995 [ matteing ] }
430 { 32996 [ data-type ] }
431 { 32997 [ image-depth ] }
432 { 32998 [ tile-depth ] }
433 { 33432 [ copyright ] }
435 { 34377 [ photoshop ] }
436 { 34665 [ exif-ifd ] }
437 { 34675 [ inter-color-profile ] }
438 { 37439 [ sto-nits ] }
439 { 42112 [ gdal-metadata ] }
440 { 50341 [ print-image-matching-info ] }
441 [ nip unhandled-ifd-entry swap ]
444 : process-ifds ( loading-tiff -- loading-tiff )
448 [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags
452 ERROR: unhandled-compression compression ;
454 : (uncompress-strips) ( strips compression -- uncompressed-strips )
456 { compression-none [ ] }
457 { compression-lzw [ [ tiff-lzw-uncompress ] map ] }
458 [ unhandled-compression ]
461 : uncompress-strips ( ifd -- ifd )
463 _ compression find-tag (uncompress-strips)
466 : strips>bitmap ( ifd -- ifd )
467 dup strips>> concat >>bitmap ;
469 : (strips-predictor) ( ifd -- ifd )
471 [ image-width find-tag ]
472 [ samples-per-pixel find-tag ] tri
476 [ _ [ group ] [ 0 <array> ] bi [ v+ ] accumulate* concat ] map
480 : strips-predictor ( ifd -- ifd )
482 dup predictor find-tag
484 { predictor-none [ ] }
485 { predictor-horizontal-differencing [ (strips-predictor) ] }
490 ERROR: unknown-component-order ifd ;
492 : fix-bitmap-endianness ( ifd -- ifd )
493 dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
495 { { 32 32 32 32 } [ 4 seq>native-endianness ] }
496 { { 32 32 32 } [ 4 seq>native-endianness ] }
497 { { 16 16 16 16 } [ 2 seq>native-endianness ] }
498 { { 16 16 16 } [ 2 seq>native-endianness ] }
502 [ unknown-component-order ]
505 : ifd-component-order ( ifd -- component-order component-type )
506 bits-per-sample find-tag {
507 { { 32 32 32 32 } [ RGBA float-components ] }
508 { { 32 32 32 } [ RGB float-components ] }
509 { { 16 16 16 16 } [ RGBA ushort-components ] }
510 { { 16 16 16 } [ RGB ushort-components ] }
511 { { 8 8 8 8 } [ RGBA ubyte-components ] }
512 { { 8 8 8 } [ RGB ubyte-components ] }
513 { 8 [ LA ubyte-components ] }
514 [ unknown-component-order ]
517 : handle-alpha-data ( ifd -- ifd )
518 dup extra-samples find-tag {
519 { extra-samples-associated-alpha-data [ ] }
520 { extra-samples-unspecified-alpha-data [ ] }
521 { extra-samples-unassociated-alpha-data [ ] }
522 [ bad-extra-samples ]
525 : ifd>image ( ifd -- image )
527 [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
528 [ ifd-component-order [ >>component-order ] [ >>component-type ] bi* ]
529 [ bitmap>> >>bitmap ]
532 : tiff>image ( image -- image )
533 ifds>> values [ ifd>image ] map first ;
535 : with-tiff-endianness ( loading-tiff quot -- )
536 [ dup endianness>> ] dip with-endianness ; inline
538 : load-tiff-ifds ( -- loading-tiff )
541 dup ifd-offset>> read-ifds
543 ] with-tiff-endianness ;
545 : process-chunky-ifd ( ifd -- )
549 fix-bitmap-endianness
551 dup extra-samples tag? [ handle-alpha-data ] when
554 : process-planar-ifd ( ifd -- )
555 "planar ifd not supported" throw ;
557 : dispatch-planar-configuration ( ifd planar-configuration -- )
559 { planar-configuration-chunky [ process-chunky-ifd ] }
560 { planar-configuration-planar [ process-planar-ifd ] }
563 : process-ifd ( ifd -- )
564 dup planar-configuration find-tag* [
565 dispatch-planar-configuration
567 drop "no planar configuration" throw
570 : process-tif-ifds ( loading-tiff -- )
571 ifds>> values [ process-ifd ] each ;
573 : load-tiff ( -- loading-tiff )
575 0 seek-absolute seek-input
576 [ process-tif-ifds ] with-tiff-endianness ;
578 ! tiff files can store several images -- we just take the first for now
579 M: tiff-image stream>image* ( stream tiff-image -- image )
580 drop [ [ load-tiff tiff>image ] throw-on-eof ] with-input-stream ;
582 { "tif" "tiff" } [ tiff-image ?register-image-class ] each