gistfile1.cl

;; Turing Machine Simulator
;; CS 422
;; Andrew Butcher

(defconstant tape-alphabet-size 256)
(defconstant trace-tape-chars 78)

(defstruct transition
  control-state
  head-symbol
  transition-result)

(defstruct transition-result
  control-state
  write-symbol
  direction)

(defstruct turing-machine
  initial-control-state
  blank-symbol
  num-accepting-states
  accepting-states
  transition-table)

(defstruct turing-machine-state
  control-state
  head-position
  tape-size
  tape)

(defun create-initial-state (initial-control-state input-string-length input-string)
  (make-turing-machine-state
	:control-state initial-control-state
	:head-position 0
	:tape-size input-string-length
	:tape (copy-list input-string)))

(defun update-state (state new-control-state direction write-symbol blank-symbol)
  (setf (turing-machine-state-control-state state) new-control-state)
  (setf (nth (turing-machine-state-head-position state)
	     (turing-machine-state-tape state))
	write-symbol)
  (if (eql direction 'dir-left)
      (decf (turing-machine-state-head-position state))
      (incf (turing-machine-state-head-position state))))
;  (if (>= (turing-machine-state-head-position state)
;	  (turing-machine-state-tape-size state))
;      (let ((tape (copy-list (turing-machine-state-tape state))))
;	(dotimes (n (+ (* (length tape) 2) 10))
;	  (setf tape (append tape (list blank-symbol))))
;	(setf (turing-machine-state-tape state) tape))))

(defun trace-state (state)
  (let (str)
    (dotimes (n (1- (turing-machine-state-head-position state)))
      (setf str (append str (list #\Space))))
    (setf str (append str (list #\v)))
    (format t "~A~%" (coerce str 'string))
    (format t "~A~%" (coerce (turing-machine-state-tape state) 'string))))

(defun simulate (machine input-string-length input-string)
  (let ((state (create-initial-state (turing-machine-initial-control-state machine)
				     input-string-length
				     input-string)))
    (dotimes (n (* (length input-string) 2))
      (setf (turing-machine-state-tape state)
	    (append (turing-machine-state-tape state)
		    (list (turing-machine-blank-symbol machine)))))
    (trace-state state)
    (format t "Start~%")
    (loop while (not (member (turing-machine-state-control-state state)
			     (turing-machine-accepting-states machine)))
       do
	 (let ((next (match-transition (turing-machine-state-control-state state)
				       (nth (turing-machine-state-head-position state)
					    (turing-machine-state-tape state))
				       (turing-machine-transition-table machine))))
;	   (format t "Current control-state: ~A~%"
;		   (turing-machine-state-control-state state))
;	   (format t "Current head-symbol: ~A~%"
;		   (nth (turing-machine-state-head-position state)
;			(turing-machine-state-tape state)))
	   (update-state state
			 (transition-result-control-state next)
			 (transition-result-direction next)
			 (transition-result-write-symbol next)
			 (turing-machine-blank-symbol machine))
	   (trace-state state))))
  (format t "Done~%"))


(defun match-transition (control-state head-symbol transition-table)
  (let ((result nil))
    (if (eql head-symbol nil)
	(setf head-symbol #\#))
    (dolist (transition transition-table)
      (if (and (eql control-state
		    (transition-control-state transition))
	       (eql head-symbol
		    (transition-head-symbol transition)))
	  (setf result (transition-transition-result transition))))
    result))

(defun get-example-turing-machine ()
  (make-turing-machine
   :initial-control-state 0
   :blank-symbol #\#
   :num-accepting-states 1
   :accepting-states '(5)
   :transition-table (list
		      (make-transition
		       :control-state 0
		       :head-symbol #\#
		       :transition-result (make-transition-result
					   :control-state 4
					   :write-symbol #\#
					   :direction 'dir-right))
		      (make-transition
		       :control-state 0
		       :head-symbol #\a
		       :transition-result (make-transition-result
					   :control-state 1
					   :write-symbol #\#
					   :direction 'dir-right))
		      (make-transition
		       :control-state 4
		       :head-symbol #\#
		       :transition-result (make-transition-result
					   :control-state 5
					   :write-symbol #\#
					   :direction 'dir-right))
		      (make-transition
		       :control-state 1
		       :head-symbol #\a
		       :transition-result (make-transition-result
					   :control-state 1
					   :write-symbol #\a
					   :direction 'dir-right))
		      (make-transition
		       :control-state 1
		       :head-symbol #\b
		       :transition-result (make-transition-result
					   :control-state 1
					   :write-symbol #\b
					   :direction 'dir-right))
		      (make-transition
		       :control-state 1
		       :head-symbol #\#
		       :transition-result (make-transition-result
					   :control-state 2
					   :write-symbol #\#
					   :direction 'dir-left))

		      (make-transition
		       :control-state 2
		       :head-symbol #\b
		       :transition-result (make-transition-result
					   :control-state 3
					   :write-symbol #\#
					   :direction 'dir-left))
		      (make-transition
		       :control-state 3
		       :head-symbol #\a
		       :transition-result (make-transition-result
					   :control-state 3
					   :write-symbol #\a
					   :direction 'dir-left))
		      (make-transition
		       :control-state 3
		       :head-symbol #\b
		       :transition-result (make-transition-result
					   :control-state 3
					   :write-symbol #\b
					   :direction 'dir-left))
		      (make-transition
		       :control-state 3
		       :head-symbol #\#
		       :transition-result (make-transition-result
					   :control-state 0
					   :write-symbol #\#
					   :direction 'dir-right))
		      )))