Simple Turing machine simulator

gistfile1.lisp

(defparameter *tape* '())
(defparameter *deltas* '())
(defparameter *tape-pos* 0)
(defparameter *q* 0)

(define-condition no-delta (error)
  ((text :initarg :text :accessor text)))

(defun final-statep (final-states)
  "checks whether current state *q* is a final state"
  (find *q* final-states))

(defun apply-delta ()
  "applies appropriate delta rule based on current state of the machine and
   symbol on the tape"
  (let ((rules-for-state (assoc *q* *deltas*)))
    (if rules-for-state
      (let* ((all-rules (cdr rules-for-state))
             (tape-rule (assoc (current-state) all-rules)))
        (if tape-rule
          (let* ((delta (cdr tape-rule))
                 (new-q (first delta))
                 (new-w (second delta))
                 (new-i (third delta)))
            (setf *q* new-q)
            (setf (nth *tape-pos* *tape*) new-w)
            (case new-i
              (R (incf *tape-pos*))
              (L (decf *tape-pos*))))
          (error 'no-delta :text "no rules for state and tape")))
      (error 'no-delta :text "no rules for state"))))

(defun current-state ()
  "reads current state from the tape"
  (flet ((n-blanks (n) (make-list n :initial-element '_)))
    (cond ((minusp *tape-pos*) (setf *tape* (append (n-blanks (- *tape-pos*)) *tape*))
                               (setf *tape-pos* 0))
          ((>= *tape-pos* (length *tape*)) (setf *tape* (append *tape* (n-blanks (1+ (- *tape-pos* (length *tape*))))))))
    (nth *tape-pos* *tape*)))


(defun make-tm (deltas final-states)
  "construct a TM with given deltas and final states"
  (lambda (tape max-iterations)
    (let ((*deltas* deltas)
          (*tape* tape)
          (*tape-pos* 0)
          (*q* 0))
      (dotimes (i max-iterations (return (values :NOHALT *tape*)))
        (handler-case  (apply-delta)
          (no-delta () (return (values :REJECT *tape*))))
        (when (final-statep final-states)
          (return (values :ACCEPT i *tape*)))))))

(defun run-tm (M tape &optional (max-iterations 10000))
  "runs the given TM on the tape with optional max iterations count"
  (funcall M tape max-iterations))

;;;; sample programs
;                     (q_old (read_tape q_new write_tape move_window)*)*
(defparameter *even-b* '(((0 (1 0 1 R)
                             (0 0 0 R)
                             (_ 1 _ L))
                          (1 (0 2 0 L)))
                         (2)))

(defparameter *even-u* '(((0 (1 1 1 R)
                             (_ 2 _ S))
                          (1 (1 0 1 R)))
                         (2)))

; the delta functions are a pain to read/write like this though, so let's help ourselves with a function:
(defun prepare-deltas (deltas)
  "auxilary function that lets us write more natural delta rules and transforms
   them into an efficient version (for use in our tm) for us"
  (let* ((removed-arrows (loop for from  = (pop deltas) then (pop deltas)
                               and arrow = (pop deltas) then (pop deltas)
                               and to    = (pop deltas) then (pop deltas)
                               while from collect `(,from ,to)))
         (sorted-deltas (sort removed-arrows #'< :key #'caar)))
    (butlast (third (reduce (lambda (current next)
                              (let* ((q (first current))
                                     (q-rules (second current))
                                     (other-rules (third current))
                                     (next-q (caar next))
                                     (next-tape (cadar next))
                                     (next-rule (cadr next))
                                     (rule-written `(,next-tape ,@next-rule)))
                                (if (eql q next-q)
                                  `(,q ,(cons rule-written q-rules) ,other-rules)
                                  `(,next-q
                                     ,(list rule-written)
                                     ,(cons `(,q ,@q-rules)
                                            other-rules)))))
                            (append sorted-deltas '(() ())) :initial-value '(() () ()))))))

; now we can simply write   (q_old read_tape) -> (q_new write_tape move_window)
; which is more in tune with the definition of delta function δ: (Q x Γ) → (Q × Γ × {L, S, R})
(defparameter *0n1n* `(,(prepare-deltas '((0 0) -> (1 a R)
                                          (1 0) -> (1 0 R)
                                          (1 1) -> (2 b L)
                                          (1 b) -> (1 b R)
                                          (2 0) -> (2 0 L)
                                          (2 b) -> (2 b L)
                                          (2 a) -> (0 a R)
                                          (0 b) -> (3 b R)
                                          (3 b) -> (3 b R)
                                          (3 _) -> (4 _ R)))
                       (4)))

;; run with:
; (run-tm (apply #'make-tm *0n1n*) '(0 0 0 1 1 1)) ; language 0^n1^n