diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 34f6c3e4e0..462f75ff79 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order ; +sorting.slots math.order math.parser prettyprint ; IN: graphics.tiff TUPLE: tiff @@ -10,20 +10,135 @@ endianness the-answer ifd-offset ifds -; +processed-ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries ; +TUPLE: ifd count ifd-entries next ; -CONSTRUCTOR: ifd ( count ifd-entries -- ifd ) ; +CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset ; CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; +TUPLE: photometric-interpretation color ; + +CONSTRUCTOR: photometric-interpretation ( color -- object ) ; + +SINGLETONS: white-is-zero black-is-zero rgb palette-color ; + +ERROR: bad-photometric-interpretation n ; + +: lookup-photometric-interpretation ( n -- singleton ) + { + { 0 [ white-is-zero ] } + { 1 [ black-is-zero ] } + { 2 [ rgb ] } + { 3 [ palette-color ] } + [ bad-photometric-interpretation ] + } case ; + + +TUPLE: compression method ; + +CONSTRUCTOR: compression ( method -- object ) ; + +SINGLETONS: no-compression CCITT-2 pack-bits lzw ; + +ERROR: bad-compression n ; + +: lookup-compression ( n -- compression ) + { + { 1 [ no-compression ] } + { 2 [ CCITT-2 ] } + { 5 [ lzw ] } + { 32773 [ pack-bits ] } + [ bad-compression ] + } case ; + +TUPLE: image-length n ; +CONSTRUCTOR: image-length ( n -- object ) ; + +TUPLE: image-width n ; +CONSTRUCTOR: image-width ( n -- object ) ; + +TUPLE: x-resolution n ; +CONSTRUCTOR: x-resolution ( n -- object ) ; + +TUPLE: y-resolution n ; +CONSTRUCTOR: y-resolution ( n -- object ) ; + +TUPLE: rows-per-strip n ; +CONSTRUCTOR: rows-per-strip ( n -- object ) ; + +TUPLE: strip-offsets n ; +CONSTRUCTOR: strip-offsets ( n -- object ) ; + +TUPLE: strip-byte-counts n ; +CONSTRUCTOR: strip-byte-counts ( n -- object ) ; + +TUPLE: bits-per-sample n ; +CONSTRUCTOR: bits-per-sample ( n -- object ) ; + +TUPLE: samples-per-pixel n ; +CONSTRUCTOR: samples-per-pixel ( n -- object ) ; + +SINGLETONS: no-resolution-unit +inch-resolution-unit +centimeter-resolution-unit ; + +TUPLE: resolution-unit type ; +CONSTRUCTOR: resolution-unit ( type -- object ) ; + +ERROR: bad-resolution-unit n ; + +: lookup-resolution-unit ( n -- object ) + { + { 1 [ no-resolution-unit ] } + { 2 [ inch-resolution-unit ] } + { 3 [ centimeter-resolution-unit ] } + [ bad-resolution-unit ] + } case ; + + +TUPLE: predictor type ; +CONSTRUCTOR: predictor ( type -- object ) ; + +SINGLETONS: no-predictor horizontal-differencing-predictor ; + +ERROR: bad-predictor n ; + +: lookup-predictor ( n -- object ) + { + { 1 [ no-predictor ] } + { 2 [ horizontal-differencing-predictor ] } + [ bad-predictor ] + } case ; + + +TUPLE: planar-configuration type ; +CONSTRUCTOR: planar-configuration ( type -- object ) ; + +SINGLETONS: chunky planar ; + +ERROR: bad-planar-configuration n ; + +: lookup-planar-configuration ( n -- object ) + { + { 1 [ no-predictor ] } + { 2 [ horizontal-differencing-predictor ] } + [ bad-predictor ] + } case ; + + +TUPLE: new-subfile-type n ; +CONSTRUCTOR: new-subfile-type ( n -- object ) ; + + + ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -56,14 +171,52 @@ ERROR: bad-tiff-magic bytes ; [ dup ifd-offset>> seek 2 read endian> - dup [ read-ifd ] replicate >>ifds + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ] with-tiff-endianness ; +! ERROR: unhandled-ifd-entry data n ; + +: unhandled-ifd-entry ; + +: ifd-entry-value ( ifd-entry -- n ) + dup count>> 1 = [ + offset>> + ] [ + [ offset>> seek ] [ count>> read ] bi + ] if ; + +: process-ifd-entry ( ifd-entry -- object ) + [ ifd-entry-value ] [ tag>> ] bi { + { 254 [ ] } + { 256 [ ] } + { 257 [ ] } + { 258 [ ] } + { 259 [ lookup-compression ] } + { 262 [ lookup-photometric-interpretation ] } + { 273 [ ] } + { 277 [ ] } + { 278 [ ] } + { 279 [ ] } + { 282 [ ] } + { 283 [ ] } + { 284 [ ] } + { 296 [ lookup-resolution-unit ] } + { 317 [ lookup-predictor ] } + [ unhandled-ifd-entry swap 2array ] + } case ; + +: process-ifd ( ifd -- processed-ifd ) + ifd-entries>> [ process-ifd-entry ] map ; + : (load-tiff) ( path -- tiff ) binary [ - tiff new + read-header read-ifds + dup ifds>> [ process-ifd ] map + >>processed-ifds ] with-file-reader ; : load-tiff ( path -- tiff )