source: project/release/4/sfht/trunk/sfht.scm @ 14491

;; 
;;
;; A dictionary structure implemented with a counting Bloom filter.
;;
;; Based on the Shared-node Fast Hash Table (SFHT) data structure
;; described by Song, et al., in _Fast Hash Table Lookup Using
;; Extended Bloom Filter: An Aid to Network Processing_. (SIGCOMM'05)
;;
;; 
;; Copyright 2007-2009 Ivan Raikov.
;;
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>."))))
;;

(module sfht 

  (make-sfht)

  (import scheme chicken data-structures)

  (require-extension srfi-1 matchable sparse-vectors)

(define ln06185 (log 0.6185))
(define ln05 (log 0.5))

(define (sfht:error x . rest)
  (let ((port (open-output-string)))
    (let loop ((objs (cons x rest)))
      (if (null? objs)
          (begin
            (newline port)
            (error 'sfht (get-output-string port)))
          (begin (display (car objs) port)
                 (display " " port)
                 (loop (cdr objs)))))))

(define (make-sfht n p make-random-state random! key->vector key-vector-ref key-vector-length . rest)

  (let-optionals rest ((key-equal? equal?))

    (define m (round (+ 1.0 (* (* n (log p)) ln06185))))
    (define k (inexact->exact (round (+ 0.5 (/ (log p) ln05)))))

    (define default (list 0 (list)))
    
    (define ba (make-sparse-vector default))
    
    (define size 0)
    
    ;; Hash functions based on uniform pseudo-random numbers
    (define rng-states (list-tabulate k (lambda (i) 
                                          (make-random-state i))))

    ;; Pre-calculate hash function coefficients for vectors of size up
    ;; to 127 elements
    (define H 127)

    (define random-coeffs
      (map (lambda (st) 
             (list-tabulate H (lambda (x) (random! st))))
           rng-states))

    (define (extend-random-coeffs! H1)
      (let ((d (- H1 H)))
        (if (< d 1) (sfht:error 'extend-random-coeffs! 
                                ": the new number of coefficients is less than the old one"))
        (let ((cfs1 (map (lambda (st cfs) 
                           (let ((cfs1 (list-tabulate d (lambda (x) (random! st)))))
                             (append cfs cfs1)))
                         rng-states random-coeffs)))
          (set! random-coeffs cfs1)
          (set! H H1))))

    (define (and-coeffs h kv)
      (let loop ((i 0) (h h) (ax (list)))
        (if (null? h) (reverse ax)
            (loop (fx+ 1 i) (cdr h) (cons (* (car h) (key-vector-ref kv i)) ax)))))
    
    (define (hash key k n) 
      (let* ((kv   (key->vector key))
             (kvl  (key-vector-length kv)))
        (if (fx> kvl H)
            (extend-random-coeffs! kvl))
        (if (fx= kvl 0) (map car random-coeffs)
            (let loop ((i 0) (hh random-coeffs) (ax (list)))
              (if (null? hh) 
                  (map (lambda (lst) (apply bitwise-xor lst)) (reverse ax))
                  (loop (fx+ 1 i) (cdr hh)
                        (cons (and-coeffs (car hh) kv) ax)))))))

    (define (insert! key x)
      (let ((h  (hash key k n))
            (b  (cons (cons key x) (list))))
        (let loop ((i h))
          (if (not (null? i))
              (let* ((index  (car i))
                     (bkt    (sparse-vector-ref ba index)))
                (let-values (((sz lst) (match bkt
                                              ((sz lst)  (values sz lst))
                                              (else (sfht:error 'insert! ": invalid bucket " bkt " at index " index)))))
                            (if (fx= 0 sz)
                                (sparse-vector-set! ba index (list 1 (list (cons key x))))
                                (beginxb
                                  (let tail ((k sz) (lst lst) (prev #f))
                                    (if (null? lst)
                                        (let ((b (list (cons key x))))
                                          (if prev (set-cdr! prev b) (set-cdr! bkt b)))
                                        (if (fx<= k 0)
                                            (set-cdr! bkt (cons (cons key x) (cdr bkt)))
                                            (tail (fx- k 1) (cdr lst) lst))))
                                  (set-car! bkt (fx+ 1 (car bkt)))))
                            (loop (cdr i))))))
        (set! size (fx+ 1 size))
        #f))
      
    (define (delete! key)
      (define found? #f)
      (let ((h  (hash key k n)))
        (let loop ((i h))
          (if (not (null? i))
              (let* ((index  (car i))
                     (bkt    (sparse-vector-ref ba index)))
                (let-values (((sz lst) (match bkt
                                              ((sz lst)  (values sz lst))
                                              (else (sfht:error 'remove! ": invalid bucket " bkt " at index " i)))))
                  (let bktloop ((k sz) (lst lst) (prev #f))
                    (if (not (null? lst))
                        (if (fx< 0 k)
                            (match lst
                                   (((key1 . _) . rest)
                                    (if (key-equal? key key1)
                                        (begin
                                          (set! found? #t)
                                          (set-car! bkt (fx- (car bkt) 1))
                                          (if prev (set-cdr! prev rest) (set-cdr! bkt (list rest))))
                                        (bktloop (fx- k 1) rest lst)))
                                   (else (sfht:error 'remove! ": invalid bucket list " lst)))))))
                (loop (cdr i)))))
        (if found? (set! size (fx- size 1)))
        found?))

    (define (min-bucket bkts . rest)
      (let-optionals rest ((minb (or (null? bkts) (car bkts))))
                     (if (null? bkts) minb
                         (let ((bkt (car bkts)))
                           (if (fx< (car bkt) (car minb))
                               (min-bucket (cdr bkts) bkt)
                               (min-bucket (cdr bkts) minb))))))
    
    (define (find key)
      (let* ((h     (hash key k n))
             (bkts  (map (lambda (i) (sparse-vector-ref ba i)) h))
             (minb  (min-bucket bkts)))
        (let loop ((k (car minb)) (lst (cadr minb)))
          (if (or (fx= 0 k) (null? lst)) #f
              (match  lst
                     (((key1 . _) . rest)
                      (if (key-equal? key key1) (car lst)
                          (loop (fx- k 1) rest)))
                     (else (sfht:error 'find ": invalid bucket list " lst)))))))
    
     (define (debugprint)
       (let ((bkts (sparse-vector->list ba)))
         (for-each 
          (lambda (bkt)
            (display "bucket:")
            (display " sz = ")
            (display (car bkt))
            (display " lst = ")
            (display (cdr bkt))
            (display #\newline))
          bkts)))
        
    
    (define (apply-default-clause src key default-clause)
      (cond
       ((null? default-clause)
        (sfht:error src ": key " key " was not found in the SFHT "))
       ((procedure? (car default-clause)) ((car default-clause)))
       (else (car default-clause))))
    
    
    ;; Dispatcher
    (lambda (selector)
      (case selector
        ((get)
         (lambda (key . default-clause)
           (or (find key) (apply-default-clause 'get key default-clause))))
        
        ((delete!)
         (lambda (key . default-clause)
           (or (delete! key) (apply-default-clause 'delete! key default-clause))))
        
        ((put!) insert!)
        
        ((empty?) (fx= size 0))
        
        ((size)   size)
        
        ((clear!)  (begin
                     (set! ba (make-sparse-vector default))
                     (set! size 0)))
        
        ((debugprint) (debugprint))
        (else
         (sfht:error "Unknown message " selector " sent to an SFHT"))))))
    
)