Below is the complete code implementing the simple explanation facility of A Simple Explanation Facility. The implementation principle is exactly as described.
;;; ---------- A SIMPLE EXPLANATION FACILITY ---------
(in-package kw-user)
; connects rule to explanation definitions
(defvar *explanation-table*
(make-hash-table :test #'eq))
; explanation generated at runtime
(defvar *explanation* nil)
;;; the next four definitions make up the defexplain
;;; macro for each of the why, what and because
;;; definitions we create a function which we can call
;;; at runtime on the bindings of the instantiation to
;;; generate the explanation text - this will be
;;; reasonably efficient
(defun is-var (expr)
"is this a variable (i.e. starts with ?)"
(and (symbolp expr)
(eql (char (symbol-name expr) 0) #\?)))
(defun find-vars (expr)
"returns a list of all the variables in expr"
(if (consp expr)
(append (find-vars (car expr))
(find-vars (cdr expr)))
(if (is-var expr) (list expr) nil)))
(defun make-explain-func (explain-stuff)
"generates a function to generate explanation text at
runtime"
(let* ((explain-string (car explain-stuff))
(explain-args (cdr explain-stuff))
(vars (remove-duplicates
(find-vars explain-args))))
`#'(lambda (bindings)
(let ,(mapcar
#'(lambda (v)
`(,v (cdr (assoc `,v bindings))))
vars)
(format nil ,explain-string ,
@explain-args)))))
(defmacro defexplain (rulename &key why what because)
"puts an entry for the rule in the explanation table"
`(setf (gethash `,rulename *explanation-table*)
(list ,(make-explain-func why)
,(make-explain-func what)
,(make-explain-func because))))
;;; next two definitions generate an explanation for
;;; each instantiation that fires and stores it away in
;;; *explanation*
(defun add-explanation (inst)
"generate an explanation for firing this
instantiation"
(let ((explain-info
(gethash (inst-rulename inst)
*explanation-table*)))
(when explain-info
(do-the-rest explain-info (inst-bindings inst)))))
(defun do-the-rest (explain-info bindings)
"creates explanation text derived from explain
functions and bindings"
(let ((why-func (first explain-info))
(what-func (second explain-info))
(because-func (third explain-info)))
(push `(,*cycle* ,(inst-rulename inst)
,(funcall why-func bindings)
,(funcall what-func bindings)
,(funcall because-func bindings))
*explanation*)))))
;;; meta-interpreter for explanation contexts
;;; before firing the rule generate explanation for
;;; this cycle
(defrule explain-context :backward
((explain-context)
<--
(start-cycle)
(instantiation ?inst)
((add-explanation ?inst))
(fire-rule ?inst)
(cut)
(explain-context)))
;;; simple text output of the explanation
(defun explain (&optional cycle)
"print out either the whole explanation or just for
one cycle"
(if cycle (explain-cycle (assoc cycle *explanation*))
(dolist (cycle-entry (reverse *explanation*))
(explain-cycle cycle-entry))))
(defun explain-cycle (entry)
"print this explanation entry"
(if entry
(let ((cycle (first entry))
(rulename (second entry))
(why (third entry))
(what (fourth entry))
(because (fifth entry)))
(format t "~2%~a: ~a~%~a~%~a~%~a"
cycle rulename why what because))
(format t "~2%No explanation for this cycle")))
;;; we could make a really smart tool here, but to give
;;; the general idea...
(defun explain-an-action ()
(let ((item
(tk:scrollable-menu
(reverse *explanation*)
:title "Which action do you want
explained?"
:name-function #'(lambda (x) (fourth x)))))
(if item (tk:send-a-message (fifth item)))))
;;; starting the rule interpreter should clear any old
;;; explanation
(defadvice (infer rest-explanation :before)
(&rest args)
(unless *in-interpreter* (setq *explanation* nil)))
Below are some example rules using the explanation facility. They are taken from the Monkey and Banana Example distributed with KnowledgeWorks. The classes used in the example are
monkey
,
object
and
goal
.
(defrule mb7 :forward
:context mab
(goal ?g status active type holds object ?w)
(object ?o1 kb-name ?w at ?p on floor)
(monkey ?m at ?p holds nil)
-->
((format t "~%Grab ~s" ?w))
(assert (monkey ?m holds ?w))
(assert (goal ?g status satisfied)))
(defexplain mb7
:why ("Monkey is at the ~s which is on the floor" ?w)
:what ("Monkey grabs the ~s" ?w)
:because ("Monkey needs the ~s somewhere else" ?w))
(defrule mb12 :forward
:context mab
:context mab
(goal ?g status active type walk-to object ?p)
(monkey ?m on floor at ?c holds nil)
(test (not (eq ?c ?p)))
-->
((format t "~%Walk to ~s" ?p))
(assert (monkey ?m at ?p))
(assert (goal ?g status satisfied)))
(defexplain mb12
:why ("Monkey is on the floor holding nothing")
:what ("Monkey walks to ~s" ?p)
:because ("Monkey needs to do something with an
object at ~s" ?p))
(defrule mb13 :forward
:context mab
(goal ?g status active type walk-to object ?p)
(monkey ?m on floor at ?c holds ?w)
(test (and ?w (not (eq ?c ?p))))
(object ?o1 kb-name ?w)
-->
((format t "~%Walk to ~s" ?p))
(assert (monkey ?m at ?p))
(assert (object ?o1 at ?p))
(assert (goal ?g status satisfied)))
(defexplain mb13
:why ("Monkey is on the floor and is holding the ~s"
?w)
:what ("Monkey walks to ~s with the ~s" ?p ?w)
:because ("Monkey wants the ~s to be at ~s" ?w ?p))
(defrule mb14 :forward
:context mab
(goal ?g status active type on object floor)
(monkey ?m on ?x)
(test (not (eq ?x `floor)))
-->
((format t "~%Jump onto the floor"))
(assert (monkey ?m on floor))
(assert (goal ?g status satisfied)))
(defexplain mb14
:why ("Monkey is on ~s" ?x)
:what ("Monkey jumps onto the floor")
:because ("Monkey needs to go somewhere"))
(defrule mb17 :forward
:context mab
(goal ?g status active type on object ?o)
(object ?o1 kb-name ?o at ?p)
(monkey ?m at ?p holds nil)
-->
((format t "~%Climb onto ~s" ?o))
(assert (monkey ?m on ?o))
(assert (goal ?g status satisfied)))
(defexplain mb17
:why ("Monkey is at the location of the ~s" ?o)
:what ("Monkey climbs onto the ~s" ?o)
:because ("Monkey wants to be on top of the ~s" ?o))
(defrule mb18 :forward
:context mab
(goal ?g status active type holds object nil)
(monkey ?m holds ?x)
(test ?x)
-->
((format t "~%Drop ~s" ?x))
(assert (monkey ?m holds nil))
(assert (goal ?g status satisfied)))
(defexplain mb18
:why ("Monkey is holding the ~s" ?x)
:what ("Monkey drops the ~s" ?x)
:because ("Monkey wants to do something for which he
can't hold anything"))