;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;;; Code for the parser adapted from Paradigms of AI Programming
;;;; Copyright (c) 1991 Peter Norvig

(defvar *grammar* nil "The grammar used by GENERATE.")
(defvar *sem-list-verb* nil)
(defvar *sem-list-noun* nil)
(defvar *sem-list-pro*  nil)
(defvar *sem-list-det*  nil)
(defvar *sem-list-prep* nil)

(defvar *me* nil)
(defvar *you* "llamabo")

(defstruct (rule (:type list)) lhs -> rhs)

(defstruct (parse) "A parse tree and a remainder." tree rem)

;; Trees are of the form: (lhs . rhs)
(defun new-tree (cat rhs) (cons cat rhs))
(defun tree-lhs (tree) (first tree))
(defun tree-rhs (tree) (rest tree))

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

(defparameter *open-categories* '(Noun)
  "Categories to consider for unknown words")

(defun lexical-rules (word)
  "Return a list of rules with word on the right hand side."
  (or (find-all word *grammar* :key #'rule-rhs :test #'equal)
      (mapcar #'(lambda (cat) `(,cat -> ,word)) *open-categories*)))

(defun rules-starting-with (cat)
  "Return a list of rules where cat starts the rhs."
  (find-all cat *grammar*
            :key #'(lambda (rule) (first-or-nil (rule-rhs rule)))))

(defun first-or-nil (x)
  "The first element pod x if it is a list; else nil"
  (if (consp x) (first x) nil))

(defun complete-parses (parses)
  "Those parses that are complete (have no remainder)."
  (find-all-if #'null parses :key #'parse-rem))

(defun parse (words)
  "Bottom-up parse, returning all parses of any prefix of 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)
  "Look for the categories needed to complete the parse."
  (if (null needed)
      ;; If nothing needed, return parse and upward extensions
      (let ((parse (make-parse :tree (new-tree lhs rhs) :rem rem)))
	(cons parse
	      (mapcan
	       #'(lambda (rule)
		   (extend-parse (rule-lhs rule)
				(list (parse-tree parse))
				rem (rest (rule-rhs rule))))
	       (rules-starting-with lhs))))
    ;; otherwise try to extend rightward
    (mapcan
     #'(lambda (p)
	(if (eq (parse-lhs p) (first needed))
	     (extend-parse lhs (append1 rhs (parse-tree p))
			     (parse-rem p) (rest needed))))
     (parse rem))))

(defun append1 (items item)
  "Add item to end of list of items."
  (append items (list item)))

(defun length=1 (x)
  "Is x a list of length 1?"
  (and (consp x) (null (cdr x))))

(setf (symbol-function 'find-all-if) #'remove-if-not)

(defun find-all (item sequence &rest keyword-args
                 &key (test #'eql) test-not &allow-other-keys)
  "Find all those elements of sequence that match item,
  according to the keywords.  Doesn't alter sequence."
  (if test-not
      (apply #'remove item sequence
             :test-not (complement test-not) keyword-args)
      (apply #'remove item sequence
             :test (complement test) keyword-args)))

(defun parser (words)
  "Return all complete parses of a list of words."
  (mapcar #'parse-tree (complete-parses (parse words))))

(defun use (grammar)
  "Switch to a new grammar."
  (length (setf *grammar* grammar)))

;;;
;;;
;;;
;;;
(defun getAll (elm list &optional (pos 0) (alist nil))
  (let ((head (car (nth pos list)))(tail (cdr (nth pos list))))
    (cond
     ((null head)
      alist)
     ((eql head elm)
      (getAll elm list (+ pos 1) (push tail alist)))
     (t (getAll elm list (+ pos 1) alist)))))

(defun getLambdaList (PS)
  "Return all lambda funcs associated to this parse"
  (let ((head (car PS)) (tail (cdr PS)))
    (cond
     ((eql head 'S)
      (if (eql (car (nth 1 tail)) 'S)
	  (let ((lambdalist nil))
		(dolist (x (getLambdaList (nth 0 tail)))
		  (dolist (xp (getLambdaList (nth 1 tail)))
		    (push #'(lambda () 
			      (values (funcall x) (funcall xp))) lambdalist)))
		lambdalist)
	(let ((lambdalist nil))
	  (dolist (x (getLambdaList (nth 1 tail)))
	    (dolist (xp (getLambdaList (nth 0 tail)))
	      (push (funcall x xp) lambdalist)))
	  lambdalist)))
     ((eql head 'NP)
      (if (= (length tail) 2)
	  (let ((lambdalist nil))
	    (dolist (x (getLambdaList (nth 0 tail)))
	      (dolist (xp (getLambdaList (nth 1 tail)))
		(push (funcall x xp) lambdalist)))
	    lambdalist)
	(getLambdaList (car tail))))
     ((eql head 'VP)
      (let ((lambdalist nil))
	(dolist (x (getLambdaList (nth 0 tail)))
	  (dolist (xp (getLambdaList (nth 1 tail)))
	    (push (funcall x xp) lambdalist)))
	lambdalist))
     ((eql head 'PP)
      (let ((lambdalist nil))
	(dolist (x (getLambdaList (nth 0 tail)))
	  (dolist (xp (getLambdaList (nth 1 tail)))
	    (push (funcall x xp) lambdalist)))
	lambdalist))
     ((eql head 'DP)
      (if (= (length tail) 2)
	  (let ((lambdalist nil))
	    (dolist (x (getLambdaList (nth 0 tail)))
	      (dolist (xp (getLambdaList (nth 1 tail)))
		(push (funcall x xp) lambdalist)))
	     lambdalist)
	(getLambdaList (car tail))))
     ((eql head 'Prep)
      (getAll (car tail) *sem-list-prep*))
     ((eql head 'Det)
      (getAll (car tail) *sem-list-det*))
     ((eql head 'Pro)
      (getAll (car tail) *sem-list-pro*)) 
     ((eql head 'Verb)
      (getAll (car tail) *sem-list-verb*))
     ((eql head 'Noun)
      (let ((semlist (getAll (car tail) *sem-list-noun*)))
	(if (null semlist)
	    (list #'(lambda () (car tail)))
	  semlist)))
     (t (list 'error)))))


;;; Grammars
(defparameter *grammar3*
  '((S -> (NP VP))
    (S -> (NP S))
    (S -> (S S))
    (NP -> (DP Noun))
    (NP -> (Pro))
    (DP -> (Det))
    (NP -> (Noun))
    (PP -> (Prep NP))
    (VP -> (Verb NP))
    (VP -> (Verb PP))
    (Noun -> man) (Noun -> ball) (Noun -> woman) (Noun -> table) (Noun -> llamabo) (Noun -> F1)
    (Noun -> noun) (Noun -> verb) (Noun -> pizza)
    (Verb -> hit) (Verb -> took) (Verb -> saw) (Verb -> liked) (Verb -> pick) (Verb -> reload)
    (Verb -> go)
    (Prep -> to)
    (Prep -> up)
    (Verb -> is)
    (Det -> the)
    (Det -> a)
    (Pro -> this)
    (Pro -> me)
    (Pro -> you)))

(defparameter *my-sem-list-noun* 
  `((llamabo . ,(lambda () *you* ))
    (ball  . ,(lambda () 'my_beloved_toy_ball1))
    (ball  . ,(lambda () 'my_beloved_toy_ball2))
    (F1    . ,(lambda () "test.lisp"))
    (F2    . ,(lambda () "../NLParser/NLParser.lisp"))
    (PIZZA . ,(lambda () "very very very tasty hmmmmm...... will you save me a pice of it ?:)"))))

(defparameter *my-sem-list-pro*
  `((this . ,(lambda () "this"))
    (me   . ,(lambda () *me*))
    (you   . ,(lambda () *you*))))

(defparameter *my-sem-list-verb* 
  `((pick     . ,(lambda (target) #'(lambda (source) #'(lambda ()
							(format nil "~A pick ~A" (funcall source) (funcall target))))))
    (reload   . ,(lambda (target) #'(lambda (source) #'(lambda ()
							(load (format nil "~A" (funcall target)))))))
    (is       . ,(lambda (target) #'(lambda (source) #'(lambda ()
							(format nil "~A is ~A" (funcall source) (funcall target))))))
    (go       . ,(lambda (target) #'(lambda (source) #'(lambda ()
							(format nil "~A go ~A" (funcall source) (funcall target))))))
    (listen   . ,(lambda (target) #'(lambda (source) #'(lambda () 
							(format nil "~A: ~A" (funcall target) (readword (symbol-value (funcall target))))))))
    (google   . ,(lambda (target) #'(lambda (source) #'(lambda () nil))))))

(defparameter *my-sem-list-prep*
  `((to . ,(lambda (target) #'(lambda () (format nil "to ~A" (funcall target)))))
    (up . ,(lambda (target) #'(lambda () (format nil "up ~A" (funcall target)))))))

(defparameter *my-sem-list-det*
  `((the . ,(lambda (target) #'(lambda () (format nil "the ~A" (funcall target)))))
    (a   . ,(lambda (target) #'(lambda () (format nil "a ~A" (funcall target)))))))