;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;; Code from Paradigms of Artificial Intelligence Programming
;;; Copyright (c) 1991 Peter Norvig

;; additions by tim@menzies.us

#+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS CL:STYLE-WARNING))

(defun mappend (fn list)
  "Append the results of calling fn on each element of list.
   Like mapcon, but uses append instead of nconc."
  (apply #'append (mapcar fn list)))

(defmacro o (x) 
  "print a named value;
   e.g. (let ((a 22)) (o a)) ==>  [a]=[22]"
  `(progn (format t "[~a]=[~a] " (quote ,x) ,x) ,x))

(defmacro oo (&rest l)
  "print a list of names values;
   e.g. (let ((aa 22) (b 33)) (oo a b)) ==> [a]=22;[b]=[33]"
  `(progn 
    ,@(mapcar #'(lambda(x) `(o ,x)) l) 
    (terpri)))

(defun shuffle (l)
  (let ((n (length l)))
    (loop for i below n do
	  (rotatef
	   (elt l i)
	   (elt l (random n)))))
  l)

(defun ?elt (choices)
  "choose one item  from a list of choices"
  (elt choices (floor (random (length choices)))))

(defun ?elts (choices n)
  "return  up to  n randomly selected choices"
  (if (zerop n)
      nil
      (let ((any (?elt choices)))
	(cons any
	      (?elts (remove any choices)
		     (- n 1))))))

(defun vowelp (character)
  "Returns t if 'character' is a vowel."
  (case character
    ((#\A #\a) t)
    ((#\E #\e) t)
    ((#\I #\i) t)
    ((#\O #\o) t)
    ((#\U #\u) t)
    (otherwise nil)))

(defun number-of-vowels (symbol)
  "Counts the number of vowels in 'string'."
  (labels ((vowel (c) (if (vowelp c) 1 0)))
    (let ((n 0))
      (map nil #'(lambda (c) 
		   (incf n (vowel c)))
	 (string symbol))
      n)))


(defun combine-all (xlist ylist)
  "Return a list of lists formed by appending a y to an x.
  E.g., (combine-all '((a) (b)) '((1) (2)))
  -> ((A 1) (B 1) (A 2) (B 2))."
  (mappend #'(lambda (y)
               (mapcar #'(lambda (x) (append x y)) xlist))
           ylist))

		       
;;; ==============================

(defparameter *simple-grammar*
  '((sentence -> (noun-phrase verb-phrase))
    (noun-phrase -> (Article Noun))
    (verb-phrase -> (Verb noun-phrase))
    (Article -> the a)
    (Noun -> the (!pick 2 aa bb cc dd ee) man ball woman table)
    (Verb -> hit took saw liked))
  "A grammar for a trivial subset of English.")

(defparameter *grammar* *simple-grammar*
  "The grammar used by generate.  Initially, this is
  *simple-grammar*, but we can switch to other grammers.")

;;; ==============================

(defun rule-lhs (rule)
  "The left hand side of a rule."
  (first rule))

(defun rule-rhs (rule)
  "The right hand side of a rule."
  (rest (rest rule)))

(defun rewrites (category)
  "Return a list of the possible rewrites for this category."
  (rule-rhs (assoc category *grammar*)))

;;; ==============================
(defparameter *wme* nil)

(defstruct wme
  "working memory"
  used
  (cost 0)
  (benefit 0))

(defun zap ()
  (setf *wme* (make-wme)))

(defun generate (phrase)
  "Generate a random sentence or phrase"
  (zap)
  (generate1 phrase))

(defun generate1 (phrase)
  (let (action)
    (cond (;; case 1. we have a special action
	   (setf action (actionp phrase)) 
	   (generate1 (funcall action phrase)))

	  ;; case 2: we have a list of options
	  ((listp phrase)
	   (mappend #'(lambda (x) 
			(generate1 x)) 
		    phrase))

	  ;; case 3, we have to rewrite the phrase with a rule
	  ((rewrites phrase)
	   (generate1 (?elt (rewrites phrase))))

	  ;; case 4. none of the above. we have a new atom 
	  ;; to add to the phrases
	  (t (use-one-phrase phrase)))))

(defun actionp (l)  
  "If the head of the list 'l' is one of the 'actions', 
  then return that head."
  (let ((actions '(!pick !otherstuff))
	(action   (and (listp l) (first l))))
    (and (member action actions)
	 action)))

(defun !pick  (l)   
  "(!pick N a b c...). Return N items from (a b c ..)"
  (do-!pick (second l) (cdr (cdr l))))

(defun do-!pick (l n)
  "Worker for !pick"
  (?elts n l))

(defun use-one-phrase (phrase)
  "Unless the phrase has been seen before,
   run the local assessment function and 
   return phrase as a list." 
  (unless (used-before phrase)
    (local-assessment phrase))
  (list phrase))

(defun used-before (phrase)
  (member phrase (wme-used *wme*)))

(defun local-assessment (phrase)
  "Add the phrase to 'used' and
  update the total cost of using all words."
  (push phrase (wme-used *wme*))
  (incf (wme-cost *wme*) 
	(number-of-vowels phrase) ))
	;; note that this is a bogus cost rule. 
	;; (i.e. vowels cost more). but i just
	;; add it here to give you a demo of how
	;; they might be done

;;; ==============================

; CS472 students!!  generate-tree needs to be updated as per genrate and generate1
(defun generate-tree (phrase)
  "Generate a random sentence or phrase,
  with a complete parse tree."
  (cond ((listp phrase)
         (mapcar #'generate-tree phrase))
        ((rewrites phrase)
         (cons phrase
               (generate-tree (random-elt (rewrites phrase)))))
	(t (list phrase))))