;;; -*- Mode:LISP; Package:USER; Base:10 -*-


;;; ATN interpreter with backtracking and role and feature frames.
				    

;;; Judith Ann Marcet





;;;;;;;;;;;;;;;; DEFINITION OF THE ATN GRAMMAR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Definition of a simple ATN grammar. That is, a grammar represented as a transition
;;; network (a set of nodes (or states) with arcs between them). The arcs are labeled
;;; with tests and an arc may be traversed only if the test(s) are true. Word-category
;;; tests and word-feature tests are accessed via assq. Word-feature tests are lisp forms
;;; to be evaluated. Word-category testing is done in-line using the word-category
;;; provided in the ATN. Someday word-category testing might be done by lisp forms
;;; embedded in the ATN.
;;;
;;; The arcs may also have actions associated with them. Node actions have the
;;; following general nature:
;;;
;;;    1). "parse" actions set the node register equal to *arc-test-result*.
;;;
;;;    2). "word" actions set the node register equal to *arc-test-result*.
;;;
;;;    3). "send" actions do a get-register for node.
;;;
;;;    4). "jump" actions evaluate the arc-action and jump to the next node.
;;;
;;;
;;;





;;;
;;; def-nodes:
;;;
;;;  takes a list of nodes in the form:
;;;
;;;   ((node ((arc-test) (arc-action) next-node)
;;;          ((arc-test) (arc-action) next-node))
;;;    (node ((arc-test) (arc-action) next-node)))
;;;
;;;  and sets the "arcs" property of "node" to the cdr of the form.
;;;  The ATN is represented as properties hanging off the nodes.
;;;

