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
|
Last modified: 1988-10-21
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 2014 |
|