source: project/sfht/trunk/sfht.scm @ 6192

Last change on this file since 6192 was 6192, checked in by Ivan Raikov, 12 years ago

Created an RNG-independent interface.

File size: 6.5 KB
Line 
1;;
2;;
3;; A dictionary structure implemented with a counting Bloom filter.
4;;
5;; Based on the Shared-node Fast Hash Table (SFHT) data structure
6;; described by Song, et al., in _Fast Hash Table Lookup Using
7;; Extended Bloom Filter: An Aid to Network Processing_. (SIGCOMM'05)
8;;
9;;
10;; Copyright 2007 Ivan Raikov
11;;
12;;
13;; This program is free software: you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
17;;
18;; This program is distributed in the hope that it will be useful, but
19;; WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21;; General Public License for more details.
22;;
23;; A full copy of the GPL license can be found at
24;; <http://www.gnu.org/licenses/>."))))
25;;
26
27(require-extension srfi-1)
28(require-extension sparse-vectors)
29
30(define-extension sfht)
31
32(define ln06185 (log 0.6185))
33(define ln05 (log 0.5))
34
35(define (sfht:error x . rest)
36  (let ((port (open-output-string)))
37    (let loop ((objs (cons x rest)))
38      (if (null? objs)
39          (begin
40            (newline port)
41            (error 'sfht (get-output-string port)))
42          (begin (display (car objs) port)
43                 (display " " port)
44                 (loop (cdr objs)))))))
45
46(define (make-sfht n p make-random-state random! key->vector key-vector-ref key-vector-length . rest)
47
48  (let-optionals rest ((key-equal? equal?))
49
50    (define m (round (+ 1.0 (* (* n (log p)) ln06185))))
51    (define k (inexact->exact (round (+ 0.5 (/ (log p) ln05)))))
52
53    (define default (list 0 (list)))
54   
55    (define ba (make-sparse-vector default))
56   
57    (define size 0)
58   
59    ;; Hash functions based on uniform pseudo-random numbers
60    (define rng-states (list-tabulate k (lambda (i) (make-random-state i))))
61
62    ;; Pre-calculate hash function coefficients for vectors of size up
63    ;; to 127 elements
64    (define H 127)
65
66    (define random-coeffs
67      (map (lambda (st) (list-tabulate H (lambda (x) (random! st))))
68           rng-states))
69
70    (define (extend-random-coeffs! H1)
71      (let ((d (- H1 H)))
72        (if (< d 1) (sfht:error 'extend-random-coeffs! 
73                                ": the new number of coefficients is less than the old one"))
74        (let ((cfs1 (map (lambda (st cfs) 
75                           (let ((cfs1 (list-tabulate d (lambda (x) (random! st)))))
76                             (append cfs cfs1)))
77                         rng-states random-coeffs)))
78          (set! random-coeffs cfs1)
79          (set! H H1))))
80
81    (define (and-coeffs h kv)
82      (let loop ((i 0) (h h) (ax (list)))
83        (if (null? h) (reverse ax)
84            (loop (fx+ 1 i) (cdr h) (cons (* (car h) (key-vector-ref kv i)) ax)))))
85   
86    (define (hash key k n) 
87      (let* ((kv   (key->vector key))
88             (kvl  (key-vector-length kv)))
89        (if (fx> kvl H)
90            (extend-random-coeffs! kvl))
91        (if (fx= kvl 0) (map car random-coeffs)
92            (let loop ((i 0) (hh random-coeffs) (ax (list)))
93              (if (null? hh) 
94                  (map (lambda (lst) (apply bitwise-xor lst)) (reverse ax))
95                  (loop (fx+ 1 i) (cdr hh)
96                        (cons (and-coeffs (car hh) kv) ax)))))))
97
98    (define (insert! key x)
99      (let ((h  (hash key k n))
100            (b  (cons (cons key x) (list))))
101        (let loop ((i h))
102          (if (not (null? i))
103              (let* ((index  (car i))
104                     (bkt    (sparse-vector-ref ba index)))
105                (let-values (((sz lst) (match bkt
106                                              ((sz lst)  (values sz lst))
107                                              (else (sfht:error 'insert! ": invalid bucket " bkt " at index " index)))))
108                            (if (fx= 0 sz)
109                                (sparse-vector-set! ba index (list 1 (list (cons key x))))
110                                (begin
111                                  (let tail ((k sz) (lst lst) (prev #f))
112                                    (if (null? lst)
113                                        (let ((b (list (cons key x))))
114                                          (if prev (set-cdr! prev b) (set-cdr! bkt b)))
115                                        (if (fx<= k 0)
116                                            (set-cdr! bkt (cons (cons key x) (cdr bkt)))
117                                            (tail (fx- k 1) (cdr lst) lst))))
118                                  (set-car! bkt (fx+ 1 (car bkt)))))
119                            (loop (cdr i))))))
120        (set! size (fx+ 1 size))
121        #f))
122     
123    (define (delete! key)
124      (define found? #f)
125      (let ((h  (hash key k n)))
126        (let loop ((i h))
127          (if (not (null? i))
128              (let* ((index  (car i))
129                     (bkt    (sparse-vector-ref ba index)))
130                (let-values (((sz lst) (match bkt
131                                              ((sz lst)  (values sz lst))
132                                              (else (sfht:error 'remove! ": invalid bucket " bkt " at index " i)))))
133                  (let bktloop ((k sz) (lst lst) (prev #f))
134                    (if (not (null? lst))
135                        (if (fx< 0 k)
136                            (match lst
137                                   (((key1 . _) . rest)
138                                    (if (key-equal? key key1)
139                                        (begin
140                                          (set! found? #t)
141                                          (set-car! bkt (fx- (car bkt) 1))
142                                          (if prev (set-cdr! prev rest) (set-cdr! bkt (list rest))))
143                                        (bktloop (fx- k 1) rest lst)))
144                                   (else (sfht:error 'remove! ": invalid bucket list " lst)))))))
145                (loop (cdr i)))))
146        (if found? (set! size (fx- size 1)))
147        found?))
148
149    (define (min-bucket bkts . rest)
150      (let-optionals rest ((minb (or (null? bkts) (car bkts))))
151                     (if (null? bkts) minb
152                         (let ((bkt (car bkts)))
153                           (if (fx< (car bkt) (car minb))
154                               (min-bucket (cdr bkts) bkt)
155                               (min-bucket (cdr bkts) minb))))))
156   
157    (define (find key)
158      (let* ((h     (hash key k n))
159             (bkts  (map (lambda (i) (sparse-vector-ref ba i)) h))
160             (minb  (min-bucket bkts)))
161        (let loop ((k (car minb)) (lst (cadr minb)))
162          (if (or (fx= 0 k) (null? lst)) #f
163              (match  lst
164                     (((key1 . _) . rest)
165                      (if (key-equal? key key1) (car lst)
166                          (loop (fx- k 1) rest)))
167                     (else (sfht:error 'find ": invalid bucket list " lst)))))))
168   
169     (define (debugprint)
170       (let ((bkts (sparse-vector->list ba)))
171         (for-each
172          (lambda (bkt)
173            (display "bucket:")
174            (display " sz = ")
175            (display (car bkt))
176            (display " lst = ")
177            (display (cdr bkt))
178            (display #\newline))
179          bkts)))
180       
181   
182    (define (apply-default-clause src key default-clause)
183      (cond
184       ((null? default-clause)
185        (sfht:error src ": key " key " was not found in the SFHT "))
186       ((procedure? (car default-clause)) ((car default-clause)))
187       (else (car default-clause))))
188   
189   
190    ;; Dispatcher
191    (lambda (selector)
192      (case selector
193        ((get)
194         (lambda (key . default-clause)
195           (or (find key) (apply-default-clause 'get key default-clause))))
196       
197        ((delete!)
198         (lambda (key . default-clause)
199           (or (delete! key) (apply-default-clause 'delete! key default-clause))))
200       
201        ((put!) insert!)
202       
203        ((empty?) (fx= size 0))
204       
205        ((size)   size)
206       
207        ((clear!)  (begin
208                     (set! ba (make-sparse-vector default))
209                     (set! size 0)))
210       
211        ((debugprint) (debugprint))
212        (else
213         (sfht:error "Unknown message " selector " sent to an SFHT"))))))
214   
215
216
Note: See TracBrowser for help on using the repository browser.