home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / snobol / aisnobol / sir.sno < prev    next >
Text File  |  1987-10-10  |  23KB  |  596 lines
  1. * SIR.SNO - SNOBOL4+ Version
  2. *
  3. * This version of Bertram Raphael's SIR program
  4. * was translated into SNOBOL4 using the SNOLISPIST
  5. * list processing routines.
  6. *
  7. * This program follows closely the LISP version by
  8. * S. Shapiro, "Techniques of Artificial Intelligence,"
  9. * Van Nostrand, NY, 1979, pp. 123-140.
  10. *
  11. * The comments are from Shapiro's LISP program.
  12. *
  13. * To run the program with the canned input of Shapiro's book:
  14. *     a)  have copies of SIR, SNOCORE.INC, and SNOLIB.INC in your
  15. *         directory.
  16. *     b)  type SNOBOL4 SIR <SIR.IN
  17. *
  18. *
  19. -INCLUDE "SNOCORE.INC"
  20. -EJECT
  21. **************************************
  22. * FUNCTIONS FOR THE TOP LEVEL OF SIR *
  23. **************************************
  24. *
  25. * Gets and processes sentences until a sentence begins with the
  26. * word "BYE," then returns "GOODBYE."
  27. *
  28.  DEFINE('SIR()S')    :(SIR.END)
  29. SIR   S = GET.SENTENCE()      :F(FRETURN)
  30.       SIR = EQU(CAR(S),"BYE") "GOOD-BYE"     :S(RETURN)
  31.       PROCESS(S)    :S(SIR)F(FRETURN)
  32. SIR.END
  33. *
  34. *---------------------------------------------------------------------------
  35. * Reads in one sentence, which must end either with a "!" or a "?"
  36. * and returns the sentence in a list.
  37. *
  38.  DEFINE('GET.SENTENCE()S,P')       :(GET.SENTENCE.END)
  39. GET.SENTENCE   S = S " " REPLACE(IN(.OUTPUT.), &LCASE, &UCASE) :F(FRETURN)
  40.      S RPOS(1) ANY("!?") . P = " " P
  41. +         :F(GET.SENTENCE)
  42.  GET.SENTENCE = READ( "(" S ")" )      :S(RETURN)F(FRETURN)
  43. GET.SENTENCE.END
  44. *
  45. *---------------------------------------------------------------------------
  46. * Processes the sentence SENTENCE according to the rules in the
  47. * global list RULE.LIST.
  48. *
  49.  DEXP('PROCESS(SENTENCE) = PROCESS.1(SENTENCE,RULE.LIST)')
  50. *
  51. *---------------------------------------------------------------------------
  52. * The first rule in the list RULES that is applicable to the sentence
  53. * SENTENCE is applied, and its value is printed.  If no rule is
  54. * applicable, an error message is printed.
  55. *
  56.  DEFINE('PROCESS.1(SENTENCE,RULES)RESP,CA')
  57. +         :(PROCESS.1.END)
  58. PROCESS.1      CA = POP( .RULES)   :F(PROCESS.1.ERR)
  59.      RESP = APPLY.RULE(CA,SENTENCE)
  60.      IDENT(RESP,NIL)    :S(PROCESS.1)
  61.      PROCESS.1 = |RESP       :(RETURN)
  62. PROCESS.1.ERR
  63. +     |"STATEMENT FORM NOT RECOGNIZED."
  64.       |"   IN PROCESS.1, "
  65.       |("    SENTENCE = " CONCAT(SENTENCE," "))     :(RETURN)
  66. PROCESS.1.END
  67. -EJECT
  68. ********************************
  69. * DEFINING THE SYNTAX OF RULES *
  70. ********************************
  71. *
  72. * The rules we will use are just like those Raphael used, except that
  73. * we will let a pattern be an atom as well as a list.  If a pattern
  74. * is an atom, it will mean "the same as the previous rule."  We do this
  75. * to make the rules more perspicuous without paying too high a price in
  76. * efficiency.  For each set of our rules with the same pattern, Raphael
  77. * used one rule, and used the test predicates and action functions to
  78. * perform the division into several rules that we have done directly.
  79. *
  80. * A rule has four parts:
  81. *
  82. * 1. A PATTERN, which is either a list or an atom.  An atom is to be
  83. *    interpreted as ditto marks, i.e., the same pattern as the previous rule.
  84. *
  85. * 2. A list of VARIABLES appearing in the pattern.  Each variable represents
  86. *    a blank in the pattern.  If a sentence matches the pattern, each
  87. *    variable is bound to the sequence of words filling its blank.
  88. *
  89. * 3. A list of TESTS, one for each variable.  Each test, applied to its
  90. *    variable, returns NIL if the test fails or some non-NIL value if it
  91. *    succeeds.
  92. *
  93. * 4. An ACTION to be carried out if the pattern matches and the variables
  94. *    pass the tests.  An action is a the form (ACT SELECTOR1 ... SELECTORk),
  95. *    where ACT is a function of k arguments and SELECTORi is a function
  96. *    which, when applied to the list of test results, gives the ith
  97. *    argument for ACT.
  98. *
  99.  DATA('RULE(PATTERN,VARIABLES,TESTS,ACTION)')
  100. -EJECT
  101. ************************************
  102. * FUNCTIONS FOR INTERPRETING RULES *
  103. ************************************
  104. *
  105. * Tries to apply the rule RULE to the input sentence INP.  Returns NIL
  106. * if the rule does not apply, otherwise, returns a message that depends
  107. * on the rule.
  108. *
  109.  DEFINE('APPLY.RULE(RULE,INP)')   :(APPLY.RULE.END)
  110. APPLY.RULE     APPLY.RULE = NIL
  111.       APPLY.RULE =
  112. +        DIFFER(NIL,MATCH(INP,PATTERN(RULE),VARIABLES(RULE)))
  113. +        APPLY.RULE.1(
  114. +             APPLY.TESTS(TESTS(RULE),EVLIS(VARIABLES(RULE))),
  115. +             ACTION(RULE))       :(RETURN)
  116. APPLY.RULE.END
  117. *
  118. *---------------------------------------------------------------------------
  119. * Tries to match the pattern PAT with the input sentence INP.  VARS is a list
  120. * of variables in the pattern.  If the pattern matches, each variable is set
  121. * to the substring which it matches in INP and MATCH returns T.  Otherwise,
  122. * MATCH returns NIL.
  123. *
  124. * The global variable MATCH.FLAG is set to the value that MATCH returns,
  125. * so if PAT is an atom, MATCH returns the value of MATCH.FLAG.  If this is
  126. * T, the variables still have the values they had when the previous rule
  127. * matched.
  128. *
  129.  DEFINE('MATCH(INP,PAT,VARS)')     :(MATCH.END)
  130. MATCH     ATOM(PAT)      :S(MATCH.A)
  131.       INITIALIZE(VARS)
  132.       MATCH.FLAG = MATCH1(INP,PAT,VARS)
  133. MATCH.A  MATCH = MATCH.FLAG   :(RETURN)
  134. MATCH.END
  135. *
  136. *---------------------------------------------------------------------------
  137. * Initializes each variable in the list LVARS to the value NIL.
  138. *
  139.  DEXP('INITIALIZE(LVARS) = MAPC( .'
  140. + DEXP('LAMBDA(LAMBDA...V) = SET.(LAMBDA...V,NIL)')
  141. +     ',LVARS)')
  142. *
  143. *---------------------------------------------------------------------------
  144. * Tries to match the pattern PAT to the input sentence INP, setting the
  145. * variables in the list VARS to the substring of INPU which they match.
  146. * Returns T if PAT matches INP.  Otherwise, it returns NIL.
  147. *
  148.  DEFINE('MATCH1(INP,PAT,VARS)CA')    :(MATCH1.END)
  149. MATCH1  MATCH1 = NULL(INP) NULLP(PAT)       :S(RETURN)
  150.       MATCH1 = NULL(PAT) NIL       :S(RETURN)
  151.       CA = CAR(PAT)
  152.       MEMQ(CA,VARS)     :F(MATCH1A)
  153.          MATCH1 = NULL( CDR(PAT))
  154. +             SET.(CA,APPEND($CA ~ INP ~ NIL))
  155. +             :S(RETURN)
  156.          MATCH1 = EQU(CAR(INP),CADR(PAT))
  157. +             MATCH1(CDR(INP),CDDR(PAT),VARS)
  158. +             :S(RETURN)
  159.          MATCH1 = DIFFER(NIL,SET.(CA,SNOC($CA,CAR(INP))))
  160. +             MATCH1(CDR(INP),PAT,VARS)     :(RETURN)
  161. MATCH1A  MATCH1 = EQU(CAR(INP),CA)
  162. +             MATCH1(CDR(INP),CDR(PAT),VARS)
  163. +             :S(RETURN)
  164.          MATCH1 = NIL       :(RETURN)
  165. MATCH1.END
  166. *
  167. *---------------------------------------------------------------------------
  168. * Applies the ith function on the list TESTS to the ith S-expression on
  169. * the list PHRASES, and returns a list of the results unless ony of these
  170. * results is NIL, in which case NIL is returned.  NIL is also returned
  171. * if the two lists are of different lengths or if PHRASES is an empty list.
  172. *
  173.  DEFINE('APPLY.TESTS(TESTS,PHRASES)L')       :(APPLY.TESTS.END)
  174. APPLY.TESTS    APPLY.TESTS = NIL
  175.       L = NIL
  176. APPLY.TESTS1 L = DIFFER(NIL,PHRASES) DIFFER(NIL,TESTS)
  177. +        APPLY(CAR(TESTS),CAR(PHRASES)) ~ L       :F(RETURN)
  178.       DIFFER(NIL,CAR(L))  ?POP( .TESTS)  ?POP( .PHRASES)    :F(RETURN)
  179.       APPLY.TESTS = NULL(TESTS) NULL(PHRASES)
  180. +        LREVERSE(L)      :S(RETURN)F(APPLY.TESTS1)
  181. APPLY.TESTS.END
  182. *
  183. *---------------------------------------------------------------------------
  184. * Applies the action ACT, which his a list of functions, to L, which is
  185. * a list of values, and returns the result.
  186. *
  187.  DEFINE('APPLY.RULE.1(L,ACT)XPR')       :(APPLY.RULE.1.END)
  188. APPLY.RULE.1
  189. +     APPLY.RULE.1 = NULL(L)  NIL  :S(RETURN)
  190.       XPR =
  191. +        CAR(ACT) '('
  192. +        CONCAT( RMAPCAR( L, CDR(ACT)), ',', '"') ')'
  193.       APPLY.RULE.1 = EVALCODE(XPR)      :(RETURN)
  194. APPLY.RULE.1.END
  195. *
  196. *---------------------------------------------------------------------------
  197. * Applies each function on the list LF to the S-expression S, and
  198. * returns a list of the results.
  199. *
  200.  DEFINE('RMAPCAR(S,LF)F')    :(RMAPCAR.END)
  201. RMAPCAR  RMAPCAR = NIL
  202. RMAPCAR1      F = POP( .LF)       :F(RMAPCAR2)
  203.       RMAPCAR = APPLY(F,S) ~ RMAPCAR        :(RMAPCAR1)
  204. RMAPCAR2      RMAPCAR = LREVERSE(RMAPCAR)   :(RETURN)
  205. RMAPCAR.END
  206. -EJECT
  207. *******************************************
  208. * GENERAL FUNCTIONS FOR RELATIONAL GRAPHS *
  209. *******************************************
  210. *
  211. * Inserts an arc labeled REL from node X to node Y unless such an arc
  212. * already exists.
  213. *
  214.  DEFINE('ADDXRY(X,REL,Y)')    :(ADDXRY.END)
  215. ADDXRY   ADDXRY = MEMQ(Y,GET(X,REL)) NIL    :S(RETURN)
  216.       ADDXRY = PUTPROP(X,Y,REL)    :(RETURN)
  217. ADDXRY.END   OPSYN( .ADDYRX, .ADDXRY)
  218. *
  219. *---------------------------------------------------------------------------
  220. * Returns T if a path of arcs described by ARC_PATH exists from node X to
  221. * node Y.  The syntax of ARC_PATH can be described as follows:
  222. *
  223. * 1. Any atom is a basic path element.
  224. * 2. A basic path element followed by "*" or by "+" is a path element.
  225. * 3. A list of path elements is an ARC_PATH.
  226. * 4. An ARC_PATH is also a basic path element.
  227. *
  228. * A basic path element followed by a "*" means zero of more occurrences
  229. * of that basic path element.  A basic path element followed by a "+"
  230. * means one or more occurrences of that basic path element.
  231. *
  232.  DEXP('PATH(PATH...X,PATH...R,PATH...Y) = '
  233. +     'MEMQ( $PATH...Y,'
  234. +     'PATH1( $PATH...X ~ NIL, PATH...R))')
  235. *
  236. *---------------------------------------------------------------------------
  237. * Returns all nodes reachable from any of the nodes in the list LN
  238. * by following the ARC_PATH LR.
  239.  DEFINE('PATH1(LN,LR)')     :(PATH1.END)
  240. PATH1    DIFFER(NIL,LN)  DIFFER(NIL,LR)      :F(PATH1C)
  241.        DIFFER(NIL,CDR(LR)) MEMQ(CADR(LR),"*" ~ "+" ~ NIL)  :F(PATH1A)
  242.        LN = EXTENDM(CADR(LR),LN,CAR(LR))
  243.        LR = CDR(LR)       :(PATH1B)
  244. PATH1A    LN = EXTEND(LN,CAR(LR))
  245. PATH1B    LR = CDR(LR)    :(PATH1)
  246. PATH1C    PATH1 = LN      :(RETURN)
  247. PATH1.END
  248. *
  249. *---------------------------------------------------------------------------
  250. * Returns the list of nodes reachable from any of the nodes on the list LN
  251. * by following the path element consisting of the basic path element R
  252. * followed by OP, which is either "*" or "+".
  253. *
  254.  DEFINE('EXTENDM(OP,LN,R)')   :(EXTENDM.END)
  255. EXTENDM  LN = IDENT(OP,"+") EXTEND(LN,R)
  256.       EXTENDM = LN
  257. EXTENDM1      DIFFER(NIL,LN) :F(RETURN)
  258.       LN = COMPLEMENT(EXTEND(LN,R),EXTENDM)
  259.       EXTENDM = APPEND(EXTENDM ~ LN ~ NIL)  :(EXTENDM1)
  260. EXTENDM.END
  261. *
  262. *---------------------------------------------------------------------------
  263. * Returns the list of nodes reachable from any of the nodes on the list LN
  264. * by following one instance of the basic path element R.
  265. *
  266.  DEFINE('EXTEND(LN,R)')       :(EXTEND.END)
  267. EXTEND   EXTEND = NULL(LN) NIL    :S(RETURN)
  268.       EXTEND = ~ATOM(R) PATH1(LN,R)     :S(RETURN)
  269.       EXTEND = UNION(GET(CAR(LN),R),
  270. +        EXTEND(CDR(LN),R))   :(RETURN)
  271. EXTEND.END
  272. *
  273. *---------------------------------------------------------------------------
  274. * Returns a set consisting of those elements of the set S1 that are not
  275. * also elements of the set S2.  (COMPLEMENT(S1,S2))
  276. *
  277.  OPSYN( .COMPLEMENT, .EXCLUDE)
  278. -EJECT
  279. *********************************************************
  280. * TEST FUNCTIONS FOR THE SYNTAX OF ENGLISH NOUN PHRASES *
  281. *********************************************************
  282. *
  283. * The division of noun phrases into unique, generic, and specific as
  284. * defined below is taken from Raphael (1968).  First we define two
  285. * global lists, one of generic determiners, and one of specific
  286. * (definite) determiners.
  287. *
  288.  G.DETS = READ( "(EACH EVERY ANY A AN)" )
  289.  S.DETS = READ( "(THE)" )
  290. *
  291. *---------------------------------------------------------------------------
  292. * If NP is a list of a single word, it is presumed to be a unique noun
  293. * phrase, and that word is returned.  Otherwise NIL is returned.
  294. *
  295.  DEXP('UNIQUE(NP) = NIL ; UNIQUE = '
  296. +     'NULL(CDR(NP)) CAR(NP) ; ')
  297. *
  298. *---------------------------------------------------------------------------
  299. * If NP is a list of words beginning with a G.DET, it is presumed to
  300. * be a generic noun phrase, and that last word is returned.  Otherwise,
  301. * NIL is returned.
  302. *
  303.  DEXP('GENERIC(NP) = NIL ; GENERIC = '
  304. +     'MEMQ(CAR(NP),G.DETS) RAC(NP) ; ')
  305. *
  306. *---------------------------------------------------------------------------
  307. * If NP is a list of words beginning with S.DET, it is presumed to be a
  308. * specific noun phrase, and the last word is returned.  Otherwise, NIL
  309. * is returned.
  310. *
  311.  DEXP('SPECIFIC(NP) = NIL ; SPECIFIC = '
  312. +     'MEMQ(CAR(NP),S.DETS) RAC(NP) ; ')
  313. *
  314. *---------------------------------------------------------------------------
  315. * If NPNP is a unique noun phrase followed by a generic noun phrase, a list
  316. * is returned containing the one word of the forming and the last word of
  317. * of the latter.  Otherwise, NIL is returned.
  318. *
  319.  DEXP('UNIQUE.GENERIC(NPNP) = '
  320. +     'APPLY.TESTS( #"(UNIQUE GENERIC)", SPLIT(NPNP,G.DETS))')
  321. *
  322. *---------------------------------------------------------------------------
  323. * IF NPNP is a specific noun phrase followed by a generic noun phrase, a
  324. * list is returned containing the last word of each.  Otherwise, NIL is
  325. * returned.
  326. *
  327.  DEXP('SPECIFIC.GENERIC(NPNP) = '
  328. +     'APPLY.TESTS( #"(SPECIFIC GENERIC)", SPLIT(NPNP,G.DETS))')
  329. *
  330. *---------------------------------------------------------------------------
  331. * If NPNP is a generic noun phrase followed by another generic noun phrase,
  332. * a list is returned containing the last word of each of them.  Otherwise,
  333. * NIL is returned.
  334. *
  335.  DEXP('GENERIC.GENERIC(NPNP) = '
  336. +     'APPLY.TESTS( #"(GENERIC GENERIC)", SPLIT(NPNP,G.DETS))')
  337. *
  338. *---------------------------------------------------------------------------
  339. * SNP is a list consisting of one or more noun phrases, and LD is a list
  340. * of initial words of noun phrases (determiners).  SPLIT returns a list
  341. * of sublists, the ith sublist being the ith noun phrase in SNP.
  342. *
  343.  DEXP('SPLIT(SNP,LD) = SPLIT1(CDR(SNP),LD,CAR(SNP) ~ NIL,NIL)')
  344. *
  345.  DEFINE('SPLIT1(SNP,LD,NP,LNP)')   :(SPLIT1.END)
  346. SPLIT1   SPLIT1 =
  347. +     NULL(SNP) LREVERSE( LREVERSE(NP) ~ LNP)     :S(RETURN)
  348.       SPLIT1 = MEMQ(CAR(SNP),LD)
  349. +        SPLIT1(CDR(SNP),LD,CAR(SNP) ~ NIL,
  350. +             LREVERSE(NP) ~ LNP)       :S(RETURN)
  351.       SPLIT1 =
  352. +        SPLIT1( CDR(SNP), LD, CAR(SNP) ~ NP, LNP)
  353. +             :(RETURN)
  354. SPLIT1.END
  355. -EJECT
  356. ********************
  357. * ACTION FUNCTIONS *
  358. ********************
  359. *
  360. * We present action functions for set relations, equivalence relations,
  361. * and ownership relations.  Except for the function EQUIV.COMPRESS and
  362. * its help functions, the functions given here have exactly the same names,
  363. * arguments, and actions as specified in Raphael (1968).  They are,
  364. * however, implemented in a different way.
  365. *
  366. * Some responses returned from semantic routines
  367. *
  368.  UNDERSTAND = "I UNDERSTAND."
  369.  YES = "YES."
  370.  SOMETIMES = "SOMETIMES."
  371.  INSUFFICIENT = "INSUFFICIENT INFORMATION"
  372.  SILENCE = ""
  373. -EJECT
  374. ***********************************************
  375. * ACTION FUNCTIONS FOR INFORMATION ABOUT SETS *
  376. ***********************************************
  377. *
  378. * Adds the information that X is a subset of Y.
  379. *
  380.  DEFINE('SETR(X,Y)')    :(SETR.END)
  381. SETR  ADDXRY(X,"SUBSET",Y)
  382.       ADDYRX(Y,"SUPERSET",X)
  383.       SETR = UNDERSTAND      :(RETURN)
  384. SETR.END
  385. *
  386. *---------------------------------------------------------------------------
  387. * Determines if X is a subset of Y.
  388. *
  389.  DEFINE('SETRQ(X,Y)')   :(SETRQ.END)
  390. SETRQ  SETRQ = PATH( .X, #"(SUBSET *)", .Y)   YES
  391. +        :S(RETURN)
  392.       SETRQ = PATH( .Y, #"(SUBSET +)", .X)   SOMETIMES
  393. +        :S(RETURN)
  394.       SETRQ = INSUFFICIENT   :(RETURN)
  395. SETRQ.END
  396. *
  397. *---------------------------------------------------------------------------
  398. * Adds the information that X is a member of the set Y.
  399. *
  400.  DEFINE('SETRS(X,Y)')  :(SETRS.END)
  401. SETRS ADDXRY(X,"MEMBER",Y)
  402.         ADDYRX(Y,"ELEMENTS",X)
  403.         SETRS = UNDERSTAND  :(RETURN)
  404. SETRS.END
  405. *
  406. *---------------------------------------------------------------------------
  407. * Determines if X is a member of the set Y.
  408. *
  409.  DEFINE('SETRSQ(X,Y)') :(SETRSQ.END)
  410. SETRSQ   SETRSQ =
  411. +        PATH( .X, #"(EQUIV * MEMBER SUBSET *)", .Y)   YES
  412. +        :S(RETURN)
  413.       SETRSQ = INSUFFICIENT :(RETURN)
  414. SETRSQ.END
  415. *
  416. *---------------------------------------------------------------------------
  417. * Adds the information that the unique element of the set X is an
  418. * element of the set Y.  Does nothing if X has more than one element.
  419. *
  420.  DEFINE('SETRS1(X,Y)') :(SETRS1.END)
  421. SETRS1   SETRS1 = DIFFER(NIL,SET.(.X,SPECIFY(X)))
  422. +        SETRS(X,Y)      :S(RETURN)
  423.       SETRS1 = SILENCE   :(RETURN)
  424. SETRS1.END
  425. *
  426. *---------------------------------------------------------------------------
  427. * If X has a unique element, it is returned.  If X has no elements, one
  428. * is created and returned.  If X has more than one element, a message is
  429. * printed and NIL is returned.
  430. *
  431.  DEXP('SPECIFY(X) = '
  432. +     'SPECIFY1(EQUIV.COMPRESS(GET(X,"ELEMENTS")),X)')
  433. *
  434.  DEFINE('SPECIFY1(U,X)')      :(SPECIFY1.END)
  435. SPECIFY1     NULL(U)    :F(SPECIFY1A)
  436.       SPECIFY1 = SET.( .U, GENSYM())
  437.       SETRS(U,X)
  438.       |(U " IS A " X ".")   :(RETURN)
  439. SPECIFY1A
  440. +     SPECIFY1 = NULL(CDR(U)) CAR(U)    :S(RETURN)
  441.       |("WHICH " X "? ... " !U)
  442.       SPECIFY1 = NIL    :(RETURN)
  443. SPECIFY1.END
  444. *
  445. *---------------------------------------------------------------------------
  446. * LX is a list of which some elements may be equivalent to some others.  A
  447. * list is returned of the elements of LX without such redundant members.
  448. *
  449.  DEXP('EQUIV.COMPRESS(LX) = EQUIV.COMP1(LX,NIL)')
  450. *
  451.  DEFINE('EQUIV.COMP1(LX,LEX)')     :(EQUIV.COMP1.END)
  452. EQUIV.COMP1
  453. +     EQUIV.COMP1 = NULL(LX) NIL   :S(RETURN)
  454.       EQUIV.COMP1 = MEMQ(CAR(LX),LEX)
  455. +        EQUIV.COMP1(CDR(LX),LEX)      :S(RETURN)
  456.       EQUIV.COMP1 =
  457. +        CAR(LX) ~
  458. +             EQUIV.COMP1( CDR(LX),
  459. +                  APPEND( GET(CAR(LX),"EQUIV") ~ LEX ~ NIL))
  460. +                  :(RETURN)
  461. EQUIV.COMP1.END
  462. *
  463. *---------------------------------------------------------------------------
  464. * Determines if the unique element of the set X (if there is one) is a
  465. * member of the set Y.
  466. *
  467.  DEFINE('SETRS1Q(X,Y)')      :(SETRS1Q.END)
  468. SETRS1Q  SETRS1Q = DIFFER(NIL,SET.(.X,SPECIFY(X)))
  469. +        SETRSQ(X,Y)    :S(RETURN)
  470.       SETRS1Q = SILENCE      :(RETURN)
  471. SETRS1Q.END
  472. -EJECT
  473. *************************************************
  474. * ACTION FUNCTIONS FOR THE EQUIVALENCE RELATION *
  475. *************************************************
  476. *
  477. * Adds the information that X is equivalent to Y.
  478. *
  479.  DEFINE('EQUIV(X,Y)')   :(EQUIV.END)
  480. EQUIV  ADDXRY(X,"EQUIV",Y)
  481.        ADDYRX(Y,"EQUIV",X)
  482.        EQUIV = UNDERSTAND   :(RETURN)
  483. EQUIV.END
  484. *
  485. *---------------------------------------------------------------------------
  486. * If there is a unique element of the set Y, adds the information that it
  487. * is equivalent to X.
  488. *
  489.  DEFINE('EQUIV1(X,Y)')  :(EQUIV1.END)
  490. EQUIV1  EQUIV1 = DIFFER(NIL,SET.(.Y,SPECIFY(Y)))
  491. +       EQUIV(X,Y)     :S(RETURN)
  492.      EQUIV1 = SILENCE  :(RETURN)
  493. EQUIV1.END
  494. -EJECT
  495. ************************************
  496. * ACTION FUNCTIONS ABOUT OWNERSHIP *
  497. ************************************
  498. *
  499. * Adds the information that every member of the set Y owns a member of
  500. * the set X.
  501. *
  502.  DEFINE('OWNR(X,Y)')   :(OWNR.END)
  503. OWNR  ADDXRY(X,"OWNED.BY",Y)
  504.       ADDYRX(Y,"POSSESS.BY.EACH",X)
  505.       OWNR = UNDERSTAND      :(RETURN)
  506. OWNR.END
  507. *
  508. *---------------------------------------------------------------------------
  509. * Determines if every member of the set Y owns a member of the set X.
  510. *
  511.  DEFINE('OWNRQ(X,Y)')  :(OWNRQ.END)
  512. OWNRQ OWNRQ = EQU(X,Y)
  513. +        "NO, THEY ARE THE SAME."     :S(RETURN)
  514.       OWNRQ = PATH( .Y, #"(SUBSET * POSSESS.BY.EACH)", .X)
  515. +        YES  :S(RETURN)
  516.       OWNRQ = INSUFFICIENT  :(RETURN)
  517. OWNRQ.END
  518. *
  519. *---------------------------------------------------------------------------
  520. * Adds the information that Y owns a member of the set X.
  521. *
  522.  DEFINE('OWNRGU(X,Y)') :(OWNRGU.END)
  523. OWNRGU   ADDYRX(Y,"POSSESS",X)
  524.       ADDXRY(X,"OWNED",Y)
  525.       OWNRGU = UNDERSTAND       :(RETURN)
  526. OWNRGU.END
  527. *
  528. *---------------------------------------------------------------------------
  529. * Determines if Y owns a member of the set X.
  530. *
  531.  DEFINE('OWNRGUQ(X,Y)')     :(OWNRGUQ.END)
  532. OWNRGUQ OWNRGUQ =
  533. +         PATH( .Y, #"(EQUIV * POSSESS SUBSET *)", .X)
  534. +         YES     :S(RETURN)
  535.       OWNRGUQ =
  536. +         PATH( .Y, #("(EQUIV * MEMBER SUBSET *"
  537. +           " POSSESS.BY.EACH SUBSET *)"), .X)
  538. +         YES      :S(RETURN)
  539.       OWNRGUQ = INSUFFICIENT      :(RETURN)
  540. OWNRGUQ.END
  541. *
  542. *---------------------------------------------------------------------------
  543. * Determines if some member of the set Y owns the unique element of
  544. * the set X (if such exists).
  545. *
  546.  DEFINE('OWNRSGQ(X,Y)')     :(OWNRSGQ.END)
  547. OWNRSGQ  OWNRSGQ = IDENT(NIL,SPECIFY(X)) SILENCE    :S(RETURN)
  548.       OWNRSGQ =
  549. +        PATH( .X, #"(OWNED EQUIV * MEMBER SUBSET *)", .Y)
  550. +        YES      :S(RETURN)
  551.       OWNRSGQ = INSUFFICIENT      :(RETURN)
  552. OWNRSGQ.END
  553. -EJECT
  554. ********************************************
  555. * A SET OF RULES USING THE ABOVE FUNCTIONS *
  556. ********************************************
  557. *
  558. * Take a string of rules and convert them to the RULE data structure.
  559. *
  560.  DEFINE('MAKE.RULES(STL)ST,R')    :(MAKE.RULES.END)
  561. MAKE.RULES    MAKE.RULES = NIL
  562. MAKE.RULES1   ST = POP( .STL)    :F(MAKE.RULES2)
  563.       ST = READ( "(" ST ")" )
  564.       R = RULE(CAR(ST),CADR(ST),CADDR(ST),CADDDR(ST))
  565.       MAKE.RULES = R ~ MAKE.RULES       :(MAKE.RULES1)
  566. MAKE.RULES2   MAKE.RULES = LREVERSE(MAKE.RULES)    :(RETURN)
  567. MAKE.RULES.END
  568. *
  569. *---------------------------------------------------------------------------
  570. * Rules
  571. *
  572.  RULE.LIST = MAKE.RULES(
  573. + '(IS *X* ?) (*X*) (UNIQUE.GENERIC) (SETRSQ CAAR CADAR)' ~
  574. + '   -     (*X*) (SPECIFIC.GENERIC) (SETRS1Q CAAR CADAR)' ~
  575. + '   -     (*X*) (GENERIC.GENERIC) (SETRQ CAAR CADAR)' ~
  576. + '(DOES *X* OWN *Y* ?) (*X* *Y*) (GENERIC GENERIC) (OWNRQ CADR CAR)' ~
  577. + '   -     (*X* *Y*) (UNIQUE GENERIC) (OWNRGUQ CADR CAR)' ~
  578. + '   -     (*X* *Y*) (GENERIC SPECIFIC) (OWNRSGQ CADR CAR)' ~
  579. + '(*X* IS *Y* !) (*X* *Y*) (UNIQUE GENERIC) (SETRS CAR CADR)' ~
  580. + '   -     (*X* *Y*) (GENERIC GENERIC) (SETR CAR CADR)' ~
  581. + '   -     (*X* *Y*) (SPECIFIC GENERIC) (SETRS1 CAR CADR)' ~
  582. + '   -     (*X* *Y*) (UNIQUE UNIQUE) (EQUIV CAR CADR)' ~
  583. + '   -     (*X* *Y*) (UNIQUE SPECIFIC) (EQUIV1 CAR CADR)' ~
  584. + '   -     (*X* *Y*) (SPECIFIC UNIQUE) (EQUIV1 CADR CAR)' ~
  585. + '(*X* OWNS *Y* !) (*X* *Y*)  (GENERIC GENERIC) (OWNR CADR CAR)' ~
  586. + '   -     (*X* *Y*) (UNIQUE GENERIC) (OWNRGU CADR CAR)' ~
  587. + NIL)
  588. *
  589. *
  590. *************************
  591. * EXECUTION BEGINS HERE *
  592. *************************
  593. *
  594.  |SIR()
  595. END
  596.