source: project/release/5/bloom-filter/trunk/bloom-filter.scm @ 36748

Last change on this file since 36748 was 36748, checked in by kon, 6 months ago

share code as inline

File size: 11.4 KB
Line 
1;;;; bloom-filter.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Jun '06
4
5;; Issues
6;;
7;; - Uses 'message-digest-object' to create a digest. Some overhead if actual
8;; object type is known.
9;;
10;; - Cannot change digest generator after filter creation.
11;;
12;; - Note the use of "in-place" list mutators, '(*! ...). Be vewy careful.
13;;
14;; - Although K may be lower all of the hashes are generated anyway. It
15;; is up to the caller to optimize.
16;;
17;; - Use of 'iset' is slower than bit-vector.
18
19(module bloom-filter
20
21(;export
22  ;
23  optimum-size
24  optimum-k
25  optimum-m
26  p-random-one-bit
27  p-false-positive
28  desired-m
29  actual-k
30  ;
31  make-bloom-filter
32  bloom-filter? check-bloom-filter error-bloom-filter
33  bloom-filter-algorithms
34  bloom-filter-n
35  bloom-filter-m
36  bloom-filter-k
37  bloom-filter-p-false-positive
38  bloom-filter-set!
39  bloom-filter-exists?)
40
41(import scheme
42  (chicken base)
43  (chicken fixnum)
44  (chicken flonum)
45  (chicken type)
46  (chicken memory)
47  (only (srfi 1) list-copy take! reverse!)
48  iset
49  message-digest-primitive
50  message-digest-type
51  message-digest-item
52  (only type-checks
53    define-check+error-type
54    check-positive-fixnum check-flonum check-open-interval check-list)
55  (only type-errors-basic signal-bounds-error))
56
57;;;(should be able to get from module)
58
59(define-type iset:integer-set *)
60
61;;;
62
63(define-type boolean-set iset:integer-set)
64
65(define-type message-digest-primitive (struct message-digest-primitive))
66
67(define-type message-digest-primitives (list-of message-digest-primitive))
68
69(define-type bloom-filter-hasher (* (list-of fixnum) -> (list-of fixnum)))
70
71(define-type bloom-filter-hashers (list-of bloom-filter-hasher))
72
73(define-type unsigned-native-integer-getter (* fixnum --> (or fixnum bignum)))
74
75;;
76
77(define-constant LN2 0.69314718055994528622676398299518041312694549560546875) ;ln(2)
78(define-constant -LN2^2 -0.48045301391820138814381380143458954989910125732421875) ;-(ln(2)^2)
79
80;;
81
82(define-constant MACHINE-WORD-SIZE
83  (cond-expand
84    (64bit
85      8 )
86    (else
87      4 ) ) )
88
89(define-inline (object-data-pointer obj)
90  ;skip over the machine-word header
91  (pointer+ (object->pointer obj) MACHINE-WORD-SIZE) )
92
93(define-inline (pointer-word-offset ptr idx)
94  (pointer+ ptr (fx* idx MACHINE-WORD-SIZE)) )
95
96(define-inline (object-data-offset obj idx)
97  (pointer-word-offset (object-data-pointer obj) idx) )
98
99(cond-expand
100  (64bit
101    (: wordvector64-ref unsigned-native-integer-getter)
102    (define (wordvector64-ref obj idx)
103      (pointer-u64-ref (object-data-offset obj idx)) ) )
104  (else
105    (: wordvector32-ref unsigned-native-integer-getter)
106    (define (wordvector32-ref obj idx)
107      (pointer-u32-ref (object-data-offset obj idx)) ) ) )
108
109(: wordvector-ref unsigned-native-integer-getter)
110;
111(define wordvector-ref
112  (cond-expand
113    (64bit
114      wordvector64-ref )
115    (else
116      wordvector32-ref ) ) )
117
118;;; Record Type
119
120(define-type bloom-filter (struct bloom-filter))
121
122(: *make-bloom-filter (fixnum fixnum fixnum boolean-set bloom-filter-hashers message-digest-primitives -> bloom-filter))
123(: bloom-filter? (* -> boolean : bloom-filter))
124(: *bloom-filter-n (bloom-filter --> fixnum))
125(: *bloom-filter-n-set! (bloom-filter fixnum -> void))
126(: *bloom-filter-m (bloom-filter --> fixnum))
127(: *bloom-filter-k (bloom-filter --> fixnum))
128(: *bloom-filter-bits (bloom-filter --> boolean-set))
129(: *bloom-filter-bits-set! (bloom-filter boolean-set -> void))
130(: *bloom-filter-hashers (bloom-filter --> bloom-filter-hashers))
131(: *bloom-filter-algorithms (bloom-filter --> message-digest-primitives))
132;
133(define (bloom-filter-k bf)
134  (*bloom-filter-k (check-bloom-filter 'bloom-filter-k bf)) )
135;
136(define-record-type bloom-filter
137  (*make-bloom-filter n m k bits hashes mdps)
138  bloom-filter?
139  (n *bloom-filter-n *bloom-filter-n-set!)
140  (m *bloom-filter-m)
141  (k *bloom-filter-k)
142  (bits *bloom-filter-bits *bloom-filter-bits-set!)
143  (hashes *bloom-filter-hashers)
144  (mdps *bloom-filter-algorithms) )
145
146;;; Support
147
148;;
149
150(: message-digest-primitive-lengths (message-digest-primitives --> (list-of fixnum)))
151;
152(define (message-digest-primitive-lengths mdps)
153  (map message-digest-primitive-digest-length mdps) )
154
155(: bloom-filter-indices (bloom-filter * --> list))
156;
157(define (bloom-filter-indices bf obj)
158  (foldl
159    (lambda (ls hasher) (hasher obj ls))
160    '()
161    (*bloom-filter-hashers bf)) )
162
163(: bloom-filter-k-indices (bloom-filter * --> list))
164;
165(define (bloom-filter-k-indices bf obj)
166  (take! (bloom-filter-indices bf obj) (*bloom-filter-k bf)) )
167
168(: bloom-filter-foldl (bloom-filter procedure * list --> *))
169;
170(define (bloom-filter-foldl bf func init obj)
171  (foldl func init (bloom-filter-k-indices bf obj)) )
172
173(: message-digest-result->integers (* fixnum fixnum fixnum (list-of fixnum) -> (list-of fixnum)))
174;
175(define (message-digest-result->integers obj m wrdcnt bytrem ls)
176  ;
177  (define (whole-words)
178    (let loop ((idx 0) (ints ls))
179      (if (fx>= idx wrdcnt)
180        ints
181        (let* (
182          (num (wordvector-ref obj idx))
183          (int (remainder num m)) )
184          (loop (fx+ idx 1) (cons int ints)) ) ) ) )
185  ;
186  (define (partial-word)
187    (let (
188      (ptr (object->pointer obj))
189      (bytoff (fx* wrdcnt MACHINE-WORD-SIZE)) )
190      (do (
191        (cnt  bytrem                (fx- cnt 1))
192        (ptr  (pointer+ ptr bytoff) (pointer+ ptr 1))
193        (int  0                     (fx+ int (pointer-u8-ref ptr))) )
194        ((fx>= 0 cnt) int)) ) )
195  ;
196  (reverse! (cons (partial-word) (whole-words))) )
197
198(: make-bloom-filter-hasher (message-digest-primitive fixnum -> bloom-filter-hasher))
199;
200(define (make-bloom-filter-hasher mdp m)
201  (let (
202    (len (message-digest-primitive-digest-length mdp)) )
203    (let (
204      (wrdcnt (fx/ len MACHINE-WORD-SIZE) )
205      (bytrem (fxmod len MACHINE-WORD-SIZE) ) )
206      ;returns a list of hash values for the supplied object
207      (lambda (obj ls)
208        (let ((blb (message-digest-object mdp obj 'blob)))
209          (message-digest-result->integers blb m wrdcnt bytrem ls) ) ) ) ) )
210
211;;; Calculators
212
213;; Actual optimal: (expt (* n (log2 (/ m (- m 1)))) -1)
214;; Returns the upper-bound
215
216;n : capacity, p : probability of false-positive
217;=> m : bits, k : hashes
218(: optimum-size (float fixnum --> fixnum fixnum))
219;
220(define (optimum-size p n)
221  (let* (
222    (nx (exact->inexact n))
223    (mx (fpceiling (fp/ (fp* nx (fplog p)) -LN2^2)))
224    (kx (fpceiling (fp/ (fp* mx LN2) nx))) )
225    (values (inexact->exact mx) (inexact->exact kx)) ) )
226
227(: optimum-k (fixnum fixnum --> fixnum))
228;
229(define (optimum-k n m)
230  (let (
231    (nx (exact->inexact n))
232    (mx (exact->inexact m)) )
233    (inexact->exact (fpceiling (fp* LN2 (fp/ mx nx)))) ) )
234
235(: optimum-m (fixnum fixnum --> fixnum))
236;
237(define (optimum-m k n)
238  (let (
239    (kx (exact->inexact k))
240    (nx (exact->inexact n)) )
241    (inexact->exact (fpceiling (fp/ (fp* nx kx) LN2))) ) )
242
243(: p-random-one-bit (fixnum fixnum fixnum --> float))
244;
245(define (p-random-one-bit k n m)
246  (let (
247    (kx (exact->inexact k))
248    (nx (exact->inexact n))
249    (mx (exact->inexact m)) )
250    (fp- 1.0 (fpexpt (fp- 1.0 (fp/ 1.0 mx)) (fp* kx nx))) ) )
251
252(: p-false-positive (fixnum fixnum fixnum --> float))
253;
254(define (p-false-positive k n m)
255  (let (
256    (kx (exact->inexact k)) )
257    (fpexpt (p-random-one-bit k n m) kx) ) )
258
259(: desired-m (float fixnum #!optional fixnum --> fixnum fixnum float))
260;
261(define (desired-m p n #!optional opt-k)
262  (check-flonum 'desired-m p 'p)
263  (let (
264    (opt-k (and opt-k (check-positive-fixnum 'desired-m opt-k 'optimal-k))) )
265    (let loop ((m (check-positive-fixnum 'desired-m n 'n)))
266      (let* (
267        (k (or opt-k (optimum-k n m)))
268        (calc-p (p-false-positive k n m)) )
269        (cond
270          ((fp<= calc-p p)
271            (values m k calc-p) )
272          ((fx< (fx- most-positive-fixnum m) n)
273            (signal-bounds-error 'desired-m "cannot represent `m' as a fixnum" m n calc-p) )
274          (else
275            ;FIXME the increment is too large for large n ?
276            (loop (fx+ m n)) ) ) ) ) ) )
277
278(: actual-k (message-digest-primitives --> fixnum))
279;
280(define (actual-k mdps)
281  (let ((wrdcntr (lambda (tot len) (fx+ tot (fx/ len MACHINE-WORD-SIZE)))))
282    (foldl wrdcntr 0 (message-digest-primitive-lengths mdps)) ) )
283
284;;; Bloom Filter
285
286(define-check+error-type bloom-filter bloom-filter?)
287
288(: bloom-filter-algorithms (bloom-filter --> message-digest-primitives))
289;
290(define (bloom-filter-algorithms bf)
291  (list-copy
292    (*bloom-filter-algorithms
293      (check-bloom-filter 'bloom-filter-algorithms bf))) )
294
295(: bloom-filter-n (bloom-filter --> fixnum))
296;
297(define (bloom-filter-n bf)
298  (*bloom-filter-n (check-bloom-filter 'bloom-filter-n bf)) )
299
300(: bloom-filter-m (bloom-filter --> fixnum))
301;
302(define (bloom-filter-m bf)
303  (*bloom-filter-m (check-bloom-filter 'bloom-filter-m bf)) )
304
305(: bloom-filter-k (bloom-filter --> fixnum))
306;
307(define (bloom-filter-k bf)
308  (*bloom-filter-k (check-bloom-filter 'bloom-filter-k bf)) )
309
310;FIXME make-bloom-filter type is ugh
311;( p n mdps) | ( m mdps [k])
312(: make-bloom-filter ((or fixnum float) (or fixnum message-digest-primitives) #!optional (or fixnum message-digest-primitives) -> bloom-filter))
313;
314(define (make-bloom-filter m mdps #!optional des-k)
315  ;processing ( m mdps [k] ) or ( p n mdps ) ?
316  (if (list? mdps)
317    (check-positive-fixnum 'make-bloom-filter m 'm)
318    (let (
319      (p (check-flonum 'make-bloom-filter m 'p))
320      (n (check-positive-fixnum 'make-bloom-filter mdps 'n)) )
321      (check-open-interval 'make-bloom-filter p  0.0 1.0 'p)
322      (set! mdps des-k)
323      (set!-values (m des-k) (optimum-size p n)) ) )
324  ;algorithms
325  (for-each
326    (cut check-message-digest-primitive 'make-bloom-filter <>)
327    (check-list 'make-bloom-filter mdps 'mdps))
328  ;get the "desired" # of hash values (k)
329  (let (
330    (act-k (actual-k mdps)) )
331    (if (not des-k)
332      (set! des-k act-k)
333      (when (fx< act-k (check-positive-fixnum 'make-bloom-filter des-k))
334        ;FIXME tell them how !
335        (error 'make-bloom-filter "insufficient hash functions supplied" act-k des-k) ) ) )
336  ;bloom filter is a multi-hash into a bitvector
337  (let (
338    (bits (make-bit-vector m))
339    (hashers (map (cut make-bloom-filter-hasher <> m) mdps)) )
340    (*make-bloom-filter 0 m des-k bits hashers mdps) ) )
341
342(: bloom-filter-p-false-positive (bloom-filter --> float))
343;
344(define (bloom-filter-p-false-positive bf . n)
345  (check-bloom-filter 'bloom-filter-p-false-positive bf)
346  (p-false-positive
347    (*bloom-filter-k bf)
348    (optional n (*bloom-filter-n bf))
349    (*bloom-filter-m bf)) )
350
351(: bit-on! (boolean-set fixnum -> boolean-set))
352;
353(define (bit-on! bits idx)
354  (bit-vector-set! bits idx #t)
355  bits )
356
357(: *make-bit-counter (boolean-set -> (fixnum fixnum -> fixnum)))
358;
359(define-inline (*make-bit-counter bits)
360  (lambda (cnt idx) (if (bit-vector-ref bits idx) (fx+ cnt 1) cnt)) )
361
362(: *bloom-filter-exists? (bloom-filter * --> boolean))
363;
364(define-inline (*bloom-filter-exists? bf obj)
365  (let* (
366    (bits (*bloom-filter-bits bf))
367    (bitcnt (bloom-filter-foldl bf (*make-bit-counter bits) 0 obj)) )
368    (fx<= (*bloom-filter-k bf) bitcnt) ) )
369
370(: bloom-filter-exists? (bloom-filter * --> boolean))
371;
372(define (bloom-filter-exists? bf obj)
373  (*bloom-filter-exists? (check-bloom-filter 'bloom-filter-exists? bf) obj) )
374
375(: bloom-filter-set! (bloom-filter * -> void))
376;
377(define (bloom-filter-set! bf obj)
378  ;tracks actual pop (n) so cannot "reset"
379  (unless (*bloom-filter-exists? (check-bloom-filter 'bloom-filter-set! bf) obj)
380    ;spray rep bits
381    (let ((bits (bloom-filter-foldl bf bit-on! (*bloom-filter-bits bf) obj)))
382      (*bloom-filter-bits-set! bf bits) )
383    ;bump actual pop
384    (*bloom-filter-n-set! bf (fx+ (*bloom-filter-n bf) 1)) ) )
385
386) ;module bloom-filter
Note: See TracBrowser for help on using the repository browser.