diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 2df4dce916..9922048009 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -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 ( -- 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 ) + 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 -- ) -- ) :> 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 :> 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 } ; -: ( bs tdesc -- 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 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 [ 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 diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 0e3bb105a7..ab27c70ac0 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -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 clone - [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ; + 16 f + [ '[ _ 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 [ 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 append ] bi* ] [ suffix ] if - ] reduce - [ - dup array? [ second 0 ] [ 1array ] if - ] map concat - nip swap cut 2array [ - [ length>> [0,b) ] [ ] bi get-table - ] map ; + ] reduce + [ dup array? [ second 0 ] [ 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 ] map :> tables + bitstream tables [ ] 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>> 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