; SEMANTIC INFORMATION RETRIEVAL (S I R) ; THIS PROGRAM WAS PLAGERIZED (?) FROM SHAPIRO'S BOOK 'TECHNIQUES ; OF ARTIFICIAL INTELLIGENCE' AND ADAPTED TO THIS INTERPRETER. ; SIR INTERACTS WITH THE USER TO BUILD AND ANSWER QUESTIONS ON A DATA ; BASE CONSISTING OF MEMBERSHIP, OWNERSHIP, AND SET RELATIONS BETWEEN ; NOUN PHRASES. SIR DISTINGUISHES 3 TYPES OF NOUN PHRASES ; SPECIFIC NOUN PHRASE STARTING WITH 'THE' ; GENERIC NOUN PHRASE STARTING WITH 'A' 'EVERY' ETC. ; UNIQUE SIMPLE NAME (CHARLIE NEW-YORK ETC) ; SIR USES A RULE-LIST (SEE END OF PROGRAM FOR THE DEFAULT LIST) TO MATCH ; AN INPUT SENTENCE AND PERFORM SOME ACTION. FOR EXAMPLE TAKE THE TWO RULES ; ((X IS A Y !) (X Y) (UNIQUE GENERIC) (SETRS CAR CADR)) ; ( DITTO (X Y) (UNIQUE UNIQUE ) (EQUIV CAR CADR)) ; THE SENTENCE 'CHARLIE IS A MAN' WOULD MATCH THE FIRST RULE SETTING THE ; VARIABLE 'X' TO 'CHARLIE' AND THE VARIABLE 'Y' TO 'A MAN'. THE FUNCTION ; 'SETRS' IS CALLED WHICH SETS 'CHARLIE' AS A MEMBER OF THE SET 'A MAN' ; THE SENTENCE 'CHARLIE IS CHARLES' WOULD MATCH THE SECOND RULE. THE FUNCTION ; 'EQUIV' IS CALLED WHICH ESTABLISHES AN EQUIVALENCE LINK BETWEEN ; 'CHARLES' AND 'CHARLIE' ; THE FOLLOWING DIALOGUE WAS TAKEN FROM SHAPIRO'S BOOK AND USED TO TEST ; THE PROGRAM ; (SIR) ; ANY FEM-LIBBER IS AN EXAMPLE OF A MODERN-PERSON ! ; (I UNDERSTAND) ; EVERY MODERN-PERSON IS A PERSON ! ; (I UNDERSTAND) ; IS A FEM-LIBBER A PERSON ? ; (YES) ; IS A PERSON A MODERN-PERSON ? ; (SOMETIMES) ; IS A CHAUVINIST-PIG A PERSON ? ; (INSUFFICIENT INFORMATION) ; CAREN IS A MODERN-PERSON ! ; (I UNDERSTAND) ; IS CARAN A PERSON ? ; (YES) ; IS SCHNERTZ A PERSON ? ; (INSUFFICIENT INFORMATION) ; THE MAN IS A CHAUVINIST-PIG ! ; (G1 IS A MAN) ; (I UNDERSTAND) ; EVERY CHAUVINIST-PIG IS AN OLD-FASHIONED-PERSON ! ; (I UNDERSTAND) ; IS THE MAN AN OLD-FASHIONED-PERSON ? ; (YES) ; STU IS A MAN ! ; (I UNDERSTAND) ; IS THE MAN AN OLD-FASHIONED-PERSON ? ; (WHICH MAN (G1 STU)) ; CHARLIE IS A FIREMAN ! ; (I UNDERSTAND) ; STU IS CHARLIE ! ; (I UNDERSTAND) ; IS STU A FIREMAN ? ; (YES) ; IS THE FIREMAN A MAN ? ; (YES) ; IS EVERY FIREMAN A MAN ? ; (INSUFFICIENT INFORMATION) ; JUDI IS A FIREMAN ! ; (I UNDERSTAND) ; JUDITH IS A FIREMAN ! ; (I UNDERSTAND) ; IS THE FIREMAN A MAN ? ; (WHICH FIREMAN (JUDITH JUDI CHARLIE)) ; JUDI IS JUDITH ! ; (I UNDERSTAND) ; IS THE FIREMAN A MAN ? ; (WHICH FIREMAN (JUDITH CHARLIE)) ; EVERY FIREMAN OWNS A PAIR OF RED SUSPENDERS ! ; (I UNDERSTAND) ; STU OWNS A CAT ! ; (I UNDERSTAND) ; THE CAT IS SCHNERTZ ! ; (I UNDERSTAND) ; DOES A FIREMAN OWN THE CAT ? ; (YES) ; WHAT IS THE MEANING OF LIFE ? ; (STATEMENT FORM NOT RECOGNIZED) ; BYE ! ; GOOD-BYE ; ; TO RUN SIR HAVE LISP BUILT WITH AT LEAST 4096 NODES. HAVE IT ; PROCESS THIS FILE (@SIR.LSP) DEFINING THE FUNCTIONS, RULE-LIST ; ETC. WE USED 'SAVLSP' TO BACK UP THE LOADED INTERPRETER ; IN A FILE 'SIR.TSK' AND CAN PLAY WITH 'SIR' BY SIMPLY ; USING 'RUN SIR' ; TO START SIMPLY CALL SIR WITH NO ARGUMENTS ; LISP>(SIR) ; HAVE FUN ! (DE SIR () , (PROG (S) , , (MSG "Hello" T) , , (REPEAT , , , (SETQ S (GET_SENTENCE)) , , , UNTIL (EQ (CAR S) 'BYE) , , , (PROCESS S) , , ,,,) , , (MSG "Good bye" T) , ,,,) ,,,) ; GET_SENTENCE READS IN ONE SENTENCE ENDING IN EITHER A ! OR ?. IT RETURNS ; IT IN A LIST (DE GET_SENTENCE () , (PROG (S) , , (REPEAT , , , (SETQ S (CONS (READ) S)) , , , UNTIL (MEMBER (CAR S) '(! ?)) , , ,,,) , , (RETURN (REVERSE S)) , ,,,) ,,,) ; PROCESS PROCESSES THE SENTENCE ACCORDING TO THE RULES IN THE GLOBAL ; RULE LIST (DE PROCESS (SENTENCE) , (PROCESS_1 SENTENCE RULE_LIST) ,,,) ; PROCESS 1 FINDS THE FIRST RULE THAT IS APPLICABLE TO THE SENTENCE AND ITS ; VALUE IS PRINTED. IF NO RULE IS APPLICABLE THE ERROR IS PRINTED (DE PROCESS_1 (SENTENCE RULES) , (PROG (RESP) , , (COND , , , ( , , , , (REPEAT , , , , , WHILE RULES , , , , , UNTIL (SETQ RESP (APPLY_RULE (CAR RULES) SENTENCE)) , , , , , (SETQ RULES (CDR RULES)) , , , , ,,,) , , , , (PRINT RESP) , , , ,,,) , , , (T (MSG "Statment form not recognized" T)) , , ,,,) , ,,,) ,,,) ; SYNTAX OF RULES ; A RULE HAS FOUR PARTS ; 1) A PATTERN WHICH IS EITHER A LIST OR AN ATOM. AN ATOM IS ; TAKEN TO BE DITTO MARKS. THAT IS THE SAME AS THE PREVIOUS ; RULE ; 2) A LIST OF VARIABLES APPEARING IN THE PATTERN. EACH VARIABLE ; REPRESENTS A BLANK IN THE PATTERN. IF THE SENTENCE MATCHES ; 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 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 LIST OF THE ; FORM ; (ACT S1 S2 ... SK) ; WHERE ACT IS A FUNCTION OF K ARGUMENTS AND SJ (SAY) IS ; IS A FUNCTION WHICH, APPLIED TO THE LIST OF TEST RESULTS ; GIVES THE JTH ARGUMENT FOR ACT (DE PATTERN (RULE) (CAR RULE)) (DE VARIABLES (RULE) (CADR RULE)) (DE TESTS (RULE) (CADDR RULE)) (DE ACTION (RULE) (CADDR (CDR RULE))) ; APPLY_RULE TRIES TO APPLY 'RULE' TO THE INPUT SENTENCE 'INP'. IT RETURNS ; NIL IF THE RULE DOES NOT APPLY, OTHERWISE RETURNS A MESSAGE THAT ; DEPENDS ON THE RULE (DE APPLY_RULE (RULE INP) , (COND , , ((MATCH INP (PATTERN RULE) (VARIABLES RULE)) , , , (APPLY_RULE_1 , , , , (APPLY_TESTS (TESTS RULE) (EVLIS (VARIABLES RULE))) , , , , (ACTION RULE) , , , ,,,) , , ,,,) , , (T NIL) , ,,,) ,,,) ; MATCH 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. (DE MATCH (INP PAT VARS) , (COND , , ((ATOM PAT) MATCH_FLAG) , , (T , , , (INITIALIZE VARS) , , , (SETQ MATCH_FLAG (MATCH1 INP PAT VARS)) , , ,,,) , ,,,) ,,,) ; 'INITIALIZE' INITS EACH VARIABLE IN THE LIST 'LVARS' TO 'NIL'. (DE INITIALIZE (LVARS) , (MAPCAR , , LVARS , , (FUNCTION (LAMBDA (VAR) , , , (SET VAR NIL) , , ,,,)) , ,,,) ,,,) ; MATCH1 (THE REAL PATTERN MATCHER) TRIES TO MATCH THE PATTERN 'PAT' TO ; THE INPUT SENTENCE 'INP' SETTING THE VARIABLES IN THE LIST 'VARS' TI ; THE SUBSTRINGS OF 'INP' WHICH THEY MATCH. RETURNS T OR NIL DEPENDING ; ON SUCCESS (DE MATCH1 (INP PAT VARS) , (COND , , ((NULL INP) (NULL PAT)) , , ((NULL PAT) NIL ) , , ((MEMBER (CAR PAT) VARS) , , , (COND , , , , ((NULL (CDR PAT)) , , , , , (SET (CAR PAT) (APPEND (EVAL (CAR PAT)) INP)) , , , , ,,,) , , , , ((EQ (CAR INP) (CADR PAT)) , , , , , (MATCH1 (CDR INP) (CDDR PAT) VARS) , , , , ,,,) , , , , (T , , , , , (SET (CAR PAT) , , , , , , (SNOC , , , , , , , (EVAL (CAR PAT)) , , , , , , , (CAR INP) , , , , , , ,,,) , , , , , ,,,) , , , , , (MATCH1 (CDR INP) PAT VARS) , , , , ,,,) , , , ,,,) , , ,,,) , , ((EQ (CAR INP) (CAR PAT)) , , , (MATCH1 (CDR INP) (CDR PAT) VARS) , , ,,,) , , (T NIL) , ,,,) ,,,) ; SNOC TACKS 'S' ON TO THE LIST 'LIS' AS THE LAST ELEMENT (DE SNOC (LIS S) , (COND , , ((NULL LIS) (CONS S NIL)) , , (T , , , (PROG (P) , , , , (SETQ P LIS) , , , , (REPEAT , , , , , UNTIL (NULL (CDR P)) , , , , , (SETQ P (CDR P)) , , , , ,,,) , , , , (RPLACD P (CONS S NIL)) , , , , (RETURN LIS) , , , ,,,) , , ,,,) , ,,,) ,,,) ; APPLY_TEST APPLIES EACH FUNCTION ON THE LIST TESTS TO ITS CORRESPONDING ; S-EXPRESSION IN 'PHRASES' AND RETURNS A LIST OF THE RESULTS UNLESS ANY ; OF THE RESULTS IS NIL - IN WHICH CASE NIL IS RETURNED. NIL IS ALSO ; RETURNED IF THE ARGUMENTS ARE LISTS OF DIFFERENT LENGTH OR IF PHRASES ; IS EMPTY (DE APPLY_TESTS (TESTS PHRASES) , (PROG (L) , , (COND , , , ( , , , , (AND PHRASES , , , , , (REPEAT , , , , , , WHILE TESTS , , , , , , (SETQ L (CONS ((CAR TESTS) (CAR PHRASES)) L)) , , , , , , , , , , , , WHILE (CAR L) , , , , , , (SETQ TESTS (CDR TESTS)) , , , , , , (SETQ PHRASES (CDR PHRASES)) , , , , , , , , , , , , UNTIL (AND (NULL TESTS) (NULL PHRASES)) , , , , , ,,,) , , , , ,,,) , , , , (RETURN (REVERSE L)) , , , ,,,) , , , (T (RETURN NIL)) , , ,,,) , ,,,) ,,,) ; APPLY_RULE_1 APPLIES THE ACTION 'ACT' WHICH IS A LIST OF FUNCTIONS TO 'L' ; WHICH IS A LIST OF VALUES AND RETURNS THE RESULT (DE APPLY_RULE_1 (L ACT) , (COND , , (L , , , (APPLY (CAR ACT) (RMAPCAR L (CDR ACT))) , , ,,,) , ,,,) ,,,) ; RMAPCAR APPLIES EACH FUNCTION ON THE LIST 'LF' TO THE S-EXPRESSION 'S' AND ; RETURNS A LIST OF THE RESULTS (DE RMAPCAR (S LF) , (COND , , ((NULL LF) NIL) , , (T , , , (CONS ((CAR LF) S) (RMAPCAR S (CDR LF))) , , ,,,) , ,,,) ,,,) ; AN 'ARC-PATH' FROM SAY X TO Y HAS THE FOLLOWING SYNTAX ; 1) ANY ATOM IS A BASIC PATH ELEMENT ; 2) A BASIC PATH ELEMENT FOLLOWED BY A '*' OR '+' 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 OR MORE ; OCCURANCES OF THAT ELEMENT. A BASIC PATH ELEMENT FOLLOWED BY A '+' ; MEANS ONE OR MORE OCCURANCES OF THAT BASIC PATH ELEMENT ; ADD INSERTS AN ARC LABELED 'REL' FROM NODE X TO NODE Y UNLESS SUCH AN ARC ; ALREADY EXISTS. NOTE - THE 'REL' PROPERTYS FOR ATOMIC SYMBOLS HAVE LISTS ; OF OTHER ATOMIC SYMBOLS FOR THEIR VALUES. (DE ADD (X REL Y) , (COND , , ((MEMBER Y (GET X REL)) NIL) , , (T , , , (PUT X REL (CONS Y (GET X REL))) , , ,,,) , ,,,) ,,,) ; PATH RETURNS T IF A PATH OF ARCS DESCRIBED BY ARC-PATH EXISTS FROM NODE ; X TO NODE Y (DF PATH , (X_RELS_Y ALIST) , (MEMBER , , (EVAL (CADDR X_RELS_Y) ALIST) , , (PATH1 (LIST (EVAL (CAR X_RELS_Y) ALIST)) (CADR X_RELS_Y)) , ,,,) ,,,) ; PATH1 RETURNS ALL NODES REACHABLE FROM ANY OF THE NODES IS THE LIST 'LN' ; BY FOLLOWING ARC-PATH 'LR' (DE PATH1 (LN LR) , (PROGN , , (REPEAT , , , WHILE LN , , , WHILE LR , , , (COND , , , , ((AND (CDR LR) (MEMBER (CADR LR) '(* +))) , , , , , (SETQ LN (EXTENDM (CADR LR) LN (CAR LR))) , , , , , (SETQ LR (CDR LR)) , , , , ,,,) , , , , (T , , , , , (SETQ LN (EXTEND LN (CAR LR))) , , , , ,,,) , , , ,,,) , , , (SETQ LR (CDR LR)) , , ,,,) , , LN , ,,,) ,,,) ; EXTENDM 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 '+' (DE EXTENDM (OP LN R) , (PROG (ANS) , , (COND , , , ((EQ OP '+) (SETQ LN (EXTEND LN R))) , , ,,,) , , (SETQ ANS LN) , , (REPEAT , , , WHILE LN , , , (SETQ LN (COMPLEMENT (EXTEND LN R) ANS)) , , , (SETQ ANS (APPEND ANS LN)) , , ,,,) , , (RETURN ANS) , ,,,) ,,,) ; EXTEND 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' (DE EXTEND (LN R) , (COND , , ((NULL LN) NIL) , , ((NOT (ATOM R)) (PATH1 LN R)) , , ( T (UNION (GET (CAR LN) R) (EXTEND (CDR LN) R))) , ,,,) ,,,) ; COMPLEMENT RETURNS A SET CONSISTING OF ALL ELEMENTS OF THE SET 'S1' THAT ; ARE NOT ALSO ELEMENTS OF THE SET 'S2' (DE COMPLEMENT (S1 S2) , (COND , , ((NULL S1) NIL) , , ((MEMBER (CAR S1) S2) (COMPLEMENT (CDR S1) S2)) , , (T (CONS (CAR S1) (COMPLEMENT (CDR S1) S2))) , ,,,) ,,,) ; UNION RETURNS THE SET CONSISTING OF ALL ELEMENTS THAT ARE EITHER IN 'S1' ; OR 'S2' (DE UNION (S1 S2) , (COND , , ((NULL S1) S2) , , ((MEMBER (CAR S1) S2) (UNION (CDR S1) S2)) , , ( T (CONS (CAR S1) (UNION (CDR S1) S2))) , ,,,) ,,,) ; DEFINE TWO GLOBAL LISTS - ONE FOR GENERIC DETERMINERS AND ONE FOR ; SPECIFIC (DEFINITE) DETERMINERS (SETQ G_DETS '(EACH EVERY ANY A AN)) (SETQ S_DETS '(THE)) ; UNIQUE - IF 'NP' (NOUN PHRASE) IS A LIST WITH A SINGLE WORD (NAME) THAT ; WORD IS RETURNED. OTHERWISE NIL IS RETURNED (DE UNIQUE (NP) , (COND , , ((NULL (CDR NP)) (CAR NP)) , ,,,) ,,,) ; GENERIC - IF 'NP' IS A LIST OF WORDS BEGINNING WITH A G_DET (SEE ABOVE) ; THE LAST WORD IS RETURNED. OTHERWISE NIL IS RETURNED (DE GENERIC (NP) , (COND , , ((MEMBER (CAR NP) G_DETS) (RAC NP)) , ,,,) ,,,) ; SPECIFIC - IF 'NP' IS A LIST OF WORDS BEGINNING WITH A S_DET (SEE ABOVE) ; THE LAST WORD IS RETURNED. OTHERWISE NIL IS RETURNED (DE SPECIFIC (NP) , (COND , , ((MEMBER (CAR NP) S_DETS) (RAC NP)) , ,,,) ,,,) ; UNIQUE_GENERIC. IF NPNP IS A UNIQUE NOUN PHRASE FOLLOWED BY A GENERIC ; NOUN PHRASE A LIST IS RETURNED CONTAINING ONE WORD OF THE FORMER AND ; THE LAST WORD OF THE LATTER. ELSE NIL IS RETURNED (DE UNIQUE_GENERIC (NPNP) , (APPLY_TESTS '(UNIQUE GENERIC) (SPLIT NPNP G_DETS)) ,,,) ; SPECIFIC_GENERIC. IF NPNP IS A SPECIFIC NOUN PHRASE FOLLOWED BY A GENERIC ; NOUN PHRASE A LIST IS RETURNED CONTAINING ONE WORD OF THE FORMER AND ; THE LAST WORD OF THE LATTER. ELSE NIL IS RETURNED (DE SPECIFIC_GENERIC (NPNP) , , (APPLY_TESTS '(SPECIFIC GENERIC) (SPLIT NPNP G_DETS)) ,,,) ; GENERIC_GENERIC. IF NPNP IS A GENERIC NOUN PHRASE FOLLOWED BY A GENERIC ; NOUN PHRASE A LIST IS RETURNED CONTAINING ONE WORD OF THE FORMER AND ; THE LAST WORD OF THE LATTER. ELSE NIL IS RETURNED (DE GENERIC_GENERIC (NPNP) , , (APPLY_TESTS '(GENERIC GENERIC) (SPLIT NPNP G_DETS)) ,,,) ; SPLIT BREAKS APART A LIST OF SEVERAL NOUN PHRASES. 'SNP' IS THE LIST ; CONTAINING MULTIPLE NOUN PHRASES AND 'LD' IS A LIST OF INITIAL WORDS ; (DETERMINERS). SPLIT RETURNS A LIST OF SUBLISTS, EACH SUBLIST BEING ; A NOUN PHRASE (DE SPLIT (SNP LD) , (SPLIT1 (CDR SNP) LD (LIST (CAR SNP)) NIL) ,,,) (DE SPLIT1 (SNP LD NP LNP) , (COND , , ((NULL SNP) (REVERSE (CONS (REVERSE NP) LNP))) , , ((MEMBER (CAR SNP) LD) , , , (SPLIT1 , , , , (CDR SNP) , , , , LD , , , , (LIST (CAR SNP)) , , , , (CONS (REVERSE NP) LNP) , , , ,,,) , , ,,,) , , (T , , , (SPLIT1 (CDR SNP) LD (CONS (CAR SNP) NP) LNP) , , ,,,) , ,,,) ,,,) ; ACTION FUNCTIONS ; THESE ARE THE ACTION FUNCTIONS FOR SET RELATIONS, EQUIVALENCE RELATIONS, ; AND OWNERSHIP RELATIONS. ; MESSAGES FOR ACTIONS TO RETURN (SETQ UNDERSTAND "I understand") (SETQ YES "Yes") (SETQ SOMETIMES "Sometimes") (SETQ INSUFFICIENT "Insufficient information") (SETQ SILENCE '(NIL)) ; ACTION FUNCTIONS FOR INFORMATION ABOUT SETS ; SETR AND THE INFORMATION THAT X IS A SUBSET OF Y (DE SETR (X Y) , (PROGN , , (ADD X 'SUBSET Y) , , (ADD Y 'SUPERSET X) , , UNDERSTAND , ,,,) ,,,) ; SETRQ DETERMINES IF X IS A SUBSET OF Y (DE SETRQ (X Y) , (COND , , ((PATH X (SUBSET *) Y) YES) , , ((PATH Y (SUBSET +) X) SOMETIMES) , , ( T INSUFFICIENT) , ,,,) ,,,) ; SETRS ADDS THE INFORMATION THAT X IS A MEMBER OF THE SET Y (DE SETRS (X Y) , (PROGN , , (ADD X 'MEMBER Y) , , (ADD Y 'ELEMENTS X) , , UNDERSTAND , ,,,) ,,,) ; SETRSQ DETERMINES IF X IS A MEMBER OF THE SET Y (DE SETRSQ (X Y) , (COND , , ((PATH X (EQUIV * MEMBER SUBSET *) Y) YES) , , ( T INSUFFICIENT) , ,,,) ,,,) ; SETRS1 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 (DE SETRS1 (X Y) , (COND , , ((SETQ X (SPECIFY X)) , , , (SETRS X Y) , , ,,,) , , (T SILENCE) , ,,,) ,,,) ; SPECIFY - IF X HAS A UNIQUE ELEMENT IT IS RETURNED. IF X HAS NO ELEMENTS ; ONE IS CREATED AND RETURNED (GENSYM). IF X HAS MORE THAN ONE ELEMENT ; THE MESSAGE 'WHICH X (A B C...)' IS PRINTED AND NIL IS RETURNED (DE SPECIFY (X) , (SPECIFY1 (EQUIV_COMPRESS (GET X 'ELEMENTS)) X) ,,,) (DE SPECIFY1 (U X) , (COND , , ((NULL U) , , , (SETRS (SETQ U (GENSYM)) X) , , , (PRINT (LIST U 'IS 'A X)) , , , U , , ,,,) , , ((NULL (CDR U)) (CAR U)) , , ( T , , , (PRINT (LIST 'WHICH X , , , , (MAPCAR U '(LAMBDA (E) E)) , , , ,,,)) , , , NIL , , ,,,) , ,,,) ,,,) ; EQUIV_COMPRESS TAKES A LIST 'LX' OF WHICH SOME ELEMENTS MAY BE EQUIVALENT ; TO SOME OTHERS. A LIST IS RETURNED WITHOUT SUCH REDUNDANT MEMBERS (DE EQUIV_COMPRESS (LX) , (EQUIV_COMP1 LX NIL) ,,,) (DE EQUIV_COMP1 (LX LEX) , (COND , , ((NULL LX) NIL) , , ((MEMBER (CAR LX) LEX) (EQUIV_COMP1 (CDR LX) LEX)) , , ( T , , , (CONS , , , , (CAR LX) , , , , (EQUIV_COMP1 (CDR LX) (APPEND (GET (CAR LX) 'EQUIV) LEX)) , , , ,,,) , , ,,,) , ,,,) ,,,) ; SETRS1 DETERMINES IF THE UNIQUE ELEMENT IN 'X' (IF THERE IS ONE) IS A ; MEMBER OF THE SET 'Y' (DE SETRS1Q (X Y) , (COND , , ((SETQ X (SPECIFY X)) (SETRSQ X Y)) , , ( T SILENCE) , ,,,) ,,,) ; ACTION FUNCTIONS FOR THE EQUIVALENCE RELATION ; EQUIV ADDS THE INFORMATION THAT 'X' IS EQUIVALENT TO 'Y' (DE EQUIV (X Y) , (PROGN , , (ADD X 'EQUIV Y) , , (ADD Y 'EQUIV X) , , UNDERSTAND , ,,,) ,,,) ; EQUIV1 - IF THERE IS A UNIQUE ELEMENT OF THE SET Y, ADDS THE INFO THAT IT ; IS EQUIVALENT RO X (DE EQUIV1 (X Y) , (COND , , ((SETQ Y (SPECIFY Y)) (EQUIV X Y)) , , ( T SILENCE) , ,,,) ,,,) ; ACTION FUNCTION ABOUT OWNERSHIP ; OWNR ADDS THE INFO THAT EVERY MEMBER OF THE SET Y OWNS A MEMBER OF THE SET ; X (DE OWNR (X Y) , (PROGN , , (ADD X 'OWNED_BY Y) , , (ADD Y 'POSSESS_BY_EACH X) , , UNDERSTAND , ,,,) ,,,) ; OWNRQ DETERMINES IF EVERY MEMBER OF THE SET Y OWNS A MEMBER OF THE SET X (DE OWNRQ (X Y) , (COND , , ((EQ X Y) "No, they are the same") , , ((PATH Y (SUBSET * POSSESS_BY_EACH) X) YES) , , ( T INSUFFICIENT) , ,,,) ,,,) ; OWNRGU ADDS THE INFORMATION THAT Y OWNS A MEMBER OF THE SET X (DE OWNRGU (X Y) , (PROGN , , (ADD Y 'POSSES X) , , (ADD X 'OWNED Y) , , UNDERSTAND , ,,,) ,,,) ; OWNRGUQ DETERMINES IF Y OWNS A MEMBER OF THE SET X (DE OWNRGUQ (X Y) , (COND , , ((PATH Y (EQUIV * POSSES SUBSET *) X) YES) , , ((PATH Y (EQUIV * MEMBER SUBSET * POSSESS_BY_EACH SUBSET *) X) YES) , , ( T INSUFFICIENT) , ,,,) ,,,) ; OWNRSGQ DETERMINES IF SOME MEMBER OF THE SET Y OWNS THE UNIQUE ELEMENT ; OF THE SET X (IF SUCH EXISTS) (DE OWNRSGQ (X Y) , (COND , , ((NOT (SPECIFY X)) SILENCE) , , ((PATH X (OWNED EQUIV * MEMBER SUBSET *) Y) YES) , , (T INSUFFICIENT) , ,,,) ,,,) ; ESOTERIC FUNCTIONS THAT NEED DEFINING ; RAC RETURNS THE LAST TOP ELEMENT OF 'LIS' (DE RAC (LIS) , (COND , , ((NULL (CDR LIS)) (CAR LIS)) , , ( T (RAC (CDR LIS))) , ,,,) ,,,) ; THIS RULE LIST SUPPORTS THE CONVERSATION (AND SIMILAR ONES) SHOWN ; AT THE TOP OF THE LISTING. IT CAN BE EXTENDED OF COURSE (SETQ RULE_LIST , '( , , ( (IS X ?) (X) (UNIQUE_GENERIC) (SETRSQ CAAR CADAR)) , , ( DITTO (X) (SPECIFIC_GENERIC) (SETRS1Q CAAR CADAR)) , , ( DITTO (X) (GENERIC_GENERIC) (SETRQ CAAR CADAR)) , , , , ((DOES X OWN Y ?) (X Y) (GENERIC GENERIC) (OWNRQ CADR CAR)) , , ( DITTO (X Y) (UNIQUE GENERIC) (OWNRGUQ CADR CAR)) , , ( DITTO (X Y) (GENERIC SPECIFIC)(OWNRSGQ CADR CAR)) , , , , ((X IS Y !) (X Y) (UNIQUE GENERIC) (SETRS CAR CADR)) , , ( DITTO (X Y) (GENERIC GENERIC) (SETR CAR CADR)) , , ( DITTO (X Y) (SPECIFIC GENERIC)(SETRS1 CAR CADR)) , , ( DITTO (X Y) (UNIQUE UNIQUE) (EQUIV CAR CADR)) , , ( DITTO (X Y) (UNIQUE SPECIFIC) (EQUIV1 CAR CADR)) , , ( DITTO (X Y) (SPECIFIC UNIQUE) (EQUIV1 CADR CAR)) , , , , ((X OWNS Y !) (X Y) (GENERIC GENERIC) (OWNR CADR CAR)) , , ( DITTO (X Y) (UNIQUE GENERIC) (OWNRGU CADR CAR)) , ,,,) ,,,) (LEX "!" 'CHRCLMONOP) (LEX "?" 'CHRCLMONOP)