(defparameter *grammar1*
  '((sentence -> (NP VP))
    (NP -> (Art Noun))
    (VP -> (Verb NP))
    (Art -> the a)
    (Noun -> man ball woman table)
    (verb hit took saw liked)))

(defparameter *grammar3*
  '((sentence -> (NP VP))
    (NP -> (Art Noun))
    (VP -> (Verb NP))
    (Art -> the) (Art -> a)
    (Noun -> man)
    (Noun -> ball)
    (Noun -> woman)
    (Noun -> table)
    (Noun -> noun)
    (Noun -> verb)
    (Verb -> hit)
    (verb -> took)
    (verb -> saw)
    (verb -> liked)))

(defparameter *grammar4*
  '((S -> (NP VP))
    (NP -> (D N))
    (NP -> (D A+ N))
    (NP -> (NP PP))
    (NP -> (Pro))
    (NP -> (Name))
    (VP -> (V NP))
    (VP -> (V))
    (VP -> (VP PP))
    (PP -> (P NP))
    (A+ -> (A))
    (A+ -> (A A+))
    (Pro -> I) (Pro -> you) (Pro -> he) (Pro -> she)
    (Pro -> it) (Pro -> me) (Pro -> him) (Pro ->her)
    (Name -> Matsui) (Name -> Asoh)
    (A -> big) (A -> little) (A -> old) (A -> young)
    (A -> blue) (A -> green) (A -> orange) (A -> perspicuous)
    (D -> the) (D -> a) (D -> an)
    (N -> man) (N -> ball) (N -> woman) (N -> ball) (N -> table)
    (N -> orange) (N -> saw) (N -> saws) (N -> noun)
    (N -> verb)
    (P -> with) (P -> for) (P -> at) (p -> on) (p -> by) (p -> of) (p -> in) 
    (V -> hit)
    (v -> took)
    (v -> saw)
    (v -> liked)
    (V -> saws)))


(defvar *grammar* *grammar1*)

(defun new-tree (cat rhs) (cons cat rhs))

(defun rule-lhs (rule) (first rule))
(defun rule-rhs (rule) (rest (rest rule)))
(defun tree-lhs (tree) (first tree))
(defun tree-rhs (tree) (rest tree))

(defun parse-lhs (parse) (tree-lhs (first parse)))

(defun lexical-rules (word)
   (mapcan #'(lambda (x) (if (equal (car (rule-rhs x)) word) (list x)))
	   *grammar*))

(defun rules-starting-with (cat)
   (mapcan #'(lambda (x) (if (eql (first-or-nil (car (rule-rhs x))) cat) (list x)))
	   *grammar*))
(defun first-or-nil (x)
   (if (consp x) (first x) nil))
(defun parser (words)
   (mapcar #'first (complete-parses (parse words))))

(defun complete-parses (parses)
   (mapcan #'(lambda (x) (if (null (second x)) (list x))) parses))

(defun random-elt (choices)
   (elt choices (random (length choices))))
(defun one-of (set) (list (random-elt set)))
(defun rewrites (cat)
   (rule-rhs (assoc cat *grammar*)))
(defun mappend (fn the-list)
   (apply #'append (mapcar fn the-list)))
(defun generate (phrase)
   (cond ((listp phrase) (mappend #'generate phrase))
         ((rewrites phrase)
  	   (generate (random-elt (rewrites phrase))))
	 (t (list phrase))))

(defun parse (words)
   (unless (null words)
	(mapcan #'(lambda (rule)
			(extend-parse (rule-lhs rule) (list (first words))
					(rest words) nil))
		(lexical-rules (first words)))) ) 

(defun extend-parse (lhs rhs rem needed)
   (if (null needed)
	(let ((parse (list (new-tree lhs rhs) rem)))
	   (cons parse
		 (mapcan 
		    #'(lambda (rule)
			(extend-parse (rule-lhs rule)
				      (list (first parse))
				      rem (rest (car (rule-rhs rule)))))
		    (rules-starting-with lhs))))
	(mapcan #'(lambda (p)
		     (if (eq (parse-lhs  p) (first needed))
			 (extend-parse lhs (append1 rhs (first p))
			 		(second  p) (rest needed))))
		(parse rem))))

(defun append1 (items item) (append items (list item)))

