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
+[ BIN: 1111111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 10 swap peek
+] unit-test
-[ 4095 12 t ]
-[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 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
+
+[ 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
-[ B{ 254 } ]
+[ BIN: 11111 ]
[
- 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
+ 5 swap peek
] unit-test
-[ 255 8 t ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] 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
-[ 255 8 f ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
+[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test
widthed boa ;
: zero-widthed ( -- widthed ) 0 0 <widthed> ;
-: zero-widthed? ( widthed -- ? ) zero-widthed = ;
+: zero-widthed? ( widthed -- ? ) zero-widthed = ;
TUPLE: bit-reader
{ bytes byte-array }
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 -- )
: seek ( n bitstream -- )
{
- [ byte-pos>> 8 * ]
- [ bit-pos>> + + 8 /mod ]
- [ (>>bit-pos) ]
+ [ byte-pos>> 8 * ]
+ [ bit-pos>> + + 8 /mod ]
+ [ (>>bit-pos) ]
[ (>>byte-pos) ]
} cleave ; inline
: 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 ;
[ 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>> ;
! 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 ] }
[ 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
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 ;
: 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 -- )
] 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 ;
! Copyright (C) 2009 Marc Fauconneau.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors arrays byte-arrays combinators grouping images\r
-images.loader images.viewer kernel locals math math.order\r
+kernel locals math math.order\r
math.ranges math.vectors sequences sequences.deep fry ;\r
IN: images.processing\r
\r
projects / factor.git / commitdiff