CommonLispで非決定性有限オートマトン

DFAの次は当然NFA。

NFAは現在取りうる状態の集合から、入力により次の状態の集合へと遷移する操作を繰り返し、最終的な状態の集合に受理状態が含まれていれば受理、そうでなければ拒否となると考えれば良いと思われる。これは、すべての遷移を並行処理しているようなイメージだろう。

'次の状態'には、イプシロン遷移で辿れるすべての状態を含む。

CommonLispでリストを集合として扱う関数にunion(nunion),set-difference(nset-difference) ,intersection(nintersection)などがある。

果たして正しく動いているのかどうか。

;;; Nondeterministic Finit Automaton

;;イプシロン遷移を表す特殊な入力記号として利用する
(defparameter *epsilon* '@)

(defclass NFA ()
  ((terminals :accessor terminals :initarg :terminals)
   (move-functions :accessor move-functions :initarg :move-functions)
   (entry-state :accessor entry-state :initarg :entry-state)
   (all-states :accessor all-states :initarg :all-states)
   (current-states :accessor current-states :initarg :current-states)))

;;;すべての状態を抜き出す
;;;結局使わないけれど。
(defun get-all-states (entry terminals rules)
  (let ((states (copy-list (cons entry terminals))))
    (loop :for rule in rules
       :do
       (pushnew (car rule) states)
       (dolist (mv-rule (cdr rule))
	 (dolist (s (cdr mv-rule))
	   (pushnew s states))))
    states))

(defmacro define-nfa (name (entry (&rest terminals)) &body rules)
  `(defclass ,name (NFA)
     ((terminals :reader terminals :initform ',terminals)
      (move-functions :reader move-functinos :initform ',rules)
      (entry-state :reader entry-state :initform ',entry)
      (all-states :reader all-states :initform (get-all-states ',entry ',terminals ',rules))
      (current-states :accessor current-states
		      :initform (adjoin ',entry (move-epsilon ',entry ',rules nil))))))

;;;nfaが受理状態かどうか
(defun accept? (nfa)
  (let ((terminals (terminals nfa)))
    (loop :for s in (current-states nfa)
       :when (find s terminals)
       :do (return-from accept? t))
    nil))

;;この時点ではイプシロン遷移しない。現在の状態に移ったときに完了しているはず。
(defun move (nfa input)
  (let ((states (current-states nfa))
	(result nil))
    (let ((acc nil))
      (dolist (s states)
	(unless (eq s *epsilon*)
	  (push (move-inner s input (move-functions nfa)) acc)))
      (dolist (next-states acc)
	(dolist (s next-states)
	  (pushnew s result))))
    (setf (current-states nfa) result)))

(defun move-inner (state input rules)
  (let ((rule (assoc state rules)))
    (let ((r (assoc input (cdr rule))))
      (when r
	(let ((result (cdr r)))
	  (reduce #'union
		  (mapcar
		   #'(lambda (s)
		       (move-epsilon s rules result))
		   result)
		  :initial-value result))))))

;;イプシロン遷移
;;tracked-statesは今までに現れた'次の状態'の集合
;;ループしたときに終了させる手段として保持
(defun move-epsilon (state rules tracked-states)
  (let ((rule (assoc state rules)))
    (let ((r (assoc *epsilon* (cdr rule))))
      (when r
	(let ((result (cdr r)))
	  (let ((next-tracked-states (union result tracked-states)))
	    (reduce #'union
		    (mapcar
		     #'(lambda (s)
			 (if (find s tracked-states)
			     nil
			     (move-epsilon s rules next-tracked-states)))
		     result)
		    :initial-value result)))))))

(defmethod run ((obj nfa) symbols)
  (dolist (s symbols)
    (setf (current-states obj)
	  (move obj s)))
  (accept? obj))

(defmethod run ((obj symbol) symbols)
  (let ((nfa (make-instance obj)))
    (run nfa symbols)))

;;; テスト
(define-nfa test-nfa (:0 (:q :r))
    (:0
     (@ :q :r))
    (:q
     (0 :q)
     (@ :a))
    (:a
     (0 :q))
    (:r
     (1 :r)))

;;"a(a|b)*bb"を受理する
(define-nfa test-nfa-2 (:i (:f))
  (:i
   (#\a :1))
  (:1
   (@ :2 :4))
  (:2
   (#\a :3)
   (#\b :3))
  (:3
   (@ :2 :4))
  (:4
   (#\b :5))
  (:5
   (#\b :f)))

;;(trace move)
;;(run 'test-nfa '(0 1))
;;(run 'test-nfa '(1 1))
;;(run 'test-nfa-2 (coerce "aababb" 'list))

綺麗に書けたと納得のいくソースコードが書けるようになるのはいつの日のことか。