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 ;
|
io.streams.byte-array ;
|
||||||
IN: bitstreams.tests
|
IN: bitstreams.tests
|
||||||
|
|
||||||
[ 1 t ]
|
|
||||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
|
|
||||||
|
|
||||||
[ 254 8 t ]
|
[ BIN: 1111111111 ]
|
||||||
[ 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 } ]
|
|
||||||
[
|
[
|
||||||
binary <byte-writer> <bitstream-writer> 254 8 rot
|
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||||
[ write-bits ] keep stream>> >byte-array
|
2 >>byte-pos 6 >>bit-pos
|
||||||
|
10 swap peek
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 255 8 t ]
|
[ BIN: 111111111 ]
|
||||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
[
|
||||||
|
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 ]
|
[ BIN: 11111111 ]
|
||||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
|
[
|
||||||
|
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: msb0-bit-writer < bit-writer ;
|
||||||
TUPLE: lsb0-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: peek ( n bitstream -- value )
|
||||||
GENERIC: poke ( value n bitstream -- )
|
GENERIC: poke ( value n bitstream -- )
|
||||||
|
|
@ -64,50 +67,6 @@ GENERIC: poke ( value n bitstream -- )
|
||||||
: read ( n bitstream -- value )
|
: read ( n bitstream -- value )
|
||||||
[ peek ] [ seek ] 2bi ; inline
|
[ 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
|
<PRIVATE
|
||||||
|
|
||||||
ERROR: not-enough-bits widthed n ;
|
ERROR: not-enough-bits widthed n ;
|
||||||
|
|
@ -130,18 +89,69 @@ ERROR: not-enough-bits widthed n ;
|
||||||
[ 8 split-widthed dup zero-widthed? not ]
|
[ 8 split-widthed dup zero-widthed? not ]
|
||||||
[ swap bits>> ] B{ } produce-as nip swap ;
|
[ 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>
|
PRIVATE>
|
||||||
|
|
||||||
M:: lsb0-bit-writer poke ( value n bs -- )
|
M:: lsb0-bit-writer poke ( value n bs -- )
|
||||||
value n <widthed> :> widthed
|
value n <widthed> :> widthed
|
||||||
widthed
|
widthed
|
||||||
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
|
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
|
||||||
|
byte bs widthed>> |widthed :> new-byte
|
||||||
byte #bits>> 8 = [
|
new-byte #bits>> dup 8 > [ "oops" throw ] when 8 = [
|
||||||
byte bits>> bs bytes>> push
|
new-byte bits>> bs bytes>> push
|
||||||
zero-widthed bs (>>widthed)
|
zero-widthed bs (>>widthed)
|
||||||
remainder widthed>bytes
|
remainder widthed>bytes
|
||||||
[ bs bytes>> push-all ] [ B bs (>>widthed) ] bi*
|
[ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
|
||||||
] [
|
] [
|
||||||
byte bs (>>widthed)
|
byte bs (>>widthed)
|
||||||
] if ;
|
] 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.
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien.accessors byte-arrays combinators
|
USING: accessors alien.accessors assocs byte-arrays combinators
|
||||||
constructors destructors fry io io.binary kernel locals macros
|
io.encodings.binary io.streams.byte-array kernel math sequences
|
||||||
math math.ranges multiline sequences sequences.private ;
|
vectors ;
|
||||||
IN: bitstreams
|
IN: compression.lzw
|
||||||
|
|
||||||
QUALIFIED-WITH: bitstreams bs
|
QUALIFIED-WITH: bitstreams bs
|
||||||
|
|
||||||
CONSTANT: clear-code 256
|
CONSTANT: clear-code 256
|
||||||
CONSTANT: end-of-information 257
|
CONSTANT: end-of-information 257
|
||||||
|
|
||||||
TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
|
TUPLE: lzw input output table code old-code ;
|
||||||
code old-code ;
|
|
||||||
|
|
||||||
SYMBOL: table-full
|
SYMBOL: table-full
|
||||||
|
|
||||||
ERROR: index-too-big n ;
|
|
||||||
|
|
||||||
: lzw-bit-width ( n -- n' )
|
: lzw-bit-width ( n -- n' )
|
||||||
{
|
{
|
||||||
{ [ dup 510 <= ] [ drop 9 ] }
|
{ [ dup 510 <= ] [ drop 9 ] }
|
||||||
|
|
@ -26,37 +23,14 @@ ERROR: index-too-big n ;
|
||||||
[ drop table-full ]
|
[ drop table-full ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: lzw-bit-width-compress ( lzw -- n )
|
|
||||||
count>> lzw-bit-width ;
|
|
||||||
|
|
||||||
: lzw-bit-width-uncompress ( lzw -- n )
|
: lzw-bit-width-uncompress ( lzw -- n )
|
||||||
table>> length lzw-bit-width ;
|
table>> length lzw-bit-width ;
|
||||||
|
|
||||||
: initial-compress-table ( -- assoc )
|
|
||||||
258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
|
|
||||||
|
|
||||||
: initial-uncompress-table ( -- seq )
|
: initial-uncompress-table ( -- seq )
|
||||||
258 iota [ 1vector ] V{ } map-as ;
|
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 )
|
: reset-lzw-uncompress ( lzw -- lzw )
|
||||||
initial-uncompress-table >>table reset-lzw ;
|
initial-uncompress-table >>table ;
|
||||||
|
|
||||||
: <lzw-compress> ( input -- obj )
|
|
||||||
lzw new
|
|
||||||
swap >>input
|
|
||||||
! binary <byte-writer> <bitstream-writer> >>output
|
|
||||||
V{ } clone >>output ! TODO
|
|
||||||
reset-lzw-compress ;
|
|
||||||
|
|
||||||
: <lzw-uncompress> ( input -- obj )
|
: <lzw-uncompress> ( input -- obj )
|
||||||
lzw new
|
lzw new
|
||||||
|
|
@ -64,79 +38,8 @@ ERROR: index-too-big n ;
|
||||||
BV{ } clone >>output
|
BV{ } clone >>output
|
||||||
reset-lzw-uncompress ;
|
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 ;
|
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 )
|
: lookup-old-code ( lzw -- vector )
|
||||||
[ old-code>> ] [ table>> ] bi nth ;
|
[ old-code>> ] [ table>> ] bi nth ;
|
||||||
|
|
||||||
|
|
@ -155,7 +58,7 @@ ERROR: not-in-table value ;
|
||||||
: add-to-table ( seq lzw -- ) table>> push ;
|
: add-to-table ( seq lzw -- ) table>> push ;
|
||||||
|
|
||||||
: lzw-read ( lzw -- lzw n )
|
: 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
|
DEFER: lzw-uncompress-char
|
||||||
: handle-clear-code ( lzw -- )
|
: handle-clear-code ( lzw -- )
|
||||||
|
|
@ -203,6 +106,6 @@ DEFER: lzw-uncompress-char
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
: lzw-uncompress ( seq -- byte-array )
|
: lzw-uncompress ( seq -- byte-array )
|
||||||
<lsb0-bitstream>
|
bs:<msb0-bit-reader>
|
||||||
! binary <byte-reader> ! <bitstream-reader>
|
<lzw-uncompress>
|
||||||
<lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
|
[ lzw-uncompress-char ] [ output>> ] bi ;
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! 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 byte-arrays combinators grouping images
|
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 ;
|
math.ranges math.vectors sequences sequences.deep fry ;
|
||||||
IN: images.processing
|
IN: images.processing
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue