steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

cleaning up huffman and inflate code

db4
Doug Coleman 2009-10-06 20:22:53 -05:00
parent 8dff4776c6
commit 091d22a437
2 changed files with 68 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
basis/compression/huffman/huffman.factor
View File

@ -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

74
basis/compression/inflate/inflate.factor
View File

@ -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