停止性を保証する必要はないという事で最終状態はacceptになるかどうかだけで良いという
事でerror状態を削減したり、メモリーというのはそもそも無いという事でメモリーを削除したり
make-machine時に利用可能な記号列を渡す事で先に定義がただしいかチェックする昨日を追加しました。
;; ;; 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>) &optional (blanc *blanc-code*)) (decf (look-at tape)) ;;underflow tape (when (= -1 (look-at tape)) (setf (data tape) (concatenate 'vector (vector blanc) (data tape))) (setf (look-at tape) 0))) (defmethod move-right ((tape <tape>) &optional (blanc *blanc-code*)) (incf (look-at tape)) (when (= (length (data tape)) (look-at tape)) ;;overflow tape (vector-push-extend (data tape) blanc))) ;; ;; Turing Machine ;; ; ; CONSTANT SYMBOL (defvar *init-state* 'init) (defvar *accept-state* 'accept) (defvar *blanc-code* 'N) (defclass <machine> () ((input-tape :initarg :input :initform (error "Input tape was not specified.") :reader input-tape) (alphabet :initform () :initarg :alphabet :reader alphabet) (blanc :initform () :initarg :blanc :reader blanc) (final-state :initform *accept-state* :initarg :final-state :reader final-state) (state :initform *init-state* :initarg :state :accessor state) (rules :initform () :initarg :rules :accessor rules))) (defun check-machine-definition (input-data states symbols blanc-symbol input-symbols initial-state final-state transition-table) (when (not (subsetp input-data symbols)) (error "Input tape conteins illigal character")) ;;Check states not empty (when (null states) (error "State set is empty")) ;;Check symbols not empty (when (null symbols) (error "Symbol set is empty")) ;;Check blance symbol is member of symbols (when (not (and (atom blanc-symbol) (member blanc-symbol symbols))) (error "Blanc symbols isn't member of symbols")) ;;Check input-symbols is subset of (symbols - blanc-symbol) (when (not (subsetp input-symbols (remove blanc-symbol symbols))) (error "Input symbol-set is subset of (symbols - blanc-symbol)")) (when (not (member initial-state states)) (error "Initial state is not member of states")) (when (not (member final-state states)) (error "Finish state is not member of states")) (check-machine-transition-table states symbols transition-table)) (defun check-machine-transition-table (states symbols table) (loop for rule in table when (not (member (car rule) states)) do (error "Unknown state : ~A~%" (car rule)) do (loop for trans in (cdr rule) for in = (nth 0 trans) for put = (nth 1 trans) for move = (nth 2 trans) for next-state = (nth 3 trans) when (not (member in symbols)) do (error "Unknown input: ~A in ~A~%" in trans) when (not (member put symbols)) do (error "Illigal put: ~A in ~A ~%" put trans) when (not (member move '(left right))) do (error "Illigal move: ~A in ~A~%" move trans) when (not (member next-state states)) do (error "Unknown next-state: ~A in ~A~%" next-state trans)))) (defun make-machine (input-data states symbols blanc-symbol input-symbols &optional (initial-state *init-state*) (final-state *accept-state*) (transition-table nil)) (check-machine-definition input-data states symbols blanc-symbol input-symbols initial-state final-state transition-table) (make-instance '<machine> :input (make-tape-with input-data) :state initial-state :final-state final-state :blanc blanc-symbol :alphabet input-symbols :rules transition-table)) (defmethod lookup-rule ((m <machine>)) (assoc (state m) (rules m))) (defmethod update ((m <machine>)) (when (not (accept-p 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) (blanc m))) ((eql 'right (nth 2 match-rule)) (move-right (input-tape m) (blanc m))) (t (error "Illigal move ~A" (nth 2 match-rule)))) (setf (state m) (nth 3 match-rule))) (error "No match rule")))))) (defmethod accept-p ((m <machine>)) (eql (final-state m) (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))) (defparameter *sample-adder* (make-machine '(N 1 1 1 0 1 1 1 1) '(init find-zero find-num add shift go-head accept) '(N 0 1) 'N '(0 1) 'init 'accept `((init (N N right find-zero)) (find-zero (1 1 right find-zero) (0 M 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 (accept-p m) do (format t "--------------------~%") (show-machine-state m) (update m)))
定義が変更されたのみで、run-machineした時の結果はかわってません。
そろそろ万能チューリングマシンをつくりたい。
