zork-fortran/np3.for

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.

D	DFLAG=IAND(PRSFLG, 16).NE.0
D	if(DFLAG)write(0,*) 'synflags=',sdir,sind,sstd,sflip,sdriv,svmask

	J=ACT
C						!SET UP PTR TO SYNTAX.
	DRIVE=0
C						!NO DEFAULT.
	DFORCE=0
C						!NO FORCED DEFAULT.
	QPREP=IAND(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 UNPACKS(J,NEWJ)
C						!UNPACK SYNTAX.

D	IF(DFLAG) PRINT 60,O1,P1,DOBJ,DFL1,DFL2
D60	FORMAT(' SYNMCH INPUTS TO SYNEQL- ',5I7)

	SPREP=IAND(DOBJ,VPMASK)
	IF(.NOT.SYNEQL(P1,O1,DOBJ,DFL1,DFL2)) GO TO 1000

D	IF(DFLAG) PRINT 60,O2,P2,IOBJ,IFL1,IFL2

	SPREP=IAND(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((IAND(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

D	IF(DFLAG) PRINT 20,DRIVE,DFORCE
D20	FORMAT(' SYNMCH, DRIVE=',2I6)

	IF(DRIVE.EQ.0) DRIVE=DFORCE
C						!NO DRIVER? USE FORCE.
	IF(DRIVE.EQ.0) GO TO 10000
C						!ANY DRIVER?
	CALL UNPACKS(DRIVE,DFORCE)
C						!UNPACK DFLT SYNTAX.
C
C TRY TO FILL DIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
C
	IF((IAND(VFLAG,SDIR).EQ.0).OR.(O1.NE.0)) GO TO 4000
C
C FIRST TRY TO SNARF ORPHAN OBJECT.
C
	O1=IAND(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.

D	IF(DFLAG) PRINT 30,O1
D30	FORMAT(' SYNMCH- DO GWIM= ',I6)

	IF(O1.GT.0) GO TO 4000
C						!TEST RESULT.
	CALL ORPHAN(-1,ACT,0,IAND(DOBJ,VPMASK),0)
	CALL RSPEAK(623)
	RETURN
C
C TRY TO FILL INDIRECT OBJECT SLOT IF THAT WAS THE PROBLEM.
C
4000	IF((IAND(VFLAG,SIND).EQ.0).OR.(O2.NE.0)) GO TO 6000
	O2=GWIM(IOBJ,IFW1,IFW2)
C						!GWIM.

D	IF(DFLAG) PRINT 40,O2
D40	FORMAT(' SYNMCH- IO GWIM= ',I6)

	IF(O2.GT.0) GO TO 6000
	IF(O1.EQ.0) O1=IAND(OFLAG,OSLOT)
	CALL ORPHAN(-1,ACT,O1,IAND(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(IAND(VFLAG,SFLIP).EQ.0) GO TO 5000
	J=O1
C						!YES.
	O1=O2
	O2=J
C
5000	PRSA=IAND(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.

D	IF(DFLAG) PRINT 50,SYNMCH,PRSA,PRSO,PRSI,ACT,O1,O2
D50	FORMAT(' SYNMCH- RESULTS ',L1,6I7)

	RETURN
C
	END
C UNPACKS-	UNPACK SYNTAX SPECIFICATION, ADV POINTER
C
C DECLARATIONS
C
	SUBROUTINE UNPACKS(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(IAND(VFLAG,SDIR).EQ.0) RETURN
	DFL1=-1
C						!ASSUME STD.
	DFL2=-1
	IF(IAND(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(IAND(DOBJ,VEBIT).EQ.0) GO TO 200
	DFL1=DFW1
C						!YES.
	DFL2=DFW2
C
200	IF(IAND(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(IAND(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.IAND(SPREP,VPMASK)).AND.
     &	(IOR(IAND(SFL1,OFLAG1(OBJ)),
     &	  IAND(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 'gamestat.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.(IAND(SFLAG,VFBIT).EQ.0)) GO TO 500
	IF(IAND(OFLAG2(X),OPENBT).NE.0) GO TO 500
	CALL RSPSUB(566,ODO2)
C						!CANT REACH.
	RETURN
C
500	IF(IAND(SFLAG,VRBIT).EQ.0) GO TO 1000
	IF(IAND(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((IAND(OFLAG1(OBJ),TAKEBT).NE.0).AND.
     &	(IAND(OFLAG2(OBJ),TRYBT).EQ.0)) GO TO 3000
C
C NOT TAKEABLE.  IF WE CARE, FAIL.
C
	IF(IAND(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(IAND(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)=IOR(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 'gamestat.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=IAND(SFLAG,VCBIT).EQ.0
C
C FIRST SEARCH ADVENTURER
C
	IF(IAND(SFLAG,VABIT).NE.0)
     &	NOBJ=FWIM(SFW1,SFW2,0,0,WINNER,NOCARE)
	IF(IAND(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.
     &	(IAND(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