source: project/bloom-filter/bloom-filter.scm @ 5443

Last change on this file since 5443 was 5443, checked in by Kon Lovett, 13 years ago

Chg for misc-extn 3.0

File size: 7.5 KB
Line 
1;;;; bloom-filter.scm
2;;;; Kon Lovett, Jun '06
3
4;; Issues
5;;
6;; - Not optimal for 64-bit machines.
7;;
8;; - Note the use of "in-place" list mutators, '(*! ...). Be verwy careful.
9;;
10;; - Although K may be lower the actual number of hash functions
11;; all are generated anyway. It is up to the caller to optimize.
12;;
13;; - Should unavailable message-digests be an error, rather than a warning?
14;;
15;; - No ability to add message-digest-primitives at runtime.
16
17(use srfi-1 utils)
18(use iset message-digest hash-utils lookup-table misc-extn-control misc-extn-numeric misc-extn-record mathh-int)
19
20(eval-when (compile)
21        (declare
22                (usual-integrations)
23                (generic)
24                (inline)
25                (no-procedure-checks)
26                (no-bound-checks)
27                (constant
28                        bloom-filter:optimum-k
29                        bloom-filter:optimum-m
30                        bloom-filter:p-random-one-bit
31                        bloom-filter:p-false-positive
32                        bloom-filter:desired-m
33                        bloom-filter:actual-k
34                        bloom-filter?)
35                (export
36                        bloom-filter:optimum-k
37                        bloom-filter:optimum-m
38                        bloom-filter:p-random-one-bit
39                        bloom-filter:p-false-positive
40                        bloom-filter:desired-m
41                        bloom-filter:actual-k
42                        make-bloom-filter
43                        bloom-filter?
44                        bloom-filter-n
45                        bloom-filter-m
46                        bloom-filter-k
47                        bloom-filter-p-false-positive
48                        bloom-filter-set!
49                        bloom-filter-exists?) ) )
50
51;;;
52
53(include "mathh-constants")
54
55;;; Record Type
56
57(define-inline-unchecked-record-type bloom-filter
58        (%make-bloom-filter n m k bits hashes)
59        %bloom-filter?
60        (n %bloom-filter-n %bloom-filter-n-set!)
61        (m %bloom-filter-m)
62        (k %bloom-filter-k)
63        (bits %bloom-filter-bits %bloom-filter-bits-set!)
64        (hashes %bloom-filter-hashes) )
65
66;;; Internals
67
68(define (check-positive-integer obj loc)
69        (unless (and (integer? obj) (positive? obj) (<= obj most-positive-fixnum))
70                (error loc "not a positive integer" obj) ) )
71
72(define-macro (ensure-positive-fixnum N LOC)
73        `(begin
74                (check-positive-integer ,N ,LOC)
75                (set! ,N (inexact->exact ,N)) ) )
76
77(define (unavailable-warning kind obj)
78        (warning (conc kind " '" obj "' is unavailable")) )
79
80(define *message-digest-primitives* #f)
81
82(define (load-primitives-info)
83        (set! *message-digest-primitives*
84                (alist->dict
85                        (map!
86                                (lambda (prim-pair)
87                                        (let ([impt-pair (cdr prim-pair)])
88                                                `(,(car prim-pair) . ((#f . ,(car impt-pair)) . (#f . ,(cdr impt-pair)))) ) )
89                                (with-input-from-file
90                                        (make-pathname (repository-path) "hash-primitives-info")
91                                        read)))) )
92
93(define (make-message-digest-primitive-list mds)
94
95        (define fake-mdp
96                (make-message-digest-primitive
97                        0
98                        unsigned-integer32-size
99                        (lambda (ctxt)
100                                (void))
101                        (lambda (ctxt bytes count)
102                                (void))
103                        (lambda (ctxt result)
104                                (string-binary-unsigned-int32-set! result 0)
105                                (void))) )
106
107        (define (get-mdp prim-defn)
108                (let ([proc-pair (car prim-defn)]
109                                        [extn-pair (cdr prim-defn)])
110
111                        ; Load unit if necessary
112                        (unless (car extn-pair)
113                                (set-car! extn-pair #t)
114                                (condition-case (require (cdr extn-pair))
115                                        [exp () (set-car! extn-pair #f)]) )
116
117                        ; Get message-digest-primitive, if loaded & necessary
118                        ; This only works if a top-level binding!
119                        ; Modules are a problem, need to use 'module$name'
120                        (if (car extn-pair)
121                                (unless (car proc-pair)
122                                        (set-car! proc-pair
123                                                (condition-case (eval `(,(cdr proc-pair)))
124                                                        [exp () #f])) )
125                                (unavailable-warning 'unit (cdr extn-pair)) )
126
127                        ; Return message-digest-primitive
128                        (cond
129                                [(car proc-pair) => identity]
130                                [else
131                                        (unavailable-warning 'procedure (cdr proc-pair))
132                                        fake-mdp] ) ) )
133
134        (map
135                (lambda (md)
136                        (cond
137                                [(message-digest-primitive? md) md]
138                                [(dict-ref *message-digest-primitives* md)=> get-mdp]
139                                [else
140                                        (error "unknown message-digest" md)]))
141                mds) )
142
143(define-inline (make-message-digest-primitive-lengths-list mds)
144        (map!
145                message-digest-primitive-digest-length
146                (make-message-digest-primitive-list mds)) )
147
148(define-inline (message-digest->integer-list str restriction)
149        (map!
150                (lambda (str)
151                        (restriction (string-binary->unsigned-int32 str)))
152                (string->substring-list/shared str unsigned-integer32-size)) )
153
154(define-inline (bloom-filter-indicies-list bf obj)
155        (map
156                (lambda (hasher)
157                        (hasher obj))
158                (%bloom-filter-hashes bf)) )
159
160(define-inline (bloom-filter-index-for-each proc idxs-lst k)
161        (for-each proc (take! (apply append! idxs-lst) k)) )
162
163(define (bloom-filter-for-each bf proc obj)
164        (bloom-filter-index-for-each proc (bloom-filter-indicies-list bf obj) (%bloom-filter-k bf)) )
165
166;;; Argument Checking
167
168(define (check-bloom-filter obj loc)
169        (unless (%bloom-filter? obj)
170                (error loc "invalid bloom-filter" obj) ) )
171
172;;; Public Object Accessors
173
174(define (bloom-filter? obj)
175        (%bloom-filter? obj) )
176
177(define (bloom-filter-n bf)
178        (check-bloom-filter bf 'bloom-filter-n)
179        (%bloom-filter-n bf) )
180
181(define (bloom-filter-m bf)
182        (check-bloom-filter bf 'bloom-filter-m)
183        (%bloom-filter-m bf) )
184
185(define (bloom-filter-k bf)
186        (check-bloom-filter bf 'bloom-filter-k)
187        (%bloom-filter-k bf) )
188
189(define (make-bloom-filter m mds #!optional desired-k)
190        (ensure-positive-fixnum m 'make-bloom-filter)
191        (let (
192                        [make-mdp
193                                (lambda (mdp ranger)
194                                        (lambda (obj)
195                                                (message-digest->integer-list
196                                                        (message-digest-primitive-apply mdp obj 'bloom-filter)
197                                                        ranger) ) )])
198                (let* ([mdp-lst (make-message-digest-primitive-list mds)]
199                                         [actual-k (bloom-filter:actual-k mdp-lst)])
200                        (if desired-k
201                                (begin
202                                        (ensure-positive-fixnum desired-k 'make-bloom-filter)
203                                        (when (fx< actual-k desired-k)
204                                                (error 'make-bloom-filter
205                                                        "insufficient hash functions" actual-k desired-k) ) )
206                                (set! desired-k actual-k))
207                        (%make-bloom-filter 0 m desired-k
208                                (make-bit-vector m)
209                                (map
210                                        (cut make-mdp <>
211                                                (lambda (n)
212                                                        ; Hash functions return integers, and m is a fixnum, so 'inexact->exact'
213                                                        ; will produce a fixnum.
214                                                        (inexact->exact (modulo n m)) ))
215                                        mdp-lst)))) )
216
217;;; Calculators
218
219;; Actual optimal: (expt (* n (log2 (/ m (- m 1)))) -1)
220;; Returns the upper-bound, but w/ rounding
221
222(define (bloom-filter:optimum-k n m)
223        (inexact->exact (round (* LN2 (/ m n)))) )
224
225(define (bloom-filter:optimum-m k n)
226        (inexact->exact (round (/ (* n k) LN2))) )              ; Similar to above
227
228(define (bloom-filter:p-random-one-bit k n m)
229        (- 1 (expt (- 1 (/ 1 m)) (* k n))) )
230
231(define (bloom-filter:p-false-positive k n m)
232        (expt (bloom-filter:p-random-one-bit k n m) k) )
233
234(define (bloom-filter:desired-m p n . r)
235        (ensure-positive-fixnum n 'bloom-filter:desired-m)
236        (let loop ([m n])
237                (let* ([k (optional r (bloom-filter:optimum-k n m))]
238                                         [calc-p (bloom-filter:p-false-positive k n m)])
239                        (if (<= calc-p p)
240                                (values m k calc-p)
241                                (loop (fx+ m n))))) )
242
243(define (bloom-filter:actual-k mds)
244        (fold
245                (lambda (len accum)
246                        (fx+ accum (fx/ len unsigned-integer32-size)))
247                0
248                (make-message-digest-primitive-lengths-list mds)) )
249
250(define (bloom-filter-p-false-positive bf . n)
251        (check-bloom-filter bf 'bloom-filter-p-false-positive)
252        (bloom-filter:p-false-positive
253                (%bloom-filter-k bf)
254                (optional n (%bloom-filter-n bf))
255                (%bloom-filter-m bf)) )
256
257;;; Accessors
258
259(define (bloom-filter-set! bf obj)
260        (check-bloom-filter bf 'bloom-filter-set!)
261        (let ([bits (%bloom-filter-bits bf)])
262                (bloom-filter-for-each
263                        bf
264                        (lambda (idx)
265                                (set! bits (bit-vector-set! bits idx #t)))
266                        obj)
267                (%bloom-filter-bits-set! bf bits) )
268        (%bloom-filter-n-set! bf (fx++ (%bloom-filter-n bf)))
269        #t )
270
271(define (bloom-filter-exists? bf obj)
272        (check-bloom-filter bf 'bloom-filter-exists?)
273        (let ([bits (%bloom-filter-bits bf)]
274                                [cnt 0])
275                (bloom-filter-for-each
276                        bf
277                        (lambda (idx)
278                                (when (bit-vector-ref bits idx)
279                                        (fx++! cnt)))
280                        obj)
281                (fx= cnt (%bloom-filter-k bf))) )
282
283;;;
284;;; Module Init
285;;;
286
287(load-primitives-info)
Note: See TracBrowser for help on using the repository browser.