-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathNATURAL.LSP
173 lines (141 loc) · 10.7 KB
/
NATURAL.LSP
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
~
~ NATURAL
~
(PRINT 'NATURAL)
(PACKAGE NATURAL
(DEF EXAMINE PLACE REMOVE HEREP HERE SHOWTHIS SHOWCONTENTS MOVETO *PP-NET PNET INSTANCE-FILTER SELCT SHOWNET RECORD SETR GETR
ADDR WORLD COMPILE SUBST GENNAME ATTACH INTERSECTION GETF TESTF)
(PUT NETWORK PARSE-WORD PARSE-NOUN-GROUP PARSE-COMMAND)
{This eval compiles the ATN descriptions}
(EVAL (PRINTC "Compiling ATN parsers..."))
(EVAL (MAPCAR '[LAMBDA (FUNC)
(APPLY 'COMPILE
(GET FUNC
'NETWORK))]
'(PARSE-WORD PARSE-NOUN-GROUP PARSE-COMMAND))))
(DEF 'EXAMINE
'(LAMBDA (OBJ DESCR) (SETQ DESCR (GET OBJ (QUOTE EXTXT))) (COND (DESCR (PRINTC DESCR CMDWIN)) (T (PRINTC "You see nothing of inte~
rest." CMDWIN)))))
(DEF 'PLACE
'(LAMBDA (OBJ NEWHOLDER) (PUT NEWHOLDER (CONS OBJ (GET NEWHOLDER (QUOTE CONTAINS))) (QUOTE CONTAINS)) (PUT OBJ NEWHOLDER (QUOTE H~
OLDER))))
(DEF 'REMOVE
'(LAMBDA (OBJ) (PUT (GET OBJ (QUOTE HOLDER)) (DELETE OBJ (GET (GET OBJ (QUOTE HOLDER)) (QUOTE CONTAINS))) (QUOTE CONTAINS))))
(DEF 'HEREP
'(LAMBDA (LOC) (COND ((OR (NULL (GET LOC (QUOTE CONTAINS))) (AND (NOT (FLAGP LOC (QUOTE OPEN))) (NOT (FLAGP LOC (QUOTE ROOM)))))
NIL) ((MEMBER OBJ (GET LOC (QUOTE CONTAINS)))) ((SOME (QUOTE HEREP) (GET LOC (QUOTE CONTAINS)))))))
(DEF 'HERE
'(LAMBDA (OBJ LOC) (HEREP LOC)))
(DEF 'SHOWTHIS
'(LAMBDA (THIS HTAB) (SETQ HTAB 0) (COND ((FLAGP THIS (QUOTE OPEN)) (SHOWCONTENTS THIS)) (T (FLAG THIS (QUOTE OPEN)) (SHOWCONTENT~
S THIS) (REMFLAG THIS (QUOTE OPEN))))))
(DEF 'SHOWCONTENTS
'(LAMBDA (THING) (COND ((NOT (EQUAL THIS THING)) (TERPRI NIL CMDWIN) (SPACES HTAB CMDWIN) (PRINC (GET THING (QUOTE OBDESCR)) CMDW~
IN))) (COND ((AND (GET THING (QUOTE CONTAINS)) (FLAGP THING (QUOTE OPEN))) (TERPRI NIL CMDWIN) (SPACES HTAB) (PRINC "Inside the " CM~
DWIN) (PRINC (SUBSTRING (GET THING (QUOTE OBDESCR)) (\+ 1 (INSTRING " " (GET THING (QUOTE OBDESCR))))) CMDWIN) (PRINC " is:" CMDWIN)
(SETQ HTAB (\+ HTAB 2)) (MAPCAR (QUOTE SHOWCONTENTS) (GET THING (QUOTE CONTAINS))) (SETQ HTAB (\- HTAB 2))))))
(DEF 'MOVETO
'(LAMBDA (NEXTROOM) (COND ((FLAGP NEXTROOM (QUOTE BEENHERE)) (PRINTC (GET NEXTROOM (QUOTE SHORT-DESCR)) CMDWIN)) (T (PRINTC (GET
NEXTROOM (QUOTE LONG-DESCR)) CMDWIN) (FLAG NEXTROOM (QUOTE BEENHERE)))) (SETQ CROOM NEXTROOM) (SHOWTHIS CROOM)))
(DEF '*PP-NET
'(LAMBDA (L *PP:VTAB) (SETQ *PP:VTAB (CHRPOS *PP:FILE)) (*PP-DELIM "(") (*PP-ATOM E) (*PP-BODY (CDR L) ")" (QUOTE *PP-CONDI) (\+
*PP:VTAB 4))))
(DEF 'PNET
'(LAMBDA (E F) (PROG (*PP:FILE *PP:VTAB) (SETQ *PP:FILE F) (SETQ *PP:VTAB 2) (UNMACEXPAND E) (*PP-NET (GET E (QUOTE NETWORK))) (*~
PP-TAB 0) (RETURN (QUOTE OK)))))
(DEF 'INSTANCE-FILTER
'(LAMBDA (NODE) (APPEND (SUBST (PROG (NOUN) (SETQ NOUN (GET NODE (QUOTE NOUN))) (RETURN (COND ((MEMB (QUOTE PLURAL) (GET NOUN (QU~
OTE FEATURES))) (GET NOUN (QUOTE SINGULAR-FORM))) (T NOUN)))) (QUOTE NOUN) (QUOTE (PROG (OBJECTS) (SETQ OBJECTS (GET (QUOTE NOUN) (Q~
UOTE INSTANCE)))))) (MAPCAR (QUOTE (LAMBDA (ADJECTIVE) (SUBST (GET ADJECTIVE (QUOTE ADJECTIVE-FUNCTION)) (QUOTE PREDICATE) (QUOTE (S~
ETQ OBJECTS (MAPCAN (QUOTE (LAMBDA (CANDIDATE) (COND ((PREDICATE CANDIDATE) (LIST CANDIDATE)) (T NIL)))) OBJECTS)))))) (GET NODE (QU~
OTE ADJECTIVES))) (SUBST (PROG (DETERMINER NUMBER) (SETQ DETERMINER (GET NODE (QUOTE DETERMINER))) (SETQ NUMBER (GET NODE (QUOTE NUM~
BER))) (RETURN (COND ((EQUAL DETERMINER (QUOTE DEFINITE)) (COND ((EQUAL NUMBER (QUOTE SINGULAR)) (QUOTE (EQUAL (LENGTH OBJECTS) 1)))
((EQUAL NUMBER (QUOTE PLURAL)) (QUOTE (GT (LENGTH OBJECTS) 1))))) ((EQUAL DETERMINER (QUOTE INDEFINITE)) (COND ((EQUAL NUMBER (QUOT~
E SINGULAR)) (QUOTE (GT (LENGTH OBJECTS) 0))))) ((NUMBERP NUMBER) (LIST (QUOTE GT) (QUOTE (LENGTH OBJECTS)) NUMBER))))) (QUOTE TEST)
(QUOTE ((COND (TEST (RETURN OBJECTS)) (T (RETURN NIL)))))))))
(DEF 'SELCT
'(LAMBDA (X Y) (COND ((NULL X) NIL) ((MEMB (CAR X) Y) (CAR X)) (T (SELCT (CDR X) Y)))))
(DEF 'SHOWNET
'(NLAMBDA (NAME) (PNET NAME NIL)))
(DEF 'RECORD
'(NLAMBDA X (PUT (CAR X) X (QUOTE NETWORK)) (QUOTE RECORDED)))
(DEF 'SETR
'(LAMBDA (REGISTER VALUE) (PUT THIS-NODE VALUE REGISTER) VALUE))
(DEF 'GETR
'(LAMBDA (REGISTER) (GET THIS-NODE REGISTER)))
(DEF 'ADDR
'(LAMBDA (REGISTER VALUE) (SETR REGISTER (CONS VALUE (GETR REGISTER)))))
(DEF 'WORLD
'(LAMBDA NIL (PROG (SYNTREE CROOM INST1 INST2 OPER REFUSE CMDWIN) (GETWINDOW CMDWIN (0 0) (25 80)) (WINATTR 110 CMDWIN) (WINCLR C~
MDWIN) (PRINTC WELCOMEMSG CMDWIN) (TERPRI NIL CMDWIN) (MOVETO FIRSTROOM) (LOOP (DO (\; "Analyze English") (SETQ REMAINING-WORDS (REA~
DCMMD "" CMDWIN)) (SETQ SYNTREE (PARSE-COMMAND (GENSYM) NIL)) (COND (SYNTREE (\; "
Construct Operation
") (SETQ INST1 (EVAL (INSTANCE-FILTER (GET SYNTREE (QUOTE NOUN-GROUP1))))) (COND ((GET SYNTREE (QUOTE PREPOSITION)) (SETQ INST2 (EVA~
L (INSTANCE-FILTER (GET SYNTREE (QUOTE NOUN-GROUP2)))))) (T (SETQ INST2 NIL))) (\; "
Now we have operation and operands...Do preprocessing
") (SETQ REFUSE (MAPCAN (QUOTE (LAMBDA (PRE) (PROG (TMP) (SETQ TMP (EVAL PRE)) (RETURN (COND (TMP (LIST TMP))))))) (MAPCAN (QUOTE (L~
AMBDA (OBJECT) (PROG (TMP) (SETQ TMP (GET OBJECT (QUOTE PREPROC))) (RETURN (COND (TMP (LIST TMP))))))) (GET CROOM (QUOTE CONTAINS)))
)) (\; "
If no refusals, do operation
") (COND (REFUSE) (T (EVAL (GET (GET SYNTREE (QUOTE COMMAND)) (QUOTE XEQ))))) (\; "
Do post processing
") (MAPCAN (QUOTE (LAMBDA (POST) (PROG (TMP) (SETQ TMP (EVAL POST)) (RETURN (COND (TMP (LIST TMP))))))) (MAPCAN (QUOTE (LAMBDA (OBJE~
CT) (PROG (TMP) (SETQ TMP (GET OBJECT (QUOTE POSTPROC))) (RETURN (COND (TMP (LIST TMP))))))) (GET CROOM (QUOTE CONTAINS)))) (COND ((
AND (FLAGP (QUOTE LOBBY) (QUOTE BEENHERE)) (NOT (EQ CROOM (QUOTE LOBBY))) (NOT (HERE (QUOTE DROID1) (QUOTE LOBBY)))) (PLACE (QUOTE D~
ROID1) (QUOTE LOBBY))))) (T (PRINTC "I'm afraid I don't understand that." CMDWIN))))) (RETURN (QUOTE OK)))))
(DEF 'COMPILE
'(MLAMBDA (DESCRIPTION) (\; "Compiles ATN description into LISP ATN parser") (\; "To compile prerecorded ATN: (APPLY 'COMPILE (GE~
T ATNNAME 'NETWORK))") (PROG (NAME BODY PROGRAM BEGINNING MIDDLE END) (SETQ NAME (CADR DESCRIPTION)) (SETQ BODY (CDDR DESCRIPTION))
(SETQ BEGINNING (SUBST NAME (QUOTE REPLACE) (QUOTE (PROG (THIS-NODE HOLD) (SETQ HOLD REMAINING-WORDS) (SETQ CURRENT-WORD (COND ((GET
(CAR REMAINING-WORDS) (QUOTE SYN))) (T (CAR REMAINING-WORDS)))) (SETQ THIS-NODE (GENNAME (QUOTE REPLACE))))))) (SETQ MIDDLE (APPLY
(QUOTE APPEND) (MAPCAR (QUOTE (LAMBDA (STATE) (LIST (CAR STATE) (CONS (QUOTE COND) (APPEND (MAPCAR (QUOTE (LAMBDA (CLAUSE) (APPEND (
LIST (CADR CLAUSE)) (COND ((CDR (CDDDR CLAUSE)) (CDR (CDR (CDDDR CLAUSE))))) (LIST (LIST (QUOTE GO) (CAR (CDDDR CLAUSE))))))) (CDR S~
TATE)) (QUOTE ((T (GO LOSE))))))))) BODY))) (SETQ END (QUOTE (WIN (COND ((NOT (TESTF THIS-NODE FEATURES)) (GO LOSE))) (ATTACH THIS-N~
ODE PARENT-NODE) (SETQ LAST-PARSED THIS-NODE) (RETURN THIS-NODE) LOSE (SETQ REMAINING-WORDS HOLD) (SETQ CURRENT-WORD (COND ((GET (CA~
R REMAINING-WORDS) (QUOTE SYN))) (T (CAR REMAINING-WORDS)))) (RETURN NIL)))) (SETQ PROGRAM (APPEND (APPEND BEGINNING MIDDLE) END)) (
RETURN (LIST (QUOTE DEFUN) NAME (APPEND (QUOTE (LAMBDA (PARENT-NODE FEATURES))) (LIST PROGRAM)))))))
(DEF 'SUBST
'(LAMBDA (NEW OLD TARGET) (\; "Function substitutes <sexpr1> for <sexpr2> in <sexpr3>") (DEFUN RSBST (LAMBDA (TARGET) (COND ((NUL~
L TARGET) TARGET) ((EQUAL TARGET OLD) NEW) ((ATOM TARGET) TARGET) (T (CONS (RSBST (CAR TARGET)) (RSBST (CDR TARGET))))))) (RSBST TAR~
GET)))
(DEF 'GENNAME
'(LAMBDA (NAME) (PROG (N) (COND ((SETQ N (GET NAME (QUOTE NAMECOUNTER)))) (T (SETQ N 1))) (PUT NAME (INC N) (QUOTE NAMECOUNTER))
(RETURN (READLIST (APPEND (EXPLODE NAME) (EXPLODE N)))))))
(DEF 'ATTACH
'(LAMBDA (C P) (PUT C P (QUOTE PARENT)) (PUT P (APPEND (GET P (QUOTE CHILDREN)) (LIST C)) (QUOTE CHILDREN))))
(DEF 'INTERSECTION
'(LAMBDA (X Y) (COND ((NULL X) NIL) ((MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECTION (CDR X) Y))) (T (INTERSECTION (CDR X) Y)))))
(DEF 'GETF
'(LAMBDA (X) (GET X (QUOTE FEATURES))))
(DEF 'TESTF
'(LAMBDA (NODE FEATURES) (COND ((NULL FEATURES) NIL) ((ATOM FEATURES) (SETQ FEATURES (LIST FEATURES)))) (EQUAL (LENGTH FEATURES)
(LENGTH (INTERSECTION FEATURES (GETF NODE))))))
(PUT 'PARSE-WORD
'(PARSE-WORD (S1 (IF T \--> WIN AFTER (SETQ THIS-NODE CURRENT-WORD) (SETQ REMAINING-WORDS (CDR REMAINING-WORDS)) (COND (REMAINI~
NG-WORDS (SETQ CURRENT-WORD (COND ((GET (CAR REMAINING-WORDS) (QUOTE SYN))) ((CAR REMAINING-WORDS))))) (T (SETQ CURRENT-WORD NIL))))
))
'NETWORK)
(PUT 'PARSE-NOUN-GROUP
'(PARSE-NOUN-GROUP (S1 (IF (PARSE-WORD THIS-NODE (QUOTE DETERMINER)) \--> S2 AFTER (SETR (QUOTE NUMBER) (SELCT (QUOTE (SINGULAR
PLURAL)) (GETF LAST-PARSED))) (SETR (QUOTE DETERMINER) (SELCT (QUOTE (DEFINITE INDEFINITE)) (GETF LAST-PARSED)))) (IF (PARSE-WORD T~
HIS-NODE (QUOTE NOUN)) \--> WIN AFTER (SETR (QUOTE NUMBER) (SELCT (QUOTE (SINGULAR PLURAL)) (GETF LAST-PARSED))) (SETR (QUOTE NOUN)
LAST-PARSED) (SETR (QUOTE DETERMINER) (QUOTE DEFINITE))) (IF (PARSE-WORD THIS-NODE (QUOTE ADJECTIVE)) \--> S2 AFTER (ADDR (QUOTE ADJ~
ECTIVES) LAST-PARSED))) (S2 (IF (PARSE-WORD THIS-NODE (QUOTE ADJECTIVE)) \--> S2 AFTER (ADDR (QUOTE ADJECTIVES) LAST-PARSED)) (IF (P~
ARSE-WORD THIS-NODE (QUOTE NOUN)) \--> WIN AFTER (SETR (QUOTE NUMBER) (SELCT (QUOTE (SINGULAR PLURAL)) (GETF LAST-PARSED))) (SETR (Q~
UOTE NOUN) LAST-PARSED))))
'NETWORK)
(PUT 'PARSE-COMMAND
'(PARSE-COMMAND (S1 (IF (PARSE-WORD THIS-NODE (QUOTE VERB)) \--> S2 AFTER (SETR (QUOTE COMMAND) LAST-PARSED))) (S2 (IF (NULL RE~
MAINING-WORDS) \--> WIN AFTER (SETR (QUOTE IMP-OP) (QUOTE IMPLICIT))) (IF (PARSE-NOUN-GROUP THIS-NODE NIL) \--> S3 AFTER (SETR (QUOT~
E NOUN-GROUP1) LAST-PARSED)) (IF (PARSE-WORD THIS-NODE (QUOTE PREPOSITION)) \--> S5 AFTER (SETR (QUOTE VERBMODE) (QUOTE FOLDED)) (SE~
TR (QUOTE FOLDPREP) LAST-PARSED))) (S3 (IF (NULL REMAINING-WORDS) \--> WIN AFTER (SETR (QUOTE IMP-OP) (QUOTE UNARY))) (IF (PARSE-WOR~
D THIS-NODE (QUOTE PREPOSITION)) \--> S4 AFTER (SETR (QUOTE IMP-OP) (QUOTE BINARY)) (SETR (QUOTE PREPOSITION) LAST-PARSED)) (IF (PAR~
SE-NOUN-GROUP THIS-NODE NIL) \--> WIN AFTER (SETR (QUOTE NOUN-GROUP2) (GETR (QUOTE NOUN-GROUP1))) (SETR (QUOTE NOUN-GROUP1) LAST-PAR~
SED) (SETR (QUOTE PREPOSITION) (QUOTE TO)) (SETR (QUOTE IMP-OP) (QUOTE BINARY)))) (S4 (IF (PARSE-NOUN-GROUP THIS-NODE NIL) \--> WIN
AFTER (SETR (QUOTE NOUN-GROUP2) LAST-PARSED))) (S5 (IF (PARSE-NOUN-GROUP THIS-NODE NIL) \--> WIN AFTER (SETR (QUOTE NOUN-GROUP1) LAS~
T-PARSED))))
'NETWORK)
(\; "This eval compiles the ATN descriptions")
(PRINTC "Compiling ATN parsers...")
(MAPCAR (QUOTE (LAMBDA (FUNC) (APPLY (QUOTE COMPILE) (GET FUNC (QUOTE NETWORK))))) (QUOTE (PARSE-WORD PARSE-NOUN-GROUP PARSE-COMMAND
)))