! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io kernel math namespaces
+USING: accessors combinators kernel math math.order
sequences vectors ;
QUALIFIED-WITH: bitstreams bs
IN: compression.lzw
TUPLE: gif-lzw < lzw ;
: initial-uncompress-table ( size -- seq )
- iota [ 1vector ] V{ } map-as ;
+ <iota> [ 1vector ] V{ } map-as ;
: reset-lzw-uncompress ( lzw -- lzw )
dup end-of-information-code>> 1 + initial-uncompress-table >>table
BV{ } clone >>output
reset-lzw-uncompress ;
-ERROR: not-in-table value ;
-
: lookup-old-code ( lzw -- vector )
[ old-code>> ] [ table>> ] bi nth ;
M: tiff-lzw code-space-full? size-and-limit 1 - = ;
M: gif-lzw code-space-full? size-and-limit = ;
+GENERIC: increment-code-size ( lzw -- lzw )
+
+M: lzw increment-code-size [ 1 + ] change-code-size ;
+M: gif-lzw increment-code-size [ 1 + 12 min ] change-code-size ;
+
: maybe-increment-code-size ( lzw -- lzw )
- dup code-space-full? [ [ 1 + ] change-code-size ] when ;
+ dup code-space-full? [ increment-code-size ] when ;
: add-to-table ( seq lzw -- )
[ table>> push ]
DEFER: handle-clear-code
: lzw-process-next-code ( lzw quot: ( lzw code -- ) -- )
[ lzw-read ] dip {
- { [ 3dup drop end-of-information? ] [ 3drop ] }
- { [ 3dup drop clear-code? ] [ 2drop handle-clear-code ] }
+ { [ 2over end-of-information? ] [ 3drop ] }
+ { [ 2over clear-code? ] [ 2drop handle-clear-code ] }
[ call( lzw code -- ) ]
} cond ; inline
[ output>> push-all ] [ add-to-table ] 2bi
] [ code>old-code ] bi
] if ;
-
+
: lzw-uncompress-char ( lzw -- )
[ >>code handle-uncompress-code lzw-uncompress-char ]
lzw-process-next-code ;