home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS 1992 December
/
simtel1292_SIMTEL_1292_Walnut_Creek.iso
/
msdos
/
snobol4
/
aisnobol.arc
/
SIR.SPT
< prev
next >
Wrap
Text File
|
1987-10-10
|
23KB
|
596 lines
* SIR.SPT - Spitbol-68K Version
*
* This version of Bertram Raphael's SIR program
* was translated into SNOBOL4 using the SNOLISPIST
* list processing routines.
*
* This program follows closely the LISP version by
* S. Shapiro, "Techniques of Artificial Intelligence,"
* Van Nostrand, NY, 1979, pp. 123-140.
*
* The comments are from Shapiro's LISP program.
*
* To run the program with the canned input of Shapiro's book:
* a) have copies of sir.spt, snocore.spt and snolib.spt in your
* directory.
* b) type:
* spitbol spitcore.spt sir.spt <sir.in
*
*
**************************************
* FUNCTIONS FOR THE TOP LEVEL OF SIR *
**************************************
*
* Gets and processes sentences until a sentence begins with the
* word "BYE," then returns "GOODBYE."
*
DEFINE('SIR()S') :(SIR.END)
SIR S = GET.SENTENCE() :F(FRETURN)
SIR = EQU(CAR(S),"BYE") "GOOD-BYE" :S(RETURN)
PROCESS(S) :S(SIR)F(FRETURN)
SIR.END
*
*---------------------------------------------------------------------------
* Reads in one sentence, which must end either with a "!" or a "?"
* and returns the sentence in a list.
*
DEFINE('GET.SENTENCE()S,P') :(GET.SENTENCE.END)
GET.SENTENCE S = S " " REPLACE(IN(.OUTPUT.),
+ "abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") :F(FRETURN)
S RPOS(1) ANY("!?") . P = " " P
+ :F(GET.SENTENCE)
GET.SENTENCE = READ( "(" S ")" ) :S(RETURN)F(FRETURN)
GET.SENTENCE.END
*
*---------------------------------------------------------------------------
* Processes the sentence SENTENCE according to the rules in the
* global list RULE.LIST.
*
DEXP('PROCESS(SENTENCE) = PROCESS.1(SENTENCE,RULE.LIST)')
*
*---------------------------------------------------------------------------
* The first rule in the list RULES that is applicable to the sentence
* SENTENCE is applied, and its value is printed. If no rule is
* applicable, an error message is printed.
*
DEFINE('PROCESS.1(SENTENCE,RULES)RESP,CA')
+ :(PROCESS.1.END)
PROCESS.1 CA = POP( .RULES) :F(PROCESS.1.ERR)
RESP = APPLY.RULE(CA,SENTENCE)
IDENT(RESP,NIL) :S(PROCESS.1)
PROCESS.1 = |RESP :(RETURN)
PROCESS.1.ERR
+ |"STATEMENT FORM NOT RECOGNIZED."
|" IN PROCESS.1, "
|(" SENTENCE = " CONCAT(SENTENCE," ")) :(RETURN)
PROCESS.1.END
-EJECT
********************************
* DEFINING THE SYNTAX OF RULES *
********************************
*
* The rules we will use are just like those Raphael used, except that
* we will let a pattern be an atom as well as a list. If a pattern
* is an atom, it will mean "the same as the previous rule." We do this
* to make the rules more perspicuous without paying too high a price in
* efficiency. For each set of our rules with the same pattern, Raphael
* used one rule, and used the test predicates and action functions to
* perform the division into several rules that we have done directly.
*
* A rule has four parts:
*
* 1. A PATTERN, which is either a list or an atom. An atom is to be
* interpreted as ditto marks, i.e., the same pattern as the previous rule.
*
* 2. A list of VARIABLES appearing in the pattern. Each variable represents
* a blank in the pattern. If a sentence matches the pattern, each
* variable is bound to the sequence of words filling its blank.
*
* 3. A list of TESTS, one for each variable. Each test, applied to its
* variable, returns NIL if the test fails or some non-NIL value if it
* succeeds.
*
* 4. An ACTION to be carried out if the pattern matches and the variables
* pass the tests. An action is a the form (ACT SELECTOR1 ... SELECTORk),
* where ACT is a function of k arguments and SELECTORi is a function
* which, when applied to the list of test results, gives the ith
* argument for ACT.
*
DATA('RULE(PATTERN,VARIABLES,TESTS,ACTION)')
-EJECT
************************************
* FUNCTIONS FOR INTERPRETING RULES *
************************************
*
* Tries to apply the rule RULE to the input sentence INP. Returns NIL
* if the rule does not apply, otherwise, returns a message that depends
* on the rule.
*
DEFINE('APPLY.RULE(RULE,INP)') :(APPLY.RULE.END)
APPLY.RULE APPLY.RULE = NIL
APPLY.RULE =
+ DIFFER(NIL,MATCH(INP,PATTERN(RULE),VARIABLES(RULE)))
+ APPLY.RULE.1(
+ APPLY.TESTS(TESTS(RULE),EVLIS(VARIABLES(RULE))),
+ ACTION(RULE)) :(RETURN)
APPLY.RULE.END
*
*---------------------------------------------------------------------------
* Tries to match the pattern PAT with the input sentence INP. VARS is a list
* of variables in the pattern. If the pattern matches, each variable is set
* to the substring which it matches in INP and MATCH returns T. Otherwise,
* MATCH returns NIL.
*
* The global variable MATCH.FLAG is set to the value that MATCH returns,
* so if PAT is an atom, MATCH returns the value of MATCH.FLAG. If this is
* T, the variables still have the values they had when the previous rule
* matched.
*
DEFINE('MATCH(INP,PAT,VARS)') :(MATCH.END)
MATCH ATOM(PAT) :S(MATCH.A)
INITIALIZE(VARS)
MATCH.FLAG = MATCH1(INP,PAT,VARS)
MATCH.A MATCH = MATCH.FLAG :(RETURN)
MATCH.END
*
*---------------------------------------------------------------------------
* Initializes each variable in the list LVARS to the value NIL.
*
DEXP('INITIALIZE(LVARS) = MAPC( .'
+ DEXP('LAMBDA(LAMBDA...V) = SET.(LAMBDA...V,NIL)')
+ ',LVARS)')
*
*---------------------------------------------------------------------------
* Tries to match the pattern PAT to the input sentence INP, setting the
* variables in the list VARS to the substring of INPU which they match.
* Returns T if PAT matches INP. Otherwise, it returns NIL.
*
DEFINE('MATCH1(INP,PAT,VARS)CA') :(MATCH1.END)
MATCH1 MATCH1 = NULL(INP) NULLP(PAT) :S(RETURN)
MATCH1 = NULL(PAT) NIL :S(RETURN)
CA = CAR(PAT)
MEMQ(CA,VARS) :F(MATCH1A)
MATCH1 = NULL( CDR(PAT))
+ SET.(CA,APPEND($CA ~ INP ~ NIL))
+ :S(RETURN)
MATCH1 = EQU(CAR(INP),CADR(PAT))
+ MATCH1(CDR(INP),CDDR(PAT),VARS)
+ :S(RETURN)
MATCH1 = DIFFER(NIL,SET.(CA,SNOC($CA,CAR(INP))))
+ MATCH1(CDR(INP),PAT,VARS) :(RETURN)
MATCH1A MATCH1 = EQU(CAR(INP),CA)
+ MATCH1(CDR(INP),CDR(PAT),VARS)
+ :S(RETURN)
MATCH1 = NIL :(RETURN)
MATCH1.END
*
*---------------------------------------------------------------------------
* Applies the ith function on the list TESTS to the ith S-expression on
* the list PHRASES, and returns a list of the results unless ony of these
* results is NIL, in which case NIL is returned. NIL is also returned
* if the two lists are of different lengths or if PHRASES is an empty list.
*
DEFINE('APPLY.TESTS(TESTS,PHRASES)L') :(APPLY.TESTS.END)
APPLY.TESTS APPLY.TESTS = NIL
L = NIL
APPLY.TESTS1 L = DIFFER(NIL,PHRASES) DIFFER(NIL,TESTS)
+ APPLY(CAR(TESTS),CAR(PHRASES)) ~ L :F(RETURN)
DIFFER(NIL,CAR(L)) ?POP( .TESTS) ?POP( .PHRASES) :F(RETURN)
APPLY.TESTS = NULL(TESTS) NULL(PHRASES)
+ LREVERSE(L) :S(RETURN)F(APPLY.TESTS1)
APPLY.TESTS.END
*
*---------------------------------------------------------------------------
* Applies the action ACT, which his a list of functions, to L, which is
* a list of values, and returns the result.
*
DEFINE('APPLY.RULE.1(L,ACT)XPR') :(APPLY.RULE.1.END)
APPLY.RULE.1
+ APPLY.RULE.1 = NULL(L) NIL :S(RETURN)
XPR =
+ CAR(ACT) '('
+ CONCAT( RMAPCAR( L, CDR(ACT)), ',', '"') ')'
APPLY.RULE.1 = EVALCODE(XPR) :(RETURN)
APPLY.RULE.1.END
*
*---------------------------------------------------------------------------
* Applies each function on the list LF to the S-expression S, and
* returns a list of the results.
*
DEFINE('RMAPCAR(S,LF)F') :(RMAPCAR.END)
RMAPCAR RMAPCAR = NIL
RMAPCAR1 F = POP( .LF) :F(RMAPCAR2)
RMAPCAR = APPLY(F,S) ~ RMAPCAR :(RMAPCAR1)
RMAPCAR2 RMAPCAR = LREVERSE(RMAPCAR) :(RETURN)
RMAPCAR.END
-EJECT
*******************************************
* GENERAL FUNCTIONS FOR RELATIONAL GRAPHS *
*******************************************
*
* Inserts an arc labeled REL from node X to node Y unless such an arc
* already exists.
*
DEFINE('ADDXRY(X,REL,Y)') :(ADDXRY.END)
ADDXRY ADDXRY = MEMQ(Y,GET(X,REL)) NIL :S(RETURN)
ADDXRY = PUTPROP(X,Y,REL) :(RETURN)
ADDXRY.END OPSYN( .ADDYRX, .ADDXRY)
*
*---------------------------------------------------------------------------
* Returns T if a path of arcs described by ARC_PATH exists from node X to
* node Y. The syntax of ARC_PATH can be described as follows:
*
* 1. Any atom is a basic path element.
* 2. A basic path element followed by "*" or by "+" is a path element.
* 3. A list of path elements is an ARC_PATH.
* 4. An ARC_PATH is also a basic path element.
*
* A basic path element followed by a "*" means zero of more occurrences
* of that basic path element. A basic path element followed by a "+"
* means one or more occurrences of that basic path element.
*
DEXP('PATH(PATH...X,PATH...R,PATH...Y) = '
+ 'MEMQ( $PATH...Y,'
+ 'PATH1( $PATH...X ~ NIL, PATH...R))')
*
*---------------------------------------------------------------------------
* Returns all nodes reachable from any of the nodes in the list LN
* by following the ARC_PATH LR.
DEFINE('PATH1(LN,LR)') :(PATH1.END)
PATH1 DIFFER(NIL,LN) DIFFER(NIL,LR) :F(PATH1C)
DIFFER(NIL,CDR(LR)) MEMQ(CADR(LR),"*" ~ "+" ~ NIL) :F(PATH1A)
LN = EXTENDM(CADR(LR),LN,CAR(LR))
LR = CDR(LR) :(PATH1B)
PATH1A LN = EXTEND(LN,CAR(LR))
PATH1B LR = CDR(LR) :(PATH1)
PATH1C PATH1 = LN :(RETURN)
PATH1.END
*
*---------------------------------------------------------------------------
* Returns the list of nodes reachable from any of the nodes on the list LN
* by following the path element consisting of the basic path element R
* followed by OP, which is either "*" or "+".
*
DEFINE('EXTENDM(OP,LN,R)') :(EXTENDM.END)
EXTENDM LN = IDENT(OP,"+") EXTEND(LN,R)
EXTENDM = LN
EXTENDM1 DIFFER(NIL,LN) :F(RETURN)
LN = COMPLEMENT(EXTEND(LN,R),EXTENDM)
EXTENDM = APPEND(EXTENDM ~ LN ~ NIL) :(EXTENDM1)
EXTENDM.END
*
*---------------------------------------------------------------------------
* Returns the list of nodes reachable from any of the nodes on the list LN
* by following one instance of the basic path element R.
*
DEFINE('EXTEND(LN,R)') :(EXTEND.END)
EXTEND EXTEND = NULL(LN) NIL :S(RETURN)
EXTEND = ~ATOM(R) PATH1(LN,R) :S(RETURN)
EXTEND = UNION(GET(CAR(LN),R),
+ EXTEND(CDR(LN),R)) :(RETURN)
EXTEND.END
*
*---------------------------------------------------------------------------
* Returns a set consisting of those elements of the set S1 that are not
* also elements of the set S2. (COMPLEMENT(S1,S2))
*
OPSYN( .COMPLEMENT, .EXCLUDE)
-EJECT
*********************************************************
* TEST FUNCTIONS FOR THE SYNTAX OF ENGLISH NOUN PHRASES *
*********************************************************
*
* The division of noun phrases into unique, generic, and specific as
* defined below is taken from Raphael (1968). First we define two
* global lists, one of generic determiners, and one of specific
* (definite) determiners.
*
G.DETS = READ( "(EACH EVERY ANY A AN)" )
S.DETS = READ( "(THE)" )
*
*---------------------------------------------------------------------------
* If NP is a list of a single word, it is presumed to be a unique noun
* phrase, and that word is returned. Otherwise NIL is returned.
*
DEXP('UNIQUE(NP) = NIL ; UNIQUE = '
+ 'NULL(CDR(NP)) CAR(NP) ; ')
*
*---------------------------------------------------------------------------
* If NP is a list of words beginning with a G.DET, it is presumed to
* be a generic noun phrase, and that last word is returned. Otherwise,
* NIL is returned.
*
DEXP('GENERIC(NP) = NIL ; GENERIC = '
+ 'MEMQ(CAR(NP),G.DETS) RAC(NP) ; ')
*
*---------------------------------------------------------------------------
* If NP is a list of words beginning with S.DET, it is presumed to be a
* specific noun phrase, and the last word is returned. Otherwise, NIL
* is returned.
*
DEXP('SPECIFIC(NP) = NIL ; SPECIFIC = '
+ 'MEMQ(CAR(NP),S.DETS) RAC(NP) ; ')
*
*---------------------------------------------------------------------------
* If NPNP is a unique noun phrase followed by a generic noun phrase, a list
* is returned containing the one word of the forming and the last word of
* of the latter. Otherwise, NIL is returned.
*
DEXP('UNIQUE.GENERIC(NPNP) = '
+ 'APPLY.TESTS( #"(UNIQUE GENERIC)", SPLIT(NPNP,G.DETS))')
*
*---------------------------------------------------------------------------
* IF NPNP is a specific noun phrase followed by a generic noun phrase, a
* list is returned containing the last word of each. Otherwise, NIL is
* returned.
*
DEXP('SPECIFIC.GENERIC(NPNP) = '
+ 'APPLY.TESTS( #"(SPECIFIC GENERIC)", SPLIT(NPNP,G.DETS))')
*
*---------------------------------------------------------------------------
* If NPNP is a generic noun phrase followed by another generic noun phrase,
* a list is returned containing the last word of each of them. Otherwise,
* NIL is returned.
*
DEXP('GENERIC.GENERIC(NPNP) = '
+ 'APPLY.TESTS( #"(GENERIC GENERIC)", SPLIT(NPNP,G.DETS))')
*
*---------------------------------------------------------------------------
* SNP is a list consisting of one or more noun phrases, and LD is a list
* of initial words of noun phrases (determiners). SPLIT returns a list
* of sublists, the ith sublist being the ith noun phrase in SNP.
*
DEXP('SPLIT(SNP,LD) = SPLIT1(CDR(SNP),LD,CAR(SNP) ~ NIL,NIL)')
*
DEFINE('SPLIT1(SNP,LD,NP,LNP)') :(SPLIT1.END)
SPLIT1 SPLIT1 =
+ NULL(SNP) LREVERSE( LREVERSE(NP) ~ LNP) :S(RETURN)
SPLIT1 = MEMQ(CAR(SNP),LD)
+ SPLIT1(CDR(SNP),LD,CAR(SNP) ~ NIL,
+ LREVERSE(NP) ~ LNP) :S(RETURN)
SPLIT1 =
+ SPLIT1( CDR(SNP), LD, CAR(SNP) ~ NP, LNP)
+ :(RETURN)
SPLIT1.END
-EJECT
********************
* ACTION FUNCTIONS *
********************
*
* We present action functions for set relations, equivalence relations,
* and ownership relations. Except for the function EQUIV.COMPRESS and
* its help functions, the functions given here have exactly the same names,
* arguments, and actions as specified in Raphael (1968). They are,
* however, implemented in a different way.
*
* Some responses returned from semantic routines
*
UNDERSTAND = "I UNDERSTAND."
YES = "YES."
SOMETIMES = "SOMETIMES."
INSUFFICIENT = "INSUFFICIENT INFORMATION"
SILENCE = ""
-EJECT
***********************************************
* ACTION FUNCTIONS FOR INFORMATION ABOUT SETS *
***********************************************
*
* Adds the information that X is a subset of Y.
*
DEFINE('SETR(X,Y)') :(SETR.END)
SETR ADDXRY(X,"SUBSET",Y)
ADDYRX(Y,"SUPERSET",X)
SETR = UNDERSTAND :(RETURN)
SETR.END
*
*---------------------------------------------------------------------------
* Determines if X is a subset of Y.
*
DEFINE('SETRQ(X,Y)') :(SETRQ.END)
SETRQ SETRQ = PATH( .X, #"(SUBSET *)", .Y) YES
+ :S(RETURN)
SETRQ = PATH( .Y, #"(SUBSET +)", .X) SOMETIMES
+ :S(RETURN)
SETRQ = INSUFFICIENT :(RETURN)
SETRQ.END
*
*---------------------------------------------------------------------------
* Adds the information that X is a member of the set Y.
*
DEFINE('SETRS(X,Y)') :(SETRS.END)
SETRS ADDXRY(X,"MEMBER",Y)
ADDYRX(Y,"ELEMENTS",X)
SETRS = UNDERSTAND :(RETURN)
SETRS.END
*
*---------------------------------------------------------------------------
* Determines if X is a member of the set Y.
*
DEFINE('SETRSQ(X,Y)') :(SETRSQ.END)
SETRSQ SETRSQ =
+ PATH( .X, #"(EQUIV * MEMBER SUBSET *)", .Y) YES
+ :S(RETURN)
SETRSQ = INSUFFICIENT :(RETURN)
SETRSQ.END
*
*---------------------------------------------------------------------------
* Adds the information that the unique element of the set X is an
* element of the set Y. Does nothing if X has more than one element.
*
DEFINE('SETRS1(X,Y)') :(SETRS1.END)
SETRS1 SETRS1 = DIFFER(NIL,SET.(.X,SPECIFY(X)))
+ SETRS(X,Y) :S(RETURN)
SETRS1 = SILENCE :(RETURN)
SETRS1.END
*
*---------------------------------------------------------------------------
* If X has a unique element, it is returned. If X has no elements, one
* is created and returned. If X has more than one element, a message is
* printed and NIL is returned.
*
DEXP('SPECIFY(X) = '
+ 'SPECIFY1(EQUIV.COMPRESS(GET(X,"ELEMENTS")),X)')
*
DEFINE('SPECIFY1(U,X)') :(SPECIFY1.END)
SPECIFY1 NULL(U) :F(SPECIFY1A)
SPECIFY1 = SET.( .U, GENSYM())
SETRS(U,X)
|(U " IS A " X ".") :(RETURN)
SPECIFY1A
+ SPECIFY1 = NULL(CDR(U)) CAR(U) :S(RETURN)
|("WHICH " X "? ... " !U)
SPECIFY1 = NIL :(RETURN)
SPECIFY1.END
*
*---------------------------------------------------------------------------
* LX is a list of which some elements may be equivalent to some others. A
* list is returned of the elements of LX without such redundant members.
*
DEXP('EQUIV.COMPRESS(LX) = EQUIV.COMP1(LX,NIL)')
*
DEFINE('EQUIV.COMP1(LX,LEX)') :(EQUIV.COMP1.END)
EQUIV.COMP1
+ EQUIV.COMP1 = NULL(LX) NIL :S(RETURN)
EQUIV.COMP1 = MEMQ(CAR(LX),LEX)
+ EQUIV.COMP1(CDR(LX),LEX) :S(RETURN)
EQUIV.COMP1 =
+ CAR(LX) ~
+ EQUIV.COMP1( CDR(LX),
+ APPEND( GET(CAR(LX),"EQUIV") ~ LEX ~ NIL))
+ :(RETURN)
EQUIV.COMP1.END
*
*---------------------------------------------------------------------------
* Determines if the unique element of the set X (if there is one) is a
* member of the set Y.
*
DEFINE('SETRS1Q(X,Y)') :(SETRS1Q.END)
SETRS1Q SETRS1Q = DIFFER(NIL,SET.(.X,SPECIFY(X)))
+ SETRSQ(X,Y) :S(RETURN)
SETRS1Q = SILENCE :(RETURN)
SETRS1Q.END
-EJECT
*************************************************
* ACTION FUNCTIONS FOR THE EQUIVALENCE RELATION *
*************************************************
*
* Adds the information that X is equivalent to Y.
*
DEFINE('EQUIV(X,Y)') :(EQUIV.END)
EQUIV ADDXRY(X,"EQUIV",Y)
ADDYRX(Y,"EQUIV",X)
EQUIV = UNDERSTAND :(RETURN)
EQUIV.END
*
*---------------------------------------------------------------------------
* If there is a unique element of the set Y, adds the information that it
* is equivalent to X.
*
DEFINE('EQUIV1(X,Y)') :(EQUIV1.END)
EQUIV1 EQUIV1 = DIFFER(NIL,SET.(.Y,SPECIFY(Y)))
+ EQUIV(X,Y) :S(RETURN)
EQUIV1 = SILENCE :(RETURN)
EQUIV1.END
-EJECT
************************************
* ACTION FUNCTIONS ABOUT OWNERSHIP *
************************************
*
* Adds the information that every member of the set Y owns a member of
* the set X.
*
DEFINE('OWNR(X,Y)') :(OWNR.END)
OWNR ADDXRY(X,"OWNED.BY",Y)
ADDYRX(Y,"POSSESS.BY.EACH",X)
OWNR = UNDERSTAND :(RETURN)
OWNR.END
*
*---------------------------------------------------------------------------
* Determines if every member of the set Y owns a member of the set X.
*
DEFINE('OWNRQ(X,Y)') :(OWNRQ.END)
OWNRQ OWNRQ = EQU(X,Y)
+ "NO, THEY ARE THE SAME." :S(RETURN)
OWNRQ = PATH( .Y, #"(SUBSET * POSSESS.BY.EACH)", .X)
+ YES :S(RETURN)
OWNRQ = INSUFFICIENT :(RETURN)
OWNRQ.END
*
*---------------------------------------------------------------------------
* Adds the information that Y owns a member of the set X.
*
DEFINE('OWNRGU(X,Y)') :(OWNRGU.END)
OWNRGU ADDYRX(Y,"POSSESS",X)
ADDXRY(X,"OWNED",Y)
OWNRGU = UNDERSTAND :(RETURN)
OWNRGU.END
*
*---------------------------------------------------------------------------
* Determines if Y owns a member of the set X.
*
DEFINE('OWNRGUQ(X,Y)') :(OWNRGUQ.END)
OWNRGUQ OWNRGUQ =
+ PATH( .Y, #"(EQUIV * POSSESS SUBSET *)", .X)
+ YES :S(RETURN)
OWNRGUQ =
+ PATH( .Y, #("(EQUIV * MEMBER SUBSET *"
+ " POSSESS.BY.EACH SUBSET *)"), .X)
+ YES :S(RETURN)
OWNRGUQ = INSUFFICIENT :(RETURN)
OWNRGUQ.END
*
*---------------------------------------------------------------------------
* Determines if some member of the set Y owns the unique element of
* the set X (if such exists).
*
DEFINE('OWNRSGQ(X,Y)') :(OWNRSGQ.END)
OWNRSGQ OWNRSGQ = IDENT(NIL,SPECIFY(X)) SILENCE :S(RETURN)
OWNRSGQ =
+ PATH( .X, #"(OWNED EQUIV * MEMBER SUBSET *)", .Y)
+ YES :S(RETURN)
OWNRSGQ = INSUFFICIENT :(RETURN)
OWNRSGQ.END
-EJECT
********************************************
* A SET OF RULES USING THE ABOVE FUNCTIONS *
********************************************
*
* Take a string of rules and convert them to the RULE data structure.
*
DEFINE('MAKE.RULES(STL)ST,R') :(MAKE.RULES.END)
MAKE.RULES MAKE.RULES = NIL
MAKE.RULES1 ST = POP( .STL) :F(MAKE.RULES2)
ST = READ( "(" ST ")" )
R = RULE(CAR(ST),CADR(ST),CADDR(ST),CADDDR(ST))
MAKE.RULES = R ~ MAKE.RULES :(MAKE.RULES1)
MAKE.RULES2 MAKE.RULES = LREVERSE(MAKE.RULES) :(RETURN)
MAKE.RULES.END
*
*---------------------------------------------------------------------------
* Rules
*
RULE.LIST = MAKE.RULES(
+ '(IS *X* ?) (*X*) (UNIQUE.GENERIC) (SETRSQ CAAR CADAR)' ~
+ ' - (*X*) (SPECIFIC.GENERIC) (SETRS1Q CAAR CADAR)' ~
+ ' - (*X*) (GENERIC.GENERIC) (SETRQ CAAR CADAR)' ~
+ '(DOES *X* OWN *Y* ?) (*X* *Y*) (GENERIC GENERIC) (OWNRQ CADR CAR)' ~
+ ' - (*X* *Y*) (UNIQUE GENERIC) (OWNRGUQ CADR CAR)' ~
+ ' - (*X* *Y*) (GENERIC SPECIFIC) (OWNRSGQ CADR CAR)' ~
+ '(*X* IS *Y* !) (*X* *Y*) (UNIQUE GENERIC) (SETRS CAR CADR)' ~
+ ' - (*X* *Y*) (GENERIC GENERIC) (SETR CAR CADR)' ~
+ ' - (*X* *Y*) (SPECIFIC GENERIC) (SETRS1 CAR CADR)' ~
+ ' - (*X* *Y*) (UNIQUE UNIQUE) (EQUIV CAR CADR)' ~
+ ' - (*X* *Y*) (UNIQUE SPECIFIC) (EQUIV1 CAR CADR)' ~
+ ' - (*X* *Y*) (SPECIFIC UNIQUE) (EQUIV1 CADR CAR)' ~
+ '(*X* OWNS *Y* !) (*X* *Y*) (GENERIC GENERIC) (OWNR CADR CAR)' ~
+ ' - (*X* *Y*) (UNIQUE GENERIC) (OWNRGU CADR CAR)' ~
+ NIL)
*
*
*************************
* EXECUTION BEGINS HERE *
*************************
*
|SIR()
END