1 ! Copyright (C) 2009, 2020 Marc Fauconneau, Abtin Molavi, Jacob Fischer.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs bitstreams byte-arrays
4 byte-vectors combinators combinators.short-circuit
5 combinators.smart compression.huffman endian kernel math
6 math.bitwise ranges sequences sorting ;
7 QUALIFIED-WITH: bitstreams bs
8 IN: compression.inflate
12 ERROR: bad-zlib-data ;
13 ERROR: bad-zlib-header ;
16 :: check-zlib-header ( data -- )
17 16 data bs:peek 2 >le be> 31 mod ! checksum
19 4 data bs:read 8 assert= ! compression method: deflate
20 4 data bs:read ! log2(max length)-8, 32K max
21 7 <= [ bad-zlib-header ] unless
22 5 data bs:seek ! drop check bits
23 1 data bs:read 0 assert= ! dictionary - not allowed in png
24 2 data bs:seek ! compression level; ignore
28 : read-until-terminated ( data -- data )
29 [ dup 8 swap bs:read 0 = ] [ ] until ;
31 :: interpret-flag ( flg data -- )
33 flg first 1 = [ 8 data bs:read data bs:seek ] when
34 flg second 1 = [ data read-until-terminated drop ] when
35 flg fourth 1 = [ data read-until-terminated drop ] when
36 flg second 1 = [ 1 data bs:read drop ] when ;
38 :: check-gzip-header ( data -- )
39 8 data bs:read 31 assert= ! ID 1
40 8 data bs:read 139 assert= ! ID 2
41 8 data bs:read 8 assert= ! compression method: deflate
42 1 data bs:seek ! ignore textbit
43 1 data bs:read 1 data bs:read 1 data bs:read 1 data bs:read 4array data interpret-flag
47 CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
49 : get-table ( values size -- table )
50 16 f <array> <enumerated>
51 [ '[ _ push-at ] 2each ] keep
52 seq>> rest-slice [ sort ] map ; inline
54 :: decode-huffman-tables ( bitstream -- tables )
55 5 bitstream bs:read 257 +
56 5 bitstream bs:read 1 +
57 4 bitstream bs:read 4 + clen-shuffle swap head
59 dup length [ 3 bitstream bs:read ] replicate
61 bitstream swap <huffman-decoder>
62 [ 2dup + ] dip swap :> k!
65 { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
66 { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
67 { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
70 dup array? [ dup second ] [ 1 ] if
72 ] [ ] produce swap suffix
74 dup { [ array? ] [ first 16 = ] } 1&& [
76 [ second 1 + swap <repetition> append ] bi*
81 [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
83 [ [ length>> <iota> ] [ ] bi get-table ] map ;
85 MEMO: static-huffman-tables ( -- obj )
87 0 143 [a..b] length 8 <array>
88 144 255 [a..b] length 9 <array>
89 256 279 [a..b] length 7 <array>
90 280 287 [a..b] length 8 <array>
92 0 31 [a..b] length 5 <array> 2array
93 [ [ length>> <iota> ] [ ] bi get-table ] map ;
95 CONSTANT: length-table
97 3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31
98 35 43 51 59 67 83 99 115 131 163 195 227 258
103 1 2 3 4 5 7 9 13 17 25 33 49
104 65 97 129 193 257 385 513 769 1025 1537 2049 3073
105 4097 6145 8193 12289 16385 24577
108 : nth* ( n seq -- elt )
109 [ length 1 - swap - ] [ nth ] bi ; inline
111 :: inflate-lz77 ( seq -- byte-array )
112 1000 <byte-vector> :> bytes
115 [ first2 '[ _ 1 - bytes nth* bytes push ] times ]
120 :: inflate-huffman ( bitstream tables -- bytes )
121 bitstream tables [ <huffman-decoder> ] with map :> tables
123 tables first read1-huff2
128 dup 5 > [ bad-zlib-data ] when
129 bitstream bs:read 2array
133 tables second read1-huff2
136 dup 2 - 2 /i dup 13 >
137 [ bad-zlib-data ] when
138 bitstream bs:read 2array
145 dup array? [ first2 ] [ 0 ] if
146 [ 257 - length-table nth ] [ + ] bi*
148 dup array? [ first2 ] [ 0 ] if
149 [ dist-table nth ] [ + ] bi*
154 :: inflate-raw ( bitstream -- bytes )
156 16 bitstream bs:read :> len
157 16 bitstream bs:read :> nlen
160 len nlen + 16 >signed -1 assert=
163 bitstream byte-pos>> len +
164 bitstream bytes>> <slice>
165 len 8 * bitstream bs:seek ;
167 : inflate-dynamic ( bitstream -- array )
168 dup decode-huffman-tables inflate-huffman ;
170 : inflate-static ( bitstream -- array )
171 static-huffman-tables inflate-huffman ;
173 :: inflate-loop ( bitstream -- array )
174 [ 1 bitstream bs:read 0 = ] [
178 { 0 [ inflate-raw ] }
179 { 1 [ inflate-static ] }
180 { 2 [ inflate-dynamic ] }
181 { 3 [ bad-zlib-data f ] }
183 ] [ produce ] keep call suffix concat ;
187 : zlib-inflate ( bytes -- bytes )
189 [ check-zlib-header ] [ inflate-loop ] bi
192 : gzip-inflate ( bytes -- bytes )
194 [ check-gzip-header ] [ inflate-loop ] bi