; turing machine adder

(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 ((tape tape) (k -1))
    (if (char=? (read-cell tape) #\space)
        (let loop ((tape (move-right tape)) (chrs '()))
          (if (char=? (read-cell tape) #\space)
              (values (list->string (reverse chrs)) k)
              (loop (move-right tape) (cons (read-cell tape) chrs))))
        (loop (move-left tape) (+ k 1)))))

(define adder '(
  (0 #\1     #\1     right 0)
  (0 #\+     #\1     right 1)
  (1 #\1     #\1     right 1)
  (1 #\space #\space left  2)
  (2 #\1     #\space left  -1)))

(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 (turing prog tape)
  (let loop ((state 0) (tape tape))
    (if (negative? state) (show-tape tape)
      (let ((cmd (prog 'lookup (list state (read-cell tape)))))
        (loop (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))))))))

(call-with-values
  (lambda () (turing (make-prog adder) (make-tape "111+11111" 0)))
  (lambda (str k) (display str) (display " ") (display k) (newline)))

11111111 7