]> github.com/historicalsource and other repositories - zork2.git/blob - gparser.zil
Extensions on Z-Machine Fixed.
[zork2.git] / gparser.zil
1                         "Generic PARSER file for
2                             The ZORK Trilogy
3                        started on 7/28/83 by MARC"
4
5 ;"WHICH and TRAP retrofixes installed"
6
7 "Parser global variable convention:  All parser globals will
8   begin with 'P-'.  Local variables are not restricted in any
9   way.
10 "
11
12 <SETG SIBREAKS ".,\"">
13
14 <GLOBAL PRSA <>>
15 <GLOBAL PRSI <>>
16 <GLOBAL PRSO <>>
17
18 <GLOBAL P-TABLE 0>
19 <GLOBAL P-ONEOBJ 0>
20 <GLOBAL P-SYNTAX 0>
21
22 <GLOBAL P-CCTBL <TABLE 0 0 0 0>>
23 ;"pointers used by CLAUSE-COPY (source/destination beginning/end pointers)"
24 <CONSTANT CC-SBPTR 0>
25 <CONSTANT CC-SEPTR 1>
26 <CONSTANT CC-DBPTR 2>
27 <CONSTANT CC-DEPTR 3>
28
29 <GLOBAL P-LEN 0>
30 <GLOBAL P-DIR 0>
31 <GLOBAL HERE 0>
32 <GLOBAL WINNER 0>
33
34 <GLOBAL P-LEXV
35         <ITABLE 59 (LEXV) 0 #BYTE 0 #BYTE 0> ;<ITABLE BYTE 120>>
36 <GLOBAL AGAIN-LEXV
37         <ITABLE 59 (LEXV) 0 #BYTE 0 #BYTE 0> ;<ITABLE BYTE 120>>
38 <GLOBAL RESERVE-LEXV
39         <ITABLE 59 (LEXV) 0 #BYTE 0 #BYTE 0> ;<ITABLE BYTE 120>>
40 <GLOBAL RESERVE-PTR <>>
41
42 ;"INBUF - Input buffer for READ"
43
44 <GLOBAL P-INBUF
45         <ITABLE 120 (BYTE LENGTH) 0>
46         ;<ITABLE BYTE 60>>
47 <GLOBAL OOPS-INBUF
48         <ITABLE 120 (BYTE LENGTH) 0>
49         ;<ITABLE BYTE 60>>
50 <GLOBAL OOPS-TABLE <TABLE <> <> <> <>>>
51 <CONSTANT O-PTR 0>      "word pointer to unknown token in P-LEXV"
52 <CONSTANT O-START 1>    "word pointer to sentence start in P-LEXV"
53 <CONSTANT O-LENGTH 2>   "byte length of unparsed tokens in P-LEXV"
54 <CONSTANT O-END 3>      "byte pointer to first free byte in OOPS-INBUF"
55
56 ;"Parse-cont variable"
57
58 <GLOBAL P-CONT <>>
59 <GLOBAL P-IT-OBJECT <>>
60 ;<GLOBAL LAST-PSEUDO-LOC <>>
61
62 ;"Orphan flag"
63
64 <GLOBAL P-OFLAG <>>
65 <GLOBAL P-MERGED <>>
66 <GLOBAL P-ACLAUSE <>>
67 <GLOBAL P-ANAM <>>
68 <GLOBAL P-AADJ <>>
69 ;"Parser variables and temporaries"
70
71 ;"Byte offset to # of entries in LEXV"
72
73 <CONSTANT P-LEXWORDS 1> ;"Word offset to start of LEXV entries"
74 <CONSTANT P-LEXSTART 1> ;"Number of words per LEXV entry"
75 <CONSTANT P-LEXELEN 2>
76 <CONSTANT P-WORDLEN 4> ;"Offset to parts of speech byte"
77
78 <CONSTANT P-PSOFF 4> ;"Offset to first part of speech"
79 <CONSTANT P-P1OFF 5> ;"First part of speech bit mask in PSOFF byte"
80 <CONSTANT P-P1BITS 3>
81
82 <CONSTANT P-ITBLLEN 9>
83 <GLOBAL P-ITBL <TABLE 0 0 0 0 0 0 0 0 0 0>>
84 <GLOBAL P-OTBL <TABLE 0 0 0 0 0 0 0 0 0 0>>
85 <GLOBAL P-VTBL <TABLE 0 0 0 0>>
86 <GLOBAL P-OVTBL <TABLE 0 #BYTE 0 #BYTE 0>>
87
88 <GLOBAL P-NCN 0>
89
90 <CONSTANT P-VERB 0>
91 <CONSTANT P-VERBN 1>
92 <CONSTANT P-PREP1 2>
93 <CONSTANT P-PREP1N 3>
94 <CONSTANT P-PREP2 4>
95 <CONSTANT P-PREP2N 5>
96 <CONSTANT P-NC1 6>
97 <CONSTANT P-NC1L 7>
98 <CONSTANT P-NC2 8>
99 <CONSTANT P-NC2L 9>
100
101 <GLOBAL QUOTE-FLAG <>>
102 <GLOBAL P-END-ON-PREP <>>
103
104 " Grovel down the input finding the verb, prepositions, and noun clauses.
105    If the input is <direction> or <walk> <direction>, fall out immediately
106    setting PRSA to ,V?WALK and PRSO to <direction>.  Otherwise, perform
107    all required orphaning, syntax checking, and noun clause lookup."
108 \f
109 <ROUTINE PARSER ("AUX" (PTR ,P-LEXSTART) WRD (VAL 0) (VERB <>) (OF-FLAG <>)
110                        OWINNER OMERGED LEN (DIR <>) (NW 0) (LW 0) (CNT -1))
111         <REPEAT ()
112                 <COND (<G? <SET CNT <+ .CNT 1>> ,P-ITBLLEN> <RETURN>)
113                       (T
114                        <COND (<NOT ,P-OFLAG>
115                               <PUT ,P-OTBL .CNT <GET ,P-ITBL .CNT>>)>
116                        <PUT ,P-ITBL .CNT 0>)>>
117         <SET OWINNER ,WINNER>
118         <SET OMERGED ,P-MERGED>
119         <SETG P-ADVERB <>>
120         <SETG P-MERGED <>>
121         <SETG P-END-ON-PREP <>>
122         <PUT ,P-PRSO ,P-MATCHLEN 0>
123         <PUT ,P-PRSI ,P-MATCHLEN 0>
124         <PUT ,P-BUTS ,P-MATCHLEN 0>
125         <COND (<AND <NOT ,QUOTE-FLAG> <N==? ,WINNER ,PLAYER>>
126                <SETG WINNER ,PLAYER>
127                <SETG HERE <META-LOC ,PLAYER>>
128                ;<COND (<NOT <FSET? <LOC ,WINNER> ,VEHBIT>>
129                       <SETG HERE <LOC ,WINNER>>)>
130                <SETG LIT <LIT? ,HERE>>)>
131         <COND (,RESERVE-PTR
132                <SET PTR ,RESERVE-PTR>
133                <STUFF ,RESERVE-LEXV ,P-LEXV>
134                <COND (<AND <NOT ,SUPER-BRIEF> <EQUAL? ,PLAYER ,WINNER>>
135                       <CRLF>)>
136                <SETG RESERVE-PTR <>>
137                <SETG P-CONT <>>)
138               (,P-CONT
139                <SET PTR ,P-CONT>
140                <COND (<AND <NOT ,SUPER-BRIEF>
141                            <EQUAL? ,PLAYER ,WINNER>
142                            <NOT <VERB? SAY>>>
143                       <CRLF>)>
144                <SETG P-CONT <>>)
145               (T
146                <SETG WINNER ,PLAYER>
147                <SETG QUOTE-FLAG <>>
148                <COND (<NOT <FSET? <LOC ,WINNER> ,VEHBIT>>
149                       <SETG HERE <LOC ,WINNER>>)>
150                <SETG LIT <LIT? ,HERE>>
151                <COND (<NOT ,SUPER-BRIEF> <CRLF>)>
152                <TELL ">">
153                <READ ,P-INBUF ,P-LEXV>)>
154         <SETG P-LEN <GETB ,P-LEXV ,P-LEXWORDS>>
155         <COND (<ZERO? ,P-LEN> <TELL "I beg your pardon?" CR> <RFALSE>)>
156         <COND (<EQUAL? <SET WRD <GET ,P-LEXV .PTR>> ,W?OOPS>
157                <COND (<EQUAL? <GET ,P-LEXV <+ .PTR ,P-LEXELEN>>
158                               ,W?PERIOD ,W?COMMA>
159                       <SET PTR <+ .PTR ,P-LEXELEN>>
160                       <SETG P-LEN <- ,P-LEN 1>>)>
161                <COND (<NOT <G? ,P-LEN 1>>
162                       <TELL "I can't help your clumsiness." CR>
163                       <RFALSE>)
164                      (<GET ,OOPS-TABLE ,O-PTR>
165                       <COND (<AND <G? ,P-LEN 2>
166                                   <EQUAL? <GET ,P-LEXV <+ .PTR ,P-LEXELEN>>
167                                           ,W?QUOTE>>
168                              <TELL
169 "Sorry, you can't correct mistakes in quoted text." CR>
170                              <RFALSE>)
171                             (<G? ,P-LEN 2>
172                              <TELL
173 "Warning: only the first word after OOPS is used." CR>)>
174                       <PUT ,AGAIN-LEXV <GET ,OOPS-TABLE ,O-PTR>
175                            <GET ,P-LEXV <+ .PTR ,P-LEXELEN>>>
176                       <SETG WINNER .OWINNER> ;"maybe fix oops vs. chars.?"
177                       <INBUF-ADD <GETB ,P-LEXV <+ <* .PTR ,P-LEXELEN> 6>>
178                                  <GETB ,P-LEXV <+ <* .PTR ,P-LEXELEN> 7>>
179                                  <+ <* <GET ,OOPS-TABLE ,O-PTR> ,P-LEXELEN> 3>>
180                       <STUFF ,AGAIN-LEXV ,P-LEXV>
181                       <SETG P-LEN <GETB ,P-LEXV ,P-LEXWORDS>>
182                       <SET PTR <GET ,OOPS-TABLE ,O-START>>
183                       <INBUF-STUFF ,OOPS-INBUF ,P-INBUF>)
184                      (T
185                       <PUT ,OOPS-TABLE ,O-END <>>
186                       <TELL "There was no word to replace!" CR>
187                       <RFALSE>)>)
188               (T
189                <COND (<NOT <EQUAL? .WRD ,W?AGAIN ,W?G>>
190                       <SETG P-NUMBER 0>)>
191                <PUT ,OOPS-TABLE ,O-END <>>)>
192         <COND (<EQUAL? <GET ,P-LEXV .PTR> ,W?AGAIN ,W?G>
193                <COND (<ZERO? <GETB ,OOPS-INBUF 1>>
194                       <TELL "Beg pardon?" CR>
195                       <RFALSE>)
196                      (,P-OFLAG
197                       <TELL "It's difficult to repeat fragments." CR>
198                       <RFALSE>)
199                      (<NOT ,P-WON>
200                       <TELL "That would just repeat a mistake." CR>
201                       <RFALSE>)
202                      (<G? ,P-LEN 1>
203                       <COND (<OR <EQUAL? <GET ,P-LEXV <+ .PTR ,P-LEXELEN>>
204                                         ,W?PERIOD ,W?COMMA ,W?THEN>
205                                  <EQUAL? <GET ,P-LEXV <+ .PTR ,P-LEXELEN>>
206                                         ,W?AND>>
207                              <SET PTR <+ .PTR <* 2 ,P-LEXELEN>>>
208                              <PUTB ,P-LEXV ,P-LEXWORDS
209                                    <- <GETB ,P-LEXV ,P-LEXWORDS> 2>>)
210                             (T
211                              <TELL "I couldn't understand that sentence." CR>
212                              <RFALSE>)>)
213                      (T
214                       <SET PTR <+ .PTR ,P-LEXELEN>>
215                       <PUTB ,P-LEXV ,P-LEXWORDS
216                             <- <GETB ,P-LEXV ,P-LEXWORDS> 1>>)>
217                <COND (<G? <GETB ,P-LEXV ,P-LEXWORDS> 0>
218                       <STUFF ,P-LEXV ,RESERVE-LEXV>
219                       <SETG RESERVE-PTR .PTR>)
220                      (T
221                       <SETG RESERVE-PTR <>>)>
222                ;<SETG P-LEN <GETB ,AGAIN-LEXV ,P-LEXWORDS>>
223                <SETG WINNER .OWINNER>
224                <SETG P-MERGED .OMERGED>
225                <INBUF-STUFF ,OOPS-INBUF ,P-INBUF>
226                <STUFF ,AGAIN-LEXV ,P-LEXV>
227                <SET CNT -1>
228                <SET DIR ,AGAIN-DIR>
229                <REPEAT ()
230                 <COND (<IGRTR? CNT ,P-ITBLLEN> <RETURN>)
231                       (T <PUT ,P-ITBL .CNT <GET ,P-OTBL .CNT>>)>>)
232               (T
233                <STUFF ,P-LEXV ,AGAIN-LEXV>
234                <INBUF-STUFF ,P-INBUF ,OOPS-INBUF>
235                <PUT ,OOPS-TABLE ,O-START .PTR>
236                <PUT ,OOPS-TABLE ,O-LENGTH <* 4 ,P-LEN>>
237                <SET LEN
238                     <* 2 <+ .PTR <* ,P-LEXELEN <GETB ,P-LEXV ,P-LEXWORDS>>>>>
239                <PUT ,OOPS-TABLE ,O-END <+ <GETB ,P-LEXV <- .LEN 1>>
240                                           <GETB ,P-LEXV <- .LEN 2>>>>
241                <SETG RESERVE-PTR <>>
242                <SET LEN ,P-LEN>
243                <SETG P-DIR <>>
244                <SETG P-NCN 0>
245                <SETG P-GETFLAGS 0>
246                <REPEAT ()
247                 <COND (<L? <SETG P-LEN <- ,P-LEN 1>> 0>
248                        <SETG QUOTE-FLAG <>>
249                        <RETURN>)
250                       (<OR <SET WRD <GET ,P-LEXV .PTR>>
251                            <SET WRD <NUMBER? .PTR>>>
252                        <COND (<ZERO? ,P-LEN> <SET NW 0>)
253                              (T <SET NW <GET ,P-LEXV <+ .PTR ,P-LEXELEN>>>)>
254                        <COND (<AND <EQUAL? .WRD ,W?TO>
255                                    <EQUAL? .VERB ,ACT?TELL ;,ACT?ASK>>
256                               <SET WRD ,W?QUOTE>)
257                              (<AND <EQUAL? .WRD ,W?THEN>
258                                    <G? ,P-LEN 0>
259                                    <NOT .VERB>
260                                    <NOT ,QUOTE-FLAG> ;"Last NOT added 7/3">
261                               <COND (<EQUAL? .LW 0 ,W?PERIOD>
262                                      <SET WRD ,W?THE>)
263                                     (ELSE
264                                      <PUT ,P-ITBL ,P-VERB ,ACT?TELL>
265                                      <PUT ,P-ITBL ,P-VERBN 0>
266                                      <SET WRD ,W?QUOTE>)>)>
267                        <COND (<EQUAL? .WRD ,W?THEN ,W?PERIOD ,W?QUOTE>
268                               <COND (<EQUAL? .WRD ,W?QUOTE>
269                                      <COND (,QUOTE-FLAG
270                                             <SETG QUOTE-FLAG <>>)
271                                            (T <SETG QUOTE-FLAG T>)>)>
272                               <OR <ZERO? ,P-LEN>
273                                   <SETG P-CONT <+ .PTR ,P-LEXELEN>>>
274                               <PUTB ,P-LEXV ,P-LEXWORDS ,P-LEN>
275                               <RETURN>)
276                              (<AND <SET VAL
277                                         <WT? .WRD
278                                              ,PS?DIRECTION
279                                              ,P1?DIRECTION>>
280                                    <EQUAL? .VERB <> ,ACT?WALK>
281                                    <OR <EQUAL? .LEN 1>
282                                        <AND <EQUAL? .LEN 2>
283                                             <EQUAL? .VERB ,ACT?WALK>>
284                                        <AND <EQUAL? .NW
285                                                     ,W?THEN
286                                                     ,W?PERIOD
287                                                     ,W?QUOTE>
288                                             <NOT <L? .LEN 2>>>
289                                        <AND ,QUOTE-FLAG
290                                             <EQUAL? .LEN 2>
291                                             <EQUAL? .NW ,W?QUOTE>>
292                                        <AND <G? .LEN 2>
293                                             <EQUAL? .NW ,W?COMMA ,W?AND>>>>
294                               <SET DIR .VAL>
295                               <COND (<EQUAL? .NW ,W?COMMA ,W?AND>
296                                      <PUT ,P-LEXV
297                                           <+ .PTR ,P-LEXELEN>
298                                           ,W?THEN>)>
299                               <COND (<NOT <G? .LEN 2>>
300                                      <SETG QUOTE-FLAG <>>
301                                      <RETURN>)>)
302                              (<AND <SET VAL <WT? .WRD ,PS?VERB ,P1?VERB>>
303                                    <NOT .VERB>>
304                               <SET VERB .VAL>
305                               <PUT ,P-ITBL ,P-VERB .VAL>
306                               <PUT ,P-ITBL ,P-VERBN ,P-VTBL>
307                               <PUT ,P-VTBL 0 .WRD>
308                               <PUTB ,P-VTBL 2 <GETB ,P-LEXV
309                                                     <SET CNT
310                                                          <+ <* .PTR 2> 2>>>>
311                               <PUTB ,P-VTBL 3 <GETB ,P-LEXV <+ .CNT 1>>>)
312                              (<OR <SET VAL <WT? .WRD ,PS?PREPOSITION 0>>
313                                   <EQUAL? .WRD ,W?ALL ,W?ONE ;,W?BOTH>
314                                   <WT? .WRD ,PS?ADJECTIVE>
315                                   <WT? .WRD ,PS?OBJECT>>
316                               <COND (<AND <G? ,P-LEN 1>
317                                           <EQUAL? .NW ,W?OF>
318                                           <ZERO? .VAL>
319                                           <NOT <EQUAL? .WRD
320                                                        ,W?ALL ,W?ONE ,W?A>>
321                                           ;<NOT <EQUAL? .WRD ,W?BOTH>>>
322                                      <SET OF-FLAG T>)
323                                     (<AND <NOT <ZERO? .VAL>>
324                                           <OR <ZERO? ,P-LEN>
325                                               <EQUAL? .NW ,W?THEN ,W?PERIOD>>>
326                                      <SETG P-END-ON-PREP T>
327                                      <COND (<L? ,P-NCN 2>
328                                             <PUT ,P-ITBL ,P-PREP1 .VAL>
329                                             <PUT ,P-ITBL ,P-PREP1N .WRD>)>)
330                                     (<EQUAL? ,P-NCN 2>
331                                      <TELL
332 "There were too many nouns in that sentence." CR>
333                                      <RFALSE>)
334                                     (T
335                                      <SETG P-NCN <+ ,P-NCN 1>>
336                                      <SETG P-ACT .VERB>
337                                      <OR <SET PTR <CLAUSE .PTR .VAL .WRD>>
338                                          <RFALSE>>
339                                      <COND (<L? .PTR 0>
340                                             <SETG QUOTE-FLAG <>>
341                                             <RETURN>)>)>)
342                              (<EQUAL? .WRD ,W?OF>
343                               <COND (<OR <NOT .OF-FLAG>
344                                          <EQUAL? .NW ,W?PERIOD ,W?THEN>>
345                                      <CANT-USE .PTR>
346                                      <RFALSE>)
347                                     (T
348                                      <SET OF-FLAG <>>)>)
349                              (<WT? .WRD ,PS?BUZZ-WORD>)
350                              (<AND <EQUAL? .VERB ,ACT?TELL>
351                                    <WT? .WRD ,PS?VERB ,P1?VERB>
352                                    <EQUAL? ,WINNER ,PLAYER>>
353                               <TELL
354 "Please consult your manual for the correct way to talk to other people
355 or creatures." CR>
356                               <RFALSE>)
357                              (T
358                               <CANT-USE .PTR>
359                               <RFALSE>)>)
360                       (T
361                        <UNKNOWN-WORD .PTR>
362                        <RFALSE>)>
363                 <SET LW .WRD>
364                 <SET PTR <+ .PTR ,P-LEXELEN>>>)>
365         <PUT ,OOPS-TABLE ,O-PTR <>>
366         <COND (.DIR
367                <SETG PRSA ,V?WALK>
368                <SETG PRSO .DIR>
369                <SETG P-OFLAG <>>
370                <SETG P-WALK-DIR .DIR>
371                <SETG AGAIN-DIR .DIR>)
372               (ELSE
373                <COND (,P-OFLAG <ORPHAN-MERGE>)>
374                <SETG P-WALK-DIR <>>
375                <SETG AGAIN-DIR <>>
376                <COND (<AND <SYNTAX-CHECK>
377                            <SNARF-OBJECTS>
378                            <MANY-CHECK>
379                            <TAKE-CHECK>>
380                       T)>)>>
381
382 <GLOBAL P-ACT <>>
383 <GLOBAL P-WALK-DIR <>>
384 <GLOBAL AGAIN-DIR <>>
385
386 ;"For AGAIN purposes, put contents of one LEXV table into another."
387 <ROUTINE STUFF (SRC DEST "OPTIONAL" (MAX 29) "AUX" (PTR ,P-LEXSTART) (CTR 1)
388                                                    BPTR)
389          <PUTB .DEST 0 <GETB .SRC 0>>
390          <PUTB .DEST 1 <GETB .SRC 1>>
391          <REPEAT ()
392           <PUT .DEST .PTR <GET .SRC .PTR>>
393           <SET BPTR <+ <* .PTR 2> 2>>
394           <PUTB .DEST .BPTR <GETB .SRC .BPTR>>
395           <SET BPTR <+ <* .PTR 2> 3>>
396           <PUTB .DEST .BPTR <GETB .SRC .BPTR>>
397           <SET PTR <+ .PTR ,P-LEXELEN>>
398           <COND (<IGRTR? CTR .MAX>
399                  <RETURN>)>>>
400
401 ;"Put contents of one INBUF into another"
402 <ROUTINE INBUF-STUFF (SRC DEST "AUX" CNT)
403          <SET CNT <- <GETB .SRC 0> 1>>
404          <REPEAT ()
405                  <PUTB .DEST .CNT <GETB .SRC .CNT>>
406                  <COND (<DLESS? CNT 0> <RETURN>)>>>
407
408 ;"Put the word in the positions specified from P-INBUF to the end of
409 OOPS-INBUF, leaving the appropriate pointers in AGAIN-LEXV"
410 <ROUTINE INBUF-ADD (LEN BEG SLOT "AUX" DBEG (CTR 0) TMP)
411          <COND (<SET TMP <GET ,OOPS-TABLE ,O-END>>
412                 <SET DBEG .TMP>)
413                (T
414                 <SET DBEG <+ <GETB ,AGAIN-LEXV
415                                    <SET TMP <GET ,OOPS-TABLE ,O-LENGTH>>>
416                              <GETB ,AGAIN-LEXV <+ .TMP 1>>>>)>
417          <PUT ,OOPS-TABLE ,O-END <+ .DBEG .LEN>>
418          <REPEAT ()
419           <PUTB ,OOPS-INBUF <+ .DBEG .CTR> <GETB ,P-INBUF <+ .BEG .CTR>>>
420           <SET CTR <+ .CTR 1>>
421           <COND (<EQUAL? .CTR .LEN> <RETURN>)>>
422          <PUTB ,AGAIN-LEXV .SLOT .DBEG>
423          <PUTB ,AGAIN-LEXV <- .SLOT 1> .LEN>>
424
425 ;"Check whether word pointed at by PTR is the correct part of speech.
426    The second argument is the part of speech (,PS?<part of speech>).  The
427    3rd argument (,P1?<part of speech>), if given, causes the value
428    for that part of speech to be returned."
429 \f
430 <ROUTINE WT? (PTR BIT "OPTIONAL" (B1 5) "AUX" (OFFS ,P-P1OFF) TYP)
431         <COND (<BTST <SET TYP <GETB .PTR ,P-PSOFF>> .BIT>
432                <COND (<G? .B1 4> <RTRUE>)
433                      (T
434                       <SET TYP <BAND .TYP ,P-P1BITS>>
435                       <COND (<NOT <EQUAL? .TYP .B1>> <SET OFFS <+ .OFFS 1>>)>
436                       <GETB .PTR .OFFS>)>)>>
437
438 ;" Scan through a noun clause, leave a pointer to its starting location"
439
440 <ROUTINE CLAUSE (PTR VAL WRD "AUX" OFF NUM (ANDFLG <>) (FIRST?? T) NW (LW 0))
441         <SET OFF <* <- ,P-NCN 1> 2>>
442         <COND (<NOT <EQUAL? .VAL 0>>
443                <PUT ,P-ITBL <SET NUM <+ ,P-PREP1 .OFF>> .VAL>
444                <PUT ,P-ITBL <+ .NUM 1> .WRD>
445                <SET PTR <+ .PTR ,P-LEXELEN>>)
446               (T <SETG P-LEN <+ ,P-LEN 1>>)>
447         <COND (<ZERO? ,P-LEN> <SETG P-NCN <- ,P-NCN 1>> <RETURN -1>)>
448         <PUT ,P-ITBL <SET NUM <+ ,P-NC1 .OFF>> <REST ,P-LEXV <* .PTR 2>>>
449         <COND (<EQUAL? <GET ,P-LEXV .PTR> ,W?THE ,W?A ,W?AN>
450                <PUT ,P-ITBL .NUM <REST <GET ,P-ITBL .NUM> 4>>)>
451         <REPEAT ()
452                 <COND (<L? <SETG P-LEN <- ,P-LEN 1>> 0>
453                        <PUT ,P-ITBL <+ .NUM 1> <REST ,P-LEXV <* .PTR 2>>>
454                        <RETURN -1>)>
455                 <COND (<OR <SET WRD <GET ,P-LEXV .PTR>>
456                            <SET WRD <NUMBER? .PTR>>>
457                        <COND (<ZERO? ,P-LEN> <SET NW 0>)
458                              (T <SET NW <GET ,P-LEXV <+ .PTR ,P-LEXELEN>>>)>
459                        <COND (<EQUAL? .WRD ,W?AND ,W?COMMA> <SET ANDFLG T>)
460                              (<EQUAL? .WRD ,W?ALL ,W?ONE ;,W?BOTH>
461                               <COND (<EQUAL? .NW ,W?OF>
462                                      <SETG P-LEN <- ,P-LEN 1>>
463                                      <SET PTR <+ .PTR ,P-LEXELEN>>)>)
464                              (<OR <EQUAL? .WRD ,W?THEN ,W?PERIOD>
465                                   <AND <WT? .WRD ,PS?PREPOSITION>
466                                        <GET ,P-ITBL ,P-VERB>
467                                           ;"ADDED 4/27 FOR TURTLE,UP"
468                                        <NOT .FIRST??>>>
469                               <SETG P-LEN <+ ,P-LEN 1>>
470                               <PUT ,P-ITBL
471                                    <+ .NUM 1>
472                                    <REST ,P-LEXV <* .PTR 2>>>
473                               <RETURN <- .PTR ,P-LEXELEN>>)
474                              (<WT? .WRD ,PS?OBJECT>
475                               <COND (<AND <G? ,P-LEN 0>
476                                           <EQUAL? .NW ,W?OF>
477                                           <NOT <EQUAL? .WRD ,W?ALL ,W?ONE>>>
478                                      T)
479                                     (<AND <WT? .WRD
480                                                ,PS?ADJECTIVE
481                                                ,P1?ADJECTIVE>
482                                           <NOT <EQUAL? .NW 0>>
483                                           <WT? .NW ,PS?OBJECT>>)
484                                     (<AND <NOT .ANDFLG>
485                                           <NOT <EQUAL? .NW ,W?BUT ,W?EXCEPT>>
486                                           <NOT <EQUAL? .NW ,W?AND ,W?COMMA>>>
487                                      <PUT ,P-ITBL
488                                           <+ .NUM 1>
489                                           <REST ,P-LEXV <* <+ .PTR 2> 2>>>
490                                      <RETURN .PTR>)
491                                     (T <SET ANDFLG <>>)>)
492                              (<AND <OR ,P-MERGED
493                                        ,P-OFLAG
494                                        <NOT <EQUAL? <GET ,P-ITBL ,P-VERB> 0>>>
495                                    <OR <WT? .WRD ,PS?ADJECTIVE>
496                                        <WT? .WRD ,PS?BUZZ-WORD>>>)
497                              (<AND .ANDFLG
498                                    <OR <WT? .WRD ,PS?DIRECTION>
499                                        <WT? .WRD ,PS?VERB>>>
500                               <SET PTR <- .PTR 4>>
501                               <PUT ,P-LEXV <+ .PTR 2> ,W?THEN>
502                               <SETG P-LEN <+ ,P-LEN 2>>)
503                              (<WT? .WRD ,PS?PREPOSITION> T)
504                              (T
505                               <CANT-USE .PTR>
506                               <RFALSE>)>)
507                       (T <UNKNOWN-WORD .PTR> <RFALSE>)>
508                 <SET LW .WRD>
509                 <SET FIRST?? <>>
510                 <SET PTR <+ .PTR ,P-LEXELEN>>>>
511
512 <ROUTINE NUMBER? (PTR "AUX" CNT BPTR CHR (SUM 0) (TIM <>))
513          <SET CNT <GETB <REST ,P-LEXV <* .PTR 2>> 2>>
514          <SET BPTR <GETB <REST ,P-LEXV <* .PTR 2>> 3>>
515          <REPEAT ()
516                  <COND (<L? <SET CNT <- .CNT 1>> 0> <RETURN>)
517                        (T
518                         <SET CHR <GETB ,P-INBUF .BPTR>>
519                         <COND (<EQUAL? .CHR 58>
520                                <SET TIM .SUM>
521                                <SET SUM 0>)
522                               (<G? .SUM 10000> <RFALSE>)
523                               (<AND <L? .CHR 58> <G? .CHR 47>>
524                                <SET SUM <+ <* .SUM 10> <- .CHR 48>>>)
525                               (T <RFALSE>)>
526                         <SET BPTR <+ .BPTR 1>>)>>
527          <PUT ,P-LEXV .PTR ,W?INTNUM>
528          <COND (<G? .SUM 1000> <RFALSE>)
529                (.TIM
530                 <COND (<L? .TIM 8> <SET TIM <+ .TIM 12>>)
531                       (<G? .TIM 23> <RFALSE>)>
532                 <SET SUM <+ .SUM <* .TIM 60>>>)>
533          <SETG P-NUMBER .SUM>
534          ,W?INTNUM>
535
536 <GLOBAL P-NUMBER 0>
537
538 <GLOBAL P-DIRECTION 0>
539
540 \f
541 ;"New ORPHAN-MERGE for TRAP Retrofix 6/21/84"
542
543 <ROUTINE ORPHAN-MERGE ("AUX" (CNT -1) TEMP VERB BEG END (ADJ <>) WRD)
544    <SETG P-OFLAG <>>
545    <COND (<OR <EQUAL? <WT? <SET WRD <GET <GET ,P-ITBL ,P-VERBN> 0>>
546                            ,PS?VERB ,P1?VERB>
547                       <GET ,P-OTBL ,P-VERB>>
548               <NOT <ZERO? <WT? .WRD ,PS?ADJECTIVE>>>>
549           <SET ADJ T>)
550          (<AND <NOT <ZERO? <WT? .WRD ,PS?OBJECT ,P1?OBJECT>>>
551                <EQUAL? ,P-NCN 0>>
552           <PUT ,P-ITBL ,P-VERB 0>
553           <PUT ,P-ITBL ,P-VERBN 0>
554           <PUT ,P-ITBL ,P-NC1 <REST ,P-LEXV 2>>
555           <PUT ,P-ITBL ,P-NC1L <REST ,P-LEXV 6>>
556           <SETG P-NCN 1>)>
557    <COND (<AND <NOT <ZERO? <SET VERB <GET ,P-ITBL ,P-VERB>>>>
558                <NOT .ADJ>
559                <NOT <EQUAL? .VERB <GET ,P-OTBL ,P-VERB>>>>
560           <RFALSE>)
561          (<EQUAL? ,P-NCN 2> <RFALSE>)
562          (<EQUAL? <GET ,P-OTBL ,P-NC1> 1>
563           <COND (<OR <EQUAL? <SET TEMP <GET ,P-ITBL ,P-PREP1>>
564                           <GET ,P-OTBL ,P-PREP1>>
565                      <ZERO? .TEMP>>
566                  <COND (.ADJ
567                         <PUT ,P-OTBL ,P-NC1 <REST ,P-LEXV 2>>
568                         <COND (<ZERO? <GET ,P-ITBL ,P-NC1L>>
569                                <PUT ,P-ITBL ,P-NC1L <REST ,P-LEXV 6>>)>
570                         <COND (<ZERO? ,P-NCN> <SETG P-NCN 1>)>)
571                        (T
572                         <PUT ,P-OTBL ,P-NC1 <GET ,P-ITBL ,P-NC1>>)>
573                  <PUT ,P-OTBL ,P-NC1L <GET ,P-ITBL ,P-NC1L>>)
574                 (T <RFALSE>)>)
575          (<EQUAL? <GET ,P-OTBL ,P-NC2> 1>
576           <COND (<OR <EQUAL? <SET TEMP <GET ,P-ITBL ,P-PREP1>>
577                           <GET ,P-OTBL ,P-PREP2>>
578                      <ZERO? .TEMP>>
579                  <COND (.ADJ
580                         <PUT ,P-ITBL ,P-NC1 <REST ,P-LEXV 2>>
581                         <COND (<ZERO? <GET ,P-ITBL ,P-NC1L>>
582                                <PUT ,P-ITBL ,P-NC1L <REST ,P-LEXV 6>>)>)>
583                  <PUT ,P-OTBL ,P-NC2 <GET ,P-ITBL ,P-NC1>>
584                  <PUT ,P-OTBL ,P-NC2L <GET ,P-ITBL ,P-NC1L>>
585                  <SETG P-NCN 2>)
586                 (T <RFALSE>)>)
587          (<NOT <ZERO? ,P-ACLAUSE>>
588           <COND (<AND <NOT <EQUAL? ,P-NCN 1>> <NOT .ADJ>>
589                  <SETG P-ACLAUSE <>>
590                  <RFALSE>)
591                 (T
592                  <SET BEG <GET ,P-ITBL ,P-NC1>>
593                  <COND (.ADJ <SET BEG <REST ,P-LEXV 2>> <SET ADJ <>>)>
594                  <SET END <GET ,P-ITBL ,P-NC1L>>
595                  <REPEAT ()
596                          <SET WRD <GET .BEG 0>>
597                          <COND (<EQUAL? .BEG .END>
598                                 <COND (.ADJ <ACLAUSE-WIN .ADJ> <RETURN>)
599                                       (T <SETG P-ACLAUSE <>> <RFALSE>)>)
600                                (<AND <NOT .ADJ>
601                                      <OR <BTST <GETB .WRD ,P-PSOFF>
602                                                ,PS?ADJECTIVE>
603                                          <EQUAL? .WRD ,W?ALL ,W?ONE>>>
604                                 <SET ADJ .WRD>)
605                                (<EQUAL? .WRD ,W?ONE>
606                                 <ACLAUSE-WIN .ADJ>
607                                 <RETURN>)
608                                (<BTST <GETB .WRD ,P-PSOFF> ,PS?OBJECT>
609                                 <COND (<EQUAL? .WRD ,P-ANAM>
610                                        <ACLAUSE-WIN .ADJ>)
611                                       (T
612                                        <NCLAUSE-WIN>)>
613                                 <RETURN>)>
614                          <SET BEG <REST .BEG ,P-WORDLEN>>
615                          <COND (<EQUAL? .END 0>
616                                 <SET END .BEG>
617                                 <SETG P-NCN 1>
618                                 <PUT ,P-ITBL ,P-NC1 <BACK .BEG 4>>
619                                 <PUT ,P-ITBL ,P-NC1L .BEG>)>>)>)>
620    <PUT ,P-VTBL 0 <GET ,P-OVTBL 0>>
621    <PUTB ,P-VTBL 2 <GETB ,P-OVTBL 2>>
622    <PUTB ,P-VTBL 3 <GETB ,P-OVTBL 3>>
623    <PUT ,P-OTBL ,P-VERBN ,P-VTBL>
624    <PUTB ,P-VTBL 2 0>
625    <REPEAT ()
626            <COND (<G? <SET CNT <+ .CNT 1>> ,P-ITBLLEN>
627                   <SETG P-MERGED T>
628                   <RTRUE>)
629                  (T <PUT ,P-ITBL .CNT <GET ,P-OTBL .CNT>>)>>
630    T>
631
632 ;"New ACLAUSE-WIN for TRAP retrofix 6/21/84"
633
634 <ROUTINE ACLAUSE-WIN (ADJ)
635         <PUT ,P-ITBL ,P-VERB <GET ,P-OTBL ,P-VERB>>
636         <PUT ,P-CCTBL ,CC-SBPTR ,P-ACLAUSE>
637         <PUT ,P-CCTBL ,CC-SEPTR <+ ,P-ACLAUSE 1>>
638         <PUT ,P-CCTBL ,CC-DBPTR ,P-ACLAUSE>
639         <PUT ,P-CCTBL ,CC-DEPTR <+ ,P-ACLAUSE 1>>
640         <CLAUSE-COPY ,P-OTBL ,P-OTBL .ADJ>
641         <AND <NOT <EQUAL? <GET ,P-OTBL ,P-NC2> 0>> <SETG P-NCN 2>>
642         <SETG P-ACLAUSE <>>
643         <RTRUE>>
644
645 <ROUTINE NCLAUSE-WIN ()
646         <PUT ,P-CCTBL ,CC-SBPTR ,P-NC1>
647         <PUT ,P-CCTBL ,CC-SEPTR ,P-NC1L>
648         <PUT ,P-CCTBL ,CC-DBPTR ,P-ACLAUSE>
649         <PUT ,P-CCTBL ,CC-DEPTR <+ ,P-ACLAUSE 1>>
650         <CLAUSE-COPY ,P-ITBL ,P-OTBL>
651         <AND <NOT <EQUAL? <GET ,P-OTBL ,P-NC2> 0>> <SETG P-NCN 2>>
652         <SETG P-ACLAUSE <>>
653         <RTRUE>>
654
655 ;"Print undefined word in input.
656    PTR points to the unknown word in P-LEXV"
657 \f
658 <ROUTINE WORD-PRINT (CNT BUF)
659          <REPEAT ()
660                  <COND (<DLESS? CNT 0> <RETURN>)
661                        (ELSE
662                         <PRINTC <GETB ,P-INBUF .BUF>>
663                         <SET BUF <+ .BUF 1>>)>>>
664
665 <ROUTINE UNKNOWN-WORD (PTR "AUX" BUF)
666         <PUT ,OOPS-TABLE ,O-PTR .PTR>
667         <COND (<VERB? SAY>
668                <TELL "Nothing happens." CR>
669                <RFALSE>)>
670         <TELL "I don't know the word \"">
671         <WORD-PRINT <GETB <REST ,P-LEXV <SET BUF <* .PTR 2>>> 2>
672                     <GETB <REST ,P-LEXV .BUF> 3>>
673         <TELL "\"." CR>
674         <SETG QUOTE-FLAG <>>
675         <SETG P-OFLAG <>>>
676
677 <ROUTINE CANT-USE (PTR "AUX" BUF)
678         <COND (<VERB? SAY>
679                <TELL "Nothing happens." CR>
680                <RFALSE>)>
681         <TELL "You used the word \"">
682         <WORD-PRINT <GETB <REST ,P-LEXV <SET BUF <* .PTR 2>>> 2>
683                     <GETB <REST ,P-LEXV .BUF> 3>>
684         <TELL "\" in a way that I don't understand." CR>
685         <SETG QUOTE-FLAG <>>
686         <SETG P-OFLAG <>>>
687
688 ;" Perform syntax matching operations, using P-ITBL as the source of
689    the verb and adjectives for this input.  Returns false if no
690    syntax matches, and does it's own orphaning.  If return is true,
691    the syntax is saved in P-SYNTAX."
692
693 <GLOBAL P-SLOCBITS 0>
694
695 <CONSTANT P-SYNLEN 8>
696
697 <CONSTANT P-SBITS 0>
698 <CONSTANT P-SPREP1 1>
699 <CONSTANT P-SPREP2 2>
700 <CONSTANT P-SFWIM1 3>
701 <CONSTANT P-SFWIM2 4>
702 <CONSTANT P-SLOC1 5>
703 <CONSTANT P-SLOC2 6>
704 <CONSTANT P-SACTION 7>
705 <CONSTANT P-SONUMS 3>
706
707 <ROUTINE SYNTAX-CHECK ("AUX" SYN LEN NUM OBJ
708                             (DRIVE1 <>) (DRIVE2 <>) PREP VERB TMP)
709         <COND (<ZERO? <SET VERB <GET ,P-ITBL ,P-VERB>>>
710                <TELL "There was no verb in that sentence!" CR>
711                <RFALSE>)>
712         <SET SYN <GET ,VERBS <- 255 .VERB>>>
713         <SET LEN <GETB .SYN 0>>
714         <SET SYN <REST .SYN>>
715         <REPEAT ()
716                 <SET NUM <BAND <GETB .SYN ,P-SBITS> ,P-SONUMS>>
717                 <COND (<G? ,P-NCN .NUM> T)
718                       (<AND <NOT <L? .NUM 1>>
719                             <ZERO? ,P-NCN>
720                             <OR <ZERO? <SET PREP <GET ,P-ITBL ,P-PREP1>>>
721                                 <EQUAL? .PREP <GETB .SYN ,P-SPREP1>>>>
722                        <SET DRIVE1 .SYN>)
723                       (<EQUAL? <GETB .SYN ,P-SPREP1> <GET ,P-ITBL ,P-PREP1>>
724                        <COND (<AND <EQUAL? .NUM 2> <EQUAL? ,P-NCN 1>>
725                               <SET DRIVE2 .SYN>)
726                              (<EQUAL? <GETB .SYN ,P-SPREP2>
727                                    <GET ,P-ITBL ,P-PREP2>>
728                               <SYNTAX-FOUND .SYN>
729                               <RTRUE>)>)>
730                 <COND (<DLESS? LEN 1>
731                        <COND (<OR .DRIVE1 .DRIVE2> <RETURN>)
732                              (T
733                               <TELL
734 "That sentence isn't one I recognize." CR>
735                               <RFALSE>)>)
736                       (T <SET SYN <REST .SYN ,P-SYNLEN>>)>>
737         <COND (<AND .DRIVE1
738                     <SET OBJ
739                          <GWIM <GETB .DRIVE1 ,P-SFWIM1>
740                                <GETB .DRIVE1 ,P-SLOC1>
741                                <GETB .DRIVE1 ,P-SPREP1>>>>
742                <PUT ,P-PRSO ,P-MATCHLEN 1>
743                <PUT ,P-PRSO 1 .OBJ>
744                <SYNTAX-FOUND .DRIVE1>)
745               (<AND .DRIVE2
746                     <SET OBJ
747                          <GWIM <GETB .DRIVE2 ,P-SFWIM2>
748                                <GETB .DRIVE2 ,P-SLOC2>
749                                <GETB .DRIVE2 ,P-SPREP2>>>>
750                <PUT ,P-PRSI ,P-MATCHLEN 1>
751                <PUT ,P-PRSI 1 .OBJ>
752                <SYNTAX-FOUND .DRIVE2>)
753               (<EQUAL? .VERB ,ACT?FIND>
754                <TELL "That question can't be answered." CR>
755                <RFALSE>)
756               (<NOT <EQUAL? ,WINNER ,PLAYER>>
757                <CANT-ORPHAN>)
758               (T
759                <ORPHAN .DRIVE1 .DRIVE2>
760                <TELL "What do you want to ">
761                <SET TMP <GET ,P-OTBL ,P-VERBN>>
762                <COND (<EQUAL? .TMP 0> <TELL "tell">)
763                      (<ZERO? <GETB ,P-VTBL 2>>
764                       <PRINTB <GET .TMP 0>>)
765                      (T
766                       <WORD-PRINT <GETB .TMP 2> <GETB .TMP 3>>
767                       <PUTB ,P-VTBL 2 0>)>
768                <COND (.DRIVE2
769                       <TELL " ">
770                       <THING-PRINT T T>)>
771                <SETG P-OFLAG T>
772                <PREP-PRINT <COND (.DRIVE1 <GETB .DRIVE1 ,P-SPREP1>)
773                                  (T <GETB .DRIVE2 ,P-SPREP2>)>>
774                <TELL "?" CR>
775                <RFALSE>)>>
776
777 <ROUTINE CANT-ORPHAN ()
778          <TELL "\"I don't understand! What are you referring to?\"" CR>
779          <RFALSE>>
780
781 \f
782 <ROUTINE ORPHAN (D1 D2 "AUX" (CNT -1))
783         <COND (<NOT ,P-MERGED>
784                <PUT ,P-OCLAUSE ,P-MATCHLEN 0>)>
785         <PUT ,P-OVTBL 0 <GET ,P-VTBL 0>>
786         <PUTB ,P-OVTBL 2 <GETB ,P-VTBL 2>>
787         <PUTB ,P-OVTBL 3 <GETB ,P-VTBL 3>>
788         <REPEAT ()
789                 <COND (<IGRTR? CNT ,P-ITBLLEN> <RETURN>)
790                       (T <PUT ,P-OTBL .CNT <GET ,P-ITBL .CNT>>)>>
791         <COND (<EQUAL? ,P-NCN 2>
792                <PUT ,P-CCTBL ,CC-SBPTR ,P-NC2>
793                <PUT ,P-CCTBL ,CC-SEPTR ,P-NC2L>
794                <PUT ,P-CCTBL ,CC-DBPTR ,P-NC2>
795                <PUT ,P-CCTBL ,CC-DEPTR ,P-NC2L>
796                <CLAUSE-COPY ,P-ITBL ,P-OTBL>)>
797         <COND (<NOT <L? ,P-NCN 1>>
798                <PUT ,P-CCTBL ,CC-SBPTR ,P-NC1>
799                <PUT ,P-CCTBL ,CC-SEPTR ,P-NC1L>
800                <PUT ,P-CCTBL ,CC-DBPTR ,P-NC1>
801                <PUT ,P-CCTBL ,CC-DEPTR ,P-NC1L>
802                <CLAUSE-COPY ,P-ITBL ,P-OTBL>)>
803         <COND (.D1
804                <PUT ,P-OTBL ,P-PREP1 <GETB .D1 ,P-SPREP1>>
805                <PUT ,P-OTBL ,P-NC1 1>)
806               (.D2
807                <PUT ,P-OTBL ,P-PREP2 <GETB .D2 ,P-SPREP2>>
808                <PUT ,P-OTBL ,P-NC2 1>)>>
809
810 ;<ROUTINE CLAUSE-PRINT (BPTR EPTR "OPTIONAL" (THE? T))
811         <BUFFER-PRINT <GET ,P-ITBL .BPTR> <GET ,P-ITBL .EPTR> .THE?>>
812
813 <ROUTINE THING-PRINT (PRSO? "OPTIONAL" (THE? <>) "AUX" BEG END)
814          <COND (.PRSO?
815                 <SET BEG <GET ,P-ITBL ,P-NC1>>
816                 <SET END <GET ,P-ITBL ,P-NC1L>>)
817                (ELSE
818                 <SET BEG <GET ,P-ITBL ,P-NC2>>
819                 <SET END <GET ,P-ITBL ,P-NC2L>>)>
820          <BUFFER-PRINT .BEG .END .THE?>>
821
822 <ROUTINE BUFFER-PRINT (BEG END CP
823                        "AUX" (NOSP T) WRD (FIRST?? T) (PN <>) (Q? <>))
824          <REPEAT ()
825                 <COND (<EQUAL? .BEG .END> <RETURN>)
826                       (T
827                        <SET WRD <GET .BEG 0>>
828                        <COND ;(<EQUAL? .WRD ,W?$BUZZ> T)
829                              (<EQUAL? .WRD ,W?COMMA>
830                               <TELL ", ">)
831                              (.NOSP <SET NOSP <>>)
832                              (ELSE <TELL " ">)>
833                        <COND (<EQUAL? .WRD ,W?PERIOD ,W?COMMA>
834                               <SET NOSP T>)
835                              (<EQUAL? .WRD ,W?ME>
836                               <PRINTD ,ME>
837                               <SET PN T>)
838                              (<EQUAL? .WRD ,W?INTNUM>
839                               <PRINTN ,P-NUMBER>
840                               <SET PN T>)
841                              (T
842                               <COND (<AND .FIRST?? <NOT .PN> .CP>
843                                      <TELL "the ">)>
844                               <COND (<OR ,P-OFLAG ,P-MERGED> <PRINTB .WRD>)
845                                     (<AND <EQUAL? .WRD ,W?IT>
846                                           <ACCESSIBLE? ,P-IT-OBJECT>>
847                                      <PRINTD ,P-IT-OBJECT>)
848                                     (T
849                                      <WORD-PRINT <GETB .BEG 2>
850                                                  <GETB .BEG 3>>)>
851                               <SET FIRST?? <>>)>)>
852                 <SET BEG <REST .BEG ,P-WORDLEN>>>>
853
854 <ROUTINE PREP-PRINT (PREP "AUX" WRD)
855         <COND (<NOT <ZERO? .PREP>>
856                <TELL " ">
857                <COND ;(<EQUAL? .PREP ,PR?THROUGH>
858                       <TELL "through">)
859                      (T
860                       <SET WRD <PREP-FIND .PREP>>
861                       <PRINTB .WRD>)>)>>
862
863 <ROUTINE CLAUSE-COPY (SRC DEST "OPTIONAL" (INSRT <>) "AUX" BEG END)
864         <SET BEG <GET .SRC <GET ,P-CCTBL ,CC-SBPTR>>>
865         <SET END <GET .SRC <GET ,P-CCTBL ,CC-SEPTR>>>
866         <PUT .DEST
867              <GET ,P-CCTBL ,CC-DBPTR>
868              <REST ,P-OCLAUSE
869                    <+ <* <GET ,P-OCLAUSE ,P-MATCHLEN> ,P-LEXELEN> 2>>>
870         <REPEAT ()
871                 <COND (<EQUAL? .BEG .END>
872                        <PUT .DEST
873                             <GET ,P-CCTBL ,CC-DEPTR>
874                             <REST ,P-OCLAUSE
875                                   <+ <* <GET ,P-OCLAUSE ,P-MATCHLEN> ,P-LEXELEN>
876                                      2>>>
877                        <RETURN>)
878                       (T
879                        <COND (<AND .INSRT <EQUAL? ,P-ANAM <GET .BEG 0>>>
880                               <CLAUSE-ADD .INSRT>)>
881                        <CLAUSE-ADD <GET .BEG 0>>)>
882                 <SET BEG <REST .BEG ,P-WORDLEN>>>>
883
884 \f
885 <ROUTINE CLAUSE-ADD (WRD "AUX" PTR)
886         <SET PTR <+ <GET ,P-OCLAUSE ,P-MATCHLEN> 2>>
887         <PUT ,P-OCLAUSE <- .PTR 1> .WRD>
888         <PUT ,P-OCLAUSE .PTR 0>
889         <PUT ,P-OCLAUSE ,P-MATCHLEN .PTR>>
890
891 <ROUTINE PREP-FIND (PREP "AUX" (CNT 0) SIZE)
892         <SET SIZE <* <GET ,PREPOSITIONS 0> 2>>
893         <REPEAT ()
894                 <COND (<IGRTR? CNT .SIZE> <RFALSE>)
895                       (<EQUAL? <GET ,PREPOSITIONS .CNT> .PREP>
896                        <RETURN <GET ,PREPOSITIONS <- .CNT 1>>>)>>>
897
898 <ROUTINE SYNTAX-FOUND (SYN)
899         <SETG P-SYNTAX .SYN>
900         <SETG PRSA <GETB .SYN ,P-SACTION>>>
901
902 <GLOBAL P-GWIMBIT 0>
903
904 <ROUTINE GWIM (GBIT LBIT PREP "AUX" OBJ)
905         <COND (<EQUAL? .GBIT ,RMUNGBIT>
906                <RETURN ,ROOMS>)>
907         <SETG P-GWIMBIT .GBIT>
908         <SETG P-SLOCBITS .LBIT>
909         <PUT ,P-MERGE ,P-MATCHLEN 0>
910         <COND (<GET-OBJECT ,P-MERGE <>>
911                <SETG P-GWIMBIT 0>
912                <COND (<EQUAL? <GET ,P-MERGE ,P-MATCHLEN> 1>
913                       <SET OBJ <GET ,P-MERGE 1>>
914                       <TELL "(">
915                       <COND (<AND <NOT <ZERO? .PREP>>
916                                   <NOT ,P-END-ON-PREP>>
917                              <PRINTB <SET PREP <PREP-FIND .PREP>>>
918                              <COND (<EQUAL? .PREP ,W?OUT>
919                                     <TELL " of">)>
920                              <TELL " ">
921                              <COND (<EQUAL? .OBJ ,HANDS>
922                                     <TELL "your hands">)
923                                    (T
924                                     <TELL "the " D .OBJ>)>
925                              <TELL ")" CR>)
926                             (ELSE
927                              <TELL D .OBJ ")" CR>)>
928                       .OBJ)>)
929               (T <SETG P-GWIMBIT 0> <RFALSE>)>>
930
931 <ROUTINE SNARF-OBJECTS ("AUX" OPTR IPTR L)
932          <PUT ,P-BUTS ,P-MATCHLEN 0>
933          <COND (<NOT <EQUAL? <SET IPTR <GET ,P-ITBL ,P-NC2>> 0>>
934                 <SETG P-SLOCBITS <GETB ,P-SYNTAX ,P-SLOC2>>
935                 <OR <SNARFEM .IPTR <GET ,P-ITBL ,P-NC2L> ,P-PRSI> <RFALSE>>)>
936          <COND (<NOT <EQUAL? <SET OPTR <GET ,P-ITBL ,P-NC1>> 0>>
937                 <SETG P-SLOCBITS <GETB ,P-SYNTAX ,P-SLOC1>>
938                 <OR <SNARFEM .OPTR <GET ,P-ITBL ,P-NC1L> ,P-PRSO> <RFALSE>>)>
939          <COND (<NOT <ZERO? <GET ,P-BUTS ,P-MATCHLEN>>>
940                 <SET L <GET ,P-PRSO ,P-MATCHLEN>>
941                 <COND (.OPTR <SETG P-PRSO <BUT-MERGE ,P-PRSO>>)>
942                 <COND (<AND .IPTR
943                             <OR <NOT .OPTR>
944                                 <EQUAL? .L <GET ,P-PRSO ,P-MATCHLEN>>>>
945                        <SETG P-PRSI <BUT-MERGE ,P-PRSI>>)>)>
946          <RTRUE>>
947 \f
948 <ROUTINE BUT-MERGE (TBL "AUX" LEN BUTLEN (CNT 1) (MATCHES 0) OBJ NTBL)
949         <SET LEN <GET .TBL ,P-MATCHLEN>>
950         <PUT ,P-MERGE ,P-MATCHLEN 0>
951         <REPEAT ()
952                 <COND (<DLESS? LEN 0> <RETURN>)
953                       (<ZMEMQ <SET OBJ <GET .TBL .CNT>> ,P-BUTS>)
954                       (T
955                        <PUT ,P-MERGE <+ .MATCHES 1> .OBJ>
956                        <SET MATCHES <+ .MATCHES 1>>)>
957                 <SET CNT <+ .CNT 1>>>
958         <PUT ,P-MERGE ,P-MATCHLEN .MATCHES>
959         <SET NTBL ,P-MERGE>
960         <SETG P-MERGE .TBL>
961         .NTBL>
962
963 <GLOBAL P-NAM <>>
964 <GLOBAL P-ADJ <>>
965 <GLOBAL P-ADVERB <>>
966 <GLOBAL P-ADJN <>>
967 <GLOBAL P-PRSO <ITABLE NONE 50>>
968 <GLOBAL P-PRSI <ITABLE NONE 50>>
969 <GLOBAL P-BUTS <ITABLE NONE 50>>
970 <GLOBAL P-MERGE <ITABLE NONE 50>>
971 <GLOBAL P-OCLAUSE <ITABLE NONE 100>>
972 <GLOBAL P-MATCHLEN 0>
973 <GLOBAL P-GETFLAGS 0>
974 <CONSTANT P-ALL 1>
975 <CONSTANT P-ONE 2>
976 <CONSTANT P-INHIBIT 4>
977 \f
978
979 <GLOBAL P-AND <>>
980
981 <ROUTINE SNARFEM (PTR EPTR TBL "AUX" (BUT <>) LEN WV WRD NW (WAS-ALL <>))
982    <SETG P-AND <>>
983    <COND (<EQUAL? ,P-GETFLAGS ,P-ALL>
984           <SET WAS-ALL T>)>
985    <SETG P-GETFLAGS 0>
986    <PUT .TBL ,P-MATCHLEN 0>
987    <SET WRD <GET .PTR 0>>
988    <REPEAT ()
989            <COND (<EQUAL? .PTR .EPTR>
990                   <SET WV <GET-OBJECT <OR .BUT .TBL>>>
991                   <COND (.WAS-ALL <SETG P-GETFLAGS ,P-ALL>)>
992                   <RETURN .WV>)
993                  (T
994                   <COND (<==? .EPTR <REST .PTR ,P-WORDLEN>>
995                          <SET NW 0>)
996                         (T <SET NW <GET .PTR ,P-LEXELEN>>)>
997                   <COND (<EQUAL? .WRD ,W?ALL ;,W?BOTH>
998                          <SETG P-GETFLAGS ,P-ALL>
999                          <COND (<EQUAL? .NW ,W?OF>
1000                                 <SET PTR <REST .PTR ,P-WORDLEN>>)>)
1001                         (<EQUAL? .WRD ,W?BUT ,W?EXCEPT>
1002                          <OR <GET-OBJECT <OR .BUT .TBL>> <RFALSE>>
1003                          <SET BUT ,P-BUTS>
1004                          <PUT .BUT ,P-MATCHLEN 0>)
1005                         (<EQUAL? .WRD ,W?A ,W?ONE>
1006                          <COND (<NOT ,P-ADJ>
1007                                 <SETG P-GETFLAGS ,P-ONE>
1008                                 <COND (<EQUAL? .NW ,W?OF>
1009                                        <SET PTR <REST .PTR ,P-WORDLEN>>)>)
1010                                (T
1011                                 <SETG P-NAM ,P-ONEOBJ>
1012                                 <OR <GET-OBJECT <OR .BUT .TBL>> <RFALSE>>
1013                                 <AND <ZERO? .NW> <RTRUE>>)>)
1014                         (<AND <EQUAL? .WRD ,W?AND ,W?COMMA>
1015                               <NOT <EQUAL? .NW ,W?AND ,W?COMMA>>>
1016                          <SETG P-AND T>
1017                          <OR <GET-OBJECT <OR .BUT .TBL>> <RFALSE>>
1018                          T)
1019                         (<WT? .WRD ,PS?BUZZ-WORD>)
1020                         (<EQUAL? .WRD ,W?AND ,W?COMMA>)
1021                         (<EQUAL? .WRD ,W?OF>
1022                          <COND (<ZERO? ,P-GETFLAGS>
1023                                 <SETG P-GETFLAGS ,P-INHIBIT>)>)
1024                         (<AND <SET WV <WT? .WRD ,PS?ADJECTIVE ,P1?ADJECTIVE>>
1025                               <NOT ,P-ADJ>>
1026                          <SETG P-ADJ .WV>
1027                          <SETG P-ADJN .WRD>)
1028                         (<WT? .WRD ,PS?OBJECT ,P1?OBJECT>
1029                          <SETG P-NAM .WRD>
1030                          <SETG P-ONEOBJ .WRD>)>)>
1031            <COND (<NOT <EQUAL? .PTR .EPTR>>
1032                   <SET PTR <REST .PTR ,P-WORDLEN>>
1033                   <SET WRD .NW>)>>>
1034
1035 <CONSTANT SH 128>
1036 <CONSTANT SC 64>
1037 <CONSTANT SIR 32>
1038 <CONSTANT SOG 16>
1039 <CONSTANT STAKE 8>
1040 <CONSTANT SMANY 4>
1041 <CONSTANT SHAVE 2>
1042
1043 <ROUTINE GET-OBJECT (TBL
1044                      "OPTIONAL" (VRB T)
1045                      "AUX" BITS LEN XBITS TLEN (GCHECK <>) (OLEN 0) OBJ)
1046          <SET XBITS ,P-SLOCBITS>
1047          <SET TLEN <GET .TBL ,P-MATCHLEN>>
1048          <COND (<BTST ,P-GETFLAGS ,P-INHIBIT> <RTRUE>)>
1049          <COND (<AND <NOT ,P-NAM> ,P-ADJ>
1050                 <COND (<WT? ,P-ADJN ,PS?OBJECT ,P1?OBJECT>
1051                        <SETG P-NAM ,P-ADJN>
1052                        <SETG P-ADJ <>>)
1053                       %<COND (<==? ,ZORK-NUMBER 3>
1054                               '(<SET BITS
1055                                      <WT? ,P-ADJN
1056                                           ,PS?DIRECTION ,P1?DIRECTION>>
1057                                 <SETG P-ADJ <>>
1058                                 <PUT .TBL ,P-MATCHLEN 1>
1059                                 <PUT .TBL 1 ,INTDIR>
1060                                 <SETG P-DIRECTION .BITS>
1061                                 <RTRUE>))
1062                              (ELSE '(<NULL-F> T))>>)>
1063          <COND (<AND <NOT ,P-NAM>
1064                      <NOT ,P-ADJ>
1065                      <NOT <EQUAL? ,P-GETFLAGS ,P-ALL>>
1066                      <ZERO? ,P-GWIMBIT>>
1067                 <COND (.VRB
1068                        <TELL
1069 "There seems to be a noun missing in that sentence!" CR>)>
1070                 <RFALSE>)>
1071          <COND (<OR <NOT <EQUAL? ,P-GETFLAGS ,P-ALL>> <ZERO? ,P-SLOCBITS>>
1072                 <SETG P-SLOCBITS -1>)>
1073          <SETG P-TABLE .TBL>
1074          <PROG ()
1075                <COND (.GCHECK <GLOBAL-CHECK .TBL>)
1076                      (T
1077                       <COND (,LIT
1078                              <FCLEAR ,PLAYER ,TRANSBIT>
1079                              <DO-SL ,HERE ,SOG ,SIR>
1080                              <FSET ,PLAYER ,TRANSBIT>)>
1081                       <DO-SL ,PLAYER ,SH ,SC>)>
1082                <SET LEN <- <GET .TBL ,P-MATCHLEN> .TLEN>>
1083                <COND (<BTST ,P-GETFLAGS ,P-ALL>)
1084                      (<AND <BTST ,P-GETFLAGS ,P-ONE>
1085                            <NOT <ZERO? .LEN>>>
1086                       <COND (<NOT <EQUAL? .LEN 1>>
1087                              <PUT .TBL 1 <GET .TBL <RANDOM .LEN>>>
1088                              <TELL "(How about the ">
1089                              <PRINTD <GET .TBL 1>>
1090                              <TELL "?)" CR>)>
1091                       <PUT .TBL ,P-MATCHLEN 1>)
1092                      (<OR <G? .LEN 1>
1093                           <AND <ZERO? .LEN> <NOT <EQUAL? ,P-SLOCBITS -1>>>>
1094                       <COND (<EQUAL? ,P-SLOCBITS -1>
1095                              <SETG P-SLOCBITS .XBITS>
1096                              <SET OLEN .LEN>
1097                              <PUT .TBL
1098                                   ,P-MATCHLEN
1099                                   <- <GET .TBL ,P-MATCHLEN> .LEN>>
1100                              <AGAIN>)
1101                             (T
1102                              <COND (<ZERO? .LEN> <SET LEN .OLEN>)>
1103                              <COND (<NOT <EQUAL? ,WINNER ,PLAYER>>
1104                                     <CANT-ORPHAN>
1105                                     <RFALSE>)
1106                                    (<AND .VRB ,P-NAM>
1107                                     <WHICH-PRINT .TLEN .LEN .TBL>
1108                                     <SETG P-ACLAUSE
1109                                           <COND (<EQUAL? .TBL ,P-PRSO> ,P-NC1)
1110                                                 (T ,P-NC2)>>
1111                                     <SETG P-AADJ ,P-ADJ>
1112                                     <SETG P-ANAM ,P-NAM>
1113                                     <ORPHAN <> <>>
1114                                     <SETG P-OFLAG T>)
1115                                    (.VRB
1116                                     <TELL
1117 "There seems to be a noun missing in that sentence!" CR>)>
1118                              <SETG P-NAM <>>
1119                              <SETG P-ADJ <>>
1120                              <RFALSE>)>)>
1121                <COND (<AND <ZERO? .LEN> .GCHECK>
1122                       <COND (.VRB
1123                              ;"next added 1/2/85 by JW"
1124                              <SETG P-SLOCBITS .XBITS>
1125                              <COND (<OR ,LIT <VERB? TELL ;WHERE ;WHAT ;WHO>>
1126                                     ;"Changed 6/10/83 - MARC"
1127                                     <OBJ-FOUND ,NOT-HERE-OBJECT .TBL>
1128                                     <SETG P-XNAM ,P-NAM>
1129                                     <SETG P-XADJ ,P-ADJ>
1130                                     <SETG P-XADJN ,P-ADJN>
1131                                     <SETG P-NAM <>>
1132                                     <SETG P-ADJ <>>
1133                                     <SETG P-ADJN <>>
1134                                     <RTRUE>)
1135                                    (T <TELL "It's too dark to see!" CR>)>)>
1136                       <SETG P-NAM <>>
1137                       <SETG P-ADJ <>>
1138                       <RFALSE>)
1139                      (<ZERO? .LEN> <SET GCHECK T> <AGAIN>)>
1140                <SETG P-SLOCBITS .XBITS>
1141                <SETG P-NAM <>>
1142                <SETG P-ADJ <>>
1143                <RTRUE>>>
1144
1145 ;<ROUTINE MOBY-FIND (TBL "AUX" FOO LEN)
1146          <SETG P-SLOCBITS -1>
1147          <SETG P-NAM ,P-XNAM>
1148          <SETG P-ADJ ,P-XADJ>
1149          <PUT .TBL ,P-MATCHLEN 0>
1150          <SET FOO <FIRST? ,ROOMS>>
1151          <REPEAT ()
1152                  <COND (<NOT .FOO> <RETURN>)
1153                        (T
1154                         <SEARCH-LIST .FOO .TBL ,P-SRCALL>
1155                         <SET FOO <NEXT? .FOO>>)>>
1156          <COND (<EQUAL? <SET LEN <GET .TBL ,P-MATCHLEN>> 0>
1157                 <DO-SL ,LOCAL-GLOBALS 1 1>)>
1158          <COND (<EQUAL? <SET LEN <GET .TBL ,P-MATCHLEN>> 0>
1159                 <DO-SL ,ROOMS 1 1>)>
1160          <COND (<EQUAL? <SET LEN <GET .TBL ,P-MATCHLEN>> 1>
1161                 <SETG P-MOBY-FOUND <GET .TBL 1>>)>
1162          <SETG P-NAM <>>
1163          <SETG P-ADJ <>>
1164          .LEN>
1165
1166 ;<GLOBAL P-MOBY-FOUND <>>
1167 <GLOBAL P-XNAM <>>
1168 <GLOBAL P-XADJ <>>
1169 <GLOBAL P-XADJN <>>
1170
1171 <ROUTINE WHICH-PRINT (TLEN LEN TBL "AUX" OBJ RLEN)
1172          <SET RLEN .LEN>
1173          <TELL "Which ">
1174          <COND (<OR ,P-OFLAG ,P-MERGED ,P-AND>
1175                 <PRINTB <COND (,P-NAM ,P-NAM)
1176                               (,P-ADJ ,P-ADJN)
1177                               (ELSE ,W?ONE)>>)
1178                (ELSE
1179                 <THING-PRINT <EQUAL? .TBL ,P-PRSO>>)>
1180          <TELL " do you mean, ">
1181          <REPEAT ()
1182                  <SET TLEN <+ .TLEN 1>>
1183                  <SET OBJ <GET .TBL .TLEN>>
1184                  <TELL "the " D .OBJ>
1185                  <COND (<EQUAL? .LEN 2>
1186                         <COND (<NOT <EQUAL? .RLEN 2>> <TELL ",">)>
1187                         <TELL " or ">)
1188                        (<G? .LEN 2> <TELL ", ">)>
1189                  <COND (<L? <SET LEN <- .LEN 1>> 1>
1190                         <TELL "?" CR>
1191                         <RETURN>)>>>
1192
1193 \f
1194 <ROUTINE GLOBAL-CHECK (TBL "AUX" LEN RMG RMGL (CNT 0) OBJ OBITS FOO)
1195         <SET LEN <GET .TBL ,P-MATCHLEN>>
1196         <SET OBITS ,P-SLOCBITS>
1197         <COND (<SET RMG <GETPT ,HERE ,P?GLOBAL>>
1198                <SET RMGL <- <PTSIZE .RMG> 1>>
1199                <REPEAT ()
1200                        <COND (<THIS-IT? <SET OBJ <GETB .RMG .CNT>> .TBL>
1201                               <OBJ-FOUND .OBJ .TBL>)>
1202                        <COND (<IGRTR? CNT .RMGL> <RETURN>)>>)>
1203         <COND (<SET RMG <GETPT ,HERE ,P?PSEUDO>>
1204                <SET RMGL <- </ <PTSIZE .RMG> 4> 1>>
1205                <SET CNT 0>
1206                <REPEAT ()
1207                        <COND (<EQUAL? ,P-NAM <GET .RMG <* .CNT 2>>>
1208                               <PUTP ,PSEUDO-OBJECT
1209                                     ,P?ACTION
1210                                     <GET .RMG <+ <* .CNT 2> 1>>>
1211                               <SET FOO
1212                                    <BACK <GETPT ,PSEUDO-OBJECT ,P?ACTION> 5>>
1213                               <PUT .FOO 0 <GET ,P-NAM 0>>
1214                               <PUT .FOO 1 <GET ,P-NAM 1>>
1215                               <OBJ-FOUND ,PSEUDO-OBJECT .TBL>
1216                               <RETURN>)
1217                              (<IGRTR? CNT .RMGL> <RETURN>)>>)>
1218         <COND (<EQUAL? <GET .TBL ,P-MATCHLEN> .LEN>
1219                <SETG P-SLOCBITS -1>
1220                <SETG P-TABLE .TBL>
1221                <DO-SL ,GLOBAL-OBJECTS 1 1>
1222                <SETG P-SLOCBITS .OBITS>
1223                <COND (<AND <ZERO? <GET .TBL ,P-MATCHLEN>>
1224                            <EQUAL? ,PRSA ,V?LOOK-INSIDE ,V?SEARCH ,V?EXAMINE>>
1225                       <DO-SL ,ROOMS 1 1>)>)>>
1226
1227 <ROUTINE DO-SL (OBJ BIT1 BIT2 "AUX" BTS)
1228         <COND (<BTST ,P-SLOCBITS <+ .BIT1 .BIT2>>
1229                <SEARCH-LIST .OBJ ,P-TABLE ,P-SRCALL>)
1230               (T
1231                <COND (<BTST ,P-SLOCBITS .BIT1>
1232                       <SEARCH-LIST .OBJ ,P-TABLE ,P-SRCTOP>)
1233                      (<BTST ,P-SLOCBITS .BIT2>
1234                       <SEARCH-LIST .OBJ ,P-TABLE ,P-SRCBOT>)
1235                      (T <RTRUE>)>)>>
1236
1237 <CONSTANT P-SRCBOT 2>
1238 <CONSTANT P-SRCTOP 0>
1239 <CONSTANT P-SRCALL 1>
1240
1241 <ROUTINE SEARCH-LIST (OBJ TBL LVL "AUX" FLS NOBJ)
1242         <COND (<SET OBJ <FIRST? .OBJ>>
1243                <REPEAT ()
1244                        <COND (<AND <NOT <EQUAL? .LVL ,P-SRCBOT>>
1245                                    <GETPT .OBJ ,P?SYNONYM>
1246                                    <THIS-IT? .OBJ .TBL>>
1247                               <OBJ-FOUND .OBJ .TBL>)>
1248                        <COND (<AND <OR <NOT <EQUAL? .LVL ,P-SRCTOP>>
1249                                        <FSET? .OBJ ,SEARCHBIT>
1250                                        <FSET? .OBJ ,SURFACEBIT>>
1251                                    <SET NOBJ <FIRST? .OBJ>>
1252                                    <OR <FSET? .OBJ ,OPENBIT>
1253                                        <FSET? .OBJ ,TRANSBIT>>>
1254                               <SET FLS
1255                                    <SEARCH-LIST .OBJ
1256                                                 .TBL
1257                                                 <COND (<FSET? .OBJ ,SURFACEBIT>
1258                                                        ,P-SRCALL)
1259                                                       (<FSET? .OBJ ,SEARCHBIT>
1260                                                        ,P-SRCALL)
1261                                                       (T ,P-SRCTOP)>>>)>
1262                        <COND (<SET OBJ <NEXT? .OBJ>>) (T <RETURN>)>>)>>
1263
1264 <ROUTINE OBJ-FOUND (OBJ TBL "AUX" PTR)
1265         <SET PTR <GET .TBL ,P-MATCHLEN>>
1266         <PUT .TBL <+ .PTR 1> .OBJ>
1267         <PUT .TBL ,P-MATCHLEN <+ .PTR 1>>>
1268
1269 <ROUTINE TAKE-CHECK ()
1270         <AND <ITAKE-CHECK ,P-PRSO <GETB ,P-SYNTAX ,P-SLOC1>>
1271              <ITAKE-CHECK ,P-PRSI <GETB ,P-SYNTAX ,P-SLOC2>>>>
1272 \f
1273 <ROUTINE ITAKE-CHECK (TBL IBITS "AUX" PTR OBJ TAKEN)
1274          #DECL ((TBL) TABLE (IBITS PTR) FIX (OBJ) OBJECT
1275                 (TAKEN) <OR FALSE FIX ATOM>)
1276          <COND (<AND <SET PTR <GET .TBL ,P-MATCHLEN>>
1277                      <OR <BTST .IBITS ,SHAVE>
1278                          <BTST .IBITS ,STAKE>>>
1279                 <REPEAT ()
1280                         <COND (<L? <SET PTR <- .PTR 1>> 0> <RETURN>)
1281                               (T
1282                                <SET OBJ <GET .TBL <+ .PTR 1>>>
1283                                <COND (<EQUAL? .OBJ ,IT>
1284                                       <COND (<NOT <ACCESSIBLE? ,P-IT-OBJECT>>
1285                                              <TELL
1286 "I don't see what you're referring to." CR>
1287                                              <RFALSE>)
1288                                             (T
1289                                              <SET OBJ ,P-IT-OBJECT>)>)>
1290                                <COND (<AND <NOT <HELD? .OBJ>>
1291                                            <NOT <EQUAL? .OBJ ,HANDS ,ME>>>
1292                                       <SETG PRSO .OBJ>
1293                                       <COND (<FSET? .OBJ ,TRYTAKEBIT>
1294                                              <SET TAKEN T>)
1295                                             (<NOT <EQUAL? ,WINNER ,ADVENTURER>>
1296                                              <SET TAKEN <>>)
1297                                             (<AND <BTST .IBITS ,STAKE>
1298                                                   <EQUAL? <ITAKE <>> T>>
1299                                              <SET TAKEN <>>)
1300                                             (T <SET TAKEN T>)>
1301                                       <COND (<AND .TAKEN
1302                                                   <BTST .IBITS ,SHAVE>
1303                                                   <EQUAL? ,WINNER
1304                                                           ,ADVENTURER>>
1305                                              <COND (<EQUAL? .OBJ
1306                                                             ,NOT-HERE-OBJECT>
1307                                                     <TELL
1308 "You don't have that!" CR>
1309                                                     <RFALSE>)>
1310                                              <TELL "You don't have the ">
1311                                              <PRINTD .OBJ>
1312                                              <TELL "." CR>
1313                                              <RFALSE>)
1314                                             (<AND <NOT .TAKEN>
1315                                                   <EQUAL? ,WINNER ,ADVENTURER>>
1316                                              <TELL "(Taken)" CR>)>)>)>>)
1317                (T)>>
1318
1319 <ROUTINE MANY-CHECK ("AUX" (LOSS <>) TMP)
1320         <COND (<AND <G? <GET ,P-PRSO ,P-MATCHLEN> 1>
1321                     <NOT <BTST <GETB ,P-SYNTAX ,P-SLOC1> ,SMANY>>>
1322                <SET LOSS 1>)
1323               (<AND <G? <GET ,P-PRSI ,P-MATCHLEN> 1>
1324                     <NOT <BTST <GETB ,P-SYNTAX ,P-SLOC2> ,SMANY>>>
1325                <SET LOSS 2>)>
1326         <COND (.LOSS
1327                <TELL "You can't use multiple ">
1328                <COND (<EQUAL? .LOSS 2> <TELL "in">)>
1329                <TELL "direct objects with \"">
1330                <SET TMP <GET ,P-ITBL ,P-VERBN>>
1331                <COND (<ZERO? .TMP> <TELL "tell">)
1332                      (<OR ,P-OFLAG ,P-MERGED>
1333                       <PRINTB <GET .TMP 0>>)
1334                      (T
1335                       <WORD-PRINT <GETB .TMP 2> <GETB .TMP 3>>)>
1336                <TELL "\"." CR>
1337                <RFALSE>)
1338               (T)>>
1339
1340 <ROUTINE ZMEMQ (ITM TBL "OPTIONAL" (SIZE -1) "AUX" (CNT 1))
1341         <COND (<NOT .TBL> <RFALSE>)>
1342         <COND (<NOT <L? .SIZE 0>> <SET CNT 0>)
1343               (ELSE <SET SIZE <GET .TBL 0>>)>
1344         <REPEAT ()
1345                 <COND (<EQUAL? .ITM <GET .TBL .CNT>>
1346                        <RETURN <REST .TBL <* .CNT 2>>>)
1347                       (<IGRTR? CNT .SIZE> <RFALSE>)>>>
1348 \f
1349 <ROUTINE ZMEMQB (ITM TBL SIZE "AUX" (CNT 0))
1350         <REPEAT ()
1351                 <COND (<EQUAL? .ITM <GETB .TBL .CNT>>
1352                        <RTRUE>)
1353                       (<IGRTR? CNT .SIZE>
1354                        <RFALSE>)>>>
1355
1356 <GLOBAL ALWAYS-LIT <>>
1357
1358 <ROUTINE LIT? (RM "OPTIONAL" (RMBIT T) "AUX" OHERE (LIT <>))
1359         <COND (<AND ,ALWAYS-LIT <EQUAL? ,WINNER ,PLAYER>>
1360                <RTRUE>)>
1361         <SETG P-GWIMBIT ,ONBIT>
1362         <SET OHERE ,HERE>
1363         <SETG HERE .RM>
1364         <COND (<AND .RMBIT
1365                     <FSET? .RM ,ONBIT>>
1366                <SET LIT T>)
1367               (T
1368                <PUT ,P-MERGE ,P-MATCHLEN 0>
1369                <SETG P-TABLE ,P-MERGE>
1370                <SETG P-SLOCBITS -1>
1371                <COND (<EQUAL? .OHERE .RM>
1372                       <DO-SL ,WINNER 1 1>
1373                       <COND (<AND <NOT <EQUAL? ,WINNER ,PLAYER>>
1374                                   <IN? ,PLAYER .RM>>
1375                              <DO-SL ,PLAYER 1 1>)>)>
1376                <DO-SL .RM 1 1>
1377                <COND (<G? <GET ,P-TABLE ,P-MATCHLEN> 0> <SET LIT T>)>)>
1378         <SETG HERE .OHERE>
1379         <SETG P-GWIMBIT 0>
1380         .LIT>
1381
1382 ;<ROUTINE PRSO-PRINT ("AUX" PTR)
1383          <COND (<OR ,P-MERGED
1384                     <EQUAL? <GET <SET PTR <GET ,P-ITBL ,P-NC1>> 0> ,W?IT>>
1385                 <TELL " " D ,PRSO>)
1386                (T <BUFFER-PRINT .PTR <GET ,P-ITBL ,P-NC1L> <>>)>>
1387
1388 ;<ROUTINE PRSI-PRINT ("AUX" PTR)
1389          <COND (<OR ,P-MERGED
1390                     <EQUAL? <GET <SET PTR <GET ,P-ITBL ,P-NC2>> 0> ,W?IT>>
1391                 <TELL " " D ,PRSO>)
1392                (T <BUFFER-PRINT .PTR <GET ,P-ITBL ,P-NC2L> <>>)>>
1393
1394 ;"former CRUFTY routine, re-written by SWG"
1395
1396 <ROUTINE THIS-IT? (OBJ TBL "AUX" SYNS)
1397  <COND (<FSET? .OBJ ,INVISIBLE> <RFALSE>)
1398        (<AND ,P-NAM
1399              <NOT <ZMEMQ ,P-NAM
1400                          <SET SYNS <GETPT .OBJ ,P?SYNONYM>>
1401                          <- </ <PTSIZE .SYNS> 2> 1>>>>
1402         <RFALSE>)
1403        (<AND ,P-ADJ
1404              <OR <NOT <SET SYNS <GETPT .OBJ ,P?ADJECTIVE>>>
1405                  <NOT <ZMEMQB ,P-ADJ .SYNS <- <PTSIZE .SYNS> 1>>>>>
1406         <RFALSE>)
1407        (<AND <NOT <ZERO? ,P-GWIMBIT>> <NOT <FSET? .OBJ ,P-GWIMBIT>>>
1408         <RFALSE>)>
1409  <RTRUE>>
1410
1411 <ROUTINE ACCESSIBLE? (OBJ "AUX" (L <LOC .OBJ>)) ;"can player TOUCH object?"
1412          ;"revised 5/2/84 by SEM and SWG"
1413          <COND (<FSET? .OBJ ,INVISIBLE>
1414                 <RFALSE>)
1415                ;(<EQUAL? .OBJ ,PSEUDO-OBJECT>
1416                 <COND (<EQUAL? ,LAST-PSEUDO-LOC ,HERE>
1417                        <RTRUE>)
1418                       (T
1419                        <RFALSE>)>)
1420                (<NOT .L>
1421                 <RFALSE>)
1422                (<EQUAL? .L ,GLOBAL-OBJECTS>
1423                 <RTRUE>)
1424                (<AND <EQUAL? .L ,LOCAL-GLOBALS>
1425                      <GLOBAL-IN? .OBJ ,HERE>>
1426                 <RTRUE>)
1427                (<NOT <EQUAL? <META-LOC .OBJ> ,HERE <LOC ,WINNER>>>
1428                 <RFALSE>)
1429                (<EQUAL? .L ,WINNER ,HERE <LOC ,WINNER>>
1430                 <RTRUE>)
1431                (<AND <FSET? .L ,OPENBIT>
1432                      <ACCESSIBLE? .L>>
1433                 <RTRUE>)
1434                (T
1435                 <RFALSE>)>>
1436
1437 <ROUTINE META-LOC (OBJ)
1438          <REPEAT ()
1439                  <COND (<NOT .OBJ>
1440                         <RFALSE>)
1441                        (<IN? .OBJ ,GLOBAL-OBJECTS>
1442                         <RETURN ,GLOBAL-OBJECTS>)>
1443                  <COND (<IN? .OBJ ,ROOMS>
1444                         <RETURN .OBJ>)
1445                        (T
1446                         <SET OBJ <LOC .OBJ>>)>>>