1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors byte-arrays byte-vectors
4 combinators.short-circuit fry io.binary kernel locals math
5 math.bitwise sequences sequences.private ;
9 { bits integer read-only }
10 { #bits integer read-only } ;
12 ERROR: invalid-widthed bits #bits ;
14 : check-widthed ( bits #bits -- bits #bits )
17 [ { [ nip 0 = ] [ drop 0 = not ] } 2&& ]
20 dup 0 < [ neg ] when log2 <=
23 } 2|| [ invalid-widthed ] when ;
25 : <widthed> ( bits #bits -- widthed )
29 : zero-widthed ( -- widthed ) 0 0 <widthed> ;
31 : zero-widthed? ( widthed -- ? ) zero-widthed = ;
35 { byte-pos array-capacity initial: 0 }
36 { bit-pos array-capacity initial: 0 } ;
38 TUPLE: msb0-bit-reader < bit-reader ;
39 TUPLE: lsb0-bit-reader < bit-reader ;
41 : <msb0-bit-reader> ( bytes -- bs )
42 msb0-bit-reader new swap >>bytes ; inline
44 : <lsb0-bit-reader> ( bytes -- bs )
45 lsb0-bit-reader new swap >>bytes ; inline
51 TUPLE: msb0-bit-writer < bit-writer ;
52 TUPLE: lsb0-bit-writer < bit-writer ;
54 : new-bit-writer ( class -- bs )
57 zero-widthed >>widthed ; inline
59 : <msb0-bit-writer> ( -- bs )
60 msb0-bit-writer new-bit-writer ;
62 : <lsb0-bit-writer> ( -- bs )
63 lsb0-bit-writer new-bit-writer ;
65 GENERIC: peek ( n bitstream -- value )
66 GENERIC: poke ( value n bitstream -- )
68 : get-abp ( bitstream -- abp )
69 [ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
71 : set-abp ( abp bitstream -- )
72 [ 8 /mod ] dip [ bit-pos<< ] [ byte-pos<< ] bi ; inline
74 : seek ( n bitstream -- )
75 [ get-abp + ] [ set-abp ] bi ; inline
77 : (align) ( n m -- n' )
78 [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
80 : align ( n bitstream -- )
81 [ get-abp swap (align) ] [ set-abp ] bi ; inline
83 : read ( n bitstream -- value )
84 [ peek ] [ seek ] 2bi ; inline
88 ERROR: not-enough-widthed-bits widthed n ;
90 : check-widthed-bits ( widthed n -- widthed n )
91 2dup { [ nip 0 < ] [ [ #bits>> ] dip < ] } 2||
92 [ not-enough-widthed-bits ] when ;
94 : widthed-bits ( widthed n -- bits )
96 [ [ bits>> ] [ #bits>> ] bi ] dip
97 [ - neg shift ] keep <widthed> ;
99 : split-widthed ( widthed n -- widthed1 widthed2 )
100 2dup [ #bits>> ] dip < [
104 [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
107 : widthed>bytes ( widthed -- bytes widthed )
108 [ 8 split-widthed dup zero-widthed? not ]
109 [ swap bits>> ] B{ } produce-as nip swap ;
111 :: |widthed ( widthed1 widthed2 -- widthed3 )
112 widthed1 bits>> :> bits1
113 widthed1 #bits>> :> #bits1
114 widthed2 bits>> :> bits2
115 widthed2 #bits>> :> #bits2
116 bits1 #bits2 shift bits2 bitor
117 #bits1 #bits2 + <widthed> ;
121 M:: lsb0-bit-writer poke ( value n bs -- )
122 value n <widthed> :> widthed
124 bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder )
125 byte bs widthed>> |widthed :> new-byte
126 new-byte #bits>> 8 = [
127 new-byte bits>> bs bytes>> push
128 zero-widthed bs widthed<<
129 remainder widthed>bytes
130 [ bs bytes>> push-all ] [ bs widthed<< ] bi*
135 : enough-bits? ( n bs -- ? )
138 [ bit-pos>> - ] tri <= ;
140 ERROR: not-enough-bits n bit-reader ;
142 : #bits>#bytes ( #bits -- #bytes )
143 8 /mod 0 = [ 1 + ] unless ; inline
145 :: subseq>bits-le ( bignum n bs -- bits )
146 bignum bs bit-pos>> neg shift n bits ;
148 :: subseq>bits-be ( bignum n bs -- bits )
150 8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
153 :: adjust-bits ( n bs -- )
154 n 8 /mod :> ( #bytes #bits )
155 bs [ #bytes + ] change-byte-pos
156 bit-pos>> #bits + dup 8 >= [
158 bs [ 1 + ] change-byte-pos drop
163 :: (peek) ( n bs endian> subseq-endian -- bits )
164 n bs enough-bits? [ n bs not-enough-bits ] unless
165 bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
166 bs bytes>> subseq endian> execute( seq -- x )
167 n bs subseq-endian execute( bignum n bs -- bits ) ;
169 M: lsb0-bit-reader peek ( n bs -- bits )
170 \ le> \ subseq>bits-le (peek) ;
172 M: msb0-bit-reader peek ( n bs -- bits )
173 \ be> \ subseq>bits-be (peek) ;
175 :: bit-writer-bytes ( writer -- bytes )
176 writer widthed>> #bits>> :> n
178 writer widthed>> bits>> 8 n - shift
183 :: byte-array-n>sequence ( byte-array n -- seq )
184 byte-array length 8 * n / iota
185 byte-array <msb0-bit-reader> '[