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