(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
; mkb 2002
;------------------------------------------------------------------------------
(defun defn_noun (noun)
(cond (#3!
((deduce object1 (build lex ~noun) rel "ISA"
object2 (build lex "basic ctgy")))
(report_basic noun))
((setq clas
#3! ((find (compose lex- superclass- ! subclass lex) ~noun
(compose
lex- object1- ! object2 lex) "basic
ctgy")))
(report_subbasic
noun clas))
((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 <noun>
; 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 <noun> can be deduced to perform
; (finds
rules of the variety, if x is a <noun> then x <act>)
; calls: indiv_rand_acts, only if no such rules
about the actions
; of
<noun>s are found.
;
modified: mkb 2002
;------------------------------------------------------------------------
(defun acts (noun)
;definite rule, or-entail, basic-ctgy, transitive, basic
object
(cond ((AND (setq
part1 #3! ((find (compose lex- act-
cq- ! ant class lex) ~noun
(compose lex- act- agent member- class
lex) ~noun)))
(setq part2 #3! ((find
(compose lex- class- member object- cq- ! ant class lex) ~noun))))
(list part1 part2))
;definite rule, or-entail, non-basic-ctgy, transitive
((AND (setq
part1 #3! ((find (compose lex- act-
cq- ! ant object2 lex) ~noun
(compose lex- act- agent object1- object2
lex)
~noun)))
(setq part1 #3! ((find
(compose lex- class- member object- cq- ! ant object2 lex) ~noun))))
(list part1 part2))
;definite rule, &-entail, basic-ctgy, transitive
((AND
(setq part1 #3! ((find (compose lex-
act- cq- ! &ant class lex) ~noun
(compose lex- act- agent member- class
lex) ~noun)))
(setq
part2 #3! ((find (compose lex- class-
member object- cq- ! &ant class lex) ~noun))))
(list part1 part2))
;definite rule, &-entail, non-basic ctgy, transitive
((AND
(setq part1 #3! ((find (compose lex-
act- cq- ! &ant object2 lex) ~noun
(compose lex- act- agent object1-
object2 lex)
~noun)))
(setq
part2 #3! ((find (compose lex- class-
member object- cq- ! ant object2 lex) ~noun))))
(list part1 part2))
;"presumably" rule, or-entail, basic ctgy,
transitive
((AND
(setq part1 #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)))
(setq part2
#3! ((find (compose lex- class- member
object- object- cq- ! ant class lex)
~noun))))
(list
'probable actions= part1 part2))
;"presumably" rule, or-entail, non-basic ctgy,
transitive
((AND
(setq part1 #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)))
(setq
part2 #3! ((find (compose lex- class-
member object- object- cq- ! ant object2 lex)
~noun))))
(list
'probable 'actions= part1 part2))
;"presumably" rule, &-entail, basic ctgy,
transitive
((AND
(setq part1 #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)))
(setq
part2 #3! ((find (compose lex- class-
member object- object- cq- ! &ant class lex)
~noun))))
(list 'probable 'actions= part1 part2))
;"presumably" rule, &-entail, non-basic
ctgy, transitive
((AND
(setq part1 #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)))
(setq
part2 #3! ((find (compose lex- class-
member object- object- cq- ! &ant object2 lex)
~noun))))
(list
'probable 'actions= part1 part2))
;definite rule, or-entail, basic-ctgy, transitive,
non-basic object
((AND
(setq part1 #3! ((find (compose lex-
act- cq- ! ant class lex) ~noun
(compose lex- act- agent member- class
lex) ~noun)))
(setq part2
#3! ((find (compose lex- object2- object1
object- cq- ! ant class lex) ~noun))))
(list part1 part2))
;definite rule, or-entail, non-basic-ctgy, transitive
((AND
(setq part1 #3! ((find (compose lex-
act- cq- ! ant object2 lex) ~noun
(compose lex- act- agent object1-
object2 lex)
~noun)))
(setq
part2 #3! ((find (compose lex- object2-
object1 object- cq- ! ant object2 lex) ~noun))))
(list part1 part2))
;definite rule, &-entail, basic-ctgy, transitive
((AND
(setq part1 #3! ((find (compose lex-
act- cq- ! &ant class lex) ~noun
(compose lex- act- agent member- class
lex) ~noun)))
(setq part2
#3! ((find (compose lex- object2-
object1 object- cq- ! &ant class lex) ~noun))))
(list part1 part2))
;definite rule, &-entail, non-basic ctgy, transitive
((AND
(setq part1 #3! ((find (compose lex-
act- cq- ! &ant object2 lex) ~noun
(compose lex- act- agent object1-
object2 lex)
~noun)))
(setq
part2 #3! ((find (compose lex- object2-
object1 object- cq- ! ant object2 lex) ~noun))))
(list part1 part2))
;"presumably" rule, or-entail, basic ctgy,
transitive
((AND
(setq part1 #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)))
(setq part2
#3! ((find (compose lex- object2-
object1 object- object- cq- ! ant class lex)
~noun))))
(list
'probable actions= part1 part2))
;"presumably" rule, or-entail, non-basic ctgy,
transitive
((AND
(setq part1 #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)))
(setq
part2 #3! ((find (compose lex- object2-
object1 object- object- cq- ! ant object2 lex)
~noun))))
(list
'probable 'actions= part1 part2))
;"presumably" rule, &-entail, basic ctgy,
transitive
((AND
(setq part1 #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)))
(setq
part2 #3! ((find (compose lex- object2-
object1 object- object- cq- ! &ant class lex)
~noun))))
(list 'probable 'actions= part1 part2))
;"presumably" rule, &-entail, non-basic
ctgy, transitive
((AND
(setq part1 #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)))
(setq
part2 #3! ((find (compose lex- object2-
object1 object- object- cq- ! &ant object2 lex)
~noun))))
(list 'probable
'actions= part1 part2))
;definite rule, or-entail, basic-ctgy, intransitive
((setq
part1 #3! ((find (compose lex- act-
cq- ! ant class lex) ~noun
(compose lex- act- agent member- class lex)
~noun)))
(list
'actions= part1))
;definite rule, &-entail, basic-ctgy, intransitive
((setq
part1 #3! ((find (compose lex- act-
cq- ! &ant class lex) ~noun
(compose lex- act- agent member- class lex) ~noun)))
(list
'actions= part1))
;definite rule, or-entail, non-basic-ctgy, intransitive
((setq
part1 #3! ((find (compose lex- act-
cq- ! ant object2 lex) ~noun
(compose lex- act- agent object1- object2
lex) ~noun)))
(list
'actions= part1))
;definite rule, &-entail, non-basic-ctgy,
intransitive
((setq
part1 #3! ((find (compose lex- act-
cq- ! &ant object2 lex) ~noun
(compose lex- act- agent object1- object2
lex) ~noun)))
(list part1))
;"presumably" rule, or-entail, basic ctgy,
intransitive
((setq
part1 #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= part1))
;"presumably" rule, &-entail, basic ctgy,
intransitive
((setq
part1 #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= part1))
;"presumably" rule, or-entail, non-basic ctgy,
intransitive
((setq
part1 #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= part1))
;"presumably" rule, &-entail, non-basic
ctgy, intransitive
((setq
part1 #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= part1))
(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
<noun>
; 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 <noun>
possesses. Includes possible
; and
probable possessions. Finds rules of
the sort
; If x is
a <noun> then x has <possession>.
Needs to be
; revised
so that only possessions which are part of <noun>
; are
included.
; calls: indiv_struct, only if no such rules are
found.
;
modified: mkb 2002
;------------------------------------------------------------------------------
(defun struct (noun supers)
(cond ((setq
part1 #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 part1))
((setq
part1 #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 part1))
((setq
part1 #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= part1))
((setq
part1 #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= part1))
(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
<noun>. Includes possible
; and
probable functions. Finds rules of the
sort
; If x is
a <noun> then the function of x is <function>
; calls: indiv_funct, only if no such rules are
found.
;
modified: mkb 2002
;----------------------------------------------------------------------------
(defun func (noun)
;definite rule, basic ctgy, or-entail
(cond ((setq
part1 #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 part1))
;definite rule, non-basic ctgy, or-entail
((setq
part1 #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 part1))
;definite rule, subclass of class for which function
known, or-entail
((setq
part1 #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 part1))
;definite rule, basic ctgy, or-entail, non-mol-lex
function node
((setq
part1 #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") part1))
;definite rule, non-basic ctgy, or-entail, non-mol-lex
function node
((setq
part1 #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") part1))
;definite rule, subclass of class for which function is
known, or-entail,
;non-mol-lex function node
((setq
part1 #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") part1))
;presumable rule, basic ctgy, or-entail
((setq
part1 #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 part1))
;presumable rule, non-basic ctgy, or-entail
((setq
part1 #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 part1))
;presumable rule, un-named non-basic ctgy, &-entail
((AND #3!((deduce subclass (build lex ~noun)
superclass $supercat))
(setq
part2 #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 part2))
;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))))
(setq
part3 #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") part3))
;presumable rule, subclass of class for which function is
known, or-entail
((setq part1
#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 part1))
;presumable rule, basic ctgy, non-mol-lex function node, or-entail
((setq
part1 #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") part1))
;presumable rule, non-basic ctgy, non-mol-lex function node, or-entail
((setq
part1 #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") part1))
;presumable rule, subclass of class for which function is
known,
;non-mol-lex function node, or-entail
((setq
part1 #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") part1))
(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 <noun>s as a class.
;
modified: mkb 2002
;------------------------------------------------------------------------------
(defun genprop (noun)
;def.rule, basic ctgy.
(cond ((setq part1
#3! ((find (compose lex- property-
object member- class lex) ~noun
(compose
lex- property- cq- ! ant class lex) ~noun)))
(list part1))
;def.rule, non-basic ctgy.
((setq part1
#3! ((find (compose lex- property-
object object1- object2 lex) ~noun
(compose
lex- property- cq- ! ant object2 lex) ~noun)))
(list part1))
;prob.rule, basic ctgy.
((setq part1
#3! ((find (compose lex- property-
object member- class lex) ~noun
(compose
lex- property- object- cq- ! ant class lex) ~noun)))
(list part1))
;prob.rule, non-basic ctgy.
((setq part1
#3! ((find (compose lex- property-
object object1- object2 lex) ~noun
(compose
lex- property- object- cq- ! ant object2 lex) ~noun)))
(list part1))))
;------------------------------------------------------------------------------
;
; 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 <noun> belongs
; (no
other class inclusions) and the actions (if animate),
; functions,
and structures of <noun>.
; 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 <noun> 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.
;
modified: mkb 2002
;-------------------------------------------------------------------------------
(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 ((setq
thex1 #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
thex1
'is.
'structure=
'nil
'function=
'nil
'actions=
'nil
'ownership=
(indiv_rand_rels noun)
'possible
'properties= (indiv_rand_props noun))
(list 'a
noun 'is 'something
thex1
'is.
'structure= 'nil
'function= 'nil
'actions= ac
'ownership= (indiv_rand_rels noun)
'possible 'properties= (indiv_rand_props
noun)))
(list 'a noun 'is 'something
thex1
'is.
'structure= str
'function= fun
'actions= ac
'ownership= (indiv_rand_rels noun))))
((setq
thex2 #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
thex2
'is.
'structure=
'nil
'function=
'nil
'actions=
'nil
'ownership=
(indiv_rand_rels noun)
'possible
'properties= (indiv_rand_props noun))
(list 'a
noun 'is 'something
thex2
'is.
'structure= 'nil
'function= 'nil
'actions= ac
'ownership= (indiv_rand_rels noun)
'possible 'properties= (indiv_rand_props
noun)))
(list 'a noun 'is 'something
thex2
'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 <noun>
; 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 <noun>. (See note on
"struct")
;
modified: mkb 2002
;------------------------------------------------------------------------------
(defun indiv_struct (noun)
(cond ((setq
part1 #3! ((find (compose lex-
rel- ! possessor object1- ! object2 lex)
~noun)))
(list
'possible 'structural 'features= part1))
((setq
part1 #3! ((find (compose lex-
rel- ! possessor member- ! class lex)
~noun)))
(list
'possible 'structural 'features= part1))))
;-------------------------------------------------------------------------------
;
; 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.
;
modified: mkb 2002
;-------------------------------------------------------------------------------
(defun struct3 (noun)
(cond ((setq
part1 #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 part1))
((setq
part1 #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 part1))
((setq
part1 #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 part1))
((setq part1 #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 part1))))
;-------------------------------------------------------------------------------
;
; 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 <noun>
;
modified: mkb 2002
;--------------------------------------------------------------------------
(defun indiv_rand_props (noun)
(setq prop (genprop
noun))
(if (null prop)
(cond ((setq
part1 #3! ((find (compose
lex- property- ! object object1- ! object2 lex)
~noun)))
(list part1))
((setq
part1 #3! ((find (compose
lex- property- ! object member- ! class lex)
~noun)))
(list part1)))
(list prop)))
;--------------------------------------------------------------------------
;
; function:
indiv_rand_acts
; input: a noun to be defined
; output: a list
of actions attributed to any object of type <noun>
;
modified: mkb 2002
;--------------------------------------------------------------------------
(defun indiv_rand_acts (noun)
(cond ((setq
part1 #3! ((find (compose
lex- act- ! agent object1- ! object2 lex)
~noun)))
(list
'possible 'actions= part1))
((setq
part1 #3! ((find (compose
lex- act- ! agent member- ! class lex) ~noun)))
(list
'possible 'actions= part1))))
;--------------------------------------------------------------------------
;
; function:
indiv_rand_rels
; input: a noun to be defined
; output: a list of those things which possess any
object of type <noun>
; Note:
needs to be refined/expanded.
;
;--------------------------------------------------------------------------
(defun indiv_rand_rels (noun)
(cond ((setq
part1 #3! ((find (compose
lex- class- ! member possessor- ! rel lex) ~noun)))
(list 'a
noun 'can 'belong 'to 'a part1))))
;-----------------------------------------------------------------------------
;
; function:
syn_noun
; input: a noun to be defined
; output: a list
of probable synonyms of <noun>
; calls: compare-all functions
; local vars:
supers -- a list of class inclusions of <noun>
; poss-syn -- a list of possible synonyms for
<noun>
; synonyms -- a list of known synonyms for
<noun>
; 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 <noun> 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 <noun>
; 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 <verb>, with categorization of arguments;
; causal/enablement
information; eventually to include primitive
; act of
which <verb> 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 <verb>, with categorization of arguments;
; causal/enablement
information; eventually to include primitive
; act of
which <verb> 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 <verb>, with categorization of arguments;
; causal/enablement
information; eventually to include primitive
; act of
which <verb> 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 <verb>, with categorization of arguments;
; causal/enablement
information; eventually to include primitive
; act of
which <verb> 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 <verb>, with categorization of argument;
; causal/enablement
information; eventually to include primitive
; act of
which <verb> 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 <verb> 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 <verb>
;------------------------------------------------------------------------------
(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 <verb>
;-------------------------------------------------------------------------------
(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 <verb>
;-------------------------------------------------------------------------------
(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 <verb>
; or the
atom 'something, if nothing known about what can <verb>.
;-------------------------------------------------------------------------------
(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 <verb> 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 <verb>
;------------------------------------------------------------------------------
(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 <verb>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 <verb>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 <verb>ed,
; or the
atom 'something, if nothing known about what can
; be
<verb>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 <verb> 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 <verb>
;------------------------------------------------------------------------------
(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 <verb>
;-------------------------------------------------------------------------------
(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 <verb>.
;-------------------------------------------------------------------------------
(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 <verb>, if any;
; the atom
'something if nothing known about what can be the
; indirect
object of <verb>
;-------------------------------------------------------------------------------
(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 <verb>.
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
<verb>. 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 <verb>, with categorization of argument;
; causal/enablement
information; eventually to include primitive
; act of
which <verb> 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 <nodeset>, 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
<node>, rule. Must be a molecular
rule node.
;
; returns: the
<node> at the head of the kn_cat arc from rule
;
(actually, the singleton nodeset of said <node>)
;
; written:
kae 5/20/93
;
(defun rule-kn_cat (rule)
#3!((find
kn_cat- ~rule)))
;------------------------------------------------------------------------------
;
; function:
isor-entail. A predicate
;
; argument: a
<node>, 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
<nodeset>, rule. A singleton rule
node
;
; returns: a
<nodeset> 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
<nodeset>, 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
<nodes>, 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
<nodes>, 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 <node> (having only
a single cq arc)
;
; returns: a
<node> 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 <node> (having only
a single cq arc and
; conjunct antecedents)
;
; returns: a
<node> 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
<nodes>, 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
<nodes>, 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 <node> (from the cq of a rule) which is known
; to
produce a contradiction.
; a <nodeset> of all the cqs from that
rule (note: cqlist
; includes
batpattern)
;
; returns: a
pattern <node> (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))))
