PROGRAM ADVENT
C  ADVENTURES

C  CURRENT LIMITS:
C	750 TRAVEL OPTIONS (TRAVEL, TRVSIZ).
C	300 VOCABULARY WORDS (KTAB, ATAB, TABSIZ).
C	150 LOCATIONS (LTEXT, STEXT, KEY, COND, ABB, ATLOC, LOCSIZ).
C	100 OBJECTS (PLAC, PLACE, FIXD, FIXED, LINK (TWICE), PTEXT, PROP).
C	 35 "ACTION" VERBS (ACTSPK, VRBSIZ).
C	205 RANDOM MESSAGES (RTEXT, RTXSIZ).
C	 12 DIFFERENT PLAYER CLASSIFICATIONS (CTEXT, CVAL, CLSMAX).
C	 20 HINTS, LESS 3 (HINTLC, HINTED, HINTS, HNTSIZ).
C	 35 MAGIC MESSAGES (MTEXT, MAGSIZ).
C  THERE ARE ALSO LIMITS WHICH CANNOT BE EXCEEDED DUE TO THE STRUCTURE OF
C  THE DATABASE.  (E.G., THE VOCABULARY USES N/1000 TO DETERMINE WORD TYPE,
C  SO THERE CAN'T BE MORE THAN 1000 WORDS.)  THESE UPPER LIMITS ARE:
C	1000 NON-SYNONYMOUS VOCABULARY WORDS
C	300 LOCATIONS
C	100 OBJECTS

	IMPLICIT INTEGER*2(A-Z)
	INTEGER*4 TRAVEL,ATAB,NXTLOC,WD1,WD1X,WD2,WD2X,NEWLOC
	BYTE LINES,STRING
	LOGICAL DSEEN,BLKLIN,HINTED,YES,START
	LOGICAL TOTING,HERE,AT,BITSET,DARK,WZDARK,LMWARN,CLOSNG,PANIC,
	1       CLOSED,GAVEUP,SCORNG,DEMO,YEA

	COMMON /TXTCOM/ RTEXT(205),LINES(72),ASCVAR,STRING(20)
	COMMON /BLKCOM/ BLKLIN
	COMMON /VOCCOM/ KTAB(300),ATAB(300),TABSIZ
	COMMON /PLACOM/ ATLOC(150),LINK(200),PLACE(100),FIXED(100),HOLDNG
	COMMON /PTXCOM/ PTEXT(100)
	COMMON /ABBCOM/ ABB(150)
	COMMON /MISCOM/ LINUSE,TRVS,CLSSES,OLDLOC,LOC,CVAL,TK,NEWLOC,
	1KEY,PLAC,FIXD,ACTSPK,COND,HINTS,HNTMAX,PROP,TALLY,TALLY2,
	2HINTLC,CHLOC,CHLOC2,DSEEN,DFLAG,DLOC,DALTLC,KEYS,LAMP,GRATE,
	3CAGE,ROD,ROD2,STEPS,BIRD,DOOR,PILLOW,SNAKE,FISSUR,TABLET,
	4CLAM,OYSTER,MAGZIN,DWARF,KNIFE,FOOD,BOTTLE,WATER,OIL,PLANT,
	5PLANT2,AXE,MIRROR,DRAGON,CHASM,TROLL,TROLL2,BEAR,MESSAG,VEND,
	6BATTER,NUGGET,COINS,CHEST,EGGS,TRIDNT,VASE,EMRALD,PYRAM,
	7PEARL,RUG,CHAIN,BACK,LOOK,CAVE,NULL,ENTRNC,DPRSSN,SAY,LOCK,
	8THROW,FIND,INVENT,TURNS,LMWARN,IWEST,KNFLOC,DETAIL,ABBNUM,
	9NUMDIE,MAXDIE,DKILL,FOOBAR,BONUS,CLOCK1,CLOCK2,
	1CLOSNG,PANIC,CLOSED,GAVEUP,SCORNG
	COMMON /MISC2/ I,RTXSIZ,CLSMAX,MAGSIZ,LOCSIZ,CTEXT,STEXT,LTEXT,
	1SECT,TRAVEL,TRVSIZ,TABNDX,OBJ,J,K,VERB,HNTSIZ,MAXTRS,
	2HINTED,HNTLOC,KK

	DIMENSION TRAVEL(750)
	DIMENSION LTEXT(150),STEXT(150),KEY(150),COND(150)
	DIMENSION PLAC(100),FIXD(100),PROP(100)
	DIMENSION ACTSPK(35)
	DIMENSION CTEXT(12),CVAL(12)
	DIMENSION HINTLC(20),HINTED(20),HINTS(20,4)
	DIMENSION TK(20),DSEEN(6),DLOC(6),ODLOC(6),HNAME(4)

	LINSIZ = 9650
	TRVSIZ = 750
	TABSIZ = 300
	LOCSIZ = 150
	VRBSIZ = 35
	RTXSIZ = 205
	CLSMAX = 12
	HNTSIZ = 20
	MAGSIZ = 35
	SETUP = 0
	CALL ERRSET(75,.TRUE.,.FALSE.,.FALSE.,.FALSE.,31000)
	CALL INIT
	CALL MAIN
	END
	SUBROUTINE A5TOA1(A,B,C,MSG,K)

C
C  IN ORDER TO WORK ON A PDP-11, THIS HAS BEEN CHANGED TO BE
C  AN A4 TO A1 CONVERSION ROUTINE.
C  A AND B CONTAIN A 1- TO 8-CHARACTER WORD IN 4A1 FORMAT, C CONTAINS ANOTHER
C  WORD AND/OR PUNCTUATION.  THEY ARE UNPACKED TO ONE CHARACTER PER BYTE IN THE
C  ARRAY "MSG", WITH EXACTLY ONE BLANK BETWEEN B AND C (OR NONE, IF C 'S 100
C  BIT IS OFF).
C  THE INDEX OF THE LAST NON-BLANK CHAR IN CHARS IS RETURNED IN K.

	IMPLICIT INTEGER(A-Z)
	BYTE A(4),B(4),C(8),MSG(20)

	K = 0
	DO 2 I=1,4
	IF(A(I).LE.' ') GO TO 6
	K = K+1
2	MSG(K) = A(I)

	DO 4 I=1,4
	IF(B(I).LE.' ') GO TO 6
	K = K+1
4	MSG(K) = B(I)

6	IF(C(1).LE.' ') RETURN
	IF(C(1).LT.'A') GO TO 10 	!PUNCTUATION
	K = K+1
	MSG(K) = ' '

10	DO 12 I=1,8
	IF(C(I).LE.' ') RETURN
	K = K+1
12	MSG(K) = C(I)
	RETURN

	END


	FUNCTION VOCAB(ID,INIT)

C  LOOK UP ID IN THE VOCABULARY (ATAB) AND RETURN ITS "DEFINITION" (KTAB), OR
C  -1 IF NOT FOUND.  IF INIT IS POSITIVE, THIS IS AN INITIALISATION CALL SETTING
C  UP A KEYWORD VARIABLE, AND NOT FINDING IT CONSTITUTES A BUG.  IT ALSO MEANS
C  THAT ONLY KTAB VALUES WHICH TAKEN OVER 1000 EQUAL INIT MAY BE CONSIDERED.
C  (THUS "STEPS", WHICH IS A MOTION VERB AS WELL AS AN OBJECT, MAY BE LOCATED
C  AS AN OBJECT.)  AND IT ALSO MEANS THE KTAB VALUE IS TAKEN MOD 1000.

	IMPLICIT INTEGER(A-Z)
	INTEGER*4 ATAB,ID,HASH
	COMMON /VOCCOM/ KTAB(300),ATAB(300),TABSIZ

	HASH=ID
	DO 1 I=1,TABSIZ
	IF(KTAB(I).EQ.-1)GOTO 2
	IF(INIT.GE.0.AND.KTAB(I)/1000.NE.INIT)GOTO 1
	IF(ATAB(I).EQ.HASH)GOTO 3
1	CONTINUE
	CALL BUG(21)

2	VOCAB=-1
	IF(INIT.LT.0)RETURN
	TYPE 100,HASH
100	FORMAT(' KEYWORD = ',A4)
	CALL BUG(5)

3	VOCAB=KTAB(I)
	IF(INIT.GE.0)VOCAB=MOD(VOCAB,1000)
	RETURN
	END


	SUBROUTINE DSTROY(OBJECT)

C  PERMANENTLY ELIMINATE "OBJECT" BY MOVING TO A NON-EXISTENT LOCATION.
	IMPLICIT INTEGER(A-Z)
	COMMON/PLACOM/ATLOC(150),LINK(200),PLACE(100),FIXED(100),HOLDNG
	CALL MOVE(OBJECT,0)
	RETURN


	ENTRY JUGGLE(OBJECT)

C  JUGGLE AN OBJECT BY PICKING IT UP AND PUTTING IT DOWN AGAIN, THE PURPOSE
C  BEING TO GET THE OBJECT TO THE FRONT OF THE CHAIN OF THINGS AT ITS LOC.
	I=PLACE(OBJECT)
	J=FIXED(OBJECT)
	CALL MOVE(OBJECT,I)
	CALL MOVE(OBJECT+100,J)
	RETURN



	ENTRY CARRY(OBJECT,WHERE)

C  START TOTING AN OBJECT, REMOVING IT FROM THE LIST OF THINGS AT ITS FORMER
C  LOCATION.  INCR HOLDNG UNLESS IT WAS ALREADY BEING TOTED.  IF OBJECT>100
C  (MOVING "FIXED" SECOND LOC), DON'T CHANGE PLACE OR HOLDNG.
	IF(OBJECT.GT.100)GOTO 5
	IF(PLACE(OBJECT).EQ.-1)RETURN
	PLACE(OBJECT)=-1
	HOLDNG=HOLDNG+1
5	IF(ATLOC(WHERE).NE.OBJECT)GOTO 6
	ATLOC(WHERE)=LINK(OBJECT)
	RETURN
6	TEMP=ATLOC(WHERE)
7	IF(LINK(TEMP).EQ.OBJECT)GOTO 8
	TEMP=LINK(TEMP)
	GOTO 7
8	LINK(TEMP)=LINK(OBJECT)
	RETURN



	ENTRY DROP(OBJECT,WHERE)

C  PLACE AN OBJECT AT A GIVEN LOC, PREFIXING IT ONTO THE ATLOC LIST.  DECR
C  HOLDNG IF THE OBJECT WAS BEING TOTED.
	IF(OBJECT.GT.100)GOTO 1
	IF(PLACE(OBJECT).EQ.-1)HOLDNG=HOLDNG-1
	PLACE(OBJECT)=WHERE
	GOTO 2
1	FIXED(OBJECT-100)=WHERE
2	IF(WHERE.LE.0)RETURN
	LINK(OBJECT)=ATLOC(WHERE)
	ATLOC(WHERE)=OBJECT
	RETURN
	END


	SUBROUTINE MOVE(OBJECT,WHERE)

C  PLACE ANY OBJECT ANYWHERE BY PICKING IT UP AND DROPPING IT.  MAY ALREADY BE
C  TOTING, IN WHICH CASE THE CARRY IS A NO-OP.  MUSTN'T PICK UP OBJECTS WHICH
C  ARE NOT AT ANY LOC, SINCE CARRY WANTS TO REMOVE OBJECTS FROM ATLOC CHAINS.

	IMPLICIT INTEGER(A-Z)
	COMMON/PLACOM/ATLOC(150),LINK(200),PLACE(100),FIXED(100),HOLDNG

	IF(OBJECT.GT.100)GOTO 1
	FROM=PLACE(OBJECT)
	GOTO 2
1	FROM=FIXED(OBJECT-100)
2	IF(FROM.GT.0.AND.FROM.LE.300)CALL CARRY(OBJECT,FROM)
	CALL DROP(OBJECT,WHERE)
	RETURN
	END



	INTEGER FUNCTION PUT(OBJECT,WHERE,PVAL)

C  PUT IS THE SAME AS MOVE, EXCEPT IT RETURNS A VALUE USED TO SET UP THE
C  NEGATED PROP VALUES FOR THE REPOSITORY OBJECTS.

	IMPLICIT INTEGER(A-Z)

	CALL MOVE(OBJECT,WHERE)
	PUT=(-1)-PVAL
	RETURN
	END


	INTEGER FUNCTION RAN(N)
	IMPLICIT INTEGER(A-Z)
	CALL TICK(TICKS)
	RAN = MOD(TICKS,N)
	RETURN
	END



	LOGICAL FUNCTION PCT(N)
	CALL TICK(ITICK)
	PCT = 100*ITICK .LE. 59*N
	RETURN
	END



	SUBROUTINE BUG(NUM)
	IMPLICIT INTEGER(A-Z)

C  THE FOLLOWING CONDITIONS ARE CURRENTLY CONSIDERED FATAL BUGS.  NUMBERS < 20
C  ARE DETECTED WHILE READING THE DATABASE; THE OTHERS OCCUR AT "RUN TIME".
C	0	MESSAGE LINE > 70 CHARACTERS
C	1	NULL LINE IN MESSAGE
C	2	TOO MANY WORDS OF MESSAGES
C	3	TOO MANY TRAVEL OPTIONS
C	4	TOO MANY VOCABULARY WORDS
C	5	REQUIRED VOCABULARY WORD NOT FOUND
C	6	TOO MANY RTEXT OR MTEXT MESSAGES
C	7	TOO MANY HINTS
C	8	LOCATION HAS COND BIT BEING SET TWICE
C	9	INVALID SECTION NUMBER IN DATABASE
C	20	SPECIAL TRAVEL (500>L>300) EXCEEDS GOTO LIST
C	21	RAN OFF END OF VOCABULARY TABLE
C	22	VOCABULARY TYPE (N/1000) NOT BETWEEN 0 AND 3
C	23	INTRANSITIVE ACTION VERB EXCEEDS GOTO LIST
C	24	TRANSITIVE ACTION VERB EXCEEDS GOTO LIST
C	25	CONDITIONAL TRAVEL ENTRY WITH NO ALTERNATIVE
C	26	LOCATION HAS NO TRAVEL ENTRIES
C	27	HINT NUMBER EXCEEDS GOTO LIST
C	28	INVALID MONTH RETURNED BY DATE FUNCTION

	TYPE 1, NUM
1	FORMAT (' FATAL ERROR, SEE SOURCE CODE FOR INTERPRETATION.'/
	1	' PROBABLY CAUSE: ERRONEOUS INFO IN DATABASE.'/
	2	' ERROR CODE =',I2/)
	STOP
	END
	SUBROUTINE RSPEAK(RMSG)
	IMPLICIT INTEGER(A-Z)
	BYTE LINES
	COMMON/TXTCOM/RTEXT(205),LINES(72),ASCVAR
	COMMON/PTXCOM/PTEXT(100)
	INTEGER*4 W1,W2
	EQUIVALENCE (W1,LINES),(W2,LINES(5))

	IF(RMSG.EQ.0) RETURN
	N = RTEXT(RMSG)
	GO TO 2



	ENTRY PSPEAK(PMSG,SKIP)
	N = PTEXT(PMSG)
	IF(SKIP.GE.0) N = N + SKIP + 1
20	READ(2'N) LOC,LINES
	IF(SKIP.LT.0.OR.(LOC.EQ.100*SKIP)) GO TO 4
	N = N+1
	GO TO 20



	ENTRY SPEAK(MSG)
	N = MSG
2	IF(N.EQ.0)RETURN
	READ(2'N) LOC,LINES
4	IF((W1.EQ.'>$<').OR.(W2.EQ.'>$<')) RETURN
	OLDLOC = LOC
6	DO 8 I=72,1,-1
	L = I
	IF(LINES(I) .NE. ' ') GO TO 10
8	CONTINUE
10	TYPE 101, (LINES(I),I=1,L)
101	FORMAT(' ',72A1)
	READ(2'ASCVAR) LOC,LINES
	IF(LOC .EQ. OLDLOC) GO TO 6
	RETURN
	END


	SUBROUTINE GETIN(WORD1,WORD1X,WORD2,WORD2X)

C  GET A COMMAND FROM THE ADVENTURER.  SNARF OUT THE FIRST WORD, PAD IT WITH
C  BLANKS, AND RETURN IT IN WORD1.  CHARS 5 THRU 8 ARE RETURNED IN WORD1X, IN
C  CASE WE NEED TO PRINT OUT THE WHOLE WORD IN AN ERROR MESSAGE.  ANY NUMBER OF
C  BLANKS MAY FOLLOW THE WORD.  IF A SECOND WORD APPEARS, IT IS RETURNED IN
C  WORD2 (CHARS 5 THRU 8 IN WORD2X), ELSE WORD2 IS SET TO ZERO.
	IMPLICIT INTEGER(A-V,Y-Z)
	IMPLICIT INTEGER*4(W)
	BYTE A(20),C(8)
	EQUIVALENCE (C,W1),(C(5),W2)

2	ACCEPT 101, A
101	FORMAT(20A1)
	W1 = '    '
	W2 = W1
	WORD2 = 0
	WORD2X = 0

	DO 4 J=1,20
4	IF(A(J).NE.' ') GO TO 6
	GO TO 2 			!IGNORE BLANK LINE

6	J = J-1
	DO 8 I=1,8
	J = J+1
	IF(J.GT.20) GO TO 10
	IF(A(J).EQ.' ') GO TO 10
8	C(I) = A(J)
10	WORD1 = W1
	WORD1X = W2

12	IF(J.GE.20) RETURN
	IF(A(J).EQ.' ') GO TO 14
	J = J+1
	GO TO 12

14	J = J+1
	IF(J.GT.20) RETURN
	IF(A(J).EQ.' ') GO TO 14
	W1 = '    '
	W2 = W1

	K = 0
	JJ = J+7
	IF(JJ.GT.20) JJ = 20
	DO 16 I=J,JJ
	K = K+1
	IF(A(I).LE.' ') GO TO 18
16	C(K) = A(I)
18	WORD2 = W1
	WORD2X = W2
	RETURN
	END



	LOGICAL FUNCTION YES(X,Y,Z)

C  PRINT MESSAGE X, WAIT FOR YES/NO ANSWER.  IF YES, PRINT Y AND LEAVE YEA
C  TRUE; IF NO, PRINT Z AND LEAVE YEA FALSE.
	IMPLICIT INTEGER(A-Z)
	INTEGER*4 REPLY,JUNK1,JUNK2,JUNK3

1	IF(X.NE.0)CALL RSPEAK(X)
	CALL GETIN(REPLY,JUNK1,JUNK2,JUNK3)
	IF(REPLY.EQ.'YES'.OR.REPLY.EQ.'Y')GOTO 10
	IF(REPLY.EQ.'NO'.OR.REPLY.EQ.'N')GOTO 20
	TYPE 9
9	FORMAT(' PLEASE ANSWER THE QUESTION.')
	GOTO 1
10	YES=.TRUE.
	IF(Y.NE.0)CALL RSPEAK(Y)
	RETURN
20	YES=.FALSE.
	IF(Z.NE.0)CALL RSPEAK(Z)
	RETURN
	END