それでは、実際にプログラムを作っていきましょう。まずは節の定義からです。節は構造体 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))))))