zork-fortran/np1.for

C SPARSE-	START OF PARSE
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 2 OF PRSFLG
C
	INTEGER  FUNCTION  SPARSE(LBUF,LLNT,VBFLAG)
	IMPLICIT INTEGER(A-Z)
	INTEGER  LBUF(40)
	LOGICAL  LIT,OTEST,VBFLAG
	include 'parser.h'
	include 'gamestat.h'
	include 'debug.h'
	include 'objects.h'
	include 'oindex.h'
	include 'advers.h'
	include 'verbs.h'
	include 'vocab.h'
C SPARSE, PAGE 2
C
C FUNCTIONS AND DATA
C
	OTEST(R)=(R.GT.0).AND.(R.LT.R50MIN)
C
C   THE FOLLOWING DATA STATEMENT ORIGINALLY WAS:
C
C	DATA R50MIN/1RA/,R50WAL/3RWAL/
C
	DATA R50MIN/1600/,R50WAL/36852/
C SPARSE, PAGE 7
C
C SET UP FOR PARSING
C
	SPARSE=-1
C						!ASSUME PARSE FAILS.
	ADJ=0
C						!CLEAR PARTS HOLDERS.
	ACT=0
	PREP=0
	PPTR=0
	O1=0
	O2=0
	P1=0
	P2=0
D	DFLAG=IAND(PRSFLG,4).NE.0
C
	BUZLNT=20
	PRPLNT=48
	DIRLNT=75
C SPARSE, PAGE 8
C
C NOW LOOP OVER INPUT BUFFER OF LEXICAL TOKENS.
C
	DO 1000 I=1,LLNT,2
C						!TWO WORDS/TOKEN.
	  LBUF1=LBUF(I)
C						!GET CURRENT TOKEN.
	  LBUF2=LBUF(I+1)

D	  if(DFLAG) write(0,*) 'lbuf1=',lbuf1,' lbuf2=',lbuf2

	  IF(LBUF1.EQ.0) GO TO 1500
C						!END OF BUFFER?
C
C CHECK FOR BUZZ WORD
C
	  DO 50 J=1,BUZLNT,2
	    IF((LBUF1.EQ.BVOC(J)).AND.(LBUF2.EQ.BVOC(J+1)))
     &	GO TO 1000
50	  CONTINUE
C
C CHECK FOR ACTION OR DIRECTION
C
	  IF(ACT.NE.0) GO TO 75
C						!GOT ACTION ALREADY?
	  J=1
C						!CHECK FOR ACTION.
125	  IF((LBUF1.EQ.VVOC(J)).AND.(LBUF2.EQ.VVOC(J+1)))
     &	GO TO 3000
150	  J=J+2
C						!ADV TO NEXT SYNONYM.
	  IF(.NOT.OTEST(VVOC(J))) GO TO 125
C						!ANOTHER VERB?
	  J=J+VVOC(J)+1
C						!NO, ADVANCE OVER SYNTAX.
	  IF(VVOC(J).NE.-1) GO TO 125
C						!TABLE DONE?
C
75	  IF((ACT.NE.0).AND.((VVOC(ACT).NE.R50WAL).OR.
     &	(PREP.NE.0))) GO TO 200
	  DO 100 J=1,DIRLNT,3
C						!THEN CHK FOR DIR.
	    IF((LBUF1.EQ.DVOC(J)).AND.(LBUF2.EQ.DVOC(J+1)))
     &	GO TO 2000
100	  CONTINUE
C
C NOT AN ACTION, CHECK FOR PREPOSITION, ADJECTIVE, OR OBJECT.
C
200	  DO 250 J=1,PRPLNT,3
C						!LOOK FOR PREPOSITION.
	    IF((LBUF1.EQ.PVOC(J)).AND.(LBUF2.EQ.PVOC(J+1)))
     &	GO TO 4000
250	  CONTINUE
C
	  J=1
C						!LOOK FOR ADJECTIVE.
300	  IF((LBUF1.EQ.AVOC(J)).AND.(LBUF2.EQ.AVOC(J+1)))
     &	GO TO 5000
	  J=J+1
325	  J=J+1
C						!ADVANCE TO NEXT ENTRY.
	  IF(OTEST(AVOC(J))) GO TO 325
C						!A RADIX 50 CONSTANT?
	  IF(AVOC(J).NE.-1) GO TO 300
C						!POSSIBLY, END TABLE?
C
	  J=1
C						!LOOK FOR OBJECT.
450	  IF((LBUF1.EQ.OVOC(J)).AND.(LBUF2.EQ.OVOC(J+1)))
     &	GO TO 600
	  J=J+1
500	  J=J+1
	  IF(OTEST(OVOC(J))) GO TO 500
	  IF(OVOC(J).NE.-1) GO TO 450
C
C NOT RECOGNIZABLE
C
	  IF(VBFLAG) CALL RSPEAK(601)
	  RETURN
C SPARSE, PAGE 9
C
C OBJECT PROCESSING (CONTINUATION OF DO LOOP ON PREV PAGE)
C
600	  OBJ=GETOBJ(J,ADJ,0)
C						!IDENTIFY OBJECT.

D	  IF(DFLAG) PRINT 60,J,OBJ
D60	  FORMAT(' SPARSE- OBJ AT ',I6,'  OBJ= ',I6)

	  IF(OBJ.LE.0) GO TO 6000
C						!IF LE, COULDNT.
	  IF(OBJ.NE.ITOBJ) GO TO 650
C						!"IT"?
	  OBJ=GETOBJ(0,0,LASTIT)
C						!FIND LAST.
	  IF(OBJ.LE.0) GO TO 6000
C						!IF LE, COULDNT.
C
650	  IF(PREP.EQ.9) GO TO 8000
C						!"OF" OBJ?
	  IF(PPTR.EQ.2) GO TO 7000
