B.1 The Tutorial

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

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

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

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

(defrule game-finished :forward

  :priority 15

  (game-over ?g)

  -->

  (erase ?g)

;  (test (not (tk:confirm-yes-or-no "Play again?")))

  (return))

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

(defrule does-not-exist-already :backward

  ((does-not-exist-already ?animal)

   <--

   (node ? animal ?animal)

   (cut)

   (fail))

  ((does-not-exist-already ?animal)

   <-- ))

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

KnowledgeWorks and Prolog User Guide (Macintosh version) - 24 Mar 2017