bricks.ss

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

;; ・もし、積木 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
;; >