cleaning up huffman and inflate code
parent
8dff4776c6
commit
091d22a437
|
@ -2,31 +2,35 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs fry
|
||||
hashtables io kernel locals math math.order math.parser
|
||||
math.ranges multiline sequences ;
|
||||
math.ranges multiline sequences bitstreams bit-arrays ;
|
||||
IN: compression.huffman
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! huffman codes
|
||||
|
||||
TUPLE: huffman-code
|
||||
{ value }
|
||||
{ size }
|
||||
{ code } ;
|
||||
{ value fixnum }
|
||||
{ size fixnum }
|
||||
{ code fixnum } ;
|
||||
|
||||
: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;
|
||||
: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ;
|
||||
: next-code ( code -- ) [ 1 + ] change-code drop ;
|
||||
: <huffman-code> ( -- huffman-code )
|
||||
0 0 0 huffman-code boa ; inline
|
||||
|
||||
:: all-patterns ( huff n -- seq )
|
||||
n log2 huff size>> - :> free-bits
|
||||
: next-size ( huffman-code -- )
|
||||
[ 1 + ] change-size
|
||||
[ 2 * ] change-code drop ; inline
|
||||
|
||||
: next-code ( huffman-code -- )
|
||||
[ 1 + ] change-code drop ; inline
|
||||
|
||||
:: all-patterns ( huffman-code n -- seq )
|
||||
n log2 huffman-code size>> - :> free-bits
|
||||
free-bits 0 >
|
||||
[ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]
|
||||
[ huff code>> free-bits neg 2^ /i 1array ] if ;
|
||||
[ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
|
||||
[ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
|
||||
|
||||
:: huffman-each ( tdesc quot: ( huff -- ) -- )
|
||||
:: huffman-each ( tdesc quot: ( huffman-code -- ) -- )
|
||||
<huffman-code> :> code
|
||||
tdesc
|
||||
[
|
||||
|
@ -34,7 +38,7 @@ TUPLE: huffman-code
|
|||
[ code (>>value) code clone quot call code next-code ] each
|
||||
] each ; inline
|
||||
|
||||
: update-reverse-table ( huff n table -- )
|
||||
: update-reverse-table ( huffman-code n table -- )
|
||||
[ drop all-patterns ]
|
||||
[ nip '[ _ swap _ set-at ] each ] 3bi ;
|
||||
|
||||
|
@ -43,49 +47,29 @@ TUPLE: huffman-code
|
|||
tdesc [ n table update-reverse-table ] huffman-each
|
||||
table seq>> ;
|
||||
|
||||
:: huffman-table ( tdesc max -- table )
|
||||
max f <array> :> table
|
||||
tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each
|
||||
table ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! decoder
|
||||
|
||||
TUPLE: huffman-decoder
|
||||
{ bs }
|
||||
{ tdesc }
|
||||
{ rtable }
|
||||
{ bits/level } ;
|
||||
{ bs bit-reader }
|
||||
{ tdesc array }
|
||||
{ rtable array }
|
||||
{ bits/level fixnum } ;
|
||||
|
||||
: <huffman-decoder> ( bs tdesc -- decoder )
|
||||
: <huffman-decoder> ( bs tdesc -- huffman-decoder )
|
||||
huffman-decoder new
|
||||
swap >>tdesc
|
||||
swap >>bs
|
||||
16 >>bits/level
|
||||
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;
|
||||
swap >>tdesc
|
||||
swap >>bs
|
||||
16 >>bits/level
|
||||
dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline
|
||||
|
||||
: read1-huff ( decoder -- elt )
|
||||
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ;
|
||||
: read1-huff ( huffman-decoder -- elt )
|
||||
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
|
||||
|
||||
! %remove
|
||||
: reverse-bits ( value bits -- value' )
|
||||
[ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;
|
||||
[ integer>bit-array ] dip
|
||||
f pad-tail reverse bit-array>integer ; inline
|
||||
|
||||
: read1-huff2 ( decoder -- elt )
|
||||
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ;
|
||||
|
||||
/*
|
||||
: huff>string ( code -- str )
|
||||
[ value>> number>string ]
|
||||
[ [ code>> ] [ size>> bits>string ] bi ] bi
|
||||
" = " glue ;
|
||||
|
||||
: huff. ( code -- ) huff>string print ;
|
||||
|
||||
:: rtable. ( rtable -- )
|
||||
rtable length>> log2 :> n
|
||||
rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;
|
||||
*/
|
||||
: read1-huff2 ( huffman-decoder -- elt )
|
||||
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
|
||||
|
|
|
@ -20,28 +20,28 @@ ERROR: bad-zlib-header ;
|
|||
4 data bs:read ! log2(max length)-8, 32K max
|
||||
7 <= [ bad-zlib-header ] unless
|
||||
5 data bs:seek ! drop check bits
|
||||
1 data bs:read 0 assert= ! dictionnary - not allowed in png
|
||||
1 data bs:read 0 assert= ! dictionary - not allowed in png
|
||||
2 data bs:seek ! compression level; ignore
|
||||
;
|
||||
|
||||
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
||||
|
||||
: get-table ( values size -- table )
|
||||
16 f <array> clone <enum>
|
||||
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
|
||||
16 f <array> <enum>
|
||||
[ '[ _ push-at ] 2each ] keep
|
||||
seq>> rest-slice [ natural-sort ] map ; inline
|
||||
|
||||
:: decode-huffman-tables ( bitstream -- tables )
|
||||
5 bitstream bs:read 257 +
|
||||
5 bitstream bs:read 1 +
|
||||
4 bitstream bs:read 4 +
|
||||
clen-shuffle swap head
|
||||
dup [ drop 3 bitstream bs:read ] map
|
||||
4 bitstream bs:read 4 + clen-shuffle swap head
|
||||
|
||||
dup length iota [ 3 bitstream bs:read ] replicate
|
||||
get-table
|
||||
bitstream swap <huffman-decoder>
|
||||
[ 2dup + ] dip swap :> k!
|
||||
'[
|
||||
_ read1-huff2
|
||||
{
|
||||
_ read1-huff2 {
|
||||
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
|
||||
|
@ -49,22 +49,18 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
|||
} cond
|
||||
dup array? [ dup second ] [ 1 ] if
|
||||
k swap - dup k! 0 >
|
||||
]
|
||||
[ ] produce swap suffix
|
||||
] [ ] produce swap suffix
|
||||
{ } [
|
||||
dup { [ array? ] [ first 16 = ] } 1&& [
|
||||
[ unclip-last ]
|
||||
[ unclip-last-slice ]
|
||||
[ second 1 + swap <repetition> append ] bi*
|
||||
] [
|
||||
suffix
|
||||
] if
|
||||
] reduce
|
||||
[
|
||||
dup array? [ second 0 <repetition> ] [ 1array ] if
|
||||
] map concat
|
||||
nip swap cut 2array [
|
||||
[ length>> [0,b) ] [ ] bi get-table
|
||||
] map ;
|
||||
] reduce
|
||||
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
|
||||
nip swap cut 2array
|
||||
[ [ length>> iota ] [ ] bi get-table ] map ;
|
||||
|
||||
MEMO: static-huffman-tables ( -- obj )
|
||||
[
|
||||
|
@ -78,24 +74,15 @@ MEMO: static-huffman-tables ( -- obj )
|
|||
|
||||
CONSTANT: length-table
|
||||
{
|
||||
3 4 5 6 7 8 9 10
|
||||
11 13 15 17
|
||||
19 23 27 31
|
||||
35 43 51 59
|
||||
67 83 99 115
|
||||
131 163 195 227 258
|
||||
3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31
|
||||
35 43 51 59 67 83 99 115 131 163 195 227 258
|
||||
}
|
||||
|
||||
CONSTANT: dist-table
|
||||
{
|
||||
1 2 3 4
|
||||
5 7 9 13
|
||||
17 25 33 49
|
||||
65 97 129 193
|
||||
257 385 513 769
|
||||
1025 1537 2049 3073
|
||||
4097 6145 8193 12289
|
||||
16385 24577
|
||||
1 2 3 4 5 7 9 13 17 25 33 49
|
||||
65 97 129 193 257 385 513 769 1025 1537 2049 3073
|
||||
4097 6145 8193 12289 16385 24577
|
||||
}
|
||||
|
||||
: nth* ( n seq -- elt )
|
||||
|
@ -111,26 +98,26 @@ CONSTANT: dist-table
|
|||
bytes ;
|
||||
|
||||
:: inflate-huffman ( bitstream tables -- bytes )
|
||||
tables bitstream '[ _ swap <huffman-decoder> ] map :> tables
|
||||
bitstream tables [ <huffman-decoder> ] with map :> tables
|
||||
[
|
||||
tables first read1-huff2
|
||||
dup 256 > [
|
||||
dup 285 = [
|
||||
dup 264 > [
|
||||
dup 261 - 4 /i dup 5 >
|
||||
[ bad-zlib-data ] when
|
||||
dup 261 - 4 /i
|
||||
dup 5 > [ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
] when
|
||||
] unless
|
||||
! 5 bitstream read-bits ! distance
|
||||
|
||||
tables second read1-huff2
|
||||
|
||||
dup 3 > [
|
||||
dup 2 - 2 /i dup 13 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
] when 2array
|
||||
] when
|
||||
dup 256 = not
|
||||
] when dup 256 = not
|
||||
] [ ] produce nip
|
||||
[
|
||||
dup array? [
|
||||
|
@ -148,19 +135,22 @@ CONSTANT: dist-table
|
|||
8 bitstream bs:align
|
||||
16 bitstream bs:read :> len
|
||||
16 bitstream bs:read :> nlen
|
||||
len nlen + 16 >signed -1 assert= ! len + ~len = -1
|
||||
|
||||
! len + ~len = -1
|
||||
len nlen + 16 >signed -1 assert=
|
||||
|
||||
bitstream byte-pos>>
|
||||
bitstream byte-pos>> len +
|
||||
bitstream bytes>> <slice>
|
||||
len 8 * bitstream bs:seek ;
|
||||
|
||||
: inflate-dynamic ( bitstream -- bytes )
|
||||
: inflate-dynamic ( bitstream -- array )
|
||||
dup decode-huffman-tables inflate-huffman ;
|
||||
|
||||
: inflate-static ( bitstream -- bytes )
|
||||
: inflate-static ( bitstream -- array )
|
||||
static-huffman-tables inflate-huffman ;
|
||||
|
||||
:: inflate-loop ( bitstream -- bytes )
|
||||
:: inflate-loop ( bitstream -- array )
|
||||
[ 1 bitstream bs:read 0 = ] [
|
||||
bitstream
|
||||
2 bitstream bs:read
|
||||
|
|
Loading…
Reference in New Issue