WORD PREDICTION FOR DISABLED USERS: SOURCE CODE

Julie A. Van Dyke

Department of Computer and Information Sciences
University of Delaware
Newark, Delaware  19716

Technical Report 92-04
June, 1991

(c) Julie A. Van Dyke
All Rights Reserved

ABSTRACT

Disorders such as Cerebral Palsy and Lou Gehrig's disease produce
severe physical disabilities that leave their victims unable to
communicate in typical ways.  In order to overcome this barrier,
rehabilitation engineers have developed communication aids which make
use of electronic technology to shift the burden of communication away
from the user.  Some strategies that have been employed include
prediction techniques that use statistics to predict the user's next
keystrokes.  Unfortunately, the statistical data used in these systems
is often biased or incomplete and consequently, these systems have had
only limited success.  This document contains the source code for a
solution which combines natural language processing techniques and
linguistic theory to produce a prediction system that, unlike previous
systems, models our natural rules of syntax. The syntactic predictor
makes rule-based, linguistic determinations about what words can
follow those already processed. It can be used with other devices to
reduce the effort required of the user by predicting what word forms
he or she is likely to type next. Because this system models human
linguistic knowledge, it provides a more natural solution to the
communication problem than do many other systems currently available
to disabled users.

CONTENTS

1	PREDICTOR 			1
2 	X' THEORY GRAMMAR 		15
3 	EXAMPLE LEXICON 		37
4 	DICTIONARY BREAK PACKAGE 	50

REFERENCES 				54

1 PREDICTOR

; SYNTACTIC PREDICTOR

; Julie A. Van Dyke
; May 30, 1991

; This syntactic predictor is designed to allow the user to enter a 
; partial sentence and have the predictor determine what kinds of word
; forms can serve as the next word in that partial sentence.  It is presently
; implemented to allow the user to either enter the next word in the
; sentence or to enter a list of possible next words from which it will
; choose the syntactically appropriate ones.

; This is the common LISP implementation of this program.

; For a more detailed discussion of this predictor, refer to:

; Van Dyke, J.A. (1991). Word Prediction for Disabled Users:  Applying
;	Natural Language Processing to Enhance Communication.  
;	Honors BA Thesis, University of Delaware.

(shadow `getf)
(shadow `push)
(shadow `abort)

;	CONTROL FUNCTIONS

(defun predict (&rest n)
 ; Predict is the top level function for the predictor.  It starts the 
 ; sentence parse by building a state with the first word of the sentence
 ; and CP/ as the default or with the given state as the starting
 ; point in the grammar.

(setq sentence-so-far (car n)) 
 (let ((sentence (car n)) (reglist (make-symbol "registers"))
       (holdlist (make-symbol "hold")) (stack nil))
      (checkword sentence)
      (cond ((eq (cadr n) nil)
	     (control-operation (generate-states `CP/ sentence reglist holdlist stack)))
	    (t (control-operation (generate-states (cadr n) sentence reglist holdlist stack))))))

(defun goal-state (nextstate)
 ; Goal-state returns the value of the parse if the next word in the 
 ; sentence is nil and the next state is a POP arc. The POP arc is 
 ; evaluated to build the parse.  If the nextword is non-nil or the 
 ; nextstate is not a POP OR the POP itself fails,
 ; then the function returns nil this is not a goal-state.
 ; If the sentence is nil, but the nextstate is not a poparc then the
 ; possible forms for the next word are returned.
 ; In a goal state, poparc will be the actual POP arc that was returned in
 ; get-next-arc.

 (let ((poparc (car nextstate))
       (node (car nextstate))
       (sentence (second nextstate))
       (reglist (third nextstate))
       (holdlist (fourth nextstate))
       (stack (fifth nextstate)))
      (declare (special stack holdlist reglist))


    (cond ((and (null  sentence)
		   (holdempty holdlist)
		   (null stack)
		   (listp poparc)
		   (equal `POP (car poparc)))
	   (setq results (eval (cadar nextstate)))
	    (pprint results))
          (t nil))))
 
(defun control-operation (open)
 
 ; This function controls the system's operation depending on whether or not
 ; partial parses exist.  Halt-state is a list of the partial-parses made
 ; in search-parses and also the closed list that reflects the states
 ; already checked by the parser.  It has the form (<closed> <partials>).

 (let* ((halt-state (search-parse open nil))
        (partials (cadr halt-state)))
  (cond ((null partials) nil)
        ((query-user halt-state)))))

(defun search-parse (open closed)
 ; Finds all the possible parses of the input.  Open is a list of states.
 ; Each state has the label of the arc just taken, the sentence after the
 ; arc was taken, the registerlist at that point and the holdlist and stack.
 ; Each state has the potential to be a parse.  The search through the
 ; arcs of the grammar continues as long as there are arcs to take and
 ; the sentence is not null. When the sentence becomes nil, there current
 ; state is appended to a list of partial-parses.

 ; At the end of the search all the completed parses that were found are
 ; printed out.
   
 (prog (topofopen part-parses node sentence registersofopen holdofopen stackofopen)
       (setq part-parses nil)
    
        loop
        (setq topofopen (car open))
        (setq node (car topofopen))
        (setq sentence (cadr topofopen))
        (setq registersofopen (caddr topofopen))
        (setq holdofopen (cadddr topofopen))
        (setq stackofopen (caddddr topofopen))
										    (cond ((null open)
	  (return (list closed part-parses)))
	 ((or (member topofopen closed :test #'equal-state?)
	      (member topofopen part-parses :test #'equal-state?))
	 (setq open (cdr open)) (go loop))
	 ((goal-state topofopen))
	 ((and (null sentence) (not (member topofopen part-parses :test #'equal-state?)))
	  (setq part-parses (cons topofopen part-parses))))
	 
    (setq open (append (cdr open)
		       (generate-states node sentence registersofopen
			                holdofopen stackofopen)))
    (cond (sentence (setq closed (cons topofopen closed))))
	    
    (go loop)))

; INTERFACE

(defun query-user (halting-state)
 ; Function gives the user control over the way the processing continues.
 ; Based on the partial parses which are complete for the amount of input
 ; originally available, the user can choose to complete the parse by entering
 ; words as prompted or by giving a list of possible words and having the
 ; system return the ones that could advance the parse to the next state.

 (prog (partial-parses closed choice)
   loop
   (setq partial-parses (cadr halting-state))
   (setq closed (car halting-state))

  (cond ((null (car partial-parses)) (return nil)))
   
  (terpri)
  (princ "The parser has gone as far as it can with this sentence.")
  (terpri)
  (princ "You can choose to proceed in two ways:")
  (terpri)
  (terpri)
  (princ "Method 1 allows you to enter the next word to be completed.")
  (terpri)
  (princ "The computer will then advance the parse as far as it can with this")
  (terpri)
  (princ "new word and then bring you back to this point.")
  (terpri)
  (terpri)
  (princ "Method 2 allows you to enter a list of words and the computer")
  (terpri)
  (princ "checks these words and tells you which of them could be used to")
  (terpri)
  (princ "advance the parse a further step.  At that point you are")
  (terpri)
  (princ "returned to this point and you can choose to take one of those")
  (terpri)
  (princ "words or to check another list.")
  (terpri)
  (terpri)
  (princ "The sentence parsed so far is: ")
  (print sentence-so-far)
  (terpri)
  (terpri)
  (princ "Now if you would like to use Method 1 type 1.")
  (terpri)
  (princ "If you would like to use Method 2 type 2.")
  (terpri)
  (princ "If you would like to quit this program type 0.")
  (terpri)
  (princ "Enter your selection now:")
  (terpri)
					       
  (setq choice (read))
  (cond ((equal choice 0) (return nil))
        ((equal choice 1)
	 (setq halting-state (restart-parse halting-state (get-next-input)))
         (go loop))
	((equal choice 2)
	 (princ "The grammatical possibilities are: ")
	 (print (check-list halting-state (get-list)))
	 (go loop))
	(t (princ "Enter 1 or 2 or 0 now:") (terpri)
	   (go loop)))))

(defun check-list (halt-state word-list)
 ; this function checks each word on the list with each of the partial
 ; parses to see if that word can advance the parse.  If it will,
 ; that word is returned in a list with other words that will also
 ; advance the parse.

 (cond ((null word-list) nil)
       ((append (check-a-word halt-state (car word-list))
	        (check-list halt-state (cdr word-list))))))
 
(defun check-a-word (halt-state word)
 ; this function checks one word with all the partial parses and
 ; returns that word if any of the parses go through.
      
 (cond ((null (caadr (restart-parse halt-state (list word)))) nil)
		      ((list word))))
 

(defun get-list ()
 ; this function allows the user to enter a list of words that might be used  
 ; to advance the partial-parses created from the original input.
 ; the function checks all the words in the list and returns a list of
 ; those which are possibilities for advancing the parse.
 
  (terpri)
  (princ "Enter the list of possible next words:")
  (terpri)
  (let ((list (read)))
        (checkword list)
       list))

(defun restart-parse (halted-state next-word) 
 ; This procedure receives the state of the parse when the sentence 
 ; becomes nil.  It takes the next word and restarts the parse with it and 
 ; the state of the parse when the input ran out.  It constructs a new 
 ; state with this info, puts it on the open list and continues the search.  

 (let ((parses (cadr halted-state)) 
       (closed (car halted-state)))
       (search-parse (reconstruct-open parses next-word)
       		     (reconstruct-closed closed next-word)))) 

(defun reconstruct-open (parses next-word) 
  ; function reconstructs the open list by inserting the next-word 
  ; into each of the partial-parses and generating the next states from there.

  (cond ((null parses) nil) 
	(t (cons (append (list (caar parses)) 
			 (list next-word) (cddar parses)) 
		 (reconstruct-open (cdr parses) next-word)))))

(defun reconstruct-closed (old-closed new-word) 
  ; function reconstructs the closed list to take into account the 
  ; new input.  This new word is joined to the end of the sentence in each 
  ; state on the closed list.  

  (let* ((a-closed-state (car old-closed))
	 (node (car a-closed-state))
	 (sentence (cadr a-closed-state))
	 (reglist (caddr a-closed-state))
	 (holdlist (cadddr a-closed-state))
	 (stack (caddddr a-closed-state)))

	(cond ((null old-closed) nil) 
	      ((cons (list node (append sentence new-word) 
			   reglist holdlist stack) 
		     (reconstruct-closed (cdr old-closed) new-word))))))
 

(defun get-next-input () 
  ; This function accepts the next input word and returns it.  

  (terpri) 
  (princ "Enter the next word:") 
  (let ((word (read))) 
       (checkword word) 
       (setq sentence-so-far (append sentence-so-far word))
       word))

(defun rest-of-sentence (sentence) 
  ; gets the appropriate part of the sentence for continuing the search.  
  ; input only advances on CAT, MEM, WRD, and PUSH arcs.  We know these arcs 
  ; may eat the input (i.e. the input is of the right form) because this 
  ; procedure is only called after the arc has been tested in test-arc and 
  ; taken in take-arc.  

  (cond ((null sentence) nil) 
	((or (equal kind `VIR) (equal kind `JUMP) (equal kind `POP)) sentence) 
	(t (cdr sentence)))) 

; SEARCH FUNCTIONS

(defun build-states (arcs lex reglist holdlist stack) 
  ; adds the state of the parse info to each arc. Returns a list of 
  ; states- each with a different arc and the current reglist 
  ; holdlist and stack. (i.e. no changes to the reglist are done yet, this 
  ; this only attaches them to the arcs.)

  (mapcar (function (lambda (x) (list x lex reglist holdlist stack))) arcs))

(defun generate-states (node sentence reglist holdlist stack) 
  ; function generates all the possible next states from the 
  ; given state.  
  ; It returns each state in the form of 
  ; a list of (<arc> <sentence> <reglist> <holdlist> <stack>) with 
  ; each as they would be after the arc has been taken.  

  (apply `append (mapcar (function (lambda (x) (take-arc x))) 
			 (get-arcs-off-node node sentence reglist 
					    holdlist stack))))

(defun get-arcs-off-node (node sentence reglist holdlist stack) 
  ; returns a list of states before executing each of the arcs off 
  ; the node.  These states consist of a list with sentence, reglist, 
  ; holdlist, and stack attached to each arc which is off of node and 
  ; is also valid with the sentence and current reglist and holdlist.  
  ; THe form is (<arc> <sentence> <reglist> <holdlist> <stack>).  

  (build-states (get-possible-arcs (get-arcs node) sentence 
				   reglist holdlist stack) 
		sentence reglist holdlist stack)) 

(defun get-possible-arcs (arcs sentence reglist holdlist stack) 
  ; tests all the arcs and returns only the possible ones.  

  (cond ((null arcs) nil) 
	((test-arcs (car arcs) sentence reglist holdlist stack) 
	 (cons (car arcs) 
	       (get-possible-arcs (cdr arcs) sentence reglist holdlist stack)))
	((get-possible-arcs (cdr arcs) sentence reglist holdlist stack))))

(defun test-arcs (arc sentence reglist holdlist stack) 
  ; procedure tests the arc to see if it is compatible with the current 
  ; word of input.  

  (declare (special sentence reglist holdlist stack))

  (let ((test (caddr arc))
	(kind (car arc))
	(lex (nextword sentence))
	(form (cadr arc)))
       (declare (special lex))

       (cond ((eq kind `CAT) (and (or (setq * (rootof lex)) t) (eval test) 
				  (cateq (getf CATEGORY) form))) 
	     ((eq kind `WRD) (and (or (setq * lex) t) (eval test) 
				  (eq (rootof *) form))) 
	     ((eq kind `MEM) (and (or (setq * lex) t) (eval test) 
				  (member * form :test #'equal))) 
	     ((eq kind `PUSH) (and (or (setq * lex) t) (eval test))) 
	     ((eq kind `VIR) (and (or (setq * lex) t) (eval test))) 
	     ((eq kind `JUMP) (and (or (setq * lex) t) (eval test))) 
	     ((eq kind `POP) (and (or (setq * lex) t) (eval test) (popcheck)))
	     (t nil))))

(defun do-actions (arc sentence reglist holdlist stack) 
  ; performs all the actions in an arc and returns the state 
  ; of the parse afterwards.  

  (declare (special reglist holdlist sentence stack))

  (let ((actions (cdddr arc))
	(kind (car arc))
	(lex (nextword sentence))
	(form (cadr arc)))
       (declare (special kind lex))

	(cond ((equal kind `CAT) (or (setq * (rootof lex)) t) 
	      (eval-actions arc actions sentence reglist holdlist stack)) 
	      ((equal kind `WRD) (or (setq * lex) t) 
	      (eval-actions arc actions sentence reglist holdlist stack)) 
	      ((equal kind `MEM) (or (setq * lex) t) 
	      (eval-actions arc actions sentence reglist holdlist stack)) 
	      ((equal kind `VIR) (setq * (unhold form)) 
	      (eval-actions arc actions sentence reglist holdlist stack)) 
	      ((equal kind `JUMP) (or (setq * lex) t) 
	      (eval-actions arc (append actions (list (list `to form)))
			    sentence reglist holdlist stack)) 
	      ((equal kind `POP) (or (setq * lex) t) (setq * (eval form)) 
	      (cond ((null stack) 
		    (eval-actions arc actions sentence reglist holdlist stack))
		    (t (setq arc (caar stack))
		       (setq actions (not-sends (cdddar (car stack))))
		       (setq reglist (copy-symbol (caddr (car stack)) t))
		       (setq holdlist (copy-symbol (cadddr (car stack)) t))
		       (setq stack (cdr stack)) 
		       (eval-actions arc actions 
				     sentence reglist 
				     holdlist stack)))
	       ))))

(defun eval-actions (arc actions sentence reglist holdlist stack) 
  ; takes a list of actions, evaluates them, and returns a list 
  ; of the reglist, holdlist, and stack after evaluation.  
  ; the evaluation is done by anding them together and it 
  ; stops when an action evaluates to nil.  
  
  (cond ((null actions) 
	(list (get-next-node arc) sentence reglist holdlist stack)) 
	((eval (cons `and (mapcar (function (lambda (x) (list `eval x))) 
				  actions))) 
	(list (get-next-node arc) (rest-of-sentence sentence) 
	      reglist holdlist stack))))
 

(defun take-arc (state) 
  ; takes the arc and evaluates its actions to return a state of the 
  ; next node after the arc, and the state of the world after the arc listed as 
  ; (<node> <sentence> <newregisters> <holdlist> <newstack>).  

  (let* ((arc (car state)) 
	 (sentence (cadr state))
	 (reglist (copy-symbol (caddr state) t))
	 (holdlist (copy-symbol (cadddr state) t))
	 (stack (caddddr state)) (kind (caar state))
	 (form (cadar state))
	 (newstack (cons state stack)))
	(declare (special arc sentence reglist kind))
	
	(cond ((null state) nil) 
	      ((equal kind `PUSH) 
	       (generate-states form sentence 
				(build-reg (get-sends (cdddr arc)) 
					   (copy-symbol reglist nil) holdlist stack) 
				holdlist newstack)) 
	      (t (list (do-actions arc sentence reglist holdlist stack))))))

; FUNCTIONS INVOLVED WITH PUSH

(defun get-sends (actions)
  ; get-sends filters out the pre-actions from the actions of PUSH arc.

  (filter (function (lambda (x) (member (car x) `(sendr sendrq)))) actions))

(defun not-sends (actions)
  ; not-sends filters out the actions taht aren't pre-actions of the PUSH arc.

  (filter (function (lambda (x) (not (member (car x) `(sendr sendrq)))))
	  actions))

(defun filter (pred list)
  ; filter returns a list of elements of lis that pred is non-nil for.

  (cond ((null list) nil)
	((funcall pred (car list)) (cons (car list) (filter pred (cdr list))))
	(t (filter pred (cdr list)))))

(defun build-reg (send-acts newreglist holdlist stack)
  ; buildreg builds a new register list (newreglist) from the pre-actions of
  ; a PUSH arc.  It returns the finished list.

  (declare (special newreglist))
  (eval-actions arc send-acts sentence newreglist holdlist stack) newreglist)



; GRAMMAR FUNCTIONS

(defmacro setr (thereg theform)
; setr sets the value of the reg in the reglist to the result of evaluating
; the form.

(list `doset (list `quote thereg) theform `reglist))

(defmacro setrq (thereg thevalue)
; setrq sets the value of the reg in the reglist to thevalue.

(list `doset (list `quote thereg)
	     (list `quote thevalue)
	     `reglist))

(defmacro sendr (thereg theform)
  ; sendr sets the value of reg to the result of evaluating form in newreglist,
  ; the list of registers sent down on a PUSH.  It is the equivalent of setr.

  (list `doset (list `quote thereg) theform `newreglist))

(defmacro sendrq (thereg thevalue)
  ; sendrq is like setrq just as sendr is like setr.

  (list `doset (list `quote thereg)
	(list `quote thevalue)
	`newreglist))

(defmacro liftr (thereg theform)
  ; liftr sets the value of reg to the result of evaluating form in the register
  ; list at the level of the parser above the current one.  This is done by
  ; going onto the stack to get the list of registers.

  (list `doset (list `quote thereg) theform `(caddr (car stack))))

(defun doset (reg value registers)
  ; doset puts a value as value of the property reg in the registers property
  ; list.  It returns true no matter what.

  (putprop registers value reg) t)

(defmacro getr (thereg)
  ; getr returns the contents of the register thereg.

  (list `get `reglist (list `quote thereg)))

