steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

implemented inflate-raw (uncompressed chunks)

db4
prunedtree 2009-06-05 03:29:12 -07:00
parent 9612b43034
commit f09a2807fa
1 changed files with 221 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

433
basis/compression/inflate/inflate.factor Executable file → Normal file
View File

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