C						!TOO MANY OBJS?
	  PPTR=PPTR+1
	  OBJVEC(PPTR)=OBJ
C						!STUFF INTO VECTOR.
	  PRPVEC(PPTR)=PREP
700	  PREP=0
	  ADJ=0
C Go to end of do loop (moved "1000 CONTINUE" to end of module, to avoid
C complaints about people jumping back into the doloop.)
	  GOTO 1000
C SPARSE, PAGE 10
C
C SPECIAL PARSE PROCESSORS
C
C 2000--	DIRECTION
C
2000	PRSA=WALKW
	PRSO=DVOC(J+2)
	SPARSE=1

D	IF(DFLAG) PRINT 10,J
D10	FORMAT(' SPARSE- DIR AT ',I6)

	RETURN
C
C 3000--	ACTION
C
3000	ACT=J
	OACT=0

D	IF(DFLAG) PRINT 20,J
D20	FORMAT(' SPARSE- ACT AT ',I6)
D	if(dflag) write(0,*) 'count=',vvoc(j+2),' vnr=',vvoc(j+3)

	GO TO 1000
C
C 4000--	PREPOSITION
C
4000	IF(PREP.NE.0) GO TO 4500
	PREP=PVOC(J+2)
	ADJ=0

D	IF(DFLAG) PRINT 30,J
D30	FORMAT(' SPARSE- PREP AT ',I6)

	GO TO 1000
C
4500	IF(VBFLAG) CALL RSPEAK(616)
	RETURN
C
C 5000--	ADJECTIVE
C
5000	ADJ=J
	J=(IAND(ONAME,OFLAG))

D	IF(DFLAG) PRINT 40,ADJ,J
D40	FORMAT(' SPARSE- ADJ AT ',I6,' ORPHAN= ',I6)

	IF((J.NE.0).AND.(I.GE.LLNT)) GO TO 600
	GO TO 1000
C
C 6000--	UNIDENTIFIABLE OBJECT (INDEX INTO OVOC IS J)
C
6000	IF(OBJ.LT.0) GO TO 6100
	J=579
	IF(LIT(HERE)) J=618
	IF(VBFLAG) CALL RSPEAK(J)
	RETURN
C
6100	IF(OBJ.NE.-10000) GO TO 6200
	IF(VBFLAG) CALL RSPSUB(620,ODESC2(AVEHIC(WINNER)))
	RETURN
C
6200	IF(VBFLAG) CALL RSPEAK(619)
	IF(ACT.EQ.0) ACT=(IAND(OFLAG,OACT))
	CALL ORPHAN(-1,ACT,O1,PREP,J)
	RETURN
C
C 7000--	TOO MANY OBJECTS.
C
7000	IF(VBFLAG) CALL RSPEAK(617)
	RETURN
C
C 8000--	RANDOMNESS FOR "OF" WORDS
C
8000	IF(OBJVEC(PPTR).EQ.OBJ) GO TO 700
	IF(VBFLAG) CALL RSPEAK(601)
	RETURN
C
C End of do-loop.
C
1000	CONTINUE
C						!AT LAST.
C
C NOW SOME MISC CLEANUP -- We fell out of the do-loop
C
1500	IF(ACT.EQ.0) ACT=(IAND(OFLAG,OACT))
	IF(ACT.EQ.0) GO TO 9000
C						!IF STILL NONE, PUNT.
	IF(ADJ.NE.0) GO TO 10000
C						!IF DANGLING ADJ, PUNT.
C
	IF((OFLAG.NE.0).AND.(OPREP.NE.0).AND.(PREP.EQ.0).AND.
     &	(O1.NE.0).AND.(O2.EQ.0).AND.(ACT.EQ.OACT))
     &	GO TO 11000
C
	SPARSE=0
C						!PARSE SUCCEEDS.
	IF(PREP.EQ.0) GO TO 1750
C						!IF DANGLING PREP,
	IF((PPTR.EQ.0).OR.(PRPVEC(PPTR).NE.0))
     &	GO TO 12000
	PRPVEC(PPTR)=PREP
C						!CVT TO 'PICK UP FROB'.
C
C 1750--	RETURN A RESULT
C
1750	CONTINUE
C						!WIN.

D	IF(DFLAG) PRINT 70,ACT,O1,O2,P1,P2
D70	FORMAT(' SPARSE RESULTS- ',5I7)
D	if(dflag) write(0,*) 'sparse=',sparse

	RETURN
C						!LOSE.
C
C 9000--	NO ACTION, PUNT
C
9000	IF(O1.EQ.0) GO TO 10000
C						!ANY DIRECT OBJECT?
	IF(VBFLAG) CALL RSPSUB(621,ODESC2(O1))
C						!WHAT TO DO?
	CALL ORPHAN(-1,0,O1,0,0)
	RETURN
C
C 10000--	TOTAL CHOMP
C
10000	IF(VBFLAG) CALL RSPEAK(622)
C						!HUH?
	RETURN
C
C 11000--	ORPHAN PREPOSITION.  CONDITIONS ARE
C		O1.NE.0, O2=0, PREP=0, ACT=OACT
C
11000	IF(OSLOT.NE.0) GO TO 11500
C						!ORPHAN OBJECT?
	P1=OPREP
C						!NO, JUST USE PREP.
	GO TO 1750
C
11500	O2=O1
C						!YES, USE AS DIRECT OBJ.
	P2=OPREP
	O1=OSLOT
	P1=0
	GO TO 1750
C
C 12000--	TRUE HANGING PREPOSITION.
C		ORPHAN FOR LATER.
C
12000	CALL ORPHAN(-1,ACT,0,PREP,0)
C						!ORPHAN PREP.
	GO TO 1750
C
	END