C*** A5TOA1 SUBROUTINE A5TOA1(A,B,C,QQ,LENG) C A AND B CONTAIN A 1- TO 12-CHARACTER WORD IN A6 FORMAT, C CONTAINS ANOTHER C WORD AND/OR PUNCTUATION. THEY ARE UNPACKED TO ONE CHARACTER PER WORD IN THE C ARRAY "CHARS". C THE INDEX OF THE LAST NON-BLANK CHAR IN CHARS IS RETURNED IN LENG. IMPLICIT INTEGER(A-Z) CHARACTER*6 A,B,C CHARACTER QQ(20) DO 300 JJ=1,6 QQ(JJ)=A(JJ:JJ) 300 QQ(JJ+6)=B(JJ:JJ) DO 5 I=1,12 IF(QQ(I).EQ.' ')GOTO 10 5 CONTINUE LENG=12 GOTO 15 10 CONTINUE LENG=I-1 15 DO 20 I=1,6 IF(C(I:I).NE.' ')THEN LENG=LENG+1 QQ(LENG) = C(I:I) ENDIF 20 CONTINUE DO 21 I= LENG+1,20 21 QQ(I) = ' ' DO 22 I= 1,20 22 IF(QQ(I).EQ.'_')QQ(I) = ' ' RETURN END C*** AJAR .TRUE. IF OBJ IS CONTAINER AND IS OPEN C THE NEXT LOGICAL FUNCTIONS DESCRIBE ATTRIBUTES OF OBJECTS. C (AJAR, HINGED, OPAQUE, PRINTD, TREASR, VESSEL, WEARNG) LOGICAL FUNCTION AJAR(OBJ) C AJAR(OBJ) = TRUE IF OBJECT IS AN OPEN OR UNHINGED CONTAINER. IMPLICIT INTEGER(A-Z) LOGICAL BITSET,HINGED,VESSEL COMMON /BITCOM/ OPENBT,UNLKBT,BURNBT,WEARBT COMMON /CONCOM/ LOCCON(250),OBJCON(150) AJAR=BITSET(OBJCON(OBJ),OPENBT).OR. 1 (VESSEL(OBJ).AND..NOT.HINGED(OBJ)) RETURN END C*** AT .TRUE. IF AT OBJ LOGICAL FUNCTION AT(OBJ) C AT(OBJ) = TRUE IF ON EITHER SIDE OF TWO-PLACED OBJECT IMPLICIT INTEGER(A-Z) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ AT = .FALSE. IF(OBJ.LT.1.OR.OBJ.GT.MAXOBJ)RETURN AT=PLACE(OBJ).EQ.LOC.OR.FIXED(OBJ).EQ.LOC RETURN END C*** ATHAND .TRUE. IF OBJ READILY AVAILABLE LOGICAL FUNCTION ATHAND(OBJ) C ATHAND(OBJ) = TRUE IF OBJ IS READILY REACHABLE. C IT CAN BE LYING HERE, IN HAND OR IN OPEN CONTAINER. IMPLICIT INTEGER(A-Z) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ LOGICAL TOTING,AJAR,ENCLSD,HOLDNG,AAA ATHAND = .FALSE. IF(PLACE(OBJ).EQ.LOC.OR.HOLDNG(OBJ))THEN ATHAND = .TRUE. RETURN ENDIF IF(.NOT.ENCLSD(OBJ))RETURN CONTNR=-PLACE(OBJ) ATHAND= 1 (AJAR(CONTNR).AND. 2 (PLACE(CONTNR).EQ.LOC.OR. 3 (TOTING(OBJ).AND.HOLDNG(CONTNR)))) RETURN END C*** BITOFF SUBROUTINE BITOFF(OBJ,BIT) C TURNS OFF (SETS=0) A BIT IN OBJCON. IMPLICIT INTEGER(A-Z) COMMON /CONCOM/ LOCCON(250),OBJCON(150) C OBJCON(OBJ)=IAND(OBJCON(OBJ),INOT(BITS(BIT))) C THE FOLLOWING SHOULD BE EQUIVALENT TO THE ABOVE OBJCON(OBJ)=IOR(OBJCON(OBJ),(BITS(BIT)))-BITS(BIT) RETURN END C*** BITON SUBROUTINE BITON(OBJ,BIT) C TURNS ON (SETS=1) A BIT IN OBJCON. IMPLICIT INTEGER(A-Z) COMMON /CONCOM/ LOCCON(250),OBJCON(150) OBJCON(OBJ)=IOR(OBJCON(OBJ),BITS(BIT)) RETURN END C*** BITS INTEGER FUNCTION BITS(SHIFT) IMPLICIT INTEGER (A-Z) BITS=(2**SHIFT) RETURN END C*** BITSET C MISCELLANEOUS LOGICAL FUNCTIONS (BITSET, PCT) C ALSO, SUBROUTINES FOR TURNING BITS ON AND OFF (BITON, BITOFF). LOGICAL FUNCTION BITSET(WORD,N) C BITSET(COND,L,N) = TRUE IF COND(L) HAS BIT N SET IMPLICIT INTEGER(A-Z) BITSET=IAND(WORD,2**N).NE.0 5 RETURN END C*** BLIND .TRUE. IF YOU CAN'T SEE AT THIS LOC C LOCATION ATTRIBUTES. (BLIND, DARK, FORCED, INSIDE, OUTSID, PORTAL) LOGICAL FUNCTION BLIND(DUMMY) C TRUE IF ADVENTURER IS "BLIND" AT THIS LOC, (DARKNESS OR GLARE) IMPLICIT INTEGER(A-Z) COMMON /CONCOM/ LOCCON(250),OBJCON(150) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150), 1 POINTS(150) LOGICAL DARK,ATHAND DATA LAMP /2/ BLIND=DARK(0).OR.(LOC.EQ.200.AND.ATHAND(LAMP).AND.PROP(LAMP) 1 .EQ.1) RETURN END C*** BUG 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 10 OUT OF ORDER LOCS OR RSPEAK ENTRIES. C 11 ILLEGAL MOTION WORD IN TRAVEL TABLE C 12 ** UNUSED **. C 13 UNKNOWN OR ILLEGAL WORD IN ADJECTIVE TABLE. C 14 ILLEGAL WORD IN PREP/OBJ TABLE C 15 TOO MANY ENTRIES IN PREP/OBJ TABLE C 16 OBJECT HAS CONDITION BIT SET TWICE C 17 OBJECT NUMBER TOO LARGE C 18 TOO MANY ENTRIES IN ADJECTIVE/NOUN TABLE. C 20 SPECIAL TRAVEL (500>L>300) EXCEEDS GOTO LIST C 21 RAN OFF END OF VOCABULARY TABLE C 22 VERB CLASS (N/1000) NOT BETWEEN 1 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 29 ACTION VERB 'LEAVE' HAS NO OBJECT. C 30 PREPOSITION FOUND IN UNEXPECTED TABLE C 31 RECEIVED AN UNEXPECTED WORD TERMINATOR FROM A1TOA5 C 32 TRYING TO PUT A CONTAINER INTO ITSELF (TRICKY!) C 33 UNKNOWN WORD CLASS IN GETWDS C 35 TRYING TO CARRY A NON-EXISTENT OBJECT WRITE(*,1) NUM 1 FORMAT (' FATAL ERROR, SEE SOURCE CODE FOR INTERPRETATION.'/ 1 ' PROBABLE CAUSE: ERRONEOUS INFO IN DATABASE OR BAD ASAVE.DAT'/ 2 ' ERROR CODE =',I2/) STOP END C*** BURDEN .. RETURNS WEIGHT OF ITEMS BEING CARRIED INTEGER FUNCTION BURDEN(OBJ) C IF OBJ=0, BURDEN CALCULATES THE TOTAL WEIGHT OF THE ADVENTURER'S BURDEN, C INCLUDING EVERYTHING IN ALL CONTAINERS (EXCEPT THE BOAT) THAT HE IS C CARRYING. C IF OBJ#0 AND OBJ IS A CONTAINER, CALCULATE THE WEIGHT OF EVERYTHING INSIDE C THE CONTAINER (INCLUDING THE CONTAINER ITSELF). SINCE DONKEY FORTRAN C ISN'T RECURSIVE, WE WILL ONLY CALCULATE WEIGHTS OF CONTAINED CONTAINERS C ONE LEVEL DOWN. THE ONLY SERIOUS CONTAINED CONTAINER WOULD BE THE SACK C THE ONLY THINGS WE'LL MISS WILL BE FILLED VS EMPTY BOTTLE OR CAGE. C IF OBJ#0 AND ISN'T A CONTAINER, RETURN ITS WEIGHT. IMPLICIT INTEGER(A-Z) COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150), 1 POINTS(150) COMMON /HLDCOM/ HOLDER(150),HLINK(150) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ LOGICAL TOTING,WEARNG DATA BOAT /48/ BURDEN=0 IF(OBJ.NE.0)GOTO 200 DO 100 I=1,MAXOBJ IF(.NOT.TOTING(I).OR.PLACE(I).EQ.-BOAT)GOTO 100 BURDEN=BURDEN+WEIGHT(I) 100 CONTINUE RETURN 200 BURDEN=WEIGHT(OBJ) IF(OBJ.EQ.BOAT)RETURN TEMP=HOLDER(OBJ) 210 IF(TEMP.EQ.0)RETURN BURDEN=BURDEN+WEIGHT(TEMP) TEMP=HLINK(TEMP) GOTO 210 END C*** CARRY SUBROUTINE CARRY(OBJECT,WHERE) C START TOTING AN OBJECT, REMOVING IT FROM THE LIST OF THINGS AT ITS FORMER C LOCATION. IF OBJECT>MAXOBJ (MOVING "FIXED" SECOND LOC), C DON'T CHANGE PLACE. IMPLICIT INTEGER(A-Z) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ IF(OBJECT.GT.MAXOBJ)GOTO 5 IF(PLACE(OBJECT).EQ.-1)RETURN PLACE(OBJECT)=-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) IF(TEMP.NE.0)GOTO 7 CALL BUG(35) 8 LINK(TEMP)=LINK(OBJECT) RETURN END C*** CLASS INTEGER FUNCTION CLASS(WORD) C RETURNS WORD CLASS NUMBER (1=MOTION VERB; 2=NOUN; 3=ACTION VERB; C 4=MISCELLANEOUS WORD; 5=PREPOSITION; 6=ADJECTIVE; 7=CONJUNCTION). IMPLICIT INTEGER(A-Z) CLASS=WORD/1000 +1 IF(WORD.LT.0)CLASS=-1 RETURN END C*** CLRLIN SUBROUTINE CLRLIN C CLEARS OUT ALL CURRENT SYNTAX ARGS IN PREPARATION FOR A NEW INPUT LINE IMPLICIT INTEGER(A-Z) CHARACTER*6 VTXT,OTXT,IOTXT,DTK,ATAB,TXT,ALLZERO COMMON /WRDCOM/ VERBS(45),VRBX,OBJS(45), 1 OBJX,IOBJS(15),IOBX,PREP,WORDS(45) COMMON /SV3COM/DTK(9),ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2) 1 ,TXT(35,2) DO 3333 I=1,6 3333 ALLZERO(I:I) = CHAR(0) DO 1 I=1,45 OBJS(I)=0 VERBS(I)=0 DO 1 J=1,2 1 VTXT(I,J)=ALLZERO DO 3 I=1,15 IOBJS(I)=0 DO 3 J=1,2 IOTXT(I,J)=ALLZERO 3 OTXT(I,J)=ALLZERO VRBX=0 OBJX=0 IOBX=0 PREP=0 RETURN END C*** CONFUZ INTEGER FUNCTION CONFUZ(DUMMY) C GENERATES SOME VARIANT OF "DON'T UNDERSTAND THAT" MESSAGE. IMPLICIT INTEGER(A-Z) LOGICAL PCT CONFUZ=60 IF(PCT(50))CONFUZ=61 IF(PCT(33))CONFUZ=13 IF(PCT(25))CONFUZ=347 IF(PCT(20))CONFUZ=195 RETURN END C*** DARK .TRUE. IF THERE IS NO LIGHT HERE LOGICAL FUNCTION DARK(DUMMY) C TRUE IF LOCATION "LOC" IS DARK IMPLICIT INTEGER(A-Z) COMMON /CONCOM/ LOCCON(250),OBJCON(150) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150), 1 POINTS(150) LOGICAL ATHAND DATA LAMP /2/ DARK=MOD(LOCCON(LOC),2).EQ.0.AND.(PROP(LAMP).EQ.0.OR. 1 .NOT.ATHAND(LAMP)) RETURN END C*** DEAD .TRUE. IF OBJ IS NOW DEAD LOGICAL FUNCTION DEAD(OBJ) IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON/CONCOM/LOCCON(250),OBJCON(150) DEAD=BITSET(OBJCON(OBJ),10) RETURN END C*** DROP SUBROUTINE DROP(OBJECT,WHERE) C PLACE AN OBJECT AT A GIVEN LOC, PREFIXING IT ONTO THE ATLOC LIST. IMPLICIT INTEGER(A-Z) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ IF(OBJECT.GT.MAXOBJ)GOTO 1 PLACE(OBJECT)=WHERE GOTO 2 1 FIXED(OBJECT-MAXOBJ)=WHERE 2 IF(WHERE.LE.0)RETURN LINK(OBJECT)=ATLOC(WHERE) ATLOC(WHERE)=OBJECT RETURN END C*** DSTROY SUBROUTINE DSTROY(OBJECT) C PERMANENTLY ELIMINATE "OBJECT" BY MOVING TO A NON-EXISTENT LOCATION. IMPLICIT INTEGER(A-Z) CALL MOVE(OBJECT,0) RETURN END C*** EDIBLE .TRUE. IF OBJ CAN BE EATEN LOGICAL FUNCTION EDIBLE(OBJ) IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON/CONCOM/LOCCON(250),OBJCON(150) EDIBLE=BITSET(OBJCON(OBJ),7) RETURN END C*** ENCLSD .TURE. IF OBJ INSIDE SOMETHING LOGICAL FUNCTION ENCLSD(OBJECT) C ENCLSD(OBJ) = TRUE IF THE OBJ IS IN A CONTAINER IMPLICIT INTEGER(A-Z) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ ENCLSD=.FALSE. IF(OBJECT.LT.1.OR.OBJECT.GT.MAXOBJ)RETURN ENCLSD=PLACE(OBJECT).LT.-1 RETURN END C*** FORCED LOGICAL FUNCTION FORCED(LOC) C A FORCED LOCATION IS ONE FROM WHICH HE IS IMMEDIATELY BOUNCED TO ANOTHER. C NORMAL USE IS FOR DEATH (FORCE TO LOC ZERO) AND FOR DESCRIPTIONS OF C JOURNEY FROM ONE PLACE TO ANOTHER. IMPLICIT INTEGER(A-Z) COMMON /CONCOM/ LOCCON(250),OBJCON(150) FORCED=LOCCON(LOC).EQ.2 RETURN END C*** GETLIN SUBROUTINE GETLIN IMPLICIT INTEGER(A-Z) LOGICAL BLKLIN COMMON /BLKCOM/ BLKLIN CHARACTER*6 TXT,WDS(2),KK,DTK,ATAB,VTXT,OTXT,IOTXT,TXT2(35,2) LOGICAL ACTIVE COMMON /UTXCOM/ WDX CHARACTER CHRS(150), CHR2(150),CHRX(70) COMMON /SV3COM/DTK(9),ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2) 1 ,TXT(35,2) 10 DO 15 I=1,35 DO 15 J=1,2 TXT2(I,J) = ' ' 15 TXT(I,J) = ' ' 20 IF(BLKLIN)WRITE(*,*)' ' WRITE(*,1266) 1266 FORMAT(' >') C??????????????????????????????? THE FOLLOWING WORKS ON MANY COMPUTERS: C1266 FORMAT(' >',$) 30 READ (*,50)CHRX 50 FORMAT(70A1) DO 1 I=1,70 CHRX(I) = CHAR(IAND(ICHAR(CHRX(I)), 127)) IF(CHRX(I).LT.' ')CHRX(I) = ' ' IF(CHRX(I).GE.'`')CHRX(I) = CHAR(ICHAR(CHRX(I)) - 32) 1 CONTINUE DO 4 I=1,70 IF(CHRX(I).NE.' ') GOTO 6 4 CONTINUE GOTO 20 6 CONTINUE INDX = 1 DO 2 I=1,70 IF(CHRX(I).EQ.'.'.OR.CHRX(I).EQ.';'.OR.CHRX(I).EQ.',')THEN CHR2(INDX) = ' ' INDX = INDX + 1 CHR2(INDX) = 'A' INDX = INDX + 1 CHR2(INDX) = 'N' INDX = INDX + 1 CHR2(INDX) = 'D' INDX = INDX + 1 CHR2(INDX) = ' ' INDX = INDX + 1 ELSE CHR2(INDX) = CHRX(I) INDX = INDX + 1 ENDIF 2 CONTINUE CHR2(INDX) = '.' DO 70 INDX2= 1,INDX 70 IF(CHR2(INDX2).NE.' ') GOTO 73 73 CONTINUE J = 1 DO 71 I = INDX2,INDX IF(I.NE.INDX2.AND.CHRS(J-1).EQ.' '.AND.CHR2(I).EQ.' ')GOTO71 CHRS(J) = CHR2(I) J = J+1 71 CONTINUE IF(CHRS(1).EQ.'.') GOTO 20 WDX = 1 J = 1 DO 100 I=1,100 IF(CHRS(I).EQ.'.') GO TO 200 IF(CHRS(I).EQ.' ') GO TO 120 IF(J.LE.6)TXT2(WDX,1)(J:J) = CHRS(I) IF(J.GT.6.AND.J.LE.12)TXT2(WDX,2)(J-6:J-6) = CHRS(I) J = J+1 GOTO 100 120 CONTINUE J = 1 WDX = WDX + 1 100 CONTINUE 200 CONTINUE TXT(1,1) = TXT2(1,1) TXT(1,2) = TXT2(1,2) J = 1 DO 210 I=2,35 IF(TXT(J,1).NE.'AND '.OR.TXT2(I,1).NE.'AND ')THEN J = J+1 TXT(J,1) = TXT2(I,1) TXT(J,2) = TXT2(I,2) ELSE WDX = WDX - 1 ENDIF 210 CONTINUE C WRITE(*,12345)(TXT(IQQ,1),IQQ = 1,35) C12345 FORMAT(' ',5A6) END C*** GETOBJ SUBROUTINE GETOBJ(OBJ) C ANALYSE AN OBJECT WORD. SEE IF THE THING IS HERE, WHETHER WE'VE GOT A VERB C YET, AND SO ON. OBJECT MUST BE HERE UNLESS VERB IS "FIND" OR "INVENT(ORY)" C (AND NO NEW VERB YET TO BE ANALYSED). WATER, OIL AND WINE ARE ALSO C FUNNY, SINCE THEY ARE NEVER ACTUALLY DROPPED AT ANY LOCATION, BUT MIGHT C BE HERE INSIDE THE BOTTLE OR AS A FEATURE OF THE LOCATION. C C HAS THREE POSSIBLE RETURN VALUES FOR 'OBJ': C VAL > 0 :: A POSITIVE OBJECT NUMBER C VAL = 0 :: OBJECT NOT FOUND HERE. ERROR MESSAGE PRINTED. C VAL < 0 :: OBJECT WORD REALLY SOMETHING ELSE. RETURN NEGATIVE C VALUE OF SUBSTITUTED WORD. IMPLICIT INTEGER(A-Z) LOGICAL AT CHARACTER ZAPP(20) COMMON /DWFCOM/ DWARF,KNIFE,KNFLOC,DFLAG,DSEEN(6),DLOC(6), 1 ODLOC(6),DWFMAX COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /MNECOM/ BACK,CAVE,DPRSSN,ENTRNC,EXIT,GO,LOOK,NULL, 1 AXE,BEAR,BOAT,BOOK,BOOK2,BOOTH,CARVNG,CHASM,CHASM2,DOOR,GNOME, 2 GRATE,LAMP,PDOOR,PLANT,PLANT2,ROCKS,ROD,ROD2,SAFE, 3 TDOOR,TDOOR2,TROLL,TROLL2,EMRALD,SPICES, 4 FIND,YELL,INVENT,LEAVE,POUR,SAY,TAKE,THROW, 5 IWEST,PHUCE(2,4),TK(20) COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150), 1 POINTS(150) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ CHARACTER*6 TXT COMMON /UTXCOM/ WDX CHARACTER*6 VTXT,OTXT,IOTXT,DTK,ATAB COMMON /WRDCOM/ VERBS(45),VRBX,OBJS(45), 1 OBJX,IOBJS(15),IOBX,PREP,WORDS(45) LOGICAL ATHAND,BLIND,HERE,HOLDNG,PLURAL COMMON /SV3COM/DTK(9),ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2) 1 ,TXT(35,2) IF(HOLDNG(OBJ))RETURN IF(BLIND(0))GOTO 280 IF(FIXED(OBJ).EQ.LOC.OR.ATHAND(OBJ))GOTO 290 IF(.NOT.HERE(OBJ))GOTO 205 K=335 IF(PLURAL(OBJ))K=373 OBJ=0 CALL RSPEAK(K) RETURN 205 IF(OBJ.NE.GRATE)GOTO 210 IF(LOC.EQ.1.OR.LOC.EQ.4.OR.LOC.EQ.7)OBJ=-DPRSSN IF(LOC.GT.9.AND.LOC.LT.15)OBJ=-ENTRNC IF(OBJ.EQ.GRATE)GOTO 280 RETURN 210 IF(OBJ.NE.DWARF)GOTO 220 L1=DWFMAX-1 DO 212 I=1,L1 IF(DLOC(I).EQ.LOC.AND.DFLAG.GE.2)GOTO 290 212 CONTINUE GOTO 280 220 IF(OBJ.EQ.LIQLOC(LOC).OR. 1 (ATHAND(BOTTLE).AND.LIQ(BOTTLE).EQ.OBJ).OR. 2 (ATHAND(CASK).AND.LIQ(CASK).EQ.OBJ))GOTO 290 IF(OBJ.NE.PLANT.OR..NOT.AT(PLANT2).OR.PROP(PLANT2).EQ.0)GOTO 230 OBJ=PLANT2 GOTO 290 230 IF(OBJ.NE.ROCKS.OR..NOT.AT(CARVNG))GOTO 240 OBJ=CARVNG GOTO 290 240 IF(OBJ.NE.ROD.OR..NOT.ATHAND(ROD2))GOTO 250 OBJ=ROD2 GOTO 290 250 IF(OBJ.NE.DOOR.OR..NOT. 1 (AT(SAFE).OR.AT(TDOOR).OR.AT(TDOOR2).OR.AT(PDOOR))) 2 GOTO 260 OBJ=TDOOR IF(AT(TDOOR2))OBJ=TDOOR2 IF(AT(PDOOR))OBJ=PDOOR IF(AT(SAFE))OBJ=SAFE GOTO 290 260 IF(OBJ.NE.BOOK.OR..NOT.ATHAND(BOOK2))GOTO 270 OBJ=BOOK2 GOTO 290 270 IF(VERBS(VRBX).EQ.FIND.OR.VERBS(VRBX).EQ.INVENT)GOTO 290 C IT ISN'T HERE. TELL HIM & RETURN. 280 OBJ=0 CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'_here.',ZAPP,K) WRITE(*,282)(ZAPP(I),I=1,K) 282 FORMAT(/' I see no ',20A1) 290 RETURN END C*** GETWDS SUBROUTINE GETWDS C WHEN CALLED, CHECKS IF PREVIOUS WORDS VECTOR HAS BEEN EXHAUSTED. C IF NOT, BRANCH AROUND THE CODE WHICH READS IN A NEW LINE. IF VECTOR IS EMPTY C SUCK UP A LINE FROM THE TTY, THEN CHECK EACH WORD FOR INTELLIGIBILITY. C IF THE WORD IS VALID, ITS NUMBER GETS STUCK INTO THE WORDS VECTOR. C THEN EACH WORD IS PARSED BY THE APPROPRIATE CODE. THE LABELS BELOW ARE C 100 TIMES THE WORD CLASS. C C THE FOLLOWING VECTORS ARE USED: C TXT(WDX,2) HOLD THE RAW TEXT FROM GETLIN C WORDS(WDX) LIST OF WORD NUMBERS, CONVERTED FROM TXT(WDX,1). C VTXT(VRBX,2) HOLD THE TEXT FOR VERB VRBX. C VERBS(VRBX) IS THE LIST OF VALIDATED VERB NUMBERS. C OTXT(OBJX,2) HOLDS THE TEXT OF THE OBJECT OBJX. C OBJX(OBJX) IS THE LIST OF VALIDATED OBJECT NUMBERS. C IOTXT(IOBX,2) HOLDS THE TEXT FOR PREP'S IOBJ. IMPLICIT INTEGER(A-Z) LOGICAL BLIND,LIVING,PCT,PFLAG,HINGED,AT,ATHAND,TOTING,K1,ISWIZ LOGICAL KILLED CHARACTER*6 WORD1,WORD2,DKK,DK CHARACTER ZAPP(20) COMMON/IZWIZ/ISWIZ COMMON /ADJCOM/ ADJKEY(50),ADJTAB(150),ADJSIZ COMMON /DIECOM/ NUMDIE,MAXDIE,TURNS,KILLED COMMON /DWFCOM/ DWARF,KNIFE,KNFLOC,DFLAG,DSEEN(6),DLOC(6), 1 ODLOC(6),DWFMAX COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /MNECOM/ BACK,CAVE,DPRSSN,ENTRNC,EXIT,GO,LOOK,NULL, 1 AXE,BEAR,BOAT,BOOK,BOOK2,BOOTH,CARVNG,CHASM,CHASM2,DOOR,GNOME, 2 GRATE,LAMP,PDOOR,PLANT,PLANT2,ROCKS,ROD,ROD2,SAFE, 3 TDOOR,TDOOR2,TROLL,TROLL2,EMRALD,SPICES, 4 FIND,YELL,INVENT,LEAVE,POUR,SAY,TAKE,THROW, 5 IWEST,PHUCE(2,4),TK(20) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ COMMON /PRPCOM/ VKEY(60),PTAB(300),VKYSIZ,PTBSIZ CHARACTER*6 TXT,DTK(9),ATAB COMMON /UTXCOM/ WDX CHARACTER*6 VTXT,OTXT,IOTXT COMMON /WRDCOM/ VERBS(45),VRBX,OBJS(45), 1 OBJX,IOBJS(15),IOBX,PREP,WORDS(45) DIMENSION TAKDIR(20) COMMON /SV3COM/DTK,ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2) 1 ,TXT(35,2) C MOTION NOUN ACTION MISC PREP ADJ CONJ DATA CLASSD,CLASSN,CLASSA,CLASSM,CLASSP,CLASSJ,CLASSC 1 /1,2,3,4,5,6,7/ C C A FEW MORE ACTION VERBS NOT IN COMMON. DATA DROP,FEED,NOTHNG,LIGHT,DRINK,SCORE /02,21,05,07,15,24/ DATA PICK,PUT,GET /41,42,44/ C C AND A MOTION VERB: DATA ENTER /3/ C C AND TO GET/DROP EVERYTHING IN SIGHT: DATA ALL /109/ C C TAKDIR IS A LIST OF MOTION VERBS WHICH ARE ACCEPTABLE AFTER 'TAKE'. DATA TAKDIR/2,6,9,10,11,13,14,17,23,25,33,34, 1 36,37,39,78,79,80,89,-1/ C C IF WORDS(WDX+1) HAS SOMETHING IN IT, WE ARE STILL PROCESSING OLD INPUT LINE. C IF WORDS(1) = -2, SOMEONE ELSE HAS CALLED GETLIN (E.G., KILL DRAGON). POUR = 13 IF(WORDS(WDX+1).GT.0)GOTO 30 C IF WORDS(1) HAS BEEN SET TO -2, SOMEONE ELSE HAS ALREADY READ IN C THE NEW LINE, PRESUMABLY TO CHECK FOR SOME NON-STANDARD WORD. C (THIS HAPPENS WHEN KILLING DRAGON WITH BARE HANDS.) 20 IF(WORDS(1).NE.-2)CALL GETLIN WDX=0 DO 25 I=1,35 WORDS(I)=0 IF(TXT(I,1).NE.' ')WORDS(I)=VOCABX(TXT(I,1),-1) 25 CONTINUE C THE FIRST WORD OF EACH CLAUSE GETS SPECIAL CHECKING, MOSTLY LOOKING C FOR IDIOMS. C SPECIAL HANDLING FOR 'SAY' AND 'CALL'. WIN IF SAYING/CALLING C MAGIC WORDS. NARKY IF UTTERING ANYTHING ELSE. IF NO OBJ, PASS C ON FOR HIGHER LEVEL PARSING. 30 PFLAG=.FALSE. WDX=WDX+1 WORD=WORDS(WDX) IF(WORD)830,800,32 32 KK=CLASS(WORD) IF(KK.EQ.-1)GOTO 91 IF(KK.EQ.CLASSA.OR.KK.EQ.CLASSD.OR.KK.EQ.CLASSM)CALL CLRLIN K=VAL(WORD) IF(KK.NE.CLASSA.OR.(K.NE.SAY.AND.K.NE.YELL))GOTO 40 C 'SAY' OR 'CALL'. IF NO NEXT WORD, PASS ON TO HIGHER POWERS. C IF OBJECT IS MAGIC WORD ('SAY XYZZY'), FLUSH 'SAY' & TAKE NEXT WORD. IF(WORDS(WDX+1).EQ.0.OR.CLASS(WORDS(WDX+1)).EQ.CLASSC)GOTO 99 WDX=WDX+1 IF(K.EQ.SAY)CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'". ',ZAPP,K) IF(K.EQ.YELL)CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'"!!!!!',ZAPP,K) WORD=WORDS(WDX) IF(WORD.EQ.62.OR.WORD.EQ.65.OR.WORD.EQ.71.OR.WORD.EQ.82 1 .OR.WORD.EQ.2025)GOTO 99 WRITE(*,37)(ZAPP(I),I=1,K) 37 FORMAT(/' Okay, "',20A1) GOTO 860 C SPECIAL STUFF FOR 'ENTER'. CAN'T GO INTO WATER. C 'ENTER BOAT' MEANS 'TAKE BOAT'. 40 WORD1=TXT(WDX,1) WORD2=TXT(WDX+1,1) IF(WORD1.NE.'ENTER ')GOTO 50 IF(WORD2.EQ.' ')GOTO 91 SPK=43 IF(LIQLOC(LOC).EQ.WATER)SPK=70 IF(WORD2.EQ.'STREAM'.OR.WORD2.EQ.'WATER '.OR.WORD2.EQ. 1 'RESERV'.OR.WORD2.EQ.'OCEAN '.OR.WORD2.EQ.'SEA ' 2 .OR.WORD2.EQ.'POOL ')GOTO 810 IF(WORD2.NE.'BOAT '.AND.WORD2.NE.'ROWBOA')GOTO 99 WORD=TAKE+2000 GOTO 99 C 'LEAVE' IS A MOTION VERB, UNLESS LEAVING AN OBJECT, C E.G., 'LEAVE BOAT' OR 'LEAVE BOTTLE'. BUT MAKE SURE TO LEAVE ('DROP') C ONLY TOTABLE OBJECTS. 50 KK=WORDS(WDX+1) IF(WORD1.NE.'LEAVE '.OR.CLASS(KK).NE.CLASSN) 1 GOTO 55 IF(HINGED(VAL(KK)).OR.FIXED(VAL(KK)).NE.0)GOTO 99 WORD=LEAVE+2000 GOTO 99 C IF 'LIGHT LAMP', LIGHT MUST BE TAKEN AS AN ACTION VERB, NOT A NOUN. 55 IF(WORD1.NE.'LIGHT'.OR.WORDS(WDX+1).NE.(LAMP+1000))GOTO 60 WORD=LIGHT+2000 GOTO 99 C 'WATER PLANT' BECOMES 'POUR WATER', IF WE ARE AT PLANT. C 'OIL DOOR' BECOMES 'POUR OIL', ETC., ETC. 60 IF((WORD1.NE.'WATER '.AND.WORD1.NE.'OIL ') 1 .OR.(WORD2.NE.'PLANT '.AND.WORD2.NE.'DOOR ' 2 .AND.WORD2.NE.'SWORD '.AND.WORD2.NE.'ANVIL '))GOTO 65 IF(.NOT.AT(VOCABX(WORD2,CLASSN)))GOTO 61 WORDS(WDX+1)=WORDS(WDX) TXT(WDX+1,1)=WORD1 TXT(WDX+1,2)=TXT(WDX,2) 61 WORD=POUR+2000 GOTO 99 C CHECK FILLING OR EMPTYING A CONTAINER. 65 IF((WORD1.NE.'EMPTY ').OR. 1 (CLASS(WORDS(WDX+1)).NE.CLASSN))GOTO 91 KK=VAL(WORDS(WDX+1)) C IF(KK.NE.SACK.AND.KK.NE.SAFE.AND.KK.NE.BOAT.AND.KK.NE.CHEST) C 1 GOTO 91 C *** UNFINISHED CODE HERE *** C ALL THAT ACTUALLY HAPPENS IS OFF ERROR MESSAGES. THE STOOGE C SIMPLY CAN'T SAY 'EMPTY SACK OR 'TAKE ALL FROM SACK' ETC GOTO 91 C THIS IS THE 'INNER' LOOP. DISPATCHING OF ALL WORDS IN A CLAUSE AFTER C THE FIRST COMES THRU HERE. 90 WDX=WDX+1 WORD=WORDS(WDX) 91 IF(WORD)830,900,92 96 WCLASS=WCLASS+1 WORD=VOCABX(TXT(WDX,1),-(WCLASS+1)) IF(WORD.EQ.-1)GOTO 800 WORDS(WDX)=WORD 92 IF(CLASS(WORD).NE.CLASSN)GOTO 99 C IT'S NOT THE FIRST: MAKE SURE HE INCLUDED A COMMA OR 'AND'. C DIFFERENTIATE BETWEEN DIR & INDIR OBJECTS. C CHECK FOR SPECIAL CASE OF MULTIPLE OBJECTS: 'FEED BEAR HONEY' OR C 'THROW TROLL NUGGET'. K=OBJX IF(PFLAG)K=IOBX IF(K.EQ.0.OR.CLASS(WORDS(WDX-1)).EQ.CLASSC)GOTO 99 KK=VAL(VERBS(VRBX)) IF(.NOT.LIVING(OBJS(OBJX)).OR.(KK.NE.THROW.AND.KK.NE.FEED)) 1 GOTO 800 IOBX=IOBX+1 IOBJS(IOBX)=OBJS(OBJX) OBJS(OBJX)=0 OBJX=OBJX-1 99 WCLASS=CLASS(WORD) GOTO(100,200,300,400,500,600,700),WCLASS C MWD OBJ AVB MVB PRP ADJ CNJ CALL BUG(33) C MOTION VERB. C A MOTION VERB IS EITHER A DIRECTION ('WEST') OR A MOTION ('JUMP'). C MULTIPLE MOTIONS MUST BE SEPARATED BY COMMAS OR AND'S. THERE ARE C SOME IDIOMATIC USES WHICH MUST BE SCANNED FOR, SUCH AS 'TAKE BRIDGE', C WHICH BECOMES 'BRIDGE' AND 'GO WEST', WHICH BECOMES 'WEST', AND 'LEAVE THING' C IS DIFFERENT FROM JUST 'LEAVE'. C C IF ORIGINAL VERB WAS 'GO', FLUSH IT & REPLACE WITH THIS ONE. C I.E., 'GO WEST' BECOMES 'WEST'. C C CHECK TAKDIR(20) LIST FOR VALID OBJECT MOTION VERBS FOR 'TAKE'. C IF FOUND, THROW AWAY 'TAKE' AND USE THE MOTION VERB. C C SINCE THE ORIGINAL VERB IS AN ACTION VERB, CHECK THIS WORD IN THE C NOUN TABLE. MAYBE IT IS AN OBJECT SYNONYMOUS WITH A VERB ('ROCKS'). C C IF IT ISN'T A VALID MOTION-OBJECT OF 'TAKE' OR 'GO', NOR AN OBJECT, C CHECK THE PREP TABLE. IF FOUND, HAND IT TO THE PREPOSITION ANALYZER. 100 IF(VRBX.EQ.0)GOTO 180 K=VERBS(VRBX) IF(CLASS(K).GT.CLASSA)GOTO 800 IF(CLASS(K).NE.CLASSA)GOTO 140 IF(VAL(K).EQ.GO)GOTO 180 IF(VAL(K).NE.TAKE)GOTO 96 KK=VAL(WORD) DO 110 I=1,20 IF(TAKDIR(I).EQ.KK)GOTO 180 110 CONTINUE GOTO 96 C IF ORIGINAL MOTION VERB WAS CRAWL, JUMP OR CLIMB, IGNORE CURRENT WORD. C I.E., 'CLIMB UP' OR 'JUMP OVER' BECOME 'CLIMB' & 'JUMP' ONLY. 140 IF(K.EQ.17.OR.K.EQ.39.OR.K.EQ.56)GOTO 90 C 'CRAWL' 'JUMP' 'CLIMB' 180 VERBS(1)=WORD VRBX=1 IF(TXT(WDX,1).NE.'WEST ')GOTO 90 IWEST=IWEST+1 IF(IWEST.EQ.10)CALL RSPEAK(17) K=VAL(WORD) IF(K.EQ.EXIT.OR.K.EQ.ENTER)GOTO 860 GOTO 90 C ANALYZE OBJECT. C IF PFLAG IS TRUE, THEN WE ARE PROCESSING A SET OF INDIRECT (PREP) C OBJECTS, NOT DIRECT OBJS. 200 IF(PFLAG)GOTO 503 IF(VRBX.NE.0)GOTO 220 K=VOCABX(TXT(WDX,1),-(CLASSA+1)) IF(K.EQ.-1)GOTO 220 WORD=K GOTO 300 220 WORD=VAL(WORD) IF(WORD.EQ.ALL)GOTO 280 222 CALL GETOBJ(WORD) IF(WORD)230,860,240 C IT WASN'T REALLY AN OBJECT. GO SEE WHAT IT WAS. 230 WORD=-WORD GOTO 99 C IT WAS REALLY AN OBJECT & IT IS HERE. 240 OBJX=OBJX+1 OBJS(OBJX)=WORD OTXT(OBJX,1)=TXT(WDX,1) OTXT(OBJX,2)=TXT(WDX,2) GOTO 90 C TAKE EVERYTHING NOT BATTENED DOWN. 280 KK=VAL(VERBS(VRBX)) K1=.FALSE. IF(KK.EQ.DROP.OR.KK.EQ.PUT.OR.KK.EQ.LEAVE)GOTO 281 K1=.TRUE. IF(KK.NE.TAKE.AND.KK.NE.PICK.AND.KK.NE.GET)GOTO 800 SPK=357 IF(BLIND(0))GOTO 810 281 DO 289 I=1,MAXOBJ IF(.NOT.ATHAND(I).OR.FIXED(I).NE.0)GOTO 289 IF(I.GE.WATER.AND.I.LE.WINE+1)GOTO 289 IF((K1.AND.TOTING(I)) .OR. (.NOT.K1.AND..NOT.TOTING(I)) )GOTO 289 OBJX=OBJX+1 OBJS(OBJX)=I C OTXT(OBJX,1)=NTXT(I,1) C OTXT(OBJX,2)=NTXT(I,2) OTXT(OBJX,1)='BUG???' OTXT(OBJX,2)=' ' IF(OBJX.EQ.44)GOTO 90 289 CONTINUE GOTO 90 C ACTION VERB. 300 IF(VRBX.EQ.0)GOTO 370 IF(VAL(VERBS(VRBX)).NE.TAKE)GOTO 320 K=VAL(WORD) IF(K.EQ.DRINK.OR.K.EQ.INVENT.OR.K.EQ.SCORE.OR.K.EQ.NOTHNG 1 .OR.K.EQ.LOOK)GOTO 371 IF(K.NE.GO)GOTO 800 DK=TXT(WDX,1) IF(DK.EQ.'WALK '.OR.DK.EQ.'RUN '.OR.DK.EQ.'HIKE ') 1 GOTO 371 GOTO 800 320 IF(OBJX.NE.0.OR.CLASS(WORDS(WDX-1)).NE.CLASSC)GOTO 800 370 VRBX=VRBX+1 371 VERBS(VRBX)=WORD VTXT(VRBX,1)=TXT(WDX,1) VTXT(VRBX,2)=TXT(WDX,2) GOTO 90 C MISCELLANEOUS WORDS/VERBS. 400 IF(VRBX.NE.0)GOTO 800 VERBS(1)=WORD VRBX=1 GOTO 90 C ANALYZE A PREPOSITION AND ITS OBJECT. CHECK THAT PREP C IS VALID FOR THIS VERB, AND THEN CHECK THAT THE OBJECT IS VALID C FOR THIS PREPOSITION. IF FIRST CHECK FAILS, SYNTAX IS MESSED C UP; IF SECOND PART FAILS, IT MAY MERELY BE AN IMPOSSIBLE ACT. 500 IF(CLASS(VERBS(VRBX)).NE.CLASSA.OR.IOBX.NE.0)GOTO 800 IF(PFLAG)GOTO 503 VRBKEY=VKEY(VAL(VERBS(VRBX))) IF(VRBKEY.EQ.0)GOTO 800 PREP=VAL(WORD) PFLAG=.TRUE. WDX=WDX+1 WORD=WORDS(WDX) IF(WORD.EQ.0)GOTO 510 GOTO(800,503,800,800,800,600,510),CLASS(WORD) GOTO 840 503 WORD=VAL(WORD) IF(WORD.EQ.ALL)GOTO 510 504 CALL GETOBJ(WORD) IF(WORD)570,860,505 505 IOBX=IOBX+1 IOBJS(IOBX)=WORD IOTXT(IOBX,1)=TXT(WDX,1) IOTXT(IOBX,2)=TXT(WDX,2) 510 KK=IABS(PTAB(VRBKEY)/1000) IF(KK.NE.PREP)GOTO 525 C PREP IS VALID WITH THIS VERB. NOW CHECK OBJECT OF PREP. IF(WORD.EQ.0.OR.CLASS(WORD).EQ.CLASSC)GOTO 530 C AN OBJ FOLLOWS THE PREP. SEE IF IT'S PLAUSIBLE. 520 KK=IABS((MOD(PTAB(VRBKEY),0001000))) IF(KK.EQ.WORD.AND.KK.EQ.ALL)GOTO 280 IF(KK.EQ.WORD.OR.KK.EQ.999)GOTO 90 525 VRBKEY=VRBKEY+1 IF(PTAB(VRBKEY-1).GE.0)GOTO 510 GOTO 570 C NO OBJ FOLLOWS PREP. CHECK SPECIAL CASES. 530 PFLAG=.FALSE. WDX=WDX-1 DK=TXT(WDX,1) DKK=VTXT(VRBX,1) IF((DK.NE.'ON '.AND.DK.NE.'OFF ').AND. 1 (DKK.NE.'TURN '.OR.OBJS(OBJX).NE.LAMP) .AND. 2 (DKK.NE.'TAKE '.AND.DKK.NE.'PUT ') )GOTO 570 IF((DK.EQ.'UP '.AND.DKK.NE.'PICK ').OR. 1 (DK.EQ.'DOWN '.AND.(DKK.NE.'PUT '.AND.VERBS(VRBX).NE.THROW 2 )))GOTO 570 WDX=WDX+1 WORD=WORDS(WDX) IF(WORD.EQ.0)GOTO 900 IF(CLASS(WORD).NE.CLASSC)GOTO 800 GOTO 91 C YOU CAN'T DO THAT!! 570 SPK=NOWAY(0) GOTO 810 C ADJECTIVE HANDLER. C SCARF THE NEXT WORD, MAKE SURE IT IS A VALID OBJECT FOR THIS ADJ. C THEN CALL GETOBJ TO SEE IF IT IS REALLY THERE, THEN LINK INTO OBJ C CODE. 600 ADJ=VAL(WORD) WDX=WDX+1 WORD=WORDS(WDX) IF(WORD)840,640,605 605 IF(CLASS(WORD).EQ.CLASSC) GOTO 640 IF(CLASS(WORD).NE.CLASSN) WORD=VOCABX(TXT(WDX,1),-(CLASSN+1)) IF(WORD.EQ.-1.OR.CLASS(WORD).NE.CLASSN.OR.VAL(WORD).EQ.ALL) 1 GOTO 800 WORDS(WDX)=WORD KK=VAL(WORD) K=ADJKEY(ADJ) 610 IF(KK.EQ.IABS(ADJTAB(K)))GOTO 92 IF(ADJTAB(K).LT.0)GOTO 800 K=K+1 GOTO 610 640 CALL A5TOA1(TXT(WDX-1,1),TXT(WDX-1,2),'_WHAT?',ZAPP,K) WRITE(*,642)(ZAPP(I),I=1,K) 642 FORMAT(1X, 20A1) GOTO 20 C ANALYZE A CONJUNCTION. MAY BE A COMMA OR AN EXPLICIT "AND". C LOOK AHEAD AT NEXT WORD. IF IT IS AN ACTION VERB AND NO OBJECT C HAS YET BEEN SPECIFIED, PUT IT INTO THE VERB STACK. IF IT IS C AN OBJECT, ADD IT TO THE PILE. C ELSE, BUMP BACK THE WORD POINTER, ASSUME END OF CLAUSE, AND C RETURN. 700 WDX=WDX+1 WORD=WORDS(WDX) IF(WORD)840,800,710 710 GOTO(790,92,720,790,800,92,800),CLASS(WORD) C A NEW ACTION VERB FOLLOWS. IF NO PREVIOUS VERB HAS BEEN TYPED, C HE LOSES. IF PREVIOUS VERB IS NOT AN ACTION VERB, HE LOSES. C IF AN OBJ/IOBJ WAS SPECIFIED FOR PREV ACT VERB, HE LOSES. ONLY C VALID SYNTAX IS: 'GET AND OPEN CAGE'. 720 IF(VRBX.NE.0.AND.CLASS(VERBS(VRBX)).EQ.CLASSA 1 .AND.OBJX.EQ.0.AND.IOBX.EQ.0)GOTO 92 790 WDX=WDX-1 GOTO 900 C GEE, I DON'T UNDERSTAND. FLUSH REST OF CURRENT CLAUSE, UP TO C EOL OR CONJUNCTION & CONTINUE. 800 SPK=CONFUZ(0) 810 CALL RSPEAK(SPK) 820 CALL CLRLIN GOTO 20 C AN IRREGULAR WORD WAS TYPED IN BY USER. CHECK FOR WIZARDRY. 830 CONTINUE 840 CONTINUE 841 IF(PCT(25))GOTO 850 CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'. ',ZAPP,K) WRITE(*,842)(ZAPP(I),I=1,K) 842 FORMAT(/' I don''t understand the word ',20A1) CALL CLRLIN GOTO 20 850 CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'? ',ZAPP,K) WRITE(*,852)(ZAPP(I),I=1,K) 852 FORMAT(/' Mumble? ',20A1) CALL CLRLIN GOTO 20 C SCAN TO CONJ OR END OF LINE. 860 CALL CLRLIN PFLAG=.FALSE. 862 WDX=WDX+1 IF(WORDS(WDX).EQ.0)GOTO 20 IF(CLASS(WORDS(WDX)).EQ.CLASSC)GOTO 90 GOTO 862 C END OF CLAUSE. WE APPEAR TO HAVE REACHED THE END OF A SENTENCE. C IT WAS TERMINATED EITHER BY CRLF OR A CONJUNCTION. IF A CONJ, C THE CONJ ANALYZER CLAIMS THAT THE NEXT WORDS ARE NOT PART OF C THIS CLAUSE. DECIDE WHETHER OR NOT WE HAVE ENOUGH TO WORK WITH. 900 PFLAG=.FALSE. IF(VERBS(1).NE.0)GOTO 930 IF(OBJS(1).EQ.0)GOTO 800 IF(OBJS(2).NE.0)GOTO 920 CALL A5TOA1(OTXT(1,1),OTXT(1,2),'? ',ZAPP,K) WRITE(*,915)(ZAPP(I),I=1,K) 915 FORMAT(/' What do you want to do with the ',20A1) GOTO 20 920 WRITE(*,*)' What do you want to do with them' GOTO 20 930 IF(OBJX.GT.1.AND.IOBX.GT.1)GOTO 800 RETURN END C*** HERE .TRUE. IF OBJ AT THIS LOCATION LOGICAL FUNCTION HERE(OBJ) C HERE(OBJ) = TRUE IF THE OBJ IS AT "LOC" (OR IS BEING CARRIED) IMPLICIT INTEGER(A-Z) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ LOGICAL TOTING HERE = .FALSE. IF(OBJ.LT.1.OR.OBJ.GT.MAXOBJ)RETURN HERE=PLACE(OBJ).EQ.LOC.OR.TOTING(OBJ) RETURN END C*** HINGED .TRUE. IF OBJ CAN BE OPENED LOGICAL FUNCTION HINGED(OBJ) C HINGED(OBJ) = TRUE IF OBJECT CAN BE OPENED/SHUT. IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) HINGED=BITSET(OBJCON(OBJ),1) RETURN END C*** HOLDNG .TRUE. IF HOLDING OBJ LOGICAL FUNCTION HOLDNG(OBJ) C HOLDNG(OBJ) = TRUE IF THE OBJ IS BEING CARRIED IN HAND. IMPLICIT INTEGER(A-Z) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ HOLDNG = .FALSE. IF(OBJ.LT.1.OR.OBJ.GT.MAXOBJ)RETURN HOLDNG=PLACE(OBJ).EQ.-1 RETURN END C*** INSERT SUBROUTINE INSERT(OBJECT,CONTNR) IMPLICIT INTEGER(A-Z) COMMON /HLDCOM/ HOLDER(150),HLINK(150) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ IF(CONTNR.EQ.OBJECT)CALL BUG(32) CALL CARRY(OBJECT,LOC) TEMP=HOLDER(CONTNR) HOLDER(CONTNR)=OBJECT HLINK(OBJECT)=TEMP PLACE(OBJECT)=-CONTNR RETURN END C*** INSIDE .TRUE. IF LOCATION IS WELL WITHIN THE CAVE LOGICAL FUNCTION INSIDE(LOC) C INSIDE(LOC) = TRUE IF LOCATION IS WELL WITHIN THE CAVE IMPLICIT INTEGER(A-Z) LOGICAL OUTSID,PORTAL INSIDE=.NOT.OUTSID(LOC).AND..NOT.PORTAL(LOC) RETURN END C*** JUGGLE SUBROUTINE 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. IMPLICIT INTEGER(A-Z) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ I=PLACE(OBJECT) J=FIXED(OBJECT) CALL MOVE(OBJECT,I) CALL MOVE(OBJECT+MAXOBJ,J) RETURN END C*** LIQ INTEGER FUNCTION LIQ(OBJ) IMPLICIT INTEGER(A-Z) COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5) COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150), 1 POINTS(150) C LIQ=LIQ2(MAX0(PROP(OBJ),-1-PROP(OBJ))) LIQ = 0 IF(OBJ.NE.BOTTLE.AND.OBJ.NE.CASK)RETURN IQ = MAX0(PROP(OBJ)+1,-1-(PROP(OBJ)+1)) IF(IQ.LE.0)RETURN LIQ=LIQTYP(IQ) RETURN END C*** LIQ2 C NON-LOGICAL (ILLOGICAL?) FUNCTIONS (CLASS,LIQ,LIQ2,LIQLOC,VAL) INTEGER FUNCTION LIQ2(PBOTL) IMPLICIT INTEGER(A-Z) COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5) LIQ2=(1-PBOTL)*WATER+(PBOTL/2)*(WATER+OIL)+(PBOTL/4) 1 *(WATER+WINE-2*OIL) RETURN END C*** LIQLOC INTEGER FUNCTION LIQLOC(LOC) IMPLICIT INTEGER(A-Z) COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5) INTEGER WRD(2) COMMON /CONCOM/ LOCCON(250),OBJCON(150) EQUIVALENCE (LOCCON,WRD) C CALL TOOCT(LOCCON(LOC)) C CALL TOOCT(WRD(LOC*2)) LIQLOC=LIQ2((MOD(LOCCON(LOC)/8,2)*(MOD(LOCCON(LOC)/2*2,16)-9) 1 +1)) RETURN END C*** LIVING .TRUE. IF OBJ IS LIVING, BEAR FOR EXAMPLE LOGICAL FUNCTION LIVING(OBJ) C LIVING(OBJ) = TRUE IF OBJ IS SOME SORT OF CRITTER IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) LIVING=BITSET(OBJCON(OBJ),9) RETURN END C*** LOCKED .TRUE. IF LOCKABLE OBJ IS LOCKED LOGICAL FUNCTION LOCKED(OBJ) IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON/CONCOM/LOCCON(250),OBJCON(150) LOCKED=BITSET(OBJCON(OBJ),4) RETURN END C*** LOCKS .TRUE. IF YOU CAN LOCK THIS OBJ LOGICAL FUNCTION LOCKS(OBJ) IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON/CONCOM/LOCCON(250),OBJCON(150) LOCKS=BITSET(OBJCON(OBJ),3) RETURN END C*** LOOKIN SUBROUTINE LOOKIN(CONTNR) C LIST CONTENTS IF OBJ IS A CONTAINER AND IS OPEN OR TRANSPARENT. C SAVE INITIAL VALUE OF BLKLIN THRU SUBROUTINE. IMPLICIT INTEGER(A-Z) COMMON /BLKCOM/ BLKLIN COMMON /HLDCOM/ HOLDER(150),HLINK(150) LOGICAL VESSEL,AJAR,OPAQUE,BLKLIN,BSAVE DIMENSION TK(20) IF(.NOT.VESSEL(CONTNR).OR. 1 (.NOT.AJAR(CONTNR).AND.OPAQUE(CONTNR)) )RETURN TEMP=HOLDER(CONTNR) LOOP=0 BSAVE=BLKLIN 20 IF(TEMP.EQ.0)RETURN BLKLIN=.FALSE. IF(LOOP.EQ.0)CALL RSPEAK(360) CALL TNOUA CALL PSPEAK(TEMP,-1) BLKLIN=BSAVE TEMP=HLINK(TEMP) LOOP=-1 GOTO 20 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(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ LOGICAL ENCLSD IF(OBJECT.GT.MAXOBJ)THEN FROM=FIXED(OBJECT-MAXOBJ) ELSE IF(ENCLSD(OBJECT))CALL REMOVE(OBJECT) FROM=PLACE(OBJECT) ENDIF IF(FROM.GT.0.AND.FROM.LE.MAXOBJ*2)CALL CARRY(OBJECT,FROM) CALL DROP(OBJECT,WHERE) RETURN END C*** NOWAY INTEGER FUNCTION NOWAY(DUMMY) C GENERATE'S SOME VARIANT OF "CAN'T DO THAT" MESSAGE. IMPLICIT INTEGER(A-Z) LOGICAL PCT NOWAY=14 IF(PCT(50))NOWAY=110 IF(PCT(33))NOWAY=147 IF(PCT(25))NOWAY=250 IF(PCT(20))NOWAY=262 IF(PCT(17))NOWAY=25 IF(PCT(14))NOWAY=345 IF(PCT(12))NOWAY=346 RETURN END C*** OPAQUE .TRUE. IF OBJ IS NON-TRANSPARENT CONTAINER LOGICAL FUNCTION OPAQUE(OBJ) C OPAQUE(OBJ) = TRUE IF OBJECT IS NOT TRANSPARENT. E.G., BAG & CHEST ARE OPAQ C WICKER CAGE & GLASS BOTTLE ARE TRANSPARENT. IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) OPAQUE=BITSET(OBJCON(OBJ),6) RETURN END C*** OUTSID .TRUE. IF LOCATION IS OUTSIDE THE CAVE LOGICAL FUNCTION OUTSID(LOC) C OUTSID(LOC) = TRUE IF LOCATION IS OUTSIDE THE CAVE IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) OUTSID=BITSET(LOCCON(LOC),6) RETURN END C*** PCT LOGICAL FUNCTION PCT(N) C PCT(N) = TRUE N% OF THE TIME (N INTEGER FROM 0 TO 100) IMPLICIT INTEGER(A-Z) PCT=RANZ(100).LT.N RETURN END C*** PLURAL .TRUE. IF OBJ IS MULTIPLE OBJS LOGICAL FUNCTION PLURAL(OBJ) C PLURAL(OBJ) = TRUE IF OBJECT IS A "BUNCH" OF THINGS (COINS, SHOES). IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) PLURAL=BITSET(OBJCON(OBJ),13) RETURN END C*** PORTAL .TRUE. IF LOCATION IS IN CAVE ENTRANCE LOGICAL FUNCTION PORTAL(LOC) C PORTAL(LOC) = TRUE IS LOCATION IS IN CAVE "ENTRANCE" IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) PORTAL=BITSET(LOCCON(LOC),5) RETURN END C*** PRINTD .TRUE. IF OBJ CAN BE READ LOGICAL FUNCTION PRINTD(OBJ) C PRINTD(OBJ) = TRUE IF OBJECT CAN BE READ. IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) PRINTD=BITSET(OBJCON(OBJ),8) RETURN END C*** PSPEAK SUBROUTINE PSPEAK(MSG,SKIP) C FIND THE SKIP+1ST MESSAGE FROM MSG AND PRINT IT. MSG SHOULD BE THE INDEX OF C THE INVENTORY MESSAGE FOR OBJECT. (INVEN+N+1 MESSAGE IS PROP=N MESSAGE). IMPLICIT INTEGER(A-Z) COMMON /TXTCOM/ LINES(25000),RTEXT(450),PTEXT(150) M=PTEXT(MSG) IF(SKIP.LT.0)GOTO 9 DO 3 I=0,SKIP 1 M=IABS(LINES(M)) IF(LINES(M).GE.0)GOTO 1 3 CONTINUE 9 CALL SPEAK(M) RETURN END C*** PUT 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 C*** RANZ C UTILITY ROUTINES (SHIFT, RAN, DATIME, CIAO, BUG, LOG) INTEGER FUNCTION RANZ(RANGE) IMPLICIT INTEGER (A-Z) SAVE DATA SEED/12345/ SEED = SEED*69069+1 I = 16384/RANGE J = IABS(SEED)/I RANZ = MOD(J,RANGE) RETURN END C*** RATING SUBROUTINE RATING(SCORE,BONUS,GAVEUP,SCORNG,CLOSNG,CLOSED 1 ,HNTMAX) C CALCULATE WHAT THE PLAYER'S SCORE WOULD BE IF HE QUIT NOW. C THIS MAY BE THE END OF THE GAME, OR HE MAY JUST BE WONDERING C HOW HE IS DOING. IMPLICIT INTEGER(A-Z) LOGICAL TREASR,GAVEUP,CLOSNG,CLOSED,SCORNG,HINTED,KILLED COMMON /MNECOM/ BACK,CAVE,DPRSSN,ENTRNC,EXIT,GO,LOOK,NULL, 1 AXE,BEAR,BOAT,BOOK,BOOK2,BOOTH,CARVNG,CHASM,CHASM2,DOOR,GNOME, 2 GRATE,LAMP,PDOOR,PLANT,PLANT2,ROCKS,ROD,ROD2,SAFE, 3 TDOOR,TDOOR2,TROLL,TROLL2,EMRALD,SPICES, 4 FIND,YELL,INVENT,LEAVE,POUR,SAY,TAKE,THROW, 5 IWEST,PHUCE(2,4),TK(20) COMMON /DIECOM/ NUMDIE,MAXDIE,TURNS,KILLED COMMON /DWFCOM/ DWARF,KNIFE,KNFLOC,DFLAG,DSEEN(6),DLOC(6), 1 ODLOC(6),DWFMAX COMMON /HNTCOM/ HINTLC(20),HINTED(20),HINTS(20,4),HNTSIZ,HNTMIN COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150), 1 POINTS(150) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ COMMON /SV2COM/ANVIL,BATTER,BEES,BILLBD,BIRD,BRUSH,CAGE, 1 CAKES,CHAIN,CHEST,CHLOC,CHLOC2,CLAM,CLOAK,CLSSES,COINS,CROWN, 2 DALTLC,DOG,DRAGON,EGGS,FISSUR,FLOWER,GATLOC,GRAIL,HIVE, 3 HONEY,HORN,JEWELS,KEYS,LYRE, 4 MAGZIN,MIRROR,MUSHRM,MXSCOR,NUGGET,OYSTER,PEARL,PHONE, 5 PILLOW,POLE,POSTER,PREPAT,PREPDN,PREPFR,PREPIN,PREPOF, 6 PREPON,PYRAM,RADIUM,RING,RUG,SAPPHI,SHIELD,SHOES, 7 SHUT,SLUGS,SNAKE,SPHERE,STEPS,STICKS,SWORD,TABLET,TRIDNT, 8 UNLOCK,VASE,WALL,WALL2,WEAR,WUMPUS,Y2,YANK DIMENSION QK(20) C THE PRESENT SCORING ALGORITHM IS AS FOLLOWS: C (TREASURE POINTS ARE EXPLAINED IN A FOLLOWING COMMENT) C OBJECTIVE: POINTS: PRESENT TOTAL POSSIBLE: C GETTING WELL INTO CAVE 25 25 C TOTAL POSSIBLE FOR TREASURES (+MAG) 426 C SURVIVING (MAX-NUM)*10 30 C NOT QUITTING 4 4 C REACHING "CLOSNG" 20 20 C "CLOSED": QUIT/KILLED 10 C KLUTZED 20 C WRONG WAY 25 C SUCCESS 30 30 C ROUND OUT THE TOTAL 16 16 C TOTAL: 551 C (POINTS CAN ALSO BE DEDUCTED FOR USING HINTS.) SCORE=0 MXSCOR=0 C FIRST TALLY UP THE TREASURES. MUST BE IN BUILDING AND NOT BROKEN. C GIVE THE POOR GUY PARTIAL SCORE JUST FOR FINDING EACH TREASURE. C GETS FULL SCORE, QK(3), FOR OBJ IF: C OBJ IS AT LOC QK(1), AND C OBJ HAS PROP VALUE OF QK(2) C C WEIGHT TOTAL POSSIBLE C MAGAZINE 1 (ABSOLUTE) 1 C C ALL THE FOLLOWING ARE MULTIPLIED BY 5 (RANGE 5-25): C BOOK 2 C CASK 3 (WITH WINE ONLY) C CHAIN 4 (MUST ENTER VIA STYX) C CHEST 5 C CLOAK 3 C CLOVER 1 C COINS 5 C CROWN 2 C CRYSTAL-BALL 2 C DIAMONDS 2 C EGGS 3 C EMERALD 3 C GRAIL 2 C HORN 2 C JEWELS 1 C LYRE 1 C NUGGET 2 C PEARL 4 C PYRAMID 4 C RADIUM 4 C RING 4 C RUG 3 C SAPPHIRE 1 C SHOES 3 C SPICES 1 C SWORD 4 C TRIDENT 2 C VASE 2 C DROPLET 5 C TREE 5 C TOTAL: 85 * 5 = 425 + 1 ==> 426 DO 1010 OBJ=1,MAXOBJ IF(POINTS(OBJ).EQ.0)GOTO 1010 QK(3)=IABS(POINTS(OBJ))/1000000 QK(2)=(IABS(POINTS(OBJ))-QK(3)*1000000)/1000 QK(1)=IABS(POINTS(OBJ))-QK(3)*1000000-QK(2)*1000 IF(POINTS(OBJ).LT.0) QK(1)=-QK(1) K=0 IF(.NOT.TREASR(OBJ))GOTO 1007 K=QK(3)*2 IF(PROP(OBJ).GE.0)SCORE=SCORE+K QK(3)=QK(3)*5 1007 IF(PLACE(OBJ).EQ.QK(1).AND.PROP(OBJ).EQ.QK(2).AND. 1 (PLACE(OBJ).NE.-CHEST.OR.PLACE(CHEST).EQ.3).AND. 2 (PLACE(OBJ).NE.-SHIELD.OR.PLACE(SHIELD).EQ.-SAFE)) 3 SCORE=SCORE+QK(3)-K MXSCOR=MXSCOR+QK(3) 1010 CONTINUE C NOW LOOK AT HOW HE FINISHED AND HOW FAR HE GOT. MAXDIE AND NUMDIE TELL US C HOW WELL HE SURVIVED. GAVEUP SAYS WHETHER HE EXITED VIA QUIT. DFLAG WILL C TELL US IF HE EVER GOT SUITABLY DEEP INTO THE CAVE. CLOSNG STILL INDICATES C WHETHER HE REACHED THE ENDGAME. AND IF HE GOT AS FAR AS "CAVE CLOSED" C (INDICATED BY "CLOSED"), THEN BONUS IS ZERO FOR MUNDANE EXITS OR 133, 134, C 135 IF HE BLEW IT (SO TO SPEAK). ASCORE=(MAXDIE-NUMDIE)*10 MXSCOR=MXSCOR+MAXDIE*10 IF(.NOT.(SCORNG.OR.GAVEUP))ASCORE=ASCORE+4 MXSCOR=MXSCOR+4 IF(DFLAG.NE.0)ASCORE=ASCORE+25 MXSCOR=MXSCOR+25 IF(CLOSNG)ASCORE=ASCORE+20 MXSCOR=MXSCOR+20 IF(.NOT.CLOSED)GOTO 1020 IF(BONUS.EQ.0)ASCORE=ASCORE+10 IF(BONUS.EQ.135)ASCORE=ASCORE+20 IF(BONUS.EQ.134)ASCORE=ASCORE+25 IF(BONUS.EQ.133)ASCORE=ASCORE+30 1020 MXSCOR=MXSCOR+30 C ROUND IT OFF. ASCORE=ASCORE+16 MXSCOR=MXSCOR+16 C DEDUCT POINTS FOR HINTS. HINTS < HNTMIN ARE SPECIAL; SEE DATABASE DESCRIPTIO DO 1030 I=1,HNTMAX 1030 IF(HINTED(I))SCORE=SCORE-HINTS(I,2) JTURNS=TURNS/100 IF(JTURNS.EQ.0)ASCORE=0 IF(JTURNS.EQ.1)ASCORE=ASCORE/3 IF(JTURNS.EQ.2)ASCORE=(ASCORE*2)/3 SCORE=SCORE+ASCORE IF(SCORE.LT.0) SCORE=0 RETURN END C*** REMOVE SUBROUTINE REMOVE(OBJECT) IMPLICIT INTEGER(A-Z) COMMON /HLDCOM/ HOLDER(150),HLINK(150) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ CONTNR=-PLACE(OBJECT) PLACE(OBJECT)=-1 IF(HOLDER(CONTNR).NE.OBJECT)GOTO 1 HOLDER(CONTNR)=HLINK(OBJECT) RETURN 1 TEMP=HOLDER(CONTNR) 2 IF(HLINK(TEMP).EQ.OBJECT)GOTO 3 TEMP=HLINK(TEMP) GOTO 2 3 HLINK(TEMP)=HLINK(OBJECT) RETURN END C*** RSPEAK SUBROUTINE RSPEAK(I) C PRINT THE I-TH "RANDOM" MESSAGE (SECTION 6 OF DATABASE). IMPLICIT INTEGER(A-Z) COMMON /TXTCOM/ LINES(25000),RTEXT(450),PTEXT(150) IF(I.LE.0)RETURN M=RTEXT(I) CALL SPEAK(M) RETURN END C*** SMALL .TRUE. IF IT FITS IN SACK OR SMALL CONTAINER LOGICAL FUNCTION SMALL(OBJ) IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON/CONCOM/LOCCON(250),OBJCON(150) SMALL=BITSET(OBJCON(OBJ),5) RETURN END C*** SPEAK SUBROUTINE SPEAK(N) C PRINT THE MESSAGE WHICH STARTS AT LINES(N). PRECEDE IT WITH A BLANK LINE C UNLESS BLKLIN IS FALSE. IMPLICIT INTEGER(A-Z) LOGICAL BLKLIN COMMON /TNOUX/INDENT COMMON /TXTCOM/ LINES(25000),RTEXT(450),PTEXT(150) COMMON /BLKCOM/ BLKLIN DIMENSION OLINE(30) C DATA ZCLYD/'CLYD'/,ZLS/'<$$<'/ C ZCLYD = 0 C ZCLYD = 37+256*(9+256*(20+256*15)) ZCLYD = ICHAR('c')+256*(ICHAR('L')+ 256*(ICHAR('y') 1 +256*ICHAR('D'))) ZLS = 60+256*(36+256*(36+256*60)) XCLYD=IEOR(ZCLYD,ZLS) 100 IF(N.EQ.0)GOTO 145 IF(LINES(N+1).EQ.XCLYD)GOTO 4 K=N 1 CONTINUE L=IABS(LINES(K))-K-1 DO 2 I=1,L 2 OLINE(I)=IEOR(LINES(K+I),ZCLYD) IF(INDENT.EQ.0)WRITE(*,3) (OLINE(I),I=1,L) IF(INDENT.EQ.1)WRITE(*,133)(OLINE(I),I=1,L) 133 FORMAT(6X,19A4) 3 FORMAT(' ',19A4) K=K+L+1 IF(LINES(K).GE.0)GOTO 1 4 CONTINUE 145 INDENT=0 RETURN END C A HORRIBLE KLUDGE SUBROUTINE TNOUA INTEGER INDENT COMMON /TNOUX/INDENT INDENT=1 RETURN END C*** TOTING .TRUE. IF OBJ SOMEWHERE ON PERSON LOGICAL FUNCTION TOTING(OBJ) C TOTING(OBJ) = TRUE IF THE OBJ IS BEING CARRIED (IN HAND OR C CONTAINER). OBJ MAY NOT BE REACHABLE. SEE C ALSO: ENCLSD, ATHAND, HOLDNG. IMPLICIT INTEGER(A-Z) COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ LOGICAL HOLDNG,ENCLSD,AAA,BBB,CCC TOTING = .FALSE. IF(HOLDNG(OBJ))THEN TOTING = .TRUE. RETURN ENDIF CONTNR=-PLACE(OBJ) IF(CONTNR.LE.0)RETURN IF(HOLDNG(CONTNR))THEN TOTING = .TRUE. RETURN ENDIF OUTER=-PLACE(CONTNR) IF(OUTER.LE.0)RETURN IF(HOLDNG(OUTER))THEN TOTING = .TRUE. RETURN ENDIF OUTER2=-PLACE(OUTER) IF(OUTER2.LE.0)RETURN IF(HOLDNG(OUTER2))THEN TOTING = .TRUE. RETURN ENDIF RETURN END C*** TRAVL C FIGURE OUT THE NEW LOCATION C C GIVEN THE CURRENT LOCATION IN "LOC", AND A MOTION VERB NUMBER IN "K", PUT C THE NEW LOCATION IN "NEWLOC". THE CURRENT LOC IS SAVED IN "OLDLOC" IN CASE C HE WANTS TO RETREAT. THE CURRENT OLDLOC IS SAVED IN OLDLC2, IN CASE HE C DIES. (IF HE DOES, NEWLOC WILL BE LIMBO, AND OLDLOC WILL BE WHAT KILLED C HIM, SO WE NEED OLDLC2, WHICH IS THE LAST PLACE HE WAS SAFE.) SUBROUTINE TRAVL(K,BCROSS,TALLY2) IMPLICIT INTEGER(A-Z) LOGICAL KILLED,PCT,HOLDNG,ENCLSD LOGICAL INSIDE,OUTSID,PORTAL,TOTING,HERE,AT,FORCED COMMON /DIECOM/ NUMDIE,MAXDIE,TURNS,KILLED COMMON /TRVCOM/ TRAVEL(1600) COMMON /LTXCOM/ LTEXT(250),STEXT(250),KEY(250),ABB(250),LOCSIZ COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150), 1 FIXED(150),MAXOBJ COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150), 1 POINTS(150) COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC COMMON /MNECOM/ BACK,CAVE,DPRSSN,ENTRNC,EXIT,GO,LOOK,NULL, 1 AXE,BEAR,BOAT,BOOK,BOOK2,BOOTH,CARVNG,CHASM,CHASM2,DOOR,GNOME, 2 GRATE,LAMP,PDOOR,PLANT,PLANT2,ROCKS,ROD,ROD2,SAFE, 3 TDOOR,TDOOR2,TROLL,TROLL2,EMRALD,SPICES, 4 FIND,YELL,INVENT,LEAVE,POUR,SAY,TAKE,THROW, 5 IWEST,PHUCE(2,4),TK(20) KILLED=.FALSE. KK=KEY(LOC) NEWLOC=LOC IF(KK.EQ.0)CALL BUG(26) IF(K.EQ.NULL)RETURN IF(K.EQ.BACK)GOTO 20 IF(K.EQ.CAVE)GOTO 40 OLDLC2=OLDLOC OLDLOC=LOC 9 LL=IABS(TRAVEL(KK)) IF(MOD(LL,0001000).EQ.1.OR.MOD(LL,0001000).EQ.K) 1 GOTO 10 IF(TRAVEL(KK).LT.0000000)GOTO 50 KK=KK+1 GOTO 9 10 LL=LL/0001000 11 NEWLOC=LL/0001000 K=MOD(NEWLOC,100) IF(NEWLOC.LE.MAXLOC)GOTO 13 IF(PROP(K).NE.NEWLOC/100-3)GOTO 16 12 IF(TRAVEL(KK).LT.0)CALL BUG(25) KK=KK+1 NEW1=IABS(TRAVEL(KK))/1000 IF(NEW1.EQ.LL)GOTO 12 LL=NEW1 GOTO 11 13 IF(NEWLOC.LE.100)GOTO 14 IF(TOTING(K).OR.(NEWLOC.GT.200.AND.AT(K)))GOTO 16 GOTO 12 14 IF(NEWLOC.NE.0.AND..NOT.PCT(NEWLOC))GOTO 12 16 NEWLOC=MOD(LL,1000) IF(NEWLOC.LE.MAXLOC)GO TO 2000 IF(NEWLOC.LE.500)GOTO 30000 CALL RSPEAK(NEWLOC-500) NEWLOC=LOC RETURN C HANDLE "GO BACK". LOOK FOR VERB WHICH GOES FROM LOC TO OLDLOC, OR TO OLDLC2 C IF OLDLOC HAS FORCED-MOTION. K2 SAVES ENTRY -> FORCED LOC -> PREVIOUS LOC. 20 K=OLDLOC IF(FORCED(K))K=OLDLC2 OLDLC2=OLDLOC OLDLOC=LOC K2=0 IF(K.NE.LOC)GOTO 21 CALL RSPEAK(91) GO TO 2000 21 LL=MOD((IABS(TRAVEL(KK))/1000),1000) IF(LL.EQ.K)GOTO 25 IF(LL.GT.MAXLOC)GOTO 22 J=KEY(LL) IF(FORCED(LL).AND.MOD((IABS(TRAVEL(J))/1000),1000).EQ.K) 1 K2=KK 22 IF(TRAVEL(KK).LT.000000)GOTO 23 KK=KK+1 GOTO 21 23 KK=K2 IF(KK.NE.0)GOTO 25 CALL RSPEAK(140) 2000 IF(NEWLOC.LT.242.OR.NEWLOC.GT.247)RETURN IF(NEWLOC.NE.242)GOTO 2010 KALFLG=0 RETURN 2010 IF(NEWLOC.NE.OLDLOC+1)GOTO 2020 KALFLG=KALFLG+1 RETURN 2020 KALFLG=-10 RETURN 25 K=MOD(IABS(TRAVEL(KK)),1000) KK=KEY(LOC) GOTO 9 C CAVE. DIFFERENT MESSAGES DEPENDING ON WHETHER ABOVE GROUND. 40 IF(OUTSID(LOC))CALL RSPEAK(57) IF(.NOT.OUTSID(LOC))CALL RSPEAK(58) RETURN C NON-APPLICABLE MOTION. VARIOUS MESSAGES DEPENDING ON WORD GIVEN. 50 SPK=12 IF(K.GE.43.AND.K.LE.50)SPK=9 IF(K.EQ.29.OR.K.EQ.30)SPK=9 IF(K.EQ.7.OR.K.EQ.36.OR.K.EQ.37)SPK=10 IF(K.EQ.11.OR.K.EQ.19)SPK=11 IF(K.EQ.62.OR.K.EQ.65.OR.K.EQ.82)SPK=42 IF(K.EQ.17)SPK=80 CALL RSPEAK(SPK) RETURN C SPECIAL MOTIONS COME HERE. LABELLING CONVENTION: STATEMENT NUMBERS NNNXX C (XX=00-99) ARE USED FOR SPECIAL CASE NUMBER NNN (NNN=301-500). 30000 NEWLOC=NEWLOC-MAXLOC GOTO (30100,30200,30300,30400,30500,30600,30700),NEWLOC C ALCOV PLOVR TROLL PHUCE BOOTH BRDGE WRITE(*,1001)NEWLOC 1001 FORMAT('BUG IN TRAVEL TABLES. NEWLOC= ',I5) CALL BUG(20) C TRAVEL 301. PLOVER-ALCOVE PASSAGE. CAN CARRY ONLY EMERALD. NOTE: TRAVEL C TABLE MUST INCLUDE "USELESS" ENTRIES GOING THROUGH PASSAGE, WHICH CAN NEVER C BE USED FOR ACTUAL MOTION, BUT CAN BE SPOTTED BY "GO BACK". 30100 NEWLOC=99+100-LOC KK=BURDEN(0) IF(KK.EQ.0.OR.(KK.EQ.BURDEN(EMRALD).AND.HOLDNG(EMRALD)))RETURN NEWLOC=LOC CALL RSPEAK(117) RETURN C TRAVEL 302. PLOVER TRANSPORT. DROP THE EMERALD (ONLY USE SPECIAL TRAVEL IF C TOTING IT), SO HE'S FORCED TO USE THE PLOVER-PASSAGE TO GET IT OUT. HAVING C DROPPED IT, GO BACK AND PRETEND HE WASN'T CARRYING IT AFTER ALL. 30200 IF(ENCLSD(EMRALD))CALL REMOVE(EMRALD) CALL DROP(EMRALD,LOC) GOTO 12 C TRAVEL 303. TROLL BRIDGE. MUST BE DONE ONLY AS SPECIAL MOTION SO THAT C DWARVES WON'T WANDER ACROSS AND ENCOUNTER THE BEAR. (THEY WON'T FOLLOW THE C PLAYER THERE BECAUSE THAT REGION IS FORBIDDEN TO THE PIRATE.) IF C PROP(TROLL)=1, HE'S CROSSED SINCE PAYING, SO STEP OUT AND BLOCK HIM. C (STANDARD TRAVEL ENTRIES CHECK FOR PROP(TROLL)=0.) SPECIAL STUFF FOR BEAR. 30300 IF(PROP(TROLL).NE.1)GOTO 30310 CALL PSPEAK(TROLL,1) PROP(TROLL)=0 CALL MOVE(TROLL2,0) CALL MOVE(TROLL2+MAXOBJ,0) CALL MOVE(TROLL,PLAC(TROLL)) CALL MOVE(TROLL+MAXOBJ,FIXD(TROLL)) CALL JUGGLE(CHASM) NEWLOC=LOC RETURN 30310 NEWLOC=PLAC(TROLL)+FIXD(TROLL)-LOC IF(PROP(TROLL).EQ.0)PROP(TROLL)=1 IF(.NOT.HOLDNG(BEAR))RETURN CALL RSPEAK(162) PROP(CHASM)=1 PROP(TROLL)=2 CALL DROP(BEAR,NEWLOC) FIXED(BEAR)=-1 PROP(BEAR)=3 IF(PROP(SPICES).LT.0)TALLY2=TALLY2+1 OLDLC2=NEWLOC KILLED=.TRUE. RETURN C TRAVEL 304. GROWING OR SHRINKING IN AREA OF TINY DOOR. EACH TIME C HE DOES THIS, EVERYTHING MUST BE MOVED TO THE NEW LOC. PRESUMABLY, C ALL HIS POSSESIONS ARE SHRUNK OR STRECHED ALONG WITH HIM. C PHUCE(2,4) IS AN ARRAY CONTAINING FOUR PAIRS OF "HERE" (K) AND C "THERE" (KK) LOCATIONS. 30400 K=PHUCE(1,LOC-161+1) NEWLOC=PHUCE(2,LOC-161+1) DO 30410 OBJ=1,MAXOBJ IF(OBJ.EQ.BOAT)GOTO 30410 IF(PLACE(OBJ).EQ.K.AND.(FIXED(OBJ).EQ.0.OR.FIXED(OBJ).EQ.-1)) 1 CALL MOVE(OBJ,NEWLOC) 30410 CONTINUE RETURN C TRAVEL #5. PHONE BOOTH IN ROTUNDA. C TRYING TO SHOVE PAST GNOME, TO GET INTO PHONE BOOTH. 30500 IF((PROP(BOOTH).EQ.0.AND.PCT(55)).OR.ABB(LOC).EQ.1)GOTO 30510 NEWLOC=189 IF(PROP(BOOTH).NE.1)RETURN CALL RSPEAK(253) GOTO 30512 30510 CALL RSPEAK(263) PROP(BOOTH)=1 CALL MOVE(GNOME,188) 30512 NEWLOC=LOC RETURN C TRAVEL #6. COLLAPSING CLAY BRIDGE. HE CAN CROSS WITH THREE (OR FEWER) C THINGS. IF MORE, OR IF CARRYING OBVIOUSLY HEAVY THINGS, HE MAY END UP C IN THE DRINK. 30600 NEWLOC=235 IF(LOC.EQ.235)NEWLOC=190 BCROSS=BCROSS+1 KK=BURDEN(0) IF(KK.LE.4)RETURN K=MAX0( ((KK+BCROSS)**2)/10, 10) 30605 IF(PCT(K))GOTO 30610 CALL RSPEAK(318) RETURN 30610 CALL RSPEAK(319) NEWLOC=236 IF(HOLDNG(LAMP))CALL MOVE(LAMP,236) IF(TOTING(AXE).AND.ENCLSD(AXE))CALL REMOVE(AXE) IF(HOLDNG(AXE))CALL MOVE(AXE,208) DO 30620 OBJ=1,MAXOBJ 30620 IF(TOTING(OBJ))CALL DSTROY(OBJ) PROP(CHASM2)=1 RETURN C THE KALEIDOSCOPE CODE IS HERE 30700 IF(KALFLG.NE.5)GOTO 30701 NEWLOC=248 OLDLOC=247 RETURN 30701 NEWLOC=242+RANZ(5) OLDLOC=NEWLOC-1 CALL RSPEAK(406) KALFLG=-10 IF(NEWLOC.EQ.242)KALFLG=0 RETURN C END OF SPECIALS. END C*** TREASR .TRUE. IF OBJ IS VALUABLE FOR POINTS LOGICAL FUNCTION TREASR(OBJ) C TREASR(OBJ) = TRUE IF OBJECT IS A TREASURE IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) TREASR=BITSET(OBJCON(OBJ),14) RETURN END C*** VAL INTEGER FUNCTION VAL(WORD) C RETURNS THE 'VALUE' OF A WORD, MODULO 1000. IMPLICIT INTEGER(A-Z) VAL=MOD(WORD,1000) RETURN END C*** VESSEL .TRUE. IF OBJ CAN HOLD A LIQUID LOGICAL FUNCTION VESSEL(OBJ) C VESSEL(OBJ) = TRUE IF OBJECT IS A CONTAINER IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON /CONCOM/ LOCCON(250),OBJCON(150) VESSEL=BITSET(OBJCON(OBJ),15) RETURN END C*** VOCABX INTEGER FUNCTION VOCABX(ID,INIT) C LOOK UP ID IN THE VOCABULARY (ATAB) AND RETURN ITS "DEFINITION" (KTAB C -1 IF NOT FOUND. IF INIT IS POSITIVE, THIS IS AN INITIALISATION CALL C UP A KEYWORD VARIABLE, AND NOT FINDING IT CONSTITUTES A BUG. IT ALSO C THAT ONLY KTAB VALUES WHICH TAKEN OVER 1000 EQUAL INIT MAY BE CONSIDE C (THUS "STEPS", WHICH IS A MOTION VERB AS WELL AS AN OBJECT, MAY BE LO C AS AN OBJECT.) AND IT ALSO MEANS THE KTAB VALUE IS TAKEN MOD 1000. IMPLICIT INTEGER(A-Z) CHARACTER*6 ATAB,DTK,ID,VTXT,OTXT,IOTXT,TXT COMMON /VOCCOM/ KTAB(600),TABSIZ COMMON /SV3COM/DTK(9),ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2) 1 ,TXT(35,2) C HASH=ID.XOR.'PHROG' (DONE BY CALLER) WDCLAS=INIT IF(INIT.LT.0)WDCLAS=-INIT-1 DO 1 I=1,TABSIZ IF(KTAB(I).EQ.-1)GOTO 2 IF(ATAB(I).NE.ID)GOTO 1 IF(CLASS(KTAB(I)).GE.WDCLAS)GOTO 3 1 CONTINUE CALL BUG(21) 2 VOCABX=-1 IF(INIT.LT.0)RETURN WRITE(*,4)ID 4 FORMAT (' VOCAB ERROR: CAN''T FIND WORD ''',A5,''' IN TABLE.') CALL BUG(5) 3 VOCABX=KTAB(I) IF(INIT.GE.0)VOCABX=MOD(VOCABX,1000) RETURN END C*** WEARNG .TRUE. IF WEARING OBJ LOGICAL FUNCTION WEARNG(OBJ) C WEARNG(OBJ) = TRUE IF THE OBJ IS BEING WORN IMPLICIT INTEGER(A-Z) COMMON /BITCOM/ OPENBT,UNLKBT,BURNBT,WEARBT COMMON /CONCOM/ LOCCON(250),OBJCON(150) LOGICAL BITSET WEARNG=BITSET(OBJCON(OBJ),WEARBT) RETURN END C*** WORN .TRUE. IF OBJ IS BEING WORN LOGICAL FUNCTION WORN(OBJ) IMPLICIT INTEGER(A-Z) LOGICAL BITSET COMMON/CONCOM/LOCCON(250),OBJCON(150) WORN=BITSET(OBJCON(OBJ),11) RETURN END C*** YES LOGICAL FUNCTION YES(X,Y,Z) C PRINT MESSAGE X, WAIT FOR YES/NO ANSWER. IMPLICIT INTEGER(A-Z) CHARACTER*6 REPLY 1 IF(X.NE.0)CALL RSPEAK(X) WRITE(*,338) 338 FORMAT(/,' >') C??????????????? THE FOLLOWING WORKS BETTER ON VAXES, ETC: C338 FORMAT(/,' >',$) READ(*,30)REPLY 30 FORMAT(A6) DO 2 I=1,6 IF(REPLY(I:I).GE.'a'.AND.REPLY(I:I).LE.'z') 1 REPLY(I:I) = CHAR(ICHAR(REPLY(I:I)) -32) 2 CONTINUE IF(REPLY.EQ.'YES '.OR.REPLY.EQ.'Y ')GOTO 10 IF(REPLY.EQ.'NO '.OR.REPLY.EQ.'N ')GOTO 20 WRITE(*,*)' 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