1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
#lang racket/base
(require (for-syntax racket/base)
(for-syntax "private/count-bits-in-fixnum.rkt")
racket/private/vector-wraps
racket/match
racket/dict
racket/contract/base
racket/fixnum
racket/unsafe/ops
racket/serialize
"private/count-bits-in-fixnum.rkt")
(define bits-in-a-word 8)
(define bits-in-a-word-log2 3)
(define largest-word
(- (expt 2 bits-in-a-word) 1))
(define (word-index n)
(arithmetic-shift n (- bits-in-a-word-log2)))
(define (bit-index n)
(bitwise-and n (sub1 bits-in-a-word)))
(define (make-bit-vector size [fill #f])
(define-values (q r) (quotient/remainder size bits-in-a-word))
(define word-size (+ q (if (zero? r) 0 1)))
(define words (make-bytes word-size (if fill largest-word 0)))
(when (and fill (not (zero? r)))
(bytes-set! words q (- (expt 2 r) 1)))
(bit-vector words size))
(define bit-vector*
(let ([bit-vector
(lambda init-bits
(list->bit-vector init-bits))])
bit-vector))
(define not-given (gensym))
(define (bit-vector-ref bv n [default not-given])
(unless (exact-nonnegative-integer? n)
(raise-argument-error 'bit-vector-ref "exact-nonnegative-integer?" n))
(cond [(< n (bit-vector-size bv))
(unsafe-bit-vector-ref bv n)]
[else
(cond [(eq? default not-given)
(raise-range-error 'bit-vector-ref
"bit-vector"
"" n bv 0 (sub1 (bit-vector-size bv)))]
[(procedure? default)
(default)]
[else default])]))
(define (unsafe-bit-vector-ref bv n)
(define wi (word-index n))
(define bi (bit-index n))
(match bv
[(struct bit-vector (words size))
(define word (bytes-ref words wi))
(define bit (bitwise-bit-set? word bi))
bit]))
(define (bit-vector-iterate-first bv)
(if (zero? (bit-vector-size bv)) #f 0))
(define (bit-vector-iterate-next bv pos)
(if (>= (+ pos 1) (bit-vector-size bv))
#f
(+ pos 1)))
(define (bit-vector-iterate-key bv key)
key)
(define (bit-vector-iterate-value bv key)
(bit-vector-ref bv key))
(define (bit-vector-set! bv n b)
(define wi (word-index n))
(define bi (bit-index n))
(match bv
[(struct bit-vector (words size))
(define word (bytes-ref words wi))
(define bit (bitwise-bit-set? word bi))
(unless (eq? bit b)
(define new-word (bitwise-xor word (arithmetic-shift 1 bi)))
(bytes-set! words wi new-word))]))
(define (bit-vector-length bv)
(bit-vector-size bv))
(define bit-vector-copy*
(let ([bit-vector-copy
(case-lambda
[(bv)
(bit-vector (bytes-copy (bit-vector-words bv))
(bit-vector-size bv))]
[(bv start)
(bit-vector-copy bv start)]
[(bv start end)
(bit-vector-copy bv start end)])])
bit-vector-copy))
(define popcount-table
(let ()
(define-syntax (make-table stx)
(with-syntax ([(elt ...)
(for/list ([i (in-range 256)])
(fxpopcount i))])
;; Literal immutable vector allocated once (?)
#'(quote #(elt ...))))
(make-table)))
(define (bit-vector-popcount bv)
(for/sum ([b (in-bytes (bit-vector-words bv))])
#| (unsafe-fxpopcount* b 8) |#
(unsafe-vector-ref popcount-table b)))
(define (bit-vector->list bv)
(define len (bit-vector-size bv))
(let loop ([i 0])
(cond [(< i len)
(cons (unsafe-bit-vector-ref bv i)
(loop (add1 i)))]
[else null])))
(define (list->bit-vector init-bits)
(define len (length init-bits))
(define bv (make-bit-vector len))
(for ([i (in-range len)]
[b (in-list init-bits)])
(bit-vector-set! bv i b))
bv)
(define (bit-vector->string bv)
(let* ([l (bit-vector-size bv)]
[s (make-string l)])
(for ([i (in-range l)])
(string-set! s i (if (unsafe-bit-vector-ref bv i) #\1 #\0)))
s))
(define (string->bit-vector s)
(let* ([bv (make-bit-vector (string-length s) #f)])
(for ([i (in-range (string-length s))])
(when (eqv? (string-ref s i) #\1)
(bit-vector-set! bv i #t)))
bv))
(define-vector-wraps "bit-vector"
"boolean?" boolean?
bit-vector? bit-vector-length bit-vector-ref bit-vector-set! make-bit-vector
unsafe-bit-vector-ref bit-vector-set! bit-vector-length
in-bit-vector*
in-bit-vector
for/bit-vector
for*/bit-vector
bit-vector-copy
#f
check-bitvector)
;; A bit vector is represented as bytes.
(serializable-struct bit-vector (words size)
; words is the bytes of words
; size is the number of bits in bitvector
#:guard ;; needed because deserialization doesn't go through contracts
(lambda (words size _name)
(unless (bytes? words)
(raise-argument-error 'bit-vector "bytes?" words))
(unless (exact-nonnegative-integer? size)
(raise-argument-error 'bit-vector "exact-nonnegative-integer?" size))
(let-values ([(q r) (quotient/remainder size bits-in-a-word)])
(unless (and (= (bytes-length words) (+ q (if (zero? r) 0 1)))
;; make sure "unreachable" bits are unset
(or (zero? r) (< (bytes-ref words q) (expt 2 r))))
(error 'bit-vector "bit vector data contains wrong number of bits")))
(values words size))
#:property prop:dict/contract
(list (vector-immutable bit-vector-ref
bit-vector-set!
#f ;; set
#f ;; remove!
#f ;; remove
bit-vector-length
bit-vector-iterate-first
bit-vector-iterate-next
bit-vector-iterate-key
bit-vector-iterate-value)
(vector-immutable exact-nonnegative-integer?
boolean?
exact-nonnegative-integer?
#f #f #f))
#:methods gen:equal+hash
[(define (equal-proc x y recursive-equal?)
(let ([vx (bit-vector-words x)]
[vy (bit-vector-words y)]
[nx (bit-vector-size x)]
[ny (bit-vector-size y)])
(and (= nx ny)
(or (zero? nx) ;zero-length bit-vectors are equal
(let ([last-index (sub1 (bytes-length vx))])
(and
;; Check all but last byte.
;; These use all bits, therefore simple eq?.
(for/and ([index (in-range (sub1 last-index))])
(eq? (bytes-ref vx index)
(bytes-ref vy index)))
;; Check the used bits of the last byte.
(let ([used-bits (min 8 (remainder nx 256))])
(eq? (bitwise-bit-field (bytes-ref vx last-index)
0
used-bits)
(bitwise-bit-field (bytes-ref vy last-index)
0
used-bits)))))))))
(define (hash-code x hc)
(let ([v (bit-vector-words x)]
[n (bit-vector-size x)])
(bitwise-xor
(hc n)
(for/fold ([h 1]) ([i (in-range (bytes-length v))])
(bitwise-xor h (hc (bytes-ref v i)))))))
(define hash-proc hash-code)
(define hash2-proc hash-code)]
#:property prop:sequence in-bit-vector)
(provide/contract
[bit-vector?
(-> any/c any)]
[rename bit-vector* bit-vector
(->* () () #:rest (listof boolean?) bit-vector?)]
[make-bit-vector
(->* (exact-nonnegative-integer?) (boolean?) bit-vector?)]
[bit-vector-ref
(->* (bit-vector? exact-nonnegative-integer?) (any/c) any)]
[bit-vector-set!
(-> bit-vector? exact-nonnegative-integer? boolean? any)]
[bit-vector-length
(-> bit-vector? any)]
[bit-vector-popcount
(-> bit-vector? any)]
(rename bit-vector-copy*
bit-vector-copy
(->* [bit-vector?] [exact-nonnegative-integer? exact-nonnegative-integer?] bit-vector?))
[bit-vector->list
(-> bit-vector? (listof boolean?))]
[list->bit-vector
(-> (listof boolean?) bit-vector?)]
[bit-vector->string
(-> bit-vector? string?)]
[string->bit-vector
(-> (and/c string? #rx"^[01]*$") bit-vector?)])
(provide in-bit-vector for/bit-vector for*/bit-vector)
|
