forward-reasoning.ss

;; 前向き推論はつぎの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
;; >