有限オートマトン 修正

計算理論の基礎　オートマトンと言語(p.46)　を見ると、計算の正確な定義というのが書いてある。これに合うように、微妙に定義を変えた。

• finite-automaton クラスは定義通り５個組。内部に状態は持たない。
• make-fa は make-instance をラップしたマクロ。FA を定義する。
• transit 状態遷移関数。状態と文字を受け取り、次の状態を返す。
• run オートマトンに"文字列"(アルファベットのリスト)を受け取り、状態のリストを返す。
• accept 文字列と状態のリストを受け取り、受理する場合 t を返す。

受理する場合とは、(テキストにはもっと明確に、正確な言葉で書いている)

• 状態のリストの先頭が FA の初期状態
• 状態のリストは初期状態から文字列を順に処理して状態遷移関数で移れる状態
• 状態のリストの末尾は FA の受理状態に含まれる

(defclass finite-automaton ()
  ((states :accessor states-of :initarg :states)
   (alphabet :accessor alphabet-of :initarg :alphabet)
   (transition-function :accessor transition-function-of :initarg :transition-function)
   (initial-state :accessor initial-state-of :initarg :initial-state)
   (final-states :accessor final-states-of :initarg :final-states)))

(defmacro make-fa (states alphabet transition initial-state final-states)
  `(make-instance 'finite-automaton
                  :states ,states 
                  :alphabet ,alphabet
                  :transition-function
                  #'(lambda (state symbol)
                      (ecase state
                        ,@(loop for (s . trans) in transition
                             collect `(,s (ecase symbol ,@trans)))))
                  :final-states ,final-states
                  :initial-state ,initial-state))

(defmethod transit ((finite-automaton finite-automaton) state symbol)
  (funcall (transition-function-of finite-automaton) state symbol))

(defmethod run ((finite-automaton finite-automaton) ws)
  (loop for w in ws
     and s = (initial-state-of finite-automaton) then (transit finite-automaton s w)
     collect (transit finite-automaton s w) into seq
     finally (return (cons (initial-state-of finite-automaton) seq))))
       
(defmethod accept ((finite-automaton finite-automaton) ws state-seq)
  (if (and (equal (car state-seq) (initial-state-of finite-automaton))
           (loop for state in state-seq for w in ws for next in (cdr state-seq)
              always (equal (transit finite-automaton state w) next))
           (member (car (last state-seq)) (final-states-of finite-automaton) :test #'equal))
      t
      nil))

ついでに和集合演算を定義。ちょっと時間不足で怪しいが、一応動作するようだ。

(defun cartesian-product (q1 q2)
  (loop for r1 in q1
     append (loop for r2 in q2 collect (cons r1 r2))))

(defmethod union-fa ((m1 finite-automaton) (m2 finite-automaton))
  (let ((transition-function #'(lambda (s symbol)
                                 (cons
                                  (funcall (transition-function-of m1) (car s) symbol)
                                  (funcall (transition-function-of m2) (cdr s) symbol))))
        (initial-state (cons (initial-state-of m1)
                             (initial-state-of m2)))
        (final-states (loop for (q1 . q2) in (cartesian-product (states-of m1) (states-of m2))
                         if (or (member q1 (final-states-of m1))
                                (member q2 (final-states-of m2)))
                         collect (cons q1 q2))))
    (make-instance 'finite-automaton
                   :states (cartesian-product (states-of m1) (states-of m2))
                   :alphabet (alphabet-of m1) ;; both same alphabet
                   :transition-function transition-function
                   :initial-state initial-state
                   :final-states final-states)))

;; L(M1) = { w | w は少なくとも1つの 1 を含み、かつ、最後に表れる1の後ろに偶数個の0を含む }
(defvar *m1*
  (make-fa '(:q1 :q2 :q3)
           '(0 1)
           ((:q1
             (0 :q1)
             (1 :q2))
            (:q2
             (0 :q3)
             (1 :q2))
            (:q3
             (0 :q2)
             (1 :q2)))
           :q1
           '(:q2)))

(accept *m1* '(1 0 0) (run *m1* '(1 0 0))) ;; t
(accept *m1* '(1 0 0 0) (run *m1* '(1 0 0 0))) ;;  nil
(accept *m1* '(0 0 0 1 0 0) (run *m1* '(0 0 0 1 0 0))) ;; t

            
;; L(M2) = {w| w は 1 でおわる}
(defvar *m2*
  (make-fa '(:q1 :q2)
           '(0 1)
           ((:q1
             (0 :q1)
             (1 :q2))
            (:q2
             (0 :q1)
             (1 :q2)))
           :q1
           '(:q2)))
           
(accept *m2* '(1 0 1) (run *m2* '(1 0 1))) ; t
(accept *m2* '(1 0 0) (run *m2* '(1 0 0))) ; nil

(setq *m12* (union-fa *m1* *m2*))

(accept *m12* '(0 1) (run *m12* '(0 1))) 
t

(accept *m12* '(0 0) (run *m12* '(0 0)))
nil

(accept *m1* '(0 0 0 1 0 0) (run *m1* '(0 0 0 1 0 0)))
t