[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/LIYEw8xo    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Jan 29:
; cuckoo hashing

(define (prime? n) ; baillie-wagstaff
  (define (expm b e m)
    (define (times x y) (modulo (* x y) m))
    (cond ((zero? e) 1) ((even? e) (expm (times b b) (/ e 2) m))
    (else (times b (expm (times b b) (/ (- e 1) 2) m)))))
  (define (digits n)
    (let loop ((n n) (ds '()))
      (if (zero? n) ds (loop (quotient n 2) (cons (modulo n 2) ds)))))
  (define (isqrt n)
    (let loop ((x n) (y (quotient (+ n 1) 2)))
      (if (<= 0 (- y x) 1) x (loop y (quotient (+ y (quotient n y)) 2)))))
  (define (square? n) (let ((n2 (isqrt n))) (= n (* n2 n2))))
  (define (jacobi a n)
    (let loop ((a a) (n n))
      (cond ((= a 0) 0) ((= a 1) 1)
            ((= a 2) (case (modulo n 8) ((1 7) 1) ((3 5) -1)))
            ((even? a) (* (loop 2 n) (loop (/ a 2) n)))
            ((< n a) (loop (modulo a n) n))
            ((and (= (modulo a 4) 3) (= (modulo n 4) 3)) (- (loop n a)))
            (else (loop n a)))))
  (define (inverse x m)
    (let loop ((a 1) (b 0) (g x) (u 0) (v 1) (w m))
      (if (zero? w) (modulo a m)
        (let ((q (quotient g w)))
          (loop u v w (- a (* q u)) (- b (* q v)) (- g (* q w)))))))
  (define (strong-pseudo-prime? n a)
    (let loop ((r 0) (s (- n 1)))
      (if (even? s) (loop (+ r 1) (/ s 2))
        (if (= (expm a s n) 1) #t
          (let loop ((r r) (s s))
            (cond ((zero? r) #f) ((= (expm a s n) (- n 1)) #t)
            (else (loop (- r 1) (* s 2)))))))))
  (define (chain m f g u v)
    (let loop ((ms (digits m)) (u u) (v v))
      (cond ((null? ms) (values u v))
            ((zero? (car ms)) (loop (cdr ms) (f u) (g u v)))
            (else (loop (cdr ms) (g u v) (f v))))))
  (define (lucas-pseudo-prime? n)
    (let loop ((a 11) (b 7))
      (let ((d (- (* a a) (* 4 b))))
        (cond ((square? d) (loop (+ a 2) (+ b 1)))
              ((not (= (gcd n (* 2 a b d)) 1)) (loop (+ a 2) (+ b 2)))
              (else (let* ((x1 (modulo (- (* a a (inverse b n)) 2) n))
                           (m (quotient (- n (jacobi d n)) 2))
                           (f (lambda (u) (modulo (- (* u u) 2) n)))
                           (g (lambda (u v) (modulo (- (* u v) x1) n))))
                      (let-values (((xm xm1) (chain m f g 2 x1)))
                        (zero? (modulo (- (* x1 xm) (* 2 xm1)) n)))))))))
    (if (not (integer? n)) (error 'prime? "must be integer")
      (if (< n 2) #f (if (even? n) (= n 2) (if (zero? (modulo n 3)) (= n 3)
        (and (strong-pseudo-prime? n 2)
             (strong-pseudo-prime? n 3)
             (lucas-pseudo-prime? n)))))))

(define (next-prime n)
  (cond ((< n 2) 2) ((< n 3) 3)
  (else (let loop ((n (+ (if (even? n) 1 2) n)))
          (if (prime? n) n (loop (+ n 2)))))))

(define (ilog b n)
  (let loop1 ((lo 0) (b^lo 1) (hi 1) (b^hi b))
    (if (< b^hi n) (loop1 hi b^hi (* hi 2) (* b^hi b^hi))
      (let loop2 ((lo lo) (b^lo b^lo) (hi hi) (b^hi b^hi))
        (if (<= (- hi lo) 1) (if (= b^hi n) hi lo)
          (let* ((mid (quotient (+ lo hi) 2))
                 (b^mid (* b^lo (expt b (- mid lo)))))
            (cond ((< n b^mid) (loop2 lo b^lo mid b^mid))
                  ((< b^mid n) (loop2 mid b^mid hi b^hi))
                  (else mid))))))))

(define-syntax assert
  (syntax-rules ()
    ((assert expr result)
      (if (not (equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

(define (string-hash str x)
  (let loop ((cs (string->list str)) (h 0))
    (if (null? cs) h
      (loop (cdr cs) (+ (* h x)
        (char->integer (car cs)))))))

(define (reset-multipliers)
  (set! x1 (next-prime x2))
  (set! x2 (next-prime x1)))

(define (lookup table key)
  (let ((h (modulo (string-hash key x1) table-size)))
    (if (and (pair? (vector-ref table h))
             (string=? (car (vector-ref table h)) key))
        (vector-ref table h)
        (let ((h (modulo (string-hash key x2) table-size)))
          (if (and (pair? (vector-ref table h))
                   (string=? (car (vector-ref table h)) key))
              (vector-ref table h)
              '())))))

(define (insert table key value)
  (define (hash key x) (modulo (string-hash key x) table-size))
  (if (pair? (lookup table key))
      (let ((h1 (hash key x1)) (h2 (hash key x2)))
        (if (= (car (vector-ref table h1)) key)
            (begin (vector-set! table h1 (cons key value)) table)
            (begin (vector-set! table h2 (cons key value)) table)))
      (let loop ((key key) (value value) (count max-probes))
        (let ((h1 (hash key x1)) (h2 (hash key x2)))
          (cond ((null? (vector-ref table h1))
                  (vector-set! table h1 (cons key value)) table)
                ((null? (vector-ref table h2))
                  (vector-set! table h2 (cons key value)) table)
                ((zero? count)
                  (set! table (rehash table))
                  (insert table key value))
                (else (let ((t (vector-ref table h1)))
                        (vector-set! table h1 (cons key value))
                        (loop (car t) (cdr t) (- count 1)))))))))

(define (rehash table)
  (reset-multipliers)
  (let loop ((new-table (make-vector table-size '())) (i 0))
    (if (= i table-size) new-table
      (let ((t (vector-ref table i)))
        (if (pair? t)
            (loop (insert new-table (car t) (cdr t)) (+ i 1))
            (loop new-table (+ i 1)))))))

(define (delete table key)
  (let ((h (modulo (string-hash key x1) table-size)))
    (if (and (pair? (vector-ref table h))
             (string=? (car (vector-ref table h)) key))
        (vector-set! table h '())
        (let ((h (modulo (string-hash key x2) table-size)))
          (if (and (pair? (vector-ref table h))
                   (string=? (car (vector-ref table h)) key))
              (vector-set! table h '())))))
  table)

(define x1 #f)
(define x2 #f)
(define table-size #f)
(define max-probes #f)

(define (make-hash max-size)
  (set! x1 31) (set! x2 37)
  (set! table-size (next-prime (* 2 max-size)))
  (set! max-probes (max (* (ilog 2 max-size) 2) 20))
  (make-vector table-size '()))

(define (enlist table)
  (let loop ((i 0) (xs '()))
    (if (= i table-size) xs
      (let ((t (vector-ref table i)))
        (loop (+ i 1) (if (pair? t) (cons t xs) xs))))))

(define words '("alpha" "bravo" "charlie" "delta" "echo"
  "foxtrot" "golf" "hotel" "india" "juliet" "kilo" "lima"
  "mike" "november" "oscar" "papa" "quebec" "romeo" "sierra"
  "tango" "uniform" "victor" "whiskey" "xray" "yankee" "zulu"))

(define (cuckoo-test)
  (let ((t (make-hash 25)))
    (assert (lookup t "praxis") '())
    (let loop ((words words) (val 1))
      (when (pair? words)
        (set! t (insert t (car words) val))
        (loop (cdr words) (+ val 1))))
    (assert (lookup t "praxis") '())
    (assert (cdr (lookup t "papa")) 16)
    (set! t (delete t "papa"))
    (assert (lookup t "papa") '())))

(cuckoo-test)


Output:
No errors or program output.


Create a new paste based on this one


Comments: