From 091d22a4374b0d385ef41a9dc26879ebbc477356 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 6 Oct 2009 20:22:53 -0500
Subject: [PATCH] cleaning up huffman and inflate code
---
basis/compression/huffman/huffman.factor | 88 ++++++++++--------------
basis/compression/inflate/inflate.factor | 74 +++++++++-----------
2 files changed, 68 insertions(+), 94 deletions(-)
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
<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
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 <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