remove all the compress code from lzw until it works, fix bitstreams
Doug Coleman
parent
c443d6d815
commit
af2f62ae62
|
|
@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
|
|||
io.streams.byte-array ;
|
||||
IN: bitstreams.tests
|
||||
|
||||
[ 1 t ]
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
|
||||
|
||||
[ 254 8 t ]
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 4095 12 t ]
|
||||
[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
|
||||
|
||||
[ B{ 254 } ]
|
||||
[ BIN: 1111111111 ]
|
||||
[
|
||||
binary <byte-writer> <bitstream-writer> 254 8 rot
|
||||
[ write-bits ] keep stream>> >byte-array
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
10 swap peek
|
||||
] unit-test
|
||||
|
||||
[ 255 8 t ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
[ BIN: 111111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
9 swap peek
|
||||
] unit-test
|
||||
|
||||
[ 255 8 f ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
|
||||
[ BIN: 11111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
8 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 1111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
7 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
6 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 11111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
5 swap peek
|
||||
] unit-test
|
||||
|
||||
[ B{ } <msb0-bit-reader> 5 swap peek ] must-fail
|
||||
[ B{ } <msb0-bit-reader> 1 swap peek ] must-fail
|
||||
[ B{ } <msb0-bit-reader> 8 swap peek ] must-fail
|
||||
|
||||
[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test
|
||||
|
|
|
|||
|
|
@ -41,14 +41,17 @@ CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
|
|||
|
||||
TUPLE: msb0-bit-writer < bit-writer ;
|
||||
TUPLE: lsb0-bit-writer < bit-writer ;
|
||||
CONSTRUCTOR: msb0-bit-writer ( -- bs )
|
||||
BV{ } clone >>bytes
|
||||
0 0 <widthed> >>widthed ;
|
||||
CONSTRUCTOR: lsb0-bit-writer ( -- bs )
|
||||
BV{ } clone >>bytes
|
||||
0 0 <widthed> >>widthed ;
|
||||
|
||||
! interface
|
||||
: new-bit-writer ( class -- bs )
|
||||
new
|
||||
BV{ } clone >>bytes
|
||||
0 0 <widthed> >>widthed ; inline
|
||||
|
||||
: <msb0-bit-writer> ( -- bs )
|
||||
msb0-bit-writer new-bit-writer ;
|
||||
|
||||
: <lsb0-bit-writer> ( -- bs )
|
||||
lsb0-bit-writer new-bit-writer ;
|
||||
|
||||
GENERIC: peek ( n bitstream -- value )
|
||||
GENERIC: poke ( value n bitstream -- )
|
||||
|
|
@ -64,50 +67,6 @@ GENERIC: poke ( value n bitstream -- )
|
|||
: read ( n bitstream -- value )
|
||||
[ peek ] [ seek ] 2bi ; inline
|
||||
|
||||
|
||||
! reading
|
||||
|
||||
<PRIVATE
|
||||
|
||||
MACRO: multi-alien-unsigned-1 ( seq -- quot )
|
||||
[ '[ _ + alien-unsigned-1 ] ] map 2cleave>quot ;
|
||||
|
||||
GENERIC: fetch3-le-unsafe ( n byte-array -- value )
|
||||
GENERIC: fetch3-be-unsafe ( n byte-array -- value )
|
||||
|
||||
: fetch3-unsafe ( byte-array n offsets -- value )
|
||||
multi-alien-unsigned-1 8 2^ * + 8 2^ * + ; inline
|
||||
|
||||
M: byte-array fetch3-le-unsafe ( n byte-array -- value )
|
||||
swap { 0 1 2 } fetch3-unsafe ; inline
|
||||
M: byte-array fetch3-be-unsafe ( n byte-array -- value )
|
||||
swap { 2 1 0 } fetch3-unsafe ; inline
|
||||
|
||||
: fetch3 ( n byte-array -- value )
|
||||
[ 3 [0,b) [ + ] with map ] dip [ nth ] curry map ;
|
||||
|
||||
: fetch3-le ( n byte-array -- value ) fetch3 le> ;
|
||||
: fetch3-be ( n byte-array -- value ) fetch3 be> ;
|
||||
|
||||
GENERIC: peek16 ( n bitstream -- value )
|
||||
|
||||
M:: lsb0-bit-reader peek16 ( n bs -- v )
|
||||
bs byte-pos>> bs bytes>> fetch3-le
|
||||
bs bit-pos>> 2^ /i
|
||||
n 2^ mod ;
|
||||
|
||||
M:: msb0-bit-reader peek16 ( n bs -- v )
|
||||
bs byte-pos>> bs bytes>> fetch3-be
|
||||
24 n bs bit-pos>> + - 2^ /i
|
||||
n 2^ mod ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: lsb0-bit-reader peek ( n bs -- v ) peek16 ;
|
||||
M: msb0-bit-reader peek ( n bs -- v ) peek16 ;
|
||||
|
||||
! writing
|
||||
|
||||
<PRIVATE
|
||||
|
||||
ERROR: not-enough-bits widthed n ;
|
||||
|
|
@ -130,18 +89,69 @@ ERROR: not-enough-bits widthed n ;
|
|||
[ 8 split-widthed dup zero-widthed? not ]
|
||||
[ swap bits>> ] B{ } produce-as nip swap ;
|
||||
|
||||
:: |widthed ( widthed1 widthed2 -- widthed3 )
|
||||
widthed1 bits>> :> bits1
|
||||
widthed1 #bits>> :> #bits1
|
||||
widthed2 bits>> :> bits2
|
||||
widthed2 #bits>> :> #bits2
|
||||
bits1 #bits2 shift bits2 bitor
|
||||
#bits1 #bits2 + <widthed> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M:: lsb0-bit-writer poke ( value n bs -- )
|
||||
value n <widthed> :> widthed
|
||||
widthed
|
||||
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
|
||||
|
||||
byte #bits>> 8 = [
|
||||
byte bits>> bs bytes>> push
|
||||
byte bs widthed>> |widthed :> new-byte
|
||||
new-byte #bits>> dup 8 > [ "oops" throw ] when 8 = [
|
||||
new-byte bits>> bs bytes>> push
|
||||
zero-widthed bs (>>widthed)
|
||||
remainder widthed>bytes
|
||||
[ bs bytes>> push-all ] [ B bs (>>widthed) ] bi*
|
||||
[ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
|
||||
] [
|
||||
byte bs (>>widthed)
|
||||
] if ;
|
||||
|
||||
: enough-bits? ( n bs -- ? )
|
||||
[ bytes>> length ]
|
||||
[ byte-pos>> - 8 * ]
|
||||
[ bit-pos>> - ] tri <= ;
|
||||
|
||||
ERROR: not-enough-bits n bit-reader ;
|
||||
|
||||
: #bits>#bytes ( #bits -- #bytes )
|
||||
8 /mod 0 = [ 1 + ] unless ; inline
|
||||
|
||||
:: subseq>bits ( bignum n bs -- bits )
|
||||
bignum
|
||||
8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
|
||||
neg shift n bits ;
|
||||
|
||||
:: adjust-bits ( n bs -- )
|
||||
n 8 /mod :> #bits :> #bytes
|
||||
bs [ #bytes + ] change-byte-pos
|
||||
bit-pos>> #bits + dup 8 >= [
|
||||
8 - bs (>>bit-pos)
|
||||
bs [ 1 + ] change-byte-pos drop
|
||||
] [
|
||||
bs (>>bit-pos)
|
||||
] if ;
|
||||
|
||||
:: (peek) ( n bs word -- bits )
|
||||
n bs enough-bits? [ n bs not-enough-bits ] unless
|
||||
bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
|
||||
bs bytes>> subseq word execute( seq -- x ) :> bignum
|
||||
bignum n bs subseq>bits ;
|
||||
|
||||
M: lsb0-bit-reader peek ( n bs -- bits ) \ le> (peek) ;
|
||||
|
||||
M: msb0-bit-reader peek ( n bs -- bits ) \ be> (peek) ;
|
||||
|
||||
:: bit-writer-bytes ( writer -- bytes )
|
||||
writer widthed>> #bits>> :> n
|
||||
n 0 = [
|
||||
writer widthed>> bits>> 8 n - shift
|
||||
writer bytes>> swap push
|
||||
] unless
|
||||
writer bytes>> ;
|
||||
|
|
|
|||
|
|
@ -1,22 +1,19 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.accessors byte-arrays combinators
|
||||
constructors destructors fry io io.binary kernel locals macros
|
||||
math math.ranges multiline sequences sequences.private ;
|
||||
IN: bitstreams
|
||||
USING: accessors alien.accessors assocs byte-arrays combinators
|
||||
io.encodings.binary io.streams.byte-array kernel math sequences
|
||||
vectors ;
|
||||
IN: compression.lzw
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
CONSTANT: clear-code 256
|
||||
CONSTANT: end-of-information 257
|
||||
|
||||
TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
|
||||
code old-code ;
|
||||
TUPLE: lzw input output table code old-code ;
|
||||
|
||||
SYMBOL: table-full
|
||||
|
||||
ERROR: index-too-big n ;
|
||||
|
||||
: lzw-bit-width ( n -- n' )
|
||||
{
|
||||
{ [ dup 510 <= ] [ drop 9 ] }
|
||||
|
|
@ -26,37 +23,14 @@ ERROR: index-too-big n ;
|
|||
[ drop table-full ]
|
||||
} cond ;
|
||||
|
||||
: lzw-bit-width-compress ( lzw -- n )
|
||||
count>> lzw-bit-width ;
|
||||
|
||||
: lzw-bit-width-uncompress ( lzw -- n )
|
||||
table>> length lzw-bit-width ;
|
||||
|
||||
: initial-compress-table ( -- assoc )
|
||||
258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
|
||||
|
||||
: initial-uncompress-table ( -- seq )
|
||||
258 iota [ 1vector ] V{ } map-as ;
|
||||
|
||||
: reset-lzw ( lzw -- lzw )
|
||||
257 >>count
|
||||
V{ } clone >>omega
|
||||
V{ } clone >>omega-k
|
||||
9 >>#bits ;
|
||||
|
||||
: reset-lzw-compress ( lzw -- lzw )
|
||||
f >>k
|
||||
initial-compress-table >>table reset-lzw ;
|
||||
|
||||
: reset-lzw-uncompress ( lzw -- lzw )
|
||||
initial-uncompress-table >>table reset-lzw ;
|
||||
|
||||
: <lzw-compress> ( input -- obj )
|
||||
lzw new
|
||||
swap >>input
|
||||
! binary <byte-writer> <bitstream-writer> >>output
|
||||
V{ } clone >>output ! TODO
|
||||
reset-lzw-compress ;
|
||||
initial-uncompress-table >>table ;
|
||||
|
||||
: <lzw-uncompress> ( input -- obj )
|
||||
lzw new
|
||||
|
|
@ -64,79 +38,8 @@ ERROR: index-too-big n ;
|
|||
BV{ } clone >>output
|
||||
reset-lzw-uncompress ;
|
||||
|
||||
: push-k ( lzw -- lzw )
|
||||
[ ]
|
||||
[ k>> ]
|
||||
[ omega>> clone [ push ] keep ] tri >>omega-k ;
|
||||
|
||||
: omega-k-in-table? ( lzw -- ? )
|
||||
[ omega-k>> ] [ table>> ] bi key? ;
|
||||
|
||||
ERROR: not-in-table value ;
|
||||
|
||||
: write-output ( lzw -- )
|
||||
[
|
||||
[ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless
|
||||
] [
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> bs:poke ] bi
|
||||
] bi ;
|
||||
|
||||
: omega-k>omega ( lzw -- lzw )
|
||||
dup omega-k>> clone >>omega ;
|
||||
|
||||
: k>omega ( lzw -- lzw )
|
||||
dup k>> 1vector >>omega ;
|
||||
|
||||
: add-omega-k ( lzw -- )
|
||||
[ [ 1+ ] change-count count>> ]
|
||||
[ omega-k>> clone ]
|
||||
[ table>> ] tri set-at ;
|
||||
|
||||
: lzw-compress-char ( lzw k -- )
|
||||
>>k push-k dup omega-k-in-table? [
|
||||
omega-k>omega drop
|
||||
] [
|
||||
[ write-output ]
|
||||
[ add-omega-k ]
|
||||
[ k>omega drop ] tri
|
||||
] if ;
|
||||
|
||||
: (lzw-compress-chars) ( lzw -- )
|
||||
dup lzw-bit-width-compress table-full = [
|
||||
drop
|
||||
] [
|
||||
dup input>> stream-read1
|
||||
[ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
|
||||
[ t >>end-of-input? drop ] if*
|
||||
] if ;
|
||||
|
||||
: lzw-compress-chars ( lzw -- )
|
||||
{
|
||||
! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
|
||||
[
|
||||
[ clear-code ] dip
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> bs:poke ] bi
|
||||
]
|
||||
[ (lzw-compress-chars) ]
|
||||
[
|
||||
[ k>> ]
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> bs:poke ] tri
|
||||
]
|
||||
[
|
||||
[ end-of-information ] dip
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> bs:poke ] bi
|
||||
]
|
||||
[ ]
|
||||
} cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
|
||||
|
||||
: lzw-compress ( byte-array -- seq )
|
||||
binary <byte-reader> <lzw-compress>
|
||||
[ lzw-compress-chars ] [ output>> stream>> ] bi ;
|
||||
|
||||
: lookup-old-code ( lzw -- vector )
|
||||
[ old-code>> ] [ table>> ] bi nth ;
|
||||
|
||||
|
|
@ -155,7 +58,7 @@ ERROR: not-in-table value ;
|
|||
: add-to-table ( seq lzw -- ) table>> push ;
|
||||
|
||||
: lzw-read ( lzw -- lzw n )
|
||||
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:peek ;
|
||||
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
|
||||
|
||||
DEFER: lzw-uncompress-char
|
||||
: handle-clear-code ( lzw -- )
|
||||
|
|
@ -203,6 +106,6 @@ DEFER: lzw-uncompress-char
|
|||
] if* ;
|
||||
|
||||
: lzw-uncompress ( seq -- byte-array )
|
||||
<lsb0-bitstream>
|
||||
! binary <byte-reader> ! <bitstream-reader>
|
||||
<lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
bs:<msb0-bit-reader>
|
||||
<lzw-uncompress>
|
||||
[ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays combinators grouping images
|
||||
images.loader images.viewer kernel locals math math.order
|
||||
kernel locals math math.order
|
||||
math.ranges math.vectors sequences sequences.deep fry ;
|
||||
IN: images.processing
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue