(in-package :snepsul) (defvar *dmode* nil "Indictates whether algorithm should operate in definition mode (t) which uses Ehrlich's logic to decide which information should be reported and which infomation should be ignored, or teaching mode (nil) which reports all information that can be found.") (defstruct ndefn "A structure to store and report definitions of nouns" noun classInclusions probableClassInclusions possibleClassInclusions structuralElements probableStructuralElements possibleStructuralElements actions probableActions possibleActions properties probableProperties possibleProperties owners synonyms agents spatial namedIndividuals) ;;;------------------------------------------------------------------------------- ;;; ;;; function: defineNoun ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun defineNoun (noun &optional lexicographicMode (traceLevel -1)) "Generates a definition for 'noun'. If the optional argument lexicographicMode is t then Ehrlich's theory will be used to exclude some information from the definition, else all info will be reported. If the optional argument traceLevel is specified tracing/debugging will be enabled. The values of traceLevel are 0-4 where 0 means no tracing and 4 means trace all functions." ;; the default for traceLevel is -1 so that any tracing set up manually by the user ;; will not be overridden by the program when the optional argument traceLevel is not ;; specified. (setTraceLevel traceLevel) (setq *dmode* lexicographicMode) ;; get the requested definition and print it in human readable format. (prettyPrintDef (if lexicographicMode (defineNounLexicographic noun) (defineNounTeaching noun)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: defineNounStored ;;; This functions differs from defined noun in that it stores the ;;; it generates in the sneps network and uses that definition to answer ;;; all subsequent queries about the meaning of 'noun'. ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun defineNounStored (noun &optional lexicographicMode (traceLevel -1)) "Generates a definition for 'noun'. If the optional argument lexicographicMode is t then Ehrlich's theory will be used to exclude some information from the definition, else all info will be reported. If the optional argument traceLevel is specified tracing/debugging will be enabled. The values of traceLevel are 0-4 where 0 means no tracing and 4 means trace all functions." ;; the default for traceLevel is -1 so that any tracing set up manually by the user ;; will not be overridden by the program when the optional argument traceLevel is not ;; specified. (setTraceLevel traceLevel) (setq *dmode* lexicographicMode) (let (definition) ;; if the definition is already stored, use the stored def, otherwise generate a def (setf definition (if (isDefinitionStored noun) (getStoredDefinition noun) ;; in lexicographic mode, use Ehrlich's theory to omit some info ;; in teaching mode, retrieve all available info ;; then store the definition in the network (storeDefinition (if lexicographicMode (defineNounLexicographic noun) (defineNounTeaching noun))))) ;; print the definition in a human readable format (prettyPrintDef definition))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: defineNounLexicographic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun defineNounLexicographic (noun) "Makes a list of information that is known about the noun and reports only the information that is deemed relevant according to Ehrlich's theory." (let (definition) ;; get all the info (setf definition (defineNounTeaching noun)) ;; now examine all the info and eliminate parts that Ehrlich's theory says are unnecessary ;; if there are class inclusions, don't report probable class inclusions (if (ndefn-classInclusions definition) (or (setf (ndefn-probableClassInclusions definition) nil) (setf (ndefn-possibleClassInclusions definition) nil))) ;; if there are probable class inclusions, don't report possible class inclusions (if (ndefn-probableClassInclusions definition) (setf (ndefn-possibleClassInclusions definition) nil)) ;; if there are structural elements don't report probable or possible struct. elems. (if (ndefn-structuralElements definition) ;; using "or" is just a way to make sure that both setf statements get evaluated (or (setf (ndefn-probableStructuralElements definition) nil) (setf (ndefn-possibleStructuralElements definition) nil))) ;; if there are probable structural elements don't report possible structural elements (if (ndefn-probableStructuralElements definition) (setf (ndefn-possibleStructuralElements definition) nil)) ;; IF WE DECIDE TO PUT FUNCTIONS BACK IN THEY WOULD GO HERE ;; if there are actions don't report probable or possible actions (if (ndefn-actions definition) (or (setf (ndefn-probableActions definition) nil) (setf (ndefn-possibleActions definition) nil))) ;; if there are probable actions don't report possible actions (if (ndefn-probableActions definition) (setf (ndefn-possibleActions definition) nil)) ;; if there are properties, don't report probable or possible properties (if (ndefn-properties definition) (or (setf (ndefn-probableProperties definition) nil) (setf (ndefn-possibleProperties definition) nil))) ;; if there are probable properties, don't report possible properties (if (ndefn-probableProperties definition) (setf (ndefn-possibleProperties definition) nil)) ;; if there are class inclusions or probable class inclusions, ;; don't report named individuals (if (or (ndefn-classInclusions definition) (ndefn-probableClassInclusions definition)) (setf (ndefn-namedIndividuals definition) nil)) ;; now return the revised definition definition )) ;;;------------------------------------------------------------------------------- ;;; ;;; function: defineNounTeaching ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun defineNounTeaching (noun) "Makes a list of all information that is known about the noun. This information makes up the definition." (let (definition) ;; get a new instance of the structure ndefn (setf definition (make-ndefn)) ;; populate the fields of the definition structure ;; the noun itself (setf (ndefn-noun definition) noun) ;; class inclusions (setf (ndefn-classInclusions definition) (findClassInclusions noun)) ;; probable (with 'mode presumably') class inclusions (setf (ndefn-probableClassInclusions definition) (findProbableClassInclusions noun)) ;; possible class inclusions (setf (ndefn-possibleClassInclusions definition) (findPossibleClassInclusions noun (append (ndefn-classInclusions definition) (ndefn-probableClassInclusions definition)))) ;; structure (setf (ndefn-structuralElements definition) (findStructure noun)) ;; probable structure (setf (ndefn-probableStructuralElements definition) (findProbableStructure noun)) ;; possible structure (setf (ndefn-possibleStructuralElements definition) (findPossibleStructure noun (ndefn-classInclusions definition))) ;; functions ;;; (setf (ndefn-functions definition) (findFunctions noun)) ;; probable functions ;;; (setf (ndefn-probableFunctions definition) (findProbableFunctions noun)) ;; possible functions ;;; (setf (ndefn-possibleFunctions definition) (findPossibleFunctions noun)) ;; actions (setf (ndefn-actions definition) (findActions noun)) ;; probable actions (setf (ndefn-probableActions definition) (findProbableActions noun)) ;; possible actions (setf (ndefn-possibleActions definition) (findPossibleActions noun)) ;; properties (setf (ndefn-properties definition) (findProperties noun)) ;; probable properties (setf (ndefn-probableProperties definition) (findProbableProperties noun)) ;; possible properties (setf (ndefn-possibleProperties definition) (findPossibleProperties noun)) ;; owners (setf (ndefn-owners definition) (findOwners noun)) ;; spatial information (setf (ndefn-spatial definition) (findSpatial noun)) ;; synonyms (setf (ndefn-synonyms definition) (findSynonyms noun (ndefn-structuralElements definition) (ndefn-classInclusions definition) (ndefn-owners definition))) ;; agents who act on 'noun's (setf (ndefn-agents definition) (findAgents noun)) ;; names of specific 'noun's (setf (ndefn-namedIndividuals definition) (findNamedIndividuals noun)) ;; return the definition definition)) ;;;----------------------------------------------------------------------------- ;;; ;;; function: traceLevel ;;; input: An integer 0-4 representing the amount of tracing info that ;;; should be given: ;;; 0 - no tracing ;;; 1 - trace only reporting functions (e.g report_basic, report_abstr) ;;; 2 - trace only top level info finding functions (e.g. classes, struct) ;;; 3 - trace top level functions and functions that are directly ;;; called by top level functions ;;; 4 - trace all functions. ;;; created: stn 2002 ;;;----------------------------------------------------------------------------- (defun setTraceLevel (level) (case level (0 (untrace defineNoun defineNounTeaching defineNounLexicographic isDefinitionStored getStoredDefinition storeDefinition struct-nonbasic indiv_struct structureOfAll findStructure findProbableStructure struct-basic struct-basic-presume struct-nonbasic-presume findPossibleStructure struct-nonbasic-indiv struct-basic-indiv findClassInclusions findPossibleClassInclusions class-basic-basic-indiv class-basic-nonbasic-indiv class-nonbasic-basic-indiv class-nonbasic-nonbasic-indiv findProbableClassInclusions class-sub-sup class-rule-basic-basic class-rule-basic-nonbasic class-rule-nonbasic-basic class-rule-nonbasic-nonbasic findActions findProbableActions findPossibleActions act-object-basic-rule act-object-nonbasic-rule act-object-basic-&-rule act-object-basic-presum-rule act-object-nonbasic-presum-rule act-object-basic-presum-&-rule act-object-nonbasic-presum-&-rule act-basic-rule act-basic-&-rule act-nonbasic-rule act-nonbasic-&-rule act-basic-presum-rule act-basic-presum-&-rule act-nonbasic-presum-rule act-nonbasic-presum-&-rule act-basic act-nonbasic act-object-basic-noun act-object-nonbasic-noun findProperties findProbableProperties findPossibleProperties prop-basic prop-nonbasic prop-basic-presume prop-nonbasic-presume prop-basic-indiv prop-nonbasic-indiv findOwners owner-basic owner-nonbasic func-basic-rule func-nonbasic-rule func-nonbasic-superclass-rule func-action-basic-rule func-action-nonbasic-rule findProbableFunctions findFunctions func-basic-presum-rule func-nonbasic-presum-rule func-nonbasic-superclass-presum-&-rule func-nonbasic-superclass-presum-&-rule-nml func-nonbasic-superclass-presum-rule func-action-basic-presum-rule func-action-nonbasic-presum-rule func-action-nonbasic-superclass-presum-rule syn-sub-sup syn-syn findSynonyms eliminateDissimilarClasses similarSuperclassesp noAntonymsp antonymp eliminateDissimilarStructure similarStructurep eliminateDissimilarFunctions similarFunctionp eliminateDissimilarOwners similarOwnersp removeElement findNamedIndividuals nonbasic-named-indiv basic-named-indiv findAgents agent-basic-object agent-nonbasic-object action-basic-object action-nonbasic-object prop-relation-basic-1 prop-relation-nonbasic-1 prop-&-basic prop-&-nonbasic prop-&-relation-basic-1 prop-&-relation-nonbasic-1 prop-&-relation-nonbasic-1-presume prop-&-relation-basic-1-presume prop-relation-nonbasic-1-presume prop-relation-basic-1-presume prop-&-nonbasic-presume prop-&-basic-presume prop-relation-basic-2 prop-relation-nonbasic-2 prop-&-relation-basic-2 prop-&-relation-nonbasic-2 prop-relation-basic-2-presume prop-relation-nonbasic-2-presume prop-&-relation-basic-2-presume prop-&-relation-nonbasic-2-presume prop-basic-indiv prop-nonbasic-indiv prop-relation-basic-1-indiv prop-relation-nonbasic-1-indiv prop-relation-basic-2-indiv prop-relation-nonbasic-2-indiv obj-rel-basic-1 obj-rel-nonbasic-1 obj-&-rel-basic-1 obj-&-rel-nonbasic-1 obj-rel-basic-2 obj-rel-nonbasic-2 obj-&-rel-basic-2 obj-&-rel-nonbasic-2 obj-rel-basic-1-presume obj-rel-nonbasic-1-presume obj-&-rel-basic-1-presume obj-&-rel-nonbasic-1-presume obj-rel-basic-2-presume obj-rel-nonbasic-2-presume obj-&-rel-basic-2-presume obj-&-rel-nonbasic-2-presume obj-rel-basic-1-indiv obj-rel-nonbasic-1-indiv obj-rel-basic-2-indiv obj-rel-nonbasic-2-indiv loc-prop loc-cls-basic loc-cls-nonbasic loc-str loc-act loc-act-obj loc-rel loc-own loc-basic-prop loc-basic-cls-basic loc-basic-cls-nonbasic loc-basic-str loc-basic-act loc-basic-act-obj loc-basic-rel loc-basic-own loc-nonbasic-prop loc-nonbasic-cls-basic loc-nonbasic-cls-nonbasic loc-nonbasic-str loc-nonbasic-act loc-nonbasic-act-obj loc-nonbasic-rel loc-nonbasic-own )) (1 (trace defineNoun)) (2 (trace defineNoun defineNounTeaching defineNounLexicographic isDefinitionStored getStoredDefinition storeDefinition)) (3 (trace defineNoun defineNounTeaching defineNounLexicographic isDefinitionStored getStoredDefinition storeDefinition indiv_struct structureOfAll findStructure findProbableStructure findPossibleStructure findProperties findProbableProperties findClassInclusions findProbableClassInclusions findPossibleClassInclusions findPossibleActions findActions findProbableActions findPossibleProperties findOwners findSynonyms findSpatial)) (4 (trace defineNoun defineNounTeaching defineNounLexicographic isDefinitionStored getStoredDefinition storeDefinition struct-nonbasic indiv_struct structureOfAll findStructure findProbableStructure struct-basic struct-basic-presume struct-nonbasic-presume findPossibleStructure struct-nonbasic-indiv struct-basic-indiv findClassInclusions findProbableClassInclusions findPossibleClassInclusions class-basic-basic-indiv class-basic-nonbasic-indiv class-nonbasic-basic-indiv class-sub-sup class-rule-basic-basic class-nonbasic-nonbasic-indiv class-rule-basic-nonbasic class-rule-nonbasic-basic class-rule-nonbasic-nonbasic findActions findProbableActions findPossibleActions act-object-basic-rule act-object-nonbasic-rule act-object-basic-&-rule act-object-basic-presum-rule act-object-nonbasic-presum-rule act-object-basic-presum-&-rule act-object-nonbasic-presum-&-rule act-basic-rule act-basic-&-rule act-nonbasic-rule act-nonbasic-&-rule act-basic-presum-rule act-basic-presum-&-rule act-nonbasic-presum-rule act-nonbasic-presum-&-rule act-basic act-nonbasic act-object-basic-noun act-object-nonbasic-noun findProperties findProbableProperties findPossibleProperties prop-basic prop-nonbasic prop-basic-presume prop-nonbasic-presume prop-basic-indiv prop-nonbasic-indiv findOwners owner-basic owner-nonbasic func-basic-rule func-nonbasic-rule func-nonbasic-superclass-rule func-action-basic-rule func-action-nonbasic-rule findProbableFunctions findFunctions func-basic-presum-rule func-nonbasic-presum-rule func-nonbasic-superclass-presum-&-rule func-nonbasic-superclass-presum-&-rule-nml func-nonbasic-superclass-presum-rule func-action-basic-presum-rule func-action-nonbasic-presum-rule func-action-nonbasic-superclass-presum-rule syn-sub-sup syn-syn findSynonyms eliminateDissimilarClasses similarSuperclassesp noAntonymsp antonymp eliminateDissimilarStructure similarStructurep eliminateDissimilarFunctions similarFunctionp eliminateDissimilarOwners similarOwnersp removeElement findNamedIndividuals nonbasic-named-indiv basic-named-indiv findAgents agent-basic-object agent-nonbasic-object action-basic-object action-nonbasic-object prop-relation-basic-1 prop-relation-nonbasic-1 prop-&-basic prop-&-nonbasic prop-&-relation-basic-1 prop-&-relation-nonbasic-1 prop-&-relation-nonbasic-1-presume prop-&-relation-basic-1-presume prop-relation-nonbasic-1-presume prop-relation-basic-1-presume prop-&-nonbasic-presume prop-&-basic-presume prop-relation-basic-2 prop-relation-nonbasic-2 prop-&-relation-basic-2 prop-&-relation-nonbasic-2 prop-relation-basic-2-presume prop-relation-nonbasic-2-presume prop-&-relation-basic-2-presume prop-&-relation-nonbasic-2-presume prop-basic-indiv prop-nonbasic-indiv prop-relation-basic-1-indiv prop-relation-nonbasic-1-indiv prop-relation-basic-2-indiv prop-relation-nonbasic-2-indiv obj-rel-basic-1 obj-rel-nonbasic-1 obj-&-rel-basic-1 obj-&-rel-nonbasic-1 obj-rel-basic-2 obj-rel-nonbasic-2 obj-&-rel-basic-2 obj-&-rel-nonbasic-2 obj-rel-basic-1-presume obj-rel-nonbasic-1-presume obj-&-rel-basic-1-presume obj-&-rel-nonbasic-1-presume obj-rel-basic-2-presume obj-rel-nonbasic-2-presume obj-&-rel-basic-2-presume obj-&-rel-nonbasic-2-presume obj-rel-basic-1-indiv obj-rel-nonbasic-1-indiv obj-rel-basic-2-indiv obj-rel-nonbasic-2-indiv loc-prop loc-cls-basic loc-cls-nonbasic loc-str loc-act loc-act-obj loc-rel loc-own loc-basic-prop loc-basic-cls-basic loc-basic-cls-nonbasic loc-basic-str loc-basic-act loc-basic-act-obj loc-basic-rel loc-basic-own loc-nonbasic-prop loc-nonbasic-cls-basic loc-nonbasic-cls-nonbasic loc-nonbasic-str loc-nonbasic-act loc-nonbasic-act-obj loc-nonbasic-rel loc-nonbasic-own )) )) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prettyPrintDef ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prettyPrintDef (definition) "Prints human readable version of the definition generated by the algorithm to standard output." (format t "~& Definition of ~A: " (ndefn-noun definition)) (if (not (null (ndefn-classInclusions definition))) (format t "~& Class Inclusions: ~{~A,~}" ;; call lexicalize on each element of the list of class inclusions ;; and then print each of them, separated by commas (mapcar #'lexicalize (ndefn-classInclusions definition)))) (if (not (null (ndefn-probableClassInclusions definition))) (format t "~& Probable Class Inclusions: ~{~A,~}" (mapcar #'lexicalize (ndefn-probableClassInclusions definition)))) (if (not (null (ndefn-possibleClassInclusions definition))) (format t "~& Possible Class Inclusions: ~{~A,~}" (mapcar #'lexicalize (ndefn-possibleClassInclusions definition)))) (if (not (null (ndefn-structuralElements definition))) (format t "~& Structure: ~{~A,~}" (mapcar #'lexicalize (ndefn-structuralElements definition)))) (if (not (null (ndefn-probableStructuralElements definition))) (format t "~& Probable Structure: ~{~A,~}" (mapcar #'lexicalize (ndefn-probableStructuralElements definition)))) (if (not (null (ndefn-possibleStructuralElements definition))) (format t "~& Possible Structure: ~{~A,~}" (mapcar #'lexicalize (ndefn-possibleStructuralElements definition)))) ;;; If functions are put back into the algorithm, they will go here (if (not (null (ndefn-actions definition))) (format t "~& Actions: ~{~A,~}" (mapcar #'lexicalize (ndefn-actions definition)))) (if (not (null (ndefn-probableActions definition))) (format t "~& Probable Actions: ~{~A,~}" (mapcar #'lexicalize (ndefn-probableActions definition)))) (if (not (null (ndefn-possibleActions definition))) (format t "~& Possible Actions: ~{~A,~}" (mapcar #'lexicalize (ndefn-possibleActions definition)))) (if (not (null (ndefn-agents definition))) (format t "~& Actions performed on a ~A: ~{~A,~}" (ndefn-noun definition) (mapcar #'lexicalize (ndefn-agents definition)))) (if (not (null (ndefn-properties definition))) (format t "~& Properties: ~{~A,~}" (mapcar #'lexicalize (ndefn-properties definition)))) (if (not (null (ndefn-probableProperties definition))) (format t "~& Probable Properties: ~{~A,~}" (mapcar #'lexicalize (ndefn-probableProperties definition)))) (if (not (null (ndefn-possibleProperties definition))) (format t "~& Possible Properties: ~{~A,~}" (mapcar #'lexicalize (ndefn-possibleProperties definition)))) (if (not (null (ndefn-spatial definition))) (format t "~& ~A is a place where: ~{~A,~}" (ndefn-noun definition) (mapcar #'lexicalize (ndefn-spatial definition)))) (if (not (null (ndefn-owners definition))) (format t "~& Owners: ~{~A,~}" (mapcar #'lexicalize (ndefn-owners definition)))) (if (not (null (ndefn-synonyms definition))) (format t "~& Synonyms: ~{~A,~}" (mapcar #'lexicalize (ndefn-synonyms definition)))) (if (not (null (ndefn-namedIndividuals definition))) (format t "~& Named Individuals: ~{~A,~}" (mapcar #'lexicalize (ndefn-namedIndividuals definition)))) ) ;;;------------------------------------------------------------------------------- ;;; ;;; function: lexicalize ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun lexicalize (nodes) "Finds and returns the human language representation of the sneps nodes listed in 'nodes' if one exists. If no human language representation can be found, the node itself is returned." (let (humanRep) (cond ;; if the list is empty return the empty string ((null nodes) "") ;; if we have a list, process each element individually ((listp nodes) (concatenate 'string (lexicalize (first nodes)) " " (lexicalize (rest nodes)))) ;; look for lex arcs coming from the node ((setf humanRep #3! ((find lex- ~nodes))) (nodes2string humanRep)) ;; look for mod/head arcs coming from the node ((setf humanRep (append #3! ((find (compose mod- lex-) ~nodes)) #3! ((find (compose head- lex-) ~nodes))))) ;; if the node itself is not named, see if it is a member of a named (basic) class ;; if we are in teaching mode, look for nonbasic info as well ((and (setf humanRep (append humanRep #3! ((find (compose lex- class- ! member) ~nodes)))) *dmode*) (nodes2string humanRep)) ;; if the node itself is not named, see if it is a member of a named (nonbasic) class ((and (setf humanRep (append humanRep #3! ((find (compose lex- object2- ! object1) ~nodes (compose lex- object2- ! rel) "ISA")))) *dmode*) (nodes2string humanRep)) ;; other possible representations (such as mod/head) would go here ;; if we can't find a human language representation, return the name of the sneps node ((null humanRep) (nodes2string nodes)) ;; if we are in teaching mode and there is a human language representation, ;; return all the info we accumulated above (t (nodes2string humanRep))))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: nodes2string ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun nodes2string (nodes) "Converts a list of sneps nodes into a string consisting of the names of the nodes, separated as spaces." (cond ((null nodes) "") ((not (listp nodes)) (get-node-string nodes)) (t (concatenate 'string (get-node-string (first nodes)) " " (nodes2string (rest nodes)))))) ;;; ------------------------------------------------------------------------------ ;;; DEFINITION STORAGE SECTION ;;; ------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: isDefinitionStored ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun isDefinitionStored (noun) "T if the definition of 'noun' is stored in the SNePS network, NIL otherwise." #3! ((find (compose definition- ! word lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: getStoredDefinition ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun getStoredDefinition (noun) "Retrieves a definition that has been stored in the network." (let (definition) ;; get a new instance of the structure ndefn (setf definition (make-ndefn)) ;; set the noun that we are defining (setf (ndefn-noun definition) noun) ;; get stored class inclusions (setf (ndefn-classInclusions definition) (getStoredDefPart noun "class inclusions")) ;; get stored probable class inclusions (setf (ndefn-probableClassInclusions definition) (getStoredDefPart noun "probable class inclusions")) ;; get stored possible class inclusions (setf (ndefn-possibleClassInclusions definition) (getStoredDefPart noun "possible class inclusions")) ;; get stored structure (setf (ndefn-structuralElements definition) (getStoredDefPart noun "structural elements")) ;; get stored probable structure (setf (ndefn-probableStructuralElements definition) (getStoredDefPart noun "probable structural elements")) ;; get stored possible structure (setf (ndefn-possibleStructuralElements definition) (getStoredDefPart noun "possible structural elements")) ;; get stored actions (setf (ndefn-actions definition) (getStoredAction noun "actions")) ;; get stored probable actions (setf (ndefn-probableActions definition) (getStoredAction noun "probable actions")) ;; get stored possible actions (setf (ndefn-possibleActions definition) (getStoredAction noun "possible actions")) ;; get properties (setf (ndefn-properties definition) (getStoredProp noun "properties")) ;; get probable properties (setf (ndefn-probableProperties definition) (getStoredProp noun "probable properties")) ;; get possible properties (setf (ndefn-possibleProperties definition) (getStoredProp noun "possible properties")) ;; get owners (setf (ndefn-owners definition) (getStoredDefPart noun "owners")) ;; get synonyms (setf (ndefn-synonyms definition) (getStoredDefPart noun "synonyms")) ;; get agents who act on 'noun's (setf (ndefn-agents definition) (getStoredDefPart noun "agents-acting-on-Xs")) ;; get spatial info (setf (ndefn-spatial definition) (getStoredDefPart noun "spatial")) ;; get named individuals (setf (ndefn-namedIndividuals definition) (getStoredDefPart noun "named individuals")) ;; return the definition definition )) ;;;------------------------------------------------------------------------------- ;;; ;;; function: getStoredDefPart ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun getStoredDefPart (noun identifier) "Retrieve class inclusions that are part of the stored definition of 'noun'." #3! ((find (compose defpart- ! defwhole definition- ! word lex) ~noun (compose defpart- ! type lex) ~identifier))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: getStoredAction ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun getStoredAction (noun identifier) "Retrieve actions that are part of the stored definition of 'noun'." (let (act-wo act obj) ;; actions with objects (setf act-wo #3! ((find (compose act-defpart- ! obj-defpart obj-defpart- ! defwhole definition- ! word lex) ~noun (compose act-defpart- ! obj-defpart obj-defpart- ! type lex) ~identifier))) ;; objects (setf obj #3! ((find (compose obj-defpart- ! defwhole definition- ! word lex) ~noun (compose obj-defpart- ! type lex) ~identifier))) ;; actions without objects (setf act (set-difference #3! ((find (compose act-defpart- ! defwhole definition- ! word lex) ~noun (compose act-defpart- ! type lex) ~identifier)) act-wo)) ;; put it all together (append act (if (not (null (append act-wo obj))) (list (append act-wo obj)) nil)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: getStoredProp ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun getStoredProp (noun identifier) "Retrieve properties that are part of the stored definition of 'noun'." (let (obj rel prop) ;; objects in relations (setf obj #3! ((find (compose prp-defpart- ! rel-defpart rel-defpart- ! defwhole definition- ! word lex) ~noun (compose prp-defpart- ! rel-defpart rel-defpart- ! type lex) ~identifier))) ;; name of relations (setf rel #3! ((find (compose rel-defpart- ! defwhole definition- ! word lex) ~noun (compose rel-defpart- ! type lex) ~identifier))) ;; properties (setf prop (set-difference #3! ((find (compose prp-defpart- ! defwhole definition- ! word lex) ~noun (compose prp-defpart- ! type lex) ~identifier)) obj)) ;; put it all together (append prop (if (not (null (append rel obj))) (list (append rel obj)) nil)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: storeDefinition ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun storeDefinition (definition) "Stores the definition in the SNePS network and return it unchanged." ;; define the arc labels that we need ;; -- we do this so users don't have to remember to define these specialized labels ;; in all of their demos #3! ((define word definition defwhole defpart act-defpart obj-defpart rel-defpart prp-defpart type lex)) ;; if the word has not already been stored, do it now (if (not (isDefinitionStored (ndefn-noun definition))) #3! ((assert word (build lex ~(ndefn-noun definition)) definition #def))) ;; if there are class inclusions, store them (if (not (null (ndefn-classInclusions definition))) #3! ((assert defwhole *def defpart ~(ndefn-classInclusions definition) type (build lex "class inclusions")))) ;; if there are probable class inclusions, store them (if (not (null (ndefn-probableClassInclusions definition))) #3! ((assert defwhole *def defpart ~(ndefn-probableClassInclusions definition) type (build lex "probable class inclusions")))) ;; if there are possible class inclusions, store them (if (not (null (ndefn-possibleClassInclusions definition))) #3! ((assert defwhole *def defpart ~(ndefn-possibleClassInclusions definition) type (build lex "possible class inclusions")))) ;; if there is structure, store it (if (not (null (ndefn-structuralElements definition))) #3! ((assert defwhole *def defpart ~(ndefn-structuralElements definition) type (build lex "structural elements")))) ;; if there is probable structure, store it (if (not (null (ndefn-probableStructuralElements definition))) #3! ((assert defwhole *def defpart ~(ndefn-probableStructuralElements definition) type (build lex "probable structural elements")))) ;; if there is possible structure, store it (if (not (null (ndefn-possibleStructuralElements definition))) #3! ((assert defwhole *def defpart ~(ndefn-possibleStructuralElements definition) type (build lex "possible structural elements")))) ;; if there are any actions, store them (if (not (null (ndefn-actions definition))) (storeActions (ndefn-actions definition) "actions")) ;; if there are any probable actions, store them (if (not (null (ndefn-probableActions definition))) (storeActions (ndefn-probableActions definition) "probable actions")) ;; if there are any possible actions, store them (if (not (null (ndefn-possibleActions definition))) (storeActions (ndefn-possibleActions definition) "possible actions")) ;; if there are properties, store them (if (not (null (ndefn-properties definition))) (storeProps (ndefn-properties definition) "properties")) ;; if there are probable properties, store them (if (not (null (ndefn-probableProperties definition))) (storeProps (ndefn-probableProperties definition) "probable properties")) ;; if there are possible properties, store them (if (not (null (ndefn-possibleProperties definition))) (storeProps (ndefn-possibleProperties definition) "possible properties")) ;; if there are owners, store them (if (not (null (ndefn-owners definition))) #3! ((assert defwhole *def defpart ~(ndefn-owners definition) type (build lex "owners")))) ;; if there are synonyms, store them (if (not (null (ndefn-synonyms definition))) #3! ((assert defwhole *def defpart ~(ndefn-synonyms definition) type (build lex "synonyms")))) ;; if there are agents who act on 'noun's, store that info (if (not (null (ndefn-agents definition))) #3! ((assert defwhole *def defpart ~(ndefn-agents definition) type (build lex "agents-acting-on-Xs")))) ;; if there is spatial information, store it (if (not (null (ndefn-spatial definition))) #3! ((assert defwhole *def defpart ~(ndefn-spatial definition) type (build lex "spatial")))) ;; if there are named individuals, store them (if (not (null (ndefn-namedIndividuals definition))) #3! ((assert defwhole *def defpart ~(ndefn-namedIndividuals definition) type (build lex "named individuals")))) ;; return the definition definition) ;;;------------------------------------------------------------------------------- ;;; ;;; function: storeActions ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun storeActions (acts actType) "Stores the actions part of a definition in the network." (cond ((null acts) nil) ;; if we have an action and an object ((listp (first acts)) ;; store them #3! ((assert defwhole *def act-defpart ~(first (first acts)) obj-defpart ~(rest (first acts)) type (build lex ~actType))) ;; and keep going through the list (storeActions (rest acts) actType)) (t ;; if we have an action without an object, store it #3! ((assert defwhole *def act-defpart ~(first acts) type (build lex ~actType))) ;; and keep going through the list (storeActions (rest acts) actType)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: storeProps ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun storeProps (props propType) "Stores the properties part of a definition in the network." (cond ((null props) nil) ;; if we have a relation ((listp (first props)) ;; store them #3! ((assert defwhole *def rel-defpart ~(first (first props)) prp-defpart ~(rest (first props)) type (build lex ~propType))) ;; and keep going through the list (storeProps (rest props) propType)) ;; if we have a simple property (t ;; store it #3! ((assert defwhole *def prp-defpart ~(first props) type (build lex ~propType))) ;; and keep going through the list (storeProps (rest props) propType)))) ;;; ------------------------------------------------------------------------------ ;;; CLASS INCLUSIONS SECTION ;;; ------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: findClassInclusions ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findClassInclusions (noun) "Find all superclasses of 'noun'. Find all things Y such that, if X is a 'noun' then X is a Y." ;(class_filter (let (superclasses) (cond ;; get superclasses represented using sub-sup case frame, in definition mode return ;; them, in teaching mode continue accumulating information ((and (setf superclasses (append superclasses (class-sub-sup noun))) *dmode*) superclasses) ;; superclasses represented using a rule, both classes are basic level ((and (setf superclasses (append superclasses (class-rule-basic-basic noun))) *dmode*) superclasses) ;; superclasses represented using a rule, noun is basic and superclass is nonbasic ((and (setf superclasses (append superclasses (class-rule-basic-nonbasic noun))) *dmode*) superclasses) ;; superclasses represented using a rule, noun is nonbasic and superclass is basic ((and (setf superclasses (append superclasses (class-rule-nonbasic-basic noun))) *dmode*) superclasses) ;; superclasses represented using a rule, both classes are nonbasic level ((and (setf superclasses (append superclasses (class-rule-nonbasic-nonbasic noun))) *dmode*) superclasses) ;; if we are in teaching mode, return all the accumulated info ;; if we are in definition mode, superclasses must be nil here, so return nil (t superclasses))) ;noun)) ) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findProbableClassInclusions ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findProbableClassInclusions (noun) "Find all superclasses of 'noun' that are marked with the 'mode presumably' tag." ;(class_filter (let (superclasses) (cond ;; SN: I don't know why Ehrlich uses deduce here, this is the only place in the ;; algorithm that it is used -- I am leaving it as it is until I understand it ((and *dmode* #3! ((deduce mode (build lex "presumably") object (build subclass (build lex ~noun) superclass (build lex $maybesuper))))) (setf superclasses (append superclasses (class-sub-sup-presum noun)))) ;; superclasses represented using a presumable rule, both classes are basic level ((and (setf superclasses (append superclasses (class-rule-basic-basic-presum noun))) *dmode*) superclasses) ;; superclasses represented using a presumable rule, noun is basic and ;; superclass is nonbasic ((and (setf superclasses (append superclasses (class-rule-basic-nonbasic-presum noun))) *dmode*) superclasses) ;; superclasses represented using a presumable rule, noun is nonbasic and ;; superclass is basic ((and (setf superclasses (append superclasses (class-rule-nonbasic-basic-presum noun))) *dmode*) superclasses) ;; superclasses represented using a presumable rule, both classes are nonbasic level ((and (setf superclasses (append superclasses (class-rule-nonbasic-nonbasic-presum noun))) *dmode*) superclasses) ;; if we are in teaching mode, return all the accumulated info ;; if we are in definition mode, superclasses must be nil here, so return nil (t superclasses))) ;noun)) ) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findPossibleClassInclusions ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findPossibleClassInclusions (noun classIncls) "Find possible superclasses of noun. If some X is a member of the class 'noun' and X is also a member of the class Y, then Y is listed as a possible class inclusion for 'noun'." ;; eliminate any items that would be duplicates of class inclusions or probable ;; class inclusions from the list of possible class inclusions (set-difference (let (superclasses) (cond ;; both classes are basic level ((and (setf superclasses (append superclasses (class-basic-basic-indiv noun))) *dmode*) superclasses) ;; noun is basic, possible class inclusion is nonbasic ((and (setf superclasses (append superclasses (class-basic-nonbasic-indiv noun))) *dmode*) superclasses) ;; noun is nonbasic, possible class inclusion is basic ((and (setf superclasses (append superclasses (class-nonbasic-basic-indiv noun))) *dmode*) superclasses) ;; both classes are nonbasic level ((and (setf superclasses (append superclasses (class-nonbasic-nonbasic-indiv noun))) *dmode*) superclasses) (t superclasses))) ;; this is the list of things we are eliminating from the list to be returned ;; (second argument to set-difference) (append classIncls #3! ((find lex ~noun))))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-sub-sup ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-sub-sup (noun) "Finds superclasses of 'noun' represented using the subclass/superclass case frame." #3! ((find (compose superclass- ! subclass lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-rule-basic-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-rule-basic-basic (noun) "Finds superclasses of 'noun' represented using a rule, where both classes are basic level" #3! ((find (compose class- cq- ! ant class lex) ~noun (compose class- member member- class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-rule-basic-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-rule-basic-nonbasic (noun) "Finds superclasses of 'noun' represented using a rule, where the noun is basic level and the superclass nonbasic level." #3! ((find (compose object2- cq- ! ant class lex) ~noun (compose object2- rel) "ISA" (compose object2- object1 member- class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-rule-nonbasic-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-rule-nonbasic-basic (noun) "Finds superclasses of 'noun' represented using a rule, where the noun is nonbasic level and the superclass is basic level" #3! ((find (compose class- cq- ! ant object2 lex) ~noun (compose class- member object1- rel) "ISA" (compose class- member object1- object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-rule-nonbasic-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-rule-nonbasic-nonbasic (noun) "Finds superclasses of 'noun' represented using a rule, where both classes are nonbasic" #3! ((find (compose object2- cq- ! ant object2 lex) ~noun (compose object2- rel) "ISA" (compose object2- object1 object1- rel) "ISA" (compose object2- object1 object1- object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-sub-sup-presum ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-sub-sup-presum (noun) "Finds things that are presumably superclasses of 'noun'." #3! ((find (compose superclass- subclass lex) ~noun (compose superclass- object- ! mode lex) "presumably"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-rule-basic-basic-presum ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-rule-basic-basic-presum (noun) "Finds superclasses of 'noun' represented using a rule, where both classes are basic level" #3! ((find (compose class- object- cq- ! ant class lex) ~noun (compose class- object- mode lex) "presumably" (compose class- member member- class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-rule-basic-nonbasic-presum ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-rule-basic-nonbasic-presum (noun) "Finds superclasses of 'noun' represented using a rule, where the noun is basic level and the superclass nonbasic level." #3! ((find (compose object2- object- cq- ! ant class lex) ~noun (compose object2- object- mode lex) "presumably" (compose object2- rel) "ISA" (compose object2- object1 member- class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-rule-nonbasic-basic-presum ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-rule-nonbasic-basic-presum (noun) "Finds superclasses of 'noun' represented using a rule, where the noun is nonbasic level and the superclass is basic level" #3! ((find (compose class- cq- ! ant object2 lex) ~noun (compose class- object- mode lex) "presumably" (compose class- member object1- rel) "ISA" (compose class- member object1- object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-rule-nonbasic-nonbasic-presum ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-rule-nonbasic-nonbasic-presum (noun) "Finds superclasses of 'noun' represented using a rule, where both classes are nonbasic" #3! ((find (compose object2- object- cq- ! ant object2 lex) ~noun (compose object2- object- mode lex) "presumably" (compose object2- object1 object1- rel) "ISA" (compose object2- object1 object1- object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-basic-basic-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-basic-basic-indiv (noun) "Finds possible basic-level superclasses of a basic-level noun." #3! ((find (compose class- ! member member- ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-basic-nonbasic-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-basic-nonbasic-indiv (noun) "Finds possible nonbasic-level superclasses of a basic-level noun." #3! ((find (compose object2- ! object1 member- ! class lex) ~noun (compose object2- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-nonbasic-basic-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-nonbasic-basic-indiv (noun) "Finds possible basic-level superclasses of a nonbasic-level noun." #3! ((find (compose class- ! member object1- ! object2 lex) ~noun (compose class- ! member object1- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: class-nonbasic-nonbasic-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun class-nonbasic-nonbasic-indiv (noun) "Finds possible nonbasic-level superclasses of a nonbasic-level noun." #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! rel) "ISA" (compose object2- ! object1 object1- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: class_filter ;;; input: a list of superclasses as output by "classes", an empty list, ;;; and the noun to be defined. ;;; output: a list of classes not redundant with the rest of the definition ;;; calls: mostSpecificSuperclassp, class_filter recursively ;;;------------------------------------------------------------------------------ (defun class_filter (superclasses noun &optional filtered) "Removes any superclasses of 'noun' which less specific than other superclasses of 'noun' from the list of class inclusions and returns the result. For an example of the heirarchy of class inclusions see the documentation for mostSpecificSuperclassp." (cond ((null superclasses) filtered) ;;if first element of input is a list ((listp (first superclasses)) ;;add class_filter of car & (append filtered ;;class_filter of cdr to output (list (class_filter (first superclasses) noun filtered)) (class_filter (rest superclasses) noun filtered))) ;;if car input is an ok atom ;;add it and class_filter of ;;cdr to output. ((or (mostSpecificSuperclassp (first superclasses) noun) (string-equal (string (get-node-name (first superclasses))) "animal")) (append filtered (list (first superclasses)) (class_filter (rest superclasses) noun filtered))) ;;otherwise car input not ok. ;;add class_filter of cdr to output. (t (class_filter (rest superclasses) noun filtered)))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: mostSpecificSuperclassp (a predicate) ;;; input: a noun to be defined and a superclass attributed to ;;; returns nil if the class can be deduced from other elements of the ;;; definition, t otherwise. ;;;------------------------------------------------------------------------------ (defun mostSpecificSuperclassp (class noun) "Returns t if there are no classes between 'class' and 'noun' in a superclass-subclass relation, nil otherwise. For example if class = vertebrate, noun = cat and vertebrate is a superclass of mammal which is a superclass of cat, mostSpecificSuperclassp would return nil because mammal is a class between cat and vertebrate." (not #3! ((find (compose superclass- ! subclass lex) ~noun (compose subclass- ! superclass lex) ~class)))) ;;; ------------------------------------------------------------------------------ ;;; ACTIONS SECTION ;;; ------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-basic-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-basic-rule (noun) "Finds actions performed by all 'noun's and the objects that those actions are performed on, where the 'noun' is basic level." (let (actions objects) (setf actions #3! ((find (compose action- act- ! cq- ! ant ! class lex) ~noun (compose action- act- ! agent member- ! class lex) ~noun))) (setf objects #3! ((find (compose object- act- ! cq- ! ant ! class lex) ~noun))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-nonbasic-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-nonbasic-rule (noun) "Finds actions performed by all 'noun's and the objects that those actions are performed on, where the 'noun' is nonbasic level." (let (actions objects) (setf actions #3! ((find (compose action- act- ! cq- ! ant ! object2 lex) ~noun (compose action- act- ! agent object1- ! object2 lex) ~noun (compose action- act- ! agent object1- ! rel) "ISA"))) (setf objects #3! ((find (compose object- act- ! cq- ! ant ! object2 lex) ~noun (compose object- act- ! agent object1- ! rel) "ISA"))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-basic-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-basic-&-rule (noun) "Finds actions performed by all 'noun's and the objects that those actions are performed on, where the 'noun' is basic level." (let (actions objects) (setf actions #3! ((find (compose action- act- ! cq- ! &ant ! class lex) ~noun (compose action- act- ! agent member- ! class lex) ~noun))) (setf objects #3! ((find (compose object- act- ! cq- ! &ant ! class lex) ~noun))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-nonbasic-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-nonbasic-&-rule (noun) "Finds actions performed by all 'noun's and the objects that those actions are performed on, where the 'noun' is nonbasic level." (let (actions objects) (setf actions #3! ((find (compose action- act- ! cq- ! &ant ! object2 lex) ~noun (compose action- act- ! agent object1- ! object2 lex) ~noun (compose action- act- ! agent object1- ! rel) "ISA"))) (setf objects #3! ((find (compose object- act- ! cq- ! ant ! object2 lex) ~noun (compose object- act- ! agent object1- ! rel) "ISA"))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-basic-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-basic-rule (noun) "Finds actions performed by all 'noun's where there is no object on which the action is performed and 'noun' is a member of a basic level category." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- ! cq- ! ant ! class lex) ~noun (compose lex- act- ! agent member- ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-basic-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-basic-&-rule (noun) "Finds actions performed by all 'noun's where there is no object on which the action is performed and 'noun' is a member of a basic level category." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- ! cq- ! &ant ! class lex) ~noun (compose lex- act- ! agent member- ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-nonbasic-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-nonbasic-rule (noun) "Finds actions performed by all 'noun's where there is no object on which the action is performed and 'noun' is a member of a nonbasic level category." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- ! cq- ! ant ! object2 lex) ~noun (compose lex- act- ! agent object1- ! object2 lex) ~noun (compose lex- act- ! agent object1- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-nonbasic-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-nonbasic-&-rule (noun) "Finds actions performed by all 'noun's where there is no object on which the action is performed and 'noun' is a member of a nonbasic level category." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- ! cq- ! &ant ! object2 lex) ~noun (compose lex- act- ! agent object1- ! object2 lex) ~noun (compose lex- act- ! agent object1- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-basic-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-basic-presum-rule (noun) "Finds actions that are presumed to be performed by all 'noun's and the objects that those actions are presumed to be performed on, where the 'noun' is basic level." (let (actions objects) (setf actions #3! ((find (compose action- act- object- mode lex) "presumably" (compose action- act- object- cq- ! ant class lex) ~noun (compose action- act- agent member- class lex) ~noun))) (setf objects #3! ((find (compose object- act- object- cq- ! ant class lex) ~noun))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-nonbasic-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-nonbasic-presum-rule (noun) "Finds actions that are presumed to be performed by all 'noun's and the objects that those actions are presumed to be performed on, where the 'noun' is nonbasic level." (let (actions objects) (setf actions #3! ((find (compose action- act- object- mode lex) "presumably" (compose action- act- object- cq- ! ant object2 lex) ~noun (compose action- act- agent object1- object2 lex) ~noun (compose action- act- agent object1- rel) "ISA"))) (setf objects #3! ((find (compose object- act- object- cq- ! ant object2 lex) ~noun (compose object- act- agent object1- rel) "ISA"))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-basic-presum-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-basic-presum-&-rule (noun) "Finds actions that are presumed to be performed by all 'noun's and the objects that those actions are presumed to be performed on, where the 'noun' is basic level." (let (actions objects) (setf actions #3! ((find (compose action- act- object- mode lex) "presumably" (compose action- act- object- cq- ! &ant class lex) ~noun (compose action- act- agent member- class lex) ~noun))) (setf objects #3! ((find (compose object- act- object- cq- ! &ant class lex) ~noun))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-nonbasic-presum-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-nonbasic-presum-&-rule (noun) "Finds actions that are presumed to be performed by all 'noun's and the objects that those actions are presumed to be performed on, where the 'noun' is nonbasic level." (let (actions objects) (setf actions #3! ((find (compose action- act- object- mode lex) "presumably" (compose action- act- object- cq- ! &ant object2 lex) ~noun (compose action- act- agent object1- object2 lex) ~noun (compose action- act- agent object1- rel) "ISA"))) (setf objects #3! ((find (compose object- act- object- cq- ! &ant object2 lex) ~noun (compose object- act- agent object1- rel) "ISA"))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-basic-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-basic-presum-rule (noun) "Finds actions presumably performed by all 'noun's where there is no object on which the action is performed and 'noun' is a member of a basic level category." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- object- mode lex) "presumably" (compose lex- act- object- cq- ! ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-basic-presum-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-basic-presum-&-rule (noun) "Finds actions presumably performed by all 'noun's where there is no object on which the action is performed and 'noun' is a member of a basic level category." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- object- mode lex) "presumably" (compose lex- act- object- cq- ! &ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-nonbasic-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-nonbasic-presum-rule (noun) "Finds actions presumably performed by all 'noun's where there is no object on which the action is performed and 'noun' is a member of a nonbasic level category." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- object- mode lex) "presumably" (compose lex- act- object- cq- ! ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun (compose lex- act- agent object1- rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-nonbasic-presum-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-nonbasic-presum-&-rule (noun) "Finds actions presumably performed by all 'noun's where there is no object on which the action is performed and 'noun' is a member of a nonbasic level category." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- object- mode lex) "presumably" (compose lex- act- object- cq- ! &ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun (compose lex- act- agent object1- rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-basic (noun) "Finds actions performed by at least one member of the basic level category 'noun'." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- ! agent member- ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-nonbasic (noun) "Finds actions performed by at least one member of the nonbasic level category 'noun'." ;; we need to include the "lex-" here, even though we don't do it anywhere else, because ;; without it, this rule would be triggered on agent-act-action-object (which we don't ;; want as well as agent-act (which we do want). #3! ((find (compose lex- act- ! agent object1- ! object2 lex) ~noun (compose lex- act- ! agent object1- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-basic-noun ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-basic-noun (noun) "Finds actions performed by at least one member of the basic level category 'noun' and the objects that those actions are performed on, where the objects are basic level." (let (actions objects) (setf actions #3! ((find (compose action- act- ! agent member- ! class lex) ~noun))) (setf objects #3! ((find (compose object- act- ! agent member- ! class lex) ~noun))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: act-object-nonbasic-noun ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun act-object-nonbasic-noun (noun) "Finds actions performed by at least one member of the nonbasic level category 'noun' and the objects that those actions are performed on, where the objects are basic level." (let (actions objects) (setf actions #3! ((find (compose action- act- ! agent object1- ! object2 lex) ~noun (compose action- act- ! agent object1- ! rel) "ISA"))) (setf objects #3! ((find (compose object- act- ! agent object1- ! object2 lex) ~noun (compose object- act- ! agent object1- ! rel) "ISA"))) (if (and actions objects) (list (append actions objects)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findActions ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findActions (noun) "Find actions (and the objects that those actions are performed on, if any) that are performed by all 'noun's." (let (results) (cond ;;definite rule, or-entail, basic-ctgy, transitive ((and (setf results (append results (act-object-basic-rule noun))) *dmode*) results) ;;definite rule, or-entail, non-basic-ctgy, transitive ((and (setf results (append results (act-object-nonbasic-rule noun))) *dmode*) results) ;;definite rule, &-entail, basic-ctgy, transitive ((and (setf results (append results (act-object-basic-&-rule noun))) *dmode*) results) ;;definite rule, &-entail, non-basic ctgy, transitive ((and (setf results (append results (act-object-nonbasic-&-rule noun))) *dmode*) results) ;;definite rule, or-entail, basic-ctgy, intransitive ((and (setf results (append results (act-basic-rule noun))) *dmode*) results) ;;definite rule, &-entail, basic-ctgy, intransitive ((and (setf results (append results (act-basic-&-rule noun))) *dmode*) results) ;;definite rule, or-entail, non-basic-ctgy, intransitive ((and (setf results (append results (act-nonbasic-rule noun))) *dmode*) results) ;;definite rule, &-entail, non-basic-ctgy, intransitive ((and (setf results (append results (act-nonbasic-&-rule noun))) *dmode*) results) ;; If we are in teaching mode, return all the info we have accumulated. If we are ;; in definition mode results = nil so return nil. (t results)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findActions ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findProbableActions (noun) "Find actions (and the objects that those actions are performed on, if any) that can be presumed to be performed by all 'noun's." (let (results) (cond ;;"presumably" rule, or-entail, basic ctgy, transitive ((and (setf results (append results (act-object-basic-presum-rule noun))) *dmode*) results) ;;"presumably" rule, or-entail, non-basic ctgy, transitive ((and (setf results (append results (act-object-nonbasic-presum-rule noun))) *dmode*) results) ;;"presumably" rule, &-entail, basic ctgy, transitive ((and (setf results (append results (act-object-basic-presum-&-rule noun))) *dmode*) results) ;;"presumably" rule, &-entail, non-basic ctgy, transitive ((and (setf results (append results (act-object-nonbasic-presum-&-rule noun))) *dmode*) results) ;;"presumably" rule, or-entail, basic ctgy, intransitive ((and (setf results (append results (act-basic-presum-rule noun))) *dmode*) results) ;;"presumably" rule, &-entail, basic ctgy, intransitive ((and (setf results (append results (act-basic-presum-&-rule noun))) *dmode*) results) ;;"presumably" rule, or-entail, non-basic ctgy, intransitive ((and (setf results (append results (act-nonbasic-presum-rule noun))) *dmode*) results) ;;"presumably" rule, &-entail, non-basic ctgy, intransitive ((and (setf results (append results (act-nonbasic-presum-&-rule noun))) *dmode*) results) ;; If we are in teaching mode, return all the info we have accumulated. If we are ;; in definition mode results = nil so return nil. (t results)))) ;;;-------------------------------------------------------------------------- ;;; ;;; function: findPossibleActions ;;; input: a noun to be defined ;;; output: a list of actions attributed to any object of type ;;; modified: mkb 2002 ;;; modified: stn 2002 ;;;-------------------------------------------------------------------------- (defun findPossibleActions (noun) "Find actions (and the objects that those actions are performed on, if any) that are performed by at least one 'noun'." (let (results) (cond ;; find actions performed on objects by at least one member of the class 'noun' ((and (setf results (append results (act-object-basic-noun noun))) *dmode*) results) ((and (setf results (append results (act-object-nonbasic-noun noun))) *dmode*) results) ;; find actions with no objects that are performed by at least one 'noun'. ((and (setf results (append results (act-basic noun))) *dmode*) results) ((and (setf results (append results (act-nonbasic noun))) *dmode*) results) ;; if we are in teaching mode, return all the information that we accumulated above, ;; otherwise, return results (= nil). (t results)))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: act_filter ;;; input: a list of actions as output by "acts", an empty list, and the ;;; noun to be defined. ;;; output: a list of actions not redundant with the rest of the definition ;;; calls: non_redundant_act, act_filter recursively ;;;------------------------------------------------------------------------------ (defun act_filter (act-list filtered noun) (cond ((null act-list) filtered) ;;;if car input is a list ((listp (first act-list)) ;;;add act_filter of car & (append filtered ;;;act_filter of cdr to output (list (act_filter (first act-list) filtered noun)) (act_filter (rest act-list) filtered noun))) ;;;if car input is an ok atom ;;;add it and act_filter of ;;;cdr to output. ((non_redundant_act (first act-list) noun) (append filtered (list (first act-list)) (act_filter (rest act-list) filtered noun))) ;;;otherwise car input not ok. ;;;add act_filter of cdr to (t (act_filter (rest act-list) filtered noun)))) ;;;output. ;;;------------------------------------------------------------------------------ ;;; ;;; function: non_redundant_act (a predicate) ;;; input: a noun to be defined and an act attributed to ;;; returns nil if the act can be deduced from other elements of the ;;; definition, t otherwise. ;;;------------------------------------------------------------------------------ (defun non_redundant_act (act noun) (cond (#3! ((find (compose superclass- ! subclass lex) ~noun (compose class- ant- ! cq act lex) ~act)) nil) (#3! ((find (compose superclass- ! subclass lex) ~noun (compose object2- ant- ! cq act lex) ~act)) nil) (#3! ((find (compose superclass- ! subclass lex) ~noun (compose class- ant- ! cq object act lex) ~act)) nil) (#3! ((find (compose superclass- ! subclass lex) ~noun (compose object2- ant- ! cq object act lex) ~act)) nil) (t t))) ;;; ------------------------------------------------------------------------------ ;;; STRUCTURE SECTION ;;; ------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: findStructure ;;; ;;; Used for finding structure of a noun. ;;; modified: mkb 2002 ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------- (defun findStructure (noun) "Attempts to find structural features common to all members of the class noun." (let (parts) (cond ((and (setf parts (append parts (struct-basic noun))) *dmode*) parts) ((and (setf parts (append parts (struct-nonbasic noun))) *dmode*) parts) ;; if we have gotten to this point there are 2 possible scenarios: ;; 1) we have found no parts -- so 'parts' = nil ;; 2) we are in teaching mode (*dmode* = nil) and we want to return all the ;; info that we accumulated in the steps above. (t parts)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findProbableStructure ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findProbableStructure (noun) "Attempts to find structural features that are presumably part of all 'noun's." (let (parts) (cond ((and (setf parts (append parts (struct-basic-presume noun))) *dmode*) parts) ((and (setf parts (append parts (struct-nonbasic-presume noun))) *dmode*) parts) ;; if we have gotten to this point there are 2 possible scenarios: ;; 1) we have found no parts -- so 'parts' = nil ;; 2) we are in teaching mode (*dmode* = nil) and we want to return all the ;; info that we accumulated in the steps above. (t parts)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findPossibleStructure ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findPossibleStructure (noun superclasses) "Find things that are part of some (but not necessarily all) members of the class 'noun', and are also not part of all members of a superclass of 'noun'. For example: if the knowledge base says 'Dogs are Mammals. Rover is a Dog. Rover has nose. All Mammals have fur.' Then 'nose' would be returned but 'fur' would not be returned." (set-difference (indiv_struct noun) (structureOfAll superclasses))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: struct-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun struct-basic (noun) "Find any things that are a part of all members of the basic level category 'noun'." #3! ((find (compose part- ! whole member- ! class lex) ~noun (compose part- ! cq- ! ant ! class lex) ~noun (compose part- ! whole forall- ! ant ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: struct-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun struct-nonbasic (noun) "Find any things that are a part of all members of the nonbasic level category 'noun'." #3! ((find (compose part- ! whole object1- ! object2 lex) ~noun (compose part- ! cq- ! ant ! object2 lex) ~noun (compose part- ! whole forall- ! ant ! object2 lex) ~noun (compose part- ! whole object1- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: struct-basic-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun struct-basic-presume (noun) "Find any things that are presumably a part of all members of the basic level category 'noun'." #3! ((find (compose part- whole member- class lex) ~noun (compose part- object- mode lex) "presumably" (compose part- whole forall- ! ant class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: struct-nonbasic-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun struct-nonbasic-presume (noun) "Find any things that are presumably a part of all members of the nonbasic level category 'noun'." #3! ((find (compose part- whole object1- object2 lex) ~noun (compose part- object- mode lex) "presumably" (compose part- whole forall- ! ant object2 lex) ~noun (compose part- whole object1- rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: struct-basic-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun struct-basic-indiv (noun) "Find any things that are part of some individual who is a member of the basic level category 'noun'." #3! ((find (compose part- ! whole member- ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: struct-nonbasic-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun struct-nonbasic-indiv (noun) "Find any things that are part of some individual who is a member of the nonbasic level category 'noun'." #3! ((find (compose part- ! whole object1- ! object2 lex) ~noun (compose part- ! whole object1- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: indiv_struct ;;; input: a noun to be defined and a list of its superclasses. ;;; output: a list of possessions attributed to individuals ;;; of class . (See note on "struct") ;;; modified: mkb 2002 ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------ (defun indiv_struct (noun) "Find things that are part of some (but not necessarily all) members of the class 'noun'." (let (parts) (cond ((and (setf parts (append parts (struct-nonbasic-indiv noun))) *dmode*) parts) ((and (setf parts (append parts (struct-basic-indiv noun))) *dmode*) parts) ;; if we have gotten to this point there are 2 possible scenarios: ;; 1) we have found no parts -- so 'parts' = nil ;; 2) we are in teaching mode (*dmode* = nil) and we want to return all the ;; info that we accumulated in the steps above. (t parts)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: structureOfAll ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------- (defun structureOfAll (classes) "Find the structure of all the classes listed as parameters." (if (not (null classes)) (append (findStructure (first classes)) (structureOfAll (rest classes))) nil)) ;;; ------------------------------------------------------------------------------ ;;; FUNCTIONS SECTION ;;; ------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-basic-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-basic-rule (noun) "Find any functions of all 'noun's, where noun is a member of a basic level category." #3! ((find (compose object2- object1 member- class lex) ~noun (compose object2- rel lex) "function" (compose object2- cq- ! ant class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-nonbasic-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-nonbasic-rule (noun) "Find any functions of all 'noun's, where noun is a member of a nonbasic level category." #3! ((find (compose object2- object1 object1- object2 lex) ~noun (compose object2- rel lex) "function" (compose object2- cq- ! ant object2 lex) ~noun (compose object2- object1 object1- rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-nonbasic-superclass-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-nonbasic-superclass-rule (noun) "Find any functions of all members of a subclass of 'noun', where 'noun' is a nonbasic level category." #3! ((find (compose object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose object2- rel lex) "function" (compose object2- cq- ! ant object2 superclass- ! subclass lex) ~noun (compose object2- object1 object1- rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-action-basic-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-action-basic-rule (noun) "Find any functions of 'noun's where the function is to have some action performed on all members of the basic level class 'noun'." (let (function) #3! ((find (compose action- act- object2- object1 member- class lex) ~noun (compose action- act- object2- rel lex) "function" (compose action- act- object2- cq- ! ant class lex) ~noun)) (if (not (null function)) (append '("to be") function) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-action-nonbasic-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-action-nonbasic-rule (noun) "Find any functions of 'noun's where the function is to have some action performed on all members of the nonbasic level class 'noun'." (let (function) #3! ((find (compose act- object2- object1 object1- object2 lex) ~noun (compose act- object2- rel lex) "function" (compose act- object2- cq- ! ant object2 lex) ~noun (compose act- object2- object1 object1- rel) "ISA")) (if (not (null function)) (append '("to be") function) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-action-nonbasic-superclass-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-action-nonbasic-superclass-rule (noun) "Find any functions of 'noun's where the function is to have some action performed on all members of a nonbasic level superclass of the subclass 'noun'." (let (function) #3! ((find (compose act- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose act- object2- rel lex) "function" (compose act- object2- cq- ! ant object2 superclass- ! subclass lex) ~noun (compose act- object2- object1 object1- rel) "ISA")) (if (not (null function)) (append '("to be") function) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-basic-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-basic-presum-rule (noun) "Find any functions of all 'noun's, where noun is a member of a basic level category." #3! ((find (compose object2- object1 member- class lex) ~noun (compose object2- rel lex) "function" (compose object2- object- cq- ! ant class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-nonbasic-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-nonbasic-presum-rule (noun) "Find any presumable functions of all 'noun's, where noun is a member of a nonbasic level category." #3! ((find (compose object2- object1 object1- object2 lex) ~noun (compose object2- rel lex) "function" (compose object2- object- cq- ! ant object2 lex) ~noun (compose object2- object1 object1- rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-nonbasic-superclass-presum-&-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-nonbasic-superclass-presum-&-rule (noun) "Find any presumable functions of all members of a subclass of 'noun', where 'noun' is a nonbasic level category." (let (function) (if (and #3!((deduce subclass (build lex ~noun) superclass $supercat)) (setf function #3! ((find (compose &ant- ! cq object rel lex) "function" (compose object2- rel lex) "function" (compose object2- object1 object1- object2 subclass- superclass) (compose object2- object1 object1- rel) "ISA" (find (compose superclass- ! subclass lex) ~noun))))) function nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-nonbasic-superclass-presum-&-rule-nml ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-nonbasic-superclass-presum-&-rule-nml (noun) "Find any presumable functions of all members of a subclass of 'noun', where 'noun' is a nonbasic level category." (let (function) (if (and #3!((deduce subclass (build lex ~noun) superclass $supercat)) #3!((deduce act (build lex (find (compose act- &ant- ! cq object rel lex) "function")) object (find (compose object1- ! object2 subclass- ! superclass) (find (compose superclass- ! subclass lex) ~noun)))) (setf function #3! ((find (compose act- &ant- ! cq object rel lex) "function" (compose act- object2- rel lex) "function" (compose act- object2- object1 object1- object2 subclass- superclass) (compose act- object2- object1 object1- rel) "ISA" (find (compose superclass- ! subclass lex) ~noun))))) (append '("to be") function) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-nonbasic-superclass-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-nonbasic-superclass-presum-rule (noun) "Find any presumable functions of all members of a subclass of 'noun', where 'noun' is a nonbasic level category." #3! ((find (compose object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose object2- rel lex) "function" (compose object2- object- cq- ! ant object2 superclass- ! subclass lex) ~noun (compose object2- object1 object1- rel) "ISA"))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-action-basic-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-action-basic-presum-rule (noun) "Find any presumable functions of all members of the basic level category 'noun'." (let (function) (if (setf function #3! ((find (compose act- object2- object1 member- class lex) ~noun (compose act- object2- rel lex) "function" (compose act- object2- object- cq- ! ant class lex) ~noun))) (append '("to be") function) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-action-nonbasic-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-action-nonbasic-presum-rule (noun) "Find any presumable functions of all members of the nonbasic level category 'noun'." (let (function) (if (setf function #3! ((find (compose act- object2- object1 object1- object2 lex) ~noun (compose act- object2- rel lex) "function" (compose act- object2- object- cq- ! ant object2 lex) ~noun (compose act- object2- object1 object1- rel) "ISA"))) (append '("to be") function) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: func-action-nonbasic-superclass-presum-rule ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun func-action-nonbasic-superclass-presum-rule (noun) "Find any presumable functions of objects which are members of a nonbasic level superclass of the subclass 'noun'." (let (function) (if (setf function #3! ((find (compose act- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose act- object2- rel lex) "function" (compose act- object2- object- cq- ! ant object2 superclass- ! subclass lex) ~noun (compose act- object2- object1 object1- rel) "ISA"))) (append '("to be") function) nil))) ;;;---------------------------------------------------------------------------- ;;; ;;; function: findFunctions ;;; input: a noun to be defined ;;; output: a list of functions or purposes of . Finds rules of the sort ;;; If x is a then the function of x is ;;; modified: mkb 2002 ;;; modified: stn 2002 ;;;---------------------------------------------------------------------------- (defun findFunctions (noun) "Find things that are the function (purpose) of all 'noun's." (let (functions) (cond ;; definite rule, basic ctgy, or-entail ((and (setf functions (append functions (func-basic-rule noun))) *dmode*) functions) ;; definite rule, non-basic ctgy, or-entail ((and (setf functions (append functions (func-nonbasic-rule noun))) *dmode*) functions) ;; definite rule, subclass of class for which function known, or-entail ((and (setf functions (append functions (func-nonbasic-superclass-rule noun))) *dmode*) functions) ;; definite rule, basic ctgy, or-entail, non-mol-lex function node ((and (setf functions (append functions (func-action-basic-rule noun))) *dmode*) functions) ;; definite rule, non-basic ctgy, or-entail, non-mol-lex function node ((and (setf functions (append functions (func-action-nonbasic-rule noun))) *dmode*) functions) ;; definite rule, subclass of class for which function is known, or-entail, ;; non-mol-lex function node ((and (setf functions (append functions (func-action-nonbasic-rule noun))) *dmode*) functions) ;; If we are in teaching mode, return all the info we have accumulated. If we are in ;; definition mode, return nil. (t functions)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findProbableFunctions ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findProbableFunctions (noun) "Find things that can be presumed to be the function (purpose) of all 'noun's." (let (functions) (cond ;; presumable rule, basic ctgy, or-entail ((and (setf functions (append functions (func-basic-presum-rule noun))) *dmode*) functions) ;; presumable rule, non-basic ctgy, or-entail ((and (setf functions (append functions (func-nonbasic-presum-rule noun))) *dmode*) functions) ;; presumable rule, un-named non-basic ctgy, &-entail ((and (setf functions (append functions (func-nonbasic-superclass-presum-&-rule noun))) *dmode*) functions) ;; presumable rule, un-named non-basic ctgy, &-entail, non-mol-lex node. ((and (setf functions (append functions (func-nonbasic-superclass-presum-&-rule-nml noun))) *dmode*) functions) ;; presumable rule, subclass of class for which function is known, or-entail ((and (setf functions (append functions (func-nonbasic-superclass-presum-rule noun))) *dmode*) functions) ;; presumable rule, basic ctgy, non-mol-lex function node, or-entail ((and (setf functions (append functions (func-action-basic-presum-rule noun))) *dmode*) functions) ;; presumable rule, non-basic ctgy, non-mol-lex function node, or-entail ((and (setf functions (append functions (func-action-nonbasic-presum-rule noun))) *dmode*) functions) ;; presumable rule, subclass of class for which function is known, ;; non-mol-lex function node, or-entail ((and (setf functions (append functions (func-action-nonbasic-superclass-presum-rule noun))) *dmode*) functions) ;; if we are in teaching mode return the info we have accumulated above, else return nil (t functions)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findPossibleFunctions ;;; *** FUNCTION TO BE FILLED IN LATER *** ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------- (defun findPossibleFunctions (noun) nil) ; (cond (#3! ((find (compose object2- object- ! object object1 object1- ! object2 lex) ; ~noun ; (compose object2- object- ! object rel lex) "function")) ; (list 'possible 'function= ; #3! ((describe (find (compose object2- object- ! object object1 ; object1- ! object2 lex) ; ~noun ; (compose object2- object- ! object rel lex) ; "function"))))) ; (#3! ((find (compose object2- object- ! object object1 object1- ! object2 lex) ; ~noun ; (compose object2- object- ! object rel lex) "function")) ; (list 'possible 'function= ; #3! ((describe (find (compose object2- object- ! object object1 ; object1- ! object2 lex) ; ~noun ; (compose object2- object- ! object rel lex) ; "function"))))))) ; ;;;------------------------------------------------------------------------------ ;;; PROPERTIES SECTION ;;;------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-basic (noun) "Finds properties belong to all members of the class 'noun', where 'noun' is a basic level category." #3! ((find (compose property- ! object member- ! class lex) ~noun (compose property- ! cq- ! ant ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-nonbasic (noun) "Finds properties belong to all members of the class 'noun', where 'noun' is a nonbasic level category." #3! ((find (compose property- ! object object1- ! object2 lex) ~noun (compose property- ! cq- ! ant ! object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-basic-1 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-basic-1 (noun) "Finds relationships that all members of the basic level category 'noun' are involved in and the other objects that are also in the relation." (let (relations object) ;; we leave the 'lex-' arcs in to exclude "rel ISA" info (setf relations #3! ((find (compose lex- rel- ! object1 member- ! class lex) ~noun (compose lex- rel- ! cq- ! ant ! class lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-basic-1 noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-basic-1 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-basic-1 (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 member- ! class lex) ~noun (compose object2- ! cq- ! ant ! class lex) ~noun (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-nonbasic-1 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-nonbasic-1 (noun) "Finds relationships that all members of the nonbasic level category 'noun' are involved in and the other objects that are also in the relation." (let (relations) ;; we leave the 'lex-' arcs in to exclude "rel ISA" info (setf relations #3! ((find (compose lex- rel- ! object1 object1- ! object2 lex) ~noun (compose lex- rel- ! object1 object1- ! rel) "ISA" (compose lex- rel- ! cq- ! ant ! object2 lex) ~noun))) (mapcar #'(lambda (rel) (obj-rel-nonbasic-1 noun rel) relations)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-nonbasic-1 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-nonbasic-1 (noun relation) "Finds the objects that are involved in teh specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! object1 object1- ! rel) "ISA" (compose object2- ! cq- ! ant ! object2 lex) ~noun (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-basic (noun) "Finds properties belong to all members of the class 'noun', where 'noun' is a basic level category." #3! ((find (compose property- ! object member- ! class lex) ~noun (compose property- ! cq- ! &ant ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-nonbasic (noun) "Finds properties belong to all members of the class 'noun', where 'noun' is a nonbasic level category." #3! ((find (compose property- ! object object1- ! object2 lex) ~noun (compose property- ! cq- ! &ant ! object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-relation-basic-1 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-relation-basic-1 (noun) "Finds relationships that all members of the basic level category 'noun' are involved in and the other objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object1 member- ! class lex) ~noun (compose lex- rel- ! cq- ! &ant ! class lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-&-rel-basic-1 noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-&-rel-basic-1 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-&-rel-basic-1 (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 member- ! class lex) ~noun (compose object2- ! cq- ! &ant ! class lex) ~noun (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-relation-nonbasic-1 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-relation-nonbasic-1 (noun) "Finds relationships that all members of the nonbasic level category 'noun' are involved in and the other objects that are also in the relation." (let (relations object) (setf relations #3! ((find (compose lex- rel- ! object1 object1- ! object2 lex) ~noun (compose lex- rel- ! object1 object1- ! rel) "ISA" (compose lex- rel- ! cq- ! &ant ! object2 lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-&-rel-nonbasic-1 noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-&-rel-nonbasic-1 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-&-rel-nonbasic-1 (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! object1 object1- ! rel) "ISA" (compose object2- ! cq- ! &ant ! object2 lex) ~noun (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-basic-2 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-basic-2 (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (basic level) objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq ! object2 lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-basic-2 noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-basic-2 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-basic-2 (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose class- ! member object1- ! object2 lex) ~noun (compose class- ! ant- ! cq ! object2 lex) ~noun (compose class- ! member object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-nonbasic-2 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-nonbasic-2 (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (nonbasic level) objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq ! object2 lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-nonbasic-2 noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-nonbasic-2 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-nonbasic-2 (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! ant- ! cq ! object2 lex) ~noun (compose object2- ! rel) "ISA" (compose object2- ! object1 object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-relation-basic-2 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-relation-basic-2 (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (basic level) objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq ! object2 lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-&-rel-basic-2 noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-&-rel-basic-2 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-&-rel-basic-2 (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose class- ! member object1- ! object2 lex) ~noun (compose class- ! &ant- ! cq ! object2 lex) ~noun (compose class- ! member object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-relation-nonbasic-2 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-relation-nonbasic-2 (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (nonbasic level) objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq ! object2 lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-&-rel-nonbasic-2 noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-&-rel-nonbasic-2 ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-&-rel-nonbasic-2 (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! &ant- ! cq ! object2 lex) ~noun (compose object2- ! rel) "ISA" (compose object2- ! object1 object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-basic-1-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-basic-1-presume (noun) "Finds relationships that all members of the basic level category 'noun' are presumably involved in and the other objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object1 member- ! class lex) ~noun (compose lex- rel- ! object- cq- ! ant ! class lex) ~noun (compose lex- rel- ! object- mode lex) "presumably"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-basic-1-oresume noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-basic-1-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-basic-1-presume (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 member- ! class lex) ~noun (compose object2- ! object- cq- ! ant ! class lex) ~noun (compose object2- ! object- mode lex) "presumably" (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-nonbasic-1-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-nonbasic-1-presume (noun) "Finds relationships that all members of the nonbasic level category 'noun' are presumably involved in and the other objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object1 object1- ! object2 lex) ~noun (compose lex- rel- ! object1 object1- ! rel) "ISA" (compose lex- rel- ! object- cq- ! ant ! object2 lex) ~noun (compose lex- rel- ! object- mode lex) "presumably"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-nonbasic-1-presume noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-nonbasic-1-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-nonbasic-1-presume (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! object1 object1- ! rel) "ISA" (compose object2- ! object- cq- ! ant ! object2 lex) ~noun (compose object2- ! object- mode lex) "presumably" (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-basic-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-basic-presume (noun) "Finds properties that presumably belong to all members of the class 'noun', where 'noun' is a basic level category." #3! ((find (compose property- ! object member- ! class lex) ~noun (compose property- ! object- mode lex) "presumably" (compose property- ! object- cq- ! ant ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-nonbasic-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-nonbasic-presume (noun) "Finds properties that presumably belong to all members of the class 'noun', where 'noun' is a nonbasic level category." #3! ((find (compose property- ! object object1- ! object2 lex) ~noun (compose property- ! object- mode lex) "presumably" (compose property- ! object- cq- ! ant ! object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-relation-basic-1-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-relation-basic-1-presume (noun) "Finds relationships that all members of the basic level category 'noun' are presumably involved in and the other objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object1 member- ! class lex) ~noun (compose lex- rel- ! object- cq- ! &ant ! class lex) ~noun (compose lex- rel- ! object- mode lex) "presumably"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-&-rel-basic-1-presume noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-&-rel-basic-1-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-&-rel-basic-1-presume (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 member- ! class lex) ~noun (compose object2- ! object- cq- ! &ant ! class lex) ~noun (compose object2- ! object- mode lex) "presumably" (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-relation-nonbasic-1-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-relation-nonbasic-1-presume (noun) "Finds relationships that all members of the nonbasic level category 'noun' are presumably involved in and the other objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object1 object1- ! object2 lex) ~noun (compose lex- rel- ! object1 object1- ! rel) "ISA" (compose lex- rel- ! object- cq- ! &ant ! object2 lex) ~noun (compose lex- rel- ! object- mode lex) "presumably"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-&-rel-nonbasic-1-presume noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-&-rel-nonbasic-1-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-&-rel-nonbasic-1-presume (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! object1 object1- ! rel) "ISA" (compose object2- ! object- cq- ! &ant ! object2 lex) ~noun (compose object2- ! object- mode lex) "presumably" (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-basic-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-basic-presume (noun) "Finds properties that presumably belong to all members of the class 'noun', where 'noun' is a basic level category." #3! ((find (compose property- ! object member- ! class lex) ~noun (compose property- ! object- mode lex) "presumably" (compose property- ! object- cq- ! &ant ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-nonbasic-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-nonbasic-presume (noun) "Finds properties that presumably belong to all members of the class 'noun', where 'noun' is a nonbasic level category." #3! ((find (compose property- ! object object1- ! object2 lex) ~noun (compose property- ! object- mode lex) "presumably" (compose property- ! object- cq- ! &ant ! object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-basic-2-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-basic-2-presume (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (basic level) objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq object ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq mode lex) "presumably"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-basic-2-presume noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-basic-2-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-basic-2-presume (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose class- ! member object1- ! object2 lex) ~noun (compose class- ! ant- ! cq object ! object2 lex) ~noun (compose class- ! ant- ! cq mode lex) "presumably" (compose class- ! member object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-nonbasic-2-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-nonbasic-2-presume (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (nonbasic level) objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq object ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq mode lex) "presumably"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-nonbasic-2-presume noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-nonbasic-2-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-nonbasic-2-presume (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! ant- ! cq object ! object2 lex) ~noun (compose object2- ! ant- ! cq mode lex) "presumably" (compose object2- ! rel) "ISA" (compose object2- ! object1 object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-relation-basic-2-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-relation-basic-2-presume (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (basic level) objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq object ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq mode) "presumably"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-&-rel-basic-2-presume noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-&-rel-basic-2-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-&-rel-basic-2-presume (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose class- ! member object1- ! object2 lex) ~noun (compose class- ! &ant- ! cq object ! object2 lex) ~noun (compose class- ! &ant- ! cq mode lex) "presumably" (compose class- ! member object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-&-relation-nonbasic-2-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-&-relation-nonbasic-2-presume (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (nonbasic level) objects that are also in the relation." (let (relations) (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq object ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq mode lex) "presumably"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-&-rel-nonbasic-2-presume noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-&-rel-nonbasic-2-presume ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-&-rel-nonbasic-2-presume (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! object2 lex) ~noun (compose object2- ! &ant- ! cq object ! object2 lex) ~noun (compose object2- ! &ant- ! cq mode lex) "presumably" (compose object2- ! rel) "ISA" (compose object2- ! object1 object1- ! rel) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-basic-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-basic-indiv (noun) "Finds properties that presumably belong to all members of the class 'noun', where 'noun' is a nonbasic level category." #3! ((find (compose property- ! object object1- ! object2 lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-nonbasic-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-nonbasic-indiv (noun) "Finds properties that presumably belong to all members of the class 'noun', where 'noun' is a nonbasic level category." #3! ((find (compose property- ! object member- ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-basic-1-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-basic-1-indiv (noun) "Finds relationships that one or more members of the basic level category 'noun' are involved in and the other objects that are also in the relation." (let (relations) ;; we leave the 'lex-' in here so we don't get "ISA" relations (setf relations #3! ((find (compose lex- rel- ! object1 member- ! class lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-basic-1-indiv noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-basic-1-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-basic-1-indiv (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! rel lex lex- rel- ! object1 member- ! class lex) ~noun (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-nonbasic-1-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-nonbasic-1-indiv (noun) "Finds relationships that one or more members of the nonbasic level category 'noun' are involved in and the other objects that are also in the relation." (let (relations) ;; we leave the 'lex-' in here so we don't get "ISA" relations (setf relations #3! ((find (compose lex- rel- ! object1 object1- ! object2 lex) ~noun (compose lex- rel- ! object1 object1- ! rel) "ISA"))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-nonbasic-1-indiv noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-nonbasic-1-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-nonbasic-1-indiv (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! rel lex lex- rel- ! object1 object1- ! object2 lex) ~noun (compose object2- ! rel lex lex- rel- ! object1 object1- ! rel) "ISA" (compose object2- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-basic-2-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-basic-2-indiv (noun) "Finds relationships that some 'noun's are involved in (where the noun is the object2) and the other (basic level) objects that are also in the relation." (let (relations) ;; we leave the 'lex-' in here so we don't get "ISA" relations (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-basic-2-indiv noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-basic-2-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-basic-2-indiv (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose class- ! member object1- ! rel lex lex- rel- ! object2 lex) ~noun (compose class- ! member object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: prop-relation-nonbasic-2-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun prop-relation-nonbasic-2-indiv (noun) "Finds relationships that 'noun's are involved in (where the noun is the object2) and the other (nonbasic level) objects that are also in the relation." (let (relations) ;; we leave the 'lex-' in here so we don't get "ISA" relations (setf relations #3! ((find (compose lex- rel- ! object2 lex) ~noun (compose lex- rel- ! object1 forall- ! cq ! object2 lex) ~noun))) ;; find the objects associated with each of the relations (mapcar #'(lambda (rel) (obj-rel-nonbasic-2-indiv noun rel)) relations))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: obj-rel-nonbasic-2-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun obj-rel-nonbasic-2-indiv (noun relation) "Finds the objects that are involved in the specified relation with 'noun' and returns a list consisting of the relation followed by the objects." (cons relation #3! ((find (compose object2- ! object1 object1- ! rel lex lex- rel- ! object2 lex) ~noun (compose object2- ! ant- ! cq ! rel lex lex- rel- ! object2 lex) ~noun (compose object2- ! rel) "ISA" (compose object2- ! object1 object1- ! rel lex) ~relation)))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: findProperties ;;; input: a noun to be defined ;;; output: a list containing any general properties that are known to ;;; pertain to s as a class. ;;; modified: mkb 2002 ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------ (defun findProperties (noun) "Finds properties that are known to belong to all things which are members of the class 'noun'." (let (properties) (cond ;; property of a basic ctgy. ((and (setf properties (append properties (prop-basic noun))) *dmode*) properties) ;; property of a non-basic ctgy. ((and (setf properties (append properties (prop-nonbasic noun))) *dmode*) properties) ;; property of a basic ctgy, &-rule. ((and (setf properties (append properties (prop-&-basic noun))) *dmode*) properties) ;; property of a nonbasic ctgy, &-rule. ((and (setf properties (append properties (prop-&-nonbasic noun))) *dmode*) properties) ;; relation with basic 'noun' as object1 ((and (setf properties (append properties (prop-relation-basic-1 noun))) *dmode*) properties) ;; relation with nonbasic 'noun' as object1 ((and (setf properties (append properties (prop-relation-nonbasic-1 noun))) *dmode*) properties) ;; relation with basic 'noun' as object1, &-rule ((and (setf properties (append properties (prop-&-relation-basic-1 noun))) *dmode*) properties) ;; relation with nonbasic 'noun' as object1, &-rule ((and (setf properties (append properties (prop-&-relation-nonbasic-1 noun))) *dmode*) properties) ;; relation with basic level object1, noun as object2 ((and (setf properties (append properties (prop-relation-basic-2 noun))) *dmode*) properties) ;; relation with nonbasic level object1, noun as object2 ((and (setf properties (append properties (prop-relation-nonbasic-2 noun))) *dmode*) properties) ;; relation with basic level object1, noun as object2, &-rule ((and (setf properties (append properties (prop-&-relation-basic-2 noun))) *dmode*) properties) ;; relation with nonbasic level object1, noun as object2, &-rule ((and (setf properties (append properties (prop-&-relation-nonbasic-2 noun))) *dmode*) properties) ;; if we are in teaching mode return the info we have accumulated, if we are in ;; definition mode return nil (t properties)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: findProbableProperties ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findProbableProperties (noun) "Finds properties that are presumed to belong to all things which are members of the class 'noun'." (let (properties) (cond ;; presumable property of a basic ctgy. ((and (setf properties (append properties (prop-basic-presume noun))) *dmode*) properties) ;; presumable property of a nonbasic ctgy. ((and (setf properties (append properties (prop-nonbasic-presume noun))) *dmode*) properties) ;; presumable property of a basic category, &-rule ((and (setf properties (append properties (prop-&-basic-presume noun))) *dmode*) properties) ;; presumable property of a nonbasic category, &-rule ((and (setf properties (append properties (prop-&-nonbasic-presume noun))) *dmode*) properties) ;; presumable relation with basic 'noun' as object1, object2 is not in any category ((and (setf properties (append properties (prop-relation-basic-1-presume noun))) *dmode*) properties) ;; presumable relation with nonbasic 'noun' as object1, ;; object2 is not in any category ((and (setf properties (append properties (prop-relation-nonbasic-1-presume noun))) *dmode*) properties) ;; presumable relation with basic 'noun' as object1, ;; object2 is not in any category, &-rule ((and (setf properties (append properties (prop-&-relation-basic-1-presume noun))) *dmode*) properties) ;; presumable relation with nonbasic 'noun' as object1, ;; object2 is not in any category, &-rule ((and (setf properties (append properties (prop-&-relation-nonbasic-1-presume noun))) *dmode*) properties) ;; presumable relation with basic level object1, noun as object2 ((and (setf properties (append properties (prop-relation-basic-2-presume noun))) *dmode*) properties) ;; presumable relation with nonbasic level object1, noun as object2 ((and (setf properties (append properties (prop-relation-nonbasic-2-presume noun))) *dmode*) properties) ;; presumable relation with basic level object1, noun as object2 ((and (setf properties (append properties (prop-&-relation-basic-2-presume noun))) *dmode*) properties) ;; presumable relation with nonbasic level object1, noun as object2 ((and (setf properties (append properties (prop-&-relation-nonbasic-2-presume noun))) *dmode*) properties) ;; if we are in teaching mode return the info we have accumulated, if we are in ;; definition mode return nil (t properties)))) ;;;-------------------------------------------------------------------------- ;;; ;;; function: findPossibleProperties ;;; input: a noun to be defined ;;; output: a list of properties attributed to any object of type ;;; modified: mkb 2002 ;;; modified: stn 2002 ;;;-------------------------------------------------------------------------- (defun findPossibleProperties (noun) "Finds properties that belong to at least one thing which is a member of the class 'noun'." (let (properties) (cond ;; property belonging to a 'noun' where 'noun' is basic level ((and (setf properties (append properties (prop-basic-indiv noun))) *dmode*) properties) ;; property belonging to a 'noun' where 'noun' is nonbasic level ((and (setf properties (append properties (prop-nonbasic-indiv noun))) *dmode*) properties) ;; relation with basic 'noun' as object1 ((and (setf properties (append properties (prop-relation-basic-1-indiv noun))) *dmode*) properties) ;; relation with nonbasic 'noun' as object1 ((and (setf properties (append properties (prop-relation-nonbasic-1-indiv noun))) *dmode*) properties) ;; relation with basic level object1, noun as object2 ((and (setf properties (append properties (prop-relation-basic-2-indiv noun))) *dmode*) properties) ;; relation with nonbasic level object1, noun as object2 ((and (setf properties (append properties (prop-relation-nonbasic-2-indiv noun))) *dmode*) properties) ;; if we are in teaching mode return the info we have accumulated, if we are in ;; definition mode return nil (t properties)))) ;;;------------------------------------------------------------------------------- ;;; SPATIAL INFORMATION SECTION ;;;------------------------------------------------------------------------------- ;;;------------------------------------------------------------------------------- ;;; ;;; function: findSpatial ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findSpatial (noun) "If 'noun' is a location, find things that can occur in the location or that are true in the location" (let (spatialInfo) (cond ;; noun is a place where some individual is a member of a basic level class ((and (setf spatialInfo (append spatialInfo (loc-cls-basic noun))) *dmode*) spatialInfo) ;; noun is a place where some individual is a member of a basic level class ((and (setf spatialInfo (append spatialInfo (loc-basic-cls-basic noun))) *dmode*) spatialInfo) ;; noun is a place where some individual is a member of a basic level class ((and (setf spatialInfo (append spatialInfo (loc-nonbasic-cls-basic noun))) *dmode*) spatialInfo) ;; noun is a place where some individual is a member of a nonbasic level class ((and (setf spatialInfo (append spatialInfo (loc-cls-nonbasic noun))) *dmode*) spatialInfo) ;; noun is a place where some individual is a member of a nonbasic level class ((and (setf spatialInfo (append spatialInfo (loc-basic-cls-nonbasic noun))) *dmode*) spatialInfo) ;; noun is a place where some individual is a member of a nonbasic level class ((and (setf spatialInfo (append spatialInfo (loc-nonbasic-cls-nonbasic noun))) *dmode*) spatialInfo) ;; noun is a place where something is a part of a whole ((and (setf spatialInfo (append spatialInfo (loc-str noun))) *dmode*) spatialInfo) ;; noun is a place where something is a part of a whole ((and (setf spatialInfo (append spatialInfo (loc-basic-str noun))) *dmode*) spatialInfo) ;; noun is a place where something is a part of a whole ((and (setf spatialInfo (append spatialInfo (loc-nonbasic-str noun))) *dmode*) spatialInfo) ;; noun is a place where some action (with no object) takes place ((and (setf spatialInfo (append spatialInfo (loc-act noun))) *dmode*) spatialInfo) ;; noun is a (basic level) place where some action (with no object) takes place ((and (setf spatialInfo (append spatialInfo (loc-basic-act noun))) *dmode*) spatialInfo) ;; noun is a (nonbasic level) place where some action (with no object) takes place ((and (setf spatialInfo (append spatialInfo (loc-nonbasic-act noun))) *dmode*) spatialInfo) ;; noun is a place where some action (with an object) takes place ((and (setf spatialInfo (append spatialInfo (loc-act-obj noun))) *dmode*) spatialInfo) ;; noun is a place where some action (with an object) takes place ((and (setf spatialInfo (append spatialInfo (loc-basic-act-obj noun))) *dmode*) spatialInfo) ;; noun is a place where some action (with an object) takes place ((and (setf spatialInfo (append spatialInfo (loc-nonbasic-act-obj noun))) *dmode*) spatialInfo) ;; noun is a place where some individual has a property ((and (setf spatialInfo (append spatialInfo (loc-prop noun))) *dmode*) spatialInfo) ;; noun is a place where some individual has a property ((and (setf spatialInfo (append spatialInfo (loc-basic-prop noun))) *dmode*) spatialInfo) ;; noun is a place where some individual has a property ((and (setf spatialInfo (append spatialInfo (loc-nonbasic-prop noun))) *dmode*) spatialInfo) ;; noun is a place where some relation exists ((and (setf spatialInfo (append spatialInfo (loc-rel noun))) *dmode*) spatialInfo) ;; noun is a place where some relation exists ((and (setf spatialInfo (append spatialInfo (loc-basic-rel noun))) *dmode*) spatialInfo) ;; noun is a place where some relation exists ((and (setf spatialInfo (append spatialInfo (loc-nonbasic-rel noun))) *dmode*) spatialInfo) ;; noun is a place where someone owns something ((and (setf spatialInfo (append spatialInfo (loc-own noun))) *dmode*) spatialInfo) ;; noun is a place where someone owns something ((and (setf spatialInfo (append spatialInfo (loc-basic-own noun))) *dmode*) spatialInfo) ;; noun is a place where someone owns something ((and (setf spatialInfo (append spatialInfo (loc-nonbasic-own noun))) *dmode*) spatialInfo) ;; if we are in teaching mode return the info we have accumulated, if we are in ;; definition mode return nil (t spatialInfo) ))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-cls-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-cls-basic (noun) "Find things that are members of a (basic level) class in the location 'noun'" (let (mem cls) (setf mem #3! ((find (compose member- ! object- ! location lex) ~noun))) (setf cls #3! ((find (compose class- ! object- ! location lex) ~noun))) (if (and mem cls) (list (append mem cls)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-basic-cls-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-basic-cls-basic (noun) "Find things that are members of a (basic) class in the (basic) location 'noun'" (let (mem cls) (setf mem #3! ((find (compose member- ! object- ! location member- ! class lex) ~noun))) (setf cls #3! ((find (compose class- ! object- ! location member- ! class lex) ~noun))) (if (and mem cls) (list (append mem cls)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-nonbasic-cls-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-nonbasic-cls-basic (noun) "Find things that are members of a (basic) class in the (nonbasic) location 'noun'" (let (mem cls) (setf mem #3! ((find (compose member- ! object- ! location object1- ! object2 lex) ~noun (compose member- ! object- ! location object1- ! rel) "ISA"))) (setf cls #3! ((find (compose class- ! object- ! location object1- ! object2 lex) ~noun (compose class- ! object- ! location object1- ! rel) "ISA"))) (if (and mem cls) (list (append mem cls)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-cls-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-cls-nonbasic (noun) "Find things that are members of a (nonbasic level) class in the location 'noun'" (let (mem cls) (setf mem #3! ((find (compose object1- ! object- ! location lex) ~noun (compose object1- ! rel) "ISA"))) (setf cls #3! ((find (compose object2- ! object- ! location lex) ~noun (compose object2- ! rel) "ISA"))) (if (and mem cls) (list (append mem cls)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-basic-cls-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-basic-cls-nonbasic (noun) "Find things that are members of a (nonbasic) class in the (basic) location 'noun'" (let (mem cls) (setf mem #3! ((find (compose object1- ! object- ! location member- ! class lex) ~noun (compose object1- ! rel) "ISA"))) (setf cls #3! ((find (compose object2- ! object- ! location member- ! class lex) ~noun (compose object2- ! rel) "ISA"))) (if (and mem cls) (list (append mem cls)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-nonbasic-cls-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-nonbasic-cls-nonbasic (noun) "Find things that are members of a (nonbasic) class in the (nonbasic) location 'noun'" (let (mem cls) (setf mem #3! ((find (compose object1- ! object- ! location object1- ! object2 lex) ~noun (compose object1- ! rel) "ISA" (compose object1- ! object- ! location object1- ! rel) "ISA"))) (setf cls #3! ((find (compose object2- ! object- ! location object1- ! object2 lex) ~noun (compose object2- ! rel) "ISA" (compose object2- ! object- ! location object1- ! rel) "ISA"))) (if (and mem cls) (list (append mem cls)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-str ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-str (noun) "Find things that are parts of a whole in the location 'noun'" (let (prt whl) (setf prt #3! ((find (compose part- ! object- ! location lex) ~noun))) (setf whl #3! ((find (compose whole- ! object- ! location lex) ~noun))) (if (and whl prt) (list (append whl prt)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-basic-str ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-basic-str (noun) "Find things that are parts of a whole in the (basic) location 'noun'" (let (prt whl) (setf prt #3! ((find (compose part- ! object- ! location member- ! class lex) ~noun))) (setf whl #3! ((find (compose whole- ! object- ! location member- ! class lex) ~noun))) (if (and whl prt) (list (append whl prt)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-nonbasic-str ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-nonbasic-str (noun) "Find things that are parts of a whole in the (nonbasic) location 'noun'" (let (prt whl) (setf prt #3! ((find (compose part- ! object- ! location object1- ! object2 lex) ~noun))) (setf whl #3! ((find (compose whole- ! object- ! location object1- ! object2 lex) ~noun (compose whole- ! object- ! location object1- ! rel) "ISA"))) (if (and whl prt) (list (append whl prt)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-act ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-act (noun) "Find agents and the actions that they perform in the location 'noun'." (let (ag act) (setf ag #3! ((find (compose agent- object- ! location lex) ~noun))) ;; we use a lex arc here to be sure that we are not picking up ag-act-action-object info (setf act #3! ((find (compose lex- act- object- ! location lex) ~noun))) (if (and ag act) (list (append ag act)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-basic-act ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-basic-act (noun) "Find agents and the actions that they perform in the (basic level) location 'noun'." (let (ag act) (setf ag #3! ((find (compose agent- object- ! location member- ! class lex) ~noun))) ;; we use a lex arc here to be sure that we are not picking up ag-act-action-object info (setf act #3! ((find (compose lex- act- object- ! location member- ! class lex) ~noun))) (if (and ag act) (list (append ag act)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-nonbasic-act ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-nonbasic-act (noun) "Find agents and the actions that they perform in the (nonbasic level) location 'noun'." (let (ag act) (setf ag #3! ((find (compose agent- object- ! location object1- ! object2 lex) ~noun))) ;; we use a lex arc here to be sure that we are not picking up ag-act-action-object info (setf act #3! ((find (compose lex- act- object- ! location object1- ! object2 lex) ~noun (compose lex- act- object- ! location object1- ! rel) "ISA"))) (if (and ag act) (list (append ag act)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-act-obj ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-act-obj (noun) "Find agents, the actions that they perform in the location 'noun', and the objects of the actions." (let (ag act obj) (setf ag #3! ((find (compose agent- object- ! location lex) ~noun))) (setf act #3! ((find (compose action- act- object- ! location lex) ~noun))) (setf obj #3! ((find (compose object- act- object- ! location lex) ~noun))) (if (and ag act obj) (list (append ag act obj)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-basic-act-obj ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-basic-act-obj (noun) "Find agents, the actions that they perform in the (basic) location 'noun', and the objects of the actions." (let (ag act obj) (setf ag #3! ((find (compose agent- object- ! location member- ! class lex) ~noun))) (setf act #3! ((find (compose action- act- object- ! location member- ! class lex) ~noun))) (setf obj #3! ((find (compose object- act- object- ! location member- ! class lex) ~noun))) (if (and ag act obj) (list (append ag act obj)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-nonbasic-act-obj ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-nonbasic-act-obj (noun) "Find agents, the actions that they perform in the (nonbasic) location 'noun', and the objects of the actions." (let (ag act obj) (setf ag #3! ((find (compose agent- object- ! location object1- ! object2 lex) ~noun (compose agent- object- ! location object1- ! rel) "ISA"))) (setf act #3! ((find (compose action- act- object- ! location object1- ! object2 lex) ~noun (compose action- act- object- ! location object1- ! rel) "ISA"))) (setf obj #3! ((find (compose object- act- object- ! location object1- ! object2 lex) ~noun (compose object- act- object- ! location object1- ! rel) "ISA"))) (if (and ag act obj) (list (append ag act obj)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-prop ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-prop (noun) "Find objects and their properties which occur in the location 'noun'." (let (obj prop) (setf obj #3! ((find (compose object- ! object- ! location lex) ~noun))) (setf prop #3! ((find (compose property- ! object- ! location lex) ~noun))) (if (and obj prop) (list (append obj prop)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-basic-prop ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-basic-prop (noun) "Find objects and their properties which occur in the (basic level) location 'noun'." (let (obj prop) (setf obj #3! ((find (compose object- ! object- ! location member- ! class lex) ~noun))) (setf prop #3! ((find (compose property- ! object- ! location member- ! class lex) ~noun))) (if (and obj prop) (list (append obj prop)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-nonbasic-prop ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-nonbasic-prop (noun) "Find objects and their properties which occur in the (nonbasic level) location 'noun'." (let (obj prop) (setf obj #3! ((find (compose object- ! object- ! location object1- ! object2 lex) ~noun (compose object- ! object- ! location object1- ! rel) "ISA"))) (setf prop #3! ((find (compose property- ! object- ! location object1- ! object2 lex) ~noun (compose property- ! object- ! location object1- ! rel) "ISA"))) (if (and obj prop) (list (append obj prop)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-rel ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-rel (noun) "Find objects that have some relationship in the location 'noun'." (let (obj1 relation obj2) (setf obj1 #3! ((find (compose object1- object- ! location lex) ~noun))) (setf obj2 #3! ((find (compose object2- object- ! location lex) ~noun))) (setf relation #3! ((find (compose rel- object- ! location lex) ~noun))) (if (and obj1 relation obj2) (list (append obj1 relation obj2)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-basic-rel ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-basic-rel (noun) "Find objects that have some relationship in the (basic level) location 'noun'." (let (obj1 relation obj2) (setf obj1 #3! ((find (compose object1- object- ! location member- ! class lex) ~noun))) (setf obj2 #3! ((find (compose object2- object- ! location member- ! class lex) ~noun))) (setf relation #3! ((find (compose rel- object- ! location member- ! class lex) ~noun))) (if (and obj1 relation obj2) (list (append obj1 relation obj2)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-nonbasic-rel ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-nonbasic-rel (noun) "Find objects that have some relationship in the (nonbasic level) location 'noun'." (let (obj1 relation obj2) (setf obj1 #3! ((find (compose object1- object- ! location object1- ! object2 lex) ~noun (compose object1- object- ! location object1- ! rel) "ISA"))) (setf obj2 #3! ((find (compose object2- object- ! location object1- ! object2 lex) ~noun (compose object2- object- ! location object1- ! rel) "ISA"))) (setf relation #3! ((find (compose rel- object- ! location object1- ! object2 lex) ~noun (compose rel- object- ! location object1- ! rel) "ISA"))) (if (and obj1 relation obj2) (list (append obj1 relation obj2)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-own ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-own (noun) "Find owners and the things they own in the location 'noun'." (let (owner prpty) (setf owner #3! ((find (compose possessor- ! object- ! location lex) ~noun))) ;; I assume that the nature of the property owned by a possesor is best described ;; by the 'rel' arc in the object-rel-possessor case frame (e.g. given ;; object-pyewacket-rel-cat-possessor-person it is better to say "a person owns a cat" ;; than "a person owns pyewacket" (setf prpty #3! ((find (compose rel- ! object- ! location lex) ~noun))) (if (and owner prpty) (list (append owner prpty)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-basic-own ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-basic-own (noun) "Find owners and the things they own in the (basic level) location 'noun'." (let (owner prpty) (setf owner #3! ((find (compose possessor- ! object- ! location member- ! class lex) ~noun))) (setf prpty #3! ((find (compose rel- ! object- ! location member- ! class lex) ~noun))) (if (and owner prpty) (list (append owner prpty)) nil))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: loc-nonbasic-own ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun loc-nonbasic-own (noun) "Find owners and the things they own in the (nonbasic level) location 'noun'." (let (owner prpty) (setf owner #3! ((find (compose possessor- ! object- ! location object1- ! object2 lex) ~noun (compose possessor- ! object- ! location object1- ! rel) "ISA"))) (setf prpty #3! ((find (compose rel- ! object- ! location object1- ! object2 lex) ~noun (compose rel- ! object- ! location object1- ! rel) "ISA"))) (if (and owner prpty) (list (append owner prpty)) nil))) ;;;------------------------------------------------------------------------------- ;;; OWNERSHIP SECTION ;;;------------------------------------------------------------------------------- ;;;------------------------------------------------------------------------------- ;;; ;;; function: owner-basic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun owner-basic (noun) "Finds things which own a 'noun' where the possessor is a member of a basic level category." #3! ((find (compose class- ! member possessor- ! rel lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: owner-nonbasic ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun owner-nonbasic (noun) "Finds things which own a 'noun' where the possessor is a member of a basic level category." #3! ((find (compose object2- ! object1 possessor- ! rel lex) ~noun (compose object2- ! rel) "ISA"))) ;;;-------------------------------------------------------------------------- ;;; ;;; function: findOwners ;;; input: a noun to be defined ;;; output: a list of those things which possess any object of type ;;; ;;;-------------------------------------------------------------------------- (defun findOwners (noun) "Find things that can own a 'noun'." (let (owners) (cond ;; find owners of 'noun's who are members of basic level categories ((and (setf owners (append owners (owner-basic noun))) *dmode*) owners) ;; find owners of 'noun's who are members of nonbasic level categories ((and (setf owners (append owners (owner-nonbasic noun))) *dmode*) owners) ;; if we are in teaching mode return the info we have accumulated, if we are in ;; definition mode return nil (t owners)))) ;;;------------------------------------------------------------------------------ ;;; INDIVIDUALS SECTION ;;;------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: findNamedIndividuals ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun findNamedIndividuals (noun) "Find the proper names of individuals who are members of the class noun." (let (individuals) (cond ;; find basic level individuals ((and (setf individuals (append individuals (basic-named-indiv noun))) *dmode*) individuals) ;; find nonbasic level individuals ((and (setf individuals (append individuals (nonbasic-named-indiv noun))) *dmode*) individuals) ;; If we are in teaching mode, return the info we found above. If we are in ;; definition mode, return nil. (t individuals)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: basic-named-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun basic-named-indiv (noun) "Finds individuals with proper names who are members of the basic level class noun." #3! ((find (compose proper-name- ! object member- ! class lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: nonbasic-named-indiv ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun nonbasic-named-indiv (noun) "Finds individuals with proper names who are members of the nonbasic level class noun." #3! ((find (compose proper-name- ! object object1- ! object2 lex) ~noun (compose proper-name- ! object object1- ! rel) "ISA"))) ;;;------------------------------------------------------------------------------ ;;; AGENTS WHO ACT ON 'NOUN'S SECTION ;;;------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: agent-basic-object ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun agent-basic-object (noun) "Find basic level agents who perform actions on basic level 'noun's and the actions that they perform." (let (agents) (setf agents #3! ((find (compose agent- ! act object member- ! class lex) ~noun))) ;; now find the actions that each agent performs on 'noun's. (mapcar #'(lambda (ag) (action-basic-object noun ag)) agents) )) ;;;------------------------------------------------------------------------------- ;;; ;;; function: agent-nonbasic-object ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun agent-nonbasic-object (noun) "Find basic level agents who perform actions on nonbasic level 'noun's and the actions that they perform." (let (agents) (setf agents #3! ((find (compose agent- ! act object object1- ! object2 lex) ~noun (compose agent- ! act object object1- ! rel) "ISA"))) ;; find the actions that each agent performs on 'noun's. (mapcar #'(lambda (ag) (action-nonbasic-object noun ag)) agents) )) ;;;------------------------------------------------------------------------------- ;;; ;;; function: action-basic-object ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun action-basic-object (noun ag) "Find actions performed on basic level 'noun's by 'ag'." ;; The act- ! act goes up and down the same arc, we need to do this because we ;; only want to find actions that Cassie believes. (cons ag #3! ((find (compose action- act- ! act object member- ! class lex) ~noun (compose action- act- ! agent) ~ag)))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: action-nonbasic-object ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun action-nonbasic-object (noun ag) "Find actions performed on nonbasic level 'noun's by 'ag'." ;; The act- ! act goes up and down the same arc, we need to do this because we ;; only want to find actions that Cassie believes. (cons ag #3! ((find (compose action- act- ! act object object1- ! object2 lex) ~noun (compose action- act- ! act object object1- ! rel) "ISA" (compose action- act- ! agent) ~ag)))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: findAgents ;;; input : a noun to be defined ;;; returns : a list of the agent(s) and act(s) for which ;;; serves as object in an agent-act-object case frame. ;;; ;;; modified: mkb 04/2002 ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------ (defun findAgents (noun) "Find agents who perform actions on 'noun's and the actions that they perform." (let (agents) (cond ((and (setf agents (append agents (agent-basic-object noun))) *dmode*) agents) ((and (setf agents (append agents (agent-nonbasic-object noun))) *dmode*) agents) ;; if we are in teaching mode return the info we have accumulated, else return nil (t agents) ))) ;;;------------------------------------------------------------------------------ ;;; SYNONYMS SECTION ;;;------------------------------------------------------------------------------ ;;;------------------------------------------------------------------------------- ;;; ;;; function: syn-syn ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun syn-syn (noun) "Finds things which are explicitly marked as synonyms of 'noun'." #3! ((find (compose synonym- ! synonym lex) ~noun))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: syn-sub-sup ;;; created: stn 2002 ;;;------------------------------------------------------------------------------- (defun syn-sub-sup (superclasses) "Finds subclasses of the given list of superclasses." #3! ((find (compose subclass- ! superclass lex) ~superclasses))) ;;;----------------------------------------------------------------------------- ;;; ;;; function: findSynonyms ;;; input: a noun to be defined ;;; output: a list of probable synonyms of ;;; calls: compare-all functions ;;; written: kae ??/??/92 ;;; modified: kae 05/12/94 ;;; modified: stn 2002 ;;;----------------------------------------------------------------------------- (defun findSynonyms (noun structuralElements superclasses owners) "Find words that are specifically marked as synonyms of 'noun' or have definitions which are similar to the definition of 'noun'." (let (possibleSynonyms synonyms) ;; find things that are explicitly labeled as synonyms of 'noun'. (setf synonyms (syn-syn noun)) (setf synonyms (removeElement noun synonyms)) ;; find things that are subclasses of the same superclasses as 'noun', e.g. if we ;; are trying to define 'cat', and we know that cats and dogs are both subclasses of ;; mammal, then this will find 'dog'. (setf possibleSynonyms (syn-sub-sup superclasses)) ;; since 'noun' is itself a subclass of its superclass, remove 'noun' from the list (setf possibleSynonyms (removeElement noun possibleSynonyms)) ;; superclasses are not synonyms, they are class inclusions, so if any snuck into the ;; list of possible synonyms, get rid of them. (setf possibleSynonyms (set-difference possibleSynonyms superclasses)) ;; explicit synonyms are obviously not possible synonyms -- they are definite synonyms, ;; so we need to get rid of them (setf possibleSynonyms (set-difference possibleSynonyms synonyms)) ;; get rid of any possible synonyms whose superclasses are not sufficiently similar ;; to the superclasses of 'noun' (setf possibleSynonyms (eliminateDissimilarClasses superclasses possibleSynonyms)) ;; get rid of any possible synonyms whose structural features are not sufficiently ;; similar to the structural features of 'noun' (setf possibleSynonyms (eliminateDissimilarStructure structuralElements possibleSynonyms)) ;; get rid of any possible synonyms whose functions are not sufficiently similar ;; to the functions of 'noun' ;;; (setf possibleSynonyms (eliminateDissimilarFunctions functions possibleSynonyms nil)) ;; get rid of any possible synonyms whose ownership relations are not sufficiently ;; similar to the ownership relations of 'noun' (setf possibleSynonyms (eliminateDissimilarOwners owners possibleSynonyms nil)) ;; return the remaining synonmys along with the explicitly marked synonyms (append synonyms possibleSynonyms))) ;;;------------------------------------------------------------------------------ ;;; function: eliminateDissimilarClasses ;;; input: supers, a list of the superclasses of the target noun; ;;; possibleSynonyms, a list of possible synonyms for the target noun; ;;; verifiedSynonyms, a list of those possible synonmys that survive ;;; comparison of superclasses (initially nil) ;;; returns: verifiedSynonyms ;;; written: kae ??/??/92 ;;; modified: kae 05/12/94 ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------ (defun eliminateDissimilarClasses (supers possibleSynonyms &optional verifiedSynonyms) "Examine each of the elements of 'possibleSynonyms' and eliminate any synonyms whose class inclusions are not sufficiently similar to the class inclusions of 'noun'." (cond ;; if there are no more possibe synonyms, return the list of verified synonyms ((null possibleSynonyms) verifiedSynonyms) ;; if the superclasses of 'noun' are sufficiently similar to the superclasses of the ;; first possible synonym on the list 'possibleSynonyms' then add the possible synonym ;; to the list 'verifiedSynonyms' and check the rest of 'possibleSynonyms' ((similarSuperclassesp supers (class_filter (findClassInclusions (first possibleSynonyms)) (first possibleSynonyms))) (eliminateDissimilarClasses supers (rest possibleSynonyms) (cons (first possibleSynonyms) verifiedSynonyms))) ;; in this case, the sets of superclasses examined above were not sufficiently similar, ;; so do not add the first element of the list 'possibleSynonyms' to 'verifiedSynoynms' ;; (thereby removing it) and check the rest of 'possibleSynonyms' (t (eliminateDissimilarClasses supers (rest possibleSynonyms) verifiedSynonyms)))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: similarSuperclassesp (a predicate) ;;; input: two lists of superclasses, superclassesOfNoun is the superclasses of the ;;; target noun; superclassesOfSynonym is the superclasses of a possible synonym. ;;; returns t if target and possible synonym belong to similar lists of ;;; superclasses, nil otherwise. ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------ (defun similarSuperclassesp (superclassesOfNoun superclassesOfSynonym) "Return t if the two lists of superclasses are sufficiently similar." ;; return true if: (and ;; the two sets of superclass have at least as many elements in common as they have ;; elements which are different (>= (length (intersection superclassesOfNoun superclassesOfSynonym)) (length (union (set-difference superclassesOfNoun superclassesOfSynonym) (set-difference superclassesOfSynonym superclassesOfNoun)))) ;; they share at least two superclasses (>= (length (intersection superclassesOfNoun superclassesOfSynonym)) 2) ;; none of their superclasses are opposites of one another (noAntonymsp superclassesOfNoun superclassesOfSynonym))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: noAntonymsp (a predicate) ;;; input: two lists of superclasses, superclassesOfNoun is the superclasses of the ;;; target noun; superclassesOfSynonym is the superclasses of a possible synonym. ;;; returns nil if an an element of one list has an antonym in the other, ;;; t otherwise. ;;;------------------------------------------------------------------------------ (defun noAntonymsp (superclassesOfNoun superclassesOfSynonym) "Return t if there are no members of 'superclassesOfNoun' which are explicitly labeled as an antonym of any member of 'superclassesOfSynonym', nil otherwise." (cond ((null superclassesOfNoun) t) (t (if (null (antonymp (first superclassesOfNoun) superclassesOfSynonym)) (noAntonymsp (rest superclassesOfNoun) superclassesOfSynonym))))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: antonymp (a predicate) ;;; ;;;------------------------------------------------------------------------------ (defun antonymp (class superclassesOfSynonym) "Return t if there is at least one explicitly labeled antonym of 'class' among the list of classes 'superclassesOfSynonym', nil otherwise." (intersection #3! ((find (compose antonym- ! antonym lex) ~class)) (removeElement (get-node-name class) superclassesOfSynonym))) ;;;------------------------------------------------------------------------------ ;;; function: eliminateDissimilarStructure ;;; input: structuralElements, a list of structural elements of the target noun; ;;; possibleSynonyms, a list of possible synonyms for the target noun; ;;; verifiedSynonyms, a list of those possible synonmys that survive ;;; comparison of structure (initially nil). ;;; returns: verifiedSynonyms ;;; written: kae ??/??/92 ;;; modified: kae 05/12/94 ;;; modified: stn 2002 ;;;------------------------------------------------------------------------------ (defun eliminateDissimilarStructure (structuralElements possibleSynonyms &optional verifiedSynonyms) "Examine each element of 'possibleSynonyms' and remove it from the list if its structural elements are not sufficiently similar to 'structuralElements'." (cond ;; if there are no more possible synonyms to examine, return the list of verified synonyms ((null possibleSynonyms) verifiedSynonyms) ;; if the first element of 'possibleSynonyms' has a list of structural elements that ;; is sufficiently similar to the structural elements of 'noun' then add it to the list ;; of verified synonyms and check the rest of the list. ((similarStructurep structuralElements (findStructuralElements (first possibleSynonyms) (findClasses (first possibleSynonyms)))) (eliminateDissimilarStructure structuralElements (rest possibleSynonyms) (cons (first possibleSynonyms) verifiedSynonyms))) ;; don't put the first element of 'possibleSynonyms' into the list of verified synonyms ;; and keep checking the rest of the list (t (eliminateDissimilarStructure structuralElements (rest possibleSynonyms) verifiedSynonyms)))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: similarStructurep (a predicate) ;;; input: two lists of structural elementss, structureOfNoun is the structure ;;; of the target noun; structureOfSynonym is the structure of a possible ;;; synonym. ;;; returns t if target and possible synonym have similar lists of ;;; structural elements, nil otherwise. ;;;------------------------------------------------------------------------------ (defun similarStructurep (structureOfNoun structureOfSynonym) "Return t if there are more elements shared by the two sets of input lists than elements that separate them." (>= (length (intersection structureOfNoun structureOfSynonym)) (length (union (set-difference structureOfNoun structureOfSynonym) (set-difference structureOfSynonym structureOfNoun))))) ;;;------------------------------------------------------------------------------ ;;; function: eliminateDissimilarFunctions ;;; input: functions, the function(s) of the target being defined ;;; possibleSynonyms, a list of possible synonyms for the target noun;;; ;;; verifiedSynonyms, a list of those possible synonmys that survive ;;; comparison of function (initially nil). ;;; returns: verifiedSynonyms ;;; written: kae ??/??/92 ;;; modified: kae 05/12/94 ;;;------------------------------------------------------------------------------ (defun eliminateDissimilarFunctions (functions possibleSynonyms verifiedSynonyms) "Examine each element of 'possibleSynonyms' and remove it from the list if its functions are not sufficiently similar to 'functions'." (cond ;; if there are no more possible synonyms to examine, return the list of verified synonyms ((null possibleSynonyms) verifiedSynonyms) ;; if the first element of 'possibleSynonyms' has a list of functions that is ;; sufficiently similar to the functions of 'noun' then add it to the list of ;; verified synonyms and check the rest of the list. ((similarFunctionp functions (findFunctions (first possibleSynonyms))) (eliminateDissimilarFunctions functions (rest possibleSynonyms) (append (list (first possibleSynonyms)) verifiedSynonyms))) ;; don't put the first element of 'possibleSynonyms' into the list of verified synonyms ;; and keep checking the rest of the list (t (eliminateDissimilarFunctions functions (rest possibleSynonyms) verifiedSynonyms)))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: similarFunctionp (a predicate) ;;; input: two lists of functions, functionOfNoun is the functions of the ;;; target noun; functionOfSynonym is the functions of a possible synonym. ;;; returns t if target and possible synonym have similar functions, ;;; nil otherwise. ;;;------------------------------------------------------------------------------ (defun similarFunctionp (functionOfNoun functionOfSynonym) "Return t if there are more elements shared by the two sets of input lists than elements that separate them." (>= (length (intersection functionOfNoun functionOfSynonym)) (length (union (set-difference functionOfNoun functionOfSynonym) (set-difference functionOfSynonym functionOfNoun))))) ;;;------------------------------------------------------------------------------ ;;; function: eliminateDissimilarOwners ;;; input: noun, the target being defined ;;; possibleSynonyms, a list of possible synonyms for the target noun;;; ;;; verifiedSynonyms, a list of those possible synonmys that survive ;;; comparison of ownership or part/whole relation ;;; (initially nil). ;;; returns: verifiedSynonyms ;;; written: kae ??/??/92 ;;; modified: kae 05/12/94 ;;;------------------------------------------------------------------------------ (defun eliminateDissimilarOwners (owners possibleSynonyms verifiedSynonyms) "Examine each element of 'possibleSynonyms' and remove it from the list if its owners are not sufficiently similar to the owners of 'noun'." (cond ;; if there are no more possible synonyms to examine, return the list of verified synonyms ((null possibleSynonyms) verifiedSynonyms) ;; if the first element of 'possibleSynonyms' has a list of owners that is ;; sufficiently similar to the owners of 'noun' then add it to the list of ;; verified synonyms and check the rest of the list. ((similarOwnersp owners (findOwners (first possibleSynonyms))) (eliminateDissimilarOwners noun (rest possibleSynonyms) (append (list (first possibleSynonyms)) verifiedSynonyms))) ;; don't put the first element of 'possibleSynonyms' into the list of verified synonyms ;; and keep checking the rest of the list (t (eliminateDissimilarOwners noun (rest possibleSynonyms) verifiedSynonyms)))) ;;;------------------------------------------------------------------------------ ;;; ;;; function: similarOwnersp (a predicate) ;;; input: two lists of relations, ownersOfNoun is the relations of the ;;; target noun; ownersOfSynonym is the relations of a possible synonym. ;;; returns t if target and possible synonym have similar relations, ;;; nil otherwise. ;;;------------------------------------------------------------------------------ (defun similarOwnersp (ownersOfNoun ownersOfSynonym) "Return t if the input lists have more elements in common than elements that separate them." (>= (length (intersection ownersOfNoun ownersOfSynonym)) (length (union (set-difference ownersOfNoun ownersOfSynonym) (set-difference ownersOfSynonym ownersOfNoun))))) ;;;------------------------------------------------------------------------------- ;;; ;;; function: removeElement ;;; ;;;------------------------------------------------------------------------------- (defun removeElement (removeMe nodeList &optional weeded) "Remove an element whose name is equal to the name of 'removeMe' from 'nodeList'." (cond ;; if all the elements have been checked, return the list of elements that passed the check ((null nodeList) weeded) ;; if the name of the node 'removeMe' is the same as the name of the first node in ;; 'nodeList' then do not add the first element to the list of verified elements ;; (weeded) and check the rest of the list ((string-equal (string removeMe) (string (get-node-name (first nodeList)))) (removeElement removeMe (rest nodeList) weeded)) ;; the name of the node 'removeMe' is not the same as the name of the first node in ;; 'nodeList', so add the first node in 'nodeList' to 'weeded'. (t (removeElement removeMe (rest nodeList) (cons (first nodeList) weeded))))) ;;;------------------------------------------------------------------------------- ;;; function: get-node-name ;;;------------------------------------------------------------------------------- (defun get-node-name (node) (and (sneps:node-p node) (sneps:node-na node))) ;;;------------------------------------------------------------------------------- ;;; function: get-node-string ;;;------------------------------------------------------------------------------- (defun get-node-string (node) (string (get-node-name node)))