Merge branch 'master' of git://factorcode.org/git/factor

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<sequence ] B{ } append-outputs-as ] ;
 
-PRIVATE>
-
 : 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 <slice> @ ] ] 3map
     '[ [ _ cleave ] output>array ] ;
 
-PRIVATE>
-
 : unpack-native ( seq str -- seq )
     '[ _ _ unpack ] with-native-endian ; inline
 

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" ;
 

extra/graphics/tiff/tiff.factor

@@ -2,142 +2,123 @@
 ! 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 ;
 IN: graphics.tiff
 
-TUPLE: tiff
+TUPLE: tiff endianness the-answer ifd-offset ifds ;
-endianness
-the-answer
-ifd-offset
-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/value -- ifd-entry ) ;
-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 ;
 
+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 ] }
+        { 0 [ photometric-interpretation-white-is-zero ] }
-        { 1 [ black-is-zero ] }
+        { 1 [ photometric-interpretation-black-is-zero ] }
-        { 2 [ rgb ] }
+        { 2 [ photometric-interpretation-rgb ] }
-        { 3 [ palette-color ] }
+        { 3 [ photometric-interpretation-palette-color ] }
         [ bad-photometric-interpretation ]
-    } case <photometric-interpretation> ;
+    } case ;
-
-
-TUPLE: compression method ;
-
-CONSTRUCTOR: compression ( method -- object ) ;
-
-SINGLETONS: no-compression CCITT-2 pack-bits lzw ;
 
+SINGLETONS: compression
+compression-none
+compression-CCITT-2
+compression-lzw
+compression-pack-bits ;
 ERROR: bad-compression n ;
-
 : lookup-compression ( n -- compression )
     {
-        { 1 [ no-compression ] }
+        { 1 [ compression-none ] }
-        { 2 [ CCITT-2 ] }
+        { 2 [ compression-CCITT-2 ] }
-        { 5 [ lzw ] }
+        { 5 [ compression-lzw ] }
-        { 32773 [ pack-bits ] }
+        { 32773 [ compression-pack-bits ] }
         [ bad-compression ]
-    } case <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 ) ;
 
+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 ] }
+        { 1 [ resolution-unit-none ] }
-        { 2 [ inch-resolution-unit ] }
+        { 2 [ resolution-unit-inch ] }
-        { 3 [ centimeter-resolution-unit ] }
+        { 3 [ resolution-unit-centimeter ] }
         [ bad-resolution-unit ]
-    } case <resolution-unit> ;
+    } case ;
-
-
-TUPLE: predictor type ;
-CONSTRUCTOR: predictor ( type -- object ) ;
-
-SINGLETONS: no-predictor horizontal-differencing-predictor ;
 
+SINGLETONS: predictor
+predictor-none
+predictor-horizontal-differencing ;
 ERROR: bad-predictor n ;
-
 : lookup-predictor ( n -- object )
     {
-        { 1 [ no-predictor ] }
+        { 1 [ predictor-none ] }
-        { 2 [ horizontal-differencing-predictor ] }
+        { 2 [ predictor-horizontal-differencing ] }
         [ bad-predictor ]
-    } case <predictor> ;
+    } case ;
-
-
-TUPLE: planar-configuration type ;
-CONSTRUCTOR: planar-configuration ( type -- object ) ;
-
-SINGLETONS: chunky planar ;
 
+SINGLETONS: planar-configuration
+planar-configuration-chunky
+planar-configuration-planar ;
 ERROR: bad-planar-configuration n ;
-
 : lookup-planar-configuration ( n -- object )
     {
-        { 1 [ no-predictor ] }
+        { 1 [ planar-configuration-chunky ] }
-        { 2 [ horizontal-differencing-predictor ] }
+        { 2 [ planar-configuration-planar ] }
-        [ bad-predictor ]
+        [ bad-planar-configuration ]
-    } case <planar-configuration> ;
+    } case ;
 
+ERROR: bad-sample-format n ;
+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-format-unsigned-integer ] }
+            { 2 [ sample-format-signed-integer ] }
+            { 3 [ sample-format-ieee-float ] }
+            { 4 [ sample-format-undefined-data ] }
+            [ bad-sample-format ]
+        } case
+    ] map ;
 
-TUPLE: new-subfile-type n ;
+ERROR: bad-extra-samples n ;
-CONSTRUCTOR: new-subfile-type ( n -- object ) ;
+SINGLETONS: extra-samples
+extra-samples-unspecified-alpha-data
+extra-samples-associated-alpha-data
+extra-samples-unassociated-alpha-data ;
+: lookup-extra-samples ( seq -- object )
+    {
+        { 0 [ extra-samples-unspecified-alpha-data ] }
+        { 1 [ extra-samples-associated-alpha-data ] }
+        { 2 [ extra-samples-unassociated-alpha-data ] }
+        [ bad-extra-samples ]
+    } case ;
+
+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 ] }
@@ -145,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
     [
@@ -155,8 +133,7 @@ ERROR: bad-tiff-magic bytes ;
         4 read endian> >>ifd-offset
     ] with-endianness ;
 
