usr/src/contrib/dungeon/np3.F

C SYNMCH--      SYNTAX MATCHER
C
C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
C WRITTEN BY R. M. SUPNIK
C
C DECLARATIONS
C
C THIS ROUTINE DETAILS ON BIT 4 OF PRSFLG
C
        LOGICAL FUNCTION SYNMCH()
        IMPLICIT INTEGER(A-Z)
        LOGICAL SYNEQL,TAKEIT
#include "parser.h"
#include "vocab.h"
#include "debug.h"
C
C   THE FOLLOWING DATA STATEMENT WAS ORIGINALLY:
C
C       DATA R50MIN/1RA/
C
        DATA R50MIN/1600/
C
        SYNMCH=.FALSE.
#ifdef debug
        DFLAG=and(PRSFLG, 16).NE.0
        if(dflag) write(0,*) "synflags=",sdir,sind,sstd,sflip,sdriv,svmask
#endif
        J=ACT
C                                               !SET UP PTR TO SYNTAX.
        DRIVE=0
C                                               !NO DEFAULT.
        DFORCE=0
C                                               !NO FORCED DEFAULT.
        QPREP=and(OFLAG,OPREP)
100     J=J+2
C                                               !FIND START OF SYNTAX.
        IF((VVOC(J).LE.0).OR.(VVOC(J).GE.R50MIN)) GO TO 100
        LIMIT=J+VVOC(J)+1
C                                               !COMPUTE LIMIT.
        J=J+1
C                                               !ADVANCE TO NEXT.
C
200     CALL UNPACK(J,NEWJ)
C                                               !UNPACK SYNTAX.
#ifdef debug
        IF(DFLAG) PRINT 60,O1,P1,DOBJ,DFL1,DFL2