(defun doget (reg)
  ; doget does the same thing as getr, but it evaluates its paramenters.

  (get reglist reg))

(defmacro addl (thereg theform)
  ; addl adds the value of form to the left end of the list contained in
  ; register reg.

   (list `doset (list `quote thereg) 
	(list `quote  (append (list theform)
			     (eval (list `doget (list `quote thereg))))) `reglist))

(defmacro addr (thereg theform)
  ; addr adds the value of form to the right end of the list contained in 
  ; register reg.

  (list `doset (list `quote thereg) 
	(list `append 
	      (list `doget (list `quote thereg))
	      (list `list theform))
	`reglist))

(defun hold (constit form)
  ; hold puts form as the value of the property constit on the holdlist
  ; property list.

  (putprop holdlist form constit) t)

(defun unhold (constit)
  ; unhold gets the value of the property constit on the property list holdlist.
  ; It also sets the value of the constit to nil afterwards.

  (setq temp (get holdlist constit))
  (putprop holdlist nil constit)
  temp)

(defmacro getf (thefeature &optional theword)
  ; getf gets the value of feature for a word from the dictionary.  If no
  ; word is specified, getf assumes word to be the current word being parsed.

  (list `cond (list (list `null theword)
		    (list `dogetf (list `quote thefeature) `lex))
	(list `t (list `dogetf (list `quote thefeature) theword))))


(defun dogetf (feature word)
  ; dogetf does the same thing as getf, but it evaluates its paramenters.

  (lisp:getf (symbol-plist word) feature))

(defmacro nullr (thereg)
  ; nullr returns true if the contents of thereg are nil, or if thereg was
  ; never set.

  (list `null (list `doget (list `quote thereg))))

(defun checkf (thefeature thevalue)
  ; checkf checks to see if the feature of the current word is equal to value.

  (list `equal (list `dogetf (list `quote thefeature)
		     (list `quote lex) thevalue)))

(defun endofsentence ()
  ; endofsentence returns true if there are no more words in the sentence.

  (null sentence))

(defun abort ()
  ; abort returns nil always.

  nil)

(defmacro to (thenextstate)
  ; a nothing function.

  t)


; 	FUNCTIONS FOR BUILDQ

(defmacro buildq (&rest template)
  ; buildq builds a structure templated in pattern with the values of
  ; the elements of the forms.

  (list `car
	(list `bq
	      (list `quote (car template))
	      (list `quote (cdr template)))))

(defun dobuild (pattern forms)
  ; dobuild calls bq with the pattern and the forms to build the structure
  ; for buildq.

	(list `quote (car (bq pattern forms))))

(defun bq (pattern forms)
  ; bq does all the real work for buildq.  It returns a structure containing
  ; the completed pattern so far and the forms remaining to be finished.

  (cond ((eq pattern `*) (cons * forms))
	((eq pattern `+) (cons (doget (car forms)) (cdr forms)))
	((eq pattern `\#) (cons (eval (car forms)) (cdr forms)))
	((atom pattern) (cons pattern forms))
	((eq (car pattern) `@) (doappends (cdr pattern) forms))
	(t (let* ((structure (bq (car pattern) forms))
		  (structure1 (bq (cdr pattern) (cdr structure))))
		 (cons (cons (car structure) (car structure1))
		       (cdr structure1))))))

(defun doappends (pats forms)
  ; doappends does the same thing as bq, with the exception that it appends
  ; its results together, instead of consing them together.

  (cond ((null pats) (cons nil forms))
	(t (let* ((structure (bq (car pats) forms))
		  (structure1 (doappends (cdr pats) (cdr structure))))
		 (cons (append (car structure) (car structure1))
		       (cdr structure1))))))

;	UTILITY FUNCTIONS

(defun popcheck ()
  ; popcheck checks to see if it is legal to pop.  The only illegal condition
  ; is an empty stack when the end of the sentence hasn't been reached.

  (not (and (or lex (not (holdempty holdlist))) (null stack))))

(defun holdempty (holdlist)
  ; holdempty returns true if there is nothing on the holdlist.

  (checkcdr (symbol-plist holdlist))
t)

(defun checkcdr (holdcdr)
  ; checkcdr checks every other element in the list and returns true is all
  ; of them are nil.

  (cond ((null holdcdr) t)
	(t (and (null (cadr holdcdr)) (checkcdr (cddr holdcdr))))))

(defun nextword (sentence)
  ; nextword returns the nextword of the sentence.

  (cond ((not (endofsentence)) (car sentence))
	(t nil)))

(defun rootof (word)
  ; rootof returns the root of word in the dictionary.  If word
  ; doesn't have a root, rootof returns word.

  (let ((theroot (franz-get word `ROOT)))
       (cond ((null theroot) word)
	     (t theroot))))

