1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators io kernel math namespaces
4 prettyprint sequences vectors ;
5 QUALIFIED-WITH: bitstreams bs
17 end-of-information-code ;
19 TUPLE: tiff-lzw < lzw ;
20 TUPLE: gif-lzw < lzw ;
22 : initial-uncompress-table ( size -- seq )
23 iota [ 1vector ] V{ } map-as ;
25 : reset-lzw-uncompress ( lzw -- lzw )
26 dup end-of-information-code>> 1 + initial-uncompress-table >>table
27 dup initial-code-size>> >>code-size ;
29 : <lzw-uncompress> ( input code-size class -- obj )
32 dup code-size>> >>initial-code-size
33 dup code-size>> 1 - 2^ >>clear-code
34 dup clear-code>> 1 + >>end-of-information-code
37 reset-lzw-uncompress ;
39 ERROR: not-in-table value ;
41 : lookup-old-code ( lzw -- vector )
42 [ old-code>> ] [ table>> ] bi nth ;
44 : lookup-code ( lzw -- vector )
45 [ code>> ] [ table>> ] bi nth ;
47 : code-in-table? ( lzw -- ? )
48 [ code>> ] [ table>> length ] bi < ;
50 : code>old-code ( lzw -- lzw )
51 dup code>> >>old-code ;
53 : write-code ( lzw -- )
54 [ lookup-code ] [ output>> ] bi push-all ;
56 GENERIC: code-space-full? ( lzw -- ? )
58 : size-and-limit ( lzw -- m n ) [ table>> length ] [ code-size>> 2^ ] bi ;
60 M: tiff-lzw code-space-full? size-and-limit 1 - = ;
61 M: gif-lzw code-space-full? size-and-limit = ;
63 : maybe-increment-code-size ( lzw -- lzw )
64 dup code-space-full? [ [ 1 + ] change-code-size ] when ;
66 : add-to-table ( seq lzw -- )
68 [ maybe-increment-code-size 2drop ] 2bi ;
70 : lzw-read ( lzw -- lzw n )
71 [ ] [ code-size>> ] [ input>> ] tri bs:read ;
73 : end-of-information? ( lzw code -- ? ) swap end-of-information-code>> = ;
74 : clear-code? ( lzw code -- ? ) swap clear-code>> = ;
76 DEFER: handle-clear-code
77 : lzw-process-next-code ( lzw quot: ( lzw code -- ) -- )
79 { [ 3dup drop end-of-information? ] [ 3drop ] }
80 { [ 3dup drop clear-code? ] [ 2drop handle-clear-code ] }
81 [ call( lzw code -- ) ]
84 DEFER: lzw-uncompress-char
85 : handle-clear-code ( lzw -- )
92 ] lzw-process-next-code ;
94 : handle-uncompress-code ( lzw -- lzw )
100 [ lookup-code first ] bi suffix
101 ] [ add-to-table ] bi
102 ] [ code>old-code ] tri
105 [ lookup-old-code dup first suffix ] keep
106 [ output>> push-all ] [ add-to-table ] 2bi
107 ] [ code>old-code ] bi
110 : lzw-uncompress-char ( lzw -- )
111 [ >>code handle-uncompress-code lzw-uncompress-char ]
112 lzw-process-next-code ;
114 : lzw-uncompress ( bitstream code-size class -- byte-array )
116 [ lzw-uncompress-char ] [ output>> ] bi ;
118 : tiff-lzw-uncompress ( seq -- byte-array )
119 bs:<msb0-bit-reader> 9 tiff-lzw lzw-uncompress ;
121 : gif-lzw-uncompress ( seq code-size -- byte-array )
122 [ bs:<lsb0-bit-reader> ] dip gif-lzw lzw-uncompress ;