initial bitstreams checkin

basis/bitstreams/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/bitstreams/bitstreams-tests.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors bitstreams io io.streams.string kernel tools.test
+grouping compression.lzw multiline ;
+IN: bitstreams.tests
+
+[ 1 ]
+[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
+
+[ 254 ]
+[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+
+[ 4095 ]
+[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
+
+[ B{ 254 } ]
+[
+    <string-writer> <bitstream-writer> 254 8 rot
+    [ write-bits ] keep stream>> >byte-array
+] unit-test
+
+
+/*
+[
+    
+] [
+    B{ 7 7 7 8 8 7 7 9 7 }
+    [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ]
+    [ lzw-compress ] bi
+] unit-test
+*/

basis/bitstreams/bitstreams.factor

@@ -0,0 +1,87 @@
+! 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 ;
+IN: bitstreams
+
+TUPLE: bitstream stream current-bits #bits disposed ;
+TUPLE: bitstream-reader < bitstream ;
+
+: reset-bitstream ( stream -- stream )
+    0 >>#bits 0 >>current-bits ; inline
+
+: new-bitstream ( stream class -- bitstream )
+    new
+        swap >>stream
+        reset-bitstream ; inline
+
+M: bitstream-reader dispose ( stream -- )
+    stream>> dispose ;
+
+: <bitstream-reader> ( stream -- bitstream )
+    bitstream-reader new-bitstream ; inline
+
+: read-next-byte ( bitstream -- bitstream )
+    dup stream>> stream-read1
+    [ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline
+
+: 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 )
+    maybe-read-next-byte [
+        shift-one-bit
+    ] [
+        [ 1- ] change-#bits maybe-read-next-byte drop
+    ] bi ; inline
+
+: read-bit ( bitstream -- n )
+    dup #bits>> 1 = [
+        [ current-bits>> 1 bitand ]
+        [ read-next-byte drop ] bi
+    ] [
+        next-bit
+    ] if ; inline
+
+: bits>integer ( seq -- n )
+    0 [ [ 1 shift ] dip bitor ] reduce ; inline
+
+: read-bits ( width bitstream -- n )
+    '[ _ read-bit ] replicate bits>integer ; inline
+
+
+TUPLE: bitstream-writer < bitstream ;
+
+: <bitstream-writer> ( 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
+    ] if ;
+
+: flush-bits ( bitstream -- ) stream>> stream-flush ;
+
+: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;