KnowledgeWorks and Prolog User Guide > B Examples

NextPrevUpTopContentsIndex

B.2 Explanation Facility

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"))

KnowledgeWorks and Prolog User Guide (Unix version) - 22 Dec 2009

NextPrevUpTopContentsIndex