lzw: integrating with gif and tiff

basis/compression/lzw/lzw.factor

@@ -1,39 +1,29 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.accessors assocs byte-arrays combinators
+USING: accessors combinators io kernel math namespaces
-io.encodings.binary io.streams.byte-array kernel math sequences
+prettyprint sequences vectors ;
-vectors ;
+QUALIFIED-WITH: bitstreams bs
 IN: compression.lzw
 
-QUALIFIED-WITH: bitstreams bs
+SYMBOL: clear-code
+4 clear-code set-global
 
-CONSTANT: clear-code 256
+SYMBOL: end-of-information
-CONSTANT: end-of-information 257
+5 end-of-information set-global
 
-TUPLE: lzw input output table code old-code ;
+TUPLE: lzw input output table code old-code initial-code-size code-size ;
-
-SYMBOL: table-full
-
-: lzw-bit-width ( n -- n' )
-    {
-        { [ dup 510 <= ] [ drop 9 ] }
-        { [ dup 1022 <= ] [ drop 10 ] }
-        { [ dup 2046 <= ] [ drop 11 ] }
-        { [ dup 4094 <= ] [ drop 12 ] }
-        [ drop table-full ]
-    } cond ;
-
-: lzw-bit-width-uncompress ( lzw -- n )
-    table>> length lzw-bit-width ;
 
 : initial-uncompress-table ( -- seq )
-    258 iota [ 1vector ] V{ } map-as ;
+    end-of-information get 1 + iota [ 1vector ] V{ } map-as ;
 
 : reset-lzw-uncompress ( lzw -- lzw )
-    initial-uncompress-table >>table ;
+    initial-uncompress-table >>table
+    dup initial-code-size>> >>code-size ;
 
-: <lzw-uncompress> ( input -- obj )
+: <lzw-uncompress> ( input code-size -- obj )
     lzw new
+        swap >>initial-code-size
+        dup initial-code-size>> >>code-size
         swap >>input
         BV{ } clone >>output
         reset-lzw-uncompress ;
@@ -55,15 +45,28 @@ ERROR: not-in-table value ;
 : write-code ( lzw -- )
     [ lookup-code ] [ output>> ] bi push-all ;
 
-: add-to-table ( seq lzw -- ) table>> push ;
+: kdebug ( lzw -- lzw )
+    dup "TIFF: incrementing code size " write
+    [ code-size>> pprint ] 
+    [ " table length " write table>> length pprint ] bi
+    nl ;
+
+: maybe-increment-code-size ( lzw -- lzw )
+    dup [ table>> length ] [ code-size>> 2^ 1 - ] bi =
+    [ kdebug [ 1 + ] change-code-size ] when ;
+
+: add-to-table ( seq lzw -- )
+    [ table>> push ]
+    [ maybe-increment-code-size 2drop ] 2bi ;
 
 : lzw-read ( lzw -- lzw n )
-    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
+    [ ] [ code-size>> ] [ input>> ] tri bs:read ;
 
 DEFER: lzw-uncompress-char
 : handle-clear-code ( lzw -- )
+    "CLEAR CODE" print
     reset-lzw-uncompress
-    lzw-read dup end-of-information = [
+    lzw-read dup end-of-information get = [
         2drop
     ] [
         >>code
@@ -91,10 +94,10 @@ DEFER: lzw-uncompress-char
 : lzw-uncompress-char ( lzw -- )
     lzw-read [
         >>code
-        dup code>> end-of-information = [
+        dup code>> end-of-information get = [
             drop
         ] [
-            dup code>> clear-code = [
+            dup code>> clear-code get = [
                 handle-clear-code
             ] [
                 handle-uncompress-code
@@ -105,7 +108,19 @@ DEFER: lzw-uncompress-char
         drop
     ] if* ;
 
-: lzw-uncompress ( seq -- byte-array )
+: register-special-codes ( first-code-size -- first-code-size )
-    bs:<msb0-bit-reader>
+    [
+        1 - 2^ dup clear-code set
+        1 + end-of-information set
+    ] keep ;
+
+: lzw-uncompress ( bitstream code-size -- byte-array )
+    register-special-codes
     <lzw-uncompress>
     [ lzw-uncompress-char ] [ output>> ] bi ;
+
+: lzw-uncompress-msb0 ( seq code-size -- byte-array )
+    [ bs:<msb0-bit-reader> ] dip lzw-uncompress ;
+
+: lzw-uncompress-lsb0 ( seq code-size -- byte-array )
+    [ bs:<lsb0-bit-reader> ] dip lzw-uncompress ;

basis/images/tiff/tiff-tests.factor

@@ -1,10 +1,44 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test images.tiff ;
+USING: accessors images.tiff images.viewer io
+io.encodings.binary io.files namespaces sequences tools.test ;
 IN: images.tiff.tests
 
-: tiff-test-path ( -- path )
+: path>tiff ( path -- tiff )
-    "resource:extra/images/test-images/rgb.tiff" ;
+    binary [ input-stream get load-tiff ] with-file-reader ;
+
+: tiff-example1 ( -- tiff )
+    "resource:extra/images/testing/square.tiff" path>tiff ;
+
+: tiff-example2 ( -- tiff )
+    "resource:extra/images/testing/cube.tiff" path>tiff ;
+
+: tiff-example3 ( -- tiff )
+    "resource:extra/images/testing/bi.tiff" path>tiff ;
+
+: tiff-example4 ( -- tiff )
+    "resource:extra/images/testing/noise.tiff" path>tiff ;
+
+: tiff-example5 ( -- tiff )
+    "resource:extra/images/testing/alpha.tiff" path>tiff ;
+
+: tiff-example6 ( -- tiff )
+    "resource:extra/images/testing/color_spectrum.tiff" path>tiff ;
+
+: tiff-example7 ( -- tiff )
+    "resource:extra/images/testing/small.tiff" path>tiff ;
+
+: tiff-all. ( -- )
+    {
+        tiff-example1 tiff-example2 tiff-example3 tiff-example4 tiff-example5
+        tiff-example6
+    }
+    [ execute( -- gif ) tiff>image image. ] each ;
+
+[ 1024 ] [ tiff-example1 ifds>> first bitmap>> length ] unit-test
+[ 1024 ] [ tiff-example2 ifds>> first bitmap>> length ] unit-test
+[ 131744 ] [ tiff-example3 ifds>> first bitmap>> length ] unit-test
+[ 49152 ] [ tiff-example4 ifds>> first bitmap>> length ] unit-test
+[ 16 ] [ tiff-example5 ifds>> first bitmap>> length ] unit-test
+[ 117504 ] [ tiff-example6 ifds>> first bitmap>> length ] unit-test
 
-: tiff-test-path2 ( -- path )
-    "resource:extra/images/test-images/octagon.tiff" ;

basis/images/tiff/tiff.factor

@@ -434,10 +434,13 @@ ERROR: bad-small-ifd-type n ;
 
 ERROR: unhandled-compression compression ;
 
+: lzw-tiff-uncompress ( seq -- byte-array )
+    9 lzw-uncompress-msb0 ;
+
 : (uncompress-strips) ( strips compression -- uncompressed-strips )
     {
         { compression-none [ ] }
-        { compression-lzw [ [ lzw-uncompress ] map ] }
+        { compression-lzw [ [ lzw-tiff-uncompress ] map ] }
         [ unhandled-compression ]
     } case ;
 

extra/compression/lzw-gif/lzw-gif.factor

@@ -45,9 +45,15 @@ ERROR: not-in-table value ;
 : write-code ( lzw -- )
     [ lookup-code ] [ output>> ] bi push-all ;
 
+: kdebug ( lzw -- lzw )
+    dup "GIF: incrementing code size " write
+    [ code-size>> pprint ] 
+    [ " table length " write table>> length pprint ] bi
+    nl ;
+
 : maybe-increment-code-size ( lzw -- lzw )
     dup [ table>> length ] [ code-size>> 2^ ] bi =
-    [ [ 1 + ] change-code-size ] when ;
+    [ kdebug [ 1 + ] change-code-size ] when ;
 
 : add-to-table ( seq lzw -- )
     [ table>> push ]
@@ -58,6 +64,7 @@ ERROR: not-in-table value ;
 
 DEFER: lzw-uncompress-char
 : handle-clear-code ( lzw -- )
+    "CLEAR CODE" print
     reset-lzw-uncompress
     lzw-read dup end-of-information get = [
         2drop