source: project/release/4/bloom-filter/tags/1.1.0/bloom-filter.scm @ 20398

Last change on this file since 20398 was 20398, checked in by Kon Lovett, 10 years ago

Rel 1.1 (a little faster)

File size: 6.0 KB
Line 
1;;;; bloom-filter.scm
2;;;; Kon Lovett, Jun '06
3
4;; Issues
5;;
6;; - Uses 'meessage-digest-object' to create a digest. Some overhead if actual
7;; object type is known.
8;;
9;; - Cannot change digest generator after filter creation.
10;;
11;; - Not optimal for 64-bit machines.
12;;
13;; - Note the use of "in-place" list mutators, '(*! ...). Be vewy careful.
14;;
15;; - Although K may be lower the actual number of hash functions
16;; are generated anyway. It is up to the caller to optimize.
17
18(module bloom-filter
19
20  (;export
21    optimum-k
22    optimum-m
23    p-random-one-bit
24    p-false-positive
25    desired-m
26    actual-k
27    make-bloom-filter
28    bloom-filter? check-bloom-filter error-bloom-filter
29    bloom-filter-n
30    bloom-filter-m
31    bloom-filter-k
32    bloom-filter-p-false-positive
33    bloom-filter-set!
34    bloom-filter-exists?)
35
36  (import scheme chicken)
37
38  (use
39    srfi-1 srfi-13
40    numeric-macros moremacros
41    iset message-digest
42    record-variants type-checks hash-utils)
43
44;;;
45
46(include "mathh-constants")
47
48(define-constant unsigned-integer32-size 4)
49
50;;; Record Type
51
52(define-record-type-variant bloom-filter (unsafe unchecked inline)
53        (%make-bloom-filter n m k bits hashes mdps)
54        %bloom-filter?
55        (n %bloom-filter-n %bloom-filter-n-set!)
56        (m %bloom-filter-m)
57        (k %bloom-filter-k)
58        (bits %bloom-filter-bits %bloom-filter-bits-set!)
59        (hashes %bloom-filter-hashes)
60        (mdps %bloom-filter-algorithms) )
61
62;;; Support
63
64(define-syntax ensure-positive-fixnum
65  (syntax-rules ()
66    ((_ ?loc ?n) (set! ?n (inexact->exact (check-positive-fixnum ?loc ?n))) ) ) )
67
68(define-inline (message-digest-primitive-lengths mdps)
69        (map message-digest-primitive-digest-length mdps) )
70
71(define-inline (bloom-filter-indices bf obj)
72        (map (cut <> obj) (%bloom-filter-hashes bf)) )
73
74(define-inline (bloom-filter-k-indices bf obj)
75  (take!
76    (apply append! (bloom-filter-indices bf obj))
77    (%bloom-filter-k bf)) )
78
79(define-inline (message-digest->integers str m)
80  (let* ((bytsiz (##sys#size str))
81         (u32len (fx/ bytsiz unsigned-integer32-size)) )
82    (let loop ((idx 0)
83               (ls '()))
84      (if (fx= idx u32len) ls
85        ; Hash functions return integers,
86        ; and m is a fixnum, so 'inexact->exact' will produce a fixnum.
87        (loop
88          (fx++ idx)
89          (cons (inexact->exact (modulo (unsigned-integer32-ref str idx) m)) ls)) ) ) ) )
90
91(define-inline (bloom-filter-fold bf proc init obj)
92        (fold proc init (bloom-filter-k-indices bf obj)) )
93
94;;; Calculators
95
96;; Actual optimal: (expt (* n (log2 (/ m (- m 1)))) -1)
97;; Returns the upper-bound, but w/ rounding
98
99(define (optimum-k n m)
100        (inexact->exact (round (* LN2 (/ m n)))) )
101
102(define (optimum-m k n)
103        (inexact->exact (round (/ (* n k) LN2))) )              ; Similar to above
104
105(define (p-random-one-bit k n m)
106        (- 1 (expt (- 1 (/ 1 m)) (* k n))) )
107
108(define (p-false-positive k n m)
109        (expt (p-random-one-bit k n m) k) )
110
111(define (desired-m p n . opt-k)
112        (ensure-positive-fixnum 'desired-m n)
113        (let loop ((m n))
114                (let* ((k (optional opt-k (optimum-k n m)))
115                                         (calc-p (p-false-positive k n m)))
116                        (if (<= calc-p p) (values m k calc-p)
117        (loop (fx+ m n))))) )
118
119(define (actual-k mdps)
120        (fold
121                (lambda (len tot) (fx+ tot (fx/ len unsigned-integer32-size)))
122                0
123                (message-digest-primitive-lengths mdps)) )
124
125;;; Bloom Filter
126
127(define (bloom-filter? obj)
128        (%bloom-filter? obj) )
129
130(define-check+error-type bloom-filter)
131
132(define (bloom-filter-n bf)
133        (check-bloom-filter 'bloom-filter-n bf)
134        (%bloom-filter-n bf) )
135
136(define (bloom-filter-m bf)
137        (check-bloom-filter 'bloom-filter-m bf)
138        (%bloom-filter-m bf) )
139
140(define (bloom-filter-k bf)
141        (check-bloom-filter 'bloom-filter-k bf)
142        (%bloom-filter-k bf) )
143
144(define (make-bloom-filter m mdps #!optional des-k)
145        (ensure-positive-fixnum 'make-bloom-filter m)
146  (for-each (cut check-message-digest-primitive 'make-bloom-filter <>) mdps)
147        (let ((make-mdp
148          (lambda (mdp)
149            (lambda (obj)
150              (message-digest->integers
151                (message-digest-object mdp obj 'string)
152                m) ) ) ) )
153                (let ((act-k (actual-k mdps)))
154                        (if (not des-k) (set! des-k act-k)
155          (begin
156            (ensure-positive-fixnum 'make-bloom-filter des-k)
157            (when (fx< act-k des-k)
158              (error 'make-bloom-filter "insufficient hash functions" act-k des-k) ) ) )
159                        (%make-bloom-filter
160                          0 m des-k 
161        #;(make-iset 0 (fx-- m)) ;unsuccessful test w/ isets
162        (make-bit-vector m)
163        (map (cut make-mdp <>) mdps)
164        mdps))) )
165
166(define (bloom-filter-p-false-positive bf . n)
167        (check-bloom-filter 'bloom-filter-p-false-positive bf)
168        (bloom-filter-p-false-positive
169                (%bloom-filter-k bf)
170                (optional n (%bloom-filter-n bf))
171                (%bloom-filter-m bf)) )
172
173(define (bloom-filter-set! bf obj)
174        (check-bloom-filter 'bloom-filter-set! bf)
175  (%bloom-filter-bits-set!
176    bf
177    (bloom-filter-fold
178      bf
179      (lambda (idx bits) (bit-vector-set! bits idx #t))
180      (%bloom-filter-bits bf)
181      obj))
182        (%bloom-filter-n-set! bf (fx++ (%bloom-filter-n bf)))
183        (void) )
184
185(define (bloom-filter-exists? bf obj)
186        (check-bloom-filter 'bloom-filter-exists? bf)
187        (let ((bits (%bloom-filter-bits bf)))
188          (fx=
189      (bloom-filter-fold
190        bf
191        (lambda (idx cnt) (if (bit-vector-ref bits idx) (fx++ cnt) cnt))
192        0
193        obj)
194      (%bloom-filter-k bf)) ) )
195
196#| ;inaccurate
197(define (bloom-filter-set! bf obj)
198        (check-bloom-filter 'bloom-filter-set! bf)
199  (%bloom-filter-bits-set!
200    bf
201    (list->iset! (bloom-filter-k-indices bf obj) (%bloom-filter-bits bf)))
202        (%bloom-filter-n-set! bf (fx++ (%bloom-filter-n bf)))
203        (void) )
204
205#; ;loops
206(define (bloom-filter-exists? bf obj)
207        (check-bloom-filter 'bloom-filter-exists? bf)
208  (fx=
209    (iset-size
210      (iset-intersection
211        (%bloom-filter-bits bf)
212        (list->iset (bloom-filter-k-indices bf obj))))
213    (%bloom-filter-k bf)) )
214
215(define (bloom-filter-exists? bf obj)
216        (check-bloom-filter 'bloom-filter-exists? bf)
217        (let ((bits (%bloom-filter-bits bf)))
218    (fx=
219      (fold
220        (lambda (idx cnt) (if (iset-contains? bits idx) (fx++ cnt) cnt))
221        0
222        (bloom-filter-k-indices bf obj))
223      (%bloom-filter-k bf)) ) )
224|#
225
226) ;module bloom-filter
Note: See TracBrowser for help on using the repository browser.