簡易エキスパートシステムの作成 (後編)
●プログラムの作成
それでは、実際にプログラムを作っていきましょう。まずは節の定義からです。節は構造体 RULE で表し、述語を表すシンボルの属性リストに属性名 RULE で格納します。
リスト : 節 (事実と規則) の定義 (defstruct rule var-list ; 変数リスト clause) ; 節
スロット VAR-LIST には、節 clause で使われている変数をリストにまとめてセットします。これは節の変数を新しいシンボルに置換するときに使います。この処理は関数 copy-clasue で行います。
リスト : 節をコピーする
(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 を返すことになります。
次は、節を属性リストに登録する処理を作ります。関数名は asserta です。
リスト : 節の登録
(defun asserta (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 で作成し、登録されている節に追加します。
リスト : 節のチェック
(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 でエラーメッセージを通知します。
リスト : 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 を作ります。
リスト : 節で使用されている変数を集める
(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 を再度示します。
リスト : 実行環境の定義（再掲） (defstruct env goal ; ゴール節 rule-list ; 述語に定義されている規則 exec-rule ; 実行中の規則 exec-env ; 作成した環境（スタックになる） binding ; 束縛リスト prev-binding) ; env を作成したときの束縛リスト
構造体 env のオブジェクトを生成する関数 make-env-obj は次のようになります。
リスト : 実行環境の作成 (defun make-env-obj (pattern binding) (make-env :goal pattern :rule-list (get (car pattern) 'RULE) :binding 'call :prev-binding binding))
引数 PATTERN には節と照合するパターン (述語 引数 ... 引数) という形式のデータが与えられます。これをスロット GOAL にセットし、述語の属性 RULE から節を取り出してスロット RULE-LIST にセットします。それから、最初の呼び出しであることを示すため、スロット BINDING にシンボル CALL をセットします。引数 BINDING は環境を生成するときの束縛リストです。これをスロット PREV-BINDING にセットします。
節の実行は次に示す関数で行います。
- exec-clause : 節の実行。Call と Redo の振り分け。
- select-rule : 節の選択と実行。
- unify-head : ゴールと頭部のユニフィケーションを行う。
- exec-body : 体部の実行。再試行では環境をたどっていく。 exec-clause を再帰呼び出しする。
これらの関数は、照合成功のときには束縛した変数の束縛リストまたは NIL を、失敗したときには FAIL を返します。節の実行は exec-clause から始まります。exec-clause は GOAL にセットされたパターンと節を照合します。
リスト : 節の実行
(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))))
;; 結果を返す
result))
スロット BINDING が CALL であれば最初の呼び出しです。RULE-LIST に規則がセットされているかチェックし、規則がなければ FAIL となります。そうでなければ、select-rule で GOAL と照合成功する頭部を持つ規則を選択して、その体部を実行します。結果は RESULT にセットされます。
BINDING が CALL 以外のデータであれば再試行 (Redo) の場合です。引数 ENV の スロット EXEC-ENV にセットされている環境をたどるため、関数 EXEC-BODY を呼び出します。もし、EXEC-BODY が FAIL を返したら、次の規則を選択するため select-rule を呼び出して、その結果を RESULT にセットします。そして、最後に実行結果 RESULT を返します。
次は関数 select-rule を説明します。
リスト : 節の選択と実行
(defun select-rule (env)
(let ((result 'fail))
(loop
(unless (and (listp (setq result (unify-head env)))
(env-exec-rule env))
(return))
;; 実行環境の生成
(push (make-env-obj (car (env-exec-rule env)) result)
(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 であれば、実行する体部がない「事実」なので、loop を抜けて RESULT を返します。
実行する体部がある場合、make-env-obj で最初のゴールを実行するための環境を生成して EXEC-ENV にセットします。EXEC-BODY は再試行でも動作するように、EXEC-ENV に格納されている環境に対して、EXEC-CLAUSE を適用するように作られています。このため、最初の呼び出しでは EXEC-ENV に環境をセットしなければいけません。詳しい説明は exec-body で行います。
次に、体部を実行するため exec-body を呼び出します。その結果が成功であれば、return で loop を脱出します。失敗ならば最初に戻って、節の選択を unify-head で行います。最後に実行結果 RESULT を返します。
次は unify-head を説明します。
リスト : ゴールと規則の頭部を照合する
(defun unify-head (env)
(let ((result 'fail) now-rule)
(loop
(unless (env-rule-list env) (return))
;; 節をコピーする
(setq now-rule (copy-clause (pop (env-rule-list env))))
;; 節の head と goal のユニフィケーション
(setq result (unify (env-goal env) (pop now-rule) (env-prev-binding env)))
(when (listp result)
;; 成功
(setf (env-exec-rule env) now-rule
(env-binding env) result)
(return)))
result))
最初に、RULE-LIST の中から GOAL と照合成功する頭部を持つ節を見つけます。まず、pop で RULE-LIST から節をひとつ取り出します。次に、節を copy-clause でコピーして、それを変数 NOW-RULE にセットします。それから、GOAL と NOW-RULE の頭部を unify でユニフィケーションします。NOW-RULE に pop を適用しているので、NOW-RULE には体部しか残らないことに注意してください。
その結果が成功であれば、setf で残った体部を EXEC-RULE にセットし、結果を BINDING にセットします。そして、return で loop を脱出します。RULE-LIST が NIL になった場合は FAIL を返します。
次は、exec-body を説明します。
リスト : 体部の実行
(defun exec-body (env)
(let ((max-state (length (env-exec-rule env)))
(result 'fail)
now-state)
(loop
(unless (env-exec-env env) (return))
(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) result)
(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 で loop を脱出します。
ゴールが残っている場合は、次のゴールを実行します。EXEC-RULE から NOW-STATE の位置にあるゴールを取り出して、make-env-obj で実行環境を作成して EXEC-ENV にセットします。Common Lisp ではリストの要素を 0 から数えるので、NOW-STATE が次のゴールを指すことに注意してください。そのあと、ループの先頭に戻り exec-clasue が評価され、新しい環境でゴールと節が照合されます。
exec-body の動作は少々難しいので、簡易エキスパートシステムの作成 (前編) で説明した環境の動作図を参考にじっくりと考えてください。
●インタフェースの作成
最後に、データをファイルから読み込む load-data と、質問を受け付ける関数 ask を作ります。
リスト : データのロード
(defun load-data (filename)
(let (clause)
(with-open-file (in filename :direction :input)
(loop while (setq clause (read in nil))
do (asserta clause)))))
ファイルには、節 ((述語 引数 ... 引数) ... ) が定義されていることを前提としているので、ロード可能なファイルかチェックしていないことに注意してください。処理内容は簡単ですね。ファイルをリードオープンして、read で節を読み込み、それを asserta で属性リストにセットします。
次は、質問を受け付ける関数 ask です。
リスト : 質問を受け付ける
(defun ask (question)
(let* ((rule (make-rule-obj question))
(env (make-env-obj (rule-clause rule) nil))
result)
(loop
(unless (listp (setq result (exec-clause env)))
(return))
(dolist (var (rule-var-list rule) (terpri))
(format t "~a = ~a~%" var (variable-value var result))))))
まず、make-rule-obj で質問 question を RULE に変換します。このときに構文のチェックが行われます。次に、この質問 RULE に対応する実行環境 ENV を make-env-obj で生成します。
あとは、この ENV に exec-clause を適用することで質問とデータベースを照合します。答えが見つかれば、質問で使われている変数の解を表示します。変数リストは RULE のスロット VAR-LIST から求めることができますね。そして、variable-value を呼び出して変数の値を求めます。関数 ask は Prolog と違って無条件に再試行を行うことに注意してください。
これでプログラムは完成です。詳細は プログラムリスト をお読みくださいませ。
●実行例 -- 家系図
それでは、プログラムが完成したので実際に動かしてみましょう。具体的な例題として、次のような家系図を考えてみます。
この家系図は、次のような事実で表すことができます。
リスト : 家系図の定義 ((男性 太郎)) ; 太郎は男性である。 ((男性 一郎)) ; 一郎は男性である。 ((男性 次郎)) ; 次郎は男性である。 ((男性 三郎)) ; 三郎は男性である。 ((女性 花子)) ; 花子は女性である。 ((女性 友子)) ; 友子は女性である。 ((女性 幸子)) ; 幸子は女性である。 ((女性 洋子)) ; 洋子は女性である。 ((父親 太郎 一郎)) ; 太郎は一郎の父親である。 ((父親 太郎 次郎)) ; 太郎は次郎の父親である。 ((父親 太郎 友子)) ; 太郎は友子の父親である。 ((母親 花子 一郎)) ; 花子は一郎の母親である。 ((母親 花子 次郎)) ; 花子は次郎の母親である。 ((母親 花子 友子)) ; 花子は友子の母親である。 ((父親 一郎 三郎)) ; 一郎は三郎の父親である。 ((父親 一郎 洋子)) ; 一郎は洋子の父親である。 ((母親 幸子 三郎)) ; 幸子は三郎の母親である。 ((母親 幸子 洋子)) ; 幸子は洋子の母親である。 ; 規則の定義 ((両親 ?x ?y) (父親 ?x ?y)) ((両親 ?x ?y) (母親 ?x ?y)) ((息子 ?x ?y) (両親 ?y ?x) (男性 ?x)) ((娘 ?x ?y) (両親 ?y ?x) (女性 ?x)) ((祖父 ?x ?y) (両親 ?z ?y) (父親 ?x ?z))
性別の定義は簡単ですね。男性、女性という述語を使っています。父親と母親ですが、(父親 ?x ?y) は「?x は ?y の父親」という関係を表していることにします。
それでは、定義した事実を使って規則を作ってみましょう。まず「両親」という規則を定義します。両親は、父親か母親という事実を満たせばいいですね。このような場合、次のように定義します。
リスト : 両親の定義 (?x は ?y の両親である) ((両親 ?x ?y) (父親 ?x ?y)) ((両親 ?x ?y) (母親 ?x ?y))
「両親は父親である」と「両親は母親である」という規則を定義しただけですが、最初の節が失敗したら次の節が選択されるので、「両親は父親または母親である」という条件を満たしています。
ほかのプログラミング言語では、「～または～」という条件は OR を使って表現するのが一般的です。ところが、今回のようなエキスパートシステムでは、Prolog の場合も同様ですが、複数の規則を定義するだけで OR を実現することができるのです。それでは実行してみましょう。一郎の両親は誰か質問してみます。
* (ask '(両親 ?x 一郎)) ?X = 花子 ?X = 太郎 NIL
正解は太郎と花子です。うまく動作していますね。それでは、この規則を使って「息子」という規則を定義しましょう。?x が ?y の息子であるならば、?y は ?x の両親でかつ ?x は男性のはずです。したがって、規則は次のようになります。
リスト : 息子の定義 (?x は ?y の息子である) ((息子 ?x ?y) (両親 ?y ?x) (男性 ?x))
「かつ」は規則でゴールを順番に並べれば実現できましたね。まず (両親 ?y ?x) を満たす関係を求めます。そのあと、(男性 ?x) で ?x が男性であることを確かめます。(男性 ?x) で失敗しても、(両親 ?y ?x) に戻って次の候補を見つけてくれるので大丈夫です。それでは実行してみましょう。
* (ask '(息子 ?x 花子)) ?X = 次郎 ?X = 一郎 NIL
花子の息子は一郎と次郎である、と答えが出ました。この節で (男性 ?x) を (女性 ?x) に変更すると「娘」の関係を表すことができます。
リスト : 娘の定義 (?x は ?y の娘である) ((娘 ?x ?y) (両親 ?y ?x) (女性 ?x))
最後に「祖父」の関係を求める規則を定義しましょう。これは今までと違ってちょっと面倒です。?x の祖父 ?y を求めるには、まず ?x の両親を求め、さらにその父親を求めます。母方と父方に祖父がいますから、父親の父親を求めるのでは母方の祖父がわかりません。そこで、?x の両親を求めるときに ?x と ?y 以外の新しい変数を用意して、?x の両親をその変数とマッチングさせることにします。
リスト : 祖父の定義 (?x は ?y の祖父である) ((祖父 ?x ?y) (両親 ?z ?y) (父親 ?x ?z))
(両親 ?z ?y) で変数 ?z に ?y の両親が代入されます。そして、次のゴール (父親 ?x ?z) で ?z の父親が ?x に代入されます。変数を使うことで実行結果を保持し、次のゴールへ値を渡すことができるのです。それでは実行してみましょう。
* (ask '(祖父 ?x ?y)) ?Y = 洋子 ?X = 太郎 ?Y = 三郎 ?X = 太郎 NIL
祖父と同じように「祖母」の関係も定義できます。
●実行例 -- 簡単なリスト操作
今回作成したエキスパートシステムは、簡単なリスト操作も行うことができます。ユニフィケーション unify は、ドット対を使うと面白い動作をします。次の例を見てください。
* (unify '(春 夏 秋 冬) '(?x . ?y) nil) ((?Y 夏 秋 冬) (?X . 春))
リストとドット対をマッチングすると、ドットの後ろの変数は「残りのリストすべて」とマッチングします。この場合、?x が先頭の要素とマッチングし、春を取り除いた残りのリストと ?y がマッチングします。
これは、unify の仕組みから考えると当然の動作です。まず、春と ?x がマッチングしますね。次は、CDR 部が取り出されますが、この場合、(夏 秋 冬) と ?y を照合することになります。したがって、?y の値は (夏 秋 冬) となるのです。もう少し例を見てみましょう。
* (unify '(春 夏 秋 冬) '(?x ?y . ?z) nil) ((?Z 秋 冬) (?Y . 夏) (?X . 春))
この例では、?x が春、?y が夏にマッチングし、残りのリストと ?z がマッチングします。Lisp では、car でリストの先頭の要素を、cdr で先頭を取り除いた残りのリストを求めることができますが、今回のシステムでは、パターンマッチングを行うことでリストを分解することができるのです。実は、Prolog でも同じようにリストを操作することができます。
それでは具体的にリスト操作を行う規則を作ってみましょう。先頭の要素を求めることと、先頭の要素を取り除いた残りのリストを求めることは、リストのパターンマッチングを使えば簡単に実現できます。
リスト : リスト操作 ;;; 先頭の要素を取り出す ((first (?x . ?y) ?x)) ;;; 先頭の要素を取り除いたリストを求める ((rest (?x . ?y) ?y))
Ｃ言語や Lisp などのプログラミング言語では、実行結果を関数の返り値として出力させます。ところが、今回のエキスパートシステムでは、第 1 引数にリストを与え、第 2 引数の変数で解を取り出すように定義します。簡単な実行例を示しましょう。
* (ask '(first (a b c d) ?z)) ?Z = A NIL * (ask '(rest (a b c d) ?z)) ?Z = (B C D) NIL
first も rest もリストと (?x . ?y) をマッチングします。?x には a が、?y には (B C D) がセットされます。first の場合は変数 ?z と変数 ?x がマッチングするので、?z の値は a となります。rest の場合は変数 ?y とマッチングするので、?z の値は (B C D) となるのです。
次に、リストの先頭にデータを追加する規則を作ります。
リスト : リストの先頭にデータを追加 ((add_to_list ?x ?l (?x . ?l)))
では、実行例を見てください。
* (ask '(add_to_list a (b c d) ?z)) ?Z = (A B C D) NIL
第 1 引数に追加するデータ、第 2 引数にリスト、第 3 引数で結果を受け取ります。Lisp では cons でリストの合成を行いますが、このシステムではパターンマッチングで行うことができるのです。
次は、2 つのリストを 1 つのリストに結合する規則を作りましょう。Lisp の関数 append と同じ働きします。Lisp は再帰を使って簡単に作ることができました。今回作成したエキスパートシステムでも、再帰を使って簡単に作ることができます。
リスト : リストの結合 ((append nil ?x ?x)) ((append (?u . ?x) ?y (?u . ?z)) (append ?x ?y ?z))
append は、第 1 引数と第 2 引数のリストを結合した結果が、第 3 引数にセットされます。最初の規則は、空リストと ?x を結合すると ?x である、ということを表しています。これが再帰呼び出しの停止条件になります。次の規則では、頭部で第 1 引数のリストを ?u と ?x に分解して、?x と ?y を append したリスト ?z の先頭に ?u を追加します。
実際の動作は、再帰呼び出しによって第 1 引数のリストが分解され、停止条件で第 2 引数が第 3 引数とマッチングします。この間 ?z はずっと自由変数のままであることに注意してください。再帰呼び出しから戻るときに ?z は束縛されるのです。
停止条件から戻ってきた直後に、?z は第 2 引数のリストに束縛されています。あとは、(?u . ?z) によって第 1 引数の要素が追加され、その値が呼び出し元の ?z の値となります。けっきょく、再帰呼び出しから戻っていくときに、第 1 引数の要素が ?z に追加されていって、リストが連結されるのです。
なにか騙されているように思われるかもしれませんが、これで正常に動作します。それでは実行してみましょう。
* (ask '(append (a b c) (d e f) ?z)) ?Z = (A B C D E F) NIL * (ask '(append ((a b) (c d)) ((e f) (g h)) ?z)) ?Z = ((A B) (C D) (E F) (G H)) NIL
プログラムの動作を考えると頭が混乱するかもしれません。このようなエキスパートシステムでは、「矛盾しないように規則を定義する」ことを心がけた方がよいのでしょう。
ところで、append はリストを結合するだけでなく、リストを分解する動作を行うことができます。
* (ask '(append ?z (c d) (a b c d))) ?Z = (A B) NIL * (ask '(append (a b) ?z (a b c d))) ?Z = (C D) NIL
もっと凄いのが、第 1 引数と第 2 引数を変数にすることです。
* (ask '(append ?x ?y (a b c d))) ?Y = NIL ?X = (A B C D) ?Y = (D) ?X = (A B C) ?Y = (C D) ?X = (A B) ?Y = (B C D) ?X = (A) ?Y = (A B C D) ?X = NIL NIL
このように、2 つのリストに分解できるすべての組み合わせを求めることができます。ひとつの規則で複数の使い方ができるのが、ほかの言語にはマネのできない面白い特徴です。
今度は、リストの中から要素をひとつ選ぶ規則を作ってみます。
リスト : 要素の選択 ((select ?x (?x . ?l) ?l)) ((select ?x (?y . ?l) (?y . ?z)) (select ?x ?l ?z))
select は第 2 引数のリストから要素を選んで第 1 引数の変数にセットし、第 3 引数に残りのリストをセットします。最初の規則は簡単ですね。第 2 引数のリストを分解して先頭の要素を選びます。そして 2 番目の規則では、先頭要素を取り除いた残りのリストの中から要素を選びます。頭部の第 2 引数 (?y . ?l) でリストを分解し、select を再帰呼び出しします。要素 ?y は取り除いたリスト ?z に追加することをお忘れなく。
それでは実行してみましょう。
* (ask '(select ?x (a b c) ?y)) ?Y = (A B) ?X = C ?Y = (A C) ?X = B ?Y = (B C) ?X = A NIL
この select を使って順列を求めることができます。
リスト : 順列を求める ((perm nil nil)) ((perm ?x (?z . ?l)) (select ?z ?x ?y) (perm ?y ?l))
perm は第 1 引数のリストに格納されている要素の順列を第 2 引数の変数に求めます。2 番目の規則を見てください。?x から select で要素をひとつ選び ?z にセットします。次に、残ったリスト ?y の順列を perm で求め、その結果 ?l に ?z を追加すれば ?x の順列は完成します。再帰の停止条件は、リストの要素が無くなった場合です。
再試行するたびに select は新しい要素を返すので、これですべての順列を求めることができるのです。では、実行してみましょう。
* (ask '(perm (a b c) ?y)) ?Y = (C B A) ?Y = (C A B) ?Y = (B C A) ?Y = (B A C) ?Y = (A C B) ?Y = (A B C) NIL
正常に動作していますね。パターンマッチングとバックトラックだけで、ここまでリスト操作ができるとは驚きです。ただし、変数の使い方がＣ言語や Lisp と大きく異なるので、慣れるまでちょっと苦労しそうですね。
これまで作成したリスト操作は Prolog でも同じように行えます。参考までに、Prolog で書かれたプログラムを示します。
リスト : Prolog のプログラム % 先頭の要素を取り出す first([X | Y], X). % 先頭の要素を取り除いたリストを求める rest([X | Y], Y). % リストの先頭にデータを追加 add_to_list(X, L, [X | L]). % リストの結合 append([], X, X). append([U | X], Y, [U | Z]) :- append(X, Y, Z). % 要素の選択 select(X, [X | L], L). select(X, [Y | L], [Y | Z]) :- select(X, L, Z). % 順列を求める perm([], []). perm(X, [Z | L]) :- select(Z, X, Y), perm(Y, L).
Prolog では、リストを [X, Y, Z] のように [ ] で表します。要素がない [ ] は空リストを表していて、ドット対のドット ( . ) に対応するのが | です。エキスパートシステムの規則とほとんど同じですね。このシステムに数値演算、条件分岐、入出力などの機能を組み込むことで、よりいっそう Prolog インタプリタに近づけることができます。
●まとめ
パターンマッチングとバックトラックを用いて、規則の中から答えを導き出す簡易エキスパートシステムを作成しました。ドキュメントはちょっと長くなりましたが、プログラム自体は約 7 k byte です。記号処理が得意な Lisp だからこそ、ここまでコンパクトに記述できたと思います。ほかの言語ではパターンマッチングを作るだけでも大変でしょう。
今回作成したプログラムは簡易システムとはいいながら、その動作は Prolog とほぼ同じです。もっとも、これより複雑な規則を作るのであれば、このシステムでは力不足です。これに対し Prolog はプログラミング言語です。Lisp と同様に、データ型を判定する述語、算術演算、プログラムを制御するための述語や入出力が組み込まれているので、本格的なプログラムを作成することができます。
一時期、第五世代プロジェクトの影響で Prolog の人気が沸騰しましたが、近年は鎮静化してしまったようです。ですが、Prolog は面白い特徴を持ったプログラミング言語です。事実と規則を定義していく、つまり、物事の関係を記述していくプログラミングスタイルは、ほかの言語にはない独自なものです。M.Hiroi が初めて Prolog でプログラミングしたときは、Ｃ言語や Lisp との違いが大きすぎて、とても困惑してしまいました。かえって、ほかの言語を知らない方が、Prolog を簡単にマスターできるかもしれません。
このエキスパートシステムに興味を持たれた方は、ぜひ Prolog にも挑戦してみてください。よろしければ拙作のページ Prolog Programming もお読みくださいませ。
●プログラムリスト
;;;
;;; expert.lisp : Prolog 風簡易エキスパートシステム
;;;
;;; Copyright (C) 2003-2020 Makoto Hiroi
;;;
(declaim (ftype (function (t list) t) replace-variable)
(ftype (function (t t list) t) unify)
(ftype (function (t) t) exec-body exec-clause))
;;;
;;; サブルーチン
;;;
;;; 変数をチェックする
(defun variablep (pattern)
(and (symbolp pattern)
(char= #\? (char (string pattern) 0))))
;;; 変数束縛に追加する
(defun add-binding (var value binding)
(cons (cons var value) binding))
;;; 節で使用されている変数を集める
(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 variable-value (var binding)
(let (value)
(loop
(setq value (assoc var binding))
(unless value (return var))
(setq value (cdr value))
(cond
((eq var value)
(return value))
((variablep value)
(setq var value))
((consp value)
(return (replace-variable value binding)))
(t (return value))))))
;;; 変数を置換する
(defun replace-variable (pattern binding)
(cond
((variablep pattern)
(variable-value pattern binding))
((atom pattern) pattern)
(t
(cons (replace-variable (car pattern) binding)
(replace-variable (cdr pattern) binding)))))
;;;
;;; ユニフィケーション
;;;
;;; アトムとのユニフィケーション
(defun unify-atoms (pattern datum binding)
(if (equal pattern datum) binding 'fail))
;;; リストのユニフィケーション
(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 (pattern datum binding)
(let ((value (assoc pattern binding)))
(if (and value
(not (eq pattern (cdr value))))
(unify (cdr value) datum binding)
(add-binding pattern datum binding)))) ; insidep のチェックは不要
;;; 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 'fail)))
;;;
;;; 節 (事実と規則) の定義
;;;
(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 check-clause (clause)
(dolist (x clause)
(if (or (atom x)
(variablep (car x))
(not (symbolp (car x))))
(error "節に述語がありません ~A~%" clause))))
;;; 節の登録
(defun asserta (clause)
(check-clause clause)
(let ((predicate (car (car clause))))
(setf (get predicate 'RULE)
(cons (make-rule-obj clause) (get predicate 'RULE)))))
;;;
;;; 節の実行
;;;
;;; 実行環境の定義
(defstruct env
goal ; ゴール節
rule-list ; 述語に定義されている規則
exec-rule ; 実行中の規則
exec-env ; 作成した環境（スタックになる）
binding ; 束縛リスト
prev-binding) ; env を作成したときの束縛リスト
;;; 実行環境の作成
(defun make-env-obj (pattern binding)
(make-env
:goal pattern
:rule-list (get (car pattern) 'RULE)
:binding 'call
:prev-binding binding))
;;; 頭部とのユニフィケーション
(defun unify-head (env)
(let ((result 'fail) now-rule)
(loop
(unless (env-rule-list env) (return))
;; 節をコピーする
(setq now-rule (copy-clause (pop (env-rule-list env))))
;; 節の head と goal のユニフィケーション
(setq result (unify (env-goal env) (pop now-rule) (env-prev-binding env)))
(when (listp result)
;; 成功
(setf (env-exec-rule env) now-rule
(env-binding env) result)
(return)))
result))
;;; 頭部と照合する規則を選択
(defun select-rule (env)
(let ((result 'fail))
(loop
(unless (and (listp (setq result (unify-head env)))
(env-exec-rule env))
(return))
;; 実行環境の生成
(push (make-env-obj (car (env-exec-rule env)) result)
(env-exec-env env))
;; 体部の実行
(setq result (exec-body env))
(if (listp result) (return)))
result))
;;; 節の実行
(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))))
;; 結果を返す
result))
;;; 体部の実行
(defun exec-body (env)
(let ((max-state (length (env-exec-rule env)))
(result 'fail)
now-state)
(loop
(unless (env-exec-env env) (return))
(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) result)
(env-exec-env env)))))
result))
;;; データのロード
(defun load-data (filename)
(let (clause)
(with-open-file (in filename :direction :input)
(loop while (setq clause (read in nil))
do (asserta clause)))))
;;; 質問する
(defun ask (question)
(let* ((rule (make-rule-obj question))
(env (make-env-obj (rule-clause rule) nil))
result)
(loop
(unless (listp (setq result (exec-clause env)))
(return))
(dolist (var (rule-var-list rule) (terpri))
(format t "~a = ~a~%" var (variable-value var result))))))