(defun def-nodes (nodes)
  (loop for node in nodes
	do (setf (get (car node) 'arcs) (cdr node))))





;;; The sentence network.

;;; NOTE: move arc (c c) above arc (c d). Arcs must be ordered this way so that the
;;; noun phrase network does not start chomping up your participles.


(def-nodes '((a       ((parse f-entry)
		       (parse-condition
			 (progn (print "parse-condition test")
				(grind-top-level
				  *arc-test-result*)
				(and
				  (member 'no
					  (print
					    (get-noun-phrase-frame-feature-value-from-structure
					      'np-question
					      nil
					      *arc-test-result*)
					    ))
				  (member 'subjective
					  (print
					    (get-noun-phrase-frame-feature-value-from-structure
					      'np-head
					      'case
					      *arc-test-result*)
					    ))
				  (not (member 'int
					       (cdr 
						 (get-sentence-feature-frame
						   's-mood))))))
			 (set-sentence-frame-feature-value
			   's-subject
			   (list *arc-test-result*))
			 )
		       b)
		      ((word (word-category verb)
			     (word-features
			       ((value-to-lexicon-feature-value-comparison
				  ':word *current-word*
				  ':word-category 'verb
				  ':feature 'type
				  ':value '(non-aux)
				  ':logical-op 'not))))
		       (progn
			 (set-register 'v (verb-action))
			 (set-sentence-frame-feature-value
			   's-main-verb
			   (list (get-register 'v))))
		       q))
	     (b        ((word (word-category verb)
			      (word-features
				((subject-verb-agreement-conditions))))
			(progn
			  (set-register 'v (verb-action))
			  (set-sentence-frame-feature-value
			    's-main-verb
			    (list (get-register 'v))))
			c))
	     (c       ((word (word-category verb)
			     (word-features
			       ((verb-sequence-conditions))))
		       (progn
			 (set-register 'v (verb-action))
			 (append-to-sentence-frame-feature-value
			   's-auxiliaries
			   (car 
			     (get-sentence-feature-frame
			       's-main-verb)))
			 (set-sentence-frame-feature-value
			   's-main-verb
			   (list (get-register 'v))))
		       c)
		      ((parse f-entry)
		       (parse-condition
			 (progn (print "parse-condition test")
				(grind-top-level
				  *arc-test-result*)
			 (member 'objective
				 (print
				 (get-noun-phrase-frame-feature-value-from-structure
				   'np-head
				   'case
				   *arc-test-result*)
				 )))
			 (set-sentence-frame-feature-value
			   's-direct-object
			   *arc-test-result*)
			 )
		       d)
		      ((jump)
		       ()
		       e))
	     (d       ((jump)
		       ()
		       e))
	     (e       ((jump)
		       ()
		       gg))
	     
	     (q      ((parse f-entry)
		      (parse-condition
			(always-true)
			(set-register 'np *arc-test-result*))
		      c)
		     ((parse f-entry)
		      (set-register 'np *arc-test-result*)
		      ff))
	     (ff        ((parse pred)
			(set-register 'pred *arc-test-result*)
			gg))
	     (gg       ((null *remainder-of-sentence*)
		       ()
		       hh))
	     (hh        ((send)
			(set-register 's `(s ,
					    (cond ((get-register 'vb)
						   (list
						     (get-register 'vb)
						     (get-register 'np)
						     (get-register 'pred)))
						  (t
						   (list
						     (get-register 'np)
						     (get-register 'v)
						     (get-register 'np2))))))
			nil))))



;;; Sub-networks.



(def-nodes '((f-entry
	       ((set-register 'np-register
			      (noun-phrase-action))
		()
		f))
	     (f        ((word (word-category det))
			(progn
			  (append-np-constituent-to-np-register)
			  (set-register 'det (det-action))
			  (set-noun-phrase-frame-feature-value
			    'np-number
			    (get-feature-frame
			      'det
			      'number))
			  (set-noun-phrase-frame-feature-value
			    'np-question
			    (get-feature-frame
			      'det
			      'question))
			  (set-noun-phrase-frame-feature-value
			    'np-det
			    (get-register
			      'det))
			  )
			g)
		       ((word (word-category proper))
			(progn
			  (append-np-constituent-to-np-register)
			  (set-register 'proper (proper-action))
			  (set-noun-phrase-frame-feature-value
			    'np-number
			    (get-feature-frame
			      'proper
			      'number))
			  (set-noun-phrase-frame-feature-value
			    'np-person
			    (get-feature-frame
			      'proper
			      'person))
			  (set-noun-phrase-frame-feature-value
			    'np-head
			    (Get-register
			      'proper))
			  (set-register
			    'np (get-noun-phrase-frame
				  (get-register 'np-register)))
			  )
			h)
		       ((word (word-category pronoun))
			(progn
			  (append-np-constituent-to-np-register)
			  (set-register 'pronoun (pronoun-action))
			  (set-noun-phrase-frame-feature-value
			    'np-number
			    (get-feature-frame
			      'pronoun
			      'number))
			  (set-noun-phrase-frame-feature-value
			    'np-question
			    (get-feature-frame
			      'pronoun
			      'question))
			  (set-noun-phrase-frame-feature-value
			    'np-case
			    (get-feature-frame
			      'pronoun
			      'case))
			  (set-noun-phrase-frame-feature-value
			    'np-head
			    (get-register
			      'pronoun))
			  (set-noun-phrase-frame-feature-value
			    'np-person
			    (get-feature-frame
			      'pronoun
			      'person))
			  (set-register
			    'np (get-noun-phrase-frame
				  (get-register 'np-register)))
			  )
			h)
		       ((jump)
			(set-register 'jump-det t)
			g))
	     (g  ((word (word-category adj)
			     (word-features
			       ((cond
				  ((member 'noun
					   (get-list-of-word-categories
					     (second *remainder-of-sentence*))))
				  (t nil)))))
		       (progn
                         (append-np-constituent-to-np-register)
			 (set-register 'adj (adj-action))
			 (append-to-noun-phrase-frame-feature-value
			   'np-describers
			   (get-register
			     'adj)))
		       g)
		      
		      ((word (word-category noun)
			     (word-features
			       ((or
				  (and
				    (member
				      'verb
				      (get-list-of-word-categories
					(second *remainder-of-sentence*)))
				    (value-to-lexicon-feature-value-comparison
				      ':word (second *remainder-of-sentence*)
				      ':word-category 'verb
				      ':feature 'form
				      ':value '(present-part past-part)
				      ':logical-op 'equal))
				  (cond
				    ((member 'noun
					     (get-list-of-word-categories
					       (second *remainder-of-sentence*))))
				    (t nil)))
				(value-to-lexicon-feature-value-comparison
				  ':word *current-word*
				  ':word-category 'noun
				  ':feature 'number
				  ':value 'singular
				  ':logical-op 'equal))))
		       (progn
			 (append-np-constituent-to-np-register)
			 (set-register 'adj (adj-action))
			 (append-to-noun-phrase-frame-feature-value
			   'np-describers
			   (get-register
			     'adj)))
		       g)
		      ((word (word-category noun)
			     (word-features
			       ((or
				  (not
				    (get-noun-phrase-frame-feature-value
				      'np-det
				      'number))
				  (value-to-lexicon-feature-value-comparison
				    ':word *current-word*
				    ':word-category 'noun
				    ':feature 'number
				    ':value (car
					      (get-noun-phrase-frame-feature-value
						'np-det
						'number))
				    ':logical-op 'equal)))))
		       (progn
		 	 (append-np-constituent-to-np-register)
			 (set-register 'noun (noun-action))
			 (set-noun-phrase-frame-feature-value
			   'np-number
			   (get-feature-values
			     *current-word*
			     'noun
			     'number))
			 (set-noun-phrase-frame-feature-value
			   'np-head
			   (get-register
			     'noun))
			 (set-noun-phrase-frame-feature-value
			   'np-case
			   (get-feature-values
			     *current-word*
			     'noun
			     'case);
			   )
			 (set-noun-phrase-frame-feature-value
			   'np-person
			   (get-feature-values
			     *current-word*
			     'noun
			     'person)
			   )
			 (set-register
			   'np (get-noun-phrase-frame
				 (get-register 'np-register))))
		       h))
	     (h 
		      ((parse i)
		       (progn
			 (append-to-noun-phrase-frame-feature-value
			   'np-qualifiers
			   `(pp ,*arc-test-result*))
			 (set-register 'np (get-noun-phrase-frame
					     (get-register 'np))))
		       h)
		      ((send)
		       (get-register 'np)
		       nil))
	     (h-exit  ((send)
		       (get-register 'np)
		       nil))))

(def-nodes '((pred    ((word (word-category adj))
		       (set-register 'pred `(pred ,(adj-action)))
		       pred-send)
		      ((parse i)
		       (set-register 'pred `(pred (pp ,*arc-test-result*)))
		       pred-send))
	     (pred-send ((send)
			 (get-register 'pred)
			 nil))))


;;; A prepositional phrase is a preposition followed by a noun phrase. This means that
;;; parsing a noun phrase might invoke the PP subnet. This makes the grammar recursive.


(def-nodes '((i      ((word (word-category preposition))
		       (progn
			 (set-register 'pp-register (prepositional-phrase-action))
			 (set-register 'preposition (preposition-action))
			 (set-prepositional-phrase-frame-feature-value
			   'pp-preposition
			   (list (get-register 'preposition))))
		       j))
	     (j ((parse f-entry)
		       (progn
			 (set-prepositional-phrase-frame-feature-value
			   'pp-object
			   (list *arc-test-result*))
			 (set-register 'pp (get-register 'pp-register)))
		       k))
	     (k ((send)
		       (get-register 'pp)
		       nil))))





;;;;;;;;;;;;;;;; DEFINITION OF A VOCABULARY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;; def-features:
;;;
;;;  takes a vocabulary of words in the form:
;;;
;;;   word in the vocabulary ->
;;;
;;;    ((word ((word-category-and-its-features)
;;;            (word-category-and-its-features)))
;;;     (word ((word-category-and-its-features))) ...)
;;;
;;;
;;;   word category and its features ->
;;;
;;;     (word-category (list-of-features-associated-with-word-category))
;;;
;;;   list of features associated with word category ->
;;;
;;;      ((word-feature value) ((word-feature value) (word-feature value))
;;;       (word-feature value) ...)
;;;
;;;      A single word-feature value pair in a list form has no dependency on other
;;;      features.  Word-feature value pairs embedded in a list form are to be treated as
;;;      feature combinations.
;;;
;;;  and sets the "features" property of the word to the cadr of the form.
;;;  The word features are represented as a property of the word.
;;;  



(defun def-features (word-feature-list)
  (loop for word-feature in word-feature-list
	do (setf (get (car word-feature) 'features) (cadr word-feature))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



			
(defmacro build-vocab (vocab-list)
  `(def-features ,vocab-list))


;;; NOTE: Why does the verb "be" default to transitive??????

(defvar lexicon
	'((a
	    ((det)))
	  (am
	    ((verb ((form present) (number singular) (person first)
		    (type be non-aux)))))
	  (are
	    ((verb (((form present) (number singular) (person second)
		     (type be non-aux))
		    ((form present) (person first second third) (number plural)
		     (type be non-aux))))))
	  (be
	    ((verb ((type be non-aux)))))
	  (been
	    ((verb (((form past-part) (type be))
		    ((form past-part) (type non-aux))))))
	  (being
	    ((verb ((form present-part) (type be non-aux)))))
	  (by
	    ((preposition)))
	  (caught
	    ((verb ((form past past-part)))))
	  (dance
	    ((verb ((trans trans intrans)))
	     (noun)))
	  (deadline
	    ((noun)))
	  (did
	    ((verb ((form past) (trans trans intrans) (type do non-aux)))))
	  (do
	    ((verb ((trans trans intrans) (type do non-aux)))))
	  (does
	    ((verb ((form present) (person third) (number singular)
		    (trans trans intrans) (type do non-aux)))))
	  (done
	    ((verb ((form past-part) (trans trans intrans) (type do non-aux)))))
	  (doing
	    ((verb ((form present-part) (trans trans intrans) (type do non-aux)))))
	  (entertain
	    ((verb)))
	  (firm
	    ((adj)
	     (noun)))
	  (fish
	    ((noun ((number singular plural)))
	     (verb ((trans intrans)))))
	  (given
	    ((verb ((form past-part)
		    (trans bitrans)))))
	  (had
	    ((verb ((type have  non-aux) (form past past-part)))))
	  (has
	    ((verb ((type have non-aux) (form present) (person third) (number singular)))))
	  (have
	    ((verb ((type have non-aux)))))
	  (having
	    ((verb (((form present-part) (type have))
		    ((form present-part) (type non-aux))))))
	  (i
	    ((pronoun (((number singular) (person first) (case subjective))))))
	  (is
	    ((verb ((form present) (person third) (number singular)
		    (type be non-aux)))))
	  (kumquat
	    ((noun)))
	  (kumquats
	    ((noun ((number plural)))))
	  (persuaded
	    ((verb (((form past) (trans trans))
		    ((form past) (trans bitrans))
		    ((form past-part) (trans trans))
		    ((form past-part) (trans bitrans))))))
	  (runs
	    ((verb ((form present) (trans trans intrans) (person third) (number singular)))
	     (noun ((number plural)))))
		    
	  (secretary
	    ((noun)))
	  (silly
	    ((adj)))
	  (soft
	    ((adj)
	     (noun)))
	  (that
	    ((complementizer)
	     (determiner)
	     (pronoun)
	     (relative)))
	  (the
	    ((det)))
	  (these
	    ((det ((number plural)))))
	  (this
	    ((det ((number singular)))))
	  (to
	    ((complementizer)
	     (preposition)))
	  (tweety-bird
	    ((proper)))
	  (want
	    ((verb ((trans trans bitrans)))))
	  (wanted
	    ((verb ((trans trans bitrans) (form past-part)))))
	  (wanting
	    ((verb ((trans trans bitrans) (form present-part)))))
	  (was
	    ((verb ((form present) (person first third) (number singular)
		    (type be non-aux)))))
	  (we
	    ((pronoun (((number plural) (person first) (case subjective))))))
	  (were
	    ((verb (((form past) (person second) (number singular) (type be non-aux))
		    ((form past) (person first second third) (number plural)
		     (type be non-aux))))))
	  (who
	    ((pronoun (((case subjective) (question yes))))
	     (relative)))
	  (whom
	    ((pronoun (((case objective) (question yes))))
	     (relative)))
	  
	  ))

(defun clear-features (vocab-list)
  (loop for entry in vocab-list
	do (remprop (car entry) 'features)))




(defun def-default-features (default-feature-list)
  (loop for default-feature in default-feature-list
	do (setf (get (car default-feature) 'default-features)
		 (cdr default-feature))))


(defvar lexicon-feature-value-defaults
	'((det 
	    (number singular plural)
	    (question no))
	  (noun
	    (number singular)
	    (person first second third)
	    (case subjective objective))
	  (pronoun
	    (number singular)
	    (person third)
	    (case subjective objective)
	    (question no))
	  (proper
	    (number singular)
	    (person third)
	    (case subjective objective))
	  (verb
	    (form present infinitive)
	    (person first second third)
	    (number singular plural)
	    (trans trans)
	    (type non-aux))))


(defun clear-default-features (default-list)
  (loop for entry in default-list
	do (remprop (car entry) 'default-features)))



;;;;;;;;;;;;;;;; THE ATN INTERPRETER  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Global variables used by the interpteter.



(defvar *remainder-of-sentence*)


(defvar *current-word* nil)




;;; Registers are places to put intermediate results. Explain how they are different from
;;; "frames".

(defvar *registers* nil)


;;; *arc-test-result* is used to save either the result of an action on a "send" arc
;;; (which will be used by the "parse" arc returned to) or the word just parsed.
;;; These results are used by actions on all arcs.

(defvar *arc-test-result*)

;;;
;;; *agenda* is used to store an agenda of arcs leaving a node, as well as the state
;;; of the world at the time the arcs were added to the agenda. We shall call this time
;;; a choice point. When the interpreter returns to a choice point it must restore
;;; the world to the state it was in when the incorrect choice was made. The structure
;;; of *agenda* is as follows:
;;;
;;;     ( (a list of arcs) (list of remaining sentence) (the stack))
;;;       (a list of arcs) (list of remaining sentence) (the stack)) ... )
;;;
;;; The structure of the stack is (next-node arc-action. *registers*). The
;;; value of the stack at a choice point is the node the interpreter should go to
;;; upon returning after a "send" followed by the action to be send upon returning from a
;;; parse followed by the register values to be restored. 
;;;
;;; *agenda* is initialized on entry to the interpreter program and has another agenda
;;; item pushed onto it when a choice point is taken (that is, when one arc is chosen
;;; in "do-nodes" and there are other arcs originating from the node).
;;;



(defvar *agenda*)




;;; Test driver for ATN intrepreter.

(defun atn-test ()
  (setq *remainder-of-sentence* '(the silly secretary
				      runs 
				      kumquat to the silly secretary
				      by the kumquat))
  (setq *registers* nil)
  (setq *agenda* nil)
  (set-register 'sentence-register (sentence-action))
  (atn))

(defun foo (sentence)
  (setq *remainder-of-sentence* sentence)
  (setq *registers* nil)
  (setq *agenda* nil)
  (set-register 'sentence-register (sentence-action))
  (atn)
  (grind-top-level (get-register 'sentence-register)))

(comment ('(the firm firm persuaded soft firm secretary were
				      kumquat to the silly secretary
				      by the kumquat)))









;;; The ATN intrepreter takes an ATN and a sentence and parses the sentence using the ATN.


(defun atn ()
  (prog (answer)
	(setq *agenda*
	      (list				
		(list
		  (get-arcs-of-node 'a)
		  *remainder-of-sentence*
		  (list nil nil nil)
		  *registers*)))
     loop
	(or
	  *agenda*
	  (go exit))
	(setq answer
	      (apply
		'do-nodes
		(pop *agenda*)))
	(and answer (go exit))
	(go loop)
     exit (return answer)))

;;;  This is the real parsing function. It parses the sentence contained in the global
;;;  variable *remainder-of-sentence*.
;;;
;;;     arguments:   arcs-of-nodes -  arcs of the node where it is to start parsing
;;;                  (not the name of the node)
;;;                  *remainder-of-sentence*
;;;                  stack
;;;                  *registers* - global variable which is set to the phrase marker
;;;                  (parse) for the input
;;;              
;;;
;;;     returns:     success (non-nil value or nil)
;;;
;;;     side-effects:
;;;                  Sets *agenda* and *arc-test-result*
;;;


(defun do-nodes
       (arcs-of-nodes *remainder-of-sentence* stack *registers*)
  (prog (success return-value)
	(setq success nil)
	(setq return-value nil)
     loop
	(or arcs-of-nodes (go exit))
	(setq arcs-of-nodes
	      (let* ((an-arc			; Try the first arc. If more than one arc leaves
		       (prog1			; the node, record a choice point on the agenda.
			 (pop arcs-of-nodes)
			 (cond
			   (arcs-of-nodes
			    ;;; The agenda (*agenda*) tells the interpreter how to reset
			    ;;; the world after a failure.
			    (push
			      (list
				arcs-of-nodes
				*remainder-of-sentence*
				stack
				*registers*)
			      *agenda*)))))
		     (*current-word* (car *remainder-of-sentence*))
		     (arc-test (get-arc-test an-arc))
		     (arc-action (get-arc-action an-arc))
	             (next-node (get-arc-next-node an-arc))
		     (stack-after-send nil))
			(print *current-word*)
	(print *current-word*)

		(get-arcs-of-node
		  (cond ((is-parse-test arc-test)
			 ;;; To do a parse, go to the indicated node, recording on
			 ;;; "stack" the node to return to upon seeing a "send". Also
			 ;;; save the arc-action to be done after returning from the
			 ;;; parse and save the registers to be restored. While we are
			 ;;; traversing the parse arc the registers will be used for
			 ;;; intermediate results, so we will want to clear them.
			 (push
			   (list next-node 
				 arc-action
				 *registers*)
			   stack)
			 (get-node-to-parse arc-test))
			((is-send-test arc-test)
			 (setq *arc-test-result* (eval arc-action))
			 ;;; The top of the "stack" records the node to go to upon
			 ;;; seeing a "send", so upon seeing a "send", go to the
			 ;;; top node on the "stack". A nil "stack" indicates a
			 ;;; finished parse.
			 (setq stack-after-send (pop stack))
			 (cond
			   ;;; The stack tells the interpreter how to reset the state of the
			   ;;; world upon returning from "send". The "*agenda*" will remain the
			   ;;; same. In this way should a failure occur later the interpreter
			   ;;; can back up to this point.
			   ((and
			      stack-after-send
			      (or (not (eq (car (second stack-after-send)) 'parse-condition))
				  (eval (car (cdr (second stack-after-send))))))
			    (setq *registers* (third stack-after-send))
			    (cond ((eq (car (second stack-after-send)) 'parse-condition)
				   (eval (caddr (second stack-after-send))))
				  (t (eval (second stack-after-send))))
			    (first stack-after-send))
			   (t
			    (if (print 
			      (not (eq (car (second stack-after-send)) 'parse-condition)))
				(progn (print "alls well from send")
				  (setq success t)
				       nil)
			      nil))))
			;;; Is it a word?
			((is-word-test arc-test)
			 (cond
			   ((test-word-category-and-feature-constraints
			      arc-test *current-word*)
			    (setq *arc-test-result* *current-word*)
			    (eval arc-action)
			    (pop *remainder-of-sentence*)
			    next-node)
			   ))
			;;; Jump arc
			((is-jump-test arc-test)
			 (eval arc-action)
			 next-node)
			;;; Evaluate the arc test
			((eval arc-test)
			 next-node)
			))))
	(and success (go exit))
	(go loop)
     exit
	(print "regs on exit")
	(grind-top-level (car *registers*))
	(return success)))
  


;;;
;;; A node is an atom with a list of arcs on the property indicator "arcs".
;;;
;;; get-arcs-of-node given a node returns its arc(s) which have the form:
;;;    (((arc-test) (arc-action) next-node)
;;;     ((arc-test) (arc-action) next-node) ...)
;;;

(defun get-arcs-of-node (node)
  (and node (get node 'arcs)))


(defun get-arc-test (arc)
  (car arc))


(defun get-arc-action (arc)
  (cadr arc))

(defun get-arc-next-node (arc)
  (caddr arc))

(defun get-node-to-parse (arc-test)
  (cadr arc-test))

(defun get-word-category (arc-test)
  (cadr (assq 'word-category (cdr arc-test))))

;;; get-word-features returns a list of word-feature tests in the form:
;;;
;;;      (word-features ((form to evaluate) ...
;;;                      (form to evaluate)))
;;;
;;;      

(defun get-word-features (arc-test)
  (cadr (assq 'word-features (cdr arc-test))))

(defun is-parse-test (arc-test)
  (eq (car arc-test) 'parse))

(defun is-word-test (arc-test)
  (eq (car arc-test) 'word))

(defun is-jump-test (arc-test)
  (eq (car arc-test) 'jump))


(defun is-send-test (item-to-test)
  (and (listp item-to-test) (eq (car item-to-test) 'send)))



  
(defun get-list-of-word-categories (word)
  (loop for word-category-and-its-features
	in (get word 'features)
	collecting (car word-category-and-its-features)))

(defun test-word-category-and-feature-constraints
       (arc-test word-to-test)
  (and (member
	 (get-word-category
	   arc-test)
	 (get-list-of-word-categories word-to-test))
       (let ((list-of-word-features-and-forms-to-evaluate
	       (get-word-features arc-test)))
	 (cond ((not list-of-word-features-and-forms-to-evaluate)
		t)
	       (t (loop for word-feature-and-forms-to-evaluate
			in list-of-word-features-and-forms-to-evaluate
			always (eval word-feature-and-forms-to-evaluate)))))))




;;; NOTE: :logical-op 'not means that there is at least one instance of feature that
;;;       is not 'value
;;;
;;;       :logical-op 'equal - uses eq comparision 
;;;

;;; Think about passing lists of features and values to force comparisions within a single
;;; word sense. (multiple-features-to-compare multiple-values-to-compare)

(defun value-to-lexicon-feature-value-comparison
       (&key
	word
	word-category
	(feature nil)
	value
	logical-op)
  (let ((list-of-feature-values
	  (get-feature-values
	    word
	    word-category
	    feature)))
    (cond ((eq logical-op 'not)
	   ;;; 'not means that there is at least one instance
	   ;;; of feature that is not value.
	   (cond ((loop for word-sense-features in list-of-feature-values
			thereis
			(cond 
			  ((member
			     value
			     word-sense-features)
			   (> (length word-sense-features)
			      1))
			  (t word-sense-features))))))
	  ((eq logical-op 'equal)
	   (cond ((loop for word-sense-features in list-of-feature-values
			thereis
			(cond
			  ((atom value)		;never an atom????
			   (member
			     value
			     word-sense-features))
			  (t
			   (intersection
			     value
			     word-sense-features))))))))))


(defun test-value-to-lexicon-feature-value-comparison
       (word word-category feature value logical-op)
  (value-to-lexicon-feature-value-comparison
    :word word
    :word-category word-category
    :feature feature
    :value value
    :logical-op logical-op))

;;; There are two ways that feature values are encoded in the lexicon:
;;;
;;;    1). flat lists,
;;;
;;;    2). embedded lists, that denote feature combining.
;;;
;;; lexicon-feature-value-defaults contains default values for feature dimensions. The default
;;; values are assumed to hold for any word sense for which a value along that dimension
;;; is not specified.
;;;
;;; 

(defun get-feature-values
       (word word-category feature)
  (let ((list-of-word-category-features
	  (cadr (assq word-category
		      (get word 'features)))))
    (cond ((print list-of-word-category-features)
	   (cond ((atom (caar
			  list-of-word-category-features))
		  (cond ((cdr
			   (assq feature
				 list-of-word-category-features))
			 (list (cdr
				 (assq feature
				       list-of-word-category-features))))
			(t (list
			     (cdr
			       (assq feature
				     (get word-category 'default-features)))))))	
		 (t (let
		      ((feature-value
			 (loop for embedded-list			
			       in list-of-word-category-features
			       collecting (cdr
					    (assq feature
						  embedded-list)))))
		      (cond ((not (equal (car feature-value) 
					 nil))
			     feature-value)
			    (t (loop for the-nils in feature-value
				     collecting 
				     (cdr
				       (assq feature
					     (get word-category 'default-features))))))))))
	  (t (list
	       (cdr
		 (assq feature
		       (get word-category 'default-features))))))))



(defun value-to-sentence-main-verb-feature-value-comparison
       (&key
	(feature nil)
	value
	logical-op)
  (let* ((main-verb-features
	   (get-sentence-feature-frame
	     's-main-verb))
	 (feature-value
	   (cdr
	     (assq feature
		   (car main-verb-features)))))
    (cond ((eq logical-op 'not)
	   ;;; 'not means that there is at least one instance
	   ;;; of feature that is not value.
	   (cond ((loop for word-sense-features in feature-value
			thereis
			(cond 
			  ((member
			     value
			     word-sense-features)
			   (> (length word-sense-features)
			      1))
			  (t word-sense-features))))))
	  ((eq logical-op 'equal)
	   (cond ((loop for word-sense-features in feature-value
			thereis
			(cond
			  ((atom value)		;never an atom????
			   (member
			     value
			     word-sense-features))
			  (t
			   (intersection
			     value
			     word-sense-features))))))))))



(defun multiple-value-to-lexicon-feature-value-comparison
       ;;;
       ;;; See if for "word-category" in "word" there is a match for "features"
       ;;; in "values for a word sense in "word" (for two features).
       ;;;
       (&key
	 word
	 word-category
	 features				;Assume two.
	 values					;Assume two.
	 logical-op)
  (let ((lists-of-feature-values
	  (loop for feature in features
	        collecting (get-feature-values
			     word
			     word-category
			     feature))))
    (print lists-of-feature-values)
    (cond ((eq logical-op 'equal)
	   (cond ((loop for first-feature-value in (first values)
			for second-feature-value in (second values)
			do (progn
			     (print first-feature-value)
			     (print second-feature-value))
			thereis 
			(loop for first-word-sense-feature-values
			      in (first lists-of-feature-values)
			      for second-word-sense-feature-values
			      in (second lists-of-feature-values)
			      thereis
			      (print (and
				(intersection
				  first-feature-value 
				  first-word-sense-feature-values)
				(intersection
				  second-feature-value 
				  second-word-sense-feature-values)))))))))))




(defun testit ()
  (multiple-value-to-lexicon-feature-value-comparison
    ':word 'were
    ':word-category 'verb
    ':features '(person number)
    ':values '(((first) (third)) ((singular) (plural)))
    ':logical-op 'equal))



(defun get-register (register)
  (let ((register-value (assq register *registers*)))
     (cond (register-value
	    (cadr register-value)))))



   

(defun set-register (register register-value)
  (push (list register register-value) *registers*))








(defun set-noun-phrase-frame-feature-value
       (np-feature-to-be-set value)
  (set-feature-frame
    (list (get-register 'np-register))
    'noun-phrase
    np-feature-to-be-set
    value))


(defun set-sentence-frame-feature-value
       (sentence-feature-to-be-set value)
  (set-feature-frame
    (list (get-register 'sentence-register))
    'sentence
    sentence-feature-to-be-set
    value))

(defun set-prepositional-phrase-frame-feature-value
       (pp-feature-to-be-set value)
  (set-feature-frame
    (list (get-register 'pp-register))
    'prepositional-phrase
    pp-feature-to-be-set
    value))



(defun get-noun-phrase-frame
       (register-value)
  (cond ((eq (car register-value) 'noun-phrase)
	 register-value)
	(t (get-noun-phrase-frame (cadr register-value)))))

(defun get-noun-phrase-frame-feature-value
       (np-word-category np-feature)
  (cadr (assq np-feature
	     (cdr (assq np-word-category
			(print
			(cdr
			  (assq 'np-register *registers*))))))))


(defun get-noun-phrase-frame-feature-value-from-structure
       (np-role np-feature structure)
  (cond ((null np-feature)
	 (cadr (assq np-role
		     (cdr
		       structure))))
	(t (cadr (assq np-feature
		       (cdr (assq np-role
				  (cdr
				    structure))))))))


(defun get-sentence-subject-feature
       (feature)
  (cdr
    (assq feature
	  (cdar
	    (get-sentence-feature-frame 's-subject)))))




(defun append-np-constituent-to-np-register
       ()
  (append-to-noun-phrase-frame-feature-value
    'np-constituent
    *current-word*))


;;; NOT TESTED

(defun append-to-noun-phrase-frame-feature-value
       (np-feature-to-be-appended-to value)
  (append-to-feature-frame
    (list (get-register 'np-register))
    'noun-phrase
    np-feature-to-be-appended-to
    value))



(defun append-to-sentence-frame-feature-value
       (sentence-feature-to-be-appended-to value)
  (append-to-feature-frame
    (list (get-register 'sentence-register))
    'sentence
    sentence-feature-to-be-appended-to
    value))

;;; Bad hack - because of register structure transition nodes may or may not have a
;;; register-name.

(defun set-feature-frame
       (node register-name feature-name feature-value)
  (setf (cdr
	  (assq feature-name
		(cond ((null register-name)
		       node)
		      (t 
		       (cdr
			 (assq register-name node))))))
	feature-value))


;;; Bad hack - because of register structure transition nodes may or may not have a
;;; register-name.

;;; NOT TESTED

(defun append-to-feature-frame
       (node register-name feature-name feature-value)
  (setf (cdr
	  (assq feature-name
		(cond ((null register-name)
		       node)
		      (t 
		       (cdr
			 (assq register-name node))))))
	(append (cdr
		  (assq feature-name
			(cond ((null register-name)
			       node)
			      (t 
			       (cdr
				 (assq register-name node))))))
		(list feature-value))))
		



(defun get-feature-frame
       (register-name feature-name)
  (cdr
    (assq feature-name
	  (cadr
	    (assq register-name *registers*)))))


(defun get-sentence-feature-frame
       (feature-name)
  (cdr
    (assq feature-name
	  (cdr
	    (assq 'sentence
		  (cdr
		    (assq 'sentence-register *registers*)))))))





;;; Role and feature frames.


(defvar adj-frame-structure
	'((adj-constituent)))

(defvar complementizer-frame-structure
	'(complementizer (complementizer-constituent)))

(defvar det-frame-structure
	'((det-constituent)
	  (number)
	  (question)))

(defvar noun-frame-structure
	'((noun-constituent)
	  (number)
	  (person)
	  (case)))

(defvar preposition-frame-structure
	'(preposition (preposition-constituent)))

(defvar pronoun-frame-structure
	'((pronoun-constituent)
	  (number)
	  (person)
	  (case)
	  (question)))

(defvar proper-frame-structure
	'((proper-constituent)
	  (person)
	  (number)
	  (case)))

(defvar relative-frame-structure
	'(relative (relative-constituent)))

(defvar verb-frame-structure
	'((verb-constituent)
	  (form)
	  (person)
	  (number)
	  (trans)
	  (type)))


(defvar sentence-frame-structure
	'(sentence
	   (s-subject)
	   (s-direct-object)
	   (s-indirect-object)
	   (s-main-verb)
	   (s-binder)
	   (s-auxiliaries)
	   (s-modifiers)
	   (s-question-element)
	   (s-voice active)
	   (s-mood decl)))

(defvar noun-phrase-frame-structure
	'(noun-phrase
	   (np-constituent)
	   (np-det)
	   (np-head)
	   (np-describers)
	   (np-qualifiers)
	   (np-number)
	   (np-question no)
	   (np-person third)
	   (np-case)))


(defvar prepositional-phrase-frame-structure
	'(prepositional-phrase
	   (pp-preposition)
	   (pp-object)))
	  


;;; New functions to support role and feature frames.
;;; to set a value (setf (cdr (assq np-det your-register) '(the))) 

(defun create-frame-structure
       (node-type)
  (cond
    ((eq node-type 'adj)
     (copytree adj-frame-structure))
    ((eq node-type 'complementizer)
     (copytree complementizer-frame-structure))
    ((eq node-type 'det)
     (copytree det-frame-structure))
    ((eq node-type 'noun)
     (copytree noun-frame-structure))
    ((eq node-type 'noun-phrase)
     (copytree noun-phrase-frame-structure))
    ((eq node-type 'preposition)
     (copytree preposition-frame-structure))
    ((eq node-type 'pronoun)
     (copytree pronoun-frame-structure))
    ((eq node-type 'proper)
     (copytree proper-frame-structure))
    ((eq node-type 'relative)
     (copytree relative-frame-structure))
    ((eq node-type 'sentence)
     (copytree sentence-frame-structure))
    ((eq node-type 'verb)
     (copytree verb-frame-structure))
    ((eq node-type 'np)
     (copytree noun-phrase-frame-structure))
    ((eq node-type 'prepositional-phrase)
     (copytree prepositional-phrase-frame-structure))))






(defun adj-action ()
  (let ((node (create-frame-structure 'adj)))
    (set-feature-frame
      node
      nil
      'adj-constituent
      (list *arc-test-result*))
    node))
  
  

(defun complementizer-action ()
  (let ((node (create-frame-structure 'complementizer)))
    (set-feature-frame
      node
      nil
      'complementizer-constituent
      (list *arc-test-result*))
    node))
   

(defun det-action ()
  (let ((node (create-frame-structure 'det)))
    (set-feature-frame
      node
      nil
      'det-constituent
      (list *arc-test-result*))
    (set-feature-frame
      node
      nil
      'number
      (get-feature-values
	*current-word*
	'det
	'number))
    (set-feature-frame
      node
      nil
      'question
      (get-feature-values
	*current-word*
	'det
	'question))
    node))


(defun noun-action ()
  (let ((node (create-frame-structure 'noun)))
    (set-feature-frame
      node
      nil
      'noun-constituent
      (list *arc-test-result*))
    (set-feature-frame
      node
      nil
      'number
      (get-feature-values
	*current-word*
	'noun
	'number))
    (set-feature-frame
      node
      nil
      'person
      (get-feature-values
	*current-word*
	'noun
	'person))
    (set-feature-frame
      node
      nil
      'case
      (get-feature-values
	*current-word*
	'noun
	'case))
    node))


(defun noun-phrase-action ()
  (let ((node (create-frame-structure 'noun-phrase)))
    node))


(defun preposition-action ()
  (let ((node (create-frame-structure 'preposition)))
    (set-feature-frame
      (list node)
      'preposition
      'preposition-constituent
      (list *arc-test-result*))
    node))


(defun prepositional-phrase-action ()
  (let ((node (create-frame-structure 'prepositional-phrase)))
    node))


(defun pronoun-action ()
  (let ((node (create-frame-structure 'pronoun)))
    (set-feature-frame
      node
      nil
      'pronoun-constituent
      (list *arc-test-result*))
    (set-feature-frame
      node
      nil
      'number
      (get-feature-values
	*current-word*
	'pronoun
	'number))
    (set-feature-frame
      node
      nil
      'person
      (get-feature-values
	*current-word*
	'pronoun
	'person))
    (set-feature-frame
      node
      nil
      'question
      (get-feature-values
	*current-word*
	'pronoun
	'question))
    (set-feature-frame
      node
      nil
      'case
      (get-feature-values
	*current-word*
	'pronoun
	'case))
    node))


(defun proper-action ()
  (let ((node (create-frame-structure 'proper)))
    (set-feature-frame
      node
      nil
      'proper-constituent
      (list *arc-test-result*))
    (set-feature-frame
      node
      nil
      'number
      (get-feature-values
	*current-word*
	'proper
	'number))
    (set-feature-frame
      node
      nil
      'person
      (get-feature-values
	*current-word*
	'proper
	'person))
    (set-feature-frame
      node
      nil
      'case
      (get-feature-values
	*current-word*
	'proper
	'case))
    node))
   

(defun relative-action ()
  (let ((node (create-frame-structure 'relative)))
    (set-feature-frame
      (list node)
      'relative
      'relative-constituent
      (list *arc-test-result*))
    node))


(defun sentence-action ()
  (let ((node (create-frame-structure 'sentence)))
    node))

(defun verb-action ()
  (let ((node (create-frame-structure 'verb)))
    (set-feature-frame
      node
      nil
      'verb-constituent
      (list *arc-test-result*))
    (set-feature-frame
      node
      nil
      'form
      (get-feature-values
	*current-word*
	'verb
	'form))
    (set-feature-frame
      node
      nil
      'person
      (get-feature-values
	*current-word*
	'verb
	'person))
    (set-feature-frame
      node
      nil
      'number
      (get-feature-values
	*current-word*
	'verb
	'number))
    (set-feature-frame
      node
      nil
      'type
      (get-feature-values
	*current-word*
	'verb
	'type))
    (set-feature-frame 
      node
      nil
      'trans
      (get-feature-values
	*current-word*
	'verb
	'trans))
    node))


;;;;;;;;;;;;;;;; AUGMENTATIONS TO THE GRAMMAR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun verb-sequence-conditions ()
  ;;;
  ;;; Tests as follows:
  ;;;       If the main-verb's 'type is 'modal or 'do
  ;;;       then the verb we are parsing must have 'form equal 'infinitive.
  ;;;       If the main-verb's 'type is 'be
  ;;;       then the verb we are parsing must have 'form equal 'pres-part.
  ;;;       If the main-verb's 'type is 'have
  ;;;       then the verb we are parsing must have 'form equal 'past-part.
  ;;;       If the main-verb's 'type is 'non-aux
  ;;;       then fail.
  ;;;
  ;;; Think about adding the "additional verb dimensions" to handle all the forms
  ;;; of the verb "be" (page 212).
  ;;;
  (cond ((and
	   (or
	     (value-to-sentence-main-verb-feature-value-comparison
	       :feature 'type :value 'modal :logical-op 'equal)
	     (value-to-sentence-main-verb-feature-value-comparison
	       :feature 'type :value 'do :logical-op 'equal))
	   (value-to-lexicon-feature-value-comparison
	     ':word *current-word*
	     ':word-category 'verb
	     ':feature 'form
	     ':value 'infinitive
	     ':logical-op 'equal)))
	((value-to-sentence-main-verb-feature-value-comparison
	   :feature 'type :value 'be :logical-op 'equal)
	 (value-to-lexicon-feature-value-comparison
	   ':word *current-word*
	   ':word-category 'verb
	   ':feature 'form
	   ':value 'present-part
	   ':logical-op 'equal))
	((value-to-sentence-main-verb-feature-value-comparison
	   :feature 'type :value 'have :logical-op 'equal)
	 (value-to-lexicon-feature-value-comparison
	   ':word *current-word*
	   ':word-category 'verb
	   ':feature 'form
	   ':value 'past-part
	   ':logical-op 'equal))
	((value-to-sentence-main-verb-feature-value-comparison
	   :feature 'type :value 'non-aux :logical-op 'equal)
	 nil)))




(defun subject-verb-agreement-conditions ()
  (cond ((value-to-lexicon-feature-value-comparison
	   ':word *current-word*
	   ':word-category 'verb
	   ':feature 'type
	   ':value '(be)
	   ':logical-op 'equal)
	 (cond ((value-to-lexicon-feature-value-comparison
		  ':word *current-word*
		  ':word-category 'verb
		  ':feature 'form
		  ':value '(infinitive)
		  ':logical-op 'equal)
		t)
	       (t (cond ((multiple-value-to-lexicon-feature-value-comparison
			   ':word *current-word*
			   ':word-category 'verb
			   ':features '(person number)
			   ':values (list
				     (get-sentence-subject-feature
				       'np-person)
				     (get-sentence-subject-feature
				       'np-number))
			   ':logical-op 'equal)
			 t)
			(t nil)))))
	((value-to-lexicon-feature-value-comparison
	   ':word *current-word*
	   ':word-category 'verb
	   ':feature 'form
	   ':value '(modal
	              past)
	   ':logical-op 'equal)
	 t)
	((and (multiple-value-to-lexicon-feature-value-comparison
		':word *current-word*
		':word-category 'verb
		':features '(person number)
		':values '(((third)) ((singular)))
		':logical-op 'equal)
	      (member
		'singular
		(lexpr-funcall
		  'append
		  (get-sentence-subject-feature
		    'np-number)))
	      (member
		'third
		(lexpr-funcall
		  'append
		  (get-sentence-subject-feature
		    'np-person))))
	 t)
	((and (value-to-lexicon-feature-value-comparison
		':word *current-word*
		':word-category 'verb
		':feature 'form
		':value '(infinitive)
		':logical-op 'equal)
	      (or (member
		    'plural
		    (lexpr-funcall
		      'append
		      (get-sentence-subject-feature
			'np-number)))
		  (intersection
		    '(first second)
		    (lexpr-funcall
		      'append
		      (get-sentence-subject-feature
			'np-person)))))
	 t)
	(t nil)))





(defun always-true ()
  (print "hello from always true")
  t)



(defun set-regs ()
  (setq
   *registers*
   (quote
    ((sentence-register
      (sentence (s-subject)
                (s-direct-object)
                (s-indirect-object)
                (s-main-verb ((verb-constituent were) (form past)
                                                      (trans intrans)
                                                      (type be non-aux)))
                (s-binder)
                (s-auxiliaries ((verb-constituent were) (form past)
                                                        (trans intrans)
                                                        (type be non-aux))
                               ((verb-constituent have) (form present infinitive)
                                                        (trans trans)
                                                        (type have non-aux)))
                (s-modifiers)
                (s-question-element)
                (s-voice active)
                (s-mood decl)))))))



(defun remove-last-constituent-from-np-register ()
  (print "********surgery being performed*********")
  (nbutlast
    (assq 'np-constituent
	  (cdr (assq 'noun-phrase
		(cdr (assq 'np-register *registers*)))))))


;;;
;;; Continue with this function. Remember that some features will require different
;;; surgical procedures.
;;;

(defun remove-last-element-from-sentence-feature-frame
       (feature)
  (cond (nil
	 (print "***and more surgery**")
	 (print *current-word*)
	 (nbutlast
	   (assq feature
		 (cdr (assq 'noun-phrase
			    (cdr (assq 'np-register *registers*)))))))
	(t (print "***what, more surgery???***")
	   (setf (cdr
		   (assq feature
			 (cdr (assq 'sentence
				    (cdr (assq 'sentence-register *registers*))))))
		 nil))))



(defun setup ()
  (clear-features lexicon)
  (clear-default-features lexicon-feature-value-defaults)
  (build-vocab lexicon)
  (def-default-features lexicon-feature-value-defaults))


(setup)

(comment
(push
			   `(progn
			      (remove-last-element-from-np-feature-frame
				'np-describers)
			      (remove-last-constituent-from-np-register))
			   *list-of-register-actions-to-be-undone-on-failure*)


(eval
			     (pop *list-of-register-actions-to-be-undone-on-failure*)))



;;; Removed from the np network in order to allow testing of verb seq code. 

(comment ((word (word-category verb)
			     (word-features
			       ((value-to-lexicon-feature-value-comparison
				  ':word *current-word*
				  ':word-category 'verb
				  ':feature 'form
				  ':value '(present-part past-part)
				  ':logical-op 'equal))))
		       (progn
			 (append-np-constituent-to-np-register)
			 (set-register 'adj (adj-action))
			 (append-to-noun-phrase-frame-feature-value
			   'np-describers
			   (get-register
			     'adj)))
		       np-det))


(comment (and
	   (and
	     (not 
	       (member 'present-part
		       (cdr
			 (assq 'form (car (get-sentence-feature-frame `s-main-verb))))))
	     (not 
	       (member 'past-part
		       (cdr
			 (assq 'form (car (get-sentence-feature-frame `s-main-verb)))))))	     
	   (value-to-lexicon-feature-value-comparison
	     ':word *current-word*
	     ':word-category 'verb
	     ':feature 'form
	     ':value 'present-part
	     ':logical-op 'equal)))