home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol047 / np3.for < prev    next >
Encoding:
Text File  |  1984-04-29  |  9.5 KB  |  368 lines
  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,DFLAG
  14. C
  15. C PARSER OUTPUT
  16. C
  17.     LOGICAL PRSWON
  18.     COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
  19. C
  20.     COMMON /DEBUG/ DBGFLG,PRSFLG
  21. C
  22.     COMMON /ORPHS/ OFLAG,OACT,OSLOT,OPREP,ONAME
  23.     COMMON /PV/ ACT,O1,O2,P1,P2
  24.     COMMON /SYNTAX/VFLAG,DOBJ,DFL1,DFL2,DFW1,DFW2,
  25.     1    IOBJ,IFL1,IFL2,IFW1,IFW2
  26.     COMMON /VRBVOC/ VVOC(950)
  27.     COMMON /SYNFLG/ SDIR,SIND,SSTD,SFLIP,SDRIV,SVMASK
  28.     COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
  29.     DATA R50MIN/1RA/
  30. C
  31.     SYNMCH=.FALSE.
  32. D    DFLAG=(PRSFLG.AND."20).NE.0
  33.     J=ACT                    !SET UP PTR TO SYNTAX.
  34.     DRIVE=0                    !NO DEFAULT.
  35.     DFORCE=0                !NO FORCED DEFAULT.
  36.     QPREP=OFLAG.AND.OPREP            !VALID ORPHAN PREP FLAG.
  37. 100    J=J+2                    !FIND START OF SYNTAX.
  38.     IF((VVOC(J).LE.0).OR.(VVOC(J).GE.R50MIN)) GO TO 100
  39.     LIMIT=J+VVOC(J)+1            !COMPUTE LIMIT.
  40.     J=J+1                    !ADVANCE TO NEXT.
  41. C
  42. 200    CALL UNPACK(J,NEWJ)            !UNPACK SYNTAX.
  43. D    IF(DFLAG) TYPE 60,O1,P1,DOBJ,DFL1,DFL2
  44. D60    FORMAT(' SYNMCH INPUTS TO SYNEQL- ',5I7)
  45.     SPREP=DOBJ.AND.VPMASK            !SAVE EXPECTED PREP.
  46.     IF(.NOT.SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 1000
  47. D    IF(DFLAG) TYPE 60,O2,P2,IOBJ,IFL1,IFL2
  48.     SPREP=IOBJ.AND.VPMASK            !SAVE EXPECTED PREP.
  49.     IF(SYNEQL(P2,O2,IOBJ,IFL1,IFL2)) GO TO 6000
  50. C
  51. C SYNTAX MATCH FAILS, TRY NEXT ONE.
  52. C
  53.     IF(O2) 3000,500,3000            !IF O2=0, SET DFLT.
  54. 1000    IF(O1) 3000,500,3000            !IF O1=0, SET DFLT.
  55. 500    IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J     !IF PREP MCH.
  56.     IF((VFLAG.AND.SDRIV).NE.0) DRIVE=J    !IF DRIVER, RECORD.
  57. 3000    J=NEWJ
  58.     IF(J.LT.LIMIT) GO TO 200        !MORE TO DO?
  59. C SYNMCH, PAGE 2
  60. C
  61. C MATCH HAS FAILED.  IF DEFAULT SYNTAX EXISTS, TRY TO SNARF
  62. C ORPHANS OR GWIMS, OR MAKE NEW ORPHANS.
  63. C
  64. D    IF(DFLAG) TYPE 20,DRIVE,DFORCE
  65. D20    FORMAT(' SYNMCH, DRIVE=',2I6)
  66.     IF(DRIVE.EQ.0) DRIVE=DFORCE        !NO DRIVER? USE FORCE.
  67.     IF(DRIVE.EQ.0) GO TO 10000        !ANY DRIVER?
  68.     CALL UNPACK(DRIVE,DFORCE)        !UNPACK DFLT SYNTAX.
  69. C
  70. C TRY TO FILL DIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
  71. C
  72.     IF(((VFLAG.AND.SDIR).EQ.0).OR.(O1.NE.0)) GO TO 4000
  73. C
  74. C FIRST TRY TO SNARF ORPHAN OBJECT.
  75. C
  76.     O1=OFLAG.AND.OSLOT
  77.     IF(O1.EQ.0) GO TO 3500            !ANY ORPHAN?
  78.     IF(SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 4000
  79. C
  80. C ORPHAN FAILS, TRY GWIM.
  81. C
  82. 3500    O1=GWIM(DOBJ,DFW1,DFW2)            !GET GWIM.
  83. D    IF(DFLAG) TYPE 30,O1
  84. D30    FORMAT(' SYNMCH- DO GWIM= ',I6)
  85.     IF(O1.GT.0) GO TO 4000        !TEST RESULT.
  86.     CALL ORPHAN(-1,ACT,0,DOBJ.AND.VPMASK,0)    !FAILS, ORPHAN.
  87.     CALL RSPEAK(623)
  88.     RETURN
  89. C
  90. C TRY TO FILL INDIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
  91. C
  92. 4000    IF(((VFLAG.AND.SIND).EQ.0).OR.(O2.NE.0)) GO TO 6000
  93.     O2=GWIM(IOBJ,IFW1,IFW2)            !GWIM.
  94. D    IF(DFLAG) TYPE 40,O2
  95. D40    FORMAT(' SYNMCH- IO GWIM= ',I6)
  96.     IF(O2.GT.0) GO TO 6000
  97.     IF(O1.EQ.0) O1=OFLAG.AND.OSLOT
  98.     CALL ORPHAN(-1,ACT,O1,DOBJ.AND.VPMASK,0)
  99.     CALL RSPEAK(624)
  100.     RETURN
  101. C
  102. C TOTAL CHOMP
  103. C
  104. 10000    CALL RSPEAK(601)            !CANT DO ANYTHING.
  105.     RETURN
  106. C SYNMCH, PAGE 3
  107. C
  108. C NOW TRY TO TAKE INDIVIDUAL OBJECTS AND
  109. C IN GENERAL CLEAN UP THE PARSE VECTOR.
  110. C
  111. 6000    IF((VFLAG.AND.SFLIP).EQ.0) GO TO 5000    !FLIP?
  112.     J=O1                    !YES.
  113.     O1=O2
  114.     O2=J
  115. C
  116. 5000    PRSA=VFLAG.AND.SVMASK            !GET VERB.
  117.     PRSO=O1                    !GET DIR OBJ.
  118.     PRSI=O2                    !GET IND OBJ.
  119.     IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN    !TRY TAKE.
  120.     IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN    !TRY TAKE.
  121.     SYNMCH=.TRUE.
  122. D    IF(DFLAG) TYPE 50,SYNMCH,PRSA,PRSO,PRSI,ACT,O1,O2
  123. D50    FORMAT(' SYNMCH- RESULTS ',L1,6I7)
  124.     RETURN
  125. C
  126.     END
  127. C UNPACK-    UNPACK SYNTAX SPECIFICATION, ADV POINTER
  128. C
  129. C DECLARATIONS
  130. C
  131.     SUBROUTINE UNPACK(OLDJ,J)
  132.     IMPLICIT INTEGER(A-Z)
  133. C
  134.     COMMON /VRBVOC/ VVOC(950)
  135. C
  136.     COMMON /SYNFLG/ SDIR,SIND,SSTD,SFLIP,SDRIV,SVMASK
  137.     COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
  138.     COMMON /SYNTAX/ VFLAG,DOBJ,DFL1,DFL2,DFW1,DFW2,
  139.     1    IOBJ,IFL1,IFL2,IFW1,IFW2
  140.     INTEGER SYN(11)
  141.     EQUIVALENCE (SYN(1),VFLAG)
  142. C
  143.     DO 10 I=1,11                !CLEAR SYNTAX.
  144.       SYN(I)=0
  145. 10    CONTINUE
  146. C
  147.     VFLAG=VVOC(OLDJ)
  148.     J=OLDJ+1
  149.     IF((VFLAG.AND.SDIR).EQ.0) RETURN    !DIR OBJECT?
  150.     DFL1=-1                    !ASSUME STD.
  151.     DFL2=-1
  152.     IF((VFLAG.AND.SSTD).EQ.0) GO TO 100    !STD OBJECT?
  153.     DFW1=-1                    !YES.
  154.     DFW2=-1
  155.     DOBJ=VABIT+VRBIT+VFBIT
  156.     GO TO 200
  157. C
  158. 100    DOBJ=VVOC(J)                !NOT STD.
  159.     DFW1=VVOC(J+1)
  160.     DFW2=VVOC(J+2)
  161.     J=J+3
  162.     IF((DOBJ.AND.VEBIT).EQ.0) GO TO 200    !VBIT = VFWIM?
  163.     DFL1=DFW1                !YES.
  164.     DFL2=DFW2
  165. C
  166. 200    IF((VFLAG.AND.SIND).EQ.0) RETURN    !IND OBJECT?
  167.     IFL1=-1                    !ASSUME STD.
  168.     IFL2=-1
  169.     IOBJ=VVOC(J)
  170.     IFW1=VVOC(J+1)
  171.     IFW2=VVOC(J+2)
  172.     J=J+3
  173.     IF((IOBJ.AND.VEBIT).EQ.0) RETURN    !VBIT = VFWIM?
  174.     IFL1=IFW1                !YES.
  175.     IFL2=IFW2
  176.     RETURN
  177. C
  178.     END
  179. C SYNEQL-    TEST FOR SYNTAX EQUALITY
  180. C
  181. C DECLARATIONS
  182. C
  183.     LOGICAL FUNCTION SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2)
  184.     IMPLICIT INTEGER(A-Z)
  185. C
  186. C OBJECTS
  187. C
  188.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  189.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  190.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  191.     3    OADV(220),OCAN(220),OREAD(220)
  192. C
  193.     COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
  194. C
  195.     IF(OBJ.EQ.0) GO TO 100            !ANY OBJECT?
  196.     SYNEQL=(PREP.EQ.(SPREP.AND.VPMASK)).AND.
  197.     1    (((SFL1.AND.OFLAG1(OBJ)).OR.
  198.     2      (SFL2.AND.OFLAG2(OBJ))).NE.0)
  199.     RETURN
  200. C
  201. 100    SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0)
  202.     RETURN
  203. C
  204.     END
  205. C TAKEIT-    PARSER BASED TAKE OF OBJECT
  206. C
  207. C DECLARATIONS
  208. C
  209.     LOGICAL FUNCTION TAKEIT(OBJ,SFLAG)
  210.     IMPLICIT INTEGER(A-Z)
  211. C
  212.     COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
  213.     COMMON /STAR/ MBASE,STRBIT
  214. C
  215. C GAME STATE
  216. C
  217.     LOGICAL TELFLG
  218.     COMMON /PLAY/ WINNER,HERE,TELFLG
  219.     COMMON /STATE/ MOVES,DEATHS,RWSCOR,MXSCOR,MXLOAD,
  220.     1    LTSHFT,BLOC,MUNGRM,HS,EGSCOR,EGMXSC
  221. C
  222. C OBJECTS
  223. C
  224.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  225.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  226.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  227.     3    OADV(220),OCAN(220),OREAD(220)
  228. C
  229.     COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
  230.     1    NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
  231.     2    TOOLBT,TURNBT,ONBT
  232.     COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
  233.     1    WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
  234.     2    TCHBT,VEHBT,SCHBT
  235. C
  236. C ADVENTURERS
  237. C
  238.     COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
  239.     1    AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
  240. C TAKEIT, PAGE 2
  241. C
  242.     TAKEIT=.FALSE.                !ASSUME LOSES.
  243.     IF((OBJ.EQ.0).OR.(OBJ.GT.STRBIT)) GO TO 4000    !NULL/STARS WIN.
  244.     ODO2=ODESC2(OBJ)            !GET DESC.
  245.     X=OCAN(OBJ)                !GET CONTAINER.
  246.     IF((X.EQ.0).OR.((SFLAG.AND.VFBIT).EQ.0)) GO TO 500
  247.     IF((OFLAG2(X).AND.OPENBT).NE.0) GO TO 500
  248.     CALL RSPSUB(566,ODO2)            !CANT REACH.
  249.     RETURN
  250. C
  251. 500    IF((SFLAG.AND.VRBIT).EQ.0) GO TO 1000    !SHLD BE IN ROOM?
  252.     IF((SFLAG.AND.VTBIT).EQ.0) GO TO 2000    !CAN BE TAKEN?
  253. C
  254. C SHOULD BE IN ROOM (VRBIT NE 0) AND CAN BE TAKEN (VTBIT NE 0)
  255. C
  256.     IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000 !IF NOT, OK.
  257. C
  258. C ITS IN THE ROOM AND CAN BE TAKEN.
  259. C
  260.     IF(((OFLAG1(OBJ).AND.TAKEBT).NE.0).AND.
  261.     1    ((OFLAG2(OBJ).AND.TRYBT).EQ.0)) GO TO 3000
  262. C
  263. C NOT TAKEABLE.  IF WE CARE, FAIL.
  264. C
  265.     IF((SFLAG.AND.VCBIT).EQ.0) GO TO 4000    !IF NO CARE, RETURN.
  266.     CALL RSPSUB(445,ODO2)
  267.     RETURN
  268. C
  269. C 1000--    IT SHOULD NOT BE IN THE ROOM.
  270. C 2000--    IT CANT BE TAKEN.
  271. C
  272. 2000    IF((SFLAG.AND.VCBIT).EQ.0) GO TO 4000    !IF NO CARE, RETURN
  273. 1000    IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
  274.     CALL RSPSUB(665,ODO2)
  275.     RETURN
  276. C TAKEIT, PAGE 3
  277. C
  278. C OBJECT IS IN THE ROOM, CAN BE TAKEN BY THE PARSER,
  279. C AND IS TAKEABLE IN GENERAL.  IT IS NOT A STAR.
  280. C TAKING IT SHOULD NOT HAVE SIDE AFFECTS.
  281. C IF IT IS INSIDE SOMETHING, THE CONTAINER IS OPEN.
  282. C THE FOLLOWING CODE IS LIFTED FROM SUBROUTINE TAKE.
  283. C
  284. 3000    IF(OBJ.NE.AVEHIC(WINNER)) GO TO 3500    !TAKE VEHICLE?
  285.     CALL RSPEAK(672)
  286.     RETURN
  287. C
  288. 3500    IF(((X.NE.0).AND.(OADV(X).EQ.WINNER)).OR.
  289.     1 ((WEIGHT(0,OBJ,WINNER)+OSIZE(OBJ)).LE.MXLOAD))
  290.     2 GO TO 3700
  291.     CALL RSPEAK(558)            !TOO BIG.
  292.     RETURN
  293. C
  294. 3700    CALL NEWSTA(OBJ,559,0,0,WINNER)        !DO TAKE.
  295.     OFLAG2(OBJ)=OFLAG2(OBJ).OR.TCHBT    !TOUCHED.
  296.     CALL SCRUPD(OFVAL(OBJ))
  297.     OFVAL(OBJ)=0
  298. C
  299. 4000    TAKEIT=.TRUE.                !SUCCESS.
  300.     RETURN
  301. C
  302.     END
  303. C GWIM- GET WHAT I MEAN IN AMBIGOUS SITUATIONS
  304. C
  305. C DECLARATIONS
  306. C
  307.     INTEGER FUNCTION GWIM(SFLAG,SFW1,SFW2)
  308.     IMPLICIT INTEGER(A-Z)
  309.     LOGICAL TAKEIT,NOCARE
  310. C
  311.     COMMON /OBJFLG/ VABIT,VRBIT,VTBIT,VCBIT,VEBIT,VFBIT,VPMASK
  312.     COMMON /STAR/ MBASE,STRBIT
  313. C
  314. C GAME STATE
  315. C
  316.     LOGICAL TELFLG
  317.     COMMON /PLAY/ WINNER,HERE,TELFLG
  318. C
  319. C OBJECTS
  320. C
  321.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  322.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  323.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  324.     3    OADV(220),OCAN(220),OREAD(220)
  325. C
  326.     COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
  327.     1    NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
  328.     2    TOOLBT,TURNBT,ONBT
  329.     COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
  330.     1    WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
  331.     2    TCHBT,VEHBT,SCHBT
  332. C
  333. C ADVENTURERS
  334. C
  335.     COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
  336.     1    AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
  337. C GWIM, PAGE 2
  338. C
  339.     GWIM=-1                    !ASSUME LOSE.
  340.     AV=AVEHIC(WINNER)
  341.     NOBJ=0
  342.     NOCARE=(SFLAG.AND.VCBIT).EQ.0
  343. C
  344. C FIRST SEARCH ADVENTURER
  345. C
  346.     IF((SFLAG.AND.VABIT).NE.0)
  347.     1    NOBJ=FWIM(SFW1,SFW2,0,0,WINNER,NOCARE)
  348.     IF((SFLAG.AND.VRBIT).NE.0) GO TO 100
  349. 50    GWIM=NOBJ
  350.     RETURN
  351. C
  352. C ALSO SEARCH ROOM
  353. C
  354. 100    ROBJ=FWIM(SFW1,SFW2,HERE,0,0,NOCARE)
  355.     IF(ROBJ) 500,50,200            !TEST RESULT.
  356. C
  357. C ROBJ > 0
  358. C
  359. 200    IF((AV.EQ.0).OR.(ROBJ.EQ.AV).OR.
  360.     1    ((OFLAG2(ROBJ).AND.FINDBT).NE.0)) GO TO 300
  361.     IF(OCAN(ROBJ).NE.AV) GO TO 50        !UNREACHABLE? TRY NOBJ
  362. 300    IF(NOBJ.NE.0) RETURN            !IF AMBIGUOUS, RETURN.
  363.     IF(.NOT.TAKEIT(ROBJ,SFLAG)) RETURN    !IF UNTAKEABLE, RETURN
  364.     GWIM=ROBJ
  365. 500    RETURN
  366. C
  367.     END
  368.