diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 7113b650fd..d7d13cf17c 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -1,96 +1,147 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays destructors fry io kernel locals -math sequences ; +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: bitstream stream end-of-stream? current-bits #bits disposed ; -TUPLE: bitstream-reader < bitstream ; +TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; -: reset-bitstream ( stream -- stream ) - 0 >>#bits 0 >>current-bits ; inline +ERROR: invalid-widthed bits #bits ; -: new-bitstream ( stream class -- bitstream ) - new - swap >>stream - reset-bitstream ; inline +: 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 ; -M: bitstream-reader dispose ( stream -- ) - stream>> dispose ; +: ( bits #bits -- widthed ) + check-widthed + widthed boa ; -: ( stream -- bitstream ) - bitstream-reader new-bitstream ; inline +: zero-widthed ( -- widthed ) 0 0 ; +: zero-widthed? ( widthed -- ? ) zero-widthed = ; -: read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 [ - >>current-bits 8 >>#bits +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 ; +CONSTRUCTOR: msb0-bit-writer ( -- bs ) + BV{ } clone >>bytes + 0 0 >>widthed ; +CONSTRUCTOR: lsb0-bit-writer ( -- bs ) + BV{ } clone >>bytes + 0 0 >>widthed ; + +! interface + +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 + + +! reading + +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 + +> ] dip < [ not-enough-bits ] when + [ [ bits>> ] [ #bits>> ] bi ] dip + [ - neg shift ] keep ; + +: split-widthed ( widthed n -- widthed1 widthed2 ) + 2dup [ #bits>> ] dip < [ + drop zero-widthed ] [ - 0 >>#bits - t >>end-of-stream? - ] if* ; - -: maybe-read-next-byte ( bitstream -- bitstream ) - dup #bits>> 0 = [ read-next-byte ] when ; inline - -: shift-one-bit ( bitstream -- n ) - [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline - -: next-bit ( bitstream -- n/f ? ) - maybe-read-next-byte - dup end-of-stream?>> [ - drop f - ] [ - [ shift-one-bit ] - [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi - ] if dup >boolean ; - -: read-bit ( bitstream -- n ? ) - dup #bits>> 1 = [ - [ current-bits>> 1 bitand ] - [ read-next-byte drop ] bi t - ] [ - next-bit - ] if ; inline - -: bits>integer ( seq -- n ) - 0 [ [ 1 shift ] dip bitor ] reduce ; inline - -: read-bits ( width bitstream -- n width ? ) - [ - '[ _ read-bit drop ] replicate - [ f = ] trim-tail - [ bits>integer ] [ length ] bi - ] 2keep drop over = ; - -TUPLE: bitstream-writer < bitstream ; - -: ( stream -- bitstream ) - bitstream-writer new-bitstream ; inline - -: write-bit ( n bitstream -- ) - [ 1 shift bitor ] change-current-bits - [ 1+ ] change-#bits - dup #bits>> 8 = [ - [ [ current-bits>> ] [ stream>> stream-write1 ] bi ] - [ reset-bitstream drop ] bi - ] [ - drop - ] if ; inline - -ERROR: invalid-bit-width n ; - -:: write-bits ( n width bitstream -- ) - n 0 < [ n invalid-bit-width ] when - n 0 = [ - width [ 0 bitstream write-bit ] times - ] [ - width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times - n-length [ - n-length swap - 1- neg n swap shift 1 bitand - bitstream write-bit - ] each + [ widthed-bits ] + [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep ] 2bi ] if ; -: flush-bits ( bitstream -- ) stream>> stream-flush ; +: widthed>bytes ( widthed -- bytes widthed ) + [ 8 split-widthed dup zero-widthed? not ] + [ swap bits>> ] B{ } produce-as nip swap ; -: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ; +PRIVATE> + +M:: lsb0-bit-writer poke ( value n bs -- ) + value n :> widthed + widthed + bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte + + byte #bits>> 8 = [ + byte bits>> bs bytes>> push + zero-widthed bs (>>widthed) + remainder widthed>bytes + [ bs bytes>> push-all ] [ B bs (>>widthed) ] bi* + ] [ + byte bs (>>widthed) + ] if ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 29cbe96d69..592a0efb6c 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bitstreams byte-vectors combinators io -io.encodings.binary io.streams.byte-array kernel math sequences -vectors ; -IN: compression.lzw +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 + +QUALIFIED-WITH: bitstreams bs CONSTANT: clear-code 256 CONSTANT: end-of-information 257 @@ -52,7 +54,8 @@ ERROR: index-too-big n ; : ( input -- obj ) lzw new swap >>input - binary >>output + ! binary >>output + V{ } clone >>output ! TODO reset-lzw-compress ; : ( input -- obj ) @@ -76,7 +79,7 @@ ERROR: not-in-table value ; [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless ] [ [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] bi ; : omega-k>omega ( lzw -- lzw ) @@ -114,18 +117,18 @@ ERROR: not-in-table value ; [ [ clear-code ] dip [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] [ (lzw-compress-chars) ] [ [ k>> ] [ lzw-bit-width-compress ] - [ output>> write-bits ] tri + [ output>> bs:poke ] tri ] [ [ end-of-information ] dip [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] [ ] } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; @@ -152,7 +155,7 @@ ERROR: not-in-table value ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:peek ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) @@ -200,5 +203,6 @@ DEFER: lzw-uncompress-char ] if* ; : lzw-uncompress ( seq -- byte-array ) - binary + + ! binary ! [ lzw-uncompress-char ] [ output>> ] bi ;