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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry USING: accessors arrays assocs fry
hashtables io kernel locals math math.order math.parser hashtables io kernel locals math math.order math.parser
math.ranges multiline sequences ; math.ranges multiline sequences bitstreams bit-arrays ;
IN: compression.huffman IN: compression.huffman
QUALIFIED-WITH: bitstreams bs QUALIFIED-WITH: bitstreams bs
<PRIVATE <PRIVATE
! huffman codes
TUPLE: huffman-code TUPLE: huffman-code
{ value } { value fixnum }
{ size } { size fixnum }
{ code } ; { code fixnum } ;
: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ; : <huffman-code> ( -- huffman-code )
: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ; 0 0 0 huffman-code boa ; inline
: next-code ( code -- ) [ 1 + ] change-code drop ;
:: all-patterns ( huff n -- seq ) : next-size ( huffman-code -- )
n log2 huff size>> - :> free-bits [ 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 0 >
[ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ] [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
[ huff code>> free-bits neg 2^ /i 1array ] if ; [ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
:: huffman-each ( tdesc quot: ( huff -- ) -- ) :: huffman-each ( tdesc quot: ( huffman-code -- ) -- )
<huffman-code> :> code <huffman-code> :> code
tdesc tdesc
[ [
@ -34,7 +38,7 @@ TUPLE: huffman-code
[ code (>>value) code clone quot call code next-code ] each [ code (>>value) code clone quot call code next-code ] each
] each ; inline ] each ; inline
: update-reverse-table ( huff n table -- ) : update-reverse-table ( huffman-code n table -- )
[ drop all-patterns ] [ drop all-patterns ]
[ nip '[ _ swap _ set-at ] each ] 3bi ; [ nip '[ _ swap _ set-at ] each ] 3bi ;
@ -43,49 +47,29 @@ TUPLE: huffman-code
tdesc [ n table update-reverse-table ] huffman-each tdesc [ n table update-reverse-table ] huffman-each
table seq>> ; table seq>> ;
:: huffman-table ( tdesc max -- table )
max f <array> :> table
tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each
table ;
PRIVATE> PRIVATE>
! decoder
TUPLE: huffman-decoder TUPLE: huffman-decoder
{ bs } { bs bit-reader }
{ tdesc } { tdesc array }
{ rtable } { rtable array }
{ bits/level } ; { bits/level fixnum } ;
: <huffman-decoder> ( bs tdesc -- decoder ) : <huffman-decoder> ( bs tdesc -- huffman-decoder )
huffman-decoder new huffman-decoder new
swap >>tdesc swap >>tdesc
swap >>bs swap >>bs
16 >>bits/level 16 >>bits/level
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline
: read1-huff ( decoder -- elt ) : read1-huff ( huffman-decoder -- elt )
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
! %remove
: reverse-bits ( value bits -- value' ) : 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 ) : read1-huff2 ( huffman-decoder -- elt )
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
[ size>> swap bs>> bs:seek ] [ value>> ] bi ; [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
/*
: 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 ;
*/

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 4 data bs:read ! log2(max length)-8, 32K max
7 <= [ bad-zlib-header ] unless 7 <= [ bad-zlib-header ] unless
5 data bs:seek ! drop check bits 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 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 } 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 ) : get-table ( values size -- table )
16 f <array> clone <enum> 16 f <array> <enum>
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ; [ '[ _ push-at ] 2each ] keep
seq>> rest-slice [ natural-sort ] map ; inline
:: decode-huffman-tables ( bitstream -- tables ) :: decode-huffman-tables ( bitstream -- tables )
5 bitstream bs:read 257 + 5 bitstream bs:read 257 +
5 bitstream bs:read 1 + 5 bitstream bs:read 1 +
4 bitstream bs:read 4 + 4 bitstream bs:read 4 + clen-shuffle swap head
clen-shuffle swap head
dup [ drop 3 bitstream bs:read ] map dup length iota [ 3 bitstream bs:read ] replicate
get-table get-table
bitstream swap <huffman-decoder> bitstream swap <huffman-decoder>
[ 2dup + ] dip swap :> k! [ 2dup + ] dip swap :> k!
'[ '[
_ read1-huff2 _ read1-huff2 {
{
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] } { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] } { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 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 } cond
dup array? [ dup second ] [ 1 ] if dup array? [ dup second ] [ 1 ] if
k swap - dup k! 0 > k swap - dup k! 0 >
] ] [ ] produce swap suffix
[ ] produce swap suffix
{ } [ { } [
dup { [ array? ] [ first 16 = ] } 1&& [ dup { [ array? ] [ first 16 = ] } 1&& [
[ unclip-last ] [ unclip-last-slice ]
[ second 1 + swap <repetition> append ] bi* [ second 1 + swap <repetition> append ] bi*
] [ ] [
suffix suffix
] if ] if
] reduce ] reduce
[ [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
dup array? [ second 0 <repetition> ] [ 1array ] if nip swap cut 2array
] map concat [ [ length>> iota ] [ ] bi get-table ] map ;
nip swap cut 2array [
[ length>> [0,b) ] [ ] bi get-table
] map ;
MEMO: static-huffman-tables ( -- obj ) MEMO: static-huffman-tables ( -- obj )
[ [
@ -78,24 +74,15 @@ MEMO: static-huffman-tables ( -- obj )
CONSTANT: length-table CONSTANT: length-table
{ {
3 4 5 6 7 8 9 10 3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31
11 13 15 17 35 43 51 59 67 83 99 115 131 163 195 227 258
19 23 27 31
35 43 51 59
67 83 99 115
131 163 195 227 258
} }
CONSTANT: dist-table CONSTANT: dist-table
{ {
1 2 3 4 1 2 3 4 5 7 9 13 17 25 33 49
5 7 9 13 65 97 129 193 257 385 513 769 1025 1537 2049 3073
17 25 33 49 4097 6145 8193 12289 16385 24577
65 97 129 193
257 385 513 769
1025 1537 2049 3073
4097 6145 8193 12289
16385 24577
} }
: nth* ( n seq -- elt ) : nth* ( n seq -- elt )
@ -111,26 +98,26 @@ CONSTANT: dist-table
bytes ; bytes ;
:: inflate-huffman ( bitstream tables -- bytes ) :: inflate-huffman ( bitstream tables -- bytes )
tables bitstream '[ _ swap <huffman-decoder> ] map :> tables bitstream tables [ <huffman-decoder> ] with map :> tables
[ [
tables first read1-huff2 tables first read1-huff2
dup 256 > [ dup 256 > [
dup 285 = [ dup 285 = [
dup 264 > [ dup 264 > [
dup 261 - 4 /i dup 5 > dup 261 - 4 /i
[ bad-zlib-data ] when dup 5 > [ bad-zlib-data ] when
bitstream bs:read 2array bitstream bs:read 2array
] when ] when
] unless ] unless
! 5 bitstream read-bits ! distance
tables second read1-huff2 tables second read1-huff2
dup 3 > [ dup 3 > [
dup 2 - 2 /i dup 13 > dup 2 - 2 /i dup 13 >
[ bad-zlib-data ] when [ bad-zlib-data ] when
bitstream bs:read 2array bitstream bs:read 2array
] when 2array ] when 2array
] when ] when dup 256 = not
dup 256 = not
] [ ] produce nip ] [ ] produce nip
[ [
dup array? [ dup array? [
@ -148,19 +135,22 @@ CONSTANT: dist-table
8 bitstream bs:align 8 bitstream bs:align
16 bitstream bs:read :> len 16 bitstream bs:read :> len
16 bitstream bs:read :> nlen 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>>
bitstream byte-pos>> len + bitstream byte-pos>> len +
bitstream bytes>> <slice> bitstream bytes>> <slice>
len 8 * bitstream bs:seek ; len 8 * bitstream bs:seek ;
: inflate-dynamic ( bitstream -- bytes ) : inflate-dynamic ( bitstream -- array )
dup decode-huffman-tables inflate-huffman ; dup decode-huffman-tables inflate-huffman ;
: inflate-static ( bitstream -- bytes ) : inflate-static ( bitstream -- array )
static-huffman-tables inflate-huffman ; static-huffman-tables inflate-huffman ;
:: inflate-loop ( bitstream -- bytes ) :: inflate-loop ( bitstream -- array )
[ 1 bitstream bs:read 0 = ] [ [ 1 bitstream bs:read 0 = ] [
bitstream bitstream
2 bitstream bs:read 2 bitstream bs:read