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

remove all the compress code from lzw until it works, fix bitstreams

db4
Doug Coleman 2009-05-14 23:33:00 -05:00
parent c443d6d815
commit af2f62ae62
4 changed files with 123 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
basis/bitstreams/bitstreams-tests.factor
View File

@ -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

128
basis/bitstreams/bitstreams.factor
View File

@ -23,7 +23,7 @@ ERROR: invalid-widthed bits #bits ;
widthed boa ; widthed boa ;
: zero-widthed ( -- widthed ) 0 0 <widthed> ; : zero-widthed ( -- widthed ) 0 0 <widthed> ;
: zero-widthed? ( widthed -- ? ) zero-widthed = ; : zero-widthed? ( widthed -- ? ) zero-widthed = ;
TUPLE: bit-reader TUPLE: bit-reader
{ bytes byte-array } { bytes byte-array }
@ -41,73 +41,32 @@ 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 -- )
: seek ( n bitstream -- ) : seek ( n bitstream -- )
{ {
[ byte-pos>> 8 * ] [ byte-pos>> 8 * ]
[ bit-pos>> + + 8 /mod ] [ bit-pos>> + + 8 /mod ]
[ (>>bit-pos) ] [ (>>bit-pos) ]
[ (>>byte-pos) ] [ (>>byte-pos) ]
} cleave ; inline } cleave ; inline
: 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>> ;

117
basis/compression/lzw/lzw.factor
View File

@ -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 ;

2
basis/images/processing/processing.factor
View File

@ -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