(in-package :snepsul) ;---------------------------------------------------------------------------- ; ; function: defn_noun ; input: a noun to be defined ; output: a report about the noun's meaning. ; calls: report_subbasic if input can be deduced to be a subclass of ; a basic-level category; ; report_basic if input can be deduced to be a basic-level ctgy ; or a subclass of animal, ; report_super if a physical object, or abstract object; ; there_exists if none of the above can be deduced. ; Note: #3! is a macro which allows snepsul calls within lisp functions ; without having to name packages & use lots of commas & backquotes ; ; written: kae 1992 ; modified: kae 1994 ;------------------------------------------------------------------------------ (defun defn_noun (noun) (cond (#3! ((deduce object1 (build lex ~noun) rel "ISA" object2 (build lex "basic ctgy"))) (report_basic noun)) (#3! ((find (compose lex- superclass- ! subclass lex) ~noun (compose lex- object1- ! object2 lex) "basic ctgy")) (setq clas #3! ((find (compose lex- superclass- ! subclass lex) ~noun (compose lex- object1- ! object2 lex) "basic ctgy"))) (report_subbasic noun clas)) (#3! ((find (compose lex- superclass- ! subclass superclass- ! subclass lex) ~noun (compose lex- object1- ! object2 lex) "basic ctgy")) (setq clas #3! ((find (compose lex- superclass- ! subclass superclass- ! subclass lex) ~noun (compose lex- object1- ! object2 lex) "basic ctgy"))) (report_subbasic noun clas)) (#3! ((deduce subclass (build lex ~noun) superclass (build lex "animal"))) (report_basic noun)) (#3! ((deduce subclass (build lex ~noun) superclass (build lex "phys obj"))) (report_super noun)) (#3! ((deduce subclass (build lex ~noun) superclass (build lex "abstr obj"))) (report_abstr noun)) ((there_exists noun) (list (there_exists noun))))) ;-------------------------------------------------------------------------- ; ; function: report_basic ; input: noun to be defined ; output: a list of class inclusions for the noun, as well as any ; actions, functions, structure, certain relations, ; and synonyms. ; calls: act_filter, acts, classes, class_filter, func, struct, ; syn_noun, indiv_rand_rels ; written: kae ??/92 ; modified: kae 03/94 ;-------------------------------------------------------------------------- (defun report_basic (noun) (setq clsall (classes noun)) (setq cls (class_filter clsall nil noun)) (setq str (struct noun clsall)) (setq fun (func noun)) (setq ac (acts noun)) (setq prop (genprop noun)) (if (null prop) (if (and (null str) (null fun)) (list cls 'structure= 'nil 'function= 'nil 'actions= (act_filter ac nil noun) 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun) 'synonyms= (syn_noun noun str fun cls)) (list cls 'structure= str 'function= fun 'actions= (act_filter ac nil noun) 'ownership= (indiv_rand_rels noun) 'synonyms= (syn_noun noun str fun cls))) (if (and (null str) (null fun)) (list cls 'structure= 'nil 'function= 'nil 'actions= (act_filter ac nil noun) 'ownership= (indiv_rand_rels noun) 'properties= prop 'synonyms= (syn_noun noun str fun cls)) (list cls 'structure= str 'function= fun 'actions= (act_filter ac nil noun) 'ownership= (indiv_rand_rels noun) 'properties= prop 'synonyms= (syn_noun noun str fun cls))))) ;-------------------------------------------------------------------------- ; ; function: classes ; input: noun to be defined ; output: a list of class inclusions for the noun ;-------------------------------------------------------------------------- (defun classes (noun) (setq cls-1 (classes-1 noun)) (setq pr-cls (prob-classes noun)) (if (null pr-cls) cls-1 (append cls-1 pr-cls))) (defun classes-1 (noun) ; (cond (#3! ((deduce superclass $susu subclass ~noun)) (list 'class 'inclusion= #3! ((find (compose lex- superclass- ! subclass lex) ~noun)))) ;)) (defun prob-classes (noun) (cond (#3! ((deduce mode (build lex "presumably") object (build subclass (build lex ~noun) superclass (build lex $maybesuper)))) (list 'probable 'class 'inclusion= #3! ((find (compose lex- superclass- subclass lex) ~noun (compose lex- superclass- object- ! mode lex) "presumably")))))) ;------------------------------------------------------------------------------ ; ; 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: non_redundant_class, class_filter recursively ;------------------------------------------------------------------------------ (defun class_filter (class-list filtered noun) (cond ((null class-list) filtered) ;;;if car input is a list ((listp (car class-list)) ;;;add class_filter of car & (append filtered ;;;class_filter of cdr to output (list (class_filter (car class-list) filtered noun)) (class_filter (cdr class-list) filtered noun))) ;;;if car input is an ok atom ;;;add it and class_filter of ;;;cdr to output. ((or (non_redundant_class (car class-list) noun) (string-equal (string (get-node-name (car class-list))) "animal")) (append filtered (list (car class-list)) (class_filter (cdr class-list) filtered noun))) ;;;otherwise car input not ok. ;;;add class_filter of cdr to (t (class_filter (cdr class-list) filtered noun)))) ;;;output. ;------------------------------------------------------------------------------ ; ; function: non_redundant_class (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 non_redundant_class (class noun) (cond (#3! ((find (compose lex- superclass- ! subclass lex) ~noun (compose lex- subclass- ! superclass lex) ~class)) nil) (t t))) ;------------------------------------------------------------------------ ; ; function: acts ; input: a noun to be defined ; output: a list of actions, including probable and possible actions ; that an item of type can be deduced to perform ; (finds rules of the variety, if x is a then x ) ; calls: indiv_rand_acts, only if no such rules about the actions ; of s are found. ;------------------------------------------------------------------------ (defun acts (noun) ;definite rule, or-entail, basic-ctgy, transitive, basic object (cond ((AND #3! ((find (compose lex- act- cq- ! ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) #3! ((find (compose lex- class- member object- cq- ! ant class lex) ~noun))) (list #3! ((find (compose lex- act- cq- ! ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) #3! ((find (compose lex- class- member object- cq- ! ant class lex) ~noun)))) ;definite rule, or-entail, non-basic-ctgy, transitive ((AND #3! ((find (compose lex- act- cq- ! ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) #3! ((find (compose lex- class- member object- cq- ! ant object2 lex) ~noun))) (list #3! ((find (compose lex- act- cq- ! ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) #3! ((find (compose lex- class- member object- cq- ! ant object2 lex) ~noun)))) ;definite rule, &-entail, basic-ctgy, transitive ((AND #3! ((find (compose lex- act- cq- ! &ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) #3! ((find (compose lex- class- member object- cq- ! &ant class lex) ~noun))) (list #3! ((find (compose lex- act- cq- ! &ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) #3! ((find (compose lex- class- member object- cq- ! &ant class lex) ~noun))) ) ;definite rule, &-entail, non-basic ctgy, transitive ((AND #3! ((find (compose lex- act- cq- ! &ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) #3! ((find (compose lex- class- member object- cq- ! ant object2 lex) ~noun))) (list #3! ((find (compose lex- act- cq- ! &ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) #3! ((find (compose lex- class- member object- cq- ! &ant object2 lex) ~noun)))) ;"presumably" rule, or-entail, basic ctgy, transitive ((AND #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)) #3! ((find (compose lex- class- member object- object- cq- ! ant class lex) ~noun))) (list 'probable actions= #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)) #3! ((find (compose lex- class- member object- object- cq- ! ant class lex) ~noun)))) ;"presumably" rule, or-entail, non-basic ctgy, transitive ((AND #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)) #3! ((find (compose lex- class- member object- object- cq- ! ant object2 lex) ~noun))) (list 'probable 'actions= #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)) #3! ((find (compose lex- class- member object- object- cq- ! ant object2 lex) ~noun)))) ;"presumably" rule, &-entail, basic ctgy, transitive ((AND #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)) #3! ((find (compose lex- class- member object- object- cq- ! &ant class lex) ~noun))) (list 'probable 'actions= #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)) #3! ((find (compose lex- class- member object- object- cq- ! &ant class lex) ~noun)))) ;"presumably" rule, &-entail, non-basic ctgy, transitive ((AND #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)) #3! ((find (compose lex- class- member object- object- cq- ! &ant object2 lex) ~noun))) (list 'probable 'actions= #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)) #3! ((find (compose lex- class- member object- object- cq- ! &ant object2 lex) ~noun)))) ;definite rule, or-entail, basic-ctgy, transitive, non-basic object ((AND #3! ((find (compose lex- act- cq- ! ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) #3! ((find (compose lex- object2- object1 object- cq- ! ant class lex) ~noun))) (list #3! ((find (compose lex- act- cq- ! ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) #3! ((find (compose lex- object2- object1 object- cq- ! ant class lex) ~noun)))) ;definite rule, or-entail, non-basic-ctgy, transitive ((AND #3! ((find (compose lex- act- cq- ! ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) #3! ((find (compose lex- object2- object1 object- cq- ! ant object2 lex) ~noun))) (list #3! ((find (compose lex- act- cq- ! ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) #3! ((find (compose lex- object2- object1 object- cq- ! ant object2 lex) ~noun)))) ;definite rule, &-entail, basic-ctgy, transitive ((AND #3! ((find (compose lex- act- cq- ! &ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) #3! ((find (compose lex- object2- object1 object- cq- ! &ant class lex) ~noun))) (list #3! ((find (compose lex- act- cq- ! &ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) #3! ((find (compose lex- object2- object1 object- cq- ! &ant class lex) ~noun))) ) ;definite rule, &-entail, non-basic ctgy, transitive ((AND #3! ((find (compose lex- act- cq- ! &ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) #3! ((find (compose lex- object2- object1 object- cq- ! ant object2 lex) ~noun))) (list #3! ((find (compose lex- act- cq- ! &ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) #3! ((find (compose lex- object2- object1 object- cq- ! &ant object2 lex) ~noun)))) ;"presumably" rule, or-entail, basic ctgy, transitive ((AND #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)) #3! ((find (compose lex- object2- object1 object- object- cq- ! ant class lex) ~noun))) (list 'probable actions= #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)) #3! ((find (compose lex- object2- object1 object- object- cq- ! ant class lex) ~noun)))) ;"presumably" rule, or-entail, non-basic ctgy, transitive ((AND #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)) #3! ((find (compose lex- object2- object1 object- object- cq- ! ant object2 lex) ~noun))) (list 'probable 'actions= #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)) #3! ((find (compose lex- object2- object1 object- object- cq- ! ant object2 lex) ~noun)))) ;"presumably" rule, &-entail, basic ctgy, transitive ((AND #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)) #3! ((find (compose lex- object2- object1 object- object- cq- ! &ant class lex) ~noun))) (list 'probable 'actions= #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)) #3! ((find (compose lex- object2- object1 object- object- cq- ! &ant class lex) ~noun)))) ;"presumably" rule, &-entail, non-basic ctgy, transitive ((AND #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)) #3! ((find (compose lex- object2- object1 object- object- cq- ! &ant object2 lex) ~noun))) (list 'probable 'actions= #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)) #3! ((find (compose lex- object2- object1 object- object- cq- ! &ant object2 lex) ~noun)))) ;definite rule, or-entail, basic-ctgy, intransitive (#3! ((find (compose lex- act- cq- ! ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) (list 'actions= #3! ((find (compose lex- act- cq- ! ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) )) ;definite rule, &-entail, basic-ctgy, intransitive (#3! ((find (compose lex- act- cq- ! &ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun)) (list 'actions= #3! ((find (compose lex- act- cq- ! &ant class lex) ~noun (compose lex- act- agent member- class lex) ~noun))) ) ;definite rule, or-entail, non-basic-ctgy, intransitive (#3! ((find (compose lex- act- cq- ! ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) (list 'actions= #3! ((find (compose lex- act- cq- ! ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)))) ;definite rule, &-entail, non-basic-ctgy, intransitive (#3! ((find (compose lex- act- cq- ! &ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)) (list #3! ((find (compose lex- act- cq- ! &ant object2 lex) ~noun (compose lex- act- agent object1- object2 lex) ~noun)))) ;"presumably" rule, or-entail, basic ctgy, intransitive (#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)) (list 'probable 'actions= #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))) ) ;"presumably" rule, &-entail, basic ctgy, intransitive (#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)) (list 'probable 'actions #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))) ) ;"presumably" rule, or-entail, non-basic ctgy, intransitive (#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)) (list 'probable 'actions= #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)))) ;"presumably" rule, &-entail, non-basic ctgy, intransitive (#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)) (list 'probable 'actions= #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)))) (t (list (indiv_rand_acts noun))))) ;------------------------------------------------------------------------------ ; ; 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 (car act-list)) ;;;add act_filter of car & (append filtered ;;;act_filter of cdr to output (list (act_filter (car act-list) filtered noun)) (act_filter (cdr act-list) filtered noun))) ;;;if car input is an ok atom ;;;add it and act_filter of ;;;cdr to output. ((non_redundant_act (car act-list) noun) (append filtered (list (car act-list)) (act_filter (cdr act-list) filtered noun))) ;;;otherwise car input not ok. ;;;add act_filter of cdr to (t (act_filter (cdr 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 lex- superclass- ! subclass lex) ~noun (compose lex- class- ant- ! cq act lex) ~act)) nil) (#3! ((find (compose lex- superclass- ! subclass lex) ~noun (compose lex- object2- ant- ! cq act lex) ~act)) nil) (#3! ((find (compose lex- superclass- ! subclass lex) ~noun (compose lex- class- ant- ! cq object act lex) ~act)) nil) (#3! ((find (compose lex- superclass- ! subclass lex) ~noun (compose lex- object2- ant- ! cq object act lex) ~act)) nil) (t t))) ;------------------------------------------------------------------------------ ; ; function: struct ; input: a noun to be defined and a list of its superclasses ; output: a list of things that a possesses. Includes possible ; and probable possessions. Finds rules of the sort ; If x is a then x has . Needs to be ; revised so that only possessions which are part of ; are included. ; calls: indiv_struct, only if no such rules are found. ;------------------------------------------------------------------------------ (defun struct (noun supers) (cond (#3! ((find (compose lex- rel- possessor member- class lex) ~noun (compose lex- rel- cq- ! ant class lex) ~noun (compose lex- rel- possessor forall- ! ant class lex) ~noun)) (list #3! ((find (compose lex- rel- possessor member- class lex) ~noun (compose lex- rel- cq- ! ant class lex) ~noun (compose lex- rel- possessor forall- ! ant class lex) ~noun))) ) (#3! ((find (compose lex- rel- possessor object1- object2 lex) ~noun (compose lex- rel- cq- ! ant object2 lex) ~noun (compose lex- rel- possessor forall- ! ant object2 lex) ~noun)) (list #3! ((find (compose lex- rel- possessor object1- object2 lex) ~noun (compose lex- rel- cq- ! ant object2 lex) ~noun (compose lex- rel- possessor forall- ! ant object2 lex) ~noun)))) (#3! ((find (compose lex- rel- possessor member- class lex) ~noun (compose lex- rel- object- mode lex) "presumably" (compose lex- rel- possessor forall- ! ant class lex) ~noun)) (list 'probable 'structural 'elements= #3! ((find (compose lex- rel- possessor member- class lex) ~noun (compose lex- rel- object- mode lex) "presumably" (compose lex- rel- possessor forall- ! ant class lex) ~noun)))) (#3! ((find (compose lex- rel- possessor object1- object2 lex) ~noun (compose lex- rel- object- mode lex) "presumably" (compose lex- rel- possessor forall- ! ant object2 lex) ~noun)) (list 'probable 'structural 'elements= #3! ((find (compose lex- rel- possessor object1- object2 lex) ~noun (compose lex- rel- object- mode lex) "presumably" (compose lex- rel- possessor forall- ! ant object2 lex) ~noun)))) (t (setq superstruct (car (struct2 (caddr supers)))) (setq substruct (indiv_struct noun)) (cond ((null superstruct) substruct) (t (setq sub2struct (set-difference (cadddr substruct) superstruct)) (if (null sub2struct) nil (list 'possible 'structural 'features= sub2struct))) )))) ;---------------------------------------------------------------------------- ; ; function: func ; input: a noun to be defined ; output: a list of functions or purposes of . Includes possible ; and probable functions. Finds rules of the sort ; If x is a then the function of x is ; calls: indiv_funct, only if no such rules are found. ;---------------------------------------------------------------------------- (defun func (noun) ;definite rule, basic ctgy, or-entail (cond (#3! ((find (compose lex- object2- object1 member- class lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- cq- ! ant class lex) ~noun)) (list #3! ((find (compose lex- object2- object1 member- class lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- cq- ! ant class lex) ~noun)))) ;definite rule, non-basic ctgy, or-entail (#3! ((find (compose lex- object2- object1 object1- object2 lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- cq- ! ant object2 lex) ~noun)) (list #3! ((find (compose lex- object2- object1 object1- object2 lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- cq- ! ant object2 lex) ~noun)))) ;definite rule, subclass of class for which function known, or-entail (#3! ((find (compose lex- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- cq- ! ant object2 superclass- ! subclass lex) ~noun)) (list #3! ((find (compose lex- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- cq- ! ant object2 superclass- ! subclass lex) ~noun)))) ;definite rule, basic ctgy, or-entail, non-mol-lex function node (#3! ((find (compose lex- act- object2- object1 member- class lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- cq- ! ant class lex) ~noun)) (append '("to be") #3! ((find (compose lex- act- object2- object1 member- class lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- cq- ! ant class lex) ~noun)))) ;definite rule, non-basic ctgy, or-entail, non-mol-lex function node (#3! ((find (compose lex- act- object2- object1 object1- object2 lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- cq- ! ant object2 lex) ~noun)) (append '("to be") #3! ((find (compose lex- act- object2- object1 object1- object2 lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- cq- ! ant object2 lex) ~noun)))) ;definite rule, subclass of class for which function is known, or-entail, ;non-mol-lex function node (#3! ((find (compose lex- act- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- cq- ! ant object2 superclass- ! subclass lex) ~noun)) (append '("to be") #3! ((find (compose lex- act- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- cq- ! ant object2 superclass- ! subclass lex) ~noun)))) ;presumable rule, basic ctgy, or-entail (#3! ((find (compose lex- object2- object1 member- class lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- object- cq- ! ant class lex) ~noun)) (list #3! ((find (compose lex- object2- object1 member- class lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- object- cq- ! ant class lex) ~noun)))) ;presumable rule, non-basic ctgy, or-entail (#3! ((find (compose lex- object2- object1 object1- object2 lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- object- cq- ! ant object2 lex) ~noun)) (list #3! ((find (compose lex- object2- object1 object1- object2 lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- object- cq- ! ant object2 lex) ~noun)))) ;presumable rule, un-named non-basic ctgy, &-entail ((AND #3!((deduce subclass (build lex ~noun) superclass $supercat)) #3! ((find (compose lex- &ant- ! cq object rel lex) "function" (compose lex- object2- rel lex) "function" (compose lex- object2- object1 object1- object2 subclass- superclass) (find (compose superclass- ! subclass lex) ~noun)))) (list #3! ((find (compose lex- &ant- ! cq object rel lex) "function" (compose lex- object2- rel lex) "function" (compose lex- object2- object1 object1- object2 subclass- superclass) (find (compose superclass- ! subclass lex) ~noun))))) ;presumable rule, un-named non-basic ctgy, &-entail, non-mol-lex node. ((AND #3!((deduce subclass (build lex ~noun) superclass $supercat)) #3!((deduce act (build lex (find (compose lex- act- &ant- ! cq object rel lex) "function")) object (find (compose object1- ! object2 subclass- ! superclass) (find (compose superclass- ! subclass lex) ~noun)))) #3! ((find (compose lex- act- &ant- ! cq object rel lex) "function" (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- object1 object1- object2 subclass- superclass) (find (compose superclass- ! subclass lex) ~noun)))) (append '("to be") #3! ((find (compose lex- act- &ant- ! cq object rel lex) "function" (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- object1 object1- object2 subclass- superclass) (find (compose superclass- ! subclass lex) ~noun))))) ;presumable rule, subclass of class for which function is known, or-entail (#3! ((find (compose lex- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- object- cq- ! ant object2 superclass- ! subclass lex) ~noun)) (list #3! ((find (compose lex- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose lex- object2- rel lex) "function" (compose lex- object2- object- cq- ! ant object2 superclass- ! subclass lex) ~noun)))) ;presumable rule, basic ctgy, non-mol-lex function node, or-entail (#3! ((find (compose lex- act- object2- object1 member- class lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- object- cq- ! ant class lex) ~noun)) (append '("to be") #3! ((find (compose lex- act- object2- object1 member- class lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- object- cq- ! ant class lex) ~noun)))) ;presumable rule, non-basic ctgy, non-mol-lex function node, or-entail (#3! ((find (compose lex- act- object2- object1 object1- object2 lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- object- cq- ! ant object2 lex) ~noun)) (append '("to be") #3! ((find (compose lex- act- object2- object1 object1- object2 lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- object- cq- ! ant object2 lex) ~noun)))) ;presumable rule, subclass of class for which function is known, ;non-mol-lex function node, or-entail (#3! ((find (compose lex- act- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- object- cq- ! ant object2 superclass- ! subclass lex) ~noun)) (append '("to be") #3! ((find (compose lex- act- object2- object1 object1- object2 superclass- ! subclass lex) ~noun (compose lex- act- object2- rel lex) "function" (compose lex- act- object2- object- cq- ! ant object2 superclass- ! subclass lex) ~noun)))) (t (indiv_funct noun)))) ;------------------------------------------------------------------------------ ; ; function: genprop ; input: a noun to be defined ; output: a list containing any general properties that are known to ; pertain to s as a class. ;------------------------------------------------------------------------------ (defun genprop (noun) ;def.rule, basic ctgy. (cond (#3! ((find (compose lex- property- object member- class lex) ~noun (compose lex- property- cq- ! ant class lex) ~noun)) (list #3! ((find (compose lex- property- object member- class lex) ~noun (compose lex- property- cq- ! ant class lex) ~noun)))) ;def.rule, non-basic ctgy. (#3! ((find (compose lex- property- object object1- object2 lex) ~noun (compose lex- property- cq- ! ant object2 lex) ~noun)) (list #3! ((find (compose lex- property- object object1- object2 lex) ~noun (compose lex- property- cq- ! ant object2 lex) ~noun)))) ;prob.rule, basic ctgy. (#3! ((find (compose lex- property- object member- class lex) ~noun (compose lex- property- object- cq- ! ant class lex) ~noun)) (list #3! ((find (compose lex- property- object member- class lex) ~noun (compose lex- property- object- cq- ! ant class lex) ~noun)))) ;prob.rule, non-basic ctgy. (#3! ((find (compose lex- property- object object1- object2 lex) ~noun (compose lex- property- object- cq- ! ant object2 lex) ~noun)) (list #3! ((find (compose lex- property- object object1- object2 lex) ~noun (compose lex- property- object- cq- ! ant object2 lex) ~noun)))))) ;------------------------------------------------------------------------------ ; ; function: report_subbasic ; input: a noun to be defined, the basic level ctgy to which it belongs ; output: a list containing the basic level catgy to which belongs ; (no other class inclusions) and the actions (if animate), ; functions, and structures of . ; calls: act_filter, acts, func, struct, and syn_noun ;------------------------------------------------------------------------------ (defun report_subbasic (noun clas) (setq str (struct noun clas)) (setq fn (func noun)) (setq prop (genprop noun)) (setq cls (append (list 'x 'y) (list clas))) ;kludge for syn_noun, which ;works with the caddr of a ;class list. (if (null prop) (if #3! ((deduce subclass (build lex ~noun) superclass (build lex "animal"))) (list 'a noun 'is 'a 'kind 'of clas 'actions= (act_filter (acts noun) nil noun) 'function= fn 'structure= str 'ownership= (indiv_rand_rels noun) 'synonyms= (syn_noun noun str fn cls)) (list 'a noun 'is 'a 'kind 'of clas 'function= fn 'structure= str 'ownership= (indiv_rand_rels noun) 'synonyms= (syn_noun noun str fn cls))) (if #3! ((deduce subclass (build lex ~noun) superclass (build lex "animal"))) (list 'a noun 'is 'a 'kind 'of clas 'actions= (act_filter (acts noun) nil noun) 'function= fn 'structure= str 'ownership= (indiv_rand_rels noun) 'properties= prop 'synonyms= (syn_noun noun str fn cls)) (list 'a noun 'is 'a 'kind 'of clas 'function= fn 'structure= str 'ownership= (indiv_rand_rels noun) 'properties= prop 'synonyms= (syn_noun noun str fn cls))))) ;-------------------------------------------------------------------------- ; ; function: report_super ; input: noun to be defined ; output: a list of class inclusions for the noun, as well as any ; actions, functions, structure, certain relations, ; and synonyms. ; calls: act_filter, acts, classes, class_filter, func, struct, ; syn_noun, indiv_rand_rels, ag-act-fn ; written: kae 05/94 ;-------------------------------------------------------------------------- (defun report_super (noun) (setq clsall (classes noun)) (setq str (struct noun clsall)) (setq ac (acts noun)) (setq fun (func noun)) (setq cls (class_filter clsall nil noun)) (setq synn (syn_noun noun str fun cls)) (setq prop (genprop noun)) (if (and (null str) (null fun)) (cond ((and (null ac) (null synn)) (setq agent-act (ag-act-fn noun)) (if (not (null agent-act)) (list 'a noun 'is 'something 'a (car agent-act) 'can (cadr agent-act))) (list cls 'structure= 'nil 'function= 'nil 'actions= 'nil 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun) 'synonyms= 'nil)) (t (list cls 'structure= 'nil 'function= 'nil 'actions= (act_filter ac nil noun) 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun) 'synonyms= synn))) (if (null prop) (list cls 'structure= str 'function= fun 'actions= (act_filter ac nil noun) 'ownership= (indiv_rand_rels noun) 'synonyms= synn) (list cls 'structure= str 'function= fun 'actions= (act_filter ac nil noun) 'ownership= (indiv_rand_rels noun) 'properties= prop 'synonyms= synn)))) ;-------------------------------------------------------------------------- ; ; function: report_abstr ; input: noun to be defined ; output: a list of class inclusions for the noun, as well as any ; actions, functions, and synonyms. ; calls: act_filter, acts, classes, class_filter, func, ; syn_noun, ag-act-fn ; written: kae 06/94 ;-------------------------------------------------------------------------- (defun report_abstr (noun) (setq clsall (classes noun)) (setq ac (acts noun)) (setq fun (func noun)) (setq cls (class_filter clsall nil noun)) (setq synn (syn_noun noun nil fun cls)) (setq prop (genprop noun)) (if (and (null cls) (null fun)) (cond ((and (null ac) (null synn)) (setq agent-act (ag-act-fn noun)) (if (not (null agent-act)) (list 'a noun 'is 'something 'a (car agent-act) 'can (cadr agent-act))) (list 'function= 'nil 'actions= 'nil 'possible 'properties= (indiv_rand_props noun) 'synonyms= 'nil)) (t (list 'function= 'nil 'actions= (act_filter ac nil noun) 'possible 'properties= (indiv_rand_props noun) 'synonyms= synn))) (if (null prop) (list cls 'function= fun 'actions= (act_filter ac nil noun) 'synonyms= synn) (list cls 'function= fun 'actions= (act_filter ac nil noun) 'properties= prop 'synonyms= synn)))) ;------------------------------------------------------------------------------- ;------------------------------------------------------------------------------- ; ; function: there_exists ; input: a noun to be defined ; output: a list of individuals of type together with any ; possessions, functions, actions, relations, or other ; properties attributed to those individuals. If individuals ; exist, and have such properties, but aren't named, list ; the properties anyway. ;------------------------------------------------------------------------------- (defun there_exists (noun) (setq agent-act (ag-act-fn noun)) (setq str (struct noun nil)) (setq ac (acts noun)) (setq fun (func noun)) (cond (#3! ((find (compose lex- proper-name- ! object object1- ! object2 lex) ~noun)) (if (and (null str) (null fun)) (if (and (null ac) agent-act) (list 'a noun 'is 'something 'a (car agent-act) 'can (cadr agent-act) 'a noun 'is 'something #3! ((find (compose lex- proper-name- ! object object1- ! object2 lex) ~noun)) 'is. 'structure= 'nil 'function= 'nil 'actions= 'nil 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun)) (list 'a noun 'is 'something #3! ((find (compose lex- proper-name- ! object object1- ! object2 lex) ~noun)) 'is. 'structure= 'nil 'function= 'nil 'actions= ac 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun))) (list 'a noun 'is 'something #3! ((find (compose lex- proper-name- ! object object1- ! object2 lex) ~noun)) 'is. 'structure= str 'function= fun 'actions= ac 'ownership= (indiv_rand_rels noun)))) (#3! ((find (compose lex- proper-name- ! object member- ! class lex) ~noun)) (if (and (null str) (null fun)) (if (and (null ac) agent-act) (list 'a noun 'is 'something 'a (car agent-act) 'can (cadr agent-act) 'a noun 'is 'something #3! ((find (compose lex- proper-name- ! object member- ! class lex) ~noun)) 'is. 'structure= 'nil 'function= 'nil 'actions= 'nil 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun)) (list 'a noun 'is 'something #3! ((find (compose lex- proper-name- ! object member- ! class lex) ~noun)) 'is. 'structure= 'nil 'function= 'nil 'actions= ac 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun))) (list 'a noun 'is 'something #3! ((find (compose lex- proper-name- ! object member- ! class lex) ~noun)) 'is. 'structure= str 'function= fun 'actions= ac 'ownership= (indiv_rand_rels noun)))) (#3! ((find (compose object1- ! object2 lex) ~noun)) (if (and (null str) (null fun) agent-act) (list 'a noun 'is 'something 'a (car agent-act) 'can (cadr agent-act) 'structure= 'nil 'function= 'nil 'actions= ac 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun)) (list 'structure= str 'function= fun 'actions= ac 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun)))) (#3! ((find (compose member- ! class lex) ~noun)) (if (and (null str) (null fun) agent-act) (list 'a noun 'is 'something 'a (car agent-act) 'can (cadr agent-act) 'structure= 'nil 'function= 'nil 'actions= ac 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun)) (list 'structure= str 'function= fun 'actions= ac 'ownership= (indiv_rand_rels noun) 'possible 'properties= (indiv_rand_props noun)))) )) ;------------------------------------------------------------------------------ ; ; function: ag-act-fn ; 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. ; ;------------------------------------------------------------------------------ (defun ag-act-fn (noun) (setq local-agent #3! ((find (compose lex- class- ! member agent- ! object member- ! class lex) ~noun))) (if (null local-agent) (setq local-agent #3! ((find (compose lex- class- ! member agent- ! object object1- ! object2 lex) ~noun)))) (if (null local-agent) (setq local-agent #3! ((find (compose lex- object2- object1 agent- ! object member- ! class lex) ~noun)))) (if (null local-agent) (setq local-agent #3! ((find (compose lex- object2- object1 agent- ! object object1- ! object2 lex) ~noun)))) (if (null local-agent) (setq local-agent #3! ((find (compose lex- object2- objects1 agent- ! object member- ! class lex) ~noun)))) (if (null local-agent) (setq local-agent #3! ((find (compose lex- object2- objects1 agent- ! object object1- ! object2 lex) ~noun)))) (setq local-act #3! ((find (compose lex- act- ! object member- ! class lex) ~noun))) (if (null local-act) (setq local-act #3! ((find (compose lex- act- ! object object1- ! object2 lex) ~noun)))) (if (null local-agent) (setq local-agent #3! ((find (compose lex- class- ! member agent- ! onto object1- ! object2 lex) ~noun)))) (if (null local-agent) (setq local-agent #3! ((find (compose lex- object2- ! object1 agent- ! onto object1- ! object2 lex) ~noun)))) (if (null local-act) (setq local-act (append #3! ((find (compose lex- act- ! onto object1- ! object2 lex) ~noun)) "onto"))) (list local-agent local-act)) ;------------------------------------------------------------------------------ ; ; 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") ;------------------------------------------------------------------------------ (defun indiv_struct (noun) (cond (#3! ((find (compose lex- rel- ! possessor object1- ! object2 lex) ~noun)) (list 'possible 'structural 'features= #3! ((find (compose lex- rel- ! possessor object1- ! object2 lex) ~noun)))) (#3! ((find (compose lex- rel- ! possessor member- ! class lex) ~noun)) (list 'possible 'structural 'features= #3! ((find (compose lex- rel- ! possessor member- ! class lex) ~noun)))))) ;------------------------------------------------------------------------------- ; ; function: struct2 ;------------------------------------------------------------------------------- (defun struct2 (supers) (cond ((not (null supers)) (append (struct3 (car supers)) (struct2 (cdr supers)))))) ;------------------------------------------------------------------------------- ; ; function: struct3 ; ; a copy of the function struct, save that it does not call struct2 ; or indiv_struct. Used for finding structure of a superclass of ; the target noun. It's argument, noun, will be such a superclass, ; not the target noun itself. ;------------------------------------------------------------------------------- (defun struct3 (noun) (cond (#3! ((find (compose lex- rel- possessor member- class lex) ~noun (compose lex- rel- cq- ! ant class lex) ~noun (compose lex- rel- possessor forall- ! ant class lex) ~noun)) (list #3! ((find (compose lex- rel- possessor member- class lex) ~noun (compose lex- rel- cq- ! ant class lex) ~noun (compose lex- rel- possessor forall- ! ant class lex) ~noun))) ) (#3! ((find (compose lex- rel- possessor object1- object2 lex) ~noun (compose lex- rel- cq- ! ant object2 lex) ~noun (compose lex- rel- possessor forall- ! ant object2 lex) ~noun)) (list #3! ((find (compose lex- rel- possessor object1- object2 lex) ~noun (compose lex- rel- cq- ! ant object2 lex) ~noun (compose lex- rel- possessor forall- ! ant object2 lex) ~noun)))) (#3! ((find (compose lex- rel- possessor member- class lex) ~noun (compose lex- rel- object- mode lex) "presumably" (compose lex- rel- possessor forall- ! ant class lex) ~noun)) (list #3! ((find (compose lex- rel- possessor member- class lex) ~noun (compose lex- rel- object- mode lex) "presumably" (compose lex- rel- possessor forall- ! ant class lex) ~noun)))) (#3! ((find (compose lex- rel- possessor object1- object2 lex) ~noun (compose lex- rel- object- mode lex) "presumably" (compose lex- rel- possessor forall- ! ant object2 lex) ~noun)) (list #3! ((find (compose lex- rel- possessor object1- object2 lex) ~noun (compose lex- rel- object- mode lex) "presumably" (compose lex- rel- possessor forall- ! ant object2 lex) ~noun)))))) ;------------------------------------------------------------------------------- ; ; function: indiv_funct ; input: a noun to be defined ; output: nil (function to be filled in later) (defun indiv_funct (noun) nil) ;------------------------------------------------------------------------------- ; (cond (#3! ((find (compose lex- object2- object- ! object object1 object1- ! object2 lex) ; ~noun ; (compose lex- object2- object- ! object rel lex) "function")) ; (list 'possible 'function= ; #3! ((describe (find (compose lex- object2- object- ! object object1 ; object1- ! object2 lex) ; ~noun ; (compose lex- 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"))))))) ; ;-------------------------------------------------------------------------- ; ; function: indiv_rand_props ; input: a noun to be defined ; output: a list of properties attributed to any object of type ;-------------------------------------------------------------------------- (defun indiv_rand_props (noun) (setq prop (genprop noun)) (if (null prop) (cond (#3! ((find (compose lex- property- ! object object1- ! object2 lex) ~noun)) (list #3! ((find (compose lex- property- ! object object1- ! object2 lex) ~noun)))) (#3! ((find (compose lex- property- ! object member- ! class lex) ~noun)) (list #3! ((find (compose lex- property- ! object member- ! class lex) ~noun))))) (list prop))) ;-------------------------------------------------------------------------- ; ; function: indiv_rand_acts ; input: a noun to be defined ; output: a list of actions attributed to any object of type ;-------------------------------------------------------------------------- (defun indiv_rand_acts (noun) (cond (#3! ((find (compose lex- act- ! agent object1- ! object2 lex) ~noun)) (list 'possible 'actions= #3! ((find (compose lex- act- ! agent object1- ! object2 lex) ~noun)))) (#3! ((find (compose lex- act- ! agent member- ! class lex) ~noun)) (list 'possible 'actions= #3! ((find (compose lex- act- ! agent member- ! class lex) ~noun)))))) ;-------------------------------------------------------------------------- ; ; function: indiv_rand_rels ; input: a noun to be defined ; output: a list of those things which possess any object of type ; Note: needs to be refined/expanded. ;-------------------------------------------------------------------------- (defun indiv_rand_rels (noun) (cond (#3! ((find (compose lex- class- ! member possessor- ! rel lex) ~noun)) (list 'a noun 'can 'belong 'to 'a #3! ((find (compose lex- class- ! member possessor- ! rel lex) ~noun)))))) ;----------------------------------------------------------------------------- ; ; function: syn_noun ; input: a noun to be defined ; output: a list of probable synonyms of ; calls: compare-all functions ; local vars: supers -- a list of class inclusions of ; poss-syn -- a list of possible synonyms for ; synonyms -- a list of known synonyms for ; written: kae ??/??/92 ; modifiied: kae 05/12/94 ;----------------------------------------------------------------------------- (defun syn_noun (noun str fn cls) (prog (supers poss-syn synonyms) (setq synonyms #3! ((find (compose lex- synonym- ! synonym lex) ~noun))) (setq synonyms (weed noun synonyms nil)) (setq supers (caddr cls)) (setq poss-syn #3! ((find (compose lex- subclass- ! superclass lex) ~supers))) (cond ((null poss-syn) (return synonyms))) (setq poss-syn (weed noun poss-syn nil)) (cond ((null poss-syn) (return synonyms))) (setq poss-syn (set-difference poss-syn supers)) (cond ((null poss-syn) (return synonyms))) (setq poss-syn (set-difference poss-syn synonyms)) (cond ((null poss-syn) (return synonyms))) (setq poss-syn (compare-all-classes supers poss-syn nil)) (cond ((null poss-syn) (return synonyms))) (setq poss-syn (compare-all-structs str poss-syn nil)) (cond ((null poss-syn) (return synonyms))) (setq poss-syn (compare-all-functions fn poss-syn nil)) (cond ((null poss-syn) (return synonyms))) (setq poss-syn (compare-all-relations noun poss-syn nil)) (cond ((null poss-syn) (return synonyms))) (setq synonyms (append synonyms poss-syn)) ; #3! ((assert synonym (build lex ~noun) synonym (build lex ~poss-syn))) (return synonyms))) ;------------------------------------------------------------------------------ ; function: compare-all-classes ; input: supers, a list of the superclasses of the target noun; ; poss-syn, a list of possible synonyms for the target noun; ; syn-list, a list of those possible synonmys that survive ; comparison of superclasses (initially nil) ; returns: syn-list ; written: kae ??/??/92 ; modifiied: kae 05/12/94 ;------------------------------------------------------------------------------ (defun compare-all-classes (supers poss-syn syn-list) (cond ((null poss-syn) syn-list) ((compare_class supers (caddr (class_filter (classes (car poss-syn)) nil (car poss-syn)))) (compare-all-classes supers (cdr poss-syn) (append (list (car poss-syn)) syn-list))) (t (compare-all-classes supers (cdr poss-syn) syn-list)))) ;------------------------------------------------------------------------------ ; function: compare-all-structs ; input: noun, the target being defined ; poss-syn, a list of possible synonyms for the target noun; ; syn-list, a list of those possible synonmys that survive ; comparison of structure (initially nil). ; returns: syn-list ; written: kae ??/??/92 ; modified: kae 05/12/94 ;------------------------------------------------------------------------------ (defun compare-all-structs (str poss-syn syn-list) (cond ((null poss-syn) syn-list) ((compare_struct str (struct (car poss-syn) (classes (car poss-syn)))) (compare-all-structs str (cdr poss-syn) (append (list (car poss-syn)) syn-list))) (t (compare-all-structs str (cdr poss-syn) syn-list)))) ;------------------------------------------------------------------------------ ; function: compare-all-functions ; input: fn, the function(s) of the target being defined ; poss-syn, a list of possible synonyms for the target noun; ; syn-list, a list of those possible synonmys that survive ; comparison of function (initially nil). ; returns: syn-list ; written: kae ??/??/92 ; modified: kae 05/12/94 ;------------------------------------------------------------------------------ (defun compare-all-functions (fn poss-syn syn-list) (cond ((null poss-syn) syn-list) ((compare_func fn (func (car poss-syn))) (compare-all-functions fn (cdr poss-syn) (append (list (car poss-syn)) syn-list))) (t (compare-all-functions fn (cdr poss-syn) syn-list)))) ;------------------------------------------------------------------------------ ; function: compare-all-relations ; input: noun, the target being defined ; poss-syn, a list of possible synonyms for the target noun; ; syn-list, a list of those possible synonmys that survive ; comparison of ownership or part/whole relation ; (initially nil). ; returns: syn-list ; written: kae ??/??/92 ; modified: kae 05/12/94 ;------------------------------------------------------------------------------ (defun compare-all-relations (noun poss-syn syn-list) (cond ((null poss-syn) syn-list) ((compare_rels (indiv_rand_rels noun) (indiv_rand_rels (car poss-syn))) (compare-all-relations noun (cdr poss-syn) (append (list (car poss-syn)) syn-list))) (t (compare-all-relations noun (cdr poss-syn) syn-list)))) ;------------------------------------------------------------------------------ ; NOTE: comparison functions below may be replaced as ; experience/theory development indicates. ;------------------------------------------------------------------------------ ; ; function: compare_class (a predicate) ; input: two lists of superclasses, super1 is the superclasses of the ; target noun; super2 is the superclasses of a possible synonym. ; returns t if target and possible synonym belong to similar lists of ; superclasses, nil otherwise. ;------------------------------------------------------------------------------ (defun compare_class (super1 super2) (and (>= (length (intersection super1 super2)) (length (union (set-difference super1 super2) (set-difference super2 super1)))) (>= (length (intersection super1 super2)) 2) (no_antonyms_p super1 super2))) ;------------------------------------------------------------------------------ ; ; function: no_antonyms_p (a predicate) ; input: two lists of superclasses, super1 is the superclasses of the ; target noun; super2 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 no_antonyms_p (super1 super2) (cond ((null super1) t) (t (if (null (antonym_p (car super1) super2)) (no_antonyms_p (cdr super1) super2))))) (defun antonym_p (ant1 super2) (intersection #3! ((find (compose lex- antonym- ! antonym lex) ~ant1)) (weed (get-node-name ant1) super2 nil))) ;------------------------------------------------------------------------------ ; ; function: compare_struct (a predicate) ; input: two lists of structural elementss, struct1 is the structure ; of the target noun; struct2 is the structure of a possible ; synonym. ; returns t if target and possible synonym have similar lists of ; structural elements, nil otherwise. ;------------------------------------------------------------------------------ (defun compare_struct (struct1 struct2) (>= (length (intersection struct1 struct2)) (length (union (set-difference struct1 struct2) (set-difference struct2 struct1))))) ;------------------------------------------------------------------------------ ; ; function: compare_func (a predicate) ; input: two lists of functions, func1 is the functions of the ; target noun; func2 is the functions of a possible synonym. ; returns t if target and possible synonym have similar functions, ; nil otherwise. ;------------------------------------------------------------------------------ (defun compare_func (func1 func2) (>= (length (intersection func1 func2)) (length (union (set-difference func1 func2) (set-difference func2 func1))))) ;------------------------------------------------------------------------------ ; ; function: compare_acts (a predicate) ; input: two lists of actions, acts1 is the actions of the target ; noun; acts2 is the actions of a possible synonym. ; returns t if target and possible synonym perform similar lists of ; actions, nil otherwise. ; Note: not currently used, as actions seem too variable to provide ; a basis for deciding synonymy. ;------------------------------------------------------------------------------ (defun compare_acts (acts1 acts2) (>= (length (intersection acts1 acts2)) (length (union (set-difference acts1 acts2) (set-difference acts2 acts1))))) ;------------------------------------------------------------------------------ ; ; function: compare_rels (a predicate) ; input: two lists of relations, rels1 is the relations of the ; target noun; rels2 is the relations of a possible synonym. ; returns t if target and possible synonym have similar relations, ; nil otherwise. ;------------------------------------------------------------------------------ (defun compare_rels (rels1 rels2) (>= (length (intersection rels1 rels2)) (length (union (set-difference rels1 rels2) (set-difference rels2 rels1))))) ;------------------------------------------------------------------------------- ; ; function: weed ; input: a noun to be defined and a list of possible synonyms ; Note: the noun is a string, the elements of the list are ; nodes. ; output: the input list with the node corresponding to removed. ;------------------------------------------------------------------------------- (defun weed (noun nodelis weeded) (cond ((null nodelis) weeded) ((string-equal (string noun) (string (get-node-name (car nodelis)))) (weed noun (cdr nodelis) weeded)) (t (weed noun (cdr nodelis) (append weeded (list (car nodelis))))))) ;-------------------------------------------------------------------------------; ;------------------------------------------------------------------------------- (defun get-node-name (node) (and (sneps:node-p node) (sneps:node-na node))) .)l .in 0 Below are the revisions of the above functions that were used to generate the dictionary in chapter eight. .(l ;---------------------------------------------------------------------------- ; ; function: defn_noun ; input: a noun to be defined ; output: a report about the noun's meaning. ; calls: report_subbasic if input can be deduced to be a subclass of ; a basic-level category; ; report_basic if input can be deduced to be a basic-level ctgy ; or a subclass of animal, ; report_super if a physical object, or abstract object; ; there_exists if none of the above can be deduced. ; lastchance if there_exists turns up nil. ; Note: #3! is a macro which allows snepsul calls within lisp functions ; without having to name packages & use lots of commas & backquotes ; ; written: kae 1992 ; modified: kae 1994 ;------------------------------------------------------------------------------ (defun defn_noun (noun) (cond (#3! ((deduce object1 (build lex ~noun) rel "ISA" object2 (build lex "basic ctgy"))) (report_basic noun)) (#3! ((find (compose lex- superclass- ! subclass lex) ~noun (compose lex- object1- ! object2 lex) "basic ctgy")) (setq clas #3! ((find (compose lex- superclass- ! subclass lex) ~noun (compose lex- object1- ! object2 lex) "basic ctgy"))) (report_subbasic noun clas)) (#3! ((find (compose lex- superclass- ! subclass superclass- ! subclass lex) ~noun (compose lex- object1- ! object2 lex) "basic ctgy")) (setq clas #3! ((find (compose lex- superclass- ! subclass superclass- ! subclass lex) ~noun (compose lex- object1- ! object2 lex) "basic ctgy"))) (report_subbasic noun clas)) (#3! ((deduce subclass (build lex ~noun) superclass (build lex "animal"))) (report_basic noun)) (#3! ((deduce subclass (build lex ~noun) superclass (build lex "phys obj"))) (report_super noun)) (#3! ((deduce subclass (build lex ~noun) superclass (build lex "abstr obj"))) (report_abstr noun)) ((there_exists noun) (list (there_exists noun))) (t (lastchance noun)) )) ;------------------------------------------------------------------------------ ; ; function: lastchance ; input: a noun to be defined ; output: various bits of info that are connected with ; in the network. Called only when "there_exists" turns ; up NIL. ; written: 8/94 kae ;----------------------------------------------------------------------------- (defun lastchance (noun) (prog (junklist junk) (setq junklist nil) (setq junk #3!((find (compose lex- superclass- ! subclass lex) ~noun))) (if (not (null junk)) (setq junklist (append junklist (list 'a noun 'is 'a junk)))) (setq junk #3!((find (compose lex- subclass- ! superclass lex) ~noun))) (if (not (null junk)) (setq junklist (append junklist (list 'a junk 'is 'a noun)))) (setq junk #3!((findassert (compose cq rel lex) ~noun))) (if (null junk) (setq junk #3!((findassert (compose cq object rel lex) ~noun)))) (if (not (null junk)) (setq junklist (append junklist #3!((describe ~junk))))) (setq junk #3!((findassert (compose cq class lex) ~noun))) (if (null junk) (setq junk #3!((findassert (compose cq object2 lex) ~noun)))) (if (not (null junk)) (setq junklist (append junklist #3!((describe ~junk))))) (setq junk #3!((findassert (compose cq object lex) ~noun))) (if (not (null junk)) (setq junklist (append junklist #3!((describe ~junk))))) (setq junk #3!((findassert (compose ant class lex) ~noun))) (if (null junk) (setq junk #3!((findassert (compose ant object2 lex) ~noun)))) (if (null junk) (setq junk #3!((findassert (compose &ant class lex) ~noun)))) (if (null junk) (setq junk #3!((findassert (compose &ant object2 lex) ~noun)))) (if (not (null junk)) (setq junklist (append junklist #3!((describe ~junk))))) (setq junk #3!((findassert (compose ant rel lex) ~noun))) (if (null junk) (setq junk #3!((findassert (compose &ant rel lex) ~noun)))) (if (not (null junk)) (setq junklist (append junklist #3!((describe ~junk))))) (return junklist))) (in-package :snepsul) ;---------------------------------------------------------------------------- ; ; function: defn_verb ; input: a verb to be defined ; output: predicate structure of , with categorization of arguments; ; causal/enablement information; eventually to include primitive ; act of which is a type (if any). ; calls: report_bitransitive, or report_transitive, or report_reflexive, ; or report_intransitve, as appropriate. ; NOTE: #3! is a macro which allows snepsul commands to be invoked from ; within lisp functions; obviates need for references to pkgs, etc. ;------------------------------------------------------------------------------ (defun defn_verb (verb) (setq czs (cause verb)) (setq efs (car (effect verb))) (cond (#3! ((deduce property (build lex "bitransitive") object (build lex ~verb))) (report_bitransitive verb czs efs)) (#3! ((deduce property (build lex "transitive") object (build lex ~verb))) (report_transitive verb czs efs)) (#3! ((deduce property (build lex "reflexive") object (build lex ~verb))) (report_reflexive verb czs efs)) (t (report_intransitive verb czs efs)))) ;----------------------------------------------------------------------------- ; ; function: report_bitransitive ; input: a verb to be defined ; output: predicate structure of , with categorization of arguments; ; causal/enablement information; eventually to include primitive ; act of which is a type (if any). ; calls: categorize_subject, categorize_object, categorize_indobject, ; cause, effect, (prim_base currently undefined) ;---------------------------------------------------------------------------- (defun report_bitransitive (verb czs efs) (list 'a (categorize_subject verb) 'can verb 'a (categorize_object verb) 'to 'a (categorize_indobject verb) 'result= #3!((describe ~czs)) 'enabled 'by= #3!((describe ~efs)) ; (prim_base verb) )) ;----------------------------------------------------------------------------- ; ; function: report_transitive ; input: a verb to be defined ; output: predicate structure of , with categorization of arguments; ; causal/enablement information; eventually to include primitive ; act of which is a type (if any). ; calls: categorize_subject, categorize_object, cause, effect, ; (prim_base currently undefined) ;---------------------------------------------------------------------------- (defun report_transitive (verb czs efs) (list 'a (categorize_subject verb) 'can verb 'a (categorize_object verb) 'result= czs 'enabled 'by= #3!((describe ~efs)) ; (prim_base verb) )) ;----------------------------------------------------------------------------- ; ; function: report_reflexive ; input: a verb to be defined ; output: predicate structure of , with categorization of arguments; ; causal/enablement information; eventually to include primitive ; act of which is a type (if any). ; calls: categorize_subject, cause, effect, ; (prim_base currently undefined) ;---------------------------------------------------------------------------- (defun report_reflexive (verb czs efs) (list 'a (categorize_subject verb) 'can verb 'itself 'result= #3!((describe ~czs)) 'enabled 'by= #3!((describe ~efs)) ; (prim_base verb) )) ;----------------------------------------------------------------------------- ; ; function: report_intransitive ; input: a verb to be defined ; output: predicate structure of , with categorization of argument; ; causal/enablement information; eventually to include primitive ; act of which is a type (if any). ; calls: categorize_subject, cause, effect, ; (prim_base currently undefined) ;---------------------------------------------------------------------------- (defun report_intransitive (verb czs efs) (list 'a (categorize_subject verb) 'can verb 'result= #3!((describe ~czs)) 'enabled 'by= #3!((describe ~efs)) ; 'result= czs ; 'enabled 'by= efs ; (prim_base verb) )) ;------------------------------------------------------------------------------ ; ; function: categorize_subject ; input: a verb to be defined ; output: categorization of encountered subjects of as (in order ; of preference) 1)belonging to some basic level category, ; 2)belonging to some subclass of animal, or 3)belonging to some ; miscellaneous (but known) class. ; calls: base_cat_subj, anim_subj, some_cat_subj, emptyp ;------------------------------------------------------------------------------ (defun categorize_subject (verb) (cond ((emptyp (list (base_cat_subj verb) (anim_subj verb))) (setq subject (some_cat_subj verb)) (if (listp subject) (cathelper subject nil) subject)) ((emptyp (base_cat_subj verb)) (cathelper (anim_subj verb) nil)) (t (cathelper (base_cat_subj verb) nil)))) ;------------------------------------------------------------------------------ ; ; function: person_subj (function not currently used in defining verb) ; input: a verb to be defined ; output: the atom 'person, if a member of the class person has been ; encountered as the subject of ;------------------------------------------------------------------------------ (defun person_subj (verb) (cond ((AND #3! ((deduce agent $vsub act (build lex ~verb))) #3! ((deduce member *vsub class (build lex "person")))) 'person))) ;------------------------------------------------------------------------------- ; ; function: anim_subj ; input: a verb to be defined ; output: a list of the kinds of animal which have been known to ;------------------------------------------------------------------------------- (defun anim_subj (verb) (cond ((AND #3! ((deduce agent $vsub1 act (build lex ~verb))) #3! ((deduce member *vsub1 class (build lex "animal")))) (append #3! ((find (compose lex- class- ! member agent- ! act lex) ~verb)) #3! ((find (compose lex- class- ! members agent- ! act lex) ~verb)))) ; (#3! ((find (compose lex- class- member ; agent- act lex) ~verb)) ; (list #3! ((find (compose lex- class- member ; agent- act lex) ~verb)))) )) ;------------------------------------------------------------------------------- ; ; function: base_cat_subj ; input: a verb to be defined ; output: a list of basic level categs. which have been known to ;------------------------------------------------------------------------------- (defun base_cat_subj (verb) (cond ((AND #3! ((deduce agent $vsub2 act (build lex ~verb))) (OR #3! ((deduce member *vsub2 class $vbasic)) #3! ((deduce members *vsub2 class $vbasic))) #3! ((deduce object1 *vbasic rel "ISA" object2 (build lex "basic ctgy")))) (append #3! ((find (compose lex- class- ! member agent- ! act lex) ~verb)) #3! ((find (compose lex- class- ! members agent- ! act lex) ~verb)))))) ;------------------------------------------------------------------------------- ; ; function: some_cat_subj ; input: a verb to be defined ; output: a list of the kinds of things which have been known to ; or the atom 'something, if nothing known about what can . ;------------------------------------------------------------------------------- (defun some_cat_subj (verb) (cond ((AND #3! ((deduce agent $vsub3 act (build lex ~verb))) (OR #3! ((deduce object1 *vsub3 rel "ISA" object2 $somecat)) #3! ((deduce objects1 *vsub3 rel "ARE" object2 $somecat)))) (append #3! ((find (compose lex- object2- ! object1 agent- ! act lex) ~verb)) #3! ((find (compose lex- object2- ! objects1 agent- ! act lex) ~verb)))) ; (#3! ((find (compose lex- object2- object1 ; agent- act lex) ~verb)) ; (list #3! ((find (compose lex- object2- object1 ; agent- act lex) ~verb)))) (t 'something))) ;----------------------------------------------------------------------------- ; ; function: categorize_object ; input: a verb to be defined ; output: categorization of encountered objects of as (in order ; of preference) 1)belonging to some basic level category, ; 2)belonging to some subclass of animal, or 3)belonging to some ; miscellaneous (but known) class. ; calls: base_cat_obj, anim_obj, some_cat_obj, emptyp ;------------------------------------------------------------------------------ (defun categorize_object (verb) (cond ((emptyp (list (base_cat_obj verb) (anim_obj verb))) (setq object (some_cat_obj verb)) (if (listp object) (cathelper object nil) object)) ((emptyp (base_cat_obj verb)) (cathelper (anim_obj verb) nil)) (t (cathelper (base_cat_obj verb) nil)))) ;------------------------------------------------------------------------------ ; ; function: person_obj (function not currently used in defining verb) ; input: a verb to be defined ; output: the atom 'person, if a member of the class person has been ; encountered as the object of ;------------------------------------------------------------------------------ (defun person_obj (verb) (cond ((AND #3! ((deduce object $vobj agent $vsub4 act (build lex ~verb))) #3! ((deduce member *vobj class (build lex "person")))) 'person))) ;------------------------------------------------------------------------------- ; ; function: base_cat_obj ; input: a verb to be defined ; output: a list of basic categs. of things known to have been ed. ;------------------------------------------------------------------------------- (defun base_cat_obj (verb) (cond ((AND #3! ((deduce object $vobj1 agent $vsub5 act (build lex ~verb))) #3! ((deduce member *vobj1 class $vbasic1)) #3! ((deduce object1 *vbasic1 rel "ISA" object2 (build lex "basic ctgy")))) (append #3! ((find (compose lex- class- ! member object- ! act lex) ~verb)) #3! ((find (compose lex- class- ! members object- ! act lex) ~verb)))) ; (#3! ((find (compose lex- class- member ; object- act lex) ~verb)) ; (list #3! ((find (compose lex- class- member ; object- act lex) ~verb)))) )) ;------------------------------------------------------------------------------- ; ; function: anim_obj ; input: a verb to be defined ; output: a list of the kinds of animals known to have been ed. ;------------------------------------------------------------------------------- (defun anim_obj (verb) (cond ((AND #3! ((deduce agent $vsub6 object $vobj2 act (build lex ~verb))) #3! ((deduce member *vobj2 class (build lex "animal")))) (append #3! ((find (compose lex- class- ! member object- ! act lex) ~verb)) #3! ((find (compose lex- class- ! members object- ! act lex) ~verb)))))) ;------------------------------------------------------------------------------- ; ; function: some_cat_obj ; input: a verb to be defined ; output: a list of the kinds of things known to have been ed, ; or the atom 'something, if nothing known about what can ; be ed. ;------------------------------------------------------------------------------- (defun some_cat_obj (verb) (cond ((AND #3! ((deduce agent $vsub7 object $vobj3 act (build lex ~verb))) (OR #3! ((deduce object1 *vobj3 rel "ISA" object2 *somecat)) #3! ((deduce object1 *vobj3 rel "ISA" object2 *somecat)))) (append #3! ((find (compose lex- object2- ! object1 agent- ! act lex) ~verb)) #3! ((find (compose lex- object2- ! objects1 agent- ! act lex) ~verb)))) ; (#3! ((find (compose lex- object2- object1 ; agent- act lex) ~verb)) ; (list #3! ((find (compose lex- object2- object1 ; agent- act lex) ~verb)))) (t 'something))) ;----------------------------------------------------------------------------- ; ; function: categorize_indobject ; input: a verb to be defined ; output: categorization of encountered indirect objects of as ; (in order of preference) 1)belonging to some basic level ; category, 2)belonging to some subclass of animal, or ; 3)belonging to some miscellaneous (but known) class. ; calls: base_cat_indobj, anim_indobj, some_cat_indobj, emptyp ;------------------------------------------------------------------------------ (defun categorize_indobject (verb) (cond ((emptyp (list (base_cat_indobj verb) (anim_indobj verb))) (setq indobject (some_cat_indobj verb)) (if (listp indobject) (cathelper indobject nil) indobject)) ((emptyp (base_cat_indobj verb)) (cathelper (anim_indobj verb) nil)) (t (cathelper (base_cat_indobj verb) nil)))) ;------------------------------------------------------------------------------ ; ; function: person_indobj (function not currently used in defining verb ) ; input: a verb to be defined ; output: the atom 'person, if a member of the class person has been ; encountered as the indirect object of ;------------------------------------------------------------------------------ (defun person_indobj (verb) (cond ((AND #3! ((deduce indobj $vindobj object $vobj4 agent $vsub8 act (build lex ~verb))) #3! ((deduce member *vindobj class (build lex "person")))) 'person))) ;------------------------------------------------------------------------------- ; ; function: base_cat_indobj ; input: a verb to be defined ; output: a list of basic categs. of things encountered as indirect ; object of ;------------------------------------------------------------------------------- (defun base_cat_indobj (verb) (cond ((AND #3! ((deduce object $vobj5 agent $vsub9 indobj $vindobj1 act (build lex ~verb))) #3! ((deduce member *vindobj1 class $vbasic1)) #3! ((deduce object1 *vbasic1 rel "ISA" object2 (build lex "basic ctgy")))) (append #3! ((find (compose lex- class- ! member indobj- ! act lex) ~verb)) #3! ((find (compose lex- class- ! members indobj- ! act lex) ~verb)))) ; (#3! ((find (compose lex- class- member ; indobj- act lex) ~verb)) ; (list #3! ((find (compose lex- class- member ; indobj- act lex) ~verb)))) )) ;------------------------------------------------------------------------------- ; ; function: anim_indobj ; input: a verb to be defined ; output: a list of the kinds of animals known to have been the indirect ; object of . ;------------------------------------------------------------------------------- (defun anim_indobj (verb) (cond ((AND #3! ((deduce agent $vsub9 object $vobj6 indobj $vindobj2 act (build lex ~verb))) #3! ((deduce member *vindobj2 class (build lex "animal")))) (append #3! ((find (compose lex- class- ! member indobj- ! act lex) ~verb)) #3! ((find (compose lex- class- ! members indobj- ! act lex) ~verb)))) )) ;------------------------------------------------------------------------------- ; ; function: some_cat_indobj ; input: a verb to be defined ; output: a list of the kinds of things known to have been the indirect ; object of , if any; ; the atom 'something if nothing known about what can be the ; indirect object of ;------------------------------------------------------------------------------- (defun some_cat_indobj (verb) (cond ((AND #3! ((deduce agent $vsub10 object $vobj7 indobj $vindobj3 act (build lex ~verb))) (OR #3! ((deduce object1 *vindobj3 rel "ISA" object2 *somecat)) #3! ((deduce object1 *vindobj3 rel "ISA" object2 *somecat)))) (append #3! ((find (compose lex- object2- ! object1 indobj- ! act lex) ~verb)) #3! ((find (compose lex- object2- ! objects1 indobj- ! act lex) ~verb)))) ; (#3! ((find (compose lex- object2- object1 ; indobj- act lex) ~verb)) ; (list #3! ((find (compose lex- object2- object1 ; indobj- act lex) ~verb)))) (t 'something))) ;----------------------------------------------------------------------------- ; ; function: cause ; input: a verb to be defined ; output: a list containing the result of . List will contain ; either propositions (molecular nodes) or patterns for them, ; from rules (pattern node). ;----------------------------------------------------------------------------- (defun cause (verb) (cond (#3! ((deduce object1 (build agent *vsub11 act (build lex ~verb)) rel (build lex "enable") object2 $goal)) (cond (#3! ((find (compose cq- ! ant act lex) ~verb)) (list #3! ((find (compose cq- ! ant act lex) ~verb)) 'or 'to 'enable #3! ((find (compose lex- act- object2- ! rel lex) "enable" (compose lex- act- object2- ! object1 act lex) ~verb)))) (t (list 'to 'enable #3! ((find (compose lex- act- object2- ! rel lex) "enable" (compose lex- act- object2- ! object1 act lex) ~verb)))))) (#3! ((deduce mode (build lex "presumably") object (build object1 (build agent *vsub11 act (build lex ~verb) time $vtime) rel (build lex "enable") object2 $goal))) (cond (#3! ((find (compose cq- ! ant act lex) ~verb)) (list #3! ((find (compose cq- ! ant act lex) ~verb)) 'or 'to 'enable #3! ((find (compose lex- act- object2- rel lex) "enable" (compose lex- act- object2- object1 act lex) ~verb (compose lex- act- object2- object- ! mode lex) "presumably")))) (t (list 'to 'enable #3! ((find (compose lex- act- object2- rel lex) "enable" (compose lex- act- object2- object1 act lex) ~verb (compose lex- act- object2- object- ! mode lex) "presumably")))))) (#3! ((find (compose cq- ! ant act lex) ~verb)) (list #3! ((find (compose cq- ! ant act lex) ~verb)))) (#3! ((find (compose cq- ! &ant act lex) ~verb)) (list #3! ((find (compose cq- ! &ant act lex) ~verb)))) (#3! ((deduce cause (build agent $vsub11 act (build lex ~verb)) effect $result)) (list #3! ((find (compose effect- cause act lex) ~verb)))))) ;----------------------------------------------------------------------------- ; ; function: effect ; input: a verb to be defined ; output: a list containing the enabling conditions ; of . List will contain either propositions (molecular ; nodes) or patterns for them, from rules (pattern node). ;----------------------------------------------------------------------------- (defun effect (verb) (cond (#3! ((find (compose ant- ! cq act lex) ~verb)) (list #3! ((find (compose ant- ! cq act lex) ~verb)))) (#3! ((find (compose &ant- ! cq act lex) ~verb)) (list #3! ((find (compose &ant- ! cq act lex) ~verb)))))) ;----------------------------------------------------------------------------- (defun prim_base (verb) '(not set yet)) ;----------------------------------------------------------------------------- ; ; function: emptyp (a predicate) ; input: a list ; output: t if the input list is empty, or a list* of empty lists, ; nil if list contains any elements which are non-null. ;---------------------------------------------------------------------------- (defun emptyp (lst) (cond ((null lst) t) ((AND (listp lst) (emptyp (car lst))) (emptyp (cdr lst))))) (defun cathelper (lst aset) (cond ((null lst) aset) (t (cathelper (cdr lst) (adjoin (car lst) aset))))) ;----------------------------------------------------------------------------- ;Below are listed the modifications made to create the dictionary of chapter eight. ;----------------------------------------------------------------------------- ; ; function: report_intransitive ; input: a verb to be defined ; output: predicate structure of , with categorization of argument; ; causal/enablement information; eventually to include primitive ; act of which is a type (if any). ; calls: categorize_subject, cause, effect, and lastcahnce_v if the ; standard algorithm turns up nothing useful. ; (prim_base currently undefined) ;---------------------------------------------------------------------------- (defun report_intransitive (verb czs efs) (setq intr_subj (categorize_subject verb)) (cond ((AND (eq intr_subj 'SOMETHING) (null czs) (null efs)) (lastchance_v verb)) (t (list 'a (categorize_subject verb) 'can verb 'result= #3!((describe ~czs)) 'enabled 'by= #3!((describe ~efs)) ; (prim_base verb) )))) ;----------------------------------------------------------------------------- ; ; function: lastchance_v ; input: a verb to be defined ; output: whatever we can find out about the verb for which ; enablement, effect, and argument structure couldn't be ; deduced. ;----------------------------------------------------------------------------- (defun lastchance_v (verb) (prog (junk junklist) (setq junklist nil) (setq junk #3!((find (compose lex- object2- ant- ! cq rel lex) "function" (compose lex- object2- object1 object1- rel lex) "function" (compose lex- object2- ant- ! cq object2 lex) ~verb (compose lex- object2- object1 object1- object2 lex) ~verb))) (if (null junk) (setq junk #3!((find (compose lex- object2- ant- ! cq object rel lex) "function" (compose lex- object2- object1 object1- rel lex) "function" (compose lex- object2- ant- ! cq object object2 lex) ~verb (compose lex- object2- object1 object1- object2 lex) ~verb)))) (if (not (null junk)) (setq junklist (list 'the 'function 'of 'a junk 'is 'to verb))) (setq junk #3!((find (compose lex- synonym- ! synonym lex) ~verb))) (setq junk (set-difference junk (list verb))) (if (not (null junk)) (setq junklist (append junklist (list 'synonyms= junk)))) (setq junk #3!((findassert (compose cq act lex) ~verb))) (if (null junk) (setq junk #3!((findassert (compose cq object act lex) ~verb)))) (if (null junk) (setq junk #3!((findassert (compose cq arg act lex) ~verb)))) (if (not (null junk)) (setq junklist (append junklist junk))) (setq junk #3!((findassert (compose cq part act lex) ~verb))) (if (not (null junk)) (setq junklist (append junklist junk))) (setq junk #3!((findassert (compose cq whole act lex) ~verb))) (if (not (null junk)) (setq junklist (append junklist junk))) (setq junk #3!((findassert (compose cq object rel lex) ~verb))) (if (not (null junk)) (setq junklist (append junklist junk))) (return junklist))) ;Functions for Revising Rules ;Original Functions (in-package :snebr) ;------------------------------------------------------------------------------ ; ; function: revise-rule. For use in the fn, remove-and-add ; ; argument: a singleton , rule. Must be a molecular rule node ; ; returns: an appropriately revised rule. ; ; written: kae 5/20/93 ; modified: kae 5/28/93 ; (defun revise-rule (rule) (let ((pattern (locate-pattern rule)) (cqlis (locate-cqs rule))) (cond ((and (islife-rule.2 rule) (isor-entail rule)) (if (>= (length cqlis) 2) (if (find-cause-effect pattern cqlis) (create-2-rules rule pattern cqlis) (soften-one-conjunct rule pattern)) (soften-rule rule))) ((and (islife-rule.2 rule) (not (isor-entail rule))) (if (>= (length cqlis) 2) (if (find-cause-effect pattern cqlis) (create-2-rules-and-entail rule pattern cqlis) (soften-one-conjunct-and-entail rule pattern)) (soften-rule-and-entail rule))) ((isor-entail rule) ;;; and better than life-rule.2 (if (>= (length cqlis) 2) (if (find-cause-effect pattern cqlis) (add-disj-to-depend-conj-cqs rule pattern cqlis) (add-disj-to-indep-conjunct-cqs rule pattern)) (if (hasmin-max rule) (add-disj-to-mult-disjs rule) (add-disj-to-single-cq rule pattern)))) (t ;;; and-entailment and better than l-r.2 (if (>= (length cqlis) 2) (if (find-cause-effect cqlis) (add-disj-to-depend-conj-cqs-and-entail rule pattern cqlis) (add-disj-to-indep-conjunct-cqs-and-entail rule pattern)) (if (hasmin-max rule) (add-disj-to-mult-disjs-and-entail rule) (add-disj-to-single-cq-and-entail rule pattern)))) ))) ;------------------------------------------------------------------------------ ; ; predicates: islife-rule.1 and islife-rule.2 ; ; arguments : a molecular rule node ; ; returns : t if the rule node is of that kn_cat; nil o/w. ; ; written:kae 5/24/93 ; (defun islife-rule.2 (badrule) (string= "life-rule.2" (symbol-name (sneps:node-na (first (rule-kn_cat badrule)))))) (defun islife-rule.1 (badrule) (string= "life-rule.1" (symbol-name (sneps:node-na (first (rule-kn_cat badrule)))))) ;------------------------------------------------------------------------------ ; ; function: rule-kn_cat, a selector function ; ; argument: a , rule. Must be a molecular rule node. ; ; returns: the at the head of the kn_cat arc from rule ; (actually, the singleton nodeset of said ) ; ; written: kae 5/20/93 ; (defun rule-kn_cat (rule) #3!((find kn_cat- ~rule))) ;------------------------------------------------------------------------------ ; ; function: isor-entail. A predicate ; ; argument: a , rule. Must be a molecular rule node. ; ; returns: t if rule uses or-entailment; nil o/w (it uses and-entailment) ; ; written: kae 5/28/93 ; (defun isor-entail (rule) (not (null #3!((find ant- ~rule))))) ;------------------------------------------------------------------------------ ; ; function: locate-cqs ; ; argument: a , rule. A singleton rule node ; ; returns: a containing the consequents of the input rule. ; ; written: kae 5/20/93 ; modified: kae 5/24/93 ; (defun locate-cqs (rule) (do* ((downs (sneps:down.fcs (first rule)) (cddr downs))) ((string= (symbol-name (first downs)) "CQ") (second downs)) (if (null downs) (return nil)))) ;------------------------------------------------------------------------------ ; ; function: isdependent. A predicate (No longer used, find-cause-effect ; used instead) ; ; arguments: a , cqlist, containing the pattern nodes at the ; heads of the cq arcs from a rule. ; ; returns: t if any of the pattern nodes from cqlist dominates patterns ; which also show up as consequents of the original rule; ; nil otherwise ; ; written: kae 5/20/93 ; (defun isdependent (cqlist) (do* ((cqs cqlist (rest cqs))) ((null cqs) nil) (if (or (subsetp (second (sneps:down.fcs (first cqs))) cqlist) (subsetp (fourth (sneps:down.fcs (first cqs))) cqlist)) (return t)))) ;------------------------------------------------------------------------------ ; ; function: soften-one-conjunct ; ; arguments: two , a rule node, badrule, and a pattern node, ; badpattern. badpattern is one of badrule's cqs ; ; returns: a new rule with badpattern softened to "possibly badpattern" ; ; written: kae 5/13/90 ; (defun soften-one-conjunct (badrule badpattern) (setq goodcqs (set-difference #3!((find cq- ~badrule)) (list badpattern))) (if (null (cdr goodcqs)) (setq goodcqs (car goodcqs))) #3!((assert forall (find forall- ~badrule) ant (find ant- ~badrule) cq (~goodcqs (build mode (build lex "qpossibly") object ~badpattern)) kn_cat "questionable"))) ;------------------------------------------------------------------------------ ; ; function: soften-one-conjunct-and-entail ; ; arguments: two , a rule node, badrule, that uses and entailment ; and a pattern node, badpattern. badpattern ; is one of badrule's cqs ; ; returns: a new rule with badpattern softened to "possibly badpattern" ; ; written: kae 5/28/90 ; (defun soften-one-conjunct-and-entail (badrule badpattern) (setq goodcqs (set-difference #3!((find cq- ~badrule)) (list badpattern))) (if (null (cdr goodcqs)) (setq goodcqs (car goodcqs))) #3!((assert forall (find forall- ~badrule) &ant (find &ant- ~badrule) cq (~goodcqs (build mode (build lex "qpossibly") object ~badpattern)) kn_cat "questionable"))) ;------------------------------------------------------------------------------ ; ; function: soften-rule ; ; argument: a molecular rule (having only a single cq arc) ; ; returns: a equivalent to badrule, except that the consequent ; is now a possible consequent ; ; written: kae 4/15/93 ; (defun soften-rule (badrule) #3! ((assert forall (find forall- ~badrule) ant (find ant- ~badrule) cq (build mode (build lex "qpossibly") object (find cq- ~badrule)) kn_cat "questionable"))) ;------------------------------------------------------------------------------ ; ; function: soften-rule-and-entail ; ; argument: a molecular rule (having only a single cq arc and ; conjunct antecedents) ; ; returns: a equivalent to badrule, except that the consequent ; is now a possible consequent ; ; written: kae 5/28/93 ; (defun soften-rule-and-entail (badrule) #3! ((assert forall (find forall- ~badrule) &ant (find &ant- ~badrule) cq (build mode (build lex "qpossibly") object (find cq- ~badrule)) kn_cat "questionable"))) ;------------------------------------------------------------------------------ ; ; function: create-2-rules ; ; arguments: 2 , the first a molecular rule node to revise ; the second the pattern node which has been found ; to be the problem, ; and a list of all the consequents of badrule. ; ; returns: a rule node (?) ; ; side-effects: creates 2 rules, the first is the original with the ; questionable consequent marked as a possible and any ; cause-effect consequents involving the questionable cq removed; ; the second adds the questionable consequent to its antecedent, ; and uses the old cause-effect cq as its only cq. ; ; written: kae 5/24/93 ; (defun create-2-rules (badrule badpattern cqlist) (setq badpat2 (find-cause-effect badpattern cqlist)) (setq goodcqs (set-difference #3!((find cq- ~badrule)) (list badpattern badpat2))) (if (null (cdr goodcqs)) (setq goodcqs (car goodcqs))) #3! ((assert forall (find forall- ~badrule) ant (find ant- ~badrule) cq (~goodcqs (build mode (build lex "qpossibly") object ~badpattern)) kn_cat "questionable")) #3! ((assert forall (find forall- ~badrule) &ant ((find ant- ~badrule) ~badpattern) cq ~badpat2 kn_cat (find kn_cat- ~badrule)))) ;------------------------------------------------------------------------------ ; ; function: create-2-rules-and-entail ; ; arguments: 2 , the first a molecular rule node to revise ; the second the pattern node which has been found ; to be the problem, ; and a list of all the consequents of badrule. ; ; returns: a rule node (?) ; ; side-effects: creates 2 rules, the first is the original with the ; questionable consequent marked as a possible and any ; cause-effect consequents involving the questionable cq removed; ; the second adds the questionable consequent to its antecedent, ; and uses the old cause-effect cq as its only cq. ; ; written: kae 5/28/93 ; (defun create-2-rules-and-entail (badrule badpattern cqlist) (setq badpat2 (find-cause-effect badpattern cqlist)) (setq goodcqs (set-difference #3!((find cq- ~badrule)) (list badpattern badpat2))) (if (null (cdr goodcqs)) (setq goodcqs (car goodcqs))) #3! ((assert forall (find forall- ~badrule) &ant (find &ant- ~badrule) cq (~goodcqs (build mode (build lex "qpossibly") object ~badpattern)) kn_cat "questionable")) #3! ((assert forall (find forall- ~badrule) &ant ((find &ant- ~badrule) ~badpattern) cq ~badpat2 kn_cat "life-rule.2"))) ;------------------------------------------------------------------------------ ; ; function: find-cause-effect ; ; arguments: a pattern (from the cq of a rule) which is known ; to produce a contradiction. ; a of all the cqs from that rule (note: cqlist ; includes batpattern) ; ; returns: a pattern (from the cqlist) which itself has either ; a cause arc or an effect arc to badpattern. ; or nil if no such pattern exists. ; ; written: kae 5/24/93 ; (defun find-cause-effect (badpattern cqlist) (print badpattern) (do* ((cqs cqlist (rest cqs)) (crntcq (first cqs) (first cqs))) ((null cqs) nil) (setq crntdowns (sneps:down.fcs crntcq)) (if (or (sneps::iseq.n badpattern (first (fourth crntdowns))) (sneps::iseq.n badpattern (first (second crntdowns)))) (return crntcq)))) (in-package :snebr) ;---------------------------------------------------------------------------- ; ; function: locate-pattern ; ; argument: a , alt. Must be a molecular rule node. ; (In practice, it's the node selected for removal ; from a conflict set which invoked snebr.) ; ; returns: a , p, (p will be a pattern node from the ; consequent of alt.) ; or NIL, if alt doesn't have an appropriate cq. ; ; description: iterates locate-n for each cq in alt until ; either one is found which matches (modulo variable ; subsitution) an item in the jsupport of *probnode* ; or *altprobnode* or until all cqs have been tried ; and no match is found. Essentially an outer loop ; with locate-n as the inner loops. ; ; written: kae 5/10/93 (defun locate-pattern (alt) (do* ((p-list #3!((find cq- ~alt)) (rest p-list)) (p (first p-list) (first p-list))) ((or (null p) (locate-n *probnode* p) (locate-n *altprobnode* p)) (if (null p) nil p)))) ;---------------------------------------------------------------------------- ; ; function: locate-n ; ; argument: two s, newnode is a molecular proposition ; (in practice, the *probnode* or *altprobnode* whose ; assertion created a contradiction which invoked snebr) ; and p is a pattern node. ; ; returns: a list of two , p and n, (n is a node from jsupport ; of *probnode* which either matches p, or negates p ; when fired.) ; or NIL, if there is no match in the jsupport of *probnode* ; ; description: iterates iseq-mod-subst.n for each n until ; either one is found which matches (modulo variable ; subsitution) the fixed pattern p or until all the ; jsupports have been tried and no match is found. ; If no match is found, iterates isnegated-by for each ; n until either an n is found with a consequent to match ; the negation of p (modulo variable subst), or none exists. ; ; written: kae 5/10/93 ; modified: kae 5/31/93 (defun locate-n (newnode p) (if (not (null p)) (do* ((n-list (first (sneps::node-jsupport newnode)) (rest n-list)) (n (first n-list) (first n-list)) (p p)) ((or (null n) (iseq-mod-subst.n p n) (isnegated-by p n)) (if (null n) nil (list p n)))) nil)) ;------------------------------------------------------------------------------ ; ; function: isnegated-by. A predicate. ; ; arguments: two , a pattern and (ideally) a rule. If the second ; argument isn't a rule, should just return nil. ; ; returns: t if input rule has a (cq arg) path to a pattern which ; is eq-mod-subst to the input pattern; ; nil, otherwise ; ; written: kae 5/31/93 ; (defun isnegated-by (pattern rule) (if (not (null rule)) (do* ((cqs #3!((find cq- ~rule)) (rest cqs)) (crntcq (first cqs) (first cqs))) ((null cqs) nil) (if (iseq-mod-subst.n (first #3!((find arg- ~crntcq))) pattern) (return t))) nil)) ;----------------------------------------------------------------------------- ; ; function: has-verb-ant ; ; argument: rule, a singleton . Should contain a molecular rule ; node. ; ; written: kae 8/11/93 ; (defun has-verb-ant (rule) (setq rul1 (first (first rule))) (if #3!((find (compose act- ant-) ~rul1)) t nil)) (in-package :snebr) (defun iseq-mod-subst.n (p n) (if (not (null n)) (iscomparable.fcs (sneps:down.fcs p) (sneps:down.fcs n)) nil)) ;------------------------------------------------------------------------------ ; ; predicate: iscomparable.fcs ; ; arguments: two s, fcs1 and fcs2. ; ; returns: t if each of the cables in fcs1 has a comparable cable in fcs2 ; (and vice versa). ; nil otherwise ; ; written: kae 5/10/93 ; (defun iscomparable.fcs (fcs1 fcs2) (cond ((and (null fcs1) (null fcs2)) t) ((or (null fcs1) (null fcs2)) nil) ;;; unsure about (null fcs1) case ((iscomparable.c (cons (first fcs1) (second fcs1)) (cons (first fcs2) (second fcs2))) (iscomparable.fcs (rest (rest fcs1)) (rest (rest fcs2)))))) ;------------------------------------------------------------------------------ ; ; predicate: iscomparable.c ; ; arguments: two s, c1 and c2. ; ; returns: t if its arguments are eq; or if their relations are eq and ; their node sets are comparable. ; nil otherwise ; ; written: kae 5/10/93 ; (defun iscomparable.c (c1 c2) (cond ((sneps::iseq.c c1 c2) t) ((sneps::iseq.r (first c1) (first c2)) (iscomparable.ns (rest c1) (rest c2))))) ;------------------------------------------------------------------------------ ; ; predicate: iscomparable.ns ; ; arguments: two s, ns1 and ns2. ; ; returns: t if its arguments are eq; or if each in one argument ; has a comparable node in the other. ; nil otherwise ; ; written: kae 5/10/93 ; (defun iscomparable.ns (ns1 ns2) (cond ((sneps::iseq.ns ns1 ns2) t) ((iscomparable.n (first ns1) (first ns2)) (iscomparable.ns (rest ns1) (rest ns2))))) ;------------------------------------------------------------------------------ ; ; predicate: iscomparable.n ; ; arguments: two s, n1 and n2. ; ; returns: t if its arguments are eq; or if one is a variable node and ; the other is either a base node or another variable node ; or the node at the tail of a lex arc. ; nil otherwise ; ; written: kae 5/10/93 ; (defun iscomparable.n (n1 n2) (cond ((sneps::iseq.n n1 n2) t) ((and (sneps::isvar.n n1) (sneps::isbase.n n2)) t) ((and (sneps::isvar.n n2) (sneps::isbase.n n1)) t) ((and (sneps::isvar.n n1) (sneps::isvar.n n2)) t) ((and (sneps::isvar.n n1) (ismol-lex.n n2)) t) ((and (sneps::isvar.n n2) (ismol-lex.n n1)) t))) ;------------------------------------------------------------------------------ ; ; predicate: ismol-lex.n ; ; arguments: a ; ; returns: t if its argument is a molecular node at the tail of a lex arc. ; nil otherwise ; ; written: kae 5/10/93 ; (defun ismol-lex.n (n) (and (sneps::ismol.n n) (eq (first (sneps::down.fcs n)) 'lex))) (in-package :snebr) ;------------------------------------------------------------------------------ ; ; functions to revise rules of kn_cat better than life-rule.2 by ; adding a new "SOMETHING" disjunct, when the understanding ; expressed in current cqs is not complete. ; ; written: kae 5/28/93 ; (defun add-disj-to-single-cq (rule pattern) (print "entering add-disj-to-single") #3!((assert forall (find forall- ~rule) ant (find ant- ~rule) cq (build min 1 max 1 arg ~pattern arg "SOMETHING") kn_cat (find kn_cat- ~rule)))) (defun add-disj-to-mult-disjs (rule) #3!((assert forall (find forall- ~rule) ant (find ant- ~rule) cq (build min (find (compose min- cq- ~rule)) max (find (compose max- cq- ~rule)) arg (find (compose arg- cq- ~rule)) arg "SOMETHING") kn_cat (find kn_cat- ~rule)))) (defun add-disj-to-indep-conjunct-cqs (rule pattern) (setq goodcqs (set-difference #3!((find cq- ~rule)) (list pattern))) #3!((assert forall (find forall- ~rule) ant (find ant- ~rule) cq (~goodcqs (build min 1 max 1 arg ~pattern arg "SOMETHING")) kn_cat (find kn_cat- ~rule)))) (defun add-disj-to-depend-conj-cqs (rule pattern cqlist) (setq pat2 (find-cause-effect pattern cqlist)) (setq goodcqs (set-difference #3!((find cq- ~rule)) (list pattern pat2))) (if (null (cdr goodcqs)) (setq goodcqs (car goodcqs))) #3!((assert forall (find forall- ~rule) ant (find ant- ~rule) cq (~goodcqs (build min 1 max 1 arg ~pattern arg "SOMETHING")) kn_cat (find kn_cat- ~rule))) #3!((assert forall (find forall- ~rule) &ant ((find ant- ~rule) ~pattern) cq ~pat2 kn_cat (find kn_cat- ~rule)))) (defun add-disj-to-single-cq-and-entail (rule pattern) #3!((assert forall (find forall- ~rule) &ant (find &ant- ~rule) cq (build min 1 max 1 arg ~pattern arg "SOMETHING") kn_cat (find kn_cat- ~rule)))) (defun add-disj-to-mult-disjs-and-entail (rule) #3!((assert forall (find forall- ~rule) &ant (find &ant- ~rule) cq (build min (find (compose min- cq- ~rule)) max (find (compose max- cq- ~rule)) arg (find (compose arg- cq- ~rule)) arg "SOMETHING") kn_cat (find kn_cat- ~rule)))) (defun add-disj-to-indep-conjunct-cqs-and-entail (rule pattern) (setq goodcqs (set-difference #3!((find cq- ~rule)) (list pattern))) #3!((assert forall (find forall- ~rule) &ant (find &ant- ~rule) cq (~goodcqs (build min 1 max 1 arg ~pattern arg "SOMETHING")) kn_cat (find kn_cat- ~rule)))) (defun add-disj-to-depend-conj-cqs-and-entail (rule pattern cqlist) (setq pat2 (find-cause-effect pattern cqlist)) (setq goodcqs (set-difference #3!((find cq- ~rule)) (list pattern pat2))) (if (null (cdr goodcqs)) (setq goodcqs (car goodcqs))) #3!((assert forall (find forall- ~rule) &ant (find &ant- ~rule) cq (~goodcqs (build min 1 max 1 arg ~pattern arg "SOMETHING")) kn_cat (find kn_cat- ~rule))) #3!((assert forall (find forall- ~rule) &ant ((find &ant- ~rule) ~pattern) cq ~pat2 kn_cat (find kn_cat- ~rule)))) (defun hasmin-max (rule) #3!((find (compose min- cq-) ~rule))) (in-package :snebr) ;initializations. Only mdoubt used for now. Other lists for finer ;discrimination of doubtfulness if wanted later. For now one piece of data ;exonerates or eliminates posscq. (defun initialize () (setq hdoubt '()) (setq mdoubt '()) (setq ldoubt '()) (setq doubtflag (>= (length mdoubt) 1))) ;(or (>= (length mdoubt) 1) (>= (length hdoubt) 1) (>= (length ldoubt) 1)))) ;------------------------------------------------------------------------------- ; function: doubtful-term ; input: a rule node ; returns : nil (unimportant) ; ; side-effect: when SNeBR invoked, find the non-var nodes (i.e. mol-lex ; nodes) in the antecedent of min-alt and append to the list mdoubt. ; ; written: kae 7/7/93 ; (defun doubtful-term (rule) (do* ((antlist #3!((find (compose act- ant-) ~rule)) (cdr antlist)) (andantlis #3! ((find (compose act- &ant-) ~rule)) (cdr andantlis))) ((and (null antlist) (null andantlis)) nil) (if (and (not (null antlist)) (not (sneps::isvar.n (car antlist)))) (setq mdoubt (append mdoubt (list (car antlist))))) (if (and (not (null andantlis)) (not (sneps::isvar.n (car andantlis)))) (setq mdoubt (append (car andantlis) mdoubt))))) ;---------------------------------------------------------------------------- ; ; function: verify ; input: none ; returns: nil (unimportant) ; calls: verify-inner on each assertion in the network that is "qpossibly" ; true. ; (defun verify () ; (setq doubtflag (>= (length mdoubt) 1)) ; (if doubtflag (do* ((poss-outcomes #3!((findassert (compose mode lex) "qpossibly")) (cdr poss-outcomes)) (one-poss (car poss-outcomes) (car poss-outcomes))) ((null poss-outcomes) nil) (verify-inner one-poss))) ;) ;------------------------------------------------------------------------------ ; ; function: verify-inner ; input: a pattern node representing a qpossible outcome. ; returns: various (unimportant) ; ; description: for each term in mdoubt, find the rule that has that ; term in the antecedent and has a kn_cat of "questionable" ; and a qpossible consequent. Then compare that cq with ; qpossible assertion passed in from verify. If it matches, ; we're looking at the right term from mdoubt. If so, check ; to see if there is a matching assertion that is not ; qualified. If there is, call change-plus. If the negation ; of such an assertion can be deduced, call change-neg. ; (defun verify-inner (one-poss) (setq right-term nil) (do* ((dlist mdoubt (cdr dlist)) (term (car dlist) (car dlist))) ((or (null dlist) right-term) nil) (setq rul #3! ((find (compose ant act) ~term kn_cat "questionable" (compose cq mode lex) "qpossibly"))) (if (null rul) (setq rul #3! ((find (compose &ant act) ~term kn_cat "questionable" (compose cq mode lex) "qpossibly")))) (if (null rul) (print "error in mdoubt")) (setq posscq (first #3! ((find (compose object- cq-) ~rul (compose object- mode lex) "qpossibly")))) (setq poss (first #3! ((find object- ~one-poss)))) (setq badcq #3! ((find object ~posscq))) (setq right-term t) (if (iseq-mod-subst.n poss posscq) (if (sneps::isassert.n poss) (change-plus term rul) (if #3!((deduce min 0 max 0 arg ~poss)) (change-neg term rul badcq))) (setq right-term nil)))) ;------------------------------------------------------------------------------ ; ; function: change-plus ; input: term, a mol-lex node, and rule, a (singleton nodeset containing) ; a molecular rule node. ; calls: change-kn_cat on the rule ; resets the global variables mdoubt and doubtflag ; (defun change-plus (term rule) (print "enter change-plus") (setq mdoubt (remove term mdoubt)) (setq doubtflag (or (>= (length mdoubt) 1) (>= (length hdoubt) 1) (>= (length ldoubt) 1))) (change-kn_cat rule)) ;------------------------------------------------------------------------------ ; ; function: change-neg ; input: term, a mol-lex node, ; rule, a (singleton nodeset containing) a molecular rule node, ; badcq, a pattern node (the qpossible cq of the rule. ; calls: elimposscq on the rule ; resets the global variables mdoubt and doubtflag ; (defun change-neg (term rule badcq) (setq mdoubt (remove term mdoubt)) (setq doubtflag (or (>= (length mdoubt) 1) (>= (length hdoubt) 1) (>= (length ldoubt) 1))) (elimposscq rule badcq)) ;----------------------------------------------------------------------------- ; ; function: elimposscq ; input: a sinleton nodeset containing a rule node ; and its possible consequent (a pattern node) ; output: a copy of the input rule with the possible cq deleted. ; calls: remove-rule to dispose of the old rule after the new ; version is asserted. (defun elimposscq (rule badcq) (print "entering elimposscq") (setq goodcqs (set-difference #3!((find cq- ~rule)) badcq)) (if (not (null goodcqs)) #3! ((assert forall (find forall- ~rule) ant (find ant- ~rule) &ant (find &ant- ~rule) cq ~goodcqs kn_cat "life-rule.2"))) (remove-rule rule)) (defun change-kn_cat (rule) #3! ((assert forall (find forall- ~rule) ant (find ant- ~rule) &ant (find &ant- ~rule) cq (find cq- ~rule) kn_cat "life-rule.2")) (remove-rule rule)) ;------------------------------------------------------------------------------ ; ; function: remove-rule ; ; arguments: rule, singleton of the rule to be removed from ; context. (essentially an "unassert") ; ; Generates an error message, but seems to do its job anyway. ; ; modified from mrc's remove-and-add: kae 7/21/93 ; (defun remove-rule (rule &optional snip) (declare (special sneps:crntct snip:real-crntct sneps:messages snip:crntctname)) (let ((orders (if snip (sneps:context-orders sneps:crntct) (sneps:context-orders (value.sv sneps:crntct)))) (new-context (if snip (name.ct (buildcontext (compl.ns (context-hyps sneps:crntct) rule)) snip:crntctname) (name.ct (buildcontext (compl.ns (context-hyps (value.sv sneps:crntct)) rule)) sneps::crntct)))) (setf (sneps:context-orders new-context) orders) (inform-user-removed rule snip) (if snip (change-context-name (sneps:context-hyps new-context))))) ;Modifications to SNePSwD ;;; -*- Mode:Common-Lisp; Package:SNEBR; Syntax:COMMON-LISP; Base:10 -*- ;;; ;;; -*- File: imports.lisp (in-package :snebr) (defvar *probnode*) ;global to pkg snebr (defvar *altprobnode*) ;global to pkg snebr (defvar mdoubt) ;global to package snebr (defvar doubtflag) ;same ;;; -*- Mode:Common-Lisp; Package:SNEBR; Syntax:COMMON-LISP; Base:10 -*- ;;; ;;; ;;; -*- File: contrad.lisp ; ============================================================================= ; ; ; ck-contradiction ; ---------------- ; ; ; arguments : newnode - ; context - ; flag - 'ASSERTION | 'SNIP ; ; returns : | ----- ; ; description : Takes as arguments a node (newnode) and a context ; (context) and checks whether newnode contradicts any ; other node in the network. ; If the node contradicts a node in the network then ; the restriction of the contexts are updatted. ; If the contradicted node belongs to the belief space ; defined by context then the user is called ; to solve the contradiction. ; ; Algorithm : In order for a contradiction to exist there must exist ; a node in the network that either is negated by ; newnode node or negates newnode. ; ; 1. If there exists a node that negates newnode then ; we look at the node (or nodes) that negate it. ; 2. If there exists a node negated by newnode then ; we look at such node. ; ; ; written : jpm 11/09/82 ; modified: njm 10/06/88 ; modified: mrc 10/28/88 ; modified: kae 5/??/93 ; (defun ck-contradiction (newnode context flag) (let ((contr-nd (negation-or-negated-nd newnode))) (when contr-nd (ck-contradiction-1 newnode contr-nd context flag)) newnode)) (defun ck-contradiction-1 (newnode contr-nd context flag) (declare (special snip:real-crntct)) (let* ((contrsup (sneps:oscs-to-oss (sneps:node-asupport contr-nd))) (new-kis (sneps:update-KIS (sneps:oscs-to-oss (sneps:node-asupport newnode)) contrsup))) ; (if new-kis (snip:update-contexts-new-kis new-kis)) (when (exists-real-contradiction new-kis (if (boundp 'snip:real-crntct) (if snip:real-crntct (if (is.ct snip:real-crntct) snip:real-crntct (sneps:value.sv snip:real-crntct)) context) context)) (progn (setq *probnode* newnode) ; kludge added 5/93 to hang onto these (setq *altprobnode* contr-nd) ; nodes for later processing. --kae ; (sneps:mark-inconsistent context) ; (sneps:updateall context) (if (eq flag 'sneps:assertion) (sneps-contr-handler newnode contr-nd) (snip-contr-handler newnode contr-nd (if (boundp 'snip:real-crntct) (if snip:real-crntct snip:real-crntct context) context))))) (if new-kis (snip:update-contexts-new-kis new-kis)))) ;;; -*- Mode:Common-Lisp; Package:SNEBR; Syntax:COMMON-LISP; Base:10 -*- ;;; ;;; ;;; -*- File: removewff.lisp ;------------------------------------------------------------------------------ ; ; function: remove-and-add ; ; arguments: alt, apparently a ; (first alt) is a node. (second alt) appears to be nil. ; I've used it to store the revision of (first alt). ; That revision becomes the value of add-hyp in the ; do-list which apparently used not to do anything ; since add-hyp was always nil. I assume the do-list ; was originally included as a hook on which to hang ; some sort of revision . ; ; written: ?mrc? ; modified: kae 5/13/93 ; (defun remove-and-add (alt &optional snip) (declare (special sneps:crntct snip:real-crntct sneps:messages snip:crntctname)) ;----------------------------------------------------------------------------- ;Modification: alt was a list containing the node to be removed. This setq ;makes it a two element list: the node to be removed, and the revision thereof. ;----------------------------------------------------------------------------- (setq alt (list (first alt) (revise-rule (first alt)))) (doubtful-term (first alt)) ;sets up link for later processing ;----------------------------------------------------------------------------- ;end modifications of this function. ;----------------------------------------------------------------------------- (let ((orders (if snip (sneps:context-orders sneps:crntct) (sneps:context-orders (value.sv sneps:crntct)))) (new-context (if snip (name.ct (buildcontext (compl.ns (context-hyps sneps:crntct) (first alt))) snip:crntctname) (name.ct (buildcontext (compl.ns (context-hyps (value.sv sneps:crntct)) (first alt))) sneps::crntct)))) (dolist (add-hyp (second alt)) (setq snip:real-crntct sneps:crntct) (setq sneps:messages nil) (sneps:topsneval (append (cons 'snip:add (snip:get-down-cableset (sneps:node-fcableset add-hyp))) (list ':context 'sneps:all-hyps))) (setq snip:real-crntct nil) (sneps:topsneval (cons 'snip:add (snip:get-down-cableset (sneps:node-fcableset add-hyp)))) (setq sneps:messages t)) (setf (sneps:context-orders new-context) orders) (inform-user-removed alt snip) (if snip (change-context-name (sneps:context-hyps new-context))))) ; ============================================================================== ; ; function: remove-contradiction-snip ; written: ?????? ; modified: kae 8/93 to select ; for verbs. (defun remove-contradiction-snip (newnd-supps contrnd-supps context) (declare (special sneps:crntct)) (let* ( ; (context (if (is.ct sneps:crntct) sneps:crntct (value.sv sneps:crntct))) (val-der (filter-derivations (generate-contr-derivations newnd-supps contrnd-supps) context)) (comb-order (setf (sneps:context-combined-order context) (combine-orders (sneps:context-orders context) (sneps:context-order-of-orders context)))) (individual-alternatives (generate-individual-alternatives val-der context)) (min-alts (choicer-minimal-alternatives (minimal-alternatives individual-alternatives val-der context)))) (list min-alts val-der))) ; ; ============================================================================== ; ; function: remove-contradiction-sneps ; written: ?????? ; modified: kae 8/93 to select ; for verbs. (defun remove-contradiction-sneps (contrnd) (declare (special sneps:crntct sneps:automatic)) (let* ((context (if (is.ct sneps:crntct) sneps:crntct (value.sv sneps:crntct))) (val-der (valid-derivations-of-contrnd contrnd context)) (comb-order (setf (sneps:context-combined-order context) (combine-orders (sneps:context-orders context) (sneps:context-order-of-orders context)))) (individual-alternatives (generate-individual-alternatives val-der context)) (min-alts (choicer-minimal-alternatives (minimal-alternatives individual-alternatives val-der context)))) (list min-alts val-der))) ; ; ============================================================================== ; ; function: remove-wff-1 ; written: ?????? ; modified: kae 8/93 to select ; for verbs. (defun remove-wff-1 (node context) (declare (special sneps:crntct sneps:automatic)) (let* ((val-der (valid-derivations node context)) (theorem (if val-der (sneps:ismemb.oss (sneps:new.os) val-der))) (comb-order (if (and val-der (not theorem)) (setf (sneps:context-combined-order context) (combine-orders (sneps:context-orders context) (sneps:context-order-of-orders context))))) (individual-alternatives (if (and val-der (not theorem)) (generate-individual-alternatives val-der context))) (min-alts (if (and val-der (not theorem)) (choicer-minimal-alternatives (minimal-alternatives individual-alternatives val-der context)))) (n (length min-alts))) (if (and (not theorem) sneps:automatic (= 1 n)) (implement-remove-option min-alts 1) (progn (if theorem (tell-user-theorem node) (show-min-alts-to-user node min-alts val-der)) (if (not (null min-alts)) (implement-remove-option min-alts (if (eq n 1) (if (user-says-yes) 1) (read-remove-option n)))))))) ;------------------------------------------------------------------------------ ; ;if min-alts contains rules whose antecedents refer to verbs, pick ; them over other nodes in min-alts ; ;written: kae 8/11/93 ; (defun choicer-minimal-alternatives (altlist) (setq chosen altlist) (do* ((choices altlist (cdr choices))) ((null choices) (return chosen)) (if (not (has-verb-ant (first choices))) (setq chosen (remove (first choices) chosen))) (if (null chosen) (setq chosen altlist)))) ;The Ordering Functions (in-package :snepsul) (defun make_hier () (prog (ooo1 ooo2 ooo3 ooo4 ooo5) (setq ooo1 (make_order #3! ((find kn_cat "life-rule.2")) #3! ((find kn_cat "story-comp")))) (setq ooo2 (make_order #3! ((find kn_cat "story-comp")) #3! ((find kn_cat "life-rule.1")))) (setq ooo3 (make_order #3! ((find kn_cat "life-rule.1")) #3! ((find kn_cat "story")))) (cond ((null ooo3) (setq ooo3 (make_order #3! ((find kn_cat "story-comp")) #3! ((find kn_cat "story")))))) (setq ooo4 (make_order #3! ((find kn_cat "story")) #3! ((find kn_cat "life")))) (setq ooo5 (make_order #3! ((find kn_cat "life")) #3! ((find kn_cat "intrinsic")))) (cond ((null ooo5) (setq ooo5 (make_order #3! ((find kn_cat "story")) #3! ((find kn_cat "intrinsic")))))) (eval (append '(add-order o1) ooo1)) (eval (append '(add-order o2) ooo2)) (eval (append '(add-order o3) ooo3)) (eval (append '(add-order o4) ooo4)) (eval (append '(add-order o5) ooo5)) ; (add-order-of-orders o5 o4 o3 o2 o1) (return nil) )) (defun make_order (lessr greatr) (cond ((null lessr) nil) (t (append (order_help (car lessr) greatr) (make_order (cdr lessr) greatr))))) (defun order_help (lownode greatr) (cond ((null greatr) nil) (t (cons (list lownode (car greatr)) (order_help lownode (cdr greatr))))))