The code for the tutorial (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
(doesnt-exist-already ?new-animal)
(and ((tk:send-a-message "Animal exists already"))
(fail)))))
;;; check if a node already refers to this animal
(defrule doesnt-exist-already :backward
((doesnt-exist-already ?animal)
<--
(node ? animal ?animal)
(cut)
(fail))
((doesnt-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)))))