1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.accessors assocs byte-arrays combinators
4 io.encodings.binary io.streams.byte-array kernel math sequences
8 QUALIFIED-WITH: bitstreams bs
10 CONSTANT: clear-code 256
11 CONSTANT: end-of-information 257
13 TUPLE: lzw input output table code old-code ;
17 : lzw-bit-width ( n -- n' )
19 { [ dup 510 <= ] [ drop 9 ] }
20 { [ dup 1022 <= ] [ drop 10 ] }
21 { [ dup 2046 <= ] [ drop 11 ] }
22 { [ dup 4094 <= ] [ drop 12 ] }
26 : lzw-bit-width-uncompress ( lzw -- n )
27 table>> length lzw-bit-width ;
29 : initial-uncompress-table ( -- seq )
30 258 iota [ 1vector ] V{ } map-as ;
32 : reset-lzw-uncompress ( lzw -- lzw )
33 initial-uncompress-table >>table ;
35 : <lzw-uncompress> ( input -- obj )
39 reset-lzw-uncompress ;
41 ERROR: not-in-table value ;
43 : lookup-old-code ( lzw -- vector )
44 [ old-code>> ] [ table>> ] bi nth ;
46 : lookup-code ( lzw -- vector )
47 [ code>> ] [ table>> ] bi nth ;
49 : code-in-table? ( lzw -- ? )
50 [ code>> ] [ table>> length ] bi < ;
52 : code>old-code ( lzw -- lzw )
53 dup code>> >>old-code ;
55 : write-code ( lzw -- )
56 [ lookup-code ] [ output>> ] bi push-all ;
58 : add-to-table ( seq lzw -- ) table>> push ;
60 : lzw-read ( lzw -- lzw n )
61 [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
63 DEFER: lzw-uncompress-char
64 : handle-clear-code ( lzw -- )
66 lzw-read dup end-of-information = [
75 : handle-uncompress-code ( lzw -- lzw )
81 [ lookup-code first ] bi suffix
83 ] [ code>old-code ] tri
86 [ lookup-old-code dup first suffix ] keep
87 [ output>> push-all ] [ add-to-table ] 2bi
88 ] [ code>old-code ] bi
91 : lzw-uncompress-char ( lzw -- )
94 dup code>> end-of-information = [
97 dup code>> clear-code = [
100 handle-uncompress-code
108 : lzw-uncompress ( seq -- byte-array )
111 [ lzw-uncompress-char ] [ output>> ] bi ;