![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to np3.F CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / games / dungeon|
Return to np3.F CVS log | Up to [CSRG BSD Unix] / 43BSDReno / games / dungeon |
1.1 root 1: C SYNMCH-- SYNTAX MATCHER
2: C
3: C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
4: C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
5: C WRITTEN BY R. M. SUPNIK
6: C
7: C DECLARATIONS
8: C
9: C THIS ROUTINE DETAILS ON BIT 4 OF PRSFLG
10: C
11: LOGICAL FUNCTION SYNMCH()
12: IMPLICIT INTEGER(A-Z)
13: LOGICAL SYNEQL,TAKEIT
14: #include "parser.h"
15: #include "vocab.h"
16: #include "debug.h"
17: C
18: C THE FOLLOWING DATA STATEMENT WAS ORIGINALLY:
19: C
20: C DATA R50MIN/1RA/
21: C
22: DATA R50MIN/1600/
23: C
24: SYNMCH=.FALSE.
25: #ifdef debug
26: DFLAG=and(PRSFLG, 16).NE.0
27: if(dflag) write(0,*) "synflags=",sdir,sind,sstd,sflip,sdriv,svmask
28: #endif
29: J=ACT
30: C !SET UP PTR TO SYNTAX.
31: DRIVE=0
32: C !NO DEFAULT.
33: DFORCE=0
34: C !NO FORCED DEFAULT.
35: QPREP=and(OFLAG,OPREP)
36: 100 J=J+2
37: C !FIND START OF SYNTAX.
38: IF((VVOC(J).LE.0).OR.(VVOC(J).GE.R50MIN)) GO TO 100
39: LIMIT=J+VVOC(J)+1
40: C !COMPUTE LIMIT.
41: J=J+1
42: C !ADVANCE TO NEXT.
43: C
44: 200 CALL UNPACK(J,NEWJ)
45: C !UNPACK SYNTAX.
46: #ifdef debug
47: IF(DFLAG) PRINT 60,O1,P1,DOBJ,DFL1,DFL2
48: #ifdef NOCC
49: 60 FORMAT('SYNMCH INPUTS TO SYNEQL- ',5I7)
50: #else NOCC
51: 60 FORMAT(' SYNMCH INPUTS TO SYNEQL- ',5I7)
52: #endif NOCC
53: #endif
54: SPREP=and(DOBJ,VPMASK)
55: IF(.NOT.SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 1000
56: #ifdef debug
57: IF(DFLAG) PRINT 60,O2,P2,IOBJ,IFL1,IFL2
58: #endif
59: SPREP=and(IOBJ,VPMASK)
60: IF(SYNEQL(P2,O2,IOBJ,IFL1,IFL2)) GO TO 6000
61: C
62: C SYNTAX MATCH FAILS, TRY NEXT ONE.
63: C
64: IF(O2) 3000,500,3000
65: C !IF O2=0, SET DFLT.
66: 1000 IF(O1) 3000,500,3000
67: C !IF O1=0, SET DFLT.
68: 500 IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J
69: C !IF PREP MCH.
70: IF((and(VFLAG,SDRIV)).NE.0) DRIVE=J
71: 3000 J=NEWJ
72: IF(J.LT.LIMIT) GO TO 200
73: C !MORE TO DO?
74: C SYNMCH, PAGE 2
75: C
76: C MATCH HAS FAILED. IF DEFAULT SYNTAX EXISTS, TRY TO SNARF
77: C ORPHANS OR GWIMS, OR MAKE NEW ORPHANS.
78: C
79: #ifdef debug
80: IF(DFLAG) PRINT 20,DRIVE,DFORCE
81: #ifdef NOCC
82: 20 FORMAT('SYNMCH, DRIVE=',2I6)
83: #else NOCC
84: 20 FORMAT(' SYNMCH, DRIVE=',2I6)
85: #endif NOCC
86: #endif
87: IF(DRIVE.EQ.0) DRIVE=DFORCE
88: C !NO DRIVER? USE FORCE.
89: IF(DRIVE.EQ.0) GO TO 10000
90: C !ANY DRIVER?
91: CALL UNPACK(DRIVE,DFORCE)
92: C !UNPACK DFLT SYNTAX.
93: C
94: C TRY TO FILL DIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
95: C
96: IF((and(VFLAG,SDIR).EQ.0).OR.(O1.NE.0)) GO TO 4000
97: C
98: C FIRST TRY TO SNARF ORPHAN OBJECT.
99: C
100: O1=and(OFLAG,OSLOT)
101: IF(O1.EQ.0) GO TO 3500
102: C !ANY ORPHAN?
103: IF(SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 4000
104: C
105: C ORPHAN FAILS, TRY GWIM.
106: C
107: 3500 O1=GWIM(DOBJ,DFW1,DFW2)
108: C !GET GWIM.
109: #ifdef debug
110: IF(DFLAG) PRINT 30,O1
111: #ifdef NOCC
112: 30 FORMAT('SYNMCH- DO GWIM= ',I6)
113: #else NOCC
114: 30 FORMAT(' SYNMCH- DO GWIM= ',I6)
115: #endif NOCC
116: #endif debug
117: IF(O1.GT.0) GO TO 4000
118: C !TEST RESULT.
119: CALL ORPHAN(-1,ACT,0,and(DOBJ,VPMASK),0)
120: CALL RSPEAK(623)
121: RETURN
122: C
123: C TRY TO FILL INDIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
124: C
125: 4000 IF((and(VFLAG,SIND).EQ.0).OR.(O2.NE.0)) GO TO 6000
126: O2=GWIM(IOBJ,IFW1,IFW2)
127: C !GWIM.
128: #ifdef debug
129: IF(DFLAG) PRINT 40,O2
130: #ifdef NOCC
131: 40 FORMAT('SYNMCH- IO GWIM= ',I6)
132: #else NOCC
133: 40 FORMAT(' SYNMCH- IO GWIM= ',I6)
134: #endif NOCC
135: #endif debug
136: IF(O2.GT.0) GO TO 6000
137: IF(O1.EQ.0) O1=and(OFLAG,OSLOT)
138: CALL ORPHAN(-1,ACT,O1,and(DOBJ,VPMASK),0)
139: CALL RSPEAK(624)
140: RETURN
141: C
142: C TOTAL CHOMP
143: C
144: 10000 CALL RSPEAK(601)
145: C !CANT DO ANYTHING.
146: RETURN
147: C SYNMCH, PAGE 3
148: C
149: C NOW TRY TO TAKE INDIVIDUAL OBJECTS AND
150: C IN GENERAL CLEAN UP THE PARSE VECTOR.
151: C
152: 6000 IF(and(VFLAG,SFLIP).EQ.0) GO TO 5000
153: J=O1
154: C !YES.
155: O1=O2
156: O2=J
157: C
158: 5000 PRSA=and(VFLAG,SVMASK)
159: PRSO=O1
160: C !GET DIR OBJ.
161: PRSI=O2
162: C !GET IND OBJ.
163: IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN
164: C !TRY TAKE.
165: IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN
166: C !TRY TAKE.
167: SYNMCH=.TRUE.
168: #ifdef debug
169: IF(DFLAG) PRINT 50,SYNMCH,PRSA,PRSO,PRSI,ACT,O1,O2
170: #ifdef NOCC
171: 50 FORMAT('SYNMCH- RESULTS ',L1,6I7)
172: #else NOCC
173: 50 FORMAT(' SYNMCH- RESULTS ',L1,6I7)
174: #endif NOCC
175: #endif
176: RETURN
177: C
178: END
179: C UNPACK- UNPACK SYNTAX SPECIFICATION, ADV POINTER
180: C
181: C DECLARATIONS
182: C
183: SUBROUTINE UNPACK(OLDJ,J)
184: IMPLICIT INTEGER(A-Z)
185: #include "vocab.h"
186: #include "parser.h"
187: C
188: DO 10 I=1,11
189: C !CLEAR SYNTAX.
190: SYN(I)=0
191: 10 CONTINUE
192: C
193: VFLAG=VVOC(OLDJ)
194: J=OLDJ+1
195: IF(and(VFLAG,SDIR).EQ.0) RETURN
196: DFL1=-1
197: C !ASSUME STD.
198: DFL2=-1
199: IF(and(VFLAG,SSTD).EQ.0) GO TO 100
200: DFW1=-1
201: C !YES.
202: DFW2=-1
203: DOBJ=VABIT+VRBIT+VFBIT
204: GO TO 200
205: C
206: 100 DOBJ=VVOC(J)
207: C !NOT STD.
208: DFW1=VVOC(J+1)
209: DFW2=VVOC(J+2)
210: J=J+3
211: IF(and(DOBJ,VEBIT).EQ.0) GO TO 200
212: DFL1=DFW1
213: C !YES.
214: DFL2=DFW2
215: C
216: 200 IF(and(VFLAG,SIND).EQ.0) RETURN
217: IFL1=-1
218: C !ASSUME STD.
219: IFL2=-1
220: IOBJ=VVOC(J)
221: IFW1=VVOC(J+1)
222: IFW2=VVOC(J+2)
223: J=J+3
224: IF(and(IOBJ,VEBIT).EQ.0) RETURN
225: IFL1=IFW1
226: C !YES.
227: IFL2=IFW2
228: RETURN
229: C
230: END
231: C SYNEQL- TEST FOR SYNTAX EQUALITY
232: C
233: C DECLARATIONS
234: C
235: LOGICAL FUNCTION SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2)
236: IMPLICIT INTEGER(A-Z)
237: #include "objects.h"
238: #include "parser.h"
239: C
240: IF(OBJ.EQ.0) GO TO 100
241: C !ANY OBJECT?
242: SYNEQL=(PREP.EQ.and(SPREP,VPMASK)).AND.
243: & (or(and(SFL1,OFLAG1(OBJ)),
244: & and(SFL2,OFLAG2(OBJ))).NE.0)
245: RETURN
246: C
247: 100 SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0)
248: RETURN
249: C
250: END
251: C TAKEIT- PARSER BASED TAKE OF OBJECT
252: C
253: C DECLARATIONS
254: C
255: LOGICAL FUNCTION TAKEIT(OBJ,SFLAG)
256: IMPLICIT INTEGER(A-Z)
257: #include "parser.h"
258: COMMON /STAR/ MBASE,STRBIT
259: #include "gamestate.h"
260: #include "state.h"
261: #include "objects.h"
262: #include "oflags.h"
263: #include "advers.h"
264: C TAKEIT, PAGE 2
265: C
266: TAKEIT=.FALSE.
267: C !ASSUME LOSES.
268: IF((OBJ.EQ.0).OR.(OBJ.GT.STRBIT)) GO TO 4000
269: C !NULL/STARS WIN.
270: ODO2=ODESC2(OBJ)
271: C !GET DESC.
272: X=OCAN(OBJ)
273: C !GET CONTAINER.
274: IF((X.EQ.0).OR.(and(SFLAG,VFBIT).EQ.0)) GO TO 500
275: IF(and(OFLAG2(X),OPENBT).NE.0) GO TO 500
276: CALL RSPSUB(566,ODO2)
277: C !CANT REACH.
278: RETURN
279: C
280: 500 IF(and(SFLAG,VRBIT).EQ.0) GO TO 1000
281: IF(and(SFLAG,VTBIT).EQ.0) GO TO 2000
282: C
283: C SHOULD BE IN ROOM (VRBIT NE 0) AND CAN BE TAKEN (VTBIT NE 0)
284: C
285: IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
286: C !IF NOT, OK.
287: C
288: C ITS IN THE ROOM AND CAN BE TAKEN.
289: C
290: IF((and(OFLAG1(OBJ),TAKEBT).NE.0).AND.
291: & (and(OFLAG2(OBJ),TRYBT).EQ.0)) GO TO 3000
292: C
293: C NOT TAKEABLE. IF WE CARE, FAIL.
294: C
295: IF(and(SFLAG,VCBIT).EQ.0) GO TO 4000
296: CALL RSPSUB(445,ODO2)
297: RETURN
298: C
299: C 1000-- IT SHOULD NOT BE IN THE ROOM.
300: C 2000-- IT CANT BE TAKEN.
301: C
302: 2000 IF(and(SFLAG,VCBIT).EQ.0) GO TO 4000
303: 1000 IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
304: CALL RSPSUB(665,ODO2)
305: RETURN
306: C TAKEIT, PAGE 3
307: C
308: C OBJECT IS IN THE ROOM, CAN BE TAKEN BY THE PARSER,
309: C AND IS TAKEABLE IN GENERAL. IT IS NOT A STAR.
310: C TAKING IT SHOULD NOT HAVE SIDE AFFECTS.
311: C IF IT IS INSIDE SOMETHING, THE CONTAINER IS OPEN.
312: C THE FOLLOWING CODE IS LIFTED FROM SUBROUTINE TAKE.
313: C
314: 3000 IF(OBJ.NE.AVEHIC(WINNER)) GO TO 3500
315: C !TAKE VEHICLE?
316: CALL RSPEAK(672)
317: RETURN
318: C
319: 3500 IF(((X.NE.0).AND.(OADV(X).EQ.WINNER)).OR.
320: & ((WEIGHT(0,OBJ,WINNER)+OSIZE(OBJ)).LE.MXLOAD))
321: & GO TO 3700
322: CALL RSPEAK(558)
323: C !TOO BIG.
324: RETURN
325: C
326: 3700 CALL NEWSTA(OBJ,559,0,0,WINNER)
327: C !DO TAKE.
328: OFLAG2(OBJ)=or(OFLAG2(OBJ),TCHBT)
329: CALL SCRUPD(OFVAL(OBJ))
330: OFVAL(OBJ)=0
331: C
332: 4000 TAKEIT=.TRUE.
333: C !SUCCESS.
334: RETURN
335: C
336: END
337: C
338: C GWIM- GET WHAT I MEAN IN AMBIGOUS SITUATIONS
339: C
340: C DECLARATIONS
341: C
342: INTEGER FUNCTION GWIM(SFLAG,SFW1,SFW2)
343: IMPLICIT INTEGER(A-Z)
344: LOGICAL TAKEIT,NOCARE
345: #include "parser.h"
346: COMMON /STAR/ MBASE,STRBIT
347: #include "gamestate.h"
348: #include "objects.h"
349: #include "oflags.h"
350: #include "advers.h"
351: C GWIM, PAGE 2
352: C
353: GWIM=-1
354: C !ASSUME LOSE.
355: AV=AVEHIC(WINNER)
356: NOBJ=0
357: NOCARE=and(SFLAG,VCBIT).EQ.0
358: C
359: C FIRST SEARCH ADVENTURER
360: C
361: IF(and(SFLAG,VABIT).NE.0)
362: & NOBJ=FWIM(SFW1,SFW2,0,0,WINNER,NOCARE)
363: IF(and(SFLAG,VRBIT).NE.0) GO TO 100
364: 50 GWIM=NOBJ
365: RETURN
366: C
367: C ALSO SEARCH ROOM
368: C
369: 100 ROBJ=FWIM(SFW1,SFW2,HERE,0,0,NOCARE)
370: IF(ROBJ) 500,50,200
371: C !TEST RESULT.
372: C
373: C ROBJ > 0
374: C
375: 200 IF((AV.EQ.0).OR.(ROBJ.EQ.AV).OR.
376: & (and(OFLAG2(ROBJ),FINDBT).NE.0)) GO TO 300
377: IF(OCAN(ROBJ).NE.AV) GO TO 50
378: C !UNREACHABLE? TRY NOBJ
379: 300 IF(NOBJ.NE.0) RETURN
380: C !IF AMBIGUOUS, RETURN.
381: IF(.NOT.TAKEIT(ROBJ,SFLAG)) RETURN
382: C !IF UNTAKEABLE, RETURN
383: GWIM=ROBJ
384: 500 RETURN
385: C
386: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.