codepad

Language:

; busy beaver

(define (make-hash hash eql? oops size)
  (let ((table (make-vector size '())))
    (lambda (message . args)
      (if (eq? message 'enlist)
          (let loop ((k 0) (result '()))
            (if (= size k)
                result
                (loop (+ k 1) (append (vector-ref table k) result))))
          (let* ((key (car args))
                 (index (modulo (hash key) size))
                 (bucket (vector-ref table index)))
            (case message
              ((lookup fetch get ref recall)
                (let loop ((bucket bucket))
                  (cond ((null? bucket) oops)
                        ((eql? (caar bucket) key) (cdar bucket))
                        (else (loop (cdr bucket))))))
              ((insert insert! ins ins! set set! store store! install install!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (cadr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key (cadr args)) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((delete delete! del del! remove remove!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket) '())
                          ((eql? (caar bucket) key)
                            (cdr bucket))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((update update!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (caddr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key ((cadr args) key (cdar bucket))) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              (else (error 'hash-table "unrecognized message")) ))))))

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define blanks
  (let ((x (list #\space)))
    (set-cdr! x x)
    (cons x x)))

(define (read-cell tape) (cadr tape))

(define (write-cell chr tape)
  (cons (car tape) (cons chr (cddr tape))))

(define (move-left tape)
  (cons (cdar tape) (cons (caar tape) (cdr tape))))

(define (move-right tape)
  (cons (cons (cadr tape) (car tape)) (cddr tape)))

(define (make-tape chrs curr)
  (define (insert-cell chr tape)
    (cons (car tape) (cons chr (cdr tape))))
  (let loop ((curr curr) (chrs (reverse (string->list chrs))) (tape blanks))
    (cond ((= curr -1) (move-left tape))
          ((null? chrs) (loop (- curr 1) chrs (move-right tape)))
          (else (loop curr (cdr chrs) (insert-cell (car chrs) tape))))))

(define (show-tape tape)
  (let loop ((xs (car tape)) (k 0) (zs (list)))
    (if (= k 10) (display (drop 10 zs))
      (if (char=? (car xs) #\space)
          (loop (cdr xs) (+ k 1) (cons (car xs) zs))
          (loop (cdr xs) 0 (cons (car xs) zs)))))
  (display (cadr tape))
  (let loop ((xs (cddr tape)) (k 0) (zs (list)))
    (if (= k 10) (display (reverse (drop 10 zs)))
      (if (char=? (car xs) #\space)
          (loop (cdr xs) (+ k 1) (cons (car xs) zs))
          (loop (cdr xs) 0 (cons (car xs) zs)))))
  (newline))

(define (hash-state-symbol key)
  (+ (* (car key) 256) (char->integer (cadr key))))

(define (make-prog tuples)
  (let ((prog (make-hash hash-state-symbol equal? #f 97)))
    (do ((tuples tuples (cdr tuples)))
        ((null? tuples) prog)
      (prog 'insert (take 2 (car tuples)) (drop 2 (car tuples))))))

(define (show-beaver k state cmd tape)
  (display k) (display " ") (display state) (display " ")
  (display cmd) (display " ") (show-tape tape))

(define (turing prog tape)
  (let loop ((k 0) (state 0) (tape tape))
    (if (negative? state) (show-beaver k state "final" tape)
      (let ((cmd (prog 'lookup (list state (read-cell tape)))))
        (show-beaver k state cmd tape)
        (loop (+ k 1) (caddr cmd) (case (cadr cmd)
          ((left) (move-left (write-cell (car cmd) tape)))
          ((right) (move-right (write-cell (car cmd) tape)))
          (else (write-cell (car cmd) tape))))))))

(define (beaver bb) (turing (make-prog bb) (make-tape "" 0)))

(define bb1 '(
  (0 #\space #\*     right -1)))

(define bb2 '(
  (0 #\space #\*     right  1)
  (0 #\*     #\*     left   1)
  (1 #\space #\*     left   0)
  (1 #\*     #\*     right -1)))

(define bb3 '(
  (0 #\space #\*     right  1)
  (0 #\*     #\*     right -1)
  (1 #\space #\space right  2)
  (1 #\*     #\*     right  1)
  (2 #\space #\*     left   2)
  (2 #\*     #\*     left   0)))

(define bb4 '(
  (0 #\space #\*     right  1)
  (0 #\*     #\*     left   1)
  (1 #\space #\*     left   0)
  (1 #\*     #\space left   2)
  (2 #\space #\*     right -1)
  (2 #\*     #\*     left   3)
  (3 #\space #\*     right  3)
  (3 #\*     #\space right  0)))

(beaver bb1) (newline)
(beaver bb2) (newline)
(beaver bb3) (newline)
(beaver bb4)

Private [?]

Run code