! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.accessors assocs byte-arrays combinators constructors destructors fry io io.binary io.encodings.binary io.streams.byte-array kernel locals macros math math.ranges multiline sequences sequences.private vectors byte-vectors combinators.short-circuit math.bitwise ; IN: bitstreams TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; ERROR: invalid-widthed bits #bits ; : check-widthed ( bits #bits -- bits #bits ) dup 0 < [ invalid-widthed ] when 2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when over 0 = [ 2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when ] unless ; : ( bits #bits -- widthed ) check-widthed widthed boa ; inline : zero-widthed ( -- widthed ) 0 0 ; inline : zero-widthed? ( widthed -- ? ) zero-widthed = ; inline TUPLE: bit-reader { bytes byte-array } { byte-pos array-capacity initial: 0 } { bit-pos array-capacity initial: 0 } ; TUPLE: bit-writer { bytes byte-vector } { widthed widthed } ; TUPLE: msb0-bit-reader < bit-reader ; TUPLE: lsb0-bit-reader < bit-reader ; CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ; CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; TUPLE: msb0-bit-writer < bit-writer ; TUPLE: lsb0-bit-writer < bit-writer ; : new-bit-writer ( class -- bs ) new BV{ } clone >>bytes 0 0 >>widthed ; inline : ( -- bs ) msb0-bit-writer new-bit-writer ; inline : ( -- bs ) lsb0-bit-writer new-bit-writer ; inline GENERIC: peek ( n bitstream -- value ) GENERIC: poke ( value n bitstream -- ) : seek ( n bitstream -- ) { [ byte-pos>> 8 * ] [ bit-pos>> + + 8 /mod ] [ (>>bit-pos) ] [ (>>byte-pos) ] } cleave ; inline : read ( n bitstream -- value ) [ peek ] [ seek ] 2bi ; inline > ] dip < [ not-enough-bits ] when [ [ bits>> ] [ #bits>> ] bi ] dip [ - neg shift ] keep ; inline : split-widthed ( widthed n -- widthed1 widthed2 ) 2dup [ #bits>> ] dip < [ drop zero-widthed ] [ [ widthed-bits ] [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep ] 2bi ] if ; inline : widthed>bytes ( widthed -- bytes widthed ) [ 8 split-widthed dup zero-widthed? not ] [ swap bits>> ] B{ } produce-as nip swap ; inline :: |widthed ( widthed1 widthed2 -- widthed3 ) widthed1 bits>> :> bits1 widthed1 #bits>> :> #bits1 widthed2 bits>> :> bits2 widthed2 #bits>> :> #bits2 bits1 #bits2 shift bits2 bitor #bits1 #bits2 + ; inline PRIVATE> M:: lsb0-bit-writer poke ( value n bs -- ) value n :> widthed widthed bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte 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 ] [ bs (>>widthed) ] bi* ] [ byte bs (>>widthed) ] if ; : enough-bits? ( n bs -- ? ) [ bytes>> length ] [ byte-pos>> - 8 * ] [ bit-pos>> - ] tri <= ; inline 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 ; inline :: 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 ; inline :: (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>> ;