Let's write β

プログラミング中にできたことか、思ったこととか

チューリングマシンのシミュレート

昨日帰省から帰ってきていましたが飛行機の中で特にする事がなく、コンパイラの本を読んですこしつかれたのでコードを書く事にしました。そこでチューリングマシンでもつくってみたらおもしろいだろうなぁとおもい
書いてみたいのが以下です。

;;
;; 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

文献を参考にして書いたわけではないんので、ちょっと正確な定義かどうかわかりませんが、次は文献を借りてきて修正及び万能チューリングマシンでもつくりたいかなとおもっています。

僕が働いているAzit.incでは一緒に働けるエンジニアを募集しています!
採用情報 — 株式会社アジット|Azit Inc.