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*2 (A-Z) COMMON /ALPHAS/ BLANK C IF(A .NE. BLANK) write(*,1)A IF(B .NE. BLANK) write(*,1)B IF(C .NE. BLANK) write(*,1)C write(*,2)D RETURN C C The following two formats are modified to match what MSF77 needs c1 FORMAT('+',A2,$) c2 FORMAT('+',A2) 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*2 (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 write(*,*)'id1,id2,init,v,tabsiz=',id1,id2,init,v,tabsiz write(*,999)id1,id2 999 format(' id1//id2 =',2a2) CALL BUG(int2(21)) C 2 V=-1 IF(INIT.LT.0)RETURN write(*,100)ID1,ID2 100 FORMAT(' KEYWORD = ',2A2) CALL BUG(int2(5)) C 3 V=KTAB(I) IF(INIT.GE.0)V=MOD(V,1000) RETURN END SUBROUTINE DSTROY(OBJECT) C C PERMANENTLY ELIMINATE "OBJECT" BY MOVING TO A NON-EXISTENT LOCATION. C IMPLICIT INTEGER*2 (A-Z) C CALL MOVE(OBJECT,int2(0)) RETURN END 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*2 (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(int2(OBJECT+100),J) RETURN END 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*2 (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 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*2 (A-Z) C CALL MOVE(OBJECT,WHERE) PUT=(-1)-PVAL RETURN END 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*2 (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 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*2 (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 SUBROUTINE BUG(NUM) IMPLICIT INTEGER*2 (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 10 INVALID ACTSPK (VERB) NUMBER C 11 TOO MANY LOCATION (LTEXT OR STEXT) ENTRIES C 12 TOO MANY PLAYER CLASSES C 13 INVALID OBJECT NUMBER 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 write(*,1) NUM 1 FORMAT (/' Fatal error ',I3,'. Consult your local wizard.'/) stop 'Better luck next time' END C C C The following random number generator and its seed call are from C MSF77 version 5. Adventure does not run under that version; it C seems to work only under 4.01. The module RANDOM.OBJ has been C extracted from V5 LLIBFORE.LIB and is included in the link list. C SUBROUTINE INIRND IMPLICIT INTEGER*2 (A-Z) C C Initializes the MSF77 V5 random generator. Seed is an integer C from 0 to a bit over 10000. Multiply the clock 100ths by 100 C to do this. C call gettim(ihr,imin,isec,i100th) iseed=100*i100th call seed(iseed) RETURN END C INTEGER FUNCTION RND(RANGE) IMPLICIT INTEGER*2 (A-Z) real ran C C Uses MSF77 V5 random number generator C call random(ran) RND=RAN *FLOAT(RANGE) RETURN END