-: push-ifd ( tiff ifd -- tiff )
+: push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
-    over ifds>> push ;
 
 : read-ifd ( -- ifd )
     2 read endian>
@@ -165,63 +142,130 @@ ERROR: bad-tiff-magic bytes ;
     4 read endian> <ifd-entry> ;
 
 : read-ifds ( tiff -- tiff )
-    [
     dup ifd-offset>> seek-absolute seek-input
     2 read endian>
     dup [ read-ifd ] replicate
     4 read endian>
-        [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi
+    [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
-    ] with-tiff-endianness ;
+
+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>>
+    dup
-    [ [ strip-byte-counts instance? ] find nip n>> ]
+    [ strip-byte-counts find-tag ]
-    [ [ strip-offsets instance? ] find nip n>> ] bi
+    [ strip-offsets find-tag ] bi
-    [ seek-absolute seek-input read ] { } 2map-as >>strips ;
+    2dup [ integer? ] both? [
+        seek-absolute seek-input read 1array
+    ] [
+        [ seek-absolute seek-input read ] { } 2map-as
+    ] if >>strips ;
 
-! ERROR: unhandled-ifd-entry data n ;
+ERROR: unknown-ifd-type n ;
 
-: unhandled-ifd-entry ;
+: 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 <sliced-groups> [ endian> ] map ] }
+        { 4 [ 4 <sliced-groups> [ endian> ] map ] }
+        { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
+        { 6 [ [ 8 >signed ] map ] }
+        { 7 [ ] } ! blank
+        { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
+        { 9 [ 4 <sliced-groups> [ 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 = [
+    dup value-length 4 <= [
-        offset>>
+        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 )
+: process-ifd-entry ( ifd-entry -- value class )
     [ ifd-entry-value ] [ tag>> ] bi {
-        { 254 [ <new-subfile-type> ] }
+        { 254 [ new-subfile-type ] }
-        { 256 [ <image-width> ] }
+        { 256 [ image-width ] }
-        { 257 [ <image-length> ] }
+        { 257 [ image-length ] }
-        { 258 [ <bits-per-sample> ] }
+        { 258 [ bits-per-sample ] }
-        { 259 [ lookup-compression ] }
+        { 259 [ lookup-compression compression ] }
-        { 262 [ lookup-photometric-interpretation ] }
+        { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
-        { 273 [ <strip-offsets> ] }
+        { 273 [ strip-offsets ] }
-        { 277 [ <samples-per-pixel> ] }
+        { 274 [ orientation ] }
-        { 278 [ <rows-per-strip> ] }
+        { 277 [ samples-per-pixel ] }
-        { 279 [ <strip-byte-counts> ] }
+        { 278 [ rows-per-strip ] }
-        { 282 [ <x-resolution> ] }
+        { 279 [ strip-byte-counts ] }
-        { 283 [ <y-resolution> ] }
+        { 282 [ x-resolution ] }
-        { 284 [ <planar-configuration> ] }
+        { 283 [ y-resolution ] }
-        { 296 [ lookup-resolution-unit ] }
+        { 284 [ planar-configuration ] }
-        { 317 [ lookup-predictor ] }
+        { 296 [ lookup-resolution-unit resolution-unit ] }
-        [ unhandled-ifd-entry swap 2array ]
+        { 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 ] map >>processed-tags ;
+    dup ifd-entries>>
+    [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
+
+: strips>buffer ( ifd -- ifd )
+    dup strips>> concat >>buffer ;
 
 : (load-tiff) ( path -- tiff )
     binary [
         <tiff>
-        read-header
+        read-header dup endianness>> [
             read-ifds
-        dup ifds>> [ process-ifd read-strips drop ] each
+            dup ifds>> [ process-ifd read-strips strips>buffer drop ] each
+        ] with-endianness
     ] with-file-reader ;
 
-: load-tiff ( path -- tiff )
+: load-tiff ( path -- tiff ) (load-tiff) ;
-    (load-tiff) ;
-
-! TODO: duplicate ifds = error, seeking out of bounds = error

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>> {
+        bit-count>> bits>gl-params
-            { 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
     ] keep array>> glDrawPixels ;
 
 M: bitmap width ( bitmap -- ) width>> ;
@@ -48,3 +51,16 @@ M: bitmap height ( bitmap -- ) height>> ;
 
 : bitmap-window ( path -- gadget )
     load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
+
+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 ]
+        [ image-length find-tag ]
+        [ bits-per-sample find-tag sum bits>gl-params ]
+        [ buffer>> ]
+    } cleave glDrawPixels ;

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 - * ;
-    * ;

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)