1 ! Copyright (C) 2009 Marc Fauconneau.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: accessors arrays assocs fry
\r
4 hashtables io kernel locals math math.order math.parser
\r
5 math.ranges multiline sequences bitstreams bit-arrays ;
\r
6 IN: compression.huffman
\r
8 QUALIFIED-WITH: bitstreams bs
\r
17 : <huffman-code> ( -- huffman-code )
\r
18 0 0 0 huffman-code boa ; inline
\r
20 : next-size ( huffman-code -- )
\r
22 [ 2 * ] change-code drop ; inline
\r
24 : next-code ( huffman-code -- )
\r
25 [ 1 + ] change-code drop ; inline
\r
27 :: all-patterns ( huffman-code n -- seq )
\r
28 n log2 huffman-code size>> - :> free-bits
\r
30 [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
\r
31 [ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
\r
33 :: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )
\r
34 <huffman-code> :> code
\r
38 [ code (>>value) code clone quot call code next-code ] each
\r
41 : update-reverse-table ( huffman-code n table -- )
\r
42 [ drop all-patterns ]
\r
43 [ nip '[ _ swap _ set-at ] each ] 3bi ;
\r
45 :: reverse-table ( tdesc n -- rtable )
\r
46 n f <array> <enum> :> table
\r
47 tdesc [ n table update-reverse-table ] huffman-each
\r
52 TUPLE: huffman-decoder
\r
56 { bits/level fixnum } ;
\r
58 : <huffman-decoder> ( bs tdesc -- huffman-decoder )
\r
63 dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline
\r
65 : read1-huff ( huffman-decoder -- elt )
\r
66 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
\r
67 [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
\r
69 : reverse-bits ( value bits -- value' )
\r
70 [ integer>bit-array ] dip
\r
71 f pad-tail reverse bit-array>integer ; inline
\r
73 : read1-huff2 ( huffman-decoder -- elt )
\r
74 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
\r
75 [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
\r