#ifdef NOCC
60      FORMAT('SYNMCH INPUTS TO SYNEQL- ',5I7)
#else NOCC
60      FORMAT(' SYNMCH INPUTS TO SYNEQL- ',5I7)
#endif NOCC
#endif
        SPREP=and(DOBJ,VPMASK)
        IF(.NOT.SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 1000
#ifdef debug
        IF(DFLAG) PRINT 60,O2,P2,IOBJ,IFL1,IFL2
#endif
        SPREP=and(IOBJ,VPMASK)
        IF(SYNEQL(P2,O2,IOBJ,IFL1,IFL2)) GO TO 6000
C
C SYNTAX MATCH FAILS, TRY NEXT ONE.
C
        IF(O2) 3000,500,3000
C                                               !IF O2=0, SET DFLT.
1000    IF(O1) 3000,500,3000
C                                               !IF O1=0, SET DFLT.
500     IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J
C                                               !IF PREP MCH.
        IF((and(VFLAG,SDRIV)).NE.0) DRIVE=J
3000    J=NEWJ
        IF(J.LT.LIMIT) GO TO 200
C                                               !MORE TO DO?
C SYNMCH, PAGE 2
C
C MATCH HAS FAILED.  IF DEFAULT SYNTAX EXISTS, TRY TO SNARF
C ORPHANS OR GWIMS, OR MAKE NEW ORPHANS.
C
#ifdef debug
        IF(DFLAG) PRINT 20,DRIVE,DFORCE
#ifdef NOCC
20      FORMAT('SYNMCH, DRIVE=',2I6)
#else NOCC
20      FORMAT(' SYNMCH, DRIVE=',2I6)
#endif NOCC
#endif
        IF(DRIVE.EQ.0) DRIVE=DFORCE
C                                               !NO DRIVER? USE FORCE.
        IF(DRIVE.EQ.0) GO TO 10000
C                                               !ANY DRIVER?
        CALL UNPACK(DRIVE,DFORCE)
C                                               !UNPACK DFLT SYNTAX.
C
C TRY TO FILL DIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
C
        IF((and(VFLAG,SDIR).EQ.0).OR.(O1.NE.0)) GO TO 4000
C
C FIRST TRY TO SNARF ORPHAN OBJECT.
C
        O1=and(OFLAG,OSLOT)
        IF(O1.EQ.0) GO TO 3500
C                                               !ANY ORPHAN?
        IF(SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 4000
C
C ORPHAN FAILS, TRY GWIM.
C
3500    O1=GWIM(DOBJ,DFW1,DFW2)
C                                               !GET GWIM.
#ifdef debug
        IF(DFLAG) PRINT 30,O1
#ifdef NOCC
30      FORMAT('SYNMCH- DO GWIM= ',I6)
#else NOCC
30      FORMAT(' SYNMCH- DO GWIM= ',I6)
#endif NOCC
#endif debug
        IF(O1.GT.0) GO TO 4000
C                                               !TEST RESULT.
        CALL ORPHAN(-1,ACT,0,and(DOBJ,VPMASK),0)
        CALL RSPEAK(623)
        RETURN
C
C TRY TO FILL INDIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
C
4000    IF((and(VFLAG,SIND).EQ.0).OR.(O2.NE.0)) GO TO 6000
        O2=GWIM(IOBJ,IFW1,IFW2)
C                                               !GWIM.
#ifdef debug
        IF(DFLAG) PRINT 40,O2
#ifdef NOCC
40      FORMAT('SYNMCH- IO GWIM= ',I6)
#else NOCC
40      FORMAT(' SYNMCH- IO GWIM= ',I6)
#endif NOCC
#endif debug
        IF(O2.GT.0) GO TO 6000
        IF(O1.EQ.0) O1=and(OFLAG,OSLOT)
        CALL ORPHAN(-1,ACT,O1,and(DOBJ,VPMASK),0)
        CALL RSPEAK(624)
        RETURN
C
C TOTAL CHOMP
C
10000   CALL RSPEAK(601)
C                                               !CANT DO ANYTHING.
        RETURN
C SYNMCH, PAGE 3
C
C NOW TRY TO TAKE INDIVIDUAL OBJECTS AND
C IN GENERAL CLEAN UP THE PARSE VECTOR.
C
6000    IF(and(VFLAG,SFLIP).EQ.0) GO TO 5000
        J=O1
C                                               !YES.
        O1=O2
        O2=J
C
5000    PRSA=and(VFLAG,SVMASK)
        PRSO=O1
C                                               !GET DIR OBJ.
        PRSI=O2
C                                               !GET IND OBJ.
        IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN
C                                               !TRY TAKE.
        IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN
C                                               !TRY TAKE.
        SYNMCH=.TRUE.
#ifdef debug
        IF(DFLAG) PRINT 50,SYNMCH,PRSA,PRSO,PRSI,ACT,O1,O2
#ifdef NOCC
50      FORMAT('SYNMCH- RESULTS ',L1,6I7)
#else NOCC
50      FORMAT(' SYNMCH- RESULTS ',L1,6I7)
#endif NOCC
#endif
        RETURN
C
        END
C UNPACK-       UNPACK SYNTAX SPECIFICATION, ADV POINTER
C
C DECLARATIONS
C
        SUBROUTINE UNPACK(OLDJ,J)
        IMPLICIT INTEGER(A-Z)
#include "vocab.h"
#include "parser.h"
C
        DO 10 I=1,11
C                                               !CLEAR SYNTAX.
          SYN(I)=0
10      CONTINUE
C
        VFLAG=VVOC(OLDJ)
        J=OLDJ+1
        IF(and(VFLAG,SDIR).EQ.0) RETURN
        DFL1=-1
C                                               !ASSUME STD.
        DFL2=-1
        IF(and(VFLAG,SSTD).EQ.0) GO TO 100
        DFW1=-1
C                                               !YES.
        DFW2=-1
        DOBJ=VABIT+VRBIT+VFBIT
        GO TO 200
C
100     DOBJ=VVOC(J)
C                                               !NOT STD.
        DFW1=VVOC(J+1)
        DFW2=VVOC(J+2)
        J=J+3
        IF(and(DOBJ,VEBIT).EQ.0) GO TO 200
        DFL1=DFW1
C                                               !YES.
        DFL2=DFW2
C
200     IF(and(VFLAG,SIND).EQ.0) RETURN
        IFL1=-1
C                                               !ASSUME STD.
        IFL2=-1
        IOBJ=VVOC(J)
        IFW1=VVOC(J+1)
        IFW2=VVOC(J+2)
        J=J+3
        IF(and(IOBJ,VEBIT).EQ.0) RETURN
        IFL1=IFW1
C                                               !YES.
        IFL2=IFW2
        RETURN
C
        END
C SYNEQL-       TEST FOR SYNTAX EQUALITY
C
C DECLARATIONS
C
        LOGICAL FUNCTION SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2)
        IMPLICIT INTEGER(A-Z)
#include "objects.h"
#include "parser.h"
C
        IF(OBJ.EQ.0) GO TO 100
C                                               !ANY OBJECT?
        SYNEQL=(PREP.EQ.and(SPREP,VPMASK)).AND.
&               (or(and(SFL1,OFLAG1(OBJ)),
&                 and(SFL2,OFLAG2(OBJ))).NE.0)
        RETURN
C
100     SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0)
        RETURN
C
        END
C TAKEIT-       PARSER BASED TAKE OF OBJECT
C
C DECLARATIONS
C
        LOGICAL FUNCTION TAKEIT(OBJ,SFLAG)
        IMPLICIT INTEGER(A-Z)
#include "parser.h"
        COMMON /STAR/ MBASE,STRBIT
#include "gamestate.h"
#include "state.h"
#include "objects.h"
#include "oflags.h"
#include "advers.h"
C TAKEIT, PAGE 2
C
        TAKEIT=.FALSE.
C                                               !ASSUME LOSES.
        IF((OBJ.EQ.0).OR.(OBJ.GT.STRBIT)) GO TO 4000
