;;; This is the knowledge tree.
(defvar *animal-data* '("Does it sing" (canary)
			("Can it bark" (dog)
			 ("Does it lay eggs" (chicken)
			  (dolphin)))))

;;; INIT-ANIMAL starts everything
(defun init-animal ()
  (format t "~%Think of an animal and I will try to guess what it is~%by asking questions.~1%")
  ;; Call MAIN-LOOP with the current knowledge tree.
  (main-loop *animal-data*))

;;; MAIN-LOOP figures out whether or not we are at a NODE or a LEAF.
;;; If at a node, it asks the question that is the car of the node.
;;; Otherwise, it calls GUESS with the animal that is at the leaf.
(defun main-loop (knowledge)
  (cond ((question-node-p knowledge) (ask knowledge))
	(t (guess knowledge))))

;;; ASK takes a knowledge tree as input.  It extracts the question
;;; from the tree and poses it.  It loops back to MAIN-LOOP with
;;; either the yes-branch or the no-branch depending on the answer
;;; that the user gives.
(defun ask (knowledge)
  (format t "~%~A?~%" (question knowledge))
  (let ((answer (read-line)))
    (cond ((equalp answer "yes")
	   (main-loop (yes-branch knowledge)))
	  ((equalp answer "no")
	   (main-loop (no-branch knowledge)))
	  (t (format t "~%Please type yes or no.~%")
	     (ask knowledge)))))

;;; GUESS makes a guess.  If the guess is correct,
;;; this iteration of the game is over and it asks
;;; if the player wishes to continue.  If the guess 
;;; is incorrect, it attempts to add to its knowledge tree.
;;; GUESS is called only when we are examining a leaf
;;; of the knowledge tree.
(defun guess (knowledge)
  (format t "~%Is it ~A?~%" (a-or-an (animal knowledge)))
  (let ((answer (read-line)))
    (cond ((equalp answer "yes") (gloat) (play-again?))
	  ((equalp answer "no") (learn knowledge) (play-again?))
	  (t (format nil "~%Please type yes or no.~%")
	     (guess knowledge)))))

;;; LEARN gathers the information to replace the old-node
;;; with a new-node consisting of a question, a yes-branch,
;;; and a no-branch.  Then it calls ADD, which does the 
;;; actual replacement.  The old-node should be on the 
;;; no-branch of the new-node because that is the way the
;;; question is phrased.
(defun learn (old-node)
  (format t "~%Ok, I give up.  What was the answer?~%")
  ;; examine-animal must return a symbol
  (let ((new-animal (examine-animal (read-line))))
    (format t "~%Please type a question whose answer is yes for ~a and no for ~a.~%"
	    (a-or-an new-animal)
	    (a-or-an (animal old-node)))
    (let ((new-question (read-line)))
      (add new-question (animal old-node) new-animal old-node))))

;;; EXAMINE-ANIMAL takes a string and returns a symbol that is
;;; most likely to contain the actual name of the animal.
(defun examine-animal (string)
  (let ((list (list-from-string string)))
    (cond ((= 1 (length list)) (car list))
	  ((or (eq (car list) 'a) (eq (car list) 'an)) (car (list-from-string (single-symbol (cdr list)))))
	  (t (single-symbol (list))))))

;;; SINGLE-SYMBOL takes a list and returns it with hyphenations
;;; between elements in order to form a one-element list
(defun single-symbol (list)
  (if (= 1 (length list)) (car list) (format nil "~a-~a" (car list) (single-symbol (cdr list)))))

;;; LIST-FROM-STRING returns a list with all the
;;; contents read from a string
(defun list-from-string (string)
  (with-input-from-string (my-stream string)
    (let ((eof (list 'eof)))
      (do ((current-object (read my-stream eof) (read my-stream eof))
	   (accumulator nil))
	  ((eq current-object eof) (nreverse accumulator))
	(push current-object accumulator)))))

;;; ADD replaces the old-node with the new-node,
;;; ADD is the constructor function for the game.
(defun add (new-question old-animal new-animal node)
  (setf (car node) new-question)
  (setf (cdr node) (list (list new-animal)
			 (list old-animal))))

(defun a-or-an (symbol)
  (let ((word (format nil "~a" symbol)))
    (cond ((member (char word 0) '(#/A #/E #/I #/O #/U))
	   (format nil "an ~a" (string-downcase word)))
	  (t (format nil "a ~a" (string-downcase word))))))

;;; PLAY-AGAIN? asks the user if he wishes to continue.
(defun play-again? ()
  (format t "~%Do you want to play again?~%")
  (let ((response (read-line)))
    (cond ((equalp response "yes")
	   (init-animal))
	  ((equalp response "no")
	   (format t "~%Au revoir.~%"))
	  (t (format t "~%I guess that's a no.  Goodbye.~%")))))

(defun gloat ()
  (format t "~%It was nothing, folks.  LISPers are god.~%"))

(defun question (knowledge)
  (car knowledge))

(defun animal (knowledge)
  (car knowledge))

(defun question-node-p (knowledge)
  (stringp (question knowledge)))

(defun yes-branch (knowledge)
  (cadr knowledge))

(defun no-branch (knowledge)
  (caddr knowledge))