images.gif: Decompression now works. Still need to implement transparency and merge with TIFF LZW code

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

@@ -0,0 +1,116 @@
+! Copyright (C) 2009 Doug Coleman, Keith Lazuka
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io kernel math namespaces
+prettyprint sequences vectors ;
+QUALIFIED-WITH: bitstreams bs
+IN: compression.lzw-gif
+
+SYMBOL: clear-code
+4 clear-code set-global
+
+SYMBOL: end-of-information
+5 end-of-information set-global
+
+TUPLE: lzw input output table code old-code initial-code-size code-size ;
+
+SYMBOL: table-full
+
+: initial-uncompress-table ( -- seq )
+    end-of-information get 1 + iota [ 1vector ] V{ } map-as ;
+
+: reset-lzw-uncompress ( lzw -- lzw )
+    initial-uncompress-table >>table
+    dup initial-code-size>> >>code-size ;
+
+: <lzw-uncompress> ( code-size input -- obj )
+    lzw new
+        swap >>input
+        swap >>initial-code-size
+        dup initial-code-size>> >>code-size
+        BV{ } clone >>output
+        reset-lzw-uncompress ;
+
+ERROR: not-in-table value ;
+
+: lookup-old-code ( lzw -- vector )
+    [ old-code>> ] [ table>> ] bi nth ;
+
+: lookup-code ( lzw -- vector )
+    [ code>> ] [ table>> ] bi nth ;
+
+: code-in-table? ( lzw -- ? )
+    [ code>> ] [ table>> length ] bi < ;
+
+: code>old-code ( lzw -- lzw )
+    dup code>> >>old-code ;
+
+: write-code ( lzw -- )
+    [ lookup-code ] [ output>> ] bi push-all ;
+
+: maybe-increment-code-size ( lzw -- lzw )
+    dup [ table>> length ] [ code-size>> 2^ ] bi =
+    [ [ 1 + ] change-code-size ] when ;
+
+: add-to-table ( seq lzw -- )
+    [ table>> push ]
+    [ maybe-increment-code-size 2drop ] 2bi ;
+
+: lzw-read ( lzw -- lzw n )
+    [ ] [ code-size>> ] [ input>> ] tri bs:read ;
+
+DEFER: lzw-uncompress-char
+: handle-clear-code ( lzw -- )
+    reset-lzw-uncompress
+    lzw-read dup end-of-information get = [
+        2drop
+    ] [
+        >>code
+        [ write-code ]
+        [ code>old-code ] bi
+        lzw-uncompress-char
+    ] if ;
+
+: handle-uncompress-code ( lzw -- lzw )
+    dup code-in-table? [
+        [ write-code ]
+        [
+            [
+                [ lookup-old-code ]
+                [ lookup-code first ] bi suffix
+            ] [ add-to-table ] bi
+        ] [ code>old-code ] tri
+    ] [
+        [
+            [ lookup-old-code dup first suffix ] keep
+            [ output>> push-all ] [ add-to-table ] 2bi
+        ] [ code>old-code ] bi
+    ] if ;
+    
+: lzw-uncompress-char ( lzw -- )
+    lzw-read [
+        >>code
+        dup code>> end-of-information get = [
+            drop
+        ] [
+            dup code>> clear-code get = [
+                handle-clear-code
+            ] [
+                handle-uncompress-code
+                lzw-uncompress-char
+            ] if
+        ] if
+    ] [
+        drop
+    ] if* ;
+
+: register-special-codes ( first-code-size -- )
+    [
+        1 - 2^ dup clear-code set
+        1 + end-of-information set
+    ] keep ;
+
+: lzw-uncompress ( code-size seq -- byte-array )
+    [ register-special-codes ] dip
+    bs:<lsb0-bit-reader>
+    <lzw-uncompress>
+    [ lzw-uncompress-char ] [ output>> ] bi ;

extra/images/gif/gif-tests.factor

@@ -1,14 +1,16 @@
 ! Copyright (C) 2009 Keith Lazuka.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images.gif io io.encodings.binary io.files
+USING: accessors bitstreams compression.lzw-gif images.gif io
-math namespaces sequences tools.test math.bitwise ;
+io.encodings.binary io.files kernel math math.bitwise
+math.parser namespaces prettyprint sequences tools.test ;
+QUALIFIED-WITH: bitstreams bs
 IN: images.gif.tests
 
 : path>gif ( path -- loading-gif )
     binary [ input-stream get load-gif ] with-file-reader ;
 
 : gif-example1 ( -- loading-gif )
