- ! Copyright (C) 2009 Marc Fauconneau.\r
- ! See http://factorcode.org/license.txt for BSD license.\r
- USING: accessors arrays assocs byte-arrays\r
- byte-vectors combinators constructors fry grouping hashtables\r
- compression.huffman images io.binary kernel locals\r
- math math.bitwise math.order math.ranges multiline sequences\r
- sorting ;\r
- IN: compression.inflate\r
- \r
- QUALIFIED-WITH: bitstreams bs\r
- \r
- <PRIVATE\r
- \r
- : enum>seq ( assoc -- seq )\r
- dup keys [ ] [ max ] map-reduce 1 + f <array>\r
- [ '[ swap _ set-nth ] assoc-each ] keep ;\r
- \r
- ERROR: zlib-unimplemented ;\r
- ERROR: bad-zlib-data ;\r
- ERROR: bad-zlib-header ;\r
- \r
- :: check-zlib-header ( data -- )\r
- 16 data bs:peek 2 >le be> 31 mod ! checksum\r
- 0 assert= \r
- 4 data bs:read 8 assert= ! compression method: deflate\r
- 4 data bs:read ! log2(max length)-8, 32K max\r
- 7 <= [ bad-zlib-header ] unless \r
- 5 data bs:seek ! drop check bits \r
- 1 data bs:read 0 assert= ! dictionnary - not allowed in png\r
- 2 data bs:seek ! compression level; ignore\r
- ;\r
- \r
- :: default-table ( -- table )\r
- 0 <hashtable> :> table\r
- 0 143 [a,b] 280 287 [a,b] append 8 table set-at\r
- 144 255 [a,b] >array 9 table set-at\r
- 256 279 [a,b] >array 7 table set-at \r
- table enum>seq 1 tail ;\r
- \r
- CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }\r
- \r
- : get-table ( values size -- table ) \r
- 16 f <array> clone <enum> \r
- [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;\r
- \r
- :: decode-huffman-tables ( bitstream -- tables )\r
- 5 bitstream bs:read 257 +\r
- 5 bitstream bs:read 1 +\r
- 4 bitstream bs:read 4 +\r
- clen-shuffle swap head\r
- dup [ drop 3 bitstream bs:read ] map\r
- get-table\r
- bitstream swap <huffman-decoder> \r
- [ 2dup + ] dip swap :> k!\r
- '[\r
- _ read1-huff2\r
- {\r
- { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }\r
- { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }\r
- { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }\r
- [ ]\r
- } cond\r
- dup array? [ dup second ] [ 1 ] if\r
- k swap - dup k! 0 >\r
- ] \r
- [ ] produce swap suffix\r
- { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce\r
- [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat\r
- nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;\r
- \r
- CONSTANT: length-table\r
- {\r
- 3 4 5 6 7 8 9 10\r
- 11 13 15 17\r
- 19 23 27 31\r
- 35 43 51 59\r
- 67 83 99 115\r
- 131 163 195 227 258\r
- }\r
- \r
- CONSTANT: dist-table\r
- {\r
- 1 2 3 4 \r
- 5 7 9 13 \r
- 17 25 33 49\r
- 65 97 129 193\r
- 257 385 513 769\r
- 1025 1537 2049 3073\r
- 4097 6145 8193 12289\r
- 16385 24577\r
- }\r
- \r
- : nth* ( n seq -- elt )\r
- [ length 1- swap - ] [ nth ] bi ;\r
- \r
- :: inflate-lz77 ( seq -- bytes )\r
- 1000 <byte-vector> :> bytes\r
- seq\r
- [\r
- dup array?\r
- [ first2 '[ _ 1- bytes nth* bytes push ] times ]\r
- [ bytes push ] if\r
- ] each \r
- bytes ;\r
- \r
- :: inflate-dynamic ( bitstream -- bytes )\r
- bitstream decode-huffman-tables\r
- bitstream '[ _ swap <huffman-decoder> ] map :> tables\r
- [\r
- tables first read1-huff2\r
- dup 256 >\r
- [\r
- dup 285 = \r
- [ ]\r
- [ \r
- dup 264 > \r
- [ \r
- dup 261 - 4 /i dup 5 > \r
- [ bad-zlib-data ] when \r
- bitstream bs:read 2array \r
- ]\r
- when \r
- ] if\r
- ! 5 bitstream read-bits ! distance\r
- tables second read1-huff2\r
- dup 3 > \r
- [ \r
- dup 2 - 2 /i dup 13 >\r
- [ bad-zlib-data ] when\r
- bitstream bs:read 2array\r
- ] \r
- when\r
- 2array\r
- ]\r
- when\r
- dup 256 = not\r
- ]\r
- [ ] produce nip\r
- [\r
- dup array? [\r
- first2\r
- [ \r
- dup array? [ first2 ] [ 0 ] if\r
- [ 257 - length-table nth ] [ + ] bi*\r
- ] \r
- [\r
- dup array? [ first2 ] [ 0 ] if\r
- [ dist-table nth ] [ + ] bi*\r
- ] bi*\r
- 2array\r
- ] when\r
- ] map ;\r
- \r
- : inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;\r
- : inflate-static ( bitstream -- bytes ) zlib-unimplemented ;\r
- \r
- :: inflate-loop ( bitstream -- bytes )\r
- [ 1 bitstream bs:read 0 = ]\r
- [\r
- bitstream\r
- 2 bitstream bs:read\r
- { \r
- { 0 [ inflate-raw ] }\r
- { 1 [ inflate-static ] }\r
- { 2 [ inflate-dynamic ] }\r
- { 3 [ bad-zlib-data f ] }\r
- }\r
- case\r
- ]\r
- [ produce ] keep call suffix concat ;\r
- \r
- ! [ produce ] keep dip swap suffix\r
- \r
- :: paeth ( a b c -- p ) \r
- a b + c - { a b c } [ [ - abs ] keep 2array ] with map \r
- sort-keys first second ;\r
- \r
- :: png-unfilter-line ( prev curr filter -- curr' )\r
- prev :> c\r
- prev 3 tail-slice :> b\r
- curr :> a\r
- curr 3 tail-slice :> x\r
- x length [0,b)\r
- filter\r
- {\r
- { 0 [ drop ] }\r
- { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }\r
- { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }\r
- { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }\r
- { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }\r
- \r
- } case \r
- curr 3 tail ;\r
- \r
- PRIVATE>\r
- \r
- ! for debug -- shows residual values\r
- : reverse-png-filter' ( lines -- byte-array )\r
- [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip\r
- concat [ 128 + ] B{ } map-as ;\r
- \r
- : reverse-png-filter ( lines -- byte-array )\r
- dup first [ 0 ] replicate prefix\r
- [ { 0 0 } prepend ] map\r
- 2 clump [\r
- first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line\r
- ] map B{ } concat-as ;\r
- \r
- : zlib-inflate ( bytes -- bytes )\r
- bs:<lsb0-bit-reader>\r
- [ check-zlib-header ] [ inflate-loop ] bi\r
- inflate-lz77 ;\r
+ ! Copyright (C) 2009 Marc Fauconneau.
+ ! See http://factorcode.org/license.txt for BSD license.
+ USING: accessors arrays assocs byte-arrays
+ byte-vectors combinators constructors fry grouping hashtables
+ compression.huffman images io.binary kernel locals
+ math math.bitwise math.order math.ranges multiline sequences
+ sorting ;
+ IN: compression.inflate
+
+ QUALIFIED-WITH: bitstreams bs
+
+ <PRIVATE
+
+ : enum>seq ( assoc -- seq )
+ dup keys [ ] [ max ] map-reduce 1 + f <array>
+ [ '[ swap _ set-nth ] assoc-each ] keep ;
+
+ ERROR: zlib-unimplemented ;
+ ERROR: bad-zlib-data ;
+ ERROR: bad-zlib-header ;
+
+ :: check-zlib-header ( data -- )
+ 16 data bs:peek 2 >le be> 31 mod ! checksum
+ 0 assert=
+ 4 data bs:read 8 assert= ! compression method: deflate
+ 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
+ 2 data bs:seek ! compression level; ignore
+ ;
+
+ :: default-table ( -- table )
+ 0 <hashtable> :> table
+ 0 143 [a,b] 280 287 [a,b] append 8 table set-at
+ 144 255 [a,b] >array 9 table set-at
+ 256 279 [a,b] >array 7 table set-at
+ table enum>seq 1 tail ;
+
+ 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 ;
+
+ :: 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
+ get-table
+ bitstream swap <huffman-decoder>
+ [ 2dup + ] dip swap :> k!
+ '[
+ _ 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 ] }
+ [ ]
+ } cond
+ dup array? [ dup second ] [ 1 ] if
+ k swap - dup k! 0 >
+ ]
+ [ ] produce swap suffix
+ { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ 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 ;
+
+ 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
+ }
+
+ 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
+ }
+
+ : nth* ( n seq -- elt )
+ [ length 1- swap - ] [ nth ] bi ;
+
+ :: inflate-lz77 ( seq -- bytes )
+ 1000 <byte-vector> :> bytes
+ seq
+ [
+ dup array?
+ [ first2 '[ _ 1- bytes nth* bytes push ] times ]
+ [ bytes push ] if
+ ] each
+ bytes ;
+
+ :: inflate-dynamic ( bitstream -- bytes )
+ bitstream decode-huffman-tables
+ bitstream '[ _ swap <huffman-decoder> ] map :> tables
+ [
+ tables first read1-huff2
+ dup 256 >
+ [
+ dup 285 =
+ [ ]
+ [
+ dup 264 >
+ [
+ dup 261 - 4 /i dup 5 >
+ [ bad-zlib-data ] when
+ bitstream bs:read 2array
+ ]
+ when
+ ] if
+ ! 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
+ ]
+ [ ] produce nip
+ [
+ dup array? [
+ first2
+ [
+ dup array? [ first2 ] [ 0 ] if
+ [ 257 - length-table nth ] [ + ] bi*
+ ]
+ [
+ dup array? [ first2 ] [ 0 ] if
+ [ dist-table nth ] [ + ] bi*
+ ] bi*
+ 2array
+ ] when
+ ] map ;
+
+ :: inflate-raw ( bitstream -- bytes )
+ 8 bitstream bs:align
+ 16 bitstream bs:read :> len
+ 16 bitstream bs:read :> nlen
+ len nlen + 16 >signed -1 assert= ! len + ~len = -1
+ bitstream byte-pos>>
+ bitstream byte-pos>> len +
+ bitstream bytes>> <slice>
+ len 8 * bitstream bs:seek ;
+
+ : inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
+
+ :: inflate-loop ( bitstream -- bytes )
+ [ 1 bitstream bs:read 0 = ]
+ [
+ bitstream
+ 2 bitstream bs:read
+ {
+ { 0 [ inflate-raw ] }
+ { 1 [ inflate-static ] }
+ { 2 [ inflate-dynamic ] }
+ { 3 [ bad-zlib-data f ] }
+ }
+ case
+ ]
+ [ produce ] keep call suffix concat ;
+
+ ! [ produce ] keep dip swap suffix
+
+ :: paeth ( a b c -- p )
+ a b + c - { a b c } [ [ - abs ] keep 2array ] with map
+ sort-keys first second ;
+
+ :: png-unfilter-line ( prev curr filter -- curr' )
+ prev :> c
+ prev 3 tail-slice :> b
+ curr :> a
+ curr 3 tail-slice :> x
+ x length [0,b)
+ filter
+ {
+ { 0 [ drop ] }
+ { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
+ { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
+ { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
+ { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
+
+ } case
+ curr 3 tail ;
+
+ PRIVATE>
+
-! for debug -- shows residual values
-: reverse-png-filter' ( lines -- filtered )
++: reverse-png-filter' ( lines -- byte-array )
+ [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
- concat [ 128 + 256 wrap ] map ;
-
-: reverse-png-filter ( lines -- filtered )
++ concat [ 128 + ] B{ } map-as ;
++
++: reverse-png-filter ( lines -- byte-array )
+ dup first [ 0 ] replicate prefix
+ [ { 0 0 } prepend ] map
+ 2 clump [
+ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
- ] map concat ;
++ ] map B{ } concat-as ;
+
+ : zlib-inflate ( bytes -- bytes )
+ bs:<lsb0-bit-reader>
+ [ check-zlib-header ] [ inflate-loop ] bi
+ inflate-lz77 ;
projects / factor.git / commitdiff