;;;; ルールベースの表現

(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
;; >