00100	~    MILISY: THE MINI-LINGUISTIC SYSTEM
00200	~    WRITTEN JANUARY 1972 BY TOM MORAN,
00300	~    COMPUTER SCIENCE DEPARTMENT, CARNEGIE-MELLON UNIVERSITY, PITTSBURGH, PENNSYLVANIA
00400	~    REVISED JULY 1972
00500	~    DOCUMENTATION ON REVISIONS FOUND ON PRDOC[4,MH],TRACE.DOC[4,MH]
00600	
00700	
00800	[PROG ()
00900	
01000	
01100	[DE CONVERSE () (PROG (F TREE)
01200	
01300		(SETQ REPLY @HELLO)
01400	      A (PRINT REPLY)
01500		(LISTEN)
01600		(COND ((ATOM STRING) (TERPRI) (RETURN @BYE)))
01700		(SETQ TREE NIL)
01800		(PARSE STRING @<S> @((NIL NIL)))
01900		(COND ((NULL TREE) (SETQ REPLY @(I CANT PARSE YOUR INPUT)) (GO A)))
02000		(SETQ F FACTS)
02100		(COND (FACT-TRACE (TERPRI)
02200			(PRINC @"THE FACT LIST IS INTIALLY:")
02300			(PRINT FACTS)
02400			(TERPRI)))
02500		(COND ((NULL (INTERPRET-S TREE)) (SETQ FACTS F)))
02600		(GO A)
02700	]
02800	
02900	[DE LISTEN () (PROG2
03000	
03100		(TERPRI) (TERPRI) (PRINC @"**")
03200		(SETQ STRING (READ))
03300	]
03400	
03500	[DF SAY: (L) (SETQ STRING L)]
03600	
03700	[DE PS () (SETQ TREE (PARSE STRING @<S> @((NIL NIL))))]
03800	
03900	[DE I () (INTERPRET-S TREE)]
04000	
04100	[DE PSI () (PROG2 (PS) (I))]
04200	
04300	[SETQ TREE-TRACE NIL]
04400	
04500	[SETQ TF-TRACE NIL]
     

00100	[DF P-RULES (L) (PROG (X Y Z)
00200	
00300	      A (COND ((NULL L) (RETURN NIL)))
00400		(SETQ X (REVERSE (CADR L)))
00500		(SETQ Y NIL)
00600		(SETQ Z NIL)
00700	      B (COND ((NULL X)
00800			(SETQ Z (NCONC (LIST @! Y) Z))
00900			(PUTPROP (CAR L) Z @PRULE)
01000			(SETQ L (CDDR L))
01100			(GO A))
01200		      ((EQ (CAR X) @!)
01300			(SETQ Z (CONS Y Z))
01400			(SETQ Y NIL))
01500		      (T (SETQ Y (CONS (CAR X) Y))))
01600		(SETQ X (CDR X))
01700		(GO B)
01800	]
01900	
02000	[P-RULES
02100	
02200	<S> 	(<X> <Y> ! <SD> ! <SE> ! <SQ> ! <SEQ> ! <SWH>)
02300	<X> 	(AA BB ! AA )
02400	<Y>	(BB CC ! CC)
02500	<SD>	(<NP> <VP>)
02600	<VP>	(<COP> <PRED>)
02700	<COP>	(%BE <NEG>)
02800	<PRED>	(<PP> ! <ADJ>)
02900	<SE>	(THERE <COP> <NP> <PP>)
03000	<SQ>	(%BE <NP> <PRED>)
03100	<SEQ>	(%BE THERE <NP> <PP>)
03200	<SWH>	(%WH <COP> <PRED>)
03300	<NEG>	(NOT !)
03400	<PP>	(%PREP <NP>)
03500	<NP>	(%DET <NP1>)
03600	<NP1>	(<MOD1> %NOUN <MOD2>)
03700	<MOD1>	(<ADJ> <MOD1> !)
03800	<ADJ>	(%COLOR ! %SIZE)
03900	<MOD2>	(<SWH> !)
04000	]
04100	
04200	(DEFPROP %BE (IS ARE) SET)
04300	(DEFPROP %PREP (IN ON UNDER NEAR) SET)
04400	(DEFPROP %DET (THE A) SET)
04500	(DEFPROP %SIZE (BIG SMALL) SET)
04600	(DEFPROP %COLOR (RED BLUE GREEN BLACK) SET)
04700	(DEFPROP %NOUN (BOX BALL BLOCK TABLE FLOOR) SET)
04800	(DEFPROP %WH (WHICH WHAT) SET)
04900	
05000	
05100	
05200	
05300	(DE PARSE (* G STACK) (PROG (ALTS CLASS)
05400		(COND ((SETQ ALTS (GET G @PRULE))
05500			(RPLACD (CDAR STACK) (LIST (LIST G)))
05600			(RETURN (PAR * (CDR ALTS) (CONS (CADDAR STACK) (CONS
05700				(CONS (CAAR STACK) (CDDAR STACK)) (CDR STACK))))))
05800		  ((SETQ CLASS (GET G @SET))
05900			(COND ((MEMQ (CAR *) CLASS)
06000				(RPLACD (CDAR STACK) (LIST (LIST G (CAR *)))))
06100			  (T (RETURN))))
06200		  ((EQ (CAR *) G) (RPLACD (CDAR STACK) (LIST G)))
06300		  (T (RETURN)))
06400		(NEXT (CDR *) (CONS (CONS (CAAR STACK)(CDDAR STACK))(CDR STACK)))))
06500	
06600	(DE PAR (* ALTS STACK)
06700		(COND ((NULL ALTS))
06800		  ((NULL (CAR ALTS)) (RPLACD (CAR STACK) (LIST NIL))
06900			(NEXT * (CDR STACK)))
07000		  (T (PARSE * (CAAR ALTS) (CONS (CONS (CDAR ALTS) (CAR STACK))
07100			(CDR STACK)))
07200			(PAR * (CDR ALTS) STACK))))
07300	
07400	(DE NEXT (* STACK)
07500		(COND ((AND (NULL *) (NULL (CDR STACK))) (SETQ TREE (CONS
07600			(SUBST 0 0 (CADAR STACK)) TREE)))
07700		  ((NULL (CDR STACK)))
07800		  ((NULL (CAAR STACK)) (NEXT * (CDR STACK)))
07900		  (T (PARSE * (CAAAR STACK) (CONS (CONS (CDAAR STACK) (CDAR STACK))
08000			(CDR STACK))))) )
     

00100	[DE INTERPRET-S (TREE) (PROG (X SUBTREE)
00200	
00300		(COND (TREE-TRACE (PRINTREE TREE)))
00400		(FINDNODE <S> TREE)
00500		(COND ((NOT (OR (T-SD) (T-SE) (T-SEQ) (T-SQ) (T-SWH))) (ERROR1) (RETURN NIL)))
00600	     NP (COND ((NULL (FINDNODE <NP> TREE)) NIL)
00700		      ((INTERPRET-NP SUBTREE) (GO NP))
00800		      (T (RETURN NIL)))
00900		(FINDNODE SS TREE)
01000		(COND ((NOT (OR (T-PRED-ADJ) (T-PRED-PP))) (ERROR1) (RETURN NIL))
01100		      ((NOT (OR (T-NNEG) (T-NEG))) (ERROR1) (RETURN NIL)))
01200		(FINDNODE <S> TREE)
01300		(SETQ X (CDAR SUBTREE))
01400		(COND ((EQ (CAR X) @FIND) (GO FIND))
01500		      ((EQ (CAR X) @RECORD)
01600			(RECORD (CADR X))
01700			(SETQ REPLY @(OKAY)))
01800		      ((EQ (CAR X) @VERIFY)
01900			(SETQ X (VERIFY (CADR X)))
02000			(SETQ REPLY (COND ((NULL X) @(I DONT KNOW)) ((EQ X @TRUE) @(YES)) (T @(NO)))))
02100		      (T (ERROR1) (RETURN NIL)))
02200		(RETURN T)
02300	   FIND (SETQ X (EVAL X))
02400		(SETQ REPLY (DESCRIBE X))
02500		(RETURN T)
02600	]
02700	
02800	[DE INTERPRET-NP (TREE) (PROG (SUBTREE W X)
02900	
03000		(FINDNODE <NP1> TREE)
03100		(SETQ W (WORDS SUBTREE))
03200		(T-NP1)
03300	    ADJ (COND ((T-ADJ) (GO ADJ)))
03400		(T-MOD1)
03500		(COND ((NULL (T-MOD2)) (ERROR2) (RETURN NIL)))
03600		(FINDNODE AND TREE)
03700	    AND (COND ((T-AND) (GO AND)))
03800		(SETQ SUBTREE TREE)
03900		(T-NP)
04000		(COND ((T-INDEF) (RETURN (CAR SUBTREE))))
04100		(T-DEF)
04200		(SETQ X (CAR SUBTREE))
04300		(COND ((NULL X) (ERROR3))
04400		      ((NULL (CDR X)) (RPLACA SUBTREE (CAR X)) (RETURN (CAR X)))
04500		      (T (ERROR4)))
04600	]
04700	
04800	[DE ERROR1 () (SETQ REPLY @(I CANT INTERPRET YOUR SENTENCE))]
04900	[DE ERROR2 () (SETQ REPLY @(I CANT INTERPRET RELATIVE CLAUSES))]
05000	[DE ERROR3 () (SETQ REPLY (APPEND @(THERE IS NO) W))]
05100	[DE ERROR4 () (SETQ REPLY (APPEND (APPEND @(I DONT KNOW WHICH) W) @(YOU MEAN)))]
05200	
05300	[DF TF (L) (PROG2
05400	
05500		(PUTPROP (CAR L) (CDR L) @TF)
05600		(PUTPROP (CAR L) (LIST @LAMBDA NIL (LIST @TFX (LIST @QUOTE (CAR L)))) @EXPR)
05700	]
05800	
05900	[TF T-SD
06000		(<S> (<SD> 1 (<VP> (<COP> 0 2) 3)))
06100		(<S> RECORD (SS 2 1 3))
06200	]
06300	[TF T-SE
06400		(<S> (<SE> THERE (<COP> 0 1) 2 3))
06500		(<S> RECORD (SS 1 2 (<PRED> 3)))
06600	]
06700	[TF T-SEQ
06800		(<S> (<SEQ> 0 THERE 1 2))
06900		(<S> VERIFY (SS (<NEG> NIL) 1 (<PRED> 2)))
07000	]
07100	[TF T-SQ
07200		(<S> (<SQ> 0 1 2))
07300		(<S> VERIFY (SS (<NEG> NIL) 1 2))
07400	]
07500	[TF T-SWH
07600		(<S> (<SWH> 0 (<COP> 0 1) 2))
07700		(<S> FIND 3 (SS 1 3 2))
07800		(SETV 3 (NEWNUM))
07900	]
08000	[TF T-PRED-ADJ
08100		(SS 1 2 (<PRED> (<ADJ> (3 4))))
08200		(SS 1 (3 2 4))
08300	]
08400	[TF T-PRED-PP
08500		(SS 1 2 (<PRED> (<PP> (%PREP 3) 4)))
08600		(SS 1 (3 2 4))
08700	]
08800	[TF T-NNEG
08900		(SS (<NEG> NIL) 1)
09000		1
09100	]
09200	[TF T-NEG
09300		(SS (<NEG> NOT) 1)
09400		(NOT 1)
09500	]
09600	
09700	[TF T-NP1
09800		(<NP1> 1 (%NOUN 2) 3)
09900		(<NP1> 4 1 3 (ISA 4 2))
10000		(SETV 4 (NEWNUM))
10100	]
10200	[TF T-ADJ
10300		(<NP1> 1 (<MOD1> (<ADJ> (2 3)) 4) 5 6)
10400		(<NP1> 1 4 5 (AND 6 (2 1 3)))
10500	]
10600	[TF T-MOD1
10700		(<NP1> 1 (<MOD1> NIL) 2 3)
10800		(<NP1> 1 2 3)
10900	]
11000	[TF T-MOD2
11100		(<NP1> 1 (<MOD2> NIL) 2)
11200		(<NP1> 1 2)
11300	]
11400	[TF T-AND
11500		(AND (AND 1 2) . 3)
11600		(AND 1 2 . 3)
11700	]
11800	[TF T-NP
11900		(<NP> (%DET 1) (<NP1> 2 3))
12000		(<NP> 1 2 3)
12100	]
12200	[TF T-INDEF
12300		(<NP> A 1 2)
12400		3
12500		(PROG2 (SETV 3 (CREATE 1 2)) T)
12600	]
12700	[TF T-DEF
12800		(<NP> THE 1 2)
12900		3
13000		(PROG2 (SETV 3 (FIND 1 2)) T)
13100	]
13200	
13300	
13400	
13500	[DE TFX (R) (PROG (N V X)
13600	
13700		(SETQ N R)
13800		(SETQ R (GET R @TF))
13900		(SETQ V (MATCH NIL (CAR R) (CAR SUBTREE)))
14000		(COND ((NULL V) (RETURN NIL)))
14100		(COND ((NULL (CDDR R)) (GO A)))
14200		(SETQ X (SUBSTITUTE V (CADDR R)))
14300		(COND ((NULL (EVAL X)) (RETURN NIL)))
14400	      A (SETQ X (SUBSTITUTE V (CADR R)))
14500		(RPLACA SUBTREE X)
14600		(COND (TREE-TRACE (PRINT (LIST @APPLY N)) (PRINTREE TREE))
14700		      (TF-TRACE (PRINT N)))
14800		(RETURN T)
14900	]
     

00100	[DE PRINTREE (TREE) (PROG2 (PRINTR (CAR TREE) (LIST NIL)) @*)]
00200	
00300	[DE PRINTR (X M) (PROG ()
00400		(COND ((NULL X) (PRINC @")") (RETURN NIL)))
00500		(TERPRI)
00600		(MAPC (FUNCTION (LAMBDA (Z) (PRINC @"     "))) M)
00700		(COND ((ATOM X) (PRINC X) (RETURN NIL)))
00800		(COND ((AND (ATOM (CADR X)) (OR (NULL (CDDR X)) (AND
00900			(NULL (CDDDR X)) (ATOM (CADDR X))))) (PRINC X) (RETURN)))
01000		(PRINC @"(") (PRINC (CAR X))
01100		(SETQ M (CONS NIL M))
01200		(MAPC (FUNCTION (LAMBDA (Y) (PRINTR Y M))) (APPEND (CDR X) @(NIL)))
01300	]
01400	
01500	[DE WORDS (X) (PROG (W Z)
01600	
01700		(SETQ Z (LIST NIL))
01800		(SETQ W Z)
01900		(WORD (CAR X))
02000		(RETURN (CDR Z))
02100	]
02200	
02300	[DE WORD (X) (COND
02400	
02500		((ATOM X) (COND ((NULL X) NIL)
02600				((GET X @PRULE) NIL)
02700				((GET X @SET) NIL)
02800				(T (RPLACD W (LIST X)) (SETQ W (CDR W)))))
02900		(T (WORD (CAR X)) (WORD (CDR X)))
03000	]
03100	
03200	
03300	[DE SETV (N X) (SETQ V (CONS (CONS N X) V))]
03400	
03500	[DE NEWNUM () (SETQ NEWNUM (ADD1 NEWNUM))]
03600	
03700	(SETQ NEWNUM 100)
03800	
03900	[DF FINDNODE (N) (PROG (%TREE Y)
04000	
04100		(SETQ %TREE (EVAL (CADR N)))
04200		(SETQ N (CAR N))
04300		(COND ((EQ (CAAR %TREE) N) (RETURN (SETQ SUBTREE %TREE)))
04400		      (T (RETURN (SETQ SUBTREE (FINDNODE1 (CAR %TREE))))))
04500	]
04600	
04700	[DE FINDNODE1 (X) (COND
04800	
04900		((ATOM X) NIL)
05000		((ATOM (CAR X)) (FINDNODE1 (CDR X)))
05100		((EQ (CAAR X) N) (RETURN X))
05200		((SETQ Y (FINDNODE1 (CAR X))) (RETURN Y))
05300		(T (FINDNODE1 (CDR X)))
05400	]
05500	
05600	
05700	
05800	[DE MATCH (V F E) (PROG (X) (RETURN (COND ((NULL (MACH F E)) NIL) (V V) (T T))))]
05900	
06000	[DE MACH (F E) (COND
06100	
06200		((EQ F E) T)
06300		((NUMBERP F) (COND ((ZEROP F) T)
06400				   ((SETQ X (ASSOC F V)) (EQUAL (CDR X) E))
06500				   (T (SETQ V (CONS (CONS F E) V)) T)))
06600		((ATOM F) NIL)
06700		((ATOM E) NIL)
06800		(T (AND (MACH (CAR F) (CAR E))
06900			(MACH (CDR F) (CDR E))))
07000	]
07100	
07200	[DE SUBSTITUTE (V X) (PROG (Y) (RETURN (SUBS X)))]
07300	
07400	[DE SUBS (X) (COND
07500	
07600		((NUMBERP X) (COND ((SETQ Y (ASSOC X V)) (CDR Y)) (T X)))
07700		((ATOM X) X)
07800		(T (CONS (SUBS (CAR X)) (SUBS (CDR X))))
07900	]
08000	
08100	
08200	
08300	[SETQ FACTS NIL]
08400	
08500	[SETQ FACT-TRACE NIL]
08600	
08700	[DE RECORD (S) (COND
08800	
08900		((EQ (CAR S) @AND) (MAPC (FUNCTION RECORD) (CDR S)))
09000		(FACT-TRACE (TERPRI)
09100			(PRINC @"THE FACT LIST HAS BEEN CHANGED TO:")
09200			(PRINT (SETQ FACTS (CONS S FACTS)))
09300			(TERPRI))
09400		(T (SETQ FACTS (CONS S FACTS)))
09500	]
09600	
09700	[DF CREATE (L) (PROG (X)
09800	
09900		(SETQ X (GENSYM))
10000		(RECORD (SUBSTITUTE (LIST (CONS (CAR L) X)) (CADR L)))
10100		(RETURN X)
10200	]
10300	
10400	[DE VERIFY (S) (PROG (X)
10500	
10600		(COND ((NOT (EQ (CAR S) @AND)) (RETURN (VERIFY1 S))))
10700	      A (COND ((NULL (SETQ S (CDR S))) (RETURN @TRUE))
10800		      ((NOT (EQ (SETQ X (VERIFY1 (CAR S))) @TRUE)) (RETURN X)))
10900		(GO A)
11000	]
11100	
11200	[DE VERIFY1 (S) (PROG (F N)
11300	
11400		(SETQ F FACTS)
11500		(SETQ N (COND ((EQ (CAR S) @NOT) (CADR S)) (T (LIST @NOT S))))
11600	      A (COND ((NULL F) (RETURN NIL))
11700		      ((EQUAL (CAR F) S) (RETURN @TRUE))
11800		      ((EQUAL (CAR F) N) (RETURN @FALSE)))
11900		(SETQ F (CDR F))
12000		(GO A)
12100	]
12200	
12300	[DF FIND (L) (PROG (V X Z)
12400	
12500		(SETQ V (CAR L))
12600		(SETQ L (CADR L))
12700		(SETQ L (COND ((EQ (CAR L) @AND) (CDR L))
12800			      (T (LIST L))))
12900		(SETQ X (FIND1 V (CAR L)))
13000		(COND ((NULL (SETQ L (CDR L))) (RETURN X)))
13100		(SETQ L (CONS @AND L))
13200	      A (COND ((NULL X) (RETURN Z))
13300		      ((EQ (VERIFY (SUBSTITUTE (LIST (CONS V (CAR X))) L)) @TRUE)
13400		       (SETQ Z (CONS (CAR X) Z))))
13500		(SETQ X (CDR X))
13600		(GO A)
13700	]
13800	
13900	[DE FIND1 (V S) (PROG (F X Z)
14000	
14100		(SETQ F FACTS)
14200	      A (COND ((NULL F) (RETURN Z)))
14300		(SETQ X (MATCH NIL S (CAR F)))
14400		(SETQ X (ASSOC V X))
14500		(COND (X (SETQ Z (CONS (CDR X) Z))))
14600		(SETQ F (CDR F))
14700		(GO A)
14800	]
14900	
15000	[DE DESCRIBE (L) (PROG (Z)
15100	
15200		(COND ((NULL L) (RETURN @(NOTHING))))
15300		(MAPC (FUNCTION DESCRIBE1) L)
15400		(RETURN (CDR Z))
15500	]
15600	
15700	[DE DESCRIBE1 (X) (PROG (Y)
15800	
15900		(SETQ Y (FIND1 99 (LIST @ISA X 99)))
16000		(SETQ Y (NCONC (FIND1 99 (LIST @%COLOR X 99)) Y))
16100		(SETQ Y (NCONC (FIND1 99 (LIST @%SIZE X 99)) Y))
16200		(SETQ Z (NCONC Y Z))
16300		(SETQ Z (NCONC (LIST @AND @THE) Z))
16400	]
16500	
16600	
16700	
16800	(SETQ *NOPOINT T)
16900	(RETURN @"MINI-LINGUISTIC SYSTEM READY")   ]