; 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)