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.

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

(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) - 6 Dec 2011