File: ASUB.FT of Tape: Sources/Other/new-16

(Source file text) 

---

C SUBROUTINES FOR ADVENTURE
C
C MODIFIED FOR PDP-11 FORTRAN IV BY
C
C	R. SUPNIK
C	DISK ENGINEERING
C
	SUBROUTINE A5TOA1(A,B,C,D)
C
C THIS ROUTINE TAKES THE UP TO 6 CHARACTER "WORD" IN A:B:C
C AND TYPES IT OUT, FOLLOWED BY THE PUNCTUATION MARK IN D.
C IT ALSO APPENDS A CRLF TO GET TO A NEW LINE.
C
	IMPLICIT INTEGER (A-Z)
	COMMON /ALPHAS/ BLANK
C
	IF(A .NE. BLANK) TYPE 1,A
	IF(B .NE. BLANK) TYPE 1,B
	IF(C .NE. BLANK) TYPE 1,C
	TYPE 2,D
	RETURN
C
1	FORMAT('+',A2,$)
2	FORMAT('+',A2)
C
	END
C  DATA STRUCTURE ROUTINES (VOCAB, DSTROY, JUGGLE, MOVE, PUT, CARRY, DROP)
C
C
	SUBROUTINE VOCAB(ID1,ID2,INIT,V)
C
C  LOOK UP ID1:ID2 IN THE VOCABULARY (ATAB AND A2TAB)
C  AND RETURN ITS "DEFINITION" (KTAB), OR
C  -1 IF NOT FOUND.  IF INIT IS POSITIVE, THIS IS AN INIT 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.
C
	IMPLICIT INTEGER (A-Z)
	COMMON /VOCCOM/ KTAB,ATAB,A2TAB,TABSIZ
	DIMENSION KTAB(300),ATAB(300),A2TAB(300)
C
	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.ID1 .AND. A2TAB(I).EQ.ID2)GOTO 3
1	CONTINUE
	CALL BUG(21)
C
2	V=-1
	IF(INIT.LT.0)RETURN
	TYPE 100,ID1,ID2
100	FORMAT(' KEYWORD = ',2A2)
	CALL BUG(5)
C
3	V=KTAB(I)
	IF(INIT.GE.0)V=MOD(V,1000)
	RETURN
	END
C
C
C
	SUBROUTINE DSTROY(OBJECT)
C
C  PERMANENTLY ELIMINATE "OBJECT" BY MOVING TO A NON-EXISTENT LOCATION.
C
	IMPLICIT INTEGER (A-Z)
C
	CALL MOVE(OBJECT,0)
	RETURN
	END
C
C
C
	SUBROUTINE JUGGLE(OBJECT)
C
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.
C
	IMPLICIT INTEGER (A-Z)
	COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
	DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
C
	I=PLACE(OBJECT)
	J=FIXED(OBJECT)
	CALL MOVE(OBJECT,I)
	CALL MOVE(OBJECT+100,J)
	RETURN
	END
C
C
C
	SUBROUTINE MOVE(OBJECT,WHERE)
C
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.
C
	IMPLICIT INTEGER (A-Z)
	COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
	DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
C
	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
C
C
C
	INTEGER FUNCTION PUT(OBJECT,WHERE,PVAL)
C
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.
C
	IMPLICIT INTEGER (A-Z)
C
	CALL MOVE(OBJECT,WHERE)
	PUT=(-1)-PVAL
	RETURN
	END
C
C
C
	SUBROUTINE CARRY(OBJECT,WHERE)
C
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.
C
	IMPLICIT INTEGER (A-Z)
	COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
	DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
C
	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
	END
C
C
C
	SUBROUTINE DROP(OBJECT,WHERE)
C
C  PLACE AN OBJECT AT A GIVEN LOC, PREFIXING IT ONTO THE ATLOC LIST.  DECR
C  HOLDNG IF THE OBJECT WAS BEING TOTED.
C
	IMPLICIT INTEGER (A-Z)
	COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
	DIMENSION ATLOC(150)
	DIMENSION LINK(200)
	DIMENSION PLACE(100)
	DIMENSION FIXED(100)
C
	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
C UTILITY ROUTINES (RND, BUG)
C
	INTEGER FUNCTION RND(RANGE)
C
C A VARIANT USING THE RANDOM NUMBER GENERATOR IN FORLIB.
C
	IMPLICIT INTEGER (A-Z)
	REAL RAN
	DATA R/0/
C
	IF(R.NE.0) GO TO 1
	R=1
	CALL IDATE(I,J,K)
	I= I.OR.K
	J= J.OR.K
1	RND= RAN(I,J) *FLOAT(RANGE)
C
	RETURN
	END
C
C
C
C
	SUBROUTINE BUG(NUM)
	IMPLICIT INTEGER (A-Z)
C
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
C
	TYPE 1, NUM
1	FORMAT (' FATAL ERROR ',I3,', CONSULT YOUR LOCAL WIZARD.'/)
	STOP
	END

---