codepad

Language:

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

Private [?]

Run code