-    "resource:extra/images/testing/symbol-word-16-colors.gif" path>gif ;
+    "resource:extra/images/testing/symbol-word.gif" path>gif ;
 
 : gif-example2 ( -- loading-gif )
     "resource:extra/images/testing/check-256-colors.gif" path>gif ;
@@ -16,6 +18,9 @@ IN: images.gif.tests
 : gif-example3 ( -- loading-gif )
     "resource:extra/images/testing/monochrome.gif" path>gif ;
 
+: gif-example4 ( -- loading-gif )
+    "resource:extra/images/testing/noise.gif" path>gif ;
+
 : declared-num-colors ( gif -- n ) flags>> 3 bits 1 + 2^ ;
 : actual-num-colors ( gif -- n ) global-color-table>> length 3 /i ;
 
@@ -27,3 +32,21 @@ IN: images.gif.tests
 
 [ 2 ] [ gif-example3 actual-num-colors ] unit-test
 [ 2 ] [ gif-example3 declared-num-colors ] unit-test
+
+: >index-stream ( gif -- seq )
+    [ image-descriptor>> first-code-size>> ]
+    [ compressed-bytes>> ] bi
+    lzw-uncompress ;
+
+[
+    BV{
+        0 0 0 0 0 0
+        1 0 0 0 0 1
+        1 1 0 0 1 1
+        1 1 1 1 1 1
+        1 0 1 1 0 1
+        1 0 0 0 0 1
+    }
+] [ gif-example3 >index-stream ] unit-test
+
+

extra/images/gif/gif.factor

@@ -1,11 +1,11 @@
 ! Copyrigt (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators constructors destructors
+USING: accessors arrays assocs combinators compression.lzw-gif
-images images.loader io io.binary io.buffers
+constructors destructors grouping images images.loader io
-io.encodings.binary io.encodings.string io.encodings.utf8
+io.binary io.buffers io.encodings.binary io.encodings.string
-io.files io.files.info io.ports io.streams.limited kernel make
+io.encodings.utf8 io.files io.files.info io.ports
-math math.bitwise math.functions multiline namespaces
+io.streams.limited kernel make math math.bitwise math.functions
-prettyprint sequences ;
+multiline namespaces prettyprint sequences ;
 IN: images.gif
 
 SINGLETON: gif-image
@@ -42,7 +42,7 @@ packed delay-time color-index
 block-terminator ;
 
 TUPLE: image-descriptor
-left top width height flags lzw-min-code-size ;
+left top width height flags first-code-size ;
 
 TUPLE: plain-text-extension
 introducer label block-size text-grid-left text-grid-top text-grid-width
@@ -97,7 +97,7 @@ M: input-port stream-peek1
         2 read le> >>width
         2 read le> >>height
         1 read le> >>flags
-        1 read le> >>lzw-min-code-size ;
+        1 read le> 1 + >>first-code-size ;
 
 : read-graphic-control-extension ( -- graphic-control-extension )
     \ graphics-control-extension new
@@ -152,7 +152,7 @@ ERROR: unimplemented message ;
 
 : read-global-color-table ( loading-gif -- loading-gif )
     dup color-table? [
-        dup color-table-size read >>global-color-table
+        dup color-table-size read 3 group >>global-color-table
     ] when ;
 
 : maybe-read-local-color-table ( loading-gif -- loading-gif )
@@ -220,8 +220,25 @@ ERROR: unhandled-data byte ;
         } case
     ] with-input-stream ;
 
+: decompress ( loading-gif -- indexes )
+    [ image-descriptor>> first-code-size>> ]
+    [ compressed-bytes>> ] bi
+    lzw-uncompress ;
+
+: apply-palette ( indexes palette -- bitmap )
+    [ nth 255 suffix ] curry V{ } map-as concat ;
+
+: dimensions ( loading-gif -- dim )
+    [ image-descriptor>> width>> ] [ image-descriptor>> height>> ] bi 2array ;
+
 : loading-gif>image ( loading-gif -- image )
-    ;
+    [ <image> ] dip
+    [ dimensions >>dim ]
+    [ drop RGBA >>component-order ubyte-components >>component-type ]
+    [
+        [ decompress ] [ global-color-table>> ] bi
+        apply-palette >>bitmap
+    ] tri ;
 
 ERROR: loading-gif-error gif-image ;