昨日帰省から帰ってきていましたが飛行機の中で特にする事がなく、コンパイラの本を読んですこしつかれたのでコードを書く事にしました。そこでチューリングマシンでもつくってみたらおもしろいだろうなぁとおもい
書いてみたいのが以下です。
;; ;; Infinity Tape ;; (defclass <tape> () ((data :initform (make-array 10 :initial-element nil :adjustable t) :initarg :data :accessor data) (look-at :initform 0 :accessor look-at))) (defun make-tape-with (list) (make-instance '<tape> :data (make-array (length list) :initial-contents list :adjustable t))) (defmethod get-datum ((tape <tape>)) (aref (data tape) (look-at tape))) (defmethod set-datum ((tape <tape>) val) (setf (aref (data tape) (look-at tape)) val)) (defmethod move-left ((tape <tape>)) (decf (look-at tape)) ;;underflow tape (when (= -1 (look-at tape)) (setf (data tape) (concatenate 'vector (vector nil) (data tape))) (setf (look-at tape) 0))) (defmethod move-right ((tape <tape>)) (incf (look-at tape)) (when (= (length (data tape)) (look-at tape)) ;;overflow tape (vector-push-extend (data tape) nil))) ;; ;; Turing Machine ;; (defclass <machine> () ((input-tape :initform (make-instance '<tape>) :initarg :input :accessor input-tape) (memories :initform (vector (make-instance '<tape>)) :initarg :memories :accessor memories) (state :initform 'normal :initarg :state :accessor state) (rules :initform () :initarg :rules :accessor rules))) ; ; CONSTANT SYMBOL (defvar *init-state* 'init) (defvar *error-state* 'error) (defvar *accept-state* 'accept) (defvar *blanc-code* 'N) (defun make-machine (input cnt-memories &optional (rules nil)) (make-instance '<machine> :input (make-tape-with input) :memories (loop repeat cnt-memories collect (make-instance '<tape>)) :state *init-state* :rules rules)) (defmethod lookup-rule ((m <machine>)) (assoc (state m) (rules m))) (defmethod update ((m <machine>)) (if (not (eql *error-state* (state m))) (let ((input (get-datum (input-tape m))) (rule (cdr (lookup-rule m)))) (let ((match-rule (assoc input rule))) (if match-rule (progn (set-datum (input-tape m) (nth 1 match-rule)) (cond ((eql 'left (nth 2 match-rule)) (move-left (input-tape m))) ((eql 'right (nth 2 match-rule)) (move-right (input-tape m))) (t (error "Illigal move ~A" (nth 2 match-rule)))) (setf (state m) (nth 3 match-rule))) (error "No match rule")))) (error "Error state"))) (defmethod accept-p ((m <machine>)) (eql *accept-state* (state m))) (defmethod error-p ((m <machine>)) (eql *error-state* (state m))) (defmethod show-machine-state ((m <machine>)) (format t "State: ~A~%" (state m)) (format t "[~A] (~A)~%" (data (input-tape m)) (look-at (input-tape m))) (format t " ~A^~%" (make-string (* (look-at (input-tape m)) 2) :initial-element #\Space)) (loop for mem in (memories m) do (format t "{~A}~%" mem))) (defparameter *sample-adder* (make-machine '(N 1 1 1 0 1 1 1 1 N) 0 `((,*init-state* (N N right find-zero)) (find-zero (1 1 right find-zero) (0 0 right find-num)) (find-num (0 0 left go-head) (1 1 left add)) (add (1 0 left shift) (0 0 right add) (N N left go-head)) (shift (0 1 right add) (1 1 right go-head)) (go-head (N N left accept) (0 0 left go-head) (1 1 left go-head))))) (defmethod run-machine ((m <machine>) cnt) (loop repeat cnt until (or (accept-p m) (error-p m)) do (format t "--------------------~%") (show-machine-state m) (update m)))
こんな感じで実行されます
CL-TURING(3): (run-machine *sample-adder* 30)
--------------------
State: INIT
[#(N 1 1 1 0 1 1 1 1 N)] (0)
^
--------------------
State: FIND-ZERO
[#(N 1 1 1 0 1 1 1 1 N)] (1)
^
--------------------
State: FIND-ZERO
[#(N 1 1 1 0 1 1 1 1 N)] (2)
^
--------------------
State: FIND-ZERO
[#(N 1 1 1 0 1 1 1 1 N)] (3)
^
--------------------
State: FIND-ZERO
[#(N 1 1 1 0 1 1 1 1 N)] (4)
^
--------------------
State: FIND-NUM
[#(N 1 1 1 0 1 1 1 1 N)] (5)
^
--------------------
State: ADD
[#(N 1 1 1 0 1 1 1 1 N)] (4)
^
--------------------
State: ADD
[#(N 1 1 1 0 1 1 1 1 N)] (5)
^
--------------------
State: SHIFT
[#(N 1 1 1 0 0 1 1 1 N)] (4)
^
--------------------
State: ADD
[#(N 1 1 1 1 0 1 1 1 N)] (5)
^
--------------------
State: ADD
[#(N 1 1 1 1 0 1 1 1 N)] (6)
^
--------------------
State: SHIFT
[#(N 1 1 1 1 0 0 1 1 N)] (5)
^
--------------------
State: ADD
[#(N 1 1 1 1 1 0 1 1 N)] (6)
^
--------------------
State: ADD
[#(N 1 1 1 1 1 0 1 1 N)] (7)
^
--------------------
State: SHIFT
[#(N 1 1 1 1 1 0 0 1 N)] (6)
^
--------------------
State: ADD
[#(N 1 1 1 1 1 1 0 1 N)] (7)
^
--------------------
State: ADD
[#(N 1 1 1 1 1 1 0 1 N)] (8)
^
--------------------
State: SHIFT
[#(N 1 1 1 1 1 1 0 0 N)] (7)
^
--------------------
State: ADD
[#(N 1 1 1 1 1 1 1 0 N)] (8)
^
--------------------
State: ADD
[#(N 1 1 1 1 1 1 1 0 N)] (9)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (8)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (7)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (6)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (5)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (4)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (3)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (2)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (1)
^
--------------------
State: GO-HEAD
[#(N 1 1 1 1 1 1 1 0 N)] (0)
^
NIL文献を参考にして書いたわけではないんので、ちょっと正確な定義かどうかわかりませんが、次は文献を借りてきて修正及び万能チューリングマシンでもつくりたいかなとおもっています。
