B.1 The Tutorial

The code for the tutorial (2 Tutorial) is reproduced for easy reference.

; -*-mode : lisp ; package : kw-user -*-
 
(in-package kw-user)
 
;;; ---------------- OBJECT DEFINITIONS ------------
 
(def-kb-class node ()
   ((animal :initform nil :accessor node-animal
            :initarg :animal)
    (question :initform nil :accessor node-question
              :initarg :question)
    (yes-node :initform nil :accessor node-yes-node
              :initarg :yes-node)
    (no-node :initform nil :accessor node-no-node
             :initarg :no-node)))
 
(def-kb-class root ()
   ((node :initform nil :accessor root-node
          :initarg :node)))
 
(def-kb-struct current-node node)
(def-kb-struct game-over node animal answer)
 
;;; -------------- FORWARD CHAINING RULES -------------
 
;;; if there is no question we are about to ask then
;;; ask the question which is the root question of the
;;; question tree
 
(defrule play :forward
  (root ?r node ?node)
  (not (current-node ? node ?))
  -->
  ((tk:send-a-message
     (format nil "  ANIMAL GUESSING GAME - ~
          think of an animal to continue")))
  (assert (current-node ? node ?node)))
;;; ask a yes/no question - these are non-leaf questions
 
(defrule y-n-question :forward
  (current-node ?current node ?node)
  (node ?node animal nil question ?q yes-node ?y-n
    no-node ?n-n)
  -->
  ((tk:confirm-yes-or-no ?q) ?answer)
  (erase ?current)
  ((find-new-node ?answer ?y-n ?n-n) ?new-current)
  (assert (current-node ? node ?new-current)))
 
(defun find-new-node (answer yes-node no-node)
  (if answer yes-node no-node))
 
;;; ask an animal question - these a leaf questions
 
(defrule animal-question :forward
  (current-node ?current node ?node)
  (node ?node animal ?animal question nil)
  -->
  ((tk:confirm-yes-or-no
     (format nil "Is it a ~a?" ?animal)) ?answer)
  (erase ?current)
  (assert (game-over ? node ?node animal ?animal
    answer ?answer)))
 
;;; add new nodes to the tree for the new animal and
;;; the question that distinguishes it
 
(defrule new-question :forward
  :priority 20
  (game-over ? node ?node animal ?animal answer nil)
  -->
  (fetch-new-animal ?new-animal)
  ((tk:popup-prompt-for-string
    (format nil "Tell me a question for which the ~
           answer is yes for a ~a and no for a ~a"
           ?new-animal ?animal)) ?question)
  (assert (node ?yes-node question nil 
           animal ?new-animal))
  (assert (node ?no-node question nil animal ?animal))
  (assert (node ?node animal nil yes-node ?yes-node
           no-node ?no-node question ?question)))
 
;;; game is over
 
(defrule game-finished :forward
  :priority 15
  (game-over ?g)
  -->
  (erase ?g)
;  (test (not (tk:confirm-yes-or-no "Play again?")))
  (return))
 
;;; --------------- BACKWARD CHAINING ----------------
 
;;; prompt user for new animal
 
(defrule fetch-new-animal :backward
   ((fetch-new-animal ?new-animal)
    <--
;    (repeat)
    ((string-upcase
       (tk:popup-prompt-for-string 
                "What was your animal?"))
     ?new-animal)
    (not (= ?new-animal "NIL")) 
                ; check if abort was pressed
    (or
     (does-not-exist-already ?new-animal)
     (and ((tk:send-a-message "Animal exists already"))
          (fail)))))
 
;;; check if a node already refers to this animal
 
(defrule does-not-exist-already :backward
  ((does-not-exist-already ?animal)
   <--
   (node ? animal ?animal)
   (cut)
   (fail))
  ((does-not-exist-already ?animal)
   <-- ))
 
;;; --------------- SAVING THE ANIMAL BASE ------------
 
;;; writes out code which when loaded reconstructs the
;;; tree of questions
 
(defun save-animals (filename)
  (let* ((start-node (any `?node `(root ? node ?node)))
         (code `(make-instance `root
                 :node ,(node-code start-node)))
         (*print-pretty* t))
    (with-open-file
     (stream filename :direction :output
                      :if-exists :supersede)
      (write `(in-package kw-user) :stream stream)
      (write-char #\Newline stream)
      (write code :stream stream))
    nil))
 
(defun node-code (node)
  (when node
    `(make-instance `node 
                   :question ,(node-question node)
       :animal `,(node-animal node)
       :yes-node ,(node-code (node-yes-node node))
       :no-node ,(node-code (node-no-node node)))))