プロダクション・システム

	;; 前向き推論はつぎの3つのステップの繰り返しによって実現される
	;; Step1 照合(パターンマッチング)
	;; ルールベースの中のすべてのプロダクションルールの条件部とワー
	;; キングメモリーの内容とを照合し、実行可能なルールの集まり
	;; を探す。実行可能なルールがなければ終了する。
	;; Step2 競合の解消
	;; 実行可能なルールの集まりの中から実際に実行するルールを1
	;; つ選択する。以下の例ではユーザーがこれを行う。
	;; Step3 動作
	;; 競合の解消によって選ばれたルールの結論部を実行する。これ
	;; によりワーキングメモリーの内容は更新される。
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 推論エンジンの実現
	(define (forward-reasoning memory)
	;; Step-1 照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action rule memory))) ;Step-3 動作
	(output-data memory) ;ワーキングメモリーの出力
	(loop (choice (pattern-matching memory))
	memory)))))
	;; ワーキングメモリの内容を出力する手続き
	(define (output-data memory)
	(printn " *working-memory* :" memory))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 照合 : pattern-matching
	;;; pattern-matching は、ワーキングメモリーの内容 states とルールベー
	;;; ス *rule-base* から実行可能なルールの集まりを求める手続き
	;; PLT 実装依存の filter を使ったヴァージョン
	;; SRFI-1 を用いても良い
	(define (pattern-matching states)
	;; 全体が評価値
	(map get-rulename
	;; 偽ならそのルールをフィルタリングする
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-cond candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 実行 : rule-action
	;; ルールの結論部を実行することで、ワーキングメモリーの内容 memory を
	;; 変更する手続き
	(define (rule-action r memory) ; r はルール名
	(let ((rule (get-rule r *rule-base*)))
	(if (null? rule)
	memory
	;; ルールの実行部を評価する
	(eval-action (get-action rule) memory))))
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;;;; ルールベースの表現
	(define *rule-base*
	'((rule1 (and (USA) (English)) --> (Honolulu))
	(rule2 (and (Europe) (France)) --> (Paris))
	(rule3 (and (USA) (Continent)) --> (LosAngels))
	(rule4 (and (Island) (Equator)) --> (Honolulu))
	(rule5 (and (Asia) (Equator)) --> (Singapore))
	(rule6 (and (Island) (Micronesia)) --> (Guam))
	(rule7 (Swimming) --> (Equator))))
	;;;; ワーキングメモリーの表現
	(define *working-memory* '((Island) (Swimming)))
	;;;; eval-action
	(define (eval-action action memory) ; action は実行される結論部
	(printn "action : " action) ;追加される結論部の表示
	(cons action memory)) ;結論部の追加 & memory の内容が評価値
	;; ;; 実行例
	;; > (forward-reasoning *working-memory*)
	;; enable rules : (rule7)
	;; enter rule-name >> rule7
	;; action : (Equator)
	;; *working-memory* :((Equator) (Island) (Swimming))
	;; enable rules : (rule4 rule7)
	;; enter rule-name >> rule4
	;; action : (Honolulu)
	;; *working-memory* :((Honolulu) (Equator) (Island) (Swimming))
	;; enable rules : (rule4 rule7)
	;; enter rule-name >> quit
	;; end
	;; >

view raw forward-reasoning.ss hosted with ❤ by GitHub

	;;;; ルールベースの表現
	;; ・もし、積木 x の上に何もないならば、x をテーブルの上に置く。こ
	;; れを (on x table) と表現する。
	;; ・もし、積木 x と y の上に何もないならば、 x を y の上に積む。こ
	;; れを (on x y) と表現する。
	(define *rule-base*
	'((rule1 (clear a) --> (on a table))
	(rule2 (clear b) --> (on b table))
	(rule3 (clear c) --> (on c table))
	(rule4 (and (clear a) (clear b)) --> (on a b))
	(rule5 (and (clear a) (clear c)) --> (on a c))
	(rule6 (and (clear b) (clear a)) --> (on b a))
	(rule7 (and (clear b) (clear c)) --> (on b c))
	(rule8 (and (clear c) (clear a)) --> (on c a))
	(rule9 (and (clear c) (clear b)) --> (on c b))))
	;;;; 積み木の世界の実行部
	;; (on x y) 形式で表現されている結論部を実行
	(define (eval-action rule memory) ; memory はワーキングメモリの内容
	(let ((act (car rule)))
	(if (eq? act 'on)
	(on (cadr rule) (third rule) memory) ; on の実行
	'())))
	;; 第1引数 x を第2引数 y の上に置く操作を実現
	(define (on x y memory)
	;; (clear y) を除き
	;; (on x y) になってたら (clear z) を加え、 (on x z) を除き
	;; (on x y) を加え評価値とする
	(cons `(on ,x ,y)
	(insert-clear x (remove-clear y memory))))
	;; (remove-clear 'c '((on a table) (on c a) (clear c)))
	;; ===> ((on a table) (on c a))
	(define (remove-clear foo lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(let ((item (car lst))
	(state (caar lst))
	(block (cadar lst)))
	(loop (cdr lst)
	(if (and (eq? block foo) (eq? state 'clear))
	acc
	(cons item acc)))))))
	;; (insert-clear 'c '((on a table) (on c a) (clear c)))
	;; ===> ((on a table) (clear a) (clear c))
	(define (insert-clear foo lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(let ((item (car lst))
	(state (caar lst))
	(block (cadar lst)))
	(loop (cdr lst)
	(call/cc
	(lambda (k)
	(cons
	(cond
	((not (and (eq? block foo) (eq? state 'on)))
	item)
	((eq? (caddr item) 'table)
	(k acc))
	(else
	`(clear ,(caddr item))))
	acc))))))))
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 推論エンジンの実現
	(define (forward-reasoning memory)
	;; Step-1 照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action rule memory))) ;Step-3 動作
	(output-data memory) ;ワーキングメモリーの出力
	(loop (choice (pattern-matching memory))
	memory)))))
	;; ワーキングメモリの内容を出力する手続き
	(define (output-data memory)
	(printn " *working-memory* :" memory))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 照合 : pattern-matching
	;;; pattern-matching は、ワーキングメモリーの内容 states とルールベー
	;;; ス *rule-base* から実行可能なルールの集まりを求める手続き
	;; PLT 実装依存の filter を使ったヴァージョン
	;; SRFI-1 を用いても良い
	(define (pattern-matching states)
	;; 全体が評価値
	(map get-rulename
	;; 偽ならそのルールをフィルタリングする
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-cond candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 実行 : rule-action
	;; ルールの結論部を実行することで、ワーキングメモリーの内容 memory を
	;; 変更する手続き
	(define (rule-action r memory) ; r はルール名
	(let ((rule (get-rule r *rule-base*)))
	(if (null? rule)
	memory
	;; ルールの実行部を評価する
	(eval-action (get-action rule) memory))))
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;; ;; 実行例
	;; > (define *working-memory*
	;; '((on a table) (clear b) (on b table) (on c a)
	;; (clear c)))
	;; > (forward-reasoning *working-memory*)
	;; enable rules : (rule2 rule3 rule7 rule9)
	;; enter rule-name >> rule3
	;; *working-memory* :((on c table) (on a table) (clear b) (on b table) (clear a) (clear c))
	;; enable rules : (rule1 rule2 rule3 rule4 rule5 rule6 rule7 rule8 rule9)
	;; enter rule-name >> rule7
	;; *working-memory* :((on b c) (on c table) (on a table) (clear b) (clear a))
	;; enable rules : (rule1 rule2 rule4 rule6)
	;; enter rule-name >> rule4
	;; *working-memory* :((on a b) (on b c) (on c table) (clear a))
	;; enable rules : (rule1)
	;; enter rule-name >> quit
	;; end
	;; >

view raw bricks.ss hosted with ❤ by GitHub

	;;;; ルールベースの表現
	(define *rule-base*
	'((rule1 (and (USA) (English)) --> (Honolulu))
	(rule2 (and (Europe) (France)) --> (Paris))
	(rule3 (and (USA) (Continent)) --> (LosAngels))
	(rule4 (and (Island) (Equator)) --> (Honolulu))
	(rule5 (and (Asia) (Equator)) --> (Singapore))
	(rule6 (and (Island) (Micronesia)) --> (Guam))
	(rule7 (Swimming) --> (Equator))))
	;;;; ワーキングメモリーの表現
	(define *working-memory* '((Honolulu)))
	;;;; 推論エンジンの実現
	;; Step1 照合
	;; 目標をルールの結論部として含むルールの集まりを探す。その
	;; ようなルールがなければ、仮定は否定されたとして終了する。
	;; Step2 競合の解消
	;; ルールの集まりの中からルールを1つ選択する。前向き推論と
	;; 同様に、ユーザーがこれを行うものとする。
	;; Step3 動作
	;; 選択されたルールの条件部への各要素がつぎの条件のいずれかを
	;; 満たしていれば、これらを新しい目標値とし、Step1 へと戻る。
	;; 1) 他のルールへの結論部として含まれている。
	;; 2) ユーザーへの問い合わせによって肯定された。
	;; これらの条件が満足されなければ、仮定は否定されたこととし
	;; て終了する。
	(define (backward-reasoning memory) ;目標を memory とする
	;; Step-1 最初の目標の照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching-back memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action-back rule))) ; Step-3 動作
	(output-data-back memory) ; 結果の出力
	(loop (choice (pattern-matching-back memory)) memory)))))
	;;; 仮定が成立しないときに、そのことを出力する手続き
	(define (output-data-back item)
	(and (null? item)
	(printn (caar *working-memory*)
	" is unsuitable for you.")))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 照合 : pattern-matching-back
	;;; states で表される結論部をもつルールを
	;;; *rule-base* から探す手続き
	(define (pattern-matching-back states)
	;; 全体が評価値
	(map get-rulename ;以降が真ならそのルールを含める
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-action candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 実行 : rule-action-back
	;;; 選択されたルールの条件部が論理積の形式である
	;;; かどうかに応じて、 eval-action-back を呼び出し、
	;;; 新しい目標とすべき要素のリストを返す
	(define (rule-action-back r) ; r は選択されたルール名
	(let ((rule (get-rule r *rule-base*))) ;ルール r を取り出す
	(if (null? rule)
	'()
	(let ((items (get-cond rule)))
	(let ((item (car items)))
	(eval-action-back
	(if (eq? item 'and) ;論理積であるか?
	(cdr items) ;論理積の場合
	`(,items))
	'()))))))
	(define (eval-action-back items lst)
	(if (null? items)
	lst
	(let ((item (car items)))
	(let ((rules (pattern-matching-back `(,item))))
	(call/cc
	(lambda (k)
	(eval-action-back (cdr items)
	;; 条件部が他のルールの結論部に含まれている場合
	(if (or (pair? rules)
	;; あるいはユーザーに質問
	(eq? (question item) 'y))
	;; 論理積で記述されているならばつぎの条件の評価
	(cons item lst)
	(k '())))))))))
	(define (question lst)
	(and (pair? lst)
	(begin
	(printn "Do you feel satisfied next condition ?")
	(printn (car lst)) ;条件の表示
	(display "Please input 'y' or 'n' >> ")
	(read)))) ; y, n の読み込み
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;; ;; 実行例
	;; > (backward-reasoning *working-memory*)
	;; enable rules : (rule1 rule4)
	;; enter rule-name >> rule4
	;; Do you feel satisfied next condition ?
	;; Island
	;; Please input 'y' or 'n' >> y
	;; enable rules : (rule7)
	;; enter rule-name >> rule7
	;; Do you feel satisfied next condition ?
	;; Swimming
	;; Please input 'y' or 'n' >> y
	;; end
	;; >

view raw backward-reasoning.ss hosted with ❤ by GitHub