<PRIVATE
SYMBOL: lit-dict
-SYMBOL: dist-dict
+SYMBOL: dist-dict
SYMBOL: lit-vec
! LZ77 compression
:: create-pair ( ind seq -- array )
ind seq longest-prefix :> ( start end )
end ind - :> n
- n 3 <
+ n 3 <
[ ind seq nth ]
[ n ind start - 2array ]
if ;
: sum-vec ( vec -- n )
- [ dup array? [ first ] [ drop 1 ] if ] map-sum ;
+ [ dup array? [ first ] [ drop 1 ] if ] map-sum ;
:: compress-lz77 ( seq -- vec )
0 seq create-pair seq length <vector> ?push [ dup sum-vec seq length < ] [ dup sum-vec seq create-pair swap ?push ] while ;
{ [ dup 4097 < ] [ [ 2049 - 1024 /i 22 + ] [ 2049 - 1024 mod 10 <bits> >bit-array ] bi 2array ] }
{ [ dup 8193 < ] [ [ 4097 - 2048 /i 24 + ] [ 4097 - 2048 mod 11 <bits> >bit-array ] bi 2array ] }
{ [ dup 16385 < ] [ [ 8193 - 4096 /i 26 + ] [ 8193 - 4096 mod 12 <bits> >bit-array ] bi 2array ] }
- [ [ 8193 - 4096 /i 28 + ] [ 8193 - 4096 mod 13 <bits> >bit-array ] bi 2array ]
+ [ [ 8193 - 4096 /i 28 + ] [ 8193 - 4096 mod 13 <bits> >bit-array ] bi 2array ]
}
cond ;
-
+
! Words for transforming our vector of (length, distance) pairs and bytes into literals using above table
: pair-to-code ( pr -- code )
[ first length-to-code ] [ second dist-to-code ] bi 2array ;
: vec-to-lits ( vec -- vec )
- [ dup array? [ pair-to-code ] [ ] if ] map ;
+ [ dup array? [ pair-to-code ] [ ] if ] map ;
! Words for using the fixed Huffman code to map literals to bit arrays
! This is the table in section 3.2.6
-: (lit-to-bits) ( lit -- bitarr )
+: (lit-to-bits) ( lit -- bitarr )
{
{ [ dup 144 < ] [ 48 + 8 <bits> >bit-array reverse ] }
{ [ dup 256 < ] [ 144 - 400 + 9 <bits> >bit-array reverse ] }
: lit-to-bits ( lit -- bits )
dup array? [ [ first (lit-to-bits) ] [ second ] bi 2array ] [ (lit-to-bits) ] if ;
-
+
: pair-to-bits ( l,d -- bits )
[ first lit-to-bits ] [ second dist-to-bits ] bi 2array ;
[ dup array? [ pair-to-bits ] [ (lit-to-bits) ] if ] map ;
-! fixed huffman compression function
+! fixed huffman compression function
: (compress-fixed) ( bytes -- bits )
compress-lz77 vec-to-lits vec-to-bits ;
! Use the given dictionary to replace the element with its code
-:: replace-one ( ele code-dict -- new-ele )
+:: replace-one ( ele code-dict -- new-ele )
ele array? [ ele first code-dict at ele second 2array ] [ ele code-dict at ] if ;
! replace both elements of a length distance pair with their codes
-: replace-pair ( pair -- new-pair )
+: replace-pair ( pair -- new-pair )
[ first lit-dict get replace-one ] [ second dist-dict get replace-one ] bi 2array ;
-
+
! Replace all vector elements with their codes
: vec-to-codes ( vec -- new-vec )
[ dup array? [ replace-pair ] [ lit-dict get replace-one ] if ] map ;
: dist-code-lens ( -- len-seq )
31 [0..b] [ dist-dict get at length ] map [ zero? ] trim-tail ;
-:: replace-0-single ( m len-seq -- new-len-seq )
+:: replace-0-single ( m len-seq -- new-len-seq )
m 11 < [ len-seq m 0 <array> 17 m 3 - 3 <bits> >bit-array 2array 1array replace ]
- [ len-seq m 0 <array> 18 m 11 - 7 <bits> >bit-array 2array 1array replace ]
+ [ len-seq m 0 <array> 18 m 11 - 7 <bits> >bit-array 2array 1array replace ]
if ;
:: replace-0-range ( range len-seq -- new-len-seq )
2 139 (a..b) swap replace-0-range ;
:: replace-runs ( n len-seq -- new-len-seq )
- len-seq 7 n <array> { n { 16 ?{ t t } } } replace
- 6 n <array> { n { 16 ?{ f t } } } replace
- 5 n <array> { n { 16 ?{ t f } } } replace
+ len-seq 7 n <array> { n { 16 ?{ t t } } } replace
+ 6 n <array> { n { 16 ?{ f t } } } replace
+ 5 n <array> { n { 16 ?{ t f } } } replace
4 n <array> { n { 16 ?{ f f } } } replace ;
:: replace-all-runs ( range len-seq -- new-len-seq )
: run-free-dist ( -- len-seq )
0 31 [a..b] dist-code-lens replace-0 replace-all-runs ;
-
+
: run-free-codes ( -- len-seq )
run-free-lit run-free-dist append ;
: clen-bits ( -- bit-arr )
clen-seq [ 3 <bits> >bit-array ] map ;
-
+
: h-lit ( -- bit-arr )
lit-code-lens length 257 - 5 <bits> >bit-array ;
{ compressed-data vector } ;
! Compresses a block with dynamic huffman compression, outputting a nested array structure
-: (compress-dynamic) ( lit-seq -- bit-arr-seq )
- [ dup compress-lz77 vec-to-lits { 256 } append lit-vec set
- lit-vec get build-dicts
- dist-dict set
+: (compress-dynamic) ( lit-seq -- bit-arr-seq )
+ [ dup compress-lz77 vec-to-lits { 256 } append lit-vec set
+ lit-vec get build-dicts
+ dist-dict set
lit-dict set
- lit-code-lens supremum 16 < clen-seq supremum 8 < and
- [ drop dynamic-headers clen-bits compressed-lens
+ lit-code-lens supremum 16 < clen-seq supremum 8 < and
+ [ drop dynamic-headers clen-bits compressed-lens
lit-vec get vec-to-codes deflate-block boa ]
- [ halves [ (compress-dynamic) ] bi@ 2array ] if
+ [ halves [ (compress-dynamic) ] bi@ 2array ] if
] with-scope ;
-
+
: flatten-single ( ele -- bits )
dup array? [ concat ] when ;
: flatten-lens ( compressed-lens -- bits )
- [ flatten-single ] map concat ;
+ [ flatten-single ] map concat ;
-: flatten-pair ( pair -- bits )
- dup array? [ [ first flatten-single ] [ second flatten-single ] bi append ] when ;
+: flatten-pair ( pair -- bits )
+ dup array? [ [ first flatten-single ] [ second flatten-single ] bi append ] when ;
-: flatten-block ( bit-arr-seq -- byte-array )
+: flatten-block ( bit-arr-seq -- byte-array )
{ [ headers>> ] [ clen>> concat ] [ compressed-lens>> flatten-lens ] [ compressed-data>> [ flatten-pair ] map concat ] } cleave 4array concat ;
-: flatten-blocks ( blocks -- byte-array )
- [ flatten-block ] map unclip-last [ [ ?{ f } prepend ] map ] dip ?{ t } prepend suffix concat ;
+: flatten-blocks ( blocks -- byte-array )
+ [ flatten-block ] map unclip-last [ [ ?{ f } prepend ] map ] dip ?{ t } prepend suffix concat ;
PRIVATE>
-
+
: compress-dynamic ( byte-array -- byte-array )
(compress-dynamic) [ deflate-block? ] deep-filter flatten-blocks underlying>> gzip-header prepend B{ 0 0 } append ;
projects / factor.git / blobdiff