From d45f0c83eb94675ac655a15ebb93c7fa5335f2f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 16:19:09 -0600 Subject: [PATCH 1/5] more work on tiff files. --- extra/graphics/tiff/tiff-tests.factor | 4 +- extra/graphics/tiff/tiff.factor | 174 ++++++++++++++++++++++---- 2 files changed, 151 insertions(+), 27 deletions(-) diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor index daee9a5d9e..f800b4d213 100755 --- a/extra/graphics/tiff/tiff-tests.factor +++ b/extra/graphics/tiff/tiff-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Your name. +! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test graphics.tiff ; IN: graphics.tiff.tests @@ -6,4 +6,6 @@ IN: graphics.tiff.tests : tiff-test-path ( -- path ) "resource:extra/graphics/tiff/rgb.tiff" ; +: tiff-test-path2 ( -- path ) + "resource:extra/graphics/tiff/octagon.tiff" ; diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index f0b3f9337e..9461403805 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,7 +2,10 @@ ! 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 math.parser prettyprint classes ; +sorting.slots math.order math.parser prettyprint classes +io.binary assocs math math.bitwise byte-arrays grouping ; +USE: multiline + IN: graphics.tiff TUPLE: tiff @@ -14,13 +17,14 @@ ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries next processed-tags strips ; +TUPLE: ifd count ifd-entries next +processed-tags strips buffer ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; -TUPLE: ifd-entry tag type count offset ; +TUPLE: ifd-entry tag type count offset/value ; -CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; +CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; TUPLE: photometric-interpretation color ; @@ -132,6 +136,44 @@ ERROR: bad-planar-configuration n ; [ bad-predictor ] } case ; +TUPLE: sample-format n ; +CONSTRUCTOR: sample-format ( n -- object ) ; +ERROR: bad-sample-format n ; + +SINGLETONS: sample-unsigned-integer sample-signed-integer +sample-ieee-float sample-undefined-data ; + +: lookup-sample-format ( seq -- object ) + [ + { + { 1 [ sample-unsigned-integer ] } + { 2 [ sample-signed-integer ] } + { 3 [ sample-ieee-float ] } + { 4 [ sample-undefined-data ] } + [ bad-sample-format ] + } case + ] map ; + + +TUPLE: extra-samples n ; +CONSTRUCTOR: extra-samples ( n -- object ) ; +ERROR: bad-extra-samples n ; + +SINGLETONS: unspecified-alpha-data associated-alpha-data +unassociated-alpha-data ; + +: lookup-extra-samples ( seq -- object ) + { + { 0 [ unspecified-alpha-data ] } + { 1 [ associated-alpha-data ] } + { 2 [ unassociated-alpha-data ] } + [ bad-extra-samples ] + } case ; + + +TUPLE: orientation n ; +CONSTRUCTOR: orientation ( n -- object ) ; + TUPLE: new-subfile-type n ; CONSTRUCTOR: new-subfile-type ( n -- object ) ; @@ -157,6 +199,7 @@ ERROR: bad-tiff-magic bytes ; : push-ifd ( tiff ifd -- tiff ) over ifds>> push ; + ! over [ dup class ] [ ifds>> ] bi* set-at ; : read-ifd ( -- ifd ) 2 read endian> @@ -165,29 +208,96 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> ; : read-ifds ( tiff -- tiff ) - [ - dup ifd-offset>> seek-absolute seek-input - 2 read endian> - dup [ read-ifd ] replicate - 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi - ] with-tiff-endianness ; + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + +ERROR: no-tag class ; + +: ?at ( key assoc -- value/key ? ) + dupd at* [ nip t ] [ drop f ] if ; inline + +: find-tag ( idf class -- tag ) + swap processed-tags>> + ?at [ no-tag ] unless ; : read-strips ( ifd -- ifd ) - dup processed-tags>> - [ [ strip-byte-counts instance? ] find nip n>> ] - [ [ strip-offsets instance? ] find nip n>> ] bi - [ seek-absolute seek-input read ] { } 2map-as >>strips ; + dup + [ strip-byte-counts find-tag n>> ] + [ strip-offsets find-tag n>> ] bi + 2dup [ integer? ] both? [ + seek-absolute seek-input read 1array + ] [ + [ seek-absolute seek-input read ] { } 2map-as + ] if >>strips ; ! ERROR: unhandled-ifd-entry data n ; : unhandled-ifd-entry ; +ERROR: unknown-ifd-type n ; + +: bytes>bits ( n/byte-array -- n ) + dup byte-array? [ byte-array>bignum ] when ; + +: value-length ( ifd-entry -- n ) + [ count>> ] [ type>> ] bi { + { 1 [ ] } + { 2 [ ] } + { 3 [ 2 * ] } + { 4 [ 4 * ] } + { 5 [ 8 * ] } + { 6 [ ] } + { 7 [ ] } + { 8 [ 2 * ] } + { 9 [ 4 * ] } + { 10 [ 8 * ] } + { 11 [ 4 * ] } + { 12 [ 8 * ] } + [ unknown-ifd-type ] + } case ; + +ERROR: bad-small-ifd-type n ; + +: adjust-offset/value ( ifd-entry -- obj ) + [ offset/value>> 4 >endian ] [ type>> ] bi + { + { 1 [ 1 head endian> ] } + { 3 [ 2 head endian> ] } + { 4 [ endian> ] } + { 6 [ 1 head endian> 8 >signed ] } + { 8 [ 2 head endian> 16 >signed ] } + { 9 [ endian> 32 >signed ] } + { 11 [ endian> bits>float ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ endian> 32 >signed ] map ] } + { 10 [ 8 group [ "ii" unpack first2 / ] map ] } + { 11 [ 4 group [ "f" unpack ] map ] } + { 12 [ 8 group [ "d" unpack ] map ] } + [ unknown-ifd-type ] + } case ; + : ifd-entry-value ( ifd-entry -- n ) - dup count>> 1 = [ - offset>> + dup value-length 4 <= [ + adjust-offset/value ] [ - [ offset>> seek-absolute seek-input ] [ count>> read ] bi + [ offset/value>> seek-absolute seek-input ] + [ value-length read ] + [ type>> ] tri offset-bytes>obj ] if ; : process-ifd-entry ( ifd-entry -- object ) @@ -199,6 +309,7 @@ ERROR: bad-tiff-magic bytes ; { 259 [ lookup-compression ] } { 262 [ lookup-photometric-interpretation ] } { 273 [ ] } + { 274 [ ] } { 277 [ ] } { 278 [ ] } { 279 [ ] } @@ -207,21 +318,32 @@ ERROR: bad-tiff-magic bytes ; { 284 [ ] } { 296 [ lookup-resolution-unit ] } { 317 [ lookup-predictor ] } + { 338 [ lookup-extra-samples ] } + { 339 [ lookup-sample-format ] } [ unhandled-ifd-entry swap 2array ] } case ; : process-ifd ( ifd -- ifd ) - dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; + dup ifd-entries>> + [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; + +/* +: ifd-strips>buffer ( ifd -- ifd ) + [ + [ rows-per-strip find-tag n>> ] + [ image-length find-tag n>> ] bi + ] [ + strips>> [ length ] keep + ] bi assemble-image ; +*/ : (load-tiff) ( path -- tiff ) binary [ - read-header - read-ifds - dup ifds>> [ process-ifd read-strips drop ] each + read-header [ + read-ifds + dup ifds>> [ process-ifd read-strips drop ] each + ] with-tiff-endianness ] with-file-reader ; -: load-tiff ( path -- tiff ) - (load-tiff) ; - -! TODO: duplicate ifds = error, seeking out of bounds = error +: load-tiff ( path -- tiff ) (load-tiff) ; From 41e0db098caff53221560f50bb46855123b2c43a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 16:19:43 -0600 Subject: [PATCH 2/5] make pack/unpack public --- basis/pack/pack.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 9078817206..27cba6d6e7 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -87,12 +87,12 @@ CONSTANT: packed-length-table { CHAR: D 8 } } +PRIVATE> + MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as '[ [ [ _ spread ] input - : ch>packed-length ( ch -- n ) packed-length-table at ; inline @@ -113,14 +113,14 @@ PRIVATE> : start/end ( seq -- seq1 seq2 ) [ 0 [ + ] accumulate nip dup ] keep v+ ; inline +PRIVATE> + MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map '[ [ _ cleave ] output>array ] ; -PRIVATE> - : unpack-native ( seq str -- seq ) '[ _ _ unpack ] with-native-endian ; inline From 3672bcb08f12e4d4059d988152c9fc3956adab08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 18:39:46 -0600 Subject: [PATCH 3/5] loading some tiff files works! --- extra/graphics/tiff/tiff.factor | 6 ++++-- extra/graphics/viewer/viewer.factor | 30 ++++++++++++++++++++++------- 2 files changed, 27 insertions(+), 9 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 9461403805..b4e57d4ed6 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -14,6 +14,7 @@ the-answer ifd-offset ifds ; + CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; @@ -327,8 +328,9 @@ ERROR: bad-small-ifd-type n ; dup ifd-entries>> [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; +: strips>buffer ( ifd -- ifd ) + dup strips>> concat >>buffer ; /* -: ifd-strips>buffer ( ifd -- ifd ) [ [ rows-per-strip find-tag n>> ] [ image-length find-tag n>> ] bi @@ -342,7 +344,7 @@ ERROR: bad-small-ifd-type n ; read-header [ read-ifds - dup ifds>> [ process-ifd read-strips drop ] each + dup ifds>> [ process-ifd read-strips strips>buffer drop ] each ] with-tiff-endianness ] with-file-reader ; diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 8e0b1ec43c..90425722da 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators graphics.bitmap kernel math math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render ; +ui.gadgets.panes ui.render graphics.tiff sequences ; IN: graphics.viewer TUPLE: graphics-gadget < gadget image ; @@ -21,6 +21,14 @@ M: graphics-gadget draw-gadget* ( gadget -- ) \ graphics-gadget new-gadget swap >>image ; +: bits>gl-params ( n -- gl-bgr gl-format ) + { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case ; + M: bitmap draw-image ( bitmap -- ) dup height>> 0 < [ 0 0 glRasterPos2i @@ -32,12 +40,7 @@ M: bitmap draw-image ( bitmap -- ) [ width>> ] keep [ [ height>> abs ] keep - bit-count>> { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case + bit-count>> bits>gl-params ] keep array>> glDrawPixels ; M: bitmap width ( bitmap -- ) width>> ; @@ -48,3 +51,16 @@ M: bitmap height ( bitmap -- ) height>> ; : bitmap-window ( path -- gadget ) load-bitmap [ "bitmap" open-window ] keep ; + +M: tiff width ( tiff -- ) ifds>> first image-width find-tag n>> ; +M: tiff height ( tiff -- ) ifds>> first image-length find-tag n>> ; + +M: tiff draw-image ( tiff -- ) + [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip + ifds>> first + { + [ image-width find-tag n>> ] + [ image-length find-tag n>> ] + [ bits-per-sample find-tag n>> sum bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; From fbba25e968c0513605092fa1500fbcb8761a8540 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 19:16:46 -0600 Subject: [PATCH 4/5] clean up tiff --- extra/graphics/tiff/tiff.factor | 262 ++++++++++------------------ extra/graphics/viewer/viewer.factor | 10 +- 2 files changed, 96 insertions(+), 176 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index b4e57d4ed6..0481af8747 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -4,183 +4,121 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays sorting.slots math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays grouping ; -USE: multiline - IN: graphics.tiff -TUPLE: tiff -endianness -the-answer -ifd-offset -ifds ; - +TUPLE: tiff endianness the-answer ifd-offset ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next processed-tags strips buffer ; - CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset/value ; - CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; - -TUPLE: photometric-interpretation color ; - -CONSTRUCTOR: photometric-interpretation ( color -- object ) ; - -SINGLETONS: white-is-zero black-is-zero rgb palette-color ; - +SINGLETONS: photometric-interpretation +photometric-interpretation-white-is-zero +photometric-interpretation-black-is-zero +photometric-interpretation-rgb +photometric-interpretation-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 ] } + { 0 [ photometric-interpretation-white-is-zero ] } + { 1 [ photometric-interpretation-black-is-zero ] } + { 2 [ photometric-interpretation-rgb ] } + { 3 [ photometric-interpretation-palette-color ] } [ bad-photometric-interpretation ] - } case ; - - -TUPLE: compression method ; - -CONSTRUCTOR: compression ( method -- object ) ; - -SINGLETONS: no-compression CCITT-2 pack-bits lzw ; + } case ; +SINGLETONS: compression +compression-none +compression-CCITT-2 +compression-lzw +compression-pack-bits ; ERROR: bad-compression n ; - : lookup-compression ( n -- compression ) { - { 1 [ no-compression ] } - { 2 [ CCITT-2 ] } - { 5 [ lzw ] } - { 32773 [ pack-bits ] } + { 1 [ compression-none ] } + { 2 [ compression-CCITT-2 ] } + { 5 [ compression-lzw ] } + { 32773 [ compression-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 ) ; + } case ; +SINGLETONS: resolution-unit +resolution-unit-none +resolution-unit-inch +resolution-unit-centimeter ; ERROR: bad-resolution-unit n ; - : lookup-resolution-unit ( n -- object ) { - { 1 [ no-resolution-unit ] } - { 2 [ inch-resolution-unit ] } - { 3 [ centimeter-resolution-unit ] } + { 1 [ resolution-unit-none ] } + { 2 [ resolution-unit-inch ] } + { 3 [ resolution-unit-centimeter ] } [ bad-resolution-unit ] - } case ; - - -TUPLE: predictor type ; -CONSTRUCTOR: predictor ( type -- object ) ; - -SINGLETONS: no-predictor horizontal-differencing-predictor ; + } case ; +SINGLETONS: predictor +predictor-none +predictor-horizontal-differencing ; ERROR: bad-predictor n ; - : lookup-predictor ( n -- object ) { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } + { 1 [ predictor-none ] } + { 2 [ predictor-horizontal-differencing ] } [ bad-predictor ] - } case ; - - -TUPLE: planar-configuration type ; -CONSTRUCTOR: planar-configuration ( type -- object ) ; - -SINGLETONS: chunky planar ; + } case ; +SINGLETONS: planar-configuration +planar-configuration-chunky +planar-configuration-planar ; ERROR: bad-planar-configuration n ; - : lookup-planar-configuration ( n -- object ) { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } - [ bad-predictor ] - } case ; + { 1 [ planar-configuration-chunky ] } + { 2 [ planar-configuration-planar ] } + [ bad-planar-configuration ] + } case ; -TUPLE: sample-format n ; -CONSTRUCTOR: sample-format ( n -- object ) ; ERROR: bad-sample-format n ; - -SINGLETONS: sample-unsigned-integer sample-signed-integer -sample-ieee-float sample-undefined-data ; - +SINGLETONS: sample-format +sample-format-unsigned-integer +sample-format-signed-integer +sample-format-ieee-float +sample-format-undefined-data ; : lookup-sample-format ( seq -- object ) [ { - { 1 [ sample-unsigned-integer ] } - { 2 [ sample-signed-integer ] } - { 3 [ sample-ieee-float ] } - { 4 [ sample-undefined-data ] } + { 1 [ sample-format-unsigned-integer ] } + { 2 [ sample-format-signed-integer ] } + { 3 [ sample-format-ieee-float ] } + { 4 [ sample-format-undefined-data ] } [ bad-sample-format ] } case - ] map ; + ] map ; - -TUPLE: extra-samples n ; -CONSTRUCTOR: extra-samples ( n -- object ) ; ERROR: bad-extra-samples n ; - -SINGLETONS: unspecified-alpha-data associated-alpha-data -unassociated-alpha-data ; - +SINGLETONS: extra-samples +extra-samples-unspecified-alpha-data +extra-samples-associated-alpha-data +extra-samples-unassociated-alpha-data ; : lookup-extra-samples ( seq -- object ) { - { 0 [ unspecified-alpha-data ] } - { 1 [ associated-alpha-data ] } - { 2 [ unassociated-alpha-data ] } + { 0 [ extra-samples-unspecified-alpha-data ] } + { 1 [ extra-samples-associated-alpha-data ] } + { 2 [ extra-samples-unassociated-alpha-data ] } [ bad-extra-samples ] - } case ; + } case ; - -TUPLE: orientation n ; -CONSTRUCTOR: orientation ( n -- object ) ; - - -TUPLE: new-subfile-type n ; -CONSTRUCTOR: new-subfile-type ( n -- object ) ; +SINGLETONS: image-length image-width x-resolution y-resolution +rows-per-strip strip-offsets strip-byte-counts bits-per-sample +samples-per-pixel new-subfile-type orientation +unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; - : tiff-endianness ( byte-array -- ? ) { { B{ CHAR: M CHAR: M } [ big-endian ] } @@ -188,9 +126,6 @@ ERROR: bad-tiff-magic bytes ; [ bad-tiff-magic ] } case ; -: with-tiff-endianness ( tiff quot -- tiff ) - [ dup endianness>> ] dip with-endianness ; inline - : read-header ( tiff -- tiff ) 2 read tiff-endianness [ >>endianness ] keep [ @@ -198,9 +133,7 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> >>ifd-offset ] with-endianness ; -: push-ifd ( tiff ifd -- tiff ) - over ifds>> push ; - ! over [ dup class ] [ ifds>> ] bi* set-at ; +: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; : read-ifd ( -- ifd ) 2 read endian> @@ -221,23 +154,18 @@ ERROR: no-tag class ; dupd at* [ nip t ] [ drop f ] if ; inline : find-tag ( idf class -- tag ) - swap processed-tags>> - ?at [ no-tag ] unless ; + swap processed-tags>> ?at [ no-tag ] unless ; : read-strips ( ifd -- ifd ) dup - [ strip-byte-counts find-tag n>> ] - [ strip-offsets find-tag n>> ] bi + [ strip-byte-counts find-tag ] + [ strip-offsets find-tag ] bi 2dup [ integer? ] both? [ seek-absolute seek-input read 1array ] [ [ seek-absolute seek-input read ] { } 2map-as ] if >>strips ; -! ERROR: unhandled-ifd-entry data n ; - -: unhandled-ifd-entry ; - ERROR: unknown-ifd-type n ; : bytes>bits ( n/byte-array -- n ) @@ -301,51 +229,43 @@ ERROR: bad-small-ifd-type n ; [ type>> ] tri offset-bytes>obj ] if ; -: process-ifd-entry ( ifd-entry -- object ) +: process-ifd-entry ( ifd-entry -- value class ) [ ifd-entry-value ] [ tag>> ] bi { - { 254 [ ] } - { 256 [ ] } - { 257 [ ] } - { 258 [ ] } - { 259 [ lookup-compression ] } - { 262 [ lookup-photometric-interpretation ] } - { 273 [ ] } - { 274 [ ] } - { 277 [ ] } - { 278 [ ] } - { 279 [ ] } - { 282 [ ] } - { 283 [ ] } - { 284 [ ] } - { 296 [ lookup-resolution-unit ] } - { 317 [ lookup-predictor ] } - { 338 [ lookup-extra-samples ] } - { 339 [ lookup-sample-format ] } - [ unhandled-ifd-entry swap 2array ] + { 254 [ new-subfile-type ] } + { 256 [ image-width ] } + { 257 [ image-length ] } + { 258 [ bits-per-sample ] } + { 259 [ lookup-compression compression ] } + { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 273 [ strip-offsets ] } + { 274 [ orientation ] } + { 277 [ samples-per-pixel ] } + { 278 [ rows-per-strip ] } + { 279 [ strip-byte-counts ] } + { 282 [ x-resolution ] } + { 283 [ y-resolution ] } + { 284 [ planar-configuration ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 317 [ lookup-predictor predictor ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + [ nip unhandled-ifd-entry ] } case ; : process-ifd ( ifd -- ifd ) dup ifd-entries>> - [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; : strips>buffer ( ifd -- ifd ) dup strips>> concat >>buffer ; -/* - [ - [ rows-per-strip find-tag n>> ] - [ image-length find-tag n>> ] bi - ] [ - strips>> [ length ] keep - ] bi assemble-image ; -*/ : (load-tiff) ( path -- tiff ) binary [ - read-header [ + read-header dup endianness>> [ read-ifds dup ifds>> [ process-ifd read-strips strips>buffer drop ] each - ] with-tiff-endianness + ] with-endianness ] with-file-reader ; : load-tiff ( path -- tiff ) (load-tiff) ; diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 90425722da..517ab4e010 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -52,15 +52,15 @@ M: bitmap height ( bitmap -- ) height>> ; : bitmap-window ( path -- gadget ) load-bitmap [ "bitmap" open-window ] keep ; -M: tiff width ( tiff -- ) ifds>> first image-width find-tag n>> ; -M: tiff height ( tiff -- ) ifds>> first image-length find-tag n>> ; +M: tiff width ( tiff -- ) ifds>> first image-width find-tag ; +M: tiff height ( tiff -- ) ifds>> first image-length find-tag ; M: tiff draw-image ( tiff -- ) [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip ifds>> first { - [ image-width find-tag n>> ] - [ image-length find-tag n>> ] - [ bits-per-sample find-tag n>> sum bits>gl-params ] + [ image-width find-tag ] + [ image-length find-tag ] + [ bits-per-sample find-tag sum bits>gl-params ] [ buffer>> ] } cleave glDrawPixels ; From 045cd614c669a892a5c45ec3526c95f1f96f7d5c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 19:18:18 -0600 Subject: [PATCH 5/5] make more taxes vocabs load by default --- extra/taxes/usa/futa/futa.factor | 3 +-- extra/taxes/usa/usa.factor | 4 +++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/taxes/usa/futa/futa.factor b/extra/taxes/usa/futa/futa.factor index 7368aef825..9b862a8960 100644 --- a/extra/taxes/usa/futa/futa.factor +++ b/extra/taxes/usa/futa/futa.factor @@ -11,5 +11,4 @@ IN: taxes.usa.futa : futa-tax ( salary w4 -- x ) drop futa-base-rate min - futa-tax-rate futa-tax-offset-credit - - * ; + futa-tax-rate futa-tax-offset-credit - * ; diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index 27ff4aef98..efdb969c01 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.intervals -namespaces sequences money math.order taxes.usa.w4 ; +namespaces sequences money math.order taxes.usa.w4 +taxes.usa.futa math.finance taxes.usa.fica +taxes.usa.federal ; IN: taxes.usa ! Withhold: FICA, Medicare, Federal (FICA is social security)