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

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

Changed to chicken-setup tests directory structure.

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