(define (make-hash hash eql? oops size)
(define (lookup x xs)
(cond ((null? xs) oops)
((eql? x (caar xs)) (cdar xs))
(else (lookup x (cdr xs)))))
(let ((table (make-vector size '())))
(lambda (message key . val)
(let* ((index (modulo (hash key) size))
(alist (vector-ref table index)))
(case message
((show) (do ((i 0 (+ i 1))) ((= i size))
(display i) (display " ")
(display (vector-ref table i))
(newline)))
((insert!) (vector-set! table index
(cons (cons key (car val)) alist)))
((lookup) (lookup key alist)))))))
(define (string-hash str)
(let loop ((cs (string->list str)) (s 0))
(if (null? cs) s
(loop (cdr cs) (+ (* s 31)
(char->integer (car cs)))))))
(define (read-word)
(let loop ((c (read-char)) (cs '()))
(cond ((eof-object? c)
(if (null? cs) c
(list->string (reverse cs))))
((not (char-whitespace? c))
(loop (read-char) (cons c cs)))
((pair? cs) (list->string (reverse cs)))
(else (loop (read-char) cs)))))
(define (make-key w1 w2)
(string-append w1 (string #\tab) w2))
(define state-tab (make-hash string-hash string=? '() 4093))
(define (build-state-tab filename)
(with-input-from-file filename
(lambda ()
(let loop ((w1 "") (w2 "") (key (make-key "" "")) (w3 (read-word)))
(if (eof-object? w3)
(state-tab 'insert! key
(cons "" (state-tab 'lookup key)))
(begin (state-tab 'insert! key
(cons w3 (state-tab 'lookup key)))
(loop w2 w3 (make-key w2 w3) (read-word))))))))
(define rand
(let ((a 69069) (c 5)
(m (expt 2 32))
(seed 17070415))
(lambda s
(set! seed (modulo
(if (pair? s)
(numerator (inexact->exact (car s)))
(+ (* a seed) c)) m))
(/ seed m))))
(define (rand-item xs)
(let loop ((n 2) (x (car xs)) (xs (cdr xs)))
(cond ((null? xs) x)
((< (rand) (/ n))
(loop (+ n 1) (car xs) (cdr xs)))
(else (loop (+ n 1) x (cdr xs))))))
(define (walk n)
(let loop ((w1 "") (w2 "") (n n) (ws '()))
(let* ((key (make-key w1 w2))
(w3 (rand-item (state-tab 'lookup key))))
(if (or (string=? w3 "") (zero? n))
(reverse ws)
(loop w2 w3 (- n 1) (cons w3 ws))))))
(define (fmt ws)
(let loop ((n 60) (ws ws))
(cond ((null? ws) (newline))
((< n (string-length (car ws)))
(newline) (loop 60 ws))
(else (display (car ws)) (display " ")
(loop (- n (string-length (car ws)) 1) (cdr ws))))))
(define (shaney file-name n)
(build-state-tab file-name)
(fmt (walk n)))