(defun get-next-node (arc)
  ; returns the next arc to be taken after executing the current.
  ; (translates the (to ARC) statement),
  ; returning ARC as the next state.
  ; If there is no (to ARC) statement- as in POP arcs, the function
  ; returns the entire arc
	      
  (cond ((null arc) nil)
	((equal (car arc) `POP) arc)
	((equal (car arc) `JUMP) (cadr arc))
	((and (listp (car arc))
	      (equal (caar arc) `to)) (cadar arc))
	((get-next-node (cdr arc)))))

(defun get-arcs (state)

  ; get-arcs returns the arcs of the state.

  (strip-quotes (franz-get grammar state)))

(defun cateq (dentry form)
  ; cateq returns true if dentry=form or if form is in the list dentry.

  (cond ((atom dentry) (eq dentry form))
	(t (member form dentry :test #'equal))))

(defun strip-quotes (arcs)
  ; takes a list of arcs and strips off the quotes that preface each
  ; arc (as per this grammar).

  (cond ((null arcs) nil)
	((cons (eval (car arcs))
	       (strip-quotes (cdr arcs))))))

;	REGISTER DUMPING FUNCTIONS

(setq dumpstates nil)

(setq dump nil)
 
(defun dtoggle ()
  ; dtoggle turns the register dump features on and off
  (setq dump (not dump)))
 
(defun newdump (state)
  ; newdump adds state to the list of states to dump registers at 
  (setq dumpstates (cons state dumpstates)))

(defun setdumps (statelist)
  ; setdumps sets dumpstates to statelist
  (setq dumpstates statelist))
 
(defun nulldumps ()
  ; nulldumps sets dumpstates to nil
  (setq dumpstates nil))
 
(defun rmdump (state)
  ; rmdump removes state from dumpstates
  (setq dumplist (rmstate dumpstates state)))
 
(defun rmstate (list state)
  ; rmstate removes all occurences of state from list
  (cond ((null list) nil)
	((equal (car list) state) (rmstate (cdr list) state))
	(t         (cons (car list) (rmstate (cdr list) state)))))

(defun regdump (reglist state)
  ; regdump prints a register dump
  (princ "Register values upon entry to state ")
  (princ state)
  (terpri)
  (cond ((null (symbol-plist reglist)) (princ "No registers set")
	(terpri) (terpri))
	(t (symbol-plist reglist))))
 
(defun printvals (reglist)
  ; printvals prints the name of the register and its value on the same line
  (cond ((null reglist) (terpri))
	(t      (princ (car reglist))
	(tab 10)
	(princ (cadr reglist))
	(terpri)
	(printvals (cddr reglist)))))


;	DICTIONARY DECLARATION

(defmacro dw (word cat values feat &optional root)
  ; (dw <word> <categories> <values> <features> <root form>)
  ; dw builds the dictionary entry for word.

  `( ,(setplist word values) 
     ,(putprop word cat `CATEGORY) 
     ,(dofeatures word feat) 
     ,(putprop word root `ROOT)) 
  t)

(defun dofeatures (word feat)
  ; dofeatures sets the value of each label in the list feat to t in the
  ; property list of word.

  (cond ((null feat) nil)
	(t (putprop word t (car feat)) (dofeatures word (cdr feat)))))


; FUNCTIONS FOR COMMON LISP

(defun setplist (label properties)
  ; makes label a symbol with the property list list.
  (setf (symbol-plist label)  properties))

(defun franz-get (symbol propname)
  (if (symbolp symbol)
      (get symbol propname)
      (if (consp symbol)
	  (lisp:getf (cdr symbol) propname)
	  (error "~S is not a disembodied property list. " symbol))))

(defun putprop (symbol value propname)
  (cond ((symbolp symbol)
	 (setf (get symbol propname) value))
         (t ;; disembodied property list
	   (if (consp symbol)
	       (setf (lisp:getf (cdr symbol) propname) value)
	       (error "~S is not a disembodied property list." symbol)))))

(defun load-grammar (arclist)
  ; function puts the arc labels and the arcs themselves on a property list
  ; called grammar.  This is how common list must handle disembodied
  ; property lists.

  (setq grammar (copy-symbol `grammar))
  (do-put-props arclist))

(defun do-put-props (labeled-arcs)
  ; recursive function to do all the putprops necessary to build the grammar.
  (cond ((null labeled-arcs) nil)
	((putprop grammar (second labeled-arcs) (first labeled-arcs))
	(do-put-props (cddr labeled-arcs)))))

(defun tab (number)
  ; moves output over number spaces.
  (make-list number :initial-element `_))

(defun add1 (number)
  ; function adds one!
  (+ 1 number))

(defmacro pp (form)
  (list `print (list `quote form)))

(defun caddddr (form)
  ;common lisp does not recognize this form.
  (fifth form))

(defun equal-state? (state state-from-list)
  ; checks to parse states for equality.
  (and (equal (car state) (car state-from-list))
       (equal (cadr state) (cadr state-from-list))
       (equal (symbol-plist (caddr state)) (symbol-plist (caddr state-from-list)))
       (equal (symbol-plist (cadddr state)) (symbol-plist (cadddr state-from-list)))
       (equal (cddddr state) (cddddr state-from-list))))
2 X' THEORY GRAMMAR
; X' Theory Grammar

; Julie A. Van Dyke
; May 30, 1991

; Three basic "phrase structure rules" underly the construction of
; this grammar:
;	XP --> SPECIFIER XBAR
;	XBAR --> X COMPLEMENT
;	XBAR --> XBAR ADJUNCT or ADJUNCT XBAR

; For a more detailed discussion of this grammar, refer to Chapter 3 of:

; Van Dyke, J.A.  (1991). Word Prediction for Disabled Users: Applying
;	Natural Language Processing to Enhance Communication.  
; 	Honors BA Thesis, University of Delaware.


(load-grammar `(
		DP/ (`(CAT DET (getf PRE-DET) 
			   (setr PRE-DET *)
			   (to DP/SPEC)) 
		      `(CAT ADJ (getf PRE-DET)
			    (setr PRE-DET *)
			    (to DP/SPEC))
		      `(JUMP DP/SPEC t))

		DP/SPEC (`(PUSH DBAR/ (dpstart) 
				(sendr TYPE (getr TYPE))
				(sendr INTRO (getr INTRO))
				(sendr PRE-DET (getr PRE-DET))
				(setr DBAR *) 
				(liftr NU (getr NU)) 
				(to DP/DBAR)))
		
		DP/DBAR (`(POP (buildq (@ (DP) ((SPEC +)) (+)) PRE-DET DBAR) t))

		DBAR/ (`(CAT DET (getf CENTRAL-DET) 
			     (setr DET *) 
			     (setr DET1 *)
			     (predetcheck) 
			     (to DBAR/HEAD)) 
			`(CAT PRO t
			      (setr DET (buildq (PRO *)))
			      (setr DET1 *)
			      (setr NU (getf NUMBER))
			      (liftr NU (getr NU))
			      (to DBAR/HEAD))
			`(CAT N (getf CARDINAL)
			      (setr DET *)
			      (setr DET1 *)
			      (predetcheck)
			      (to DBAR/HEAD))
			`(JUMP DBAR/HEAD (predetcheck)))
		
		DBAR/HEAD (`(PUSH NP/ (npstart)
				  (sendr DET (getr DET1)) 
				  (sendr PRE-DET (getr PRE-DET)) 
				  (sendr TYPE (getr TYPE))
				  (sendr INTRO (getr INTRO))
				  (sendr NU (getr NU))
				  (setr COMP *)
				  (liftr NU (getr NU))
				  (to DBAR/COMP))
			    `(PUSH PP/ (and (ppstart)
					    (cateq (getr DET) `PRO))
				   (setr COMP *)
				   (to DBAR/COMP))
			    `(JUMP DBAR/COMP (cond ((getf NP (getr DET1)) nil)
						   ((getr DET1)))))

		DBAR/COMP (`(POP (cond ((nullr COMP)
					(buildq (@ (DBAR) ((HEAD +)) ((NU +)) ((COMP +))) 
					 DET NU COMP))
				       ((or(getr DET1) (getr COMP))
					(buildq (@ (DBAR) ((HEAD +)) ((COMP +)))
						DET COMP))) t))

		MP/ (`(CAT DET (getf ART)
			   (setr SPEC *)
			   (to MP/SPEC))
		      `(CAT N (getf CARDINAL)
			    (setr SPEC *)
			    (to MP/SPEC))
		      `(JUMP MP/SPEC t))

		MP/SPEC (`(PUSH MBAR/ (mpstart)
				(setr MBAR *)
				(to MP/MBAR)))

		MP/MBAR (`(POP (buildq (@ (MP) ((SPEC +)) (+)) SPEC MBAR) t))

		MBAR/ (`(CAT N (getf MENSURAL)
			    (setr M *)
			    (to MBAR/HEAD)))

		MBAR/HEAD (`(JUMP MBAR/COMP t))

		MBAR/COMP (`(POP (buildq (@ (MBAR) ((HEAD +)) ((COMP +)))
					 M COMP) t))


		ADVP/ (`(JUMP ADVP/SPEC t))

		ADVP/SPEC (`(PUSH ADVBAR/ (and (advpstart) 
					       (not (getf NEG)))
				  (setr ADVBAR *)
				  (to ADVP/ADVBAR)))
		ADVP/ADVBAR (`(POP (buildq (@ (ADVP) ((SPEC +)) (+))
					   SPEC ADVBAR) t))

		ADVBAR/ (`(CAT ADV t
			       (setr ADV *)
			       (to ADVBAR/HEAD)))

		ADVBAR/HEAD (`(PUSH PP/ (ppstart)
				    (setr COMP *)
				    (to ADBAR/COMP))
			      `(JUMP ADVBAR/COMP t))

		ADVBAR/COMP (`(POP (buildq (@ (ADVBAR) ((HEAD +)) ((COMP +)))
					   ADV COMP) t))


		QP/ (`(JUMP QP/SPEC t))

		QP/SPEC (`(PUSH QBAR/ (qpstart)
				(sendr ZONE (getr ZONE))
				(setr QBAR *)
				(liftr ZONE (getr ZONE))
				(to QP/QBAR)))

		QP/QBAR (`(POP (buildq (@ (QP) ((SPEC +)) (+))
				       SPEC QBAR) t))

		QBAR/ (`(CAT ADJ (getf QUANT)
			     (setr Q *)
			     (resetzone (getf ZONE) (getr ZONE))
			     (liftr ZONE (getr ZONE))
			     (to QBAR/HEAD)))

		QBAR/HEAD (`(PUSH PP/ (ppstart)
				  (setr COMP *)
				  (to QBAR/COMP))
			    `(JUMP QBAR/COMP t))

		QBAR/COMP (`(POP (buildq (@ (QBAR) ((HEAD +)) ((COMP +)))
					 Q COMP) t))


		DEGP/ (`(PUSH MP/ (mpstart) 
			      (setr SPEC *)
			      (to DEGP/SPEC))
			`(CAT ADJ (getf QUANT)
			      (setr SPEC *)
			      (to DEGP/SPEC))
			`(JUMP DEGP/SPEC t))


		DEGP/SPEC (`(PUSH DEGBAR/ (or (getf DEG) (apstart)
					      (advpstart)) 
				  (sendr V (getr V))
				  (sendr SELECT (getr SELECT))
				  (sendr ZONE (getr ZONE))
				  (setr DEGBAR *)
				  (liftr ZONE (getr ZONE))
				  (to DEGP/DEGBAR)))

		DEGP/DEGBAR (`(POP (buildq (@ (DEGP) ((SPEC +)) (+)) 
				       SPEC DEGBAR) 
			       (or (not (nullr SPEC))
				   (not (nullr DEGBAR)))))

		DEGBAR/ (`(CAT ADV (getf DEG)
			       (setr DEG *)
			       (to DEGBAR/HEAD))
			  `(JUMP DEGBAR/HEAD t))

		DEGBAR/HEAD (
			     `(PUSH AP/ (and (apstart) 
					     (or (equal (getr SELECT) `AP)
					     (nullr SELECT)))
				    (sendr V (getr V))
				    (sendr ZONE (getr ZONE))
				    (setr COMP *)
				    (liftr ZONE (getr ZONE))
				    (to DEGBAR/COMP))
			     `(PUSH ADVP/ (and (advpstart) 
					       (or (equal (getr SELECT) `ADVP)
					       (nullr SELECT)))
				    (setr COMP *)
				    (to DEGBAR/COMP))
			     `(PUSH QP/ (and (apstart) 
					     (or (equal (getr SELECT) `QP)
						 (nullr SELECT)))
				    (sendr ZONE (getr ZONE))
				    (setr COMP *)
				    (liftr ZONE (getr ZONE))
				    (to DEGBAR/COMP))
			     `(JUMP DEGBAR/COMP t))
	
		DEGBAR/COMP (`(POP (cond ((nullr COMP)
					  (buildq (@ (DEGBAR) ((HEAD +))) DEG))
					 ((buildq (@ (DEGBAR) ((HEAD +)) 
						     ((COMP +))) DEG COMP))) 
				   (or (not (nullr DEG))
				       (not (nullr COMP)))))


		AP/ ( `(JUMP AP/SPEC t))
	
		AP/SPEC (`(PUSH ABAR/ (apstart)
				(sendr V (getr V))
				(sendr ZONE (getr ZONE))
				(setr ABAR *)
				(liftr ZONE (getr ZONE))
				(to AP/ABAR)))

		AP/ABAR (`(POP (buildq (@ (AP) ((SPEC +)) (+))
				       SPEC ABAR) 
			       (or (not (nullr SPEC))
				   (not (nullr ABAR)))))

		ABAR/ (`(CAT ADJ t
			     (addr ADJ *)
			     (resetzone (getf ZONE) (getr ZONE))
			     (liftr ZONE (getr ZONE))
			     (predadjcheck)
			     (to ABAR/HEAD))
			`(JUMP ABAR/HEAD t))

		ABAR/HEAD (`(PUSH PP/ (ppstart)
				   (setr COMP *)
				   (to ABAR/COMP))
			    `(JUMP ABAR/COMP t))

		ABAR/COMP (`(POP (cond ((nullr COMP)
					(buildq (@ (ABAR) ((HEAD +))) ADJ))
				       ((buildq (@ (ABAR) ((HEAD +)) ((COMP +)))
						ADJ COMP))) 
				 (or (not (nullr COMP))
				     (not (nullr ADJ)))))


		NP/ (`(CAT ADJ (getf QUANT)
			   (setr QUANT *)
			   (setr SPEC *)
			   (centdetcheck)
			   (to NP/SPEC))
		      `(PUSH MP/ (mpstart)
			     (setr SPEC *)
			     (to NP/SPEC))
		      `(JUMP NP/SPEC (centdetcheck)))


		NP/SPEC (`(PUSH NBAR/ (npstart) 
				(sendr QUANT (getr QUANT)) 
				(sendr PRE-DET (getr PRE-DET)) 
				(sendr DET (getr DET)) 
				(setr NBAR *) 
				(liftr NU (getr NU))
				(to NP/NBAR))
			  `(VIR NBAR (and (getr INTRO)
					  (equal (getr TYPE) `REL-CLAUSE))
				(setr NBAR *)
				(liftr NU (getnu (getr NBAR)))
				(to NP/NBAR)))

		NP/NBAR (`(PUSH PP/ (ppstart) 
				(addr NBAR (buildq (ADJUNCT *))) 
				(to NP/NBAR)) 
			  `(POP (buildq (@ (NP) ((SPEC +)) (+))
					SPEC NBAR) t)
			  `(PUSH RELCL/ (and (getr NBAR) 
					     (not (getf WH (getr N)))
					     (nullr RELCL-TYPE))
				 (sendr ATTRIBUTE (getr ATTRIBUTE))
				 (sendr N (getr N))
				 (sendr NU (getr NU))
				 (addr NBAR (buildq (RESTRICT *)))
				 (liftr TYPE (getr TYPE))
				 (to NP/RELCL)))

		NP/RELCL (`(POP (buildq (@ (NP) ((SPEC +)) (+))
					SPEC NBAR) t))

		NBAR/ (`(PUSH DEGP/ (and (apstart) 
					 (cond ((nullr ZONE) t)
					       ((checkzone (getf ZONE) (getr ZONE)))))
			      (sendr ZONE (getr ZONE))
			      (sendr SELECT `AP)
			      (addr ATTRIBUTE (buildq (ATTRIB *)))
			      (to NBAR/))
			`(CAT N t (setr N *) 
			      (setr NU (getf NUMBER))
			      (liftr NU (getr NU))
			      (liftr N (getr N))
			      (predetnouncheck) 
			      (quantcheck) 
			      (detagree) 
			      (to NBAR/HEAD)))

		NBAR/HEAD (`(PUSH PP/ (ppstart) 
				  (setr COMP *) 
				  (to NBAR/COMP))
			    `(JUMP NBAR/COMP t)
			    `(PUSH RELCL/ (and (getr N)
					       (equal lex `that)
					       (not (getf WH (getr N))))
				   (setr RELCL-TYPE `NCC)
				   (sendr RELCL-TYPE (getr RELCL-TYPE))
				   (sendr ATTRIBUTE (getr ATTRIBUTE))
				   (sendr N (getr N))
				   (sendr NU (getr NU))
				   (setr COMP *)
				   (liftr TYPE (getr TYPE))
				   (liftr RELCL-TYPE (getr RELCL-TYPE))
				   (to NBAR/RELCL)))

		NBAR/RELCL (`(POP (buildq (@ (NBAR) + ((HEAD +)) ((NU +))
					     ((COMP +)))
				  ATTRIBUTE N NU COMP) t))

		NBAR/COMP (`(POP (cond ((nullr COMP) 
					(buildq (@ (NBAR) + ((HEAD +)) ((NU +))) 
						ATTRIBUTE N NU)) 
				       ((buildq (@ (NBAR) + ((HEAD +)) ((NU +)) ((COMP +))) 
						ATTRIBUTE N NU COMP))) t))


		PP/ (`(PUSH DEGP/ t (sendr SELECT `QP)
			     (setr SPEC *)
			     (to PP/SPEC))
		      `(JUMP PP/SPEC t))

		PP/SPEC (`(PUSH PBAR/ (ppstart) 
				(setr PBAR *) 
				(to PP/PBAR)))

		PP/PBAR (`(POP (buildq (@ (PP) ((SPEC +)) (+)) SPEC PBAR) t))

		PBAR/ (`(CAT PREP t 
			     (setr PREP *) 
			     (to PBAR/HEAD)))

		PBAR/HEAD (`(PUSH DP/ (dpstart) 
				  (setr COMP *) 
				  (to PBAR/COMP)))

		PBAR/COMP (`(POP (buildq (@ (PBAR) ((HEAD +)) ((COMP +))) 
					 PREP COMP) t))

	
		RELCL/ (`(JUMP RELCL/SPEC t))
		
		RELCL/SPEC (`(PUSH RELCLBAR/ t
				   (sendr ATTRIBUTE (getr ATTRIBUTE))
				   (sendr N (getr N))
				   (sendr NU (getr NU))
				   (setr RELCLBAR *)
				   (to RELCL/RELCLBAR)))
		
		RELCL/RELCLBAR (`(POP (buildq (+ (@ (CP) ((SPEC +)) (+)))
					     TYPE SPEC RELCLBAR) t))
		
		RELCLBAR/ (`(CAT PRO (and (not (equal lex `that)) (getf REL) (getr N))
			      (hold `NBAR (buildq (@ (NBAR) + ((HEAD +))
														((NU +)))
													 ATTRIBUTE N NU))
			      (setr INTRO *)
			      (setrq TYPE REL-CLAUSE)
			      (liftr TYPE (getr TYPE))
			      (to RELCLBAR/HEAD))
			 `(CAT DET (and (getf REL) (getr N))
			       (hold `NBAR (buildq (@ (NBAR) + ((HEAD +))
														 ((NU +)))
													  ATTRIBUTE N NU))
			       (setr INTRO *)
			       (setrq TYPE REL-CLAUSE)
			       (liftr TYPE (getr TYPE))
			       (to RELCLBAR/HEAD))
			 `(WRD that (getr N) (setr INTRO *)
			       (cond ((equal `NCC (getr RELCL-TYPE)) t)
				     ((hold `NBAR (buildq (@ (NBAR) + ((HEAD +))
														 ((NU +)))
													  ATTRIBUTE N NU))))
			       (setrq TYPE REL-CLAUSE)
			       (liftr TYPE (getr TYPE))
			       (to RELCLBAR/HEAD))
			 `(JUMP RELCLBAR/HEAD (getr N) 
				(hold `NBAR (buildq (@ (NBAR) + ((HEAD +))
														  ((NU +)))
													   ATTRIBUTE N NU))
				(setrq TYPE REL-CLAUSE)
				(liftr TYPE (getr TYPE))))



		RELCLBAR/HEAD (`(PUSH RELCLIP/ t 
				   (sendr INTRO (getr INTRO))
				   (sendr TYPE (getr TYPE))
				   (setr COMP *) 
				   (to RELCLBAR/COMP)))

		RELCLBAR/COMP (`(POP (buildq (@ (CBAR) ((HEAD +)) ((COMP +)))
					   INTRO COMP) t))

		RELCLIP/ (`(PUSH DP/ (dpstart) 
				  (sendr TYPE (getr TYPE))
				  (sendr INTRO (getr INTRO))
				  (setr DP1 *) 
				  (setr DP *)
				  (liftr TYPE (getr TYPE))
				  (to IP/SPEC)))

		CP/ (`(PUSH DP/ (and (getf WH) (dpstart))
			   (hold `DP *) 
			   (setrq TYPE WH-Q)
			   (to CP/SPEC))
		      `(CAT ADV (getf WH) 
			    (hold `DP (buildq (@ (DP) ((HEAD (WH-ADV *)) (NU \#))) 
					      (getf NUMBER)))
			    (setrq TYPE WH-Q)
			    (to CP/SPEC))
		      `(JUMP CP/SPEC t)) 

		CP/SPEC (`(PUSH CBAR/ t 
				(sendr TYPE (getr TYPE))
				(setr CBAR *)
				(cond (stack (liftr TYPE2 (getr TYPE)))
				      (t t))
				(to CP/CBAR)))

		CP/CBAR (`(POP (buildq (+ (@ (CP) ((SPEC +)) (+))) 
				       TYPE SPEC CBAR) t))
		CBAR/ (`(WRD that t 
			     (setr HEAD (buildq (COMPLEMENTIZER *)))
			     (to CBAR/HEAD))
			`(JUMP CBAR/HEAD t))

		CBAR/HEAD (`(PUSH IP/ t 
				  (sendr TYPE (getr TYPE))
				  (sendr V1 (getr V1))
				  (setr IP *)
				  (liftr TYPE (getr TYPE))
				  (to CBAR/COMP)))

		CBAR/COMP (`(POP (buildq (@ (CBAR) ((HEAD +)) ((COMP +))) HEAD IP) t))


		IP/ (`(PUSH DP/ (and (dpstart) (nullr TYPE))
			      (setr DP *) 
			      (setrq TYPE DCL) 
			      (liftr TYPE (getr TYPE))
			      (to IP/SPEC))
			`(JUMP IP/SPEC (and 
					(cond ((nullr TYPE) 
					       (setrq TYPE Y-N-Q)) 
					      (t t))
					(or (equal (getf CATEGORY) `V)
					    (equal (getf CATEGORY) `MODAL)
					    (and (listp (getf CATEGORY))
						 (or (member `V (getf CATEGORY))
						     (member `MODAL (getf CATEGORY))))))
					(liftr TYPE (getr TYPE))))

		IP/SPEC (`(PUSH IBAR/ t 
				(sendr TYPE (getr TYPE))
				(sendr DP (getr DP))
				(sendr NU (getr NU))
				(setr IBAR *)
				(to IP/IBAR)))

		IP/IBAR (`(POP (buildq (@ (IP) ((SPEC +)) (+)) 
				       DP IBAR)
			       (cond ((equal (getr TYPE) `NON-FINITE)
				      (not (null stack)))
				     (t t))))

		IBAR/ (`(CAT MODAL t 
			       (Auxagree lex nil)
			       (addr INFL (buildq (MODAL *)))
			       (addr AUXS lex)
			       (cond ((nullr FIRST-V) (setr FIRST-V lex)) (t  t))
			       (to IBAR/MODAL)) 
			  `(WRD do t 
				(Auxagree * nil)
				(addr INFL (buildq (@ (DO-SUPPORT) (*))))
				(addr AUXS *)
				(setr FIRST-V *)
				(to IBAR/BE))
			  `(JUMP IBAR/MODAL t (setr FIRST-V nil)))

		IBAR/MODAL (`(CAT ADV (and (nullr NEG) (getf NEG)
					(equal (getr FIRST-V)
					       (car (last (getr AUXS))))
					(cond ((equal (getr TYPE) `Y-N-Q)
					       (nullr DP))
					      (t t)))
			       (setr NEG (buildq (NEG *)))
			       (addl INFL (getr NEG))
			       (to IBAR/MODAL))
			  `(WRD have (cond ((and (equal (getr TYPE) `Y-N-Q) 
						(nullr DP))
					   (nullr FIRST-V)) (t t))
			       (Auxagree * (getr AUXS))
			       (addr INFL (buildq (@ (have) (en))))
			       (addr AUXS *)
			       (cond ((nullr FIRST-V) (setr FIRST-V *)) (t  t))
			       (to IBAR/HAVE))
			  `(PUSH DP/ (and (nullr DP) (dpstart))
				 (cond ((agree (getr NU) (getf PNCODE (getr FIRST-V)))
					(addr INFL 
					      (buildq (AGR \#) 
						      (car (agree (getr NU) (getf PNCODE (getr FIRST-V)))))))
				       ((abort)))
				 (setr DP *)
				 (to IBAR/MODAL))
			  `(JUMP IBAR/HAVE t))

		IBAR/HAVE (`(CAT ADV (and (nullr NEG) (getf NEG)
				       (equal (getr FIRST-V)
					      (car (last (getr AUXS))))
				       (cond ((equal (getr TYPE) `Y-N-Q)
					      (nullr DP))
					     (t t)))
			      (setr NEG (buildq (NEG *)))
			      (addl INFL (getr NEG))
			      (to IBAR/HAVE))
			 `(WRD be (cond ((and (equal (getr TYPE) `Y-N-Q) 
					     (nullr DP))
					(nullr FIRST-V)) (t t))
			      (cond ((nullr FIRST-V)
				      (not (getf UNTENSED lex))) (t )) 
			      (Auxagree * (getr AUXS))
			      (setr BE (buildq (@ (be) (ing))))
			      (addr AUXS *)
			      (cond ((nullr FIRST-V) (setr FIRST-V *)) (t  t))
			      (to IBAR/BE)) 
			 `(PUSH DP/ (and (nullr DP) (dpstart)) 
				(cond ((agree (getr NU) (getf PNCODE (getr FIRST-V)))
				       (addr INFL 
					     (buildq (AGR \#)
						     (car (agree (getr NU) (getf PNCODE (getr FIRST-V)))))))
				      ((abort)))
				(setr DP *)
				(to IBAR/HAVE))
			 `(JUMP IBAR/BE t))

		IBAR/BE (`(CAT ADV (and (nullr NEG) (getf NEG)
				     (equal (getr FIRST-V)
					    (car (last (getr AUXS))))
				     (cond ((equal (getr TYPE) `Y-N-Q)
					    (nullr DP))
					   (t t)))
			    (setr NEG (buildq (NEG *)))
			    (addl INFL (getr NEG))
			    (to IBAR/BE))
		       `(PUSH DP/ (and (nullr DP) (dpstart)) 
			     (cond ((agree (getr NU) (getf PNCODE (getr FIRST-V)))
				    (addr INFL (buildq (AGR \#)
						       (car (agree (getr NU) (getf PNCODE (getr FIRST-V)))))))
				   ((abort)))
			     (setr DP *)
			     (to IBAR/BE))
		       `(PUSH VP/ (vpstart) 
			     (sendr DP (getr DP))
			     (sendr AUXS (getr AUXS)) 
			     (sendr BE (getr BE))
			     (sendr FIRST-V (getr FIRST-V))
			     (sendr INFL (getr INFL))
                             (sendr NU (getr NU))
			     (sendr TYPE (getr TYPE))
			     (sendr V1 (getr V1))
			     (setr VP *)
			     (liftr DP (getr DP))
			     (liftr MOOD (getr MOOD))
			     (to IBAR/COMP)))

		IBAR/COMP (`(POP (buildq (@ (IBAR) ((@ (HEAD) +)) 
					  ((COMP +))) INFL VP) (getr INFL)))

		VP/(`(PUSH DEGP/ t (sendr SELECT `ADVP)
			   (setr SPEC *) 
			   (to VP/SPEC))
		     `(JUMP VP/SPEC t))

		VP/SPEC (`(PUSH VBAR/ (vpstart) 
				(sendr DP (getr DP))
				(sendr AUXS (getr AUXS)) 
				(sendr BE (getr BE))
				(sendr INFL (getr INFL))
				(sendr FIRST-V (getr FIRST-V))
                                (sendr NU (getr NU))
				(sendr TYPE (getr TYPE))
				(sendr V1 (getr V1))
				(setr VBAR *)
				(liftr INFL (getr INFL))
				(liftr DP (getr DP))
				(liftr MOOD (getr MOOD))
				(to VP/VBAR)))

		VP/VBAR (`(PUSH DP/ (and (dpstart)    
					 (getf INPR (getr V)))  
				(addr VBAR (buildq (ADJUNCT *)))
				(to VP/VBAR)) 
			  `(PUSH PP/ (and (ppstart) 
					  (or (getf TNPR (getr V))
					      (getf INPR (getr V))
					      (getf IPR (getr V))))
				 (addr VBAR (buildq (ADJUNCT *)))   
				 (to VP/VBAR))
			  `(PUSH EC/ (getf IT (getr V))
				 (sendr V (getr V))
				 (addr VBAR (buildq (ADJUNCT *)))
				 (to VP/VBAR))
			  `(PUSH ADVP/ (and (advpstart)
					    (or (getf TNP (getr V))
						(getf IP (getr V))))
				(addr VBAR (buildq (ADJUNCT *)))
				(to VP/VBAR))
			  `(VIR DP t 
				(and *
				 (addr VBAR (buildq (@ (ADJUNCT) (*)))))
				(to VP/VBAR))
			  `(VIR ADVP t 
				(and * 
				     (addr VBAR 
					   (buildq (@ (ADJUNCT) (*)))))
				(to VP/VBAR))
			  `(POP (buildq (@ (VP) ((SPEC +)) (+)) SPEC VBAR) t))


		VBAR/ (
		       `(CAT ADV (and (nullr NEG) (getf NEG)
				      (or (equal (getr FIRST-V)
					     (car (last (getr AUXS))))
					  (nullr AUXS))
				      (cond ((equal (getr TYPE) `Y-N-Q)
					     (nullr DP))
					    (t t)))
			     (setr NEG (buildq (NEG *)))
			     (addl INFL (getr NEG))
			     (liftr INFL (getr INFL))
			     (to VBAR/))
			`(VIR DP (and (equal (getr TYPE) `WH-Q) (nullr DP))
			      (setr DP *)
			      (cond ((agree (getnu (getr DP)) (getf PNCODE (getr FIRST-V)))
				     (addr INFL (buildq (AGR \#)
							(car (agree (getnu (getr DP)) (getf PNCODE (getr FIRST-V)))))))
				    ((abort)))
			     (liftr DP (getr DP))
			     (liftr INFL (getr INFL))
			     (to VBAR/))
			`(PUSH DP/ (and (nullr DP) (dpstart) 
					(equal (getr TYPE) `Y-N-Q))
			       (cond ((agree (getr NU) (getf PNCODE (getr FIRST-V)))
				      (addr INFL (buildq (AGR \#)
							 (car (agree (getr NU) (getf PNCODE (getr FIRST-V))))))
				      (liftr INFL (getr INFL)))
				     (abort))

				      (setr DP *)
			       (liftr DP (getr DP))
			       (to VBAR/))
			`(CAT V (and (nullr V)
				     (cond ((equal (getr TYPE) `Y-N-Q)
					    (getr FIRST-V)) (t t)))
			     (cond ((and (getf PASTPART)
					 (getr BE))
				    (hold `OBJ (getr DP))
				    (setrq DP 
					 (DP (DBAR (HEAD SOMEONE))))
				    (liftr DP (getr DP))
				    (setrq MOOD PASSIVE)
				    (liftr MOOD (getr MOOD))
				    (addl INFL (buildq (MOOD \#) (getr MOOD))))
				   (t t))
			     (Auxagree lex (getr AUXS))
			     (cond ((getr MOOD) t)
				   ((getr BE) (addr INFL (getr BE)))
				   (t t))
			      (cond ((getr V1)
				     (compcheck))
				    (t t))
			      (setr V *)
			     (liftr INFL (getr INFL))
			     (liftr V (getr V))
			     (cond ((nullr FIRST-V) (setr FIRST-V lex)) (t t))
			     (to VBAR/))
			`(JUMP VBAR/HEAD (getr V)
			       (cond ((equal (getr TYPE) `WH-Q)
				      (getr DP))
				     (t t))))

		VBAR/HEAD (`(PUSH DP/ (and (getf TW (getr V))
					   (getf WH))
				  (hold `DP (buildq (@ (IDISC) (*))))
				  (setr IDISC t)
				  (to VBAR/HEAD))
			    `(PUSH ADVP/ (or (getf TW (getr V))
					     (getf DNW (getr V))
					     (getf DPRW (getr V)))
				   (hold `ADVP (buildq (@ (IDISC) (*))))
				   (setr IDISC t)
				   (to VBAR/HEAD))
			    `(PUSH DEGP/ (and (apstart) 
					   (getf LA (getr V)))
				  (sendr SELECT `AP)
				  (sendr V (getr V))
				  (setr COMP (buildq (SUBJECT_COMPLEMENT *)))
				  (to VBAR/COMP))
			    `(PUSH DP/ (and (dpstart)
					    (getf LN (getr V)))
				   (setr COMP (buildq (SUBJECT_COMPLEMENT *)))
				   (to VBAR/COMP))
			    `(PUSH DP/ (and (dpstart)
					    (or (getf TN (getr V))
						(getf TNPR (getr V))
						(getf TNP (getr V))
						(getf CNT (getr V))
						(getf CNI (getr V))
						(getf CNG (getr V))
						(getf DNN (getr V))
						(getf DNPR (getr V))
						(getf DNF (getr V))
						(getf DNW (getr V))
						(getf DNT (getr V))))
				   (setr OBJ (buildq (OBJ *)))
				   (setr OBJ1 *)
				   (setr COMP (getr OBJ))
				   (to VBAR/OBJ))
			    `(VIR DP (and (nullr COMP)
					  (equal (getr TYPE) `WH-Q))
				  (setr OBJ (buildq (OBJ *)))
				  (setr OBJ1 *)
				  (setr COMP (getr OBJ))
				  (to VBAR/COMP))
			    `(VIR NBAR (and (nullr COMP)
					    (equal (getr TYPE) `REL-CLAUSE))
				  (setr OBJ (buildq (OBJ *))) 
				  (setr OBJ1 *)
				  (setr COMP (getr OBJ))
				  (to VBAR/COMP))
			    `(VIR OBJ (and (nullr COMP)
					   (equal (getr MOOD) `PASSIVE))
				  (setr OBJ (buildq (OBJ *)))
				  (setr OBJ1 *)
				  (setr COMP (getr OBJ))
				  (to VBAR/OBJ))
			    `(PUSH PP/ (and (ppstart)
					    (or (getf DPRF (getr V))
						(getf DPRW (getr V))
						(getf DPRT (getr V))))
				  (setr IOBJ (buildq (IOBJ *)))
				  (setr COMP (getr IOBJ))
				  (to VBAR/OBJ))
			    `(PUSH CP/ (or (and (equal lex `that) 
						(getf TF (getr V))
						(nullr OBJ))
					   (and (getr IDISC)
						(or (getf TW (getr V))
						    (getf DNW (getr V))
						    (getf DPRW (getr V)))))
				   (cond ((equal (getr TYPE2) `DCL)
					  (setr OBJ (buildq (OBJ *))))
					 ((abort)))
				   (setr COMP (getr OBJ))
				   (to VBAR/OBJ))
			    `(PUSH EC/ (or (getf TT (getr V))
					   (getf TNT (getr V)))
				   (sendr V (getr V))
				   (setr OBJ (buildq (OBJ *)))
				   (setr COMP (getr OBJ))
				  (to VBAR/OBJ))
			    `(PUSH SC/ (or (getf TG (getr V))
					   (getf TNG (getr V))
					   (getf TNI (getr V))
					   (getf CNN (getr V))
					   (getf CNA (getr V)))
				   (sendr V (getr V))
				   (setr OBJ (buildq (OBJ *)))
				   (setr COMP (getr OBJ))
				   (to VBAR/OBJ))
			    `(JUMP VBAR/COMP (intransitive))) 

		VBAR/OBJ (`(PUSH DP/ (and (or (getf DNW (getr V)) 
					      (getf DPRW (getr V)))
					  (getf WH))
				 (hold `DP (buildq (@ (IDISC) (*))))
				 (setr IDISC t)
				 (to VBAR/OBJ))
			   `(PUSH ADVP/ (and (or (getf TW (getr V))
						 (getf DNW (getr V))
						 (getf DPRW (getr V)))
					     (getf WH))
				  (hold `ADVP (buildq (@ (IDISC) (*))))
				  (setr IDISC t)
				  (to VBAR/HEAD))
			   `(PUSH SC/ (or 
					 (getf CNG (getr V))
					 (getf CNI (getr V)))
				 (sendr OBJ (getr OBJ))
				 (sendr V (getr V))
				 (setr OBJ-COMP (buildq (OBJ_COMP *)))
				 (addr COMP (getr OBJ-COMP))
				 (to VBAR/COMP))
			   `(PUSH EC/ (getf CNT (getr V))
				  (sendr V (getr V))
				  (setr OBJ-COMP (buildq (OBJ_COMP *)))
				  (addr COMP (getr OBJ-COMP))
				  (to VBAR/COMP))
			   `(PUSH EC/ (or (and (getf DNT (getr V))
					       (nullr IDISC)
					       (getr OBJ))
					  (and (getf DPRT (getr V))
					       (nullr IDISC)
					       (getr IOBJ))
					  (and (getr IDISC)
					       (or (getf DNW (getr V))
						   (getf DNPR (getr V)))))
				  (sendr V (getr V))
				  (cond ((getr IOBJ) t)
					((getr OBJ1)
					 (setr IOBJ (buildq (IOBJ \#)
							    (getr OBJ1)))))
				  (setr OBJ (buildq (OBJ *)))
				  (setr COMP (buildq (@ + (+)) IOBJ OBJ))
				  (to VBAR/COMP))
			   `(PUSH CP/ (or (getf DNF (getr V))
					  (getf DPRF (getr V))
					  (and (getr IDISC)
					       (or (getf DNW (getr V))
						   (getf DPRW (getr V)))))
				  (cond ((getr IOBJ) t)
					((getr OBJ1) 
					 (setr IOBJ (buildq (IOBJ \#) (getr OBJ1)))))
				  (cond ((equal (getr TYPE2) `DCL)
					 (setr OBJ (buildq (OBJ *))))
					((abort)))
				  (setr COMP (buildq (@ + (+)) IOBJ OBJ))
				  (to VBAR/COMP))
			   `(PUSH DP/ (getf DNN (getr V))
				  (setr IOBJ (buildq (IOBJ \#) (getr OBJ1)))
				  (setr OBJ (buildq (OBJ *)))
				  (setr COMP (buildq (@ + (+)) IOBJ OBJ))
				  (to VBAR/COMP))
			   `(PUSH PP/ (and (ppstart)
					   (getf DNPR (getr V)))
				  (setr IOBJ (buildq (IOBJ *)))
				  (setr COMP (buildq (@ \# (+))
						     (getr COMP) IOBJ))
				  (to VBAR/COMP))
			   `(JUMP VBAR/COMP t))

		SC/ (`(PUSH DP/ (or (getf TNG (getr V)) 
				    (and (nullr OBJ)
					 (getf CNN (getr V)))
				    (and (nullr OBJ) 
					 (getf CNA (getr V)))
				    (getf CNI (getr V))
				    (getf CNG (getr V))
				    (getf TNI (getr V)))
			    (setr SC-DP *)
			    (to SC/DP))
		      `(JUMP SC/DP (not (or (getf CNA (getr V)) 
					    (getf CNN (getr V))))
			     (setrq SC-DP (DP (DBAR TRACE)))))

		SC/DP (`(PUSH VP/ (or (getf TG (getr V))
				      (getf TNG (getr V))
				      (getf CNG (getr V)))
			      (sendr AUXS `(be))
			      (setr SC-XP *)
			      (to SC/XP))
			`(PUSH VP/ (or (getf TI (getr V))
				       (getf TNI (getr V))
				       (getf CNI (getr V)))
			       (sendr AUXS `(would))
			       (setr SC-XP *)
			       (to SC/XP))
			`(PUSH VP/ t
			       (sendr AUXS `(have))
			       (setr SC-XP *)
			       (to SC/XP))
			`(PUSH DEGP/ (and (getf CNA (getr V))
					  (getr SC-DP))
			       (sendr SELECT `AP)
			      (setr SC-XP *)
			      (to SC/XP))
			`(PUSH DP/ (and (getf CNN (getr V))
					(getr SC-DP))
			       (setr SC-XP *)
			       (to SC/XP)))

		SC/XP (`(POP (buildq (@ (SMALL_CLAUSE) (+) (+))
				     SC-DP SC-XP) t))


		EC/ (`(PUSH DP/ (getf TNT (getr V))
			    (setr EC-DP *)
			    (to EC/DP))
		      `(JUMP EC/DP t
			     (setrq EC-DP (DP (DBAR PRO)))))

		EC/DP (`(WRD to t
			     (setr EC-INFL *)
			     (to EC/to)))

		EC/to (`(PUSH VP/ t
			      (sendrq AUXS would)
			      (setr EC-VP *)
			      (to EC/VP)))

		EC/VP (`(POP (buildq (@ (EXCEPTIONAL_CLAUSE) (+) ((INFL +)) (+))
				     EC-DP EC-INFL EC-VP) t))




		VBAR/COMP ( `(WRD by (equal (getr MOOD) `PASSIVE)
				  (setr BY t)
				  (to VBAR/COMP))
			     `(PUSH DP/ (and (dpstart) (getr BY)
					     (equal (getr MOOD) `PASSIVE))
				    (cond ((agree (getr NU) 
						  (getf PNCODE (getr FIRST-V)))
					   (setr INFL (buildq ((AGR \#)) 
							      (car (agree (getr NU)
									  (getf PNCODE (getr FIRST-V))))))) 
					  ((abort))) 
				    (setr DP *) 
				    (liftr DP (getr DP)) 
				    (to VBAR/PASSIVE)) 
			     `(VIR NBAR (and (equal (getr TYPE) `REL-CLAUSE) 
					     (getr BY)
					     (equal (getr MOOD) `PASSIVE))
				   (setr NU (getnu (getr NBAR))) 
				   (setr DP *)
				   (liftr DP (getr DP))
				   (to VBAR/PASSIVE))
			     `(JUMP VBAR/PASSIVE t))
		VBAR/PASSIVE ( `(POP (cond ((nullr COMP)
					 (buildq (@ (VBAR) ((HEAD +))) V))
				       ((buildq (@ (VBAR) ((HEAD +)) ((COMP +))) V COMP))) 
				  (cond ((getr IOBJ) (getr OBJ))
					(t t))))

		  ))


; Grammar TESTS

; These tests are based on collocation information.  They are done
; at particular places in the grammar where ungrammatical collocations
; can be detected.  They allow the sentence to be judged ungrammatical as
; soon as possible.  These tests return false only if the words
; tests definitely cannot occur together.

; Included here is another type of test: agreement tests.  These check
; the number of the sentence to be certain it is constant or deviates 
; only in places where it is allowed to.  For instance the subject-verb
; agreement test is one of these.


(defun predetcheck ()
  ; This function checks to see that the pre-determiner already parsed 
  ; can co-occur with the central determiner. 

  (cond ((member (getr PRE-DET) `(all both half))
	 (or (getf ART (getr DET))
	     (getf POSS (getr DET))
	     (getf DEM (getr DET))
	     (nullr DET)))
	(t t)))
	

(defun centdetcheck ()
  ; This function checks to see if the central determiner can co-occur
  ; with the quantifier.

  (cond ((or (equal (getr DET) `a)
	     (equal (getr DET) `an))
	 (not (equal (getr QUANT) `one)))
	(t t)))

(defun quantcheck ()
  ; This function checks to see if the quantifier can co-occur with
  ; the head of the noun.
  (or (cond ((equal (getr QUANT) `one)
	     (and (getf COUNT (getr N))
		  (my-member (getf NUMBER (getr N)) (SG)))))
      (cond ((getf NUMBER (getr QUANT))
	     (equal (getf NUMBER (getr QUANT)) (getr NU)))
	    (t t))))

(defun predetnouncheck ()
  ; This function checks the pre-det and the head noun for co-occurance.
  (cond ((getf NUMBER (getr PRE-DET))
	 (or (equal (getf NUMBER (getr PRE-DET)) (getr NU))
	     (getf MASS (getr N))))
	(t t)))

(defun detagree ()
  ; This function checks for agreement between the determiner and the noun.
  ; This is based on the types of nouns that the determiners can occur with.
  ; It assumes that the determiner is stored in a register called DET and
  ; the noun is stored in a register called N.
  (setq det (franz-get (getr DET) `TAKES))
  (setq nu (getf NUMBER (getr N)))
  (and
   (cond ((and (getf COUNT (getr N)) (not (getf MASS (getr N)))
	       (my-member nu  (SG)))
	  (or (and (member `SGCT det) t) (equal (getr QUANT) `one)))
	 (t t))
   (cond ((and (getf COUNT (getr N))
	       (my-member nu (PL)))
	  (or (and (member `PLCT det) t) (null det)))
	 (t t))
   (cond ((getf MASS (getr N))
	  (or (and (member `NONCT det) t) 
	      (or (null det) (getf COUNT (getr N)))))
	 (t t))
   (cond ((getf PROPER (getr N)) (or (null det)
				     (and (member `NONCT det) t)))
	 (t t))
   (cond ((and (listp (getf CATEGORY (getr N)))
	       (member `PRO (getf CATEGORY (getr N))))
	  (null det))
	 (t t))))

(defun checkzone (newadj prevadj)
  ;checkzone checks to see if the new adjective occurs in any of the zones
  ;following the previous adjective.  This ensures "proper" adjective order.

  (cond ((null prevadj) nil)
	((eval (cons `or 
		     (mapcar 
		      (function (lambda (x) (or (> x (car prevadj))
						(= x (car prevadj)))))
		      newadj))))
	((checkzone newadj (cdr prevadj)))))

(defun resetzone (newadj prevadj)
  ;resets the ZONE register to be ready for the next adjective.
  (cond ((and (> (length newadj) 1)
	      (equal (length prevadj) 1))
	 (setr ZONE (maxzones newadj (car prevadj))))
	((setr ZONE newadj))))

(defun maxzones (newadj prevadj)
  ; creates a list of all the zones greater than that of prevadj.
  (cond ((null newadj) nil)
	((or (< prevadj (car newadj)) 
	     (equal prevadj (car newadj)))
	    (cons (car newadj) (maxzones (cdr newadj) prevadj)))
	((maxzones (cdr newadj) prevadj))))

(defun npstart () 
  ; npstart returns true if the next word begins a nounbar.
  (checkstart (dogetf `CATEGORY lex) `(N ADJ PRO)))

(defun mpstart ()
  ;mpstart returns true if the next word begins a mensural phrase.
  (or (getf ART) (getf CARDINAL) (getf MENSURAL)))

(defun advpstart ()
  ;advpstart returns true if the next word begins a adverb phrase.
  (and (checkstart (dogetf `CATEGORY lex) `(ADV))
       (not (getf DEG))))

(defun qpstart ()
  ;qpstart returns true if the next word begins a quantifier phrase.
  (getf QUANT))

(defun dpstart ()
  ; function checks the category, cat, of the current word to see if it 
  ; can begin a determiner phrase.
  (checkstart (dogetf `CATEGORY lex) `(DET ADJ N PRO)))
 
(defun apstart ()
  ;adjstart returns true if the next word begins a adjective phrase.
  (cond ((checkstart (dogetf `CATEGORY lex) `(ADJ)) t)
	((or (mpstart) (advpstart) (qpstart)))))
 
(defun ppstart ()
  ; ppstart returns true if the next word begins a prepostional phrase.
  (cond ((not (endofsentence)) (catcheck lex `PREP))
	(t                     nil)))  
 
(defun vpstart ()
  ;vpstart returns true if the next word begins a verb phrase.
  (checkstart (dogetf `CATEGORY lex) `(V ADV)))
 
(defun checkstart (wordcat phrasestarters)
  ;checks to see if there is an element of wordcat that is in the list of
  ;categories that could start the phrase.
  (cond ((not (holdempty holdlist)) t)
	((cond ((atom wordcat) (member wordcat phrasestarters))
	((cond ((null wordcat) nil)
	       ((member (car wordcat) phrasestarters))
	       ((checkstart (cdr wordcat) phrasestarters))))))))

(defun catcheck (word cat)
  ; catcheck checks to see if word is the category cat.
  (equal (get word `CATEGORY) cat))
 
(defun agree (subj vb)
  ; agree returns true if the subject agrees with the pncode, vbnu, of the verb.
  (cond ((listp subj) 
	 (setq subjnu (eval subj)))
	((setq subjnu subj)))
  (setq vbnu (eval vb))
  (cond ((null subjnu) nil) 
	((listp subjnu) (or (member (car subjnu) vbnu) 
			    (agree (list `quote (cdr subjnu)) (list `quote vbnu))) )
	((member subjnu vbnu))))

(defun predadjcheck ()
  (cond ((getf PRED lex)
	 (and (not (nullr V))
	      (linkingverb)))
	(t t)))

(defun linkingverb ()
  ; checks the verb pattern codes on the verb to see if it is a linking verb.
  ; Linking Verbs are followed by a complement that gives more information
  ; about the subject of the sentence.
  (let ((verb (getr V)))
       (or (getf LA verb)
	   (getf LN verb))))

(defun intransitive ()
  ; checks the verb pattern codes to see if the verb is intransitive.
  ; Intransitive verbs are not followed by either a complement or an
  ; object although they may be followed by an adjunct telling time, place,
  ; manner, etc. of the action of the verb.
  (let ((verb (getr V)))
       (or (getf I verb)
	   (getf IPR verb)
	   (getf IP verb)
	   (getf INPR verb)
	   (getf IT verb))))

(defun complex-transitive ()
  ;checks the verb pattern codes to see if the verb is complex-transitive.
  ;Complex transitive verbs are followed by a direct object and a complement 
  ;that gives more information about the direct object.
  (let ((verb (getr V)))
       (or (getf CNA verb)
	   (getf CNN verb)
	   (getf CNN/A verb)
	   (getf CNT verb)
	   (getf CNG verb)
	   (getf CNI verb))))


(defun dpobject ()
  ; checks the verb pattern codes on the verb to see if it could possibly have a
  ; dp as object.
  (let ((verb (getr V)))
       (or (getf TN verb)
	   (getf TNPR verb)
	   (getf TNP verb)
	   (getf TNT verb)
	   (getf TNG verb)
	   (getf TNI verb)
	   (getf CNA verb)
	   (getf CNN verb)
	   (getf CNN/A verb)
	   (getf CNT verb)
	   (getf CNG verb)
	   (getf CNI verb))))

(defun dpiobject ()
  ;checks the verb pattern codes on the verb to see if it could
  ;possibly have a dp as its indirect object.
  (let ((verb (getr V)))
       (or (getf DNN verb)
	   (getf DNF verb)
	   (getf DNW verb)
	   (getf DNT verb))))

(defun nondpiobject ()
  ; checks the verb pattern codes on the verb to see if it could
  ; possibly have a non-dp indirect object.
  (let ((verb (getr V)))
       (or (getf DPRF verb)
	   (getf DPRW verb)
	   (getf DPRT verb))))

(defun nondpobject ()
  ; checks the verb pattern codes on the verb if it has an object that is 
  ; other than a dp.
  (let ((verb (getr V)))
       (or (getf TF verb)
	   (getf TW verb)
	   (getf TT verb)
	   (getf TG verb)
	   (getf DNT verb)
	   (getf DNF verb)
	   (getf DPRF verb)
	   (getf DPRW verb)
	   (getf DPRT verb))))

(defun advadjunct ()
  ; checks the verb pattern codes on the verb to see if it can
  ; take an adverbial adjunct.
  (let ((verb (getr V)))
       (or (getf IP verb)
	   (getf I verb))))

(defun prepadjunct ()
  ; checks the verb pattern codes on the verb to see if it can
  ; take a prepositional adjunct.
  (let ((verb (getr V)))
       (or (getf IPR verb)
	   (getf INPR verb)
	   (getf TNPR verb))))

(defun my-member (a b)
  (car (mapcar (function (lambda (x) (member x b))) (eval a))))

(defun getnu (subj)
  ; This function strips the number from the subject string.  It is used to set
  ; the NU register during a VIR arc.
  (cond ((null subj) nil)
	((listp (car subj)) (append (getnu (car subj)) (getnu (cdr subj))))
	((equal (car subj) `NU) (cadr subj))
	((getnu (cdr subj)))))

	
(defun compcheck ()
  ; This function checks the complement to be certain that it corresponds with
  ; the verb forms the main verb will allow as complements.
  (let ((verb (getr V1)))
       (or
	(cond ((or (getf TG verb)
		   (getf TNG verb)
		   (getf CNG verb))
	       (getf PRESPART)))
	(cond ((or (getf IT verb)
		   (getf TT verb)
		   (getf TNT verb)
		   (getf CNT verb)
		   (getf DNT verb)
		   (getf DPRT verb)
		   (getf TNI verb)
		   (getf CNI verb)
		   (getf TW verb)
		   (getf DNW verb)
		   (getf DPRW verb))
	       (getf UNTENSED))))))


(defun Auxagree (curr-aux prev-aux)
	(declare (special curr-aux prev-aux))
  (cond ((equal prev-aux nil)
	 (and
	  (cond ((equal curr-aux `been) nil)
		(t t))
	  (cond ((nullr NU) t)
	       ((agree (getr NU) (getf PNCODE (getr FIRST-V)))
		(setr INFL (buildq ((AGR \#)) (car (agree (getr NU)
							  (getf PNCODE 
								(getr FIRST-V))))))))))
	(t 
	      (setq prev-aux (car (last prev-aux)))
	    (cond ((and (listp (getf CATEGORY prev-aux))
			(member `MODAL (getf CATEGORY prev-aux))
		   (getf UNTENSED curr-aux)))
		  ((equal (getf CATGORY prev-aux) `MODAL)
		   (getf UNTENSED curr-aux))
		  ((equal (getf ROOT prev-aux) `do)
		   (getf UNTENSED curr-aux))

     	          ((equal (getf ROOT prev-aux) `have)
	           (getf PASTPART curr-aux))

	          ((equal (getf ROOT prev-aux) `be)
		   (or (getf PRESPART curr-aux)
		       (and (getf PASTPART curr-aux)
			    (equal (getr MOOD) `PASSIVE))))
		  (t (abort))))))

3 EXAMPLE LEXICON
; WORD CATEGORIES

; All words should be classified with the category that is the most
; common analysis for that word (i.e. as appears in most grammatically
; intelligent dictionaries).  The ideal source for these categorizations
; is either the tag set of LOB corpus of British English or the 
; Oxford Advanced Learner's Dictionary (A.P. Cowie, Ed.)
; (refered to as OALD from here on).  The tag set of the Brown Corpus 
; can be used in a pinch.

; MULTIPLE CATEGORIES

; Words must be given all the categories and syntactic features in a
; single entry for this dictionary.  This means that if a word can be
; more than one category, both must be listed as arguments to the
; property "CATEGORY". For example, the word "garden" can be both a 
; noun and a verb.  It's property list should therefore include the
; assignment "CATEGORY (N V)".  Note the categories must be in a list.
; On the other hand, the word "the" can only be a DET and so it's
; property list includes the assignment "CATEGORY DET".

; Note that the entry for a word like "garden" would have to
; include not only the features for it's noun sense (i.e. MASS or
; COUNT - cf. NOUN section) but also the features for it's verb
; sense (i.e. TNS, USAGE CODE, etc.).

; NUMBER
;
; Nouns

; Number is assigned to words according to their usage and inherent
; qualities.  The ideal source for this is the OALD.  
; Agreement is based on a binary number system (Singular and plural) 
; and a ternary Person system  (First, Second, Third).
; Although english does not overtly inflect nouns according to this
; system, there are some places that the system does manifest itself-
; like with the personal pronouns.  Possible combinations of person and
; number are 1SG, 2SG, 3SG, 1PL, 2PL, 3PL.
; Note that nouns will ordinarily be either 3SG or 3PL and that the
; other codes are likely to be used only for pronouns.  

; In order to simplify the classification the codes used for
; assigning number will be the macros SG, PL, and SG/PL.
; These are defined below and will expand into the appropriate
; Person and number code to be used for verbal agreements.
; In the case of Pronouns when the exact codes are needed, the
; tense must be added to the codes given above so that they can be
; checked with the verb for agreement.  For example the
; the pronoun "I" should have the following entry:
; NUMBER (1SGPRES 1SGPAST)
;
; Verbs

; Guidelines similar to those used for nouns are used for the coding
; of Verbs.  The number property for verbs is called "PNCODE", meaning
; Person-Number Code.  Agreement in verbs is based on three things-
; Person, Number, and Tense.  This is evident with verbs like "hit"
; which can be used with any person and number in the past tense
; but in the present tense it is illegal with the 3SG number code.
; For this reason the number codes for verbs add a variable to those
; of nouns.  The possible PNCODES are as follows:
; 1SGPRES, 2SGPRES, 3SGPRES, 1PLPRES, 2PLPRES, 3PLPRES
; 1SGPAST, 2SGPAST, 3SGPAST, 1PLPAST, 2PLPAST, 3PLPAST
; NONE
; Verbs may be given any combination of these codes, such as for 
; the verb "hit": 
; PNCODE `(1SGPRES 2SGPRES 1PLPRES 2PLPRES 3PLPRES 1SGPAST 2SGPAST
;		  3SGPAST 1SGPAST 2SGPAST 3SGPAST NONE)

; Note that the PNCODE "NONE" is for use with uninflected, infinitival
; forms of the verb.  These include the infinitive, past participial 
; and present participial (or gerund) forms.

; Note that not all +N words are required to have NUMBER assignments,
; although all verbs and nouns must.  Typically determiners, adverbs, 
; prepositions, and adjectives do not unless they are inherent in 
; the meaning of the word (i.e. "all" must be PL and "one" must be
; SG but "such" need not be either).

; The following are some shortcuts for use with coding noun and
; verb number:

; For NOUNS:

(defmacro SG ()
  (list `quote `(3SGPRES 3SGPAST)))

(defmacro PL ()
  (list `quote `(3PLPRES 3PLPAST)))

(defmacro SG/PL ()
  (list `quote (ANY)))

; For VERBS:

(defmacro PRES ()
  (list `quote `(1SGPRES 2SGPRES 3SGPRES 1PLPRES 2PLPRES 3PLPRES)))

(defmacro PAST ()
  ; defines the PNCODEs for PAST tense verbs. Also included is the
  ; uninflected PNCODE because the participal forms are usually
  ; made by adding -ed to the root of the word.  This may not be appropriate
  ; for strong verbs.
  (list `quote `(1SGPAST 2SGPAST 3SGPAST 1PLPAST 2PLPAST 3PLPAST NONE)))

(defmacro X3SG ()
  ; defines the PNCODEs for present tense verbs that are only
  ; inflected for 3rd person singular.  ALso included is the 
  ; code for uninflected verbs since that is usually the same
  ; as the X3SG form.
  (list `quote `(1SGPRES 2SGPRES 1PLPRES 2PLPRES 3PLPRES NONE)))

(defmacro 3SG ()
  (list `quote `(3SGPRES)))

(defmacro NONE ()
  (list `quote `(NONE)))

(defmacro ANY ()
  (list `quote `(1SGPRES 2SGPRES 3SGPRES 1PLPRES 2PLPRES 3PLPRES
		    1SGPAST 2SGPAST 3SGPAST 1PLPAST 2PLPAST 3PLPAST NONE)))



;DETERMINERS

;PRE-DETERMINERS

; Predeterminers are determiners that occur before central
; determiners.  There can only be one predeterminer
; preceding any noun head.  There are three basic classes:
; A. Specific words: all, both, half, such
;   These coincide with the LOB tags ABL, ABN, and ABX.
; B. Multipliers: twice, thrice, once.  
;   Also included here are phrases like "three times".
; C. Fractions: one-third, etc.

;Tests: 
; If the word can exist in the environment
; "Y the X"
; then it is a pre determiner and needs to have the toggled feature
; PRE.
; Examples are:
; all the men
; double the money
; twice the amount


(setplist `all `(CATEGORY (PRO DET) PRE-DET t NUMBER (PL)))
(setplist `both `(CATEGORY DET PRE-DET t NUMBER (PL)))
(setplist `half `(CATEGORY N MENSURAL t NUMBER (PL)))
(setplist `such `(CATEGORY DET PRE-DET t))
(setplist `double `(CATEGORY ADJ PRE-DET t ))
(setplist `twice `(CATEGORY ADJ PRE-DET t))
(setplist `one-third `(CATEGORY ADJ PRE-DET t))

;CENTRAL DETERMINERS

; These are called central because of the position they occupy
; in the DP.  They must be given the toggled feature CENTRAL-DET.

; There are five types of central determiners, divided according
; to the type of noun it can occur with.
; A. Determiners of SGCT, PLCT, and NONCT nouns.
; B. Determiners of PLCT and NONCT nouns.  This is also the
; only time that the determiner may be ZERO (or null).
; C. Determiners of SG nouns of all types (ie, SGCT and SGNONCT).
; D. Determiners of PLCT nouns.
; E. Determiners of SGCT nouns.

; EXAMPLES:
; If the word can exist in the environment
; "Y man" or "Y script"
; then it occurs with singular count nouns and has the code SGCT.

; If the word can exist in the environment
; "Y men" or "Y scripts"
; then it occurs with plural count nouns and has the code PLCT.

; If the word can exist in the environment
; "Y fish" or "Y music"
; then it occurs with noncount nouns and has the code NONCT.
; Note that these are typically MASS nouns or nouns that can be
; either singular or plural.

; These codes make up the arguments to the property TAKES.  All that
; apply to a word must be listed as the value to this property, such
; as TAKES (SGCT NONCT).

; In addition there are four different semantic types:
; A. Articles
;    a, an, the
;    These coincide with the LOB tags AT or ATI.
; B. Possesives
;    his, her, their    
;    These coincide with the LOB tags PP$.
; C. Quantifiers
;    every, some
;    These coincide with the LOB tags ATI (only `no).
; D. Demonstratives.
;    this, that
;    These coincide with the LOB tag DT.
; These are included here because there are specific colocational
; tests which can be done with them.
; Their classification must be intuitive unless there are semantic
; guidelines elsewhere in the system.

(setplist `the `(CATEGORY DET CENTRAL-DET t TAKES (SGCT PLCT NONCT) ART t NP t))
(setplist `a `(CATEGORY DET CENTRAL-DET t TAKES (SGCT) ART t NP t))
(setplist `an `(CATEGORY DET CENTRAL-DET t TAKES (SGCT) ART t NP t))

(setplist `my `(CATEGORY DET CENTRAL-DET t TAKES (SGCT PLCT NONCT) POSS t NP t))
(setplist `our `(CATEGORY (DET PRO) CENTRAL-DET t TAKES (SGCT PLCT NONCT) POSS t NP t))
(setplist `your `(CATEGORY (DET PRO) CENTRAL-DET t TAKES (SGCT PLCT NONCT) POSS t NP t))
(setplist `his `(CATEGORY (DET PRO) CENTRAL-DET t TAKES (SGCT PLCT NONCT) POSS t NP t))
(setplist `her `(CATEGORY (DET PRO) CENTRAL-DET t TAKES (SGCT PLCT NONCT) POSS t NP t))
(setplist `its `(CATEGORY (DET PRO) CENTRAL-DET t TAKES (SGCT PLCT NONCT) POSS t NP t))
(setplist `their `(CATEGORY (DET PRO) CENTRAL-DET t TAKES (SGCT PLCT NONCT) POSS t NP t))

(setplist `that `(CATEGORY DET CENTRAL-DET t TAKES (SGCT NONCT) DEM t))
(setplist `this `(CATEGORY DET CENTRAL-DET t TAKES (SGCT NONCT) DEM t))
(setplist `these `(CATEGORY DET CENTRAL-DET t TAKES (PLCT) DEM t))
(setplist `those `(CATEGORY DET CENTRAL-DET t TAKES (PLCT) DEM t))

(setplist `every `(CATEGORY DET CENTRAL-DET t TAKES (SGCT) QUANT t NP t))
(setplist `each `(CATEGORY DET CENTRAL-DET t TAKES (SGCT) QUANT t))
(setplist `either `(CATEGORY DET CENTRAL-DET t TAKES (SGCT) QUANT t))
(setplist `neither `(CATEGORY DET CENTRAL-DET t TAKES (SGCT) QUANT t))
(setplist `enough `(CATEGORY DET CENTRAL-DET t TAKES (PLCT NONCT) QUANT t))
(setplist `some `(CATEGORY DET CENTRAL-DET t TAKES (PLCT NONCT) QUANT t))
(setplist `any `(CATEGORY DET CENTRAL-DET t TAKES (PLCT NONCT) QUANT t NP t))

;QUANTIFIERS/CARDINALS (POST-DETERMINERS)

; These are called POST-DETERMINERS because of the position they 
; occupy in the DP.  To occur in this position the word must be given either 
; the QUANT or the CARDINAL feature.

;These include 4 classes:
;A. Cardinal numerals: three, four, etc.
; Note that these are the only words receiving the CARDINAL feature.

;B. Ordinal numerals and "general" ordinals: first, second, last, etc.

;C. Closed-class quantifiers:  few, many, several,etc.

;D. Open class quantifiers: number (of), plenty (of), etc.

; There is some debate over the syntactic categorization of elements 
; in these 4 classes.  For the purposes of this dictionary, they are 
; assumed to be adjectives (with the exception of cardinal numbers 
; which are Nouns). This does not exclude any other syntactic classification, 
; however it does stipulate that the list of categories values include ADJ.

(setplist `many `(CATEGORY ADJ QUANT t NUMBER (PL)))
(setplist `much `(CATEGORY ADJ QUANT t NUMBER (SG)))
(setplist `several `(CATEGORY ADJ QUANT t NUMBER (PL)))
(setplist `few `(CATEGORY ADJ QUANT t NUMBER (PL)))
(setplist `little `(CATEGORY ADJ QUANT t ZONE (2) t))
(setplist `one `(CATEGORY N QUANT t  CARDINAL t TAKES (SGCT) NUMBER (SG)))
(setplist `two `(CATEGORY N CARDINAL t NUMBER (PL)))
(setplist `three `(CATEGORY N CARDINAL t NUMBER (PL)))
(setplist `first `(CATEGORY ADJ QUANT t NUMBER (SG)))
(setplist `last `(CATEGORY ADJ QUANT t))

;NOUNS

;There are three categories of nouns:
;A. Proper
;B. Count- refers to people or things that can be counted.
;C. Mass- typically refers to substances, qualities, collections, and
; objects whose individual parts can not be counted or who can not be
; themselves counted individually.

; MASS

; These nouns must be given the toggled feature MASS.

; Mass nouns are NONCT couns and are usually singular.
; The ideal source for these is OALD nouns coded "U" or "sing v". 
; The following list of examples is from Quirk, et al.

(setq MASS-standard `(CATEGORY N MASS t NUMBER (SG)))
(setplist `anger MASS-standard)
(setplist `chaos MASS-standard)
(setplist `courage MASS-standard)
(setplist `equipment MASS-standard)
(setplist `homework MASS-standard)
(setplist `moonlight MASS-standard)
(setplist `photography MASS-standard)
(setplist `research MASS-standard)
(setplist `furniture MASS-standard)
(setplist `scenery MASS-standard)
(setplist `sunshine MASS-standard)
(setplist `behavior MASS-standard)
(setplist `chess MASS-standard)
(setplist `fun MASS-standard)
(setplist `hospitality MASS-standard)
(setplist `music MASS-standard)
(setplist `publicity MASS-standard)
(setplist `resistance MASS-standard)
(setplist `shopping MASS-standard)
(setplist `traffic MASS-standard)
(setplist `cash MASS-standard)
(setplist `conduct MASS-standard)
(setplist `education MASS-standard)
(setplist `harm MASS-standard)
(setplist `leisure MASS-standard)
(setplist `parking MASS-standard)
(setplist `refuse MASS-standard)
(setplist `safety MASS-standard)
(setplist `smoking MASS-standard)
(setplist `violence MASS-standard)
(setplist `money MASS-standard)
(setplist `physics MASS-standard)

; DUAL nouns

; Some words have dual class membership.  They can be either count or
; noncount nouns as in the exchange "Would you like a cake?" "No, I
; don't like cake." These nouns must be given both the MASS and the
; COUNT toggled features.

; These nouns correspond to the OALD codes CGp and pl v.  They nouns 
; are usually singular although OALD may have some SG/PL (i.e.
; they must be at least singular.)
; Examples from Quirk, et al:

(setq DUAL-standard `(CATEGORY N MASS t COUNT t NUMBER (SG)))

(setplist `cake DUAL-standard)
(setplist `paper DUAL-standard)
(setplist `beauty DUAL-standard)
(setplist `difficulty DUAL-standard)
(setplist `experience DUAL-standard)
(setplist `light DUAL-standard)
(setplist `sound DUAL-standard)
(setplist `talk DUAL-standard)
(setplist `lamb DUAL-standard)
(setplist `time DUAL-standard)
(setplist `hair `(CATEGORY N MASS t COUNT t NUMBER (SG/PL)))

; COUNT

; These nouns must be given the toggled feature COUNT.
; These are the nouns that typically have two forms for singular and
; plural and so must be given the appropriate number. They correspond
; to the OALD code C. Some of these nouns can be both, however, and 
; so must be given the SG/PL number code (these are the nouns with 
; the OALD code "sing or pl v".

(setq SGCT-standard `(CATEGORY N COUNT t NUMBER (SG)))
(setq PLCT-standard `(CATEGORY N COUNT t NUMBER (PL)))
(setplist `man SGCT-standard)
(setplist `men PLCT-standard)
(setplist `forest SGCT-standard) 
(setplist `hall SGCT-standard)
(setplist `mountain SGCT-standard)
(setplist `king SGCT-standard)
(setplist `girl SGCT-standard)
(setplist `bus SGCT-standard)
(setplist `country SGCT-standard)
(setplist `countries PLCT-standard)
(setplist `boy SGCT-standard)
(setplist `scout SGCT-standard)
(setplist `woman SGCT-standard)
(setplist `women PLCT-standard)
(setplist `street SGCT-standard)
(setplist `mayor SGCT-standard)
(setplist `position SGCT-standard)
(setplist `dog-catcher SGCT-standard)
(setplist `thief SGCT-standard)
(setplist `engine SGCT-standard)
(setplist `grandma SGCT-standard)
(setplist `week `(CATEGORY N COUNT t NUMBER (SG) MENSURAL t))
(setplist `weeks `(CATEGORY N COUNT t NUMBER (PL) MENSURAL t))

;PROPER

; These nouns must be given the toggled feature PROPER.
; They coincide with the OALD code Gp in most cases.
; Often they are SG/PL although this is particular to the noun.

(setq SGP-standard `(CATEGORY N PROPER t NUMBER (SG)))
(setq PLP-standard `(CATEGORY N PROPER t NUMBER (PL)))
(setplist `Colorado SGP-standard)
(setplist `Mars SGP-standard)
(setplist `Whitehall `(CATEGORY N PROPER t NUMBER (SG/PL)))
(setplist `Kremlin `(CATEGORY N PROPER t NUMBER (SG/PL)))

;PRONOUNS

; The personal pronouns are classed just like PROPER nouns (as if they were
; a person's name) except their category is PRO instead of N.

(setplist `I `(CATEGORY PRO PROPER t NUMBER `(1SGPRES 1SGPAST)))
(setplist `you `(CATEGORY PRO PROPER t NUMBER `(2SGPRES 2PLPRES 2SGPAST 2PLPAST)))
(setplist `he `(CATEGORY PRO PROPER t NUMBER (SG)))
(setplist `she `(CATEGORY PRO PROPER t NUMBER (SG)))
(setplist `it `(CATEGORY PRO PROPER t NUMBER (SG)))
(setplist `we `(CATEGORY PRO PROPER t NUMBER `(1PLPRES 1PLPAST)))
(setplist `they `(CATEGORY PRO PROPER t NUMBER (PL)))
(setplist `him `(CATEGORY PRO PROPER t NUMBER (SG)))
(setplist `her `(CATEGORY PRO PROPER t NUMBER (SG)))
(setplist `them `(CATEGORY PRO PROPER t NUMBER (PL)))

; Note that there is currently no distinction of case on these pronouns.



;PREPOSITIONS

(setq PREP-standard `(CATEGORY PREP))
(setplist `from PREP-standard)
(setplist `of PREP-standard)
(setplist `on PREP-standard)
(setplist `in PREP-standard)
(setplist `by PREP-standard)
(setplist `to PREP-standard)
(setplist `for PREP-standard)
(setplist `with PREP-standard)
(setplist `at PREP-standard)
(setplist `about PREP-standard)

;ADVERBS

(setq ADV-standard `(CATEGORY ADV))
(setplist `immediately ADV-standard)
(setplist `easily ADV-standard)
(setplist `soon ADV-standard)
(setplist `also ADV-standard)
(setplist `well ADV-standard)
(setplist `away ADV-standard)

(setq DEG-standard `(CATEGORY ADV DEG t))
(setplist `how DEG-standard)
(setplist `as DEG-standard)
(setplist `this DEG-standard)
(setplist `that DEG-standard)
(setplist `so DEG-standard)
(setplist `too DEG-standard)
(setplist `more DEG-standard)
(setplist `less DEG-standard)
(setplist `most DEG-standard)
(setplist `least DEG-standard)

;CONJUNCTIONS
(setq CONJ-standard `(CATEGORY CONJ))
(setplist `that CONJ-standard)

;ADJECTIVES

; Zone 1 

; There are three semantic classifications that are included here:
; A. emphasizers- certain, definite, sheer, pure, etc.
; B. amplifiers- absolute, entire, extreme, perfect, total, etc.
; C. downtoners- feeble, slight, etc.

(setplist `sheer `(CATEGORY ADJ ZONE (1)))
(setplist `complete `(CATEGORY ADJ ZONE (1)))
(setplist `slight `(CATEGORY ADJ ZONE (1)))
(setplist `certain `(CATEGORY ADJ ZONE (1)))
(setplist `very `(CATEGORY ADJ ZONE (1)))

; Zone 2

; These are the "most adjectival items".  This is determined by four
; ways the adjective can function:
; 1. as attributive
; 2. as predicative
; 3. can take comparative or superlative forms (including most and more forms) 
; 4. can be preceded by "very"

; TESTS:
; Must satisfy all these criteria:
; 1. the Y man or Y noun(SG/PL).
; 2. John is Y or NOUN is Y.
; 3. "more Y" or "Yer".
; 4. very Y.

; Adjectives that only satisfy a few of these criteria (i.e. predicative
; only adjectives) should be classified as Zone 4 (see below). Note that the 
;predicative adjectives correspond to the OALD pred adjectives and must be
;given the toggled feature PRED.
; Zone 2 adjectives (although not all of them) correspond to the OALD
; code "attrib".

(setplist `hungry `(CATEGORY ADJ ZONE (2)))
(setplist `stupid `(CATEGORY ADJ ZONE (2)))
(setplist `rich `(CATEGORY ADJ ZONE (2)))
(setplist `funny `(CATEGORY ADJ ZONE (2)))
(setplist `long `(CATEGORY ADJ ZONE (2)))
(setplist `guilty `(CATEGORY ADJ ZONE (2)))
(setplist `ablaze `(CATEGORY ADJ ZONE (2) PRED t))


; Zone 3 
; These are colour adjectives.

(setplist `green `(CATEGORY ADJ ZONE (3)))
(setplist `greener `(CATEGORY ADJ ZONE (3) DEGREE (COMPARATIVE) ROOT green))
(setplist `white `(CATEGORY ADJ ZONE (3)))
(setplist `sleeping `(CATEGORY (ADJ V) TNS PRESENT PRESPART t ZONE (2) ROOT sleep))

;Prehead
;These are "the least adjectival and most nominal" items.
;There are four semantic classifications included here:
;A. those related to proper nouns- American, Gothic, etc.
;B. those related to nouns- usually meaning "consisting of", "involving", 
; or "relating to"- annual, economic, medical, social, political, rural
;C. nouns: tourist, college, etc. (thoses used in noun noun modification).
;D. participial adjectives- sleeping, eating, etc.

(setplist `American `(CATEGORY ADJ ZONE (4)))
(setplist `Gothic `(CATEGORY ADJ ZONE (4)))
(setplist `political `(CATEGORY ADJ ZONE (4)))
(setplist `annual `(CATEGORY ADJ ZONE (4)))
(setplist `economic `(CATEGORY ADJ ZONE (4)))
(setplist `medical `(CATEGORY ADJ ZONE (4)))
(setplist `social `(CATEGORY ADJ ZONE (4)))
(setplist `rural `(CATEGORY ADJ ZONE (4)))

;NEGATIVES

;These are words that give the sentence a negative meaning.  They
; have the feature NEG.  They are primarily adverbs and the grammar
; assumes them to be altho other forms are possible to add.


(setplist `not `(CATEGORY ADV NEG t))

;VERBS

; Verbs must all be given the CATEGORY V and a value for the
; properties PNCODE, and ROOT.

; Toggled features include UNTENSED for infinitive forms, and
; PASTPART and PRESPART for participles.  The complement features 
; are also toggled.

; COMPLEMENTS
; These features are used to classify the verbs according to the
; types of complements they allow.  The basic categories are
; TRANS, INTRANS, and BITRANS.  Other categories are according
; to the OALD verb pattern scheme.

; LA- Linking (copular) verb + Adjective.
; LN- Linking (copular) verb + Noun.
; I- Intransitive verb.
; IPR- Intransitive verb + PRepositional phrase.
; IP- Intransitive verb + Particle.
; IN/PR- Intransitive verb + Noun or PRepositional phrase.
; IT- Intransitive verb + To infinitive.
; TN- Transitive verb + Noun.
; TNPR- Transitive verb + Noun + PRepositional phrase.
; TNP- Transitive verb + Noun + Particle.
; TF- Transitive verb + Finite "that" clause.
; TW- Transitive verb + Wh-clause.
; TT- Transitive verb + To-infinitive.
; TNT- Transitive verb + Noun + To-infinitive.
; TG- Transitive verb + -inG form of the verb.
; TSG- Transitive verb + noun (+ `S) + inG form of the verb.
; TNG- Transitive verb + Noun + inG form of the verb.
; TNI- Transitive verb + Noun + Infinitive.
; CNA- Complex transitive verb + Noun + Adjective.
; CNN- Complex transitive verb + Noun + Noun.
; CNN/A- Complex transitive verb + Noun + as + Noun or Adjective.
; CNT- Complex transitive verb + Noun + To-infinitive.
; CNG- Complex transitive verb + Noun + inG form of the verb.
; CNI- Complex transitive verb + Noun + Infinitive.
; DNN- Double transitive verb + Noun + Noun.
; DNPR- Double transitive verb + Noun + PRepositional phrase.
; DNF- Double transitive verb + Noun + Finite "that" clause.
; DPRF- Double transitive verb + PRepositional phrase + Finite "that" clause.
; DNW- Double transitive verb + Noun + Wh-clause.
; DPRW- Double transitive verb + PRepositional phrase + Wh-clause.
; DNT- Double transitive verb + Noun + To-infinitive.
; DPRT- Double transitive verb + PRepositional phrase + To-infinitive.

(setplist `is `(CATEGORY V  PNCODE (3SG) ROOT be  LA t LN t IPR t IP t))
(setplist `are `(CATEGORY V  PNCODE `(2SGPRES 1PLPRES 2PLPRES 3PLPRES)  ROOT be LA t LN t IPR t IP t))
(setplist `became `(CATEGORY V  PNCODE (PAST) ROOT become  LN t LA t TN t))
(setplist `become `(CATEGORY V  PNCODE (append `(NONE) (PRES)) ROOT become  UNTENSED t PASTPART t LA t LN t TN t))
(setplist `complain `(CATEGORY V PNCODE (X3SG) ROOT complain UNTENSED t IPR t I t TF t DPRF t))
(setplist `complaining `(ROOT complain PNCODE (NONE) PRESPART t IPR t I t TF t DPRF t))
(setplist `chatter `(CATEGORY V PNCODE (X3SG) ROOT chatter  UNTENSED t IP t I t IPR t))
(setplist `chattered `(CATEGORY V PNCODE (PAST) ROOT chatter PASTPART t IP t I t IPR t))
(setplist `chattering `(ROOT complain PNCODE (NONE)  PRESPART t IPR t I t IP t))
(setplist `last `(CATEGORY V  PNCODE (X3SG) ROOT last UNTENSED t INPR t I t))
(setplist `lasted `(CATEGORY V ROOT last PNCODE (PAST) PASTPART t INPR t I t))
(setplist `hesitated `(CATEGORY V  PNCODE (PAST) ROOT hesitate PASTPART t IT t I t IPR t))
(setplist `hesitate `(CATEGORY V  PNCODE (X3SG) ROOT hesitate   UNTENSED t IT t I t IPR t))
(setplist `phone `(CATEGORY V  ROOT phone PNCODE (X3SG) UNTENSED t I t IP t TN t TNP t))
(setplist `open `(CATEGORY V PNCODE (X3SG) ROOT open UNTENSED t TN t I t IP t TNPR t IPR t TNP t))
(setplist `opened `(CATEGORY V  PNCODE (PAST) ROOT open PASTPART t TN t I t IP t TNPR t IPR t TNP t))
(setplist `convince `(CATEGORY V PNCODE (X3SG) ROOT convince UNTENSED t TNPR t TN t DNF t CNT t))
(setplist `convinced `(ROOT convince PNCODE (PAST) TNS PAST  PASTPART t TNPR t TN t DNF t CNT t))
(setplist `shook `(CATEGORY V PNCODE `(1SGPAST 2SGPAST 3SGPAST  1PLPAST 2PLPAST  3PLPAST)  ROOT shake PASTPART t TNP t CNA t TN t I t LA t IPR t))
(setplist `shaken `(CATEGORY V PNCODE (NONE) PASTPART t ROOT shake))
(setplist `shake `(CATEGORY V PNCODE (X3SG) ROOT shake UNTENSED t TNP t CNA t TN t I t LA t IPR t))
(setplist `believe `(CATEGORY V PNCODE (X3SG) ROOT believe  UNTENSED t TF t TN t TW t TNT t I t))
(setplist `decide `(CATEGORY V PNCODE (X3SG) ROOT decide UNTENSED t TF t I t IPR t TN t TNPR t TW t TT t))
(setplist `decided `(CATEGORY V  PNCODE (PAST) ROOT decide  PASTPART t TF t I t IPR t IN t TNPR t TW t TT t))
(setplist `hates `(CATEGORY V PNCODE (3SG) ROOT hate TT t TN t TNT t TG t TSG t))
(setplist `hate `(CATEGORY V  PNCODE (X3SG) ROOT hate UNTENSED t TT t TN t TNT t TG t TSG t))
(setplist `expect `(CATEGORY V PNCODE (X3SG) ROOT expect  UNTENSED t TT t TN t TNPR t TF t TNT t))
(setplist `enjoys `(CATEGORY V PNCODE (3SG) ROOT enjoy TG t TN t))
(setplist `enjoy `(CATEGORY V PNCODE (X3SG) ROOT enjoy UNTENSED t TG t TN t))
(setplist `playing `(CATEGORY V ROOT play PNCODE (NONE) PRESPART t  TG t I t IPR t IP t TN t TNPR t DNN t CNN/A t TNP t DNPR t))
(setplist `play `(CATEGORY V  ROOT play PNCODE (X3SG) UNTENSED t TG t I t IPR t IP t TN t TNPR t DNN t CNN/A t TNP t DNPR t))
(setplist `dread `(CATEGORY V  ROOT dread PNCODE (X3SG) UNTENSED t TSG t TN t TF t TT t TG t))
(setplist `spotted `(CATEGORY V  ROOT spot PNCODE (PAST) PASTPART t TNG t I t TN t TNPR t TW t CNN/A t IPR t))
(setplist `spot `(CATEGORY V  ROOT spot PNCODE (X3SG) UNTENSED t TNG t I t TN t TNPR t TW t CNN/A t IPR t))
(setplist `watched `(CATEGORY V PNCODE (PAST) ROOT watch PASTPART t TNI t I t TN t TW t TNG t IPR t))
(setplist `watch `(CATEGORY V PNCODE (X3SG) ROOT watch UNTENSED t TNI t I t TN t TW t TNG t IPR t))
(setplist `keeps `(CATEGORY V  PNCODE (3SG) ROOT keep CNA t LA t IPR t IP t TNPR t TNP t CNG t DNN t))
(setplist `keep `(CATEGORY V  PNCODE (X3SG) ROOT keep  UNTENSED t CNA t LA t IPR t IP t TNPR t TNP t CNG t DNN t))
(setplist `considered `(CATEGORY V PNCODE (PAST) ROOT consider  PASTPART t CNN t TN t TNPR t TW t TG t CNA t CNT t CNN/A t TF t))
(setplist `consider `(CATEGORY V PNCODE (X3SG) ROOT consider UNTENSED t CNN t TN t TNPR t TW t TG t CNA t CNT t CNN/A t TF t))
(setplist `accept `(CATEGORY V PNCODE (X3SG) ROOT accept  UNTENSED t CNN/A t TN t I t TF t TW t))
(setplist `accepted `(ROOT accept  PNCODE (PAST) CATEGORY V PASTPART t CNN/A t TN t I t TF t TW t))
(setplist `forced `(CATEGORY V  PNCODE (PAST) ROOT force  PASTPART t CNT t TNPR t TNP t TN t CNA t))
(setplist `force `(CATEGORY V PNCODE (X3SG) ROOT force UNTENSED t CNT t TNPR t TNP t TN t CNA t))
(setplist `got `(CATEGORY V PNCODE (PAST) ROOT get PASTPART t CNG t TN t DNN t DNPR t TNPR t LA t CNA t CNT t TG t IT t IPR t IP t TNP t))
(setplist `get `(CATEGORY V  PNCODE (X3SG) ROOT get UNTENSED t CNG t TN t DNN t DNPR t TNPR t LA t CNA t CNT t TG t IT t IPR t IP t TNP t))
(setplist `let `(CATEGORY V  PNCODE (ANY) ROOT let UNTENSED t CNI t TNPR t TNP t TN t))
(setplist `lets `(CATEGORY V PNCODE (3SG) ROOT let  CNI t TNPR t TNP t TN t))
(setplist `taught `(CATEGORY V  PNCODE (PAST) ROOT teach PASTPART t CNN t I t DNT t TN t DNW t DNN t DNPR t TF t DNF t))
(setplist `teach `(CATEGORY V PNCODE (X3SG) ROOT teach  UNTENSED t CNN t I t DNT t TN t DNW t DNN t DNPR t TF t DNF t))
(setplist `told `(CATEGORY V  PNCODE (PAST) ROOT tell  PASTPART t DNF t TN t DNN t DNPR t DNW t DNT t I t TF t TW t TNPR t IPR t))
(setplist `tell `(CATEGORY V PNCODE (X3SG) ROOT tell UNTENSED t DNF t TN t DNN t DNPR t DNW t DNT t I t TF t TW t TNPR t IPR t))
(setplist `announced `(CATEGORY V PNCODE (PAST) ROOT announce PASTPART t DPRF t TN t TF t TW t DNPR t DPRW t))
(setplist `announce `(CATEGORY V  PNCODE (X3SG) ROOT announce UNTENSED t DPRF t TN t TF t TW t DNPR t DPRW t))
(setplist `reminded `(CATEGORY V PNCODE (PAST) ROOT remind  PASTPART t DNW t TN t DNF t DNT t TNPR t))
(setplist `remind `(CATEGORY V PNCODE (X3SG) ROOT remind UNTENSED t DNW t TN t DNF t DNT t TNPR t ))
(setplist `indicate `(CATEGORY V PNCODE (X3SG) ROOT indicate UNTENSED t DPRW t TN t TF t TW t DNPR t DPRF t I t))
(setplist `warned `(CATEGORY V PNCODE (PAST) ROOT warn  PASTPART t DNT t TN t TNPR t DNF t DNW t TNPR t))
(setplist `warn `(CATEGORY V PNCODE (X3SG) ROOT warn  UNTENSED t DNT t TN t TNPR t DNF t DNW t TNPR t))
(setplist `signalled `(CATEGORY V PNCODE (PAST) ROOT signal PASTPART t DPRT t I t IPR t TN t TNPR t TW t TF t DNF t DPRF t DNW t DPRW t DNT t))
(setplist `signal `(CATEGORY V PNCODE (X3SG) ROOT signal UNTENSED t DPRT t I t IPR t TN t TNPR t TW t TF t DNF t DPRF t DNW t DPRW t DNT t))
(setplist `did `(CATEGORY V PNCODE `(1SGPAST 2SGPAST 3SGPAST 1PLPAST 2PLPAST 3PLPAST) ROOT do  PASTPART t I t TN t DNN t DNPR t TG t IPR t))
(setplist `do `(CATEGORY V PNCODE (X3SG) ROOT do  UNTENSED t I t TN t DNN t DNPR t TG t IPR t))
(setplist `hit `(CATEGORY V PNCODE (append (X3SG) (PAST)) ROOT hit UNTENSED t PASTPART t I t TN t DNN t TNPR t))
(setplist `hits `(CATEGORY V  PNCODE (3SG) ROOT hi  I t TN t DNN t TNPR t))
(setplist `hitting `(CATEGORY V ROOT hit PNCODE (NONE) PRESPART t I t TN t DNN t TNPR t))
(setplist `took `(CATEGORY V PNCODE `(1SGPAST 2SGPAST 3SGPAST 1PLPAST  2PLPAST 3PLPAST) ROOT take PASTPART t TN t DNN t TNPR t TNP t CNG t DNPR t CNN t CNT t CNN/A t TG t))
(setplist `take `(CATEGORY V PNCODE (X3SG) ROOT take UNTENSED t TN t DNN t TNPR t TNP t CNG t DNPR t CNN t CNT t CNN/A t TG t))
(setplist `could `(CATEGORY (V MODAL) PNCODE `(1SGPAST 2SGPAST 3SGPAST 1PLPAST 2PLPAST 3PLPAST) ROOT can  PASTPART t TN t))
(setplist `can `(CATEGORY (V MODAL) PNCODE (PRES) ROOT can TN t))
(setplist `would `(CATEGORY (V MODAL) PNCODE `(1SGPAST 2SGPAST 3SGPAST 1PLPAST  2PLPAST 3PLPAST)  ROOT will UNTENSED t I t TN t TNT t TF t DNN t DNPR t))
(setplist `will `(CATEGORY (V MODAL) PNCODE (PRES) ROOT will  I t TN t TNT t TF t DNN t DNPR t))
(setplist `have `(CATEGORY V PNCODE (X3SG)  ROOT have UNTENSED t TN t TNPR t CNA t TNG t TNT t CNN/A t TNP t CNI t CNG t))
(setplist `has `(CATEGORY V PNCODE (3SG)  ROOT have TN t TNPR t CNA t TNG t TNT t CNN/A t TNP t CNI t CNG t))
(setplist `been `(CATEGORY V PNCODE (PAST  PASTPART t ROOT be LA t LN t))
(setplist `be `(CATEGORY V PNCODE (NONE)  ROOT be UNTENSED t LA t LN t I t IPR t))

;+WH words

; These are determiners and pronouns and adverbs which have a +WH
; feature and so they are used to begin WH-Questions.  Some of these
; may also have the feature REL, which allows them to begin relative 
; clauses.

; These words are classed with their category as usual, along with the other
; features that go with those categories (i.e. TAKES , CENTRAL,
; NUMBER.) In addition to these typical properties, 
; they are given the toggled feature WH and/or REL according to
; their usage.

; These correspond with LOB tags WDT, WDTR, WP$, WP$R, WPA, WPO,
; WPOR, WPR, and WRB. Those tags with an "R" indicate that the word may
; also be used to introduce a relative clause and therefore needs both
; the WH and REL features.

(setplist `what `(CATEGORY (PRO DET) CENTRAL-DET t TAKES (SGCT PLCT NONCT) DEM t WH t NUMBER (SG/PL)))
(setplist `which `(CATEGORY (PRO DET) CENTRAL-DET t TAKES (SGCT PLCT NONCT) DEM t WH t REL t NUMBER (SG/PL)))
(setplist `who `(CATEGORY PRO WH t REL t NUMBER (SG/PL)))
(setplist `whose `(CATEGORY PRO WH t REL t NUMBER (SG/PL)))
(setplist `whom `(CATEGORY PRO WH t REL t NUMBER (SG/PL)))
(setplist `that `(CATEGORY PRO REL t NUMBER (SG/PL)))
(setplist `when `(CATEGORY ADV WH t NUMBER (SG/PL)))
(setplist `how `(CATEGORY ADV WH t NUMBER (SG/PL)))
4 DICTIONARY BREAK PACKAGE
; Interactive Lexicon Package for X' Theory Grammar
; Julie A. Van Dyke
; May 30, 1991

; This package provides a mechanism for checking input against the system
; dictionary to see if they are known to the computer.  If words are
; not in the dictionary, this package prompts the user to enter them
; with the appropriate dictionary codes.

; For a complete discription of the dictionary entries this system requires,
; refer to Chapter 4 of the following:

; Van Dyke, J.A.  (1991). Word Prediction for Disabled Users: Applying Natural
;       Language Processing to Enhance Communication.  Honors BA Thesis,
;       University of Delaware

;Lexicon Package Functions:

(defun checkword (words)
; Checks to see if the current word is in the dictionary.
; If it is, then the function returns true and parsing continues.
; If it is not then the parse halts and the user may add the
; word to the dictionary.

   (let ((current-word (car words)))
	(cond ((null words) nil)
	      ((null (get current-word `CATEGORY))
	       (ask-to-add current-word)
	       (checkword (cdr words)))
	      ((checkword (cdr words))))))


(defun ask-to-add (word)
 ; This function asks the user if he or she wishes to add the word 
 ; to the dictionary.

  (terpri)
  (princ "This word was not in the dictionary ")
  (print word)
  (terpri)
  (princ "Do you wish to enter it? Choose (y) or (n)")
  (terpri)
  (setq choice (read))
  (cond ((equal `(n) choice) nil)
	((addword word))))


(defun addword (word)
 ; Actually adds the word to the dictionary.
 ; The function also checks the root of the verb added and if
 ; it is not in the dictionary it is added as well.
  
 (terpri)
 (princ "It will be entered now.")
 (terpri)
 (terpri)
 (setq dict (open "dictionary" :direction :output :if-exists 
		  :append :if-does-not-exist :create)) 
  (let ((word (list word)) 
	(categories (getcats)) 
	(features-with-values (list (getvalfeat))) 
	(toggled-features (list (gettogglefeat))) 
	(root (getroot)))
       (setq new-entry
	     (append `(dw) word categories features-with-values
		     toggled-features root))
       (print new-entry dict)
       (terpri dict)
       (eval new-entry)
       (cond ((not (null root))
	      (checkword root))
	     (t t))
       (close dict)))


(defun getcats ()
 ; Reads in the categories for the word and
 ; returns them as a list set to the variable `categories'.
 (terpri)
 (princ "Enter the categories for this word.")
 (terpri)
 (princ "Possibilities: ")
 (princ "DET PRO PREP ADV N ADJ V CONJ")
 (terpri)
 (terpri)
 (princ "Enter the category in list form (i.e. enter `(N)').  If a word belongs")
 (terpri)
 (princ "to more than one category make this a list also (i.e. `(DET PRO)')")
 (terpri)
 (terpri)
 (setq categories (read))
 (cond ((null categories) (setq categories (list categories)))
       (t (list categories))))


(defun getvalfeat ()
  ; Reads in the valued features for the word
  ; and returns them as a list set to the variable
  ; features with values.
  (terpri)
  (princ "Enter the features for the word that have values.")
  (terpri)
  (princ "Your choices are: ")
  (terpri)
  (and (cond ((member `DET categories)
	      (princ "FOR DET: TAKES NUMBER") (terpri) t)
	     (t t))
       (cond ((member `PRO categories)
	      (princ "FOR PRO: NUMBER") (terpri) t)
	     (t t))
       (cond ((member `N categories)
	      (princ "FOR N: NUMBER") (terpri) t)
	     (t t))
       (cond ((member `ADJ categories)
	      (princ "FOR ADJ: NUMBER ZONE") (terpri) t)
	     (t t))
       (cond ((member `V categories)
	      (princ "FOR V: PNCODE") (terpri) t)
	     (t t)))
  (terpri)
  (princ "Remember that all values for different interpretations of the")
  (terpri)
  (princ "word must be entered in the same dictionary entry.")
  (terpri)
  (princ "Enter these features with their appropriate arguments in list form.")
  (terpri)
  (princ "For example `(TAKES (SGCT) NUMBER (SG))'.")
  (terpri) 
  (terpri)

  (setq features-with-values (read)))


(defun gettogglefeat ()
 ; Reads in the toggled features for the word
 ; and returns them as the variable
 ; toggled-features.
 (terpri)
  (princ "Enter the toggled features for the word.")
 (terpri)
 (princ "Possibilities are:")
 (terpri)
 (and (cond ((member `DET categories)
	     (princ "FOR DET: PRE-DET, CENTRAL-DET, QUANT, ART, REL, WH")
	     (terpri) t)
	     (t t))
      (cond ((member `ADJ categories)
	     (princ "FOR ADJ: QUANT, CENTRAL-DET, PRE-DET, PRED")
	     (terpri) t)
	    (t t))
      (cond ((member `N categories)
	     (princ "FOR N: CARDINAL, MASS, COUNT, PROPER, PRE-DET, MENSURAL")
	     (terpri) t)
	    (t t))
      (cond ((member `PRO categories)
	     (princ "FOR PRO: CENTRAL-DET, PROPER, POSS, DEM, PRE-DET, WH, REL")
	     (terpri) t)
	    (t t))
      (cond ((member `ADV categories)
	     (princ "FOR ADV: DEG, NEG, WH, REL")
	     (terpri) t)
	    (t t))
      (cond ((member `V categories)
	     (princ "FOR V: PRESPART, PASTPART, UNTENSED, LA, LN, I, IT, IPR, IP")
	     (terpri)
	     (princ "INPR, IT, TNP, TF, TNT, TG, TNG, TNI, TN, TNPR, TW, TT, CNT")
	     (terpri)
	     (princ "CNG, CNA, CNN, CNI, DNPR, DNN, DPRW, DNT, DPRF, DNW")
	     (terpri) t)
	    (t t)))
  (terpri)
  (princ "Remember to include all that apply to this word in all of its meanings.")
  (terpri)
  (princ "Enter them in list form like `(ART CENTRAL-DET)'")
  (terpri)
  (terpri)

  (setq toggled-features (read))
  (cond ((null toggled-features) (list toggled-features))
	(t toggled-features)))

(defun getroot ()
; Reads the root of the current word.
 (terpri)
 (princ "Enter the root of the current word.")
 (terpri)
 (princ "Only VERBS require roots, but other inflected words may have them.")
 (terpri)
 (princ "If this word has not root, enter `nil'.")
 (terpri)
 (terpri)
 (setq root (read)))

REFERENCES

Van Dyke, J. A. (1991a). Word Prediction for Disabled Users: Applying
Natural Language Processing to Enhance Communication.  Honors BA
Thesis, University of Delaware.

Van Dyke, J. A. (1991b). A Syntactic Predictor to Enhance
Communication for Disabled Users. Technical Report, Department of
Computer and Information Sciences, University of Delaware.

Van Dyke, J. A. (1991c). Tagging Guide for the X' Theory Grammar.
Technical Report. Center for Applied Science and Engineering,
A. I. DuPont Institute.

Van Dyke, J. A. (1991d). An Annotated Test-Suite for the X' Theory
Grammar. Technical Report. Center for Applied Science and Engineering,
A. I. DuPont Institute.