;;; Modified by Nyurguyana Petrova ;;; Fall 2007 ;;; ;;;:ld /projects/stn2/CVA/defun_noun.cl (^^ defvar *kncat* "life") (^^ defun getkn () *kncat*) (^^ defun setkn (value) (setf *kncat* value)) ;;; First, the SNePS relations used in the GATN are defined. (^^ define agent act action object propername member class lex subclass superclass stime etime before after skfn skarg event results object-1 rel object-2 property into sp-rel location to direction place mode possessor classmod classhead pred beg equiv end |at| |to| word kn_cat) (^^ defvar *SaynBeforeVowels* nil "If true and the next word starts with a vowel, print 'n ' before that next word.") (^^ defvar *NoBlank* nil "If true, SayOneWord shouldn't print a blank before printing the word.") (^^ defconstant *vowels* '(#\a #\e #\i #\o #\u) "A list of the vowels.") (^^ defconstant *mypunct-chars* (remove #\` *punct-chars*) "Don't eliminate the blank before the back-quote.") ;;; The following three functions implement a "phonological" component ;;; that can be used to output words and phrases from arcs of the GATN. ;;; In this way, the beginning of the sentence can be uttered before ;;; the rest of the sentence has been composed. (^^ defvar *SPEAK* nil "Possible values: nil: no speech \"|audioplay\": running on same machine as keyboard/monitor \"|auplay\": running on a remote machine" ) (^^ let ((BUFFER "")) (defun utter (words &key (flush nil) (noprint nil) (voice "WANDA")) (when (eql flush :before) (flush voice) (format sneps:outunit "~&")) (setf BUFFER (concatenate 'string BUFFER (remove #\` (remove #\' words)))) (unless noprint (format sneps:outunit "~A" words)) (when (eql flush :after) (flush voice) (unless noprint (format sneps:outunit "~%")))) (defun flush (voice) (declare (special *SPEAK*)) (when *SPEAK* (excl:shell (concatenate 'string "echo \"" BUFFER "\" | /projects/snwiz/bin/ttseSpeak " voice *SPEAK*))) (setf BUFFER ""))) ;;;(^^ cond ((y-or-n-p "~&Do you want speech? ") ;;; (setf *SPEAK* ;;; (cond ((string\= (system:getenv "DISPLAY") ":0.0") "|audioplay") ;;; (t (y-or-n-p "~&Execute~%ausun -aa &~%on your local machine.~ ;;; Then enter `y'.~%") ;;; (excl:shell ;;; (concatenate 'string ;;; "setenv AUDIOSERVER " ;;; (subseq (system:getenv "DISPLAY") ;;; 0 ;;; (position #\: (system:getenv "DISPLAY"))) ;;; ":0")) ;;; "|auplay"))) ;;; (utter "OK, I will speak." :flush :after)) ;;; (t (setf *SPEAK* nil))) (^^ compile (defun combine-strings (strings) (if (null strings) "" (concatenate 'string (first strings) " " (combine-strings (rest strings)))))) (^^ defvar *SentenceStart* t "True if the next word to be said will be the first word of a sentence") (^^ defun SayOneWord (word) "Prints the single WORD, which must be a string or a node. If the word is 'a', sets *SaynBeforeVowels*. If *SaynBeforeVowels* is set, then prints 'n ' before word/s if the first letter of word/s is a vowel." (check-type word (or string sneps:node)) (when (sneps:node-p word) (setf word (format nil "~A" word))) (when *SaynBeforeVowels* (when (member (char word 0) *vowels* :test #'char=) (format t "n")) (setf *SaynBeforeVowels* nil)) (when (string\= word "a") (setf *SaynBeforeVowels* t)) (format t " ~A" word)) ;;;(^^ compile ;;; (defun say (word/s) ;;; "Prints the single word or the list of words. ;;; If the word is 'a', sets *SaynBeforeVowels*. ;;; If *SaynBeforeVowels* is set, then prints 'n ' before word/s ;;; if the first letter of word/s is a vowel." ;;; (cond ((listp word/s) ;;; #|(speak (apply #'concatenate (cons 'string word/s)))|# ;;; (mapc #'SayOneWord word/s)) ;;; (t #|(speak word/s)|# ;;; (SayOneWord word/s))))) (^^ defun say (word/s) "Prints the single word or the list of words. If the word is 'a', sets *SaynBeforeVowels*. If *SaynBeforeVowels* is set, then prints 'n ' before word/s if the first letter of word/s is a vowel." (if (listp word/s) (mapc #'SayOneWord word/s) (SayOneWord word/s))) (^^ compile (defun possessive-form (noun) "Returns the possessive form of the noun or pronoun." (cond ((member noun '("I" "me") :test #'string\=) "my") ((string\= noun "you") "your") ((member noun '("he" "him") :test #'string\=) "his") ((member noun '("she" "her") :test #'string\=) "her") ((string\= noun "it") "its") ((member noun '("they" "them") :test #'string\=) "their") (t (concatenate 'string noun "'s"))))) (^^ compile (defun sayn (noun) "Prints the single noun or pronoun. Prints the possessive form if the POSS register is True. If *SaynBeforeVowels* is set, then prints 'n ' before the noun if its first letter is a vowel." (when (listp noun) (setf noun (first noun))) (if (getr poss) (SayOneWord (possessive-form (format nil "~A" noun))) (SayOneWord (if (sneps:node-p noun) (or (eval `(getf root ,(format nil "~A" noun))) (format nil "~A" noun)) noun))))) (^^ defvar *lastaddressee* nil "The last agent addressed by Cassie.") (^^ compile (defun addName (node useequivp) "Adds the addressee's name (so it comes out `you, ' the first time that agent is addressed. But doesn't add the name if `you' is possessive." (unless (and *lastaddressee* (sneps:ismemb.ns node (sneps:pathfrom '(kstar (equiv- ! equiv)) *lastaddressee*))) (setf *lastaddressee* node) (unless (getr poss) (let ((name (sneps:choose.ns (if useequivp #!((find (propername- ! object (kstar (compose equiv- ! equiv))) ~node)) #!((find (propername- ! object) ~node)))))) (when name (say `("," ,name)))))))) (^^ compile (defun best-class (classnodes) "Chooses the most specific from the set of nodes representing classes." (let ((bestclass (sneps:choose.ns classnodes))) (sneps:do.ns (classnode (sneps:others.ns classnodes) bestclass) (when #!((deduce subclass ~classnode superclass ~bestclass)) (setf bestclass classnode)))))) (^^ compile (defun remove-equivs (nodeset) "Removes from NODESET any node that is EQUIV to another, so only one node from an EQUIValence set is retained." (cond ((atom nodeset) nodeset) ((null (rest nodeset)) nodeset) (t (remove-duplicates nodeset :test #'(lambda (nde1 nde2) #!((deduce equiv ~nde1 equiv ~nde2)))))))) (^^ compile (defun remove-redundant-classes (nodeset) "Removes from NODESET any member-class1 node for which there is a member-class2 node in the set for which class2 is a subclass of class1. Also removes from NODESET any not(member-class1) node for which there is a not(member-class2) node in the set for which class2 is a superclass of class1." (cond ((atom nodeset) nodeset) ((null (rest nodeset)) nodeset) (t (remove-if #'(lambda (nde1) (find-if #'(lambda (nde2) (or (and #!((find class- ~nde1)) #!((find class- ~nde2)) #!((deduce superclass ~(sneps:nodeset.n nde1 'class) subclass ~(sneps:nodeset.n nde2 'class)))) (and (sneps:is-nor.n nde1) (sneps:is-nor.n nde2) #!((find (class- arg-) ~nde1)) #!((find (class- arg-) ~nde2)) #!((deduce subclass ~(sneps:pathfrom '(arg class) nde1) superclass ~(sneps:pathfrom '(arg class) nde2)))))) nodeset)) nodeset))))) (^^ defun tense-and-aspect (time) (cond (#!((findassert supint ~time subint *NOW)) '(pres prog)) (#!((findassert before ~time after *NOW)) '(past non-prog)) (#!((findassert supint ~time subint (find before- (findassert after *now)))) '(past prog)) ((intersection time (* 'NOW)) '(pres non-prog)) (t '(past non-prog)))) (^^ defun temporally-sort (nodes) (cond ((atom nodes) nodes) ((null (rest nodes)) nodes) (t (sort nodes #'(lambda (n m) (if #!((find time- ~n)) (if #!((find time- ~m)) #!((findassert before (find time- ~n) after (find time- ~m))) nil) t)))))) (^^ defun propositionp (node) "Returns T if NODE represents a proposition; NIL otherwise." (dolist (arc '(act event property equiv member possessor subclass propername subint) nil) (when (parser::internal-geta arc node) (return t)))) ;;; The following functions were all abstracted from the grammar developed by Koontz and deal with anaphora ;;; resolution. ;;; ***new defun from bugbook (^^ defun numberof (node) "Returns 'PLUR if NODE represents a plural entity; 'SING otherwise" (declare (special node)) (check-type node sneps:node) (if (find (or subclass superclass) (^ node)) 'plur 'sing)) ;;; *** lisp functions for resolving anaphora (^^ defvar *focuslist* '()) (^^ defun getinfo (node focuslist) ; node*focuslist->nodelist (if (eql focuslist nil) nil (if (eql node (first (first focuslist))) (first focuslist) (getinfo node (rest focuslist))))) (^^ defun delete-node (node focuslist) ; node*focuslist->focuslist (if (eql focuslist nil) nil (if (eql node (first (first focuslist))) (delete-node node (rest focuslist)) (cons (first focuslist) (delete-node node (rest focuslist)))))) (^^ defun reduce-all (focuslist) ; focuslist->focuslist (if (eql focuslist nil) nil (if (lisp:< (lisp:fourth (first focuslist)) 2) (delete-node (first (first focuslist)) focuslist) (cons (list (first (first focuslist)) (second (first focuslist)) (third (first focuslist)) (lisp:- (lisp:fourth (first focuslist)) 2)) (reduce-all (rest focuslist)))))) (^^ defun update (node gender num case focuslist) ;node*gender*num*case*focuslist->focuslist (if (not (getinfo node focuslist)); the node is not currently in focuslist (ocons (list node gender num (getweight case)) focuslist) ; so add it with weight of case only (if (or (not (listp gender)) ; if gender of entity is a singleton, or gender *is* a list but only a subset of focuslist representation, (and (listp (second (getinfo node focuslist))) ;then change focuslist rep. to gender's value (subsetp gender (second (getinfo node focuslist))))) (ocons (list node gender num (lisp:+ (lisp:fourth (getinfo node focuslist)) (getweight case))) focuslist) (ocons (list node (second (getinfo node focuslist)) num (lisp:+ (lisp:fourth (getinfo node focuslist)) (getweight case))) focuslist))));else keep focuslist rep (^^ defun ocons (nodelist focuslist) ; nodelist*focuslist->focuslist (if (eql focuslist nil) (list nodelist) (if (eql (first nodelist) (first (first focuslist))) (ocons nodelist (rest focuslist)) (if (lisp:< (lisp:fourth nodelist) (lisp:fourth (first focuslist))) (cons (first focuslist) (ocons nodelist (rest focuslist))) (cons nodelist (delete-node (first nodelist) focuslist)))))) (^^ defun resolve-pron (gender number focuslist) ; gender*number*focuslist->node (if (eql focuslist nil) nil (if (and (eql number (third (first focuslist))) (or (and (listp gender) (and (or (and (listp (second (first focuslist))) (or (subsetp gender (second (first focuslist))) (subsetp ((second (first focuslist)) gender)))) (member (second (first focuslist)) gender)))) (or (and (listp (second (first focuslist))) (member gender (second (first focuslist)))) (eql gender (second (first focuslist)))))) (first (first focuslist)) ; return node (resolve-pron gender number (rest focuslist))))) (^^ defun resolve-accusative (gender number dontbind focuslist) ; gender*number*focuslist*node->node (if (eql dontbind (resolve-pron gender number focuslist)) (resolve-pron gender number (rest focuslist)) (resolve-pron gender number focuslist))) (^^ defun getweight (case) ;case->weight (if (eql case 'nom) 8 (if (eql case 'acc) 7 (if (eql case 'ref) 3 nil)))) ;;; *** ;;; The initial arc is used to make two SNePSUL variables, each of ;;; which holds a SNePS variable node. This results in a major ;;; efficiency gain over creating new SNePS variable nodes each time a ;;; question or an indefinite NP is parsed. (s (wrd "setk" t (to stk)) (wrd "in" t (to sin)) (jump s1 t (or (* 'wh) ($ 'wh)) ; a SNePS variable to use for Wh questions (or (* 'x) ($ 'x)) ; a variable for indef NP's in questions )) (sin (wrd "the" t (to sin)) (wrd "story" t (to sin)) (wrd "," t (to s))) (stk (cat kn t (setr knval *) (to stk/end))) (stk/end (wrd "." t (setkn (getr knval)) (say (getr knval)) (to g/end))) (s1 (wrd "define" t #!((perform (build action believe object1 (build agent *I act (build action (build lex "definingnoun")))))) (to s1)) (jump s/init t (unless (* 'NOW) (\# 'NOW)) (unless (* 'qobj) ($ 'qobj)) (unless (* 'qst) ($ 'qst)) (unless (* 'qet) ($ 'qet)) (unless (* 'mem) ($ 'mem)) (unless (* 'propty) ($ 'propty)))) (s/init (push ps t ; Parse a sentence, and send results to RESPOND (sendr mood 'decl) ; the default (setr assertion *) (setf *focuslist* (reduce-all *focuslist*)) (setr foo *focuslist*) (jump respond))) (ps (cat wh t ; A Wh question starts with "who" or "what". (setr agent (* 'wh)) ; set AGENT to a variable node. (setr mood 'question) (liftr mood) (setr humanness (getf human)) (to s/subj)) (push np t (sendr mood 'decl) (sendr pron_case 'nom) (setr agent *) (setr mood 'decl) (liftr mood) (to s/subj))) (s/subj (to (s/is) (overlap (getf root) 'be)) (cat v t (setr proptype 'avo) (jump vp)) (cat av t (setr mod *)(liftr mod)(to s/subj)) (cat aux t (setr object (* 'wh)) (setr proptype 'avo) (to ps))) (s/is (wrd "a" t (to s/isnoun)) (cat n (and (getr generic) (overlap (getf num) 'plur)) (jump s/isnoun)) ; eg "girls are people" (cat v t (setr action *) (setr pass t) (to vp/passv)) (cat av t (setr mod *)(liftr mod)(to s/is)) (cat adj t (jump s/isadj)) (wrd "named" t (to s/isnamed))) (s/isnoun (cat n (nullr generic) (setr proptype 'isnoun) (setr object *) (to s/final)) (cat n generic (setr proptype 'isnoun) (setr object (wordize 'sing (getr *))) (to s/final))) (s/isadj (cat adj (nullr generic) (setr object *) (setr proptype 'isadj) (to s/final)) (cat adj generic (setr object *) (setr proptype 'isadj) (to s/final))) (s/isnamed (cat npr t (setr object *) (setr proptype 'isnamed) (to s/final))) (s/rule (wrd "." pass (setr prop (assert forall (^ (getr agent)) ant (^ (getr restr)) cq (^ (getr skrestr)) cq (build agent (^ (getr object)) act (build action (^ (getr action)) object (^ (getr agent))) stime (\# 'st) etime (\# 'et)))) (assert before (* 'st) after (* 'NOW)) (assert before (* 'NOW) after (* 'et)) (setr proptype 'passive) (to s/end)) (wrd "." t (setr prop (assert forall (^ (getr subj)) ant (^ (getr restr)) cq (^ (getr skrestr)) cq (build agent (^ (getr obj)) act (^ (getr act)) object (^ (getr subj)) stime (\# 'st) etime (\# 'et)))) (assert before (* 'st) after (* 'NOW)) (assert before (* 'NOW) after (* 'et)) (to s/end))) (vp/passv (wrd "by" t (setr proptype 'passive) (to vp/v))) (vp (cat v t ; Accept just a simple verb for this example, (setr action *) (to vp/v)) (cat av t (setr mod *)(liftr mod)(to vp))) (vp/v (wrd "?" t (jump s/final)) (push pp t (sendr agent) (setr prepo 'propo) (to vp/v)) (push np t (sendr pron_case 'acc) (sendr mood) (sendr agent) (setr object *) ; Set OBJECT to parse of object. (to s/final)) (jump s/final t)) ; If no object. (pp (wrd "into" t (setr into 'true) (liftr into)(to pp/end)) (wrd "to" t (setr to 'true)(liftr to)(to pp/end)) (wrd "at" t (setr dir 'true)(liftr dir)(to pp/end)) (wrd "in" t (setr pla 'true)(liftr pla)(to pp/end)) (wrd "nextto" t (setr rel *)(setr nec 'true)(liftr nec)(liftr rel)(to pp/end)) (wrd "behind" t (setr rel *)(setr nec 'true)(liftr nec)(liftr rel)(to pp/end))) (pp/end (pop onwa t)) (s/final (push pp t (setr prepo 'prepo)(setr rel *) (to s/finis)) (jump s/end (overlap embedded t)) ; an embedded proposition (wrd "." (overlap mood 'decl) (to s/end)) (wrd "?" (overlap mood 'question) (to s/end))) (s/finis (push np t (sendr mood) (sendr agent) (sendr object) ;cheking for an indirect object ;by pushing to state np. (setr indobject *) (to s/final))) (s/end (pop #! ((add member ~(getr agent) ; "isa" declarative basic class (build lex ~(getr object)) kn_cat "story")) (and (overlap mood 'decl) (overlap proptype 'isnoun) (overlap (getf basic (getr object)) t))) (pop #! ((add object-1 ~(getr agent) ; "isa" declarative specif. rel isa object-2 (build lex ~(getr object)) kn_cat "story")) (and (overlap mood 'decl) (overlap proptype 'isnoun) (nullr generic)) (liftr proptype)) (pop #! ((add subclass ~(getr agent) ; "isa" declarative generic superclass (build lex ~(getr object)) kn_cat "story")) (and (overlap mood 'decl) (overlap proptype 'isnoun) (overlap generic t)) (liftr proptype)) ;;;modified by Yana Petrova (10/26/07) ;;;'assert' was changed to 'add' (pop #! ((add object ~(getr agent) ; "is" + adj declar. specif. property (build lex ~(getr object)) kn_cat "story")) (and (overlap mood 'decl) (overlap proptype 'isadj) (nullr generic)) (liftr proptype)) (pop #! ((add object ~(getr agent) ; "is" + adj declar. generic property (build lex ~(getr object)) kn_cat "story")) (and (overlap mood 'decl) (overlap proptype 'isadj) (overlap generic t)) (liftr proptype)) (pop #! ((add object ~(getr agent) propername (build lex ~(getr object)) ;;;comment by Yana Petrova (10/26/07) ;;;according to a new case frame it should be: ;;;propername ~(getr object) kn_cat "story")) ; "is named" + propername (overlap proptype 'isnamed) (liftr proptype)) ;;;test;;; ;;;modified by Yana Petrova (10/26/07) ;;;'assert' was changed to 'add' (pop #! ((add agent ~(getr agent) ; avo declarative act (build action (build lex ~(getr action)) object ~(getr object)) kn_cat "story")) (and (overlap mood 'decl) (nullr into)(nullr to)(nullr dir)(nullr pla)(nullr nec)(nullr mod) (overlap proptype 'avo)) (liftr proptype)) (pop #!((add agent ~(getr agent) ; Assert a top-level statement. act ( build action (build lex ~(getr action)) object (build mode ~(getr mod) object ~(getr object))) kn_cat "story")) (and (overlap mood 'decl)(nullr into)(nullr to)(nullr dir)(nullr pla)(nullr nec)(getr mod)(nullr embedded))) (pop #!((add agent ~(getr agent) ; Assert a top-level statement. act (build action (build lex ~(getr action))) into ~(getr object) kn_cat "story")) (and (overlap mood 'decl)(nullr to)(nullr dir)(nullr pla)(nullr nec)(getr into))) ;builds the agent/act/into representation for sentences with the preposition "into". (pop #!((add agent ~(getr agent) ; Assert a top-level statement. act (build action (build lex ~(getr action))) to ~(getr object) kn_cat "story")) (and (overlap mood 'decl)(nullr dir)(nullr pla)(nullr nec)(nullr indobject)(getr to))) ;builds the agent/act/to representation for sentences with the preposition "to". (pop #!((add agent ~(getr agent) ; Assert a top-level statement. act ( build action (build lex ~(getr action)) object ~(getr object)) to ~(getr indobject) kn_cat "story")) (and (overlap mood 'decl)(nullr dir)(nullr pla)(nullr nec)(getr to)(getr indobject))) ;builds the agent/act-[action/object]/to representation for sentences with the preposition "to" and an indirect object. (pop #!((add agent ~(getr agent) ; Assert a top-level statement. act (build action (build lex ~(getr action))) direction ~(getr object) kn_cat "story")) (and (overlap mood 'decl)(nullr pla)(nullr nec)(getr dir))) ;builds the agent/act/direction representation for sentences with the preposition "at". (pop #!((add agent ~(getr agent) ; Assert a top-level statement. act (build action (build lex ~(getr action))) place ~(getr object) kn_cat "story")) (and (overlap mood 'decl)(nullr indobject)(nullr nec)(getr pla))) ;builds the agent/act/place representation for sentences with the preposition "in". ;removing nullr embedded from oberlap test here because screws it up (pop #!((add agent ~(getr agent) ; Assert a top-level statement. act (build action (build lex ~(getr action)) object ~(getr object)) place ~(getr indobject) kn_cat "story")) (and (overlap mood 'decl)(getr pla)(nullr nec)(getr indobject))) ;builds the agent/act-[action/object]/in representation for sentences with the preposition "in" and an indirect object. ;removing here too. (pop #!((add object ~(getr agent) ; Assert a top-level statement. location (build sp-rel (build lex ~(getr rel)) object ~(getr object)) kn_cat "story")) (and (overlap mood 'decl)(nullr pla)(getr nec)(nullr indobject))) ;builds the object/location-[sp-rel/object] representation for sentences with the preposition "next to" or "behind". ; and here (pop #2! ((build agent ~(getr agent) ; Build an embedded statement. act (build action (build lex ~(getr action)) object ~(getr object)) kn_cat "story")) (and (getr embedded) (overlap mood 'decl)) (liftr proptype)) (pop #! ((deduce agent ~(getr agent) ; avo interrogative act (build action (build lex ~(getr action)) object ~(getr object)) kn_cat "story")) (and (overlap mood 'question) (overlap proptype 'avo)) (liftr proptype)) (pop #! ((deduce agent ~(getr object) ; passive question act (build action (build lex ~(getr action)) object ~(getr agent)) kn_cat "story")) (and (overlap mood 'question) (overlap proptype 'passive)) (liftr proptype)) (pop #! ((add agent ~(getr object) ; passive act (build action (build lex ~(getr action)) object ~(getr agent)) kn_cat "story")) (overlap proptype 'passive) (liftr proptype)) (pop #! ((deduce object ~(getr agent) ; "is" + adj interrogative property (build lex ~(getr object)) kn_cat "story")) (and (overlap mood 'question) (overlap proptype 'isadj)) (liftr proptype))) ;;isa interrogatives will be implemented in the future.... ;;; Notice in all three above arcs that if there is no object, ;;; (getr object) will evaluate to NIL, ;;; and the node will be built without an OBJECT arc. (np (wrd "every" t (setr generic t) (to np/art)) (wrd "that" t (to nomprop)) ; an embedded proposition (wrd "s" t (to np)) (cat art (setr def (getf def)) (to np/art)) (jump np/art t)) (nppos (wrd "'" t (jump npa)) ; which means that the noun is a possessive noun (jump np/n t)) (npa (wrd "'" t (setr pos 't) (setr possor (getr head)) (liftr possor) (liftr pos) (to np))) (np/art (cat adj t (addr props (build lex ( ^(getr *)))) (to np/art)) ;;;added by Yana Petrova (10/29/07) ;;;to parse word "someone" (wrd ("someone" "Someone") t (assert member #someone class (build lex "person")) (setr agent (* 'someone)) (setr num (getf num)) (setr gender (getf gender)) (to s/subj)) (cat pron (overlap (getf case) 'ref) (setr head (^(getr agent))) (setr num (getf num)) (setr gender (getf gender)) (setr pron_case 'ref) (to nppos)) (cat pron (and (overlap (getf case) 'nom) (overlap (getr pron_case) 'nom) (resolve-pron (getf gender) (getf num) *focuslist*)) (setr head (resolve-pron (getf gender) (getf num) *focuslist*)) (setr num (getf num)) (setr gender (getf gender)) (to nppos)) (cat pron (and (overlap (getf case) 'acc) (overlap (getr pron_case) 'acc) (resolve-accusative (getf gender) (getf num) (^(getr agent)) *focuslist*)) (setr head (resolve-accusative (getf gender) (getf num) (^(getr agent)) *focuslist*)) (setr num (getf num)) (setr gender (getf gender)) (to nppos)) (cat npr (find (object- propername lex) (^ (getr *))) (setr head (find (object- propername lex) (^ (getr *)))) (setr num (getf num)) (setr gender (getf gender)) (to nppos)) (cat npr (null (find (object- propername lex) (^ (getr *)))) ;;;modified by Yana Petrova (10/29/07) ;;;assert was changed to add ;;;(assert object (\# 'entity) (add object (\# 'entity) propername (^ (getr *))) (setr head (* 'entity)) (setr num (getf num)) (setr gender (getf gender)) (to nppos)) ; a np of the form "a{n} {adj}* n", where ;the n has never been mentioned before, ;and the sentence is declarative. (cat n (overlap (getf num) 'plur) (setr head (build lex (^(getr *)))) (liftr generic t);;not quite right: not necessarily generic - depends ;;on whether there is article or not (setr num (getf num)) (setr gender (getf gender)) (to nppos)) (cat n (and (disjoint def t) (getr skolem) (nullr generic)) (setr head (build skfn (\# 'newskfn) skarg (^ (getr skolem)))) (liftr skrestr (build member (^ (getr head)) class (build lex (^ (getr *))))) (setr gender (getf gender)) (to nppos)) ; not sure that this is needed (cat n (and (disjoint def t) (overlap mood 'decl)(nullr possor)) (setr head (find member- ;;;modified by Yana Petrova (10/29/07) ;;;assert was changed to add ;;;(assert member #hd (add member #hd class (build lex (^ (getr *)))))) (setr num (getf num)) (setr gender (getf gender)) (to nppos)) ; an indefinite np in a question (cat n (and (disjoint def t) (overlap mood 'decl)(getr possor)(nullr object)); an indefinite possessive np. (setr head ; Create a new referent. #!((find object- ;;;modified by Yana Petrova (10/29/07) ;;;assert was changed to add ;;;(assert object #hed (add object #hed possessor ~(getr possor) rel (build lex ~(getr *)))))) (setr other #!((find member- ;;;modified by Yana Petrova (10/29/07) ;;;assert was changed to add ;;;(assert member ~ (getr head) (add member ~ (getr head) class (build lex ~(getr *)))))) (to nppos)) (cat n (and (disjoint def t) (overlap mood 'question)) (setr head (* 'x)) (to nppos)) ; a np of the form "the adj n", where ; the n has been mentioned before ; hopefully, will soon be "the adj* n" ; i.e. we'll collapse this and the next ; cat into one. (cat n (and (getr def) (find member- (find class (find lex (^ (getr *))))) (getr props)) (setr head (find member- (deduce member (* 'mem) class (build lex (^ (getr *)))) object- (deduce object (* 'propty) property (^ (getr props))))) (setr num (getf num)) (setr gender (getf gender)) (to nppos)) ; a np of the form "the n", where ; the n has been mentioned before (cat n (overlap def t) (setr head #!((find member- (deduce member *x class (build lex ~(getr *)))))) (setr num (getf num)) (setr gender (getf gender)) (to nppos)) ; a np of the form "the {adj}* n", where ; the n is basic and has never been ; mentioned before (cat n (and (getr def) (getf basic)) (setr head ;;;modified by Yana Petrova (10/29/07) ;;;assert was changed to add ;;;(assert lex (^(getr *)))) (add lex (^(getr *)))) (liftr generic t) (setr num 'plur) (setr gender (getf gender)) (to nppos)) ; can't add adj's to these for now (cat n (and (getr generic) (getf basic)) ($ 'anydog) (liftr restr (build member (* 'anydog) class (build lex (^ (getr *))))) (setr head (* 'anydog)) (setr gender (getf gender)) (to nppos))) (nomprop (push ps t ; Return the parse of embedded sentence. (sendr embedded t) (setr head *) (liftr mood)(liftr mod)(to np/end))) (n/ref (jump np/end head) (jump np/end (nullr head) (liftr generic t) ;;;modified by Yana Petrova (10/29/07) ;;;assert was changed to add ;;;(setr head (assert lex (^ (getr class)))))) (setr head (add lex (^ (getr class)))))) (np/n (jump np/end props ;;;modified by Yana Petrova (10/26/07) ;;;'assert' was changed to 'add' (add object (^ (getr head)) property (^ (getr props)))) (jump np/end (nullr object) (setf *focuslist* (update (^ (getr head)) (^ (getr gender)) (^ (getr num)) (^ (getr pron_case)) *focuslist*))) (jump np/end t)) (np/end (pop head t (liftr num))) ;;;;;;;;;;;;;;;;;;;;;; ;;; Generation Section ;;;;;;;;;;;;;;;;;;;;;; (respond (wrd 'dummy t (to flush)) (call gs * (and (getr *) (overlap mood 'decl)) (setr conj "and") (say "I understand that") ; Canned beginning of echo * (to resp/end)) ; of statement. (wrd 'FAIL t ; Question not answered. (say "I don't know") (to resp/end)) (call gs * (and (getr *) (overlap qtype 'tf) (overlap (geta max) 0)) ; Answer No to T/F question. (say "No,") (sendr conj "and") * (to resp/end)) (call gs * (and (getr *) (overlap qtype 'tf)) ; Answer Yes to T/F question. (say "Yes,") (sendr conj "and") * (to resp/end)) (call gs * (and (getr *) (overlap mood '(question #|imper|#))) ; Answer of question or report of ; doing command. (sendr conj "and") * (to resp/end)) (to (resp/end) (overlap mood 'imper)) (jump resp/end (nullr *)) (to (flush) t #!((describe ~(getr *))))) (resp/end (pop nil t (say "."))) (g ;; For use by SURFACE (push gs t (sendr conj "and") (to resp/end)) (jump g/subj (geta action) (setr person 'p1)) (push gcat (geta classmod) (sendr num 'plur) (to g/end)) (push gnp t (sendr case 'obj) (to g/end))) (gs (call gs (geta event) (geta event) (sendr tense (first (tense-and-aspect (geta time)))) (sendr aspect (second (tense-and-aspect (geta time)))) (sendr mood) (setr qtype) (sendr conj) * (to g/end)) (jump gs (and (nullr dir) (geta direction)) (setr dir 'direc)) (jump gs (and (nullr pla) (geta place)) (setr pla 'plack)) (jump gs (and (nullr intwo) (geta into)) (setr intwo 'intwo)) (jump gs (and (nullr two) (geta to)) (setr two 'two)) (rcall gnp (geta agent) (geta agent) ; Generate the agent as an np. (sendr case 'nom) reg (setr tes *) (to g/subj (geta act))) (rcall gnp (geta object) (and (geta object) (geta location)) (sendr case 'nom) reg (to gloc (geta location))) (rcall gequiv (geta equiv) (geta equiv) ; Equiv proposition. reg (to g/end)) (rcall gnp (geta member) (geta member) ; Generate the member as an np. (sendr topcl (geta class)) (sendr case 'nom) (setr num 'sing) reg (jump g/member)) (rcall gcat (geta subclass) (geta subclass) ; subcls are supercls (sendr num 'pl) reg (jump gsubsup)) (rcall gnp (geta object) (and (geta object) (geta property)) (sendr case 'nom) (setr num 'sing) reg (to gprop (geta property))) (call gcat (geta class) (geta member) ; Generate "There is a ." (say '("there" "is" "a")) (sendr case 'nom) (setr num 'sing) reg (to g/end)) (rcall gnp (geta arg1) (geta arg1) ; arg1 rel arg2 (sendr case 'nom) reg (jump g/arg1)) (rcall gnp (geta possessor) ; p's rel is obj (and (geta possessor) (nullr embedded)) (sendr case 'nom) (sendr poss t) reg (jump gposs/p)) (rcall gnp (geta possessor) ; p has a rel (and (geta possessor) (getr embedded)) (sendr case 'nom) reg (jump gposs/p)) (call gs (geta cq) (geta cq) (sendr conj "and") * (to g/end)) (call gs (geta arg) (overlap (geta max) 1) (sendr conj "or") * (to g/end)) (rcall gs (geta arg) (overlap (geta max) 0) (sendr neg 'neg) reg (to g/end)) (rcall g/subj (geta act) (geta act) ; To . (setr person 'p1) (sendr person 'p1) (say "to") reg (to g/subj (geta plan))) ) (gposs/p (rcall gcat (geta rel) (nullr embedded) (sendr case 'nom) (sendr num 'sing) reg (say "is") (jump gposs/rel)) (rcall gcat (geta rel) embedded (say (verbize (getr person) (getr tense) (getr aspect) (getr neg) "has")) (say "a") (sendr case 'nom) (sendr num 'sing) reg (to g/end) )) (gposs/rel (rcall gnp (geta object) (geta object) (sendr case 'nom) reg (to g/end))) (gequiv (push gnp t (sendr case 'nom) (sendr localdescr t) (to gequivrest))) (gequivrest (call gnp * * (say (verbize (getr person) (getr neg) "be")) (sendr case 'nom) (sendr localdescr t) reg (to gequivend))) (gequivend (jump gequivrest * (say "and")) (pop nil t)) (gsubsup (rcall gcat (geta superclass) (geta superclass) (say `(,@(verbize 'plur (getr neg) "be"))) (sendr num 'pl) reg (to g/end))) (g/member (rcall gdefcat (geta class) (and (geta class) (sneps:isassert.n (getr *))) (say `(,@(verbize (getr person) (getr neg) (getr num) "be"))) reg (to g/end)) (rcall gcat (geta class) (and (geta class) (not (sneps:isassert.n (getr *)))) (say `(,@(verbize (getr person) (getr neg) (getr num) "be"))) (say "a") reg (to g/end))) (gprop (to (g/end) t (say `(,@(verbize (getr person) (getr neg) (getr num) "be"))) (say (geta lex)))) (gloc (jump gloc2 (geta lex (geta sp-rel)) (say "is") (say (geta lex (geta sp-rel))))) (gloc2 (rcall gnp (geta object) (geta object) (sendr case 'obj) reg (to g/end))) (g/arg1 (rcall gnp (geta arg2) (geta arg2) (say `(,@(verbize (getr person) (getr neg) (getr num) (getr tense) #|(getr aspect)|# "be"))) (say (geta lex (geta rel))) reg (to g/end))) (g/sqce (rcall g/subj (geta object1) t (sendr person) reg (jump g/sqce2))) (g/sqce2 (rcall g/subj (geta object2) t (utter "and then" :flush :before) (sendr person) ;;(format sneps:outunit "~&and then") reg (to g/end))) (g/subj ; * is an act node (jump g/sqce (overlap (geta action) (sneps:node 'snsequence))) (jump g/v (and (geta action) (overlap (geta action) #2!((build lex "go"))) (overlap (geta |to|) (* 'You))) (say "came")) ; For this example, always use past tense. (jump g/v (and (getr mod) (geta lex (geta action))) (say (verbize (getr person) (getr tense) (getr aspect) (getr neg) "must" (first (geta lex (geta action)))))) (jump g/v (geta lex (geta action)) (say (verbize (getr person) (getr tense) (getr aspect) (getr neg) (first (geta lex (geta action)))))) (jump g/v (geta action) ; Use node id as verb (say (verbize (getr person) (getr tense) (getr aspect) (getr neg) (string-downcase (format nil "~A" (first (geta action)))))))) (g/v ; * is an act node (rcall gnp (geta object) ; Generate the object. (and (geta object) ; example psychological verb (overlap (geta action) #2!((build lex "see")))) (sendr case 'obj) (sendr localdescr t) reg (jump g/obj)) (rcall gnp (geta object) (geta object) ; Generate the object. (sendr case 'obj) reg (jump g/obj)) (rcall gnp (geta object1) (geta object1) ; Generate the object if object1. (sendr case 'obj) reg (jump g/obj)) (to (g/obj (getr tes)) t) (jump g/obj (not (or (geta object) (geta object1))))) ; No object. (g/obj ; * is an act node (rcall gnp (geta |to|) (and (geta |to|) ; E.g. "go left" #!((findassert member ~(geta |to|) (class lex) "direction"))) (sendr case 'obj) reg (to g/end)) (rcall gnp (geta |to|) (geta |to|) ; Generate the PP. (sendr case 'obj) (say "to") reg (to g/end)) (rcall gnp (geta |direction|) (geta |direction|) ; Generate the PP. (sendr case 'obj) (say "at") reg (to g/end)) (rcall gnp (geta |into|) (geta |into|) ; Generate the PP. (sendr case 'obj) (say "into") reg (to g/end)) (rcall gnp (geta |place|) (geta |place|) ; Generate the PP. (sendr case 'obj) (say "in") reg (to g/end)) (jump g/end (or (getr pla) (getr two) (getr intwo) (getr dir))) (to (g/end) t)) ; No PP (g/end (to (g/obj (getr tes)) (or (getr pla) (getr two) (getr intwo) (getr dir)) (setr * (getr tes))) (jump gs * (when (getr conj) (utter (getr conj) :flush :before)) ;;(format sneps:outunit "~&~A~%" (getr conj)) ) (pop nil t)) (gnp (jump gnp (and (nullr adjdescr) #!((find (compose property- ! object (kstar (compose equiv- ! equiv))) ~(getr *)))) (setr adj (geta lex #!((find (compose property- ! object (kstar (compose equiv- ! equiv))) ~(getr *))))) (setr adjdescr 'done)) ; store an adjective (to (gnp (geta object)) (geta mode) (setr mod (geta mode)) (liftr mod) (sendr mod)) (to (gnp/end) (and (getr localdescr) (overlap * (* 'I)) (overlap case 'nom)) (liftr person 'p1) (sayn "I")) (to (gnp/end) (and (nullr localdescr) (overlap case 'nom) (overlap #!((find (kstar (compose (equiv- ! equiv))) ~(getr *))) (* 'I))) (liftr person 'p1) (sayn "I")) (to (gnp/end) (and (getr localdescr) (overlap * (* 'I)) (overlap case 'obj)) (liftr person 'p1) (sayn "me")) (to (gnp/end) (and (nullr localdescr) (overlap case 'obj) (overlap #!((find (kstar (compose (equiv- ! equiv))) ~(getr *))) (* 'I))) (liftr person 'p1) (sayn "me")) (to (gnp/end) (and (nullr localdescr) (overlap * #!((find (kstar (compose equiv- ! equiv)) *You)))) (sayn "you") (addName (getr *) t) (liftr person 'p2) (liftr num 'plur)) (to (gnp/end) (and (getr localdescr) (overlap * (* 'You))) (sayn "you") (addName (getr *) nil) (liftr num 'plur) (liftr person 'p2)) (to (gnp/end) (geta lex) (sayn (geta lex))) (to (gnp/end) (and (getr localdescr) (geta propername (geta object- *))) (sayn (geta propername (geta object- *)))) (to (gnp/end) (and (nullr localdescr) #!((find (compose propername- ! object (kstar (compose equiv- ! equiv))) ~(getr *)))) (sayn #!((find (compose propername- ! object (kstar (compose equiv- ! equiv))) ~(getr *))))) ; Generate an npr. (to (gnp/end) (or (geta lex-) ; is it a lexeme (overlap 'npr ; or in the lexicon as an npr (eval `(getf ctgy ,(format nil "~A" (getr *)))))) (say (list "`" (getr *) "'"))) (rcall gstring (geta end) (geta beg) (sendr beg (geta beg)) (say "\`") reg (say "\'") (to gnp/end)) (to (gcat #!((find (class- ant- ! forall) ~(getr *)))) (and (sneps:isvar.n (getr *)) #!((find (class- ant- ! forall) ~(getr *)))) (say "every")) (call gs * (propositionp (getr *)) ;; An embedded proposition (sendr embedded t) (sendr mod) (say "that") * (to gnp/end)) (call gs (find-if #'propositionp #!((find (equiv- ! equiv) ~(getr *)))) (and (null (getr localdescr)) (find-if #'propositionp #!((find (equiv- ! equiv) ~(getr *))))) ;; An embedded proposition (say "that") * (to gnp/end)) (rcall gnp #!((find (possessor- ! object) ~(getr *))) #!((find (possessor- ! object) ~(getr *))) (sendr poss t) reg (setr num 'sing) (to gcat (geta rel (geta object-)))) (to (gdefcat (best-class #!((- (find class- (findassert member ~(getr *))) ~(getr topcl))))) #!((- (find (class- ! member) ~(getr *)) ~(getr topcl)))) ; A def or indef np. ; But don't say "a is a ." ) (gstring (to (gnp/end) (overlap * beg) (say (geta word *))) (rcall gstring (geta pred) (geta pred) (sendr beg) reg (say (geta word *)) (to gnp/end))) (gdefcat (jump gdefcat1 t (setr mems (remove-equivs #!((find member- (findassert class ~(getr *)))))))) (gdefcat1 (jump gcat (or (atom (getr mems)) (lisp:\= (length (getr mems)) 1)) (say "the") (say (getr adj))) (jump gcat (lisp:> (length (getr mems)) 1) (say "a") (say (getr adj)))) (gcat (to (gnp/end) (geta lex) (say (wordize (getr num) (geta lex *)))) (to (gcat (geta classhead)) (geta classmod) (say (geta lex (geta classmod *))))) (gnp/end (pop nil t)) (flush ;; flush the rest of the sentence and pop (to (flush) t) (pop nil t))