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 run time
(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 run time 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
run time"
(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"))
KnowledgeWorks and Prolog User Guide (Unix version) - 24 Mar 2017