それでは、実際にプログラムを作っていきましょう。まずは節の定義からです。節は構造体 Rule で表し、述語を表すシンボルの属性リストに属性名 RULE で格納します。
List 1 : 節(事実と規則)の定義 (defstruct Rule var-list ; 変数リスト clause) ; 節
スロット var-list には、節 clause で使われている変数をリストにまとめてセットします。これは節の変数を新しいシンボルに置換するときに使います。この処理は関数 copy-clasue で行います。
List 2 : 節をコピーする (defun copy-clause (rule) (sublis (if (Rule-var-list rule) (mapcar #'(lambda (var) (cons var (gensym "?"))) (Rule-var-list rule))) (Rule-clause rule)))
この処理は sublis を使えば簡単ですね。sublis に渡す連想リストが nil の場合、sublis は引数のリストをそのまま返すので、var-list が nil の場合は clause を返すことになります。
次は、節を属性リストに登録する処理を作ります。関数名は assert です。
List 3 : 節の登録 (defun assert (clause) (check-clause clause) (let ((predicate (caar clause))) (setf (get predicate 'RULE) (cons (make-rule-obj clause) (get predicate 'RULE)))))
まず、関数 check-clause で節の構造をチェックします。次に、頭部の述語を caar で取り出して変数 predicate にセットします。節は述語 predicate の属性 RULE にセットします。Rule の実体(オブジェクト)を関数 make-rule-obj で作成し、登録されている節に追加します。
List 4 : 節のチェック (defun check-clause (clause) (dolist (x clause) (if (or (atom x) (variablep (car x)) (not (symbolp (car x)))) (error "節に述語がありません ~A~%" clause))))
節のチェックは簡単です。clause の要素がリストで、その先頭の要素が述語として認められるシンボル、つまり、変数以外のシンボルであることを確認します。変数 x がリストでない、x の CAR が変数、またはシンボルでない場合は、関数 error でエラーメッセージを表示します。
List 5 : Rule を作る (defun make-rule-obj (clause) (make-Rule :var-list (collect-variable clause) :clause clause))
make-rule-obj は簡単です。関数 collect-variable で clause の変数を集めてスロット var-list にセットし、clause をスロット clause にセットするだけです。
次は、節の変数を集める collect-variable を作ります。
List 6 : 節で使用されている変数を集める (defun collect-variable (clause &optional var-list) (cond ((variablep clause) (pushnew clause var-list)) ((atom clause) var-list) (t (collect-variable (cdr clause) (collect-variable (car clause) var-list)))))
オプションパラメータ var-list に変数を集めます。var-list は累算変数として使っています。最初に、clause が変数か variablep でチェックし、そうであれば var-list へセットします。pushnew を使っているので、同じ変数を格納することはありません。clause がアトムであれば、これ以上分解できないので var-list を返します。
引数 clause がリストの場合は、cond の t 節で car と cdr に分解します。clause の CAR 部 に collect-varibale を適用し、その返り値が CDR 部の変数を集めるときに使われます。
次は、パターンマッチングとバックトラックを行う処理を作成します。最初に、実行環境を表すクラス Env を再度示します。
List 7 : 実行環境の定義(再掲) (defstruct Env goal ; ゴール節 rule-list ; 述語に定義されている規則 exec-rule ; 実行中の規則 exec-env ; 作成した環境(スタックになる) binding) ; 束縛した変数
構造体 Env のオブジェクトを生成する関数 make-env-obj は次のようになります。
List 8 : 実行環境の作成 (defun make-env-obj (pattern) (make-Env :goal pattern :rule-list (get (car pattern) 'RULE) :binding 'call))
引数 pattern には節と照合するパターン (述語 引数 ... 引数) という形式のデータが与えられます。これをスロット goal にセットし、述語の属性 RULE から節を取り出してスロット rule-list にセットします。それから、最初の呼び出しであることを示すため、スロット binding に call をセットします。
節の実行は次に示す関数で行います。
これらの関数は、照合成功のときには束縛した変数のリストまたは nil を、失敗したときには fail を返します。節の実行は exec-clause から始まります。exec-clause は goal にセットされたパターンと節を照合します。
List 9 : 節の実行 (defun exec-clause (env) (let ((result 'fail)) (if (eq (Env-binding env) 'call) ; Call (if (Env-rule-list env) (setq result (select-rule env))) ; Redo (if (eq 'fail (setq result (exec-body env))) (setq result (select-rule env)))) (if (eq result 'fail) (clear-binding (Env-binding env)) result)))
binding が call であれば最初の呼び出しです。rule-list に規則がセットされているかチェックし、規則がなければ fail となります。そうでなければ、select-rule で goal と照合成功する頭部を持つ規則を選択して、その体部を実行します。結果は result にセットされます。
binding が call 以外のデータであれば再試行 (Redo) の場合です。引数 env の スロット exec-env にセットされている環境をたどるため、関数 exec-body を呼び出します。もし、exec-body が fail を返したら、次の規則を選択するため select-rule を呼び出して、その結果を result にセットします。
そして、最後の if で実行結果 result をチェックします。もし fail であれば、clear-binding で変数束縛をクリアして fail を返します。そうでなければ result をそのまま返します。
次は select-rule を説明します。
List 10 : 節の選択と実行 (defun select-rule (env) (let ((result 'fail)) (while (and (listp (setq result (unify-head env))) (Env-exec-rule env)) ; 実行環境の生成 (push (make-env-obj (car (Env-exec-rule env))) (Env-exec-env env)) ; 体部の実行 (setq result (exec-body env)) (if (listp result) (return))) result))
節の選択は関数 unify-head で行います。unify-head の返り値がリストであれば、ユニフィケーションは成功したことがわかります。この場合、nil も成功なので述語 listp で判断しています。unify-head は規則の頭部と goal のユニフィケーションが成功した場合、規則の体部をスロット exec-rule にセットします。もし exec-rule が nil であれば、実行する体部がない「事実」なので、while ループを抜けて result を返します。
実行する体部がある場合、make-env-obj で最初のゴールを実行するための環境を生成して exec-env にセットします。exec-body は再試行でも動作するように、exec-env に格納されている環境に対して、exec-clause を適用するように作られています。このため、最初の呼び出しでは exec-env に環境をセットしなければいけません。詳しい説明は exec-body で行います。
次に、体部を実行するため exec-body を呼び出します。その結果が成功であれば、return で while ループを脱出します。失敗ならば最初に戻って、節の選択を unify-head で行います。最後に実行結果 result を返します。
次は unify-head を説明します。
List 11 : ゴールと規則の頭部を照合する (defun unify-head (env) (let ((result 'fail) now-rule) (clear-binding (Env-binding env)) (while (Env-rule-list env) ; 節をコピーする (setq now-rule (copy-clause (pop (Env-rule-list env)))) ; 節の head と goal のユニフィケーション (setq result (unify (Env-goal env) (pop now-rule) nil)) (when (listp result) ; 成功 (setf (Env-exec-rule env) now-rule (Env-binding env) result) (return))) result))
最初に、束縛された変数があれば clear-binding でクリアします。次に、rule-list の中から goal と照合成功する頭部を持つ節を見つけます。まず、pop で rule-list から節をひとつ取り出します。次に、節を copy-clause でコピーして、それを変数 now-rule にセットします。
それから、goal と now-rule の頭部を unify でユニフィケーションします。now-rule に pop を適用しているので、now-rule には体部しか残らないことに注意してください。その結果が成功であれば、setf で残った体部を exec-rule にセットし、結果を binding にセットします。そして、return で while ループを脱出します。rule-list が nil になった場合は fail を返します。
次は、exec-body を説明します。
List 12 : 体部の実行 (defun exec-body (env) (let ((max-state (length (Env-exec-rule env))) (result 'fail) now-state) (while (Env-exec-env env) (setq result (exec-clause (car (Env-exec-env env)))) (cond ; 失敗したらバックトラック ((eq 'fail result) (pop (Env-exec-env env))) ; すべてのゴールが成功 ((= max-state (setq now-state (length (Env-exec-env env)))) (return)) ; 次のゴールへ進む (t (push (make-env-obj (elt (Env-exec-rule env) now-state)) (Env-exec-env env))))) result))
exec-body は体部の実行を担当します。再試行の場合は、exec-env に格納されている環境をたどり、いちばん最後に実行した節から再試行します。このため、最初の呼び出しでは exec-env に実行環境をセットしておかないと動作しません。
体部の実行は、そこに格納されているゴールがすべて成功したときに、その規則が成功したと判断されます。まず、ゴールの総数を max-state にセットします。体部の実行は exec-env に環境がある間繰り返し行われます。exec-env に環境がなくなった場合、exec-body は fail を返します。その場合は、exec-clause に戻って select-rule が実行され、その環境における次の節が選択されます。
実際に体部を実行するには、exec-env の先頭に格納されている環境に対して exec-clasue を適用することで行います。最初の呼び出し (Call) の場合、select-rule で最初のゴールの実行環境が exec-env にセットされているので、その環境に移動してゴールと節の照合が行われます。
再試行の場合、exec-env の先頭には最後に実行された環境がセットされています。この環境に対して exec-clause を適用すれば、その環境に移動することができます。これを繰り返すことで、いちばん最後に実行した環境へたどり着くことができるのです。
exec-clause の結果が fail であれば、その実行環境を exec-env から削除します。すると、exec-env にはその前に実行したゴールの環境が出てくるので、それに対して exec-clause を実行します。これでバックトラックを実現することができます。
たとえば、最初の呼び出しの場合、1 番目のゴールが成功しても次のゴールが失敗したら、1 番目のゴールにバックトラックしないといけません。この動作は再試行の場合と同じですね。つまり、体部の実行と再試行(バックトラック)は、一体となって動作しないといけないのです。
結果が成功であれば、体部のゴールをすべて実行したかチェックします。exec-env に格納されている環境の個数 (now-state) が max-state になれば、すべてのゴールを実行したことがわかります。return で while ループを脱出します。
ゴールが残っている場合は、次のゴールを実行します。exec-rule から now-state の位置にあるゴールを取り出して、make-env-obj で実行環境を作成して exec-env にセットします。Common Lisp ではリストの要素を 0 から数えるので、now-state が次のゴールを指すことに注意してください。そのあと、ループの先頭に戻り exec-clasue が評価され、新しい環境でゴールと節が照合されます。
exec-body の動作は少々難しいので、簡易エキスパートシステムの作成(2) で説明した環境の動作図を参考にじっくりと考えてください。
最後に、データをファイルから読み込む load-data と、質問を受け付ける関数 Q を作ります。
List 13 : データのロード (defun load-data (filename) (let (clause) (with-open-file (in filename :direction :input) (while (setq clause (read in nil)) (assert clause)))))
ファイルには、節 ((述語 引数 ... 引数) ... ) が定義されていることを前提としているので、ロード可能なファイルかチェックしていないことに注意してください。処理内容は簡単ですね。ファイルをリードオープンして、read で節を読み込み、それを assert で属性リストにセットします。
次は、質問を受け付ける関数 Q です。
List 14 : 質問を受け付ける (defun Q (question) (let* ((rule (make-rule-obj question)) (env (make-env-obj (Rule-clause rule))) result) (while (listp (setq result (exec-clause env))) (dolist (var (Rule-var-list rule) (terpri)) (format t "~A = ~A~%" var (variable-value var))))))
まず、make-rule-obj で質問 question を Rule のオブジェクトに変換します。このときに構文のチェックが行われます。次に、この質問 rule に対応する実行環境 env を make-env-obj で生成します。
あとは、この env に exec-clause を適用することで質問とデータベースを照合します。答えが見つかれば、質問で使われている変数の解を表示します。変数リストは rule のスロット var-list から求めることができますね。そして、variable-value を呼び出して変数の値を求めます。関数 Q は Prolog と違って、無条件に再試行を行うことに注意してください。
これでプログラムは完成です。詳細は プログラムリスト をお読みくださいませ。次は、簡単な実行例を見ていくことにしましょう。
; ; expert.l : Prolog 風エキスパートシステム ; ; 特徴 ; パターンマッチング+バックトラックのみ ; Prolog が備えている組み込み述語は実装していない ; 規則は属性リスト RULE にセットする ; 変数は gensym を使ってコピー ; 節をコピーするので実行速度は遅い ; 値はスペシャル変数に格納する(束縛リストは使わない) ; ; 2003/02/01 xyzzy Lisp (Common Lisp) 用に書き直し ; ; Copyright (C) 1998-2003 Makoto Hiroi ; ; ********** 節の定義 ********** ; ; 節(事実と規則)の定義 ; (defstruct Rule var-list ; 変数リスト clause) ; 節 ; ; 節をコピーする ; (defun copy-clause (rule) (sublis (if (Rule-var-list rule) (mapcar #'(lambda (var) (cons var (gensym "?"))) (Rule-var-list rule))) (Rule-clause rule))) ; ; Rule を作る ; (defun make-rule-obj (clause) (make-Rule :var-list (collect-variable clause) :clause clause)) ; ; 節の登録 ; (defun assert (clause) (check-clause clause) (let ((predicate (caar clause))) (setf (get predicate 'RULE) (cons (make-rule-obj clause) (get predicate 'RULE))))) ; ; 節のチェック ; (defun check-clause (clause) (dolist (x clause) (if (or (atom x) (variablep (car x)) (not (symbolp (car x)))) (error "節に述語がありません ~A~%" clause)))) ; ********** 節の実行 ********** ; ; 実行環境の定義 ; (defstruct Env goal ; ゴール節 rule-list ; 述語に定義されている規則 exec-rule ; 実行中の規則 exec-env ; 作成した環境(スタックになる) binding) ; 束縛した変数 ; ; 実行環境の作成 ; (defun make-env-obj (pattern) (make-Env :goal pattern :rule-list (get (car pattern) 'RULE) :binding 'call)) ; ; 節の実行 ; (defun exec-clause (env) (let ((result 'fail)) (if (eq (Env-binding env) 'call) ; 最初の呼び出し (if (Env-rule-list env) (setq result (select-rule env))) ; 再試行 (if (eq 'fail (setq result (exec-body env))) ; 次の節を実行 (setq result (select-rule env)))) (if (eq result 'fail) (clear-binding (Env-binding env)) result))) ; ; 頭部と照合する規則を選択 ; (defun select-rule (env) (let ((result 'fail)) (while (and (listp (setq result (unify-head env))) (Env-exec-rule env)) ; 実行環境の生成 (push (make-env-obj (car (Env-exec-rule env))) (Env-exec-env env)) ; 体部の実行 (setq result (exec-body env)) (if (listp result) (return))) result)) ; ; 頭部とのユニフィケーション ; (defun unify-head (env) (let ((result 'fail) now-rule) (clear-binding (Env-binding env)) (while (Env-rule-list env) ; 節をコピーする (setq now-rule (copy-clause (pop (Env-rule-list env)))) ; 節の head と goal のユニフィケーション (setq result (unify (Env-goal env) (pop now-rule) nil)) (when (listp result) ; 成功 (setf (Env-exec-rule env) now-rule (Env-binding env) result) (return))) result)) ; ; 体部の実行 ; (defun exec-body (env) (let ((max-state (length (Env-exec-rule env))) (result 'fail) now-state) (while (Env-exec-env env) (setq result (exec-clause (car (Env-exec-env env)))) (cond ; 失敗したらバックトラック ((eq 'fail result) (pop (Env-exec-env env))) ; すべてのゴールが成功 ((= max-state (setq now-state (length (Env-exec-env env)))) (return)) ; 次のゴールへ進む (t (push (make-env-obj (elt (Env-exec-rule env) now-state)) (Env-exec-env env))))) result)) ; ; ********** ユニフィケーション ********** ; ; OUTPUT -- 失敗 : fail, 成功 : 束縛したシンボル ; (defun unify (pattern datum binding) (cond ((variablep pattern) (unify-variable pattern datum binding)) ((variablep datum) (unify-variable datum pattern binding)) ((and (atom pattern) (atom datum)) (unify-atoms pattern datum binding)) ((and (consp pattern) (consp datum)) (unify-pieces pattern datum binding)) (t (clear-binding binding)))) ; ; アトムとのユニフィケーション ; (defun unify-atoms (pattern datum binding) (if (equal pattern datum) binding (clear-binding binding))) ; ; リストのユニフィケーション ; (defun unify-pieces (pattern datum binding) (let ((result (unify (car pattern) (car datum) binding))) (if (eq result 'fail) 'fail (unify (cdr pattern) (cdr datum) result)))) ; ; 変数とのユニフィケーション ; (defun unify-variable (var datum binding) (if (and (boundp var) (not (eq (symbol-value var) var))) ; 自分自身ではない (unify (symbol-value var) datum binding) (add-binding var datum binding))) ; insidep のチェックは不要 ; ********** サブルーチン ********** ; ; 変数をチェックする ; (defun variablep (pattern) (and (symbolp pattern) (char= #\? (char (string pattern) 0)))) ; ; 変数値をセットする ; (defun add-binding (var datum binding) (set var datum) (cons var binding)) ; ; 変数をクリアして 'fail を返す ; (defun clear-binding (binding) (if (listp binding) (dolist (var binding) (makunbound var))) 'fail) ; ; 節で使用されている変数を集める ; (defun collect-variable (clause &optional var-list) (cond ((variablep clause) (pushnew clause var-list)) ((atom clause) var-list) (t (collect-variable (cdr clause) (collect-variable (car clause) var-list))))) ; ; 変数を置換する ; (defun replace-variable (pattern) (cond ((variablep pattern) (variable-value pattern)) ((atom pattern) pattern) (t (cons (replace-variable (car pattern)) (replace-variable (cdr pattern)))))) ; ; 変数値を求める ; (defun variable-value (var) (let (value) (loop (unless (boundp var) (return var)) (setq value (symbol-value var)) (cond ((eq var value) (return value)) ((variablep value) (setq var value)) ((consp value) (return (replace-variable value))) (t (return value)))))) ; ; データのロード : ((p ...) ... ) の形式 ; (defun load-data (filename) (let (clause) (with-open-file (in filename :direction :input) (while (setq clause (read in nil)) (assert clause))))) ; ; 質問する ; (defun Q (question) (let* ((rule (make-rule-obj question)) (env (make-env-obj (Rule-clause rule))) result) (while (listp (setq result (exec-clause env))) (dolist (var (Rule-var-list rule) (terpri)) (format t "~A = ~A~%" var (variable-value var))))))