C                                               !NULL/STARS WIN.
        ODO2=ODESC2(OBJ)
C                                               !GET DESC.
        X=OCAN(OBJ)
C                                               !GET CONTAINER.
        IF((X.EQ.0).OR.(and(SFLAG,VFBIT).EQ.0)) GO TO 500
        IF(and(OFLAG2(X),OPENBT).NE.0) GO TO 500
        CALL RSPSUB(566,ODO2)
C                                               !CANT REACH.
        RETURN
C
500     IF(and(SFLAG,VRBIT).EQ.0) GO TO 1000
        IF(and(SFLAG,VTBIT).EQ.0) GO TO 2000
C
C SHOULD BE IN ROOM (VRBIT NE 0) AND CAN BE TAKEN (VTBIT NE 0)
C
        IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
C                                               !IF NOT, OK.
C
C ITS IN THE ROOM AND CAN BE TAKEN.
C
        IF((and(OFLAG1(OBJ),TAKEBT).NE.0).AND.
&               (and(OFLAG2(OBJ),TRYBT).EQ.0)) GO TO 3000
C
C NOT TAKEABLE.  IF WE CARE, FAIL.
C
        IF(and(SFLAG,VCBIT).EQ.0) GO TO 4000
        CALL RSPSUB(445,ODO2)
        RETURN
C
C 1000--        IT SHOULD NOT BE IN THE ROOM.
C 2000--        IT CANT BE TAKEN.
C
2000    IF(and(SFLAG,VCBIT).EQ.0) GO TO 4000
1000    IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
        CALL RSPSUB(665,ODO2)
        RETURN
C TAKEIT, PAGE 3
C
C OBJECT IS IN THE ROOM, CAN BE TAKEN BY THE PARSER,
C AND IS TAKEABLE IN GENERAL.  IT IS NOT A STAR.
C TAKING IT SHOULD NOT HAVE SIDE AFFECTS.
C IF IT IS INSIDE SOMETHING, THE CONTAINER IS OPEN.
C THE FOLLOWING CODE IS LIFTED FROM SUBROUTINE TAKE.
C
3000    IF(OBJ.NE.AVEHIC(WINNER)) GO TO 3500
C                                               !TAKE VEHICLE?
        CALL RSPEAK(672)
        RETURN
C
3500    IF(((X.NE.0).AND.(OADV(X).EQ.WINNER)).OR.
&        ((WEIGHT(0,OBJ,WINNER)+OSIZE(OBJ)).LE.MXLOAD))
&        GO TO 3700
        CALL RSPEAK(558)
C                                               !TOO BIG.
        RETURN
C
3700    CALL NEWSTA(OBJ,559,0,0,WINNER)
C                                               !DO TAKE.
        OFLAG2(OBJ)=or(OFLAG2(OBJ),TCHBT)
        CALL SCRUPD(OFVAL(OBJ))
        OFVAL(OBJ)=0
C
4000    TAKEIT=.TRUE.
C                                               !SUCCESS.
        RETURN
C
        END
C
C GWIM- GET WHAT I MEAN IN AMBIGOUS SITUATIONS
C
C DECLARATIONS
C
        INTEGER FUNCTION GWIM(SFLAG,SFW1,SFW2)
        IMPLICIT INTEGER(A-Z)
        LOGICAL TAKEIT,NOCARE
#include "parser.h"
        COMMON /STAR/ MBASE,STRBIT
#include "gamestate.h"
#include "objects.h"
#include "oflags.h"
#include "advers.h"
C GWIM, PAGE 2
C
        GWIM=-1
C                                               !ASSUME LOSE.
        AV=AVEHIC(WINNER)
        NOBJ=0
        NOCARE=and(SFLAG,VCBIT).EQ.0
C
C FIRST SEARCH ADVENTURER
C
        IF(and(SFLAG,VABIT).NE.0)
&               NOBJ=FWIM(SFW1,SFW2,0,0,WINNER,NOCARE)
        IF(and(SFLAG,VRBIT).NE.0) GO TO 100
50      GWIM=NOBJ
        RETURN
C
C ALSO SEARCH ROOM
C
100     ROBJ=FWIM(SFW1,SFW2,HERE,0,0,NOCARE)
        IF(ROBJ) 500,50,200
C                                               !TEST RESULT.
C
C ROBJ > 0
C
200     IF((AV.EQ.0).OR.(ROBJ.EQ.AV).OR.
&               (and(OFLAG2(ROBJ),FINDBT).NE.0)) GO TO 300
        IF(OCAN(ROBJ).NE.AV) GO TO 50
C                                               !UNREACHABLE? TRY NOBJ
300     IF(NOBJ.NE.0) RETURN
C                                               !IF AMBIGUOUS, RETURN.
        IF(.NOT.TAKEIT(ROBJ,SFLAG)) RETURN
C                                               !IF UNTAKEABLE, RETURN
        GWIM=ROBJ
500     RETURN
C
        END