billr@saab.CNA.TEK.COM (Bill Randle) (08/23/90)
Submitted-by: Doug McDonald <mcdonald@aries.scs.uiuc.edu>
Posting-number: Volume 11, Issue 32
Archive-name: adven2/Part06
Supersedes: adven: Volume 9, Issue 89-96
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 6 (of 7)."
# Contents: asetup.f asubs.f.xab
# Wrapped by billr@saab on Wed Aug 22 16:47:44 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'asetup.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'asetup.f'\"
else
echo shar: Extracting \"'asetup.f'\" \(29694 characters\)
sed "s/^X//" >'asetup.f' <<'END_OF_FILE'
XC THIS IS THE FIRST LINE OF THE SETUP OF ADVENTURE.
XC THE COMMENTS ARE IN THE MAIN PROGRAM
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL DSEEN,BLKLIN,HINTED,YES,START,TERSE,ISWIZ,LOGOUT
X LOGICAL WZDARK,KILLED,RDFLAG,LIVING
X CHARACTER*6 DTK(9),ATAB,DJJ,DK,DKK,DL,DLL
X CHARACTER*6 VTXT,OTXT,IOTXT,TXT
X DIMENSION PHUCE2(2,4)
X
X COMMON/IZWIZ/ISWIZ
X COMMON /ADJCOM/ ADJKEY(50),ADJTAB(150),ADJSIZ
X COMMON /BITCOM/ OPENBT,LOCKBT,BURNBT,WEARBT
X COMMON /BLKCOM/ BLKLIN
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X COMMON /DIECOM/ NUMDIE,MAXDIE,TURNS,KILLED
X COMMON /DWFCOM/ DWARF,KNIFE,KNFLOC,DFLAG,DSEEN(6),DLOC(6),
X 1 ODLOC(6),DWFMAX
X COMMON /HLDCOM/ HOLDER(150),HLINK(150)
X COMMON /HNTCOM/ HINTLC(20),HINTED(20),HINTS(20,4),HNTSIZ,HNTMIN
X COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X COMMON /LTXCOM/ LTEXT(250),STEXT(250),KEY(250),ABB(250),LOCSIZ
X COMMON /MNECOM/ BACK,CAVE,DPRSSN,ENTRNC,EXIT,GO,LOOK,NULL,
X 1 AXE,BEAR,BOAT,BOOK,BOOK2,BOOTH,CARVNG,CHASM,CHASM2,DOOR,GNOME,
X 2 GRATE,LAMP,PDOOR,PLANT,PLANT2,ROCKS,ROD,ROD2,SAFE,
X 3 TDOOR,TDOOR2,TROLL,TROLL2,EMRALD,SPICES,
X 4 FIND,YELL,INVENT,LEAVE,POUR,SAY,TAKE,THROW,
X 5 IWEST,PHUCE(2,4),TK(20)
X
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X COMMON /PRPCOM/ VKEY(60),PTAB(300),VKYSIZ,PTBSIZ
X COMMON /TRVCOM/ TRAVEL(1600)
X COMMON /TXTCOM/ LINES(25000),RTEXT(450),PTEXT(150)
X COMMON /UTXCOM/ WDX
X COMMON /VOCCOM/ KTAB(600),TABSIZ
X COMMON /WRDCOM/ VERBS(45),VRBX,OBJS(45),
X 1 OBJX,IOBJS(15),IOBX,PREP,WORDS(45)
X
X COMMON /SAVCOM/ABBNUM,ADJ,ATBS,ATTACK,BCROSS,BONUS,CHASE,
X 1 CLOCK1,CLOCK2,CLOCK3,CLOSED,CLOSNG,CLSMAX,COMBO,DEADBT,
X 2 DETAIL,DKILL,DTOTAL,DWARFN,FLG239,
X 3 FOO,FOOBAR,FOOD,GAVEUP,HEALTH,HINT,HIT,HNTMAX,I,IKK,ILOC,
X 4 IOBJ,J,JJ,JK1,JKK,K,K1,KK,L,L1,LIMIT,
X 5 LINSIZ,LL,LMWARN,LOCK,LOGOUT,MESSAG,OBJ,PANIC,
X 6 PORTAL,PTBS,RDFLAG,RETN,RTXSIZ,SCORE,SCORNG,SECT,
X 7 SKEY,SLOC,SPK,START,STICK,TABNDX,TALLY,TALLY2,TERSE,
X 8 TRVS,TRVSIZ,VEND,VERB,VRBSIZ,WASTE,WKDAY,WKEND,WZDARK,
X 9 YEA,ACTSPK,CTEXT,CVAL,HNAME
X COMMON /SV2COM/ANVIL,BATTER,BEES,BILLBD,BIRD,BRUSH,CAGE,
X 1 CAKES,CHAIN,CHEST,CHLOC,CHLOC2,CLAM,CLOAK,CLSSES,COINS,CROWN,
X 2 DALTLC,DOG,DRAGON,EGGS,FISSUR,FLOWER,GATLOC,GRAIL,HIVE,
X 3 HONEY,HORN,JEWELS,KEYS,LYRE,
X 4 MAGZIN,MIRROR,MUSHRM,MXSCOR,NUGGET,OYSTER,PEARL,PHONE,
X 5 PILLOW,POLE,POSTER,PREPAT,PREPDN,PREPFR,PREPIN,PREPOF,
X 6 PREPON,PYRAM,RADIUM,RING,RUG,SAPPHI,SHIELD,SHOES,
X 7 SHUT,SLUGS,SNAKE,SPHERE,STEPS,STICKS,SWORD,TABLET,TRIDNT,
X 8 UNLOCK,VASE,WALL,WALL2,WEAR,WUMPUS,Y2,YANK
X COMMON /SV3COM/DTK,ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2)
X 1 ,TXT(35,2)
X DIMENSION ACTSPK(60),CTEXT(12),CVAL(12)
X DIMENSION HNAME(10)
X
X LOGICAL AJAR,AT,ATHAND,BITSET,BLIND,CLOSED,CLOSNG,
X 1 DARK,DEAD,EDIBLE,ENCLSD,FORCED,
X 2 GAVEUP,HERE,HINGED,HOLDNG,INSIDE,LMWARN,LOCKS,OUTSID,OPAQUE,
X 3 PANIC,PCT,PLURAL,PORTAL,PRINTD,SCORNG,SMALL,
X 4 TOTING,TREASR,LOCKED,VESSEL,WEARNG,WORN,YEA,
X 5 YESM
X
XC DATA LINSIZ/25000/,TRVSIZ/1600/,TABSIZ/600/,LOCSIZ/250/,
XC 1 VRBSIZ/60/,RTXSIZ/450/,CLSMAX/12/,HNTSIZ/20/,
XC 2 MAXOBJ/150/,MAXLOC/300/,HNTMIN/7/,PTBSIZ/300/,ADJSIZ/50/,
XC 3 VKYSIZ/60/,BLKLIN/.TRUE./,DWFMAX/6/,ISWIZ/.FALSE./
X
X DATA LINUSE/0/
XC PHUCE CONSISTS OF FOUR PAIRS OF ORIGIN/DESTINATION LOCATIONS FROM/TO
XC WHICH ONE IS TRANSPORTED ON UTTERING THE ELFIN CURSE AT THE TINY
XC DOOR. HE CAN GO FROM BIG TO SMALL OR SMALL TO BIG, ON EITHER SIDE OF
XC THE DOOR.
X DATA PHUCE2/158,160,160,158,167,166,166,167/
X
X
XC DATA DEADBT,OPENBT,LOCKBT,BURNBT,WEARBT /10,2,4,6,12/
XC STATEMENT FUNCTIONS
XC
XC
XC AJAR(OBJ = TRUE IF THE OBJECT IS OPEN
XC AT(OBJ) = TRUE IF ON EITHER SIDE OF TWO-PLACED OBJECT
XC ATHAND(OBJ) = TRUE IF OBJECT IS HERE AND NOT IN CLOSED CONTAINER.
XC BITSET(COND,L,N) = TRUE IF COND(L) HAS BIT N SET (BIT 0 IS UNITS BIT)
XC BLIND(DUMMY) = TRUE IF HERO CAN'T SEE (TOO DARK OR GLAREY)
XC DARK(DUMMY) = TRUE IF LOCATION "LOC" IS DARK
XC DEAD(OBJ) = TRUE IF CRITTER IS KILLED (OR IN ENCHANTED SLEEP)
XC FORCED(LOC) = TRUE IF LOC MOVES WITHOUT ASKING FOR INPUT (COND=2)
XC HERE(OBJ) = TRUE IF THE OBJ IS AT "LOC" (OR IS BEING CARRIED)
XC HINGED(OBJ) = TRUE IF OBJECT CAN BE OPENED/SHUT.
XC INSIDE(LOC) = TRUE IF LOCATION IS WELL WITHIN THE CAVE
XC LIQ(DUMMY) = OBJECT NUMBER OF LIQUID IN BOTTLE
XC LIQLOC(LOC) = OBJECT NUMBER OF LIQUID (IF ANY) AT LOC
XC LIVING(OBJ) = TRUE IF OBJ IS SOME SORT OF CRITTER
XC LOCKED(OBJ) = TRUE IF OBJECT IS LOCKED. (NEED NOT HAVE A LOCK,
XC E.G., RUSTY DOOR)
XC LOCKS(OBJ) = TRUE IF OBJECT HAS A LOCK.
XC OPAQUE(OBJ) = TRUE IF CONTAINER IS NOT TRANSPARENT (SACK, CHEST)
XC TRANSPARENT OBJS: BOTTLE(GLASS), CAGE(WICKER)
XC OUTSID(LOC) = TRUE IF LOCATION IS OUTSIDE THE CAVE
XC PCT(N) = TRUE N% OF THE TIME (N INTEGER FROM 0 TO 100)
XC PLURAL(OBJ) = TRUE IF IT IS A PLURAL OBJ (SHOES, KEYS, ETC.)
XC PORTAL(LOC) = TRUE IS LOCATION IS IN CAVE "ENTRANCE"
XC PRINTD(OBJ) = TRUE IF OBJECT CAN BE READ.
XC SMALL(OBJ) = TRUE IF OBJ FITS INTO SACK
XC TOTING(OBJ) = TRUE IF THE OBJ IS BEING CARRIED
XC TREASR(OBJ) = TRUE IF OBJECT IS A TREASURE
XC VESSEL(OBJ) = TRUE IF OBJECT IS A CONTAINER
XC WEARNG(OBJ) = TRUE IF OBJECT IS BEING WORN
XC WORN(OBJ) = TRUE IF THE OBJECT CAN BE WORN
XC
XC CLOSED SAYS WHETHER WE'RE ALL THE WAY CLOSED
XC CLOSNG SAYS WHETHER ITS CLOSING TIME YET
XC DEMO IS TRUE IF THIS IS A PRIME-TIME DEMONSTRATION GAME
XC GAVEUP SAYS WHETHER HE EXITED VIA "QUIT"
XC LMWARN SAYS WHETHER HE'S BEEN WARNED ABOUT LAMP GOING DIM
XC PANIC SAYS WHETHER HE'S FOUND OUT HE'S TRAPPED IN THE CAVE
XC SCORNG INDICATES TO THE RATING ROUTINE WHETHER WE'RE DOING A "SCORE" COMMAND
XC WZDARK SAYS WHETHER THE LOC HE'S LEAVING WAS DARK
XC YEA IS RANDOM YES/NO REPLY
X
X
X
X
XC CLEAR OUT THE VARIOUS TEXT-POINTER ARRAYS. ALL TEXT IS STORED IN ARRAY
XC LINES; EACH LINE IS PRECEDED BY A WORD POINTING TO THE NEXT POINTER (I.E.
XC THE WORD FOLLOWING THE END OF THE LINE). THE POINTER IS NEGATIVE IF THIS IS
XC FIRST LINE OF A MESSAGE. THE TEXT-POINTER ARRAYS CONTAIN INDICES OF
XC POINTER-WORDS IN LINES. STEXT(N) IS SHORT DESCRIPTION OF LOCATION N.
XC LTEXT(N) IS LONG DESCRIPTION. PTEXT(N) POINTS TO MESSAGE FOR PROP( PROPN)=0
XC SUCCESSIVE PROP MESSAGES ARE FOUND BY CHASING POINTERS. RTEXT CONTAINS
XC SECTION 6'S STUFF. CTEXT(N) POINTS TO A PLAYER-CLASS MESSAGE. MTEXT IS FOR
XC SECTION 12. WE ALSO CLEAR COND. SEE DESCRIPTION OF SECTION 9 FOR DETAILS.
X
X DEADBT = 10
X OPENBT = 2
X LOCKBT = 4
X BURNBT = 6
X WEARBT = 12
X DO 2238 I = 1,2
X DO 2239 J = 1,4
X PHUCE(I,J) = PHUCE2(I,J)
X2239 CONTINUE
X2238 CONTINUE
XC DATA LINSIZ/25000/,TRVSIZ/1600/,TABSIZ/600/,LOCSIZ/250/,
XC 1 VRBSIZ/60/,RTXSIZ/450/,CLSMAX/12/,HNTSIZ/20/,
XC 2 MAXOBJ/150/,MAXLOC/300/,HNTMIN/7/,PTBSIZ/300/,ADJSIZ/50/,
XC 3 VKYSIZ/60/,BLKLIN/.TRUE./,DWFMAX/6/,ISWIZ/.FALSE./
X LINSIZ = 25000
X TRVSIZ = 1600
X TABSIZ = 600
X LOCSIZ = 250
X VRBSIZ = 60
X RTXSIZ = 450
X CLSMAX = 12
X HNTSIZ = 20
X MAXOBJ = 150
X MAXLOC = 300
X HNTMIN = 7
X PTBSIZ = 300
X ADJSIZ = 50
X VKYSIZ = 60
X BLKLIN = .TRUE.
X DWFMAX = 6
X ISWIZ = .FALSE.
X
X ZCLYD = ICHAR('c')+256*(ICHAR('L')+ 256*(ICHAR('y')
X 1 +256*ICHAR('D')))
X ALLSPACE = 32+256*(32+256*(32+256*32))
X DO 1001 I=1,MAXLOC
X IF(I.LE.MAXOBJ)PTEXT(I)=0
X IF(I.LE.RTXSIZ)RTEXT(I)=0
X IF(I.LE.CLSMAX)CTEXT(I)=0
X IF(I.GT.LOCSIZ)GOTO 1001
X STEXT(I)=0
X LTEXT(I)=0
X LOCCON(I)=0
X1001 CONTINUE
X DO 1278 I=1,MAXOBJ
X POINTS(I)=0
X1278 OBJCON(I)=0
X OPEN (UNIT=2,FILE='ADVDAT',STATUS='OLD')
X DO 1279 I=1,250
X KEY(I) = 0
X1279 CONTINUE
X DO 1280 I = 1,50
X1280 ADJKEY(I) = 0
X DO 1281 I=1,150
X WEIGHT(I) = 0
X PLAC(I) = 0
X FIXD(I) = 0
X1281 ADJTAB(I) = 0
X LINUSE=1
X TRVS=1
X PTBS=1
X ATBS=1
X CLSSES=1
X
X
XC START NEW DATA SECTION. SECT IS THE SECTION NUMBER.
X
X1002 READ(2,1003)SECT
X1003 FORMAT(I8)
X WRITE(*,1015)SECT
X1015 FORMAT (' READING TABLE ',I2,'...')
X OLDLOC=-1
X GOTO(1190,1004,1004,1040,1030,1004,1004,1050,1060,1070,1004,
X 1 1080,0999,0999,1100,1120,1140),(SECT+1)
XC (0) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10)
XC (11) (12) (13) (14) (15) (16)
X999 CALL BUG(9)
X
XC SECTIONS 1, 2, 5, 6, 10 READ MESSAGES AND SET UP POINTERS.
X
X1004 JL1=LINUSE+1
X JL2=LINUSE+18
X
X READ(2,1005)LOC,(LINES(J12),J12=JL1,JL2),KK
X1005 FORMAT(I8,19A4)
X IF(KK.EQ.ALLSPACE)GOTO 1017
X PRINT 1016,LOC
X1016 FORMAT (1X,'LINE FOR LOCN ',I4,' TOO LONG.')
X CALL BUG(0)
X
X1017 IF(LOC.EQ.-1)GOTO 1002
X DO 1006 K=1,18
X JKK=LINUSE+19-K
X IF(LINES(JKK).NE.ALLSPACE)GOTO 1007
X1006 CONTINUE
X IF(LOC.EQ.0)GOTO 1004
XC ABOVE KLUGE IS TO AVOID F40 BUG IF CRLF BROKEN ACROSS RECORD BOUNDARY
X CALL BUG(1)
X
X1007 JL1=LINUSE+1
X DO 1008 JK1=JL1,JKK
X1008 LINES(JK1)=IEOR(LINES(JK1),ZCLYD)
X LINES(LINUSE)=JKK+1
X IF(LOC.EQ.OLDLOC)GOTO 1020
X IF(LOC.GT.OLDLOC.OR.SECT.EQ.5)GOTO 1019
X PRINT 1018,LOC,SECT
X1018 FORMAT (/' LINE ',I3,' OUT OF ORDER IN SECTION ',I2)
X CALL BUG(10)
X
X1019 LINES(LINUSE)=-LINES(LINUSE)
X IF(SECT.EQ.10)GOTO 1012
X IF(SECT.EQ.6)GOTO 1011
X IF(SECT.EQ.5)GOTO 1010
X IF(SECT.EQ.1)GOTO 1009
X
X STEXT(LOC)=LINUSE
X GOTO 1020
X
X1009 LTEXT(LOC)=LINUSE
X GOTO 1020
X
X1010 IF(LOC.GT.0.AND.LOC.LE.MAXOBJ)PTEXT(LOC)=LINUSE
X GOTO 1020
X
X1011 IF(LOC.GT.RTXSIZ)CALL BUG(6)
X RTEXT(LOC)=LINUSE
X GOTO 1020
X
X1012 CTEXT(CLSSES)=LINUSE
X CVAL(CLSSES)=LOC
X CLSSES=CLSSES+1
X GOTO 1020
X
X
X1020 LINUSE=JKK+1
X LINES(LINUSE)=-1
X OLDLOC=LOC
X IF(LINUSE+18.GT.LINSIZ)CALL BUG(2)
X GOTO 1004
X
XC THE STUFF FOR SECTION 4 IS ENCODED HERE. EACH "FROM-LOCATION" GETS A
XC CONTIGUOUS SECTION OF THE "TRAVEL" ARRAY. EACH ENTRY IN TRAVEL IS
XC NEWLOC*1000 + KEYWORD (FROM SECTION 3, MOTION VERBS), AND IS NEGATED IF
XC THIS IS THE LAST ENTRY FOR THIS LOCATION. KEY(N) IS THE INDEX IN TRAVEL
XC OF THE FIRST OPTION AT LOCATION N.
X
X1030 READ(2,1031)LOC,JNEW,(DTK(I),I=1,8)
X1031 FORMAT(2I8,8(A6,2X))
X IF(LOC.EQ.0)GOTO 1030
XC ABOVE KLUGE IS TO AVOID AFOREMENTIONED F40 BUG
X IF(LOC.EQ.-1)GOTO 1002
X IF(LOC.GE.OLDLOC)GOTO 1032
X PRINT 1018,LOC,SECT
X CALL BUG(10)
X
X1032 IF(KEY(LOC).NE.0)GOTO 1033
X KEY(LOC)=TRVS
X GOTO 1035
X
X1033 TRAVEL(TRVS-1)=-TRAVEL(TRVS-1)
X1035 DO 1037 L=1,8
X IF(DTK(L).EQ.' ')GOTO 1039
X K=VOCABX(DTK(L),-1)
X TRAVEL(TRVS)=JNEW*1000+K
X TRVS=TRVS+1
X IF(TRVS.EQ.TRVSIZ)CALL BUG(3)
X1037 CONTINUE
X1039 TRAVEL(TRVS-1)=-TRAVEL(TRVS-1)
X GOTO 1030
X
XC HERE WE READ IN THE VOCABULARY. KTAB(N) IS THE WORD NUMBER, ATAB(N) IS
XC THE CORRESPONDING WORD. THE -1 AT THE END OF SECTION 3 IS LEFT IN KTAB
XC AS AN END-MARKER. THE WORDS ARE GIVEN A MINIMAL HASH TO MAKE READING THE
XC CORE-IMAGE HARDER.
X
X1040 DO 1042 TABNDX=1,TABSIZ
X1043 READ(2,1041)KTAB(TABNDX),ATAB(TABNDX)
X1041 FORMAT(I8,A6)
XC IF(KTAB(TABNDX).EQ.0)GOTO 1043
XC ABOVE KLUGE IS TO AVOID AFOREMENTIONED F40 BUG
X IF(KTAB(TABNDX).EQ.-1)GOTO 1002
X1042 CONTINUE
X CALL BUG(4)
X
XC READ IN THE INITIAL LOCATIONS FOR EACH OBJECT. ALSO THE IMMOVABILITY INFO.
XC PLAC CONTAINS INITIAL LOCATIONS OF OBJECTS. FIXD IS -1 FOR IMMOVABLE
XC OBJECTS (INCLUDING THE SNAKE), OR = SECOND LOC FOR TWO-PLACED OBJECTS.
XC WEIGHT CONTAINS THE HEAVINESS OF EACH OBJ, ON A SCALE OF 1-10.
X
X1050 READ(2,1052) OBJ,J,K,KK,DL,DLL,(TK(I),I=1,3)
X1052 FORMAT(4I8,2(A6,2X),3I8)
X IF(OBJ.EQ.-1)GOTO 1002
X IF(OBJ.LE.0.OR.OBJ.GT.MAXOBJ)CALL BUG(17)
X PLAC(OBJ)=J
X FIXD(OBJ)=K
X WEIGHT(OBJ)=KK
XC READ DEFAULT OBJECT NAMES. FOR USE IN 'TAKE ALL' COMMANDS.
XC READ POINT VALUES FOR TREASURES.
X K=1
X IF(TK(3).LT.0)K=-1
X POINTS(OBJ)= (TK(1)*1000000*K) + (TK(2)*1000*K) + TK(3)
X GOTO 1050
X
XC READ DEFAULT MESSAGE NUMBERS FOR ACTION VERBS, STORE IN ACTSPK.
X
X1060 READ(2,1061)VERB,J
X1061 FORMAT(10I8)
X IF(VERB.EQ.-1)GOTO 1002
X ACTSPK(VERB)=J
X GOTO 1060
X
XC READ INFO ABOUT AVAILABLE LIQUIDS AND OTHER CONDITIONS, STORE IN COND.
X
X1070 READ(2,1061)K,(TK(I),I=1,9)
X IF(K.EQ.-1)GOTO 1002
X DO 1071 I=1,9
X LOC=TK(I)
X IF(LOC.EQ.0)GOTO 1070
X IF(K.GT.7)GOTO 1072
X IF(BITSET(LOCCON(LOC),K))CALL BUG(8)
X LOCCON(LOC)=LOCCON(LOC)+BITS(K)
X GOTO 1071
X1072 LOCCON(LOC)=IOR(LOCCON(LOC),(256*(K-7)))
X1071 CONTINUE
X GOTO 1070
X
XC READ DATA FOR HINTS.
X
X1080 HNTMAX=0
X1081 READ(2,1061)K,(TK(I),I=1,9)
X IF(K.EQ.-1)GOTO 1002
X IF(K.EQ.0)GOTO 1081
X IF(K.LT.0.OR.K.GT.HNTSIZ)CALL BUG(7)
X DO 1083 I=1,4
X1083 HINTS(K,I)=TK(I)
X HNTMAX=MAX0(HNTMAX,K)
X GOTO 1081
X
XC SECTION 14 IS THE PREPOSITION TABLE.
X1100 READ(2,1101)DK,DKK,(DTK(I),I=1,8)
X1101 FORMAT(10(A6,2X))
XC IF(DK.EQ.0)GOTO 1100
XC ABOVE KLUGE IS TO AVOID AFOREMENTIONED F40 BUG
X IF(DK.EQ.'-1 ')GOTO 1002
X VERB=VAL(VOCABX(DK,-4))
X DJJ=DK
X IF(VERB.EQ.-1)GOTO 7645
X PREP=VAL(VOCABX(DKK,-6))
X DJJ=DKK
X IF(PREP.EQ.-1)GOTO 7645
X
X IF(VKEY(VERB).NE.0)GOTO 1104
X VKEY(VERB)=PTBS
X GOTO 1105
X
X7645 PRINT 1107,DJJ
X CALL BUG(14)
X GOTO 1100
X
X
X1104 PTAB(PTBS-1)=-PTAB(PTBS-1)
X1105 DO 1110 L=1,8
X IF(DTK(L).EQ.' ')GOTO 1111
X K=VAL(VOCABX(DTK(L),-3))
X IF(K.NE.-1)GOTO 1108
X K=999
X IF(L.EQ.1.AND.DTK(1).EQ.'ANY ')GOTO 1108
X DJJ=DTK(L)
X1106 PRINT 1107,DJJ
X1107 FORMAT(/' UNRECOGNIZED WORD "',A6,'" IN PREP/OBJ TABLE.')
X CALL BUG(14)
X
X1108 PTAB(PTBS)=PREP*1000+K
X PTBS=PTBS+1
X IF(PTBS.EQ.PTBSIZ)CALL BUG(15)
X1110 CONTINUE
X1111 PTAB(PTBS-1)=-PTAB(PTBS-1)
X GOTO 1100
X
XC READ CONDITION BITS FOR OBJECTS. KK IS THE BIT; TK(I), THE OBJ LIST.
X
X1120 READ(2,1061)IKK,(TK(I),I=1,9)
X IF(IKK.EQ.-1)GOTO 1002
X DO 1125 I=1,9
X OBJ=TK(I)
X IF(OBJ.EQ.0)GOTO 1120
X IF(OBJ.LE.0.OR.OBJ.GT.MAXOBJ)CALL BUG(17)
X IF(.NOT.BITSET(OBJCON(OBJ),IKK))GOTO 1125
X WRITE(6,101)OBJ,IKK
X101 FORMAT('BIT SET TWICE OBJ=',I5,' BIT= ',I5)
X CALL BUG(16)
X1125 OBJCON(OBJ)=IOR(OBJCON(OBJ),BITS(IKK))
X GOTO 1120
X
XC SECTION 17 IS THE ADJECTIVE TABLE.
X1140 CONTINUE
X READ(2,1141)DK,(DTK(I),I=1,9)
X1141 FORMAT(10(A6,2X))
XC IF(DK.EQ.0)GOTO 1140
XC ABOVE KLUGE IS TO AVOID AFOREMENTIONED F40 BUG
X IF(DK.EQ.'-1 ')GOTO 1002
X ADJ=VOCABX(DK,-7)
X DJJ=DK
X IF(ADJ.EQ.-1.OR.CLASS(ADJ).NE.6)GOTO 1148
X ADJ=VAL(ADJ)
X IF(ADJKEY(ADJ).NE.0)GOTO 1142
X ADJKEY(ADJ)=ATBS
X GOTO 1143
X
X1142 ADJTAB(ATBS-1)=-ADJTAB(ATBS-1)
X1143 DO 1145 L=1,9
X IF(DTK(L).EQ.' ')GOTO 1146
X DJJ=DTK(L)
X K=VOCABX(DTK(L),-3)
X IF(K.EQ.-1.OR.CLASS(K).NE.2)GOTO 1148
X ADJTAB(ATBS)=VAL(K)
X ATBS=ATBS+1
X IF(ATBS.EQ.MAXOBJ)CALL BUG(18)
X1145 CONTINUE
X1146 ADJTAB(ATBS-1)=-ADJTAB(ATBS-1)
X GOTO 1140
X
X1148 PRINT 1149,DJJ
X1149 FORMAT(/' UNRECOGNIZED WORD "',A6,'" IN ADJECTIVE TABLE.')
X CALL BUG(13)
X
X
XC EVERYTHING IS READ! NOW FINISH CONSTRUCTING INTERNAL DATA FORMAT.
XC DEFINE SOME HANDY MNEMONICS. THESE CORRESPOND TO OBJECT NUMBERS.
XC (INCLUDES TREASURES.)
X
X1190 CLOSE(UNIT=2)
X ANVIL=VOCABX('ANVIL ',2)
X AXE=VOCABX('AXE ',2)
X BATTER=VOCABX('BATTER',2)
X BEAR=VOCABX('BEAR ',2)
X BEES=VOCABX('BEES ',2)
X BILLBD=VOCABX('BILLBO',2)
X BIRD=VOCABX('BIRD ',2)
X BOAT=VOCABX('BOAT ',2)
X BOOK=VOCABX('BOOK ',2)
X BOOK2=BOOK+1
X BOOTH=VOCABX('BOOTH ',2)
X BOTTLE=VOCABX('BOTTLE',2)
X BRUSH=VOCABX('BRUSH ',2)
X CAGE=VOCABX('CAGE ',2)
X CAKES=VOCABX('CAKES ',2)
X CARVNG=VOCABX('CARVIN',2)
X CASK=VOCABX('CASK ',2)
X CHAIN=VOCABX('CHAIN ',2)
X CHASM=VOCABX('CHASM ',2)
X CHASM2=CHASM+1
X CHEST=VOCABX('CHEST ',2)
X CLAM=VOCABX('CLAM ',2)
X CLOAK=VOCABX('CLOAK ',2)
X COINS=VOCABX('COINS ',2)
X CROWN=VOCABX('CROWN ',2)
X DOG=VOCABX('DOG ',2)
X DOOR=VOCABX('DOOR ',2)
X DRAGON=VOCABX('DRAGON',2)
X DWARF=VOCABX('DWARF ',2)
X EGGS=VOCABX('EGGS ',2)
X EMRALD=VOCABX('EMERAL',2)
X FISSUR=VOCABX('FISSUR',2)
X FLOWER=VOCABX('FLOWER',2)
X FOOD=VOCABX('FOOD ',2)
X GNOME=VOCABX('GNOME ',2)
X GRAIL=VOCABX('GRAIL ',2)
X GRATE=VOCABX('GRATE ',2)
X HIVE=VOCABX('HIVE ',2)
X HONEY=VOCABX('HONEY ',2)
X HORN=VOCABX('HORN ',2)
X JEWELS=VOCABX('JEWELS',2)
X KEYS=VOCABX('KEYS ',2)
X KNIFE=VOCABX('KNIFE ',2)
X LAMP=VOCABX('LAMP ',2)
X LYRE=VOCABX('LYRE ',2)
X MAGZIN=VOCABX('MAGAZI',2)
X MESSAG=VOCABX('MESSAG',2)
X MIRROR=VOCABX('MIRROR',2)
X MUSHRM=VOCABX('MUSHRO',2)
X NUGGET=VOCABX('NUGGET',2)
X OIL=VOCABX('OIL ',2)
XC OIL2=OIL+1
X OYSTER=VOCABX('OYSTER',2)
X PEARL=VOCABX('PEARL ',2)
X PHONE=VOCABX('PHONE ',2)
X PILLOW=VOCABX('PILLOW',2)
X PLANT=VOCABX('PLANT ',2)
X PLANT2=PLANT+1
X POLE=VOCABX('POLE ',2)
X POSTER=VOCABX('POSTER',2)
X PYRAM=VOCABX('PYRAMI',2)
X RADIUM=VOCABX('RADIUM',2)
X RING=VOCABX('RING ',2)
X ROCKS=VOCABX('ROCKS ',2)
X ROD= VOCABX('ROD ',2)
X ROD2=ROD+1
X RUG=VOCABX('RUG ',2)
X SAFE=VOCABX('SAFE ',2)
X SAPPHI=VOCABX('SAPPHI',2)
X SHIELD=VOCABX('TUBE ',2)
X SHOES=VOCABX('SHOES ',2)
X SKEY=VOCABX('KEY ',2)
X SLUGS=VOCABX('SLUGS ',2)
X SNAKE=VOCABX('SNAKE ',2)
X SPICES=VOCABX('SPICES',2)
X SPHERE=VOCABX('SPHERE',2)
X STEPS=VOCABX('STEPS ',2)
X STICKS=VOCABX('STICKS',2)
X SWORD=VOCABX('SWORD ',2)
X TABLET=VOCABX('TABLET',2)
X TDOOR=DOOR+1
X TDOOR2=TDOOR+1
X PDOOR=TDOOR2+1
X TRIDNT=VOCABX('TRIDEN',2)
X TROLL=VOCABX('TROLL ',2)
X TROLL2=TROLL+1
X VASE=VOCABX('VASE ',2)
X VEND=VOCABX('MACHIN',2)
X WALL=VOCABX('WALL ',2)
X WALL2=WALL+1
X WATER=VOCABX('WATER ',2)
XC WATER2=WATER+1
X WINE=VOCABX('WINE ',2)
XC WINE2=WINE+1
X WUMPUS=VOCABX('WUMPUS',2)
X
XC THESE ARE MOTION-VERB NUMBERS.
X
X BACK=VOCABX('BACK ',1)
X CAVE=VOCABX('CAVE ',1)
X DPRSSN=VOCABX('DEPRES',1)
X ENTRNC=VOCABX('ENTRAN',1)
X EXIT=VOCABX('EXIT ',1)
X NULL=VOCABX('NULL ',1)
X
XC AND SOME ACTION VERBS.
X
X FIND=VOCABX('FIND ',3)
X GO=VOCABX('GO ',3)
X HIT=VOCABX('HIT ',3)
X LOOK=VOCABX('LOOK ',3)
X YELL=VOCABX('CALL ',3)
X INVENT=VOCABX('INVENT',3)
X LEAVE=VOCABX('LEAVE ',3)
X LOCK=VOCABX('LOCK ',3)
X SAY=VOCABX('SAY ',3)
X SHUT=VOCABX('CLOSE ',3)
X TAKE=VOCABX('TAKE ',3)
X THROW=VOCABX('THROW ',3)
X UNLOCK=VOCABX('UNLOCK',3)
X WEAR=VOCABX('WEAR ',3)
X YANK=VOCABX('YANK ',3)
X
XC AND A FEW PREPOSITIONS. PREFIX 'PREP' TO DISTINGUISH THEM FROM FUNCTIONS & R
X
X PREPAT=VOCABX('AT ',5)
X PREPDN=VOCABX('DOWN ',5)
X PREPFR=VOCABX('FROM ',5)
X PREPIN=VOCABX('IN ',5)
X PREPOF=VOCABX('OFF ',5)
X PREPON=VOCABX('ON ',5)
X
XC A POPULAR LOCATION IS:
X
X Y2=33
X1200 CONTINUE
X
XC HAVING READ IN THE DATABASE, CERTAIN THINGS ARE NOW CONSTRUCTED. PROPS ARE
XC SET TO ZERO. WE FINISH SETTING UP COND BY CHECKING FOR FORCED-MOTION TRAVEL
XC ENTRIES. THE PLAC AND FIXD ARRAYS ARE USED TO SET UP ATLOC(N) AS THE FIRST
XC OBJECT AT LOCATION N, AND LINK(OBJ) AS THE NEXT OBJECT AT THE SAME LOCATION
XC AS OBJ. (OBJ>MAXOBJ INDICATES THAT FIXED(OBJ-MAXOBJ)=LOC; LINK(OBJ) IS STILL
XC THE CORRECT LINK TO USE.) ABB IS ZEROED; IT CONTROLS WHETHER THE ABBREVIATED
XC DESCRIPTION IS PRINTED. COUNTS MOD 5 UNLESS "LOOK" IS USED.
X
X LOC = 1
X DO 1201 I=1,MAXOBJ
X PLACE(I)=0
X PROP(I)=0
X HOLDER(I)=0
X HLINK(I)=0
X LINK(I)=0
X1201 LINK(I+MAXOBJ)=0
X
X DO 1202 I=1,LOCSIZ
X ABB(I)=0
X IF(LTEXT(I).EQ.0.OR.KEY(I).EQ.0)GOTO 1202
X K=KEY(I)
X IF(MOD(IABS(TRAVEL(K)),0001000).EQ.1)LOCCON(I)=2
X1202 ATLOC(I)=0
X
XC SET UP THE ATLOC AND LINK ARRAYS AS DESCRIBED ABOVE. WE'LL USE THE DROP
XC SUBROUTINE, WHICH PREFACES NEW OBJECTS ON THE LISTS. SINCE WE WANT THINGS
XC IN THE OTHER ORDER, WE'LL RUN THE LOOP BACKWARDS. IF THE OBJECT IS IN TWO
XC LOCS, WE DROP IT TWICE. THIS ALSO SETS UP "PLACE" AND "FIXED" AS COPIES OF
XC "PLAC" AND "FIXD". ALSO, SINCE TWO-PLACED OBJECTS ARE TYPICALLY BEST
XC DESCRIBED LAST, WE'LL DROP THEM FIRST.
X
X DO 1206 I=1,MAXOBJ
X K=MAXOBJ+1-I
X IF(FIXD(K).LE.0)GOTO 1206
X CALL DROP(K+MAXOBJ,FIXD(K))
X CALL DROP(K,PLAC(K))
X1206 CONTINUE
X
X DO 1207 I=1,MAXOBJ
X K=MAXOBJ+1-I
X FIXED(K)=FIXD(K)
X1207 IF(PLAC(K).NE.0.AND.FIXD(K).LE.0)CALL DROP(K,PLAC(K))
X
XC MAKE SURE ALL THE RIGHT THINGS GET CLOSED AND LOCKED, ETC., BEFORE
XC WE GET STARTED.
X
X
XC TREASURES, AS NOTED EARLIER, ARE OBJECTS WITH BITSET(14) IN OBJCON.
XC THEIR PROPS ARE INITIALLY -1, AND ARE SET TO 0 THE FIRST TIME THEY ARE
XC DESCRIBED. TALLY KEEPS TRACK OF HOW MANY ARE NOT YET FOUND, SO WE KNOW
XC WHEN TO CLOSE THE CAVE. TALLY2 COUNTS HOW MANY CAN NEVER BE FOUND (E.G. IF
XC LOST BIRD OR BRIDGE).
X
X TALLY=0
X TALLY2=0
X DO 1240 I=1,MAXOBJ
X IF(.NOT.TREASR(I))GOTO 1240
X IF(PTEXT(I).NE.0)PROP(I)=-1
X1240 TALLY=TALLY-PROP(I)
X
X
XC CLEAR THE HINT STUFF. HINTLC(I) IS HOW LONG HE'S BEEN AT LOC WITH COND BIT
XC I. HINTED(I) IS TRUE IFF HINT I HAS BEEN USED.
X
X DO 1300 I=1,HNTMAX
X HINTED(I)=.FALSE.
X1300 HINTLC(I)=0
X
XC INITIALISE THE DWARVES. DLOC IS LOC OF DWARVES, HARD-WIRED IN. ODLOC IS
XC PRIOR LOC OF EACH DWARF, INITIALLY GARBAGE. DALTLC IS ALTERNATE INITIAL LOC
XC FOR DWARF, IN CASE ONE OF THEM STARTS OUT ON TOP OF THE ADVENTURER. (NO 2
XC OF THE 5 INITIAL LOCS ARE ADJACENT.) DSEEN IS TRUE IF DWARF HAS SEEN HIM.
XC DFLAG CONTROLS THE LEVEL OF ACTIVATION OF ALL THIS:
XC 0 NO DWARF STUFF YET (WAIT UNTIL REACHES HALL OF MISTS)
XC 1 REACHED HALL OF MISTS, BUT HASN'T MET FIRST DWARF
XC 2 MET FIRST DWARF, OTHERS START MOVING, NO KNIVES THROWN YET
XC 3 A KNIFE HAS BEEN THROWN (FIRST SET ALWAYS MISSES)
XC 3+ DWARVES ARE MAD (INCREASES THEIR ACCURACY)
XC SIXTH DWARF IS SPECIAL (THE PIRATE). HE ALWAYS STARTS AT HIS CHEST'S
XC EVENTUAL LOCATION INSIDE THE MAZE. THIS LOC IS SAVED IN CHLOC FOR REF.
XC THE DEAD END IN THE OTHER MAZE HAS ITS LOC STORED IN CHLOC2.
X
X CHLOC=114
X CHLOC2=140
X DO 1700 I=1,DWFMAX
X1700 DSEEN(I)=.FALSE.
X DFLAG=0
X DLOC(1)=PLAC(SNAKE)
X DLOC(2)=PLAC(BOOTH)
X DLOC(3)=Y2
X DLOC(4)=44
X DLOC(5)=PLAC(CLAM)
XC DLOC(6)=PLAC(VEND)
X DLOC(DWFMAX)=CHLOC
X DALTLC=PLAC(NUGGET)
X
XC OTHER RANDOM FLAGS AND COUNTERS, AS FOLLOWS:
XC ABBNUM HOW OFTEN WE SHOULD PRINT NON-ABBREVIATED DESCRIPTIONS
XC BCROSS NUMBER OF TIMES COLLAPSING BRIDGE HAS BEEN TRAVERSED.
XC BONUS USED TO DETERMINE AMOUNT OF BONUS IF HE REACHES CLOSING
XC CHASE TELLS HOW CLOSE THE WUMPUS IS TO GOBBLING HIM UP
XC CLOCK1 NUMBER OF TURNS FROM FINDING LAST TREASURE TILL CLOSING
XC CLOCK2 NUMBER OF TURNS FROM FIRST WARNING TILL BLINDING FLASH
XC CLOCK3 NUMBER OF TURNS IN REPOSITORY TILL PHONE RINGS.
XC AFTER TICKING TO 0, TICKS 7 TIMES TO WAKE DWARVES.
XC COMBO CURRENT PROGRESS IN GIVING SAFE'S COMBINATION
XC DETAIL HOW OFTEN WE'VE SAID "NOT ALLOWED TO GIVE MORE DETAIL"
XC DKILL NUMBER OF DWARVES KILLED (UNUSED IN SCORING, NEEDED FOR MSG)
XC FOOBAR CURRENT PROGRESS IN SAYING "FEE FIE FOE FOO".
XC HEALTH PERCENTAGE OF MAXIMUM (100) FITNESS
XC IWEST HOW MANY TIMES HE'S SAID "WEST" INSTEAD OF "W"
XC KNFLOC 0 IF NO KNIFE HERE, LOC IF KNIFE HERE, -1 AFTER CAVEAT
XC LIMIT LIFETIME OF LAMP (NOT SET HERE)
XC MAXDIE NUMBER OF REINCARNATION MESSAGES AVAILABLE (UP TO 5)
XC NUMDIE NUMBER OF TIMES KILLED SO FAR
XC TERSE IF TRUE, NEVER PRINT LONG LOCATION DESCRIPTIONS
XC TURNS TALLIES HOW MANY COMMANDS HE'S GIVEN (IGNORES YES/NO)
XC WASTE TELLS HOW LONG HE HAS USED LAMP IN LIGHTED AREA.
X
XC LOGICALS WERE EXPLAINED EARLIER
X
X ABBNUM=5
X BCROSS=0
X BONUS=0
X CLOCK1=30
X CLOCK2=50
X CLOCK3=20+RANZ(20)
X CHASE=0
X CLOSED=.FALSE.
X CLOSNG=.FALSE.
X COMBO=0
X DETAIL=0
X DKILL=0
X FOOBAR=0
X GAVEUP=.FALSE.
X HEALTH=100
X IWEST=0
X KNFLOC=0
X LMWARN=.FALSE.
X DO 1800 I=0,4
X1800 IF(RTEXT(2*I+81).NE.0)MAXDIE=I+1
X NUMDIE=0
X PANIC=.FALSE.
X SCORNG=.FALSE.
X TERSE=.FALSE.
X TURNS=0
X WASTE=0
X
XC SETUP THE LIQUIDS ACCORDING TO CONTAINER PROP VALUES
X LIQTYP(1)=WATER
X LIQTYP(2)=0
X LIQTYP(3)=OIL
X LIQTYP(4)=0
X LIQTYP(5)=WINE
X
X PROP(POLE)=1
X PROP(SKEY)=1
X PLACE(WATER)=-1
X CALL INSERT(WATER,BOTTLE)
X PLACE(BOOK)=-1
X CALL INSERT(BOOK,SAFE)
X
XC AND CLEAR OUT ANY LEFTOVER WORD VECTORS...
X CALL CLRLIN
X DO 1810 WDX=1,35
X1810 WORDS(WDX)=0
X WDX=0
X
XC IF SETUP=1, REPORT ON AMOUNT OF ARRAYS ACTUALLY USED, TO PERMIT REDUCTIONS.
X
X
X JJ=0
X DO 1989 K=1,VKYSIZ
X1989 IF(VKEY(K).NE.0)JJ=JJ+1
X
X DO 1998 K=1,LOCSIZ
X KK=LOCSIZ+1-K
X IF(LTEXT(KK).NE.0)GOTO 1997
X1998 CONTINUE
X
X1997 LL=0
X OBJ=0
X DO 1996 K=1,MAXOBJ
X IF(TREASR(K))LL=LL+1
X1996 IF(PTEXT(K).NE.0)OBJ=OBJ+1
X
X DO 1995 K=1,TABNDX
X1995 IF(KTAB(K)/1000.EQ.2)VERB=KTAB(K)-2000
X
X DO 1994 K=1,RTXSIZ
X J=RTXSIZ+1-K
X IF(RTEXT(J).NE.0)GOTO 1993
X1994 CONTINUE
X
X1993 CONTINUE
X1992 CONTINUE
X
X
X1991 CALL RATING(SCORE,0,.FALSE.,.FALSE.,.FALSE.,.FALSE.,
X 1 HNTMAX)
X K=MAXOBJ
X PRINT 1999,LINUSE,LINSIZ,TRVS,TRVSIZ,TABNDX,TABSIZ,KK,
X 1 LOCSIZ,OBJ,K,LL,VERB,VRBSIZ,J,RTXSIZ,CLSSES,CLSMAX,
X 2 HNTMAX,HNTSIZ,PTBS,PTBSIZ,JJ,VERB,
X 3 MXSCOR
X1999 FORMAT (' TABLE SPACE USED:'/
X 1 ' ',I6,' OF ',I6,' WORDS OF MESSAGES'/
X 2 ' ',I6,' OF ',I6,' TRAVEL OPTIONS'/
X 3 ' ',I6,' OF ',I6,' VOCABULARY WORDS'/
X 4 ' ',I6,' OF ',I6,' LOCATIONS'/
X 5 ' ',I6,' OF ',I6,' OBJECTS OF WHICH ',I2,' ARE TREASURES.'/
X 6 ' ',I6,' OF ',I6,' ACTION VERBS'/
X 7 ' ',I6,' OF ',I6,' RTEXT MESSAGES'/
X 8 ' ',I6,' OF ',I6,' CLASS MESSAGES'/
X 9 ' ',I6,' OF ',I6,' HINTS'/
X 2 ' ',I6,' OF ',I6,' VERB/PREP/OBJ OPTIONS'/
X 3 ' ',I6,' OF ',I6,' VERBS TAKE PREPOSITIONS'/
X 4 /' MAXIMUM SCORE FOR THIS VERSION IS ',I4,' POINTS.'/
X 5 )
X8445 OPEN (UNIT=16,FILE='ADVTXT',STATUS='UNKNOWN',FORM=
X 1 'UNFORMATTED',ACCESS='SEQUENTIAL')
X WRITE(16)ISWIZ,ADJKEY,ADJTAB,ADJSIZ,OPENBT,LOCKBT,BURNBT,WEARBT
X WRITE(16)BLKLIN,LOCCON,OBJCON,NUMDIE,MAXDIE,TURNS,KILLED
X WRITE(16)DWARF,KNIFE,KNFLOC,DFLAG,DSEEN,DLOC,ODLOC,DWFMAX
X WRITE(16)HOLDER,HLINK,HINTLC,HINTED,HINTS,HNTSIZ,HNTMIN
X WRITE(16)BOTTLE,CASK,WATER,OIL,WINE,LIQTYP
X WRITE(16)LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X WRITE(16) LTEXT,STEXT,KEY,ABB,LOCSIZ
X WRITE(16) BACK,CAVE,DPRSSN,ENTRNC,EXIT,GO,LOOK,NULL,
X 1 AXE,BEAR,BOAT,BOOK,BOOK2,BOOTH,CARVNG,CHASM,CHASM2,DOOR,GNOME,
X 2 GRATE,LAMP,PDOOR,PLANT,PLANT2,ROCKS,ROD,ROD2,SAFE,
X 3 TDOOR,TDOOR2,TROLL,TROLL2,EMRALD,SPICES,
X 4 FIND,YELL,INVENT,LEAVE,POUR,SAY,TAKE,THROW,
X 5 IWEST,PHUCE,TK
X
X WRITE(16)PLAC,FIXD,WEIGHT,PROP,POINTS
X WRITE(16) ATLOC,LINK,PLACE,
X 1 FIXED,MAXOBJ
X WRITE(16) VKEY,PTAB,VKYSIZ,PTBSIZ,TRAVEL
X WRITE(16)LINES,RTEXT,PTEXT,WDX,KTAB,TABSIZ
X WRITE(16) VERBS,VRBX,OBJS,
X 1 OBJX,IOBJS,IOBX,PREP,WORDS
X
X WRITE(16)ABBNUM,ADJ,ATBS,ATTACK,BCROSS,BONUS,CHASE,
X 1 CLOCK1,CLOCK2,CLOCK3,CLOSED,CLOSNG,CLSMAX,COMBO,DEADBT,
X 2 DETAIL,DKILL,DTOTAL,DWARFN,FLG239,
X 3 FOO,FOOBAR,FOOD,GAVEUP,HEALTH,HINT,HIT,HNTMAX,I,IKK,ILOC,
X 4 IOBJ,J,JJ,JK1,JKK,K,K1,KK,L,L1,LIMIT,
X 5 LINSIZ,LL,LMWARN,LOCK,LOGOUT,MESSAG,OBJ,PANIC,
X 6 PORTAL,PTBS,RDFLAG,RETN,RTXSIZ,SCORE,SCORNG,SECT,
X 7 SKEY,SLOC,SPK,START,STICK,TABNDX,TALLY,TALLY2,TERSE,
X 8 TRVS,TRVSIZ,VEND,VERB,VRBSIZ,WASTE,WKDAY,WKEND,WZDARK,
X 9 YEA,ACTSPK,CTEXT,CVAL,HNAME
X WRITE(16)ANVIL,BATTER,BEES,BILLBD,BIRD,BRUSH,CAGE,
X 1 CAKES,CHAIN,CHEST,CHLOC,CHLOC2,CLAM,CLOAK,CLSSES,COINS,CROWN,
X 2 DALTLC,DOG,DRAGON,EGGS,FISSUR,FLOWER,GATLOC,GRAIL,HIVE,
X 3 HONEY,HORN,JEWELS,KEYS,LYRE,
X 4 MAGZIN,MIRROR,MUSHRM,MXSCOR,NUGGET,OYSTER,PEARL,PHONE,
X 5 PILLOW,POLE,POSTER,PREPAT,PREPDN,PREPFR,PREPIN,PREPOF,
X 6 PREPON,PYRAM,RADIUM,RING,RUG,SAPPHI,SHIELD,SHOES,
X 7 SHUT,SLUGS,SNAKE,SPHERE,STEPS,STICKS,SWORD,TABLET,TRIDNT,
X 8 UNLOCK,VASE,WALL,WALL2,WEAR,WUMPUS,Y2,YANK
X WRITE(16)DTK,ATAB,VTXT,OTXT,IOTXT
X 1 ,TXT
X CLOSE(16)
X
X STOP
X END
END_OF_FILE
if test 29694 -ne `wc -c <'asetup.f'`; then
echo shar: \"'asetup.f'\" unpacked with wrong size!
fi
# end of 'asetup.f'
fi
if test -f 'asubs.f.xab' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'asubs.f.xab'\"
else
echo shar: Extracting \"'asubs.f.xab'\" \(25642 characters\)
sed "s/^X//" >'asubs.f.xab' <<'END_OF_FILE'
X
X INTEGER FUNCTION LIQLOC(LOC)
X IMPLICIT INTEGER(A-Z)
X COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5)
X INTEGER WRD(2)
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X EQUIVALENCE (LOCCON,WRD)
XC CALL TOOCT(LOCCON(LOC))
XC CALL TOOCT(WRD(LOC*2))
X
X LIQLOC=LIQ2((MOD(LOCCON(LOC)/8,2)*(MOD(LOCCON(LOC)/2*2,16)-9)
X 1 +1))
X
X RETURN
X END
X
X
X
XC*** LIVING .TRUE. IF OBJ IS LIVING, BEAR FOR EXAMPLE
X
X
X LOGICAL FUNCTION LIVING(OBJ)
X
XC LIVING(OBJ) = TRUE IF OBJ IS SOME SORT OF CRITTER
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X LIVING=BITSET(OBJCON(OBJ),9)
X
X RETURN
X END
X
X
X
X
XC*** LOCKED .TRUE. IF LOCKABLE OBJ IS LOCKED
X
X LOGICAL FUNCTION LOCKED(OBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON/CONCOM/LOCCON(250),OBJCON(150)
X LOCKED=BITSET(OBJCON(OBJ),4)
X RETURN
X END
X
XC*** LOCKS .TRUE. IF YOU CAN LOCK THIS OBJ
X
X LOGICAL FUNCTION LOCKS(OBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON/CONCOM/LOCCON(250),OBJCON(150)
X LOCKS=BITSET(OBJCON(OBJ),3)
X RETURN
X END
X
X
X
X
X
X
XC*** LOOKIN
X
X SUBROUTINE LOOKIN(CONTNR)
X
XC LIST CONTENTS IF OBJ IS A CONTAINER AND IS OPEN OR TRANSPARENT.
XC SAVE INITIAL VALUE OF BLKLIN THRU SUBROUTINE.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /BLKCOM/ BLKLIN
X COMMON /HLDCOM/ HOLDER(150),HLINK(150)
X LOGICAL VESSEL,AJAR,OPAQUE,BLKLIN,BSAVE
X DIMENSION TK(20)
X
X IF(.NOT.VESSEL(CONTNR).OR.
X 1 (.NOT.AJAR(CONTNR).AND.OPAQUE(CONTNR)) )RETURN
X TEMP=HOLDER(CONTNR)
X LOOP=0
X BSAVE=BLKLIN
X20 IF(TEMP.EQ.0)RETURN
X BLKLIN=.FALSE.
X IF(LOOP.EQ.0)CALL RSPEAK(360)
X CALL TNOUA
X CALL PSPEAK(TEMP,-1)
X BLKLIN=BSAVE
X TEMP=HLINK(TEMP)
X LOOP=-1
X GOTO 20
X
X END
X
X
X
X SUBROUTINE MOVE(OBJECT,WHERE)
X
XC PLACE ANY OBJECT ANYWHERE BY PICKING IT UP AND DROPPING IT. MAY ALREADY BE
XC TOTING, IN WHICH CASE THE CARRY IS A NO-OP. MUSTN'T PICK UP OBJECTS WHICH
XC ARE NOT AT ANY LOC, SINCE CARRY WANTS TO REMOVE OBJECTS FROM ATLOC CHAINS.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X LOGICAL ENCLSD
X
X IF(OBJECT.GT.MAXOBJ)THEN
X FROM=FIXED(OBJECT-MAXOBJ)
X ELSE
X IF(ENCLSD(OBJECT))CALL REMOVE(OBJECT)
X FROM=PLACE(OBJECT)
X ENDIF
X IF(FROM.GT.0.AND.FROM.LE.MAXOBJ*2)CALL CARRY(OBJECT,FROM)
X CALL DROP(OBJECT,WHERE)
X RETURN
X END
X
X
X
X
X
X
XC*** NOWAY
X
X
X INTEGER FUNCTION NOWAY(DUMMY)
X
XC GENERATE'S SOME VARIANT OF "CAN'T DO THAT" MESSAGE.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL PCT
X
X NOWAY=14
X IF(PCT(50))NOWAY=110
X IF(PCT(33))NOWAY=147
X IF(PCT(25))NOWAY=250
X IF(PCT(20))NOWAY=262
X IF(PCT(17))NOWAY=25
X IF(PCT(14))NOWAY=345
X IF(PCT(12))NOWAY=346
X RETURN
X END
X
X
X
X
X
X
XC*** OPAQUE .TRUE. IF OBJ IS NON-TRANSPARENT CONTAINER
X
X
X LOGICAL FUNCTION OPAQUE(OBJ)
X
XC OPAQUE(OBJ) = TRUE IF OBJECT IS NOT TRANSPARENT. E.G., BAG & CHEST ARE OPAQ
XC WICKER CAGE & GLASS BOTTLE ARE TRANSPARENT.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X OPAQUE=BITSET(OBJCON(OBJ),6)
X
X RETURN
X END
X
XC*** OUTSID .TRUE. IF LOCATION IS OUTSIDE THE CAVE
X
X
X LOGICAL FUNCTION OUTSID(LOC)
X
XC OUTSID(LOC) = TRUE IF LOCATION IS OUTSIDE THE CAVE
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X OUTSID=BITSET(LOCCON(LOC),6)
X
X RETURN
X END
X
X
X
X
XC*** PCT
X
X
X LOGICAL FUNCTION PCT(N)
X
XC PCT(N) = TRUE N% OF THE TIME (N INTEGER FROM 0 TO 100)
X
X IMPLICIT INTEGER(A-Z)
X PCT=RANZ(100).LT.N
X RETURN
X END
X
X
X
X
X
X
XC*** PLURAL .TRUE. IF OBJ IS MULTIPLE OBJS
X
X
X LOGICAL FUNCTION PLURAL(OBJ)
X
XC PLURAL(OBJ) = TRUE IF OBJECT IS A "BUNCH" OF THINGS (COINS, SHOES).
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X PLURAL=BITSET(OBJCON(OBJ),13)
X
X RETURN
X END
X
X
X
X
X
X
XC*** PORTAL .TRUE. IF LOCATION IS IN CAVE ENTRANCE
X
X
X LOGICAL FUNCTION PORTAL(LOC)
X
XC PORTAL(LOC) = TRUE IS LOCATION IS IN CAVE "ENTRANCE"
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X PORTAL=BITSET(LOCCON(LOC),5)
X
X RETURN
X END
X
X
X
X
XC*** PRINTD .TRUE. IF OBJ CAN BE READ
X
X
X LOGICAL FUNCTION PRINTD(OBJ)
X
XC PRINTD(OBJ) = TRUE IF OBJECT CAN BE READ.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X PRINTD=BITSET(OBJCON(OBJ),8)
X
X RETURN
X END
X
X
X
X
XC*** PSPEAK
X
X
X
X SUBROUTINE PSPEAK(MSG,SKIP)
X
XC FIND THE SKIP+1ST MESSAGE FROM MSG AND PRINT IT. MSG SHOULD BE THE INDEX OF
XC THE INVENTORY MESSAGE FOR OBJECT. (INVEN+N+1 MESSAGE IS PROP=N MESSAGE).
X
X IMPLICIT INTEGER(A-Z)
X COMMON /TXTCOM/ LINES(25000),RTEXT(450),PTEXT(150)
X
X M=PTEXT(MSG)
X IF(SKIP.LT.0)GOTO 9
X DO 3 I=0,SKIP
X1 M=IABS(LINES(M))
X IF(LINES(M).GE.0)GOTO 1
X3 CONTINUE
X9 CALL SPEAK(M)
X RETURN
X END
X
X
X
X
X
X
X
XC*** PUT
X
X
X
X INTEGER FUNCTION PUT(OBJECT,WHERE,PVAL)
X
XC PUT IS THE SAME AS MOVE, EXCEPT IT RETURNS A VALUE USED TO SET UP THE
XC NEGATED PROP VALUES FOR THE REPOSITORY OBJECTS.
X
X IMPLICIT INTEGER(A-Z)
X
X CALL MOVE(OBJECT,WHERE)
X PUT=(-1)-PVAL
X RETURN
X END
X
X
X
X
XC*** RANZ
XC UTILITY ROUTINES (SHIFT, RAN, DATIME, CIAO, BUG, LOG)
X
X INTEGER FUNCTION RANZ(RANGE)
X IMPLICIT INTEGER (A-Z)
X SAVE
X DATA SEED/12345/
X SEED = SEED*69069+1
X I = 16384/RANGE
X J = IABS(SEED)/I
X RANZ = MOD(J,RANGE)
X RETURN
X END
X
X
X
XC*** RATING
X
X SUBROUTINE RATING(SCORE,BONUS,GAVEUP,SCORNG,CLOSNG,CLOSED
X 1 ,HNTMAX)
X
XC CALCULATE WHAT THE PLAYER'S SCORE WOULD BE IF HE QUIT NOW.
XC THIS MAY BE THE END OF THE GAME, OR HE MAY JUST BE WONDERING
XC HOW HE IS DOING.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL TREASR,GAVEUP,CLOSNG,CLOSED,SCORNG,HINTED,KILLED
X COMMON /MNECOM/ BACK,CAVE,DPRSSN,ENTRNC,EXIT,GO,LOOK,NULL,
X 1 AXE,BEAR,BOAT,BOOK,BOOK2,BOOTH,CARVNG,CHASM,CHASM2,DOOR,GNOME,
X 2 GRATE,LAMP,PDOOR,PLANT,PLANT2,ROCKS,ROD,ROD2,SAFE,
X 3 TDOOR,TDOOR2,TROLL,TROLL2,EMRALD,SPICES,
X 4 FIND,YELL,INVENT,LEAVE,POUR,SAY,TAKE,THROW,
X 5 IWEST,PHUCE(2,4),TK(20)
X COMMON /DIECOM/ NUMDIE,MAXDIE,TURNS,KILLED
X COMMON /DWFCOM/ DWARF,KNIFE,KNFLOC,DFLAG,DSEEN(6),DLOC(6),
X 1 ODLOC(6),DWFMAX
X COMMON /HNTCOM/ HINTLC(20),HINTED(20),HINTS(20,4),HNTSIZ,HNTMIN
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X COMMON /SV2COM/ANVIL,BATTER,BEES,BILLBD,BIRD,BRUSH,CAGE,
X 1 CAKES,CHAIN,CHEST,CHLOC,CHLOC2,CLAM,CLOAK,CLSSES,COINS,CROWN,
X 2 DALTLC,DOG,DRAGON,EGGS,FISSUR,FLOWER,GATLOC,GRAIL,HIVE,
X 3 HONEY,HORN,JEWELS,KEYS,LYRE,
X 4 MAGZIN,MIRROR,MUSHRM,MXSCOR,NUGGET,OYSTER,PEARL,PHONE,
X 5 PILLOW,POLE,POSTER,PREPAT,PREPDN,PREPFR,PREPIN,PREPOF,
X 6 PREPON,PYRAM,RADIUM,RING,RUG,SAPPHI,SHIELD,SHOES,
X 7 SHUT,SLUGS,SNAKE,SPHERE,STEPS,STICKS,SWORD,TABLET,TRIDNT,
X 8 UNLOCK,VASE,WALL,WALL2,WEAR,WUMPUS,Y2,YANK
X
X DIMENSION QK(20)
X
XC THE PRESENT SCORING ALGORITHM IS AS FOLLOWS:
XC (TREASURE POINTS ARE EXPLAINED IN A FOLLOWING COMMENT)
XC OBJECTIVE: POINTS: PRESENT TOTAL POSSIBLE:
XC GETTING WELL INTO CAVE 25 25
XC TOTAL POSSIBLE FOR TREASURES (+MAG) 426
XC SURVIVING (MAX-NUM)*10 30
XC NOT QUITTING 4 4
XC REACHING "CLOSNG" 20 20
XC "CLOSED": QUIT/KILLED 10
XC KLUTZED 20
XC WRONG WAY 25
XC SUCCESS 30 30
XC ROUND OUT THE TOTAL 16 16
XC TOTAL: 551
XC (POINTS CAN ALSO BE DEDUCTED FOR USING HINTS.)
X
X SCORE=0
X MXSCOR=0
X
XC FIRST TALLY UP THE TREASURES. MUST BE IN BUILDING AND NOT BROKEN.
XC GIVE THE POOR GUY PARTIAL SCORE JUST FOR FINDING EACH TREASURE.
XC GETS FULL SCORE, QK(3), FOR OBJ IF:
XC OBJ IS AT LOC QK(1), AND
XC OBJ HAS PROP VALUE OF QK(2)
XC
XC WEIGHT TOTAL POSSIBLE
XC MAGAZINE 1 (ABSOLUTE) 1
XC
XC ALL THE FOLLOWING ARE MULTIPLIED BY 5 (RANGE 5-25):
XC BOOK 2
XC CASK 3 (WITH WINE ONLY)
XC CHAIN 4 (MUST ENTER VIA STYX)
XC CHEST 5
XC CLOAK 3
XC CLOVER 1
XC COINS 5
XC CROWN 2
XC CRYSTAL-BALL 2
XC DIAMONDS 2
XC EGGS 3
XC EMERALD 3
XC GRAIL 2
XC HORN 2
XC JEWELS 1
XC LYRE 1
XC NUGGET 2
XC PEARL 4
XC PYRAMID 4
XC RADIUM 4
XC RING 4
XC RUG 3
XC SAPPHIRE 1
XC SHOES 3
XC SPICES 1
XC SWORD 4
XC TRIDENT 2
XC VASE 2
XC DROPLET 5
XC TREE 5
XC TOTAL: 85 * 5 = 425 + 1 ==> 426
X
X DO 1010 OBJ=1,MAXOBJ
X IF(POINTS(OBJ).EQ.0)GOTO 1010
X QK(3)=IABS(POINTS(OBJ))/1000000
X QK(2)=(IABS(POINTS(OBJ))-QK(3)*1000000)/1000
X QK(1)=IABS(POINTS(OBJ))-QK(3)*1000000-QK(2)*1000
X IF(POINTS(OBJ).LT.0) QK(1)=-QK(1)
X K=0
X IF(.NOT.TREASR(OBJ))GOTO 1007
X K=QK(3)*2
X IF(PROP(OBJ).GE.0)SCORE=SCORE+K
X QK(3)=QK(3)*5
X1007 IF(PLACE(OBJ).EQ.QK(1).AND.PROP(OBJ).EQ.QK(2).AND.
X 1 (PLACE(OBJ).NE.-CHEST.OR.PLACE(CHEST).EQ.3).AND.
X 2 (PLACE(OBJ).NE.-SHIELD.OR.PLACE(SHIELD).EQ.-SAFE))
X 3 SCORE=SCORE+QK(3)-K
X MXSCOR=MXSCOR+QK(3)
X1010 CONTINUE
XC NOW LOOK AT HOW HE FINISHED AND HOW FAR HE GOT. MAXDIE AND NUMDIE TELL US
XC HOW WELL HE SURVIVED. GAVEUP SAYS WHETHER HE EXITED VIA QUIT. DFLAG WILL
XC TELL US IF HE EVER GOT SUITABLY DEEP INTO THE CAVE. CLOSNG STILL INDICATES
XC WHETHER HE REACHED THE ENDGAME. AND IF HE GOT AS FAR AS "CAVE CLOSED"
XC (INDICATED BY "CLOSED"), THEN BONUS IS ZERO FOR MUNDANE EXITS OR 133, 134,
XC 135 IF HE BLEW IT (SO TO SPEAK).
X
X ASCORE=(MAXDIE-NUMDIE)*10
X MXSCOR=MXSCOR+MAXDIE*10
X IF(.NOT.(SCORNG.OR.GAVEUP))ASCORE=ASCORE+4
X MXSCOR=MXSCOR+4
X IF(DFLAG.NE.0)ASCORE=ASCORE+25
X MXSCOR=MXSCOR+25
X IF(CLOSNG)ASCORE=ASCORE+20
X MXSCOR=MXSCOR+20
X IF(.NOT.CLOSED)GOTO 1020
X IF(BONUS.EQ.0)ASCORE=ASCORE+10
X IF(BONUS.EQ.135)ASCORE=ASCORE+20
X IF(BONUS.EQ.134)ASCORE=ASCORE+25
X IF(BONUS.EQ.133)ASCORE=ASCORE+30
X1020 MXSCOR=MXSCOR+30
XC ROUND IT OFF.
X
X ASCORE=ASCORE+16
X MXSCOR=MXSCOR+16
X
XC DEDUCT POINTS FOR HINTS. HINTS < HNTMIN ARE SPECIAL; SEE DATABASE DESCRIPTIO
X
X DO 1030 I=1,HNTMAX
X1030 IF(HINTED(I))SCORE=SCORE-HINTS(I,2)
X JTURNS=TURNS/100
X IF(JTURNS.EQ.0)ASCORE=0
X IF(JTURNS.EQ.1)ASCORE=ASCORE/3
X IF(JTURNS.EQ.2)ASCORE=(ASCORE*2)/3
X SCORE=SCORE+ASCORE
X IF(SCORE.LT.0) SCORE=0
X RETURN
X END
X
X
X
X
XC*** REMOVE
X
X
X SUBROUTINE REMOVE(OBJECT)
X
X IMPLICIT INTEGER(A-Z)
X COMMON /HLDCOM/ HOLDER(150),HLINK(150)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X
X CONTNR=-PLACE(OBJECT)
X PLACE(OBJECT)=-1
X
X IF(HOLDER(CONTNR).NE.OBJECT)GOTO 1
X HOLDER(CONTNR)=HLINK(OBJECT)
X RETURN
X
X1 TEMP=HOLDER(CONTNR)
X2 IF(HLINK(TEMP).EQ.OBJECT)GOTO 3
X TEMP=HLINK(TEMP)
X GOTO 2
X
X3 HLINK(TEMP)=HLINK(OBJECT)
X RETURN
X END
X
X
X
X
X
XC*** RSPEAK
X
X SUBROUTINE RSPEAK(I)
X
XC PRINT THE I-TH "RANDOM" MESSAGE (SECTION 6 OF DATABASE).
X
X IMPLICIT INTEGER(A-Z)
X COMMON /TXTCOM/ LINES(25000),RTEXT(450),PTEXT(150)
X
X IF(I.LE.0)RETURN
X M=RTEXT(I)
X CALL SPEAK(M)
X RETURN
X END
X
X
X
X
X
XC*** SMALL .TRUE. IF IT FITS IN SACK OR SMALL CONTAINER
X
X LOGICAL FUNCTION SMALL(OBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON/CONCOM/LOCCON(250),OBJCON(150)
X SMALL=BITSET(OBJCON(OBJ),5)
X RETURN
X END
X
X
X
XC*** SPEAK
X
X SUBROUTINE SPEAK(N)
X
XC PRINT THE MESSAGE WHICH STARTS AT LINES(N). PRECEDE IT WITH A BLANK LINE
XC UNLESS BLKLIN IS FALSE.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BLKLIN
X COMMON /TNOUX/INDENT
X COMMON /TXTCOM/ LINES(25000),RTEXT(450),PTEXT(150)
X COMMON /BLKCOM/ BLKLIN
X DIMENSION OLINE(30)
XC DATA ZCLYD/'CLYD'/,ZLS/'<$$<'/
XC ZCLYD = 0
XC ZCLYD = 37+256*(9+256*(20+256*15))
X ZCLYD = ICHAR('c')+256*(ICHAR('L')+ 256*(ICHAR('y')
X 1 +256*ICHAR('D')))
X ZLS = 60+256*(36+256*(36+256*60))
X XCLYD=IEOR(ZCLYD,ZLS)
X100 IF(N.EQ.0)GOTO 145
X IF(LINES(N+1).EQ.XCLYD)GOTO 4
X K=N
X1 CONTINUE
X L=IABS(LINES(K))-K-1
X DO 2 I=1,L
X2 OLINE(I)=IEOR(LINES(K+I),ZCLYD)
X IF(INDENT.EQ.0)WRITE(*,3) (OLINE(I),I=1,L)
X IF(INDENT.EQ.1)WRITE(*,133)(OLINE(I),I=1,L)
X133 FORMAT(6X,19A4)
X3 FORMAT(' ',19A4)
X K=K+L+1
X IF(LINES(K).GE.0)GOTO 1
X4 CONTINUE
X145 INDENT=0
X RETURN
X END
X
X
XC A HORRIBLE KLUDGE
X SUBROUTINE TNOUA
X INTEGER INDENT
X COMMON /TNOUX/INDENT
X INDENT=1
X RETURN
X END
X
X
X
XC*** TOTING .TRUE. IF OBJ SOMEWHERE ON PERSON
X
X
X LOGICAL FUNCTION TOTING(OBJ)
X
XC TOTING(OBJ) = TRUE IF THE OBJ IS BEING CARRIED (IN HAND OR
XC CONTAINER). OBJ MAY NOT BE REACHABLE. SEE
XC ALSO: ENCLSD, ATHAND, HOLDNG.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X LOGICAL HOLDNG,ENCLSD,AAA,BBB,CCC
X
X
X
X TOTING = .FALSE.
X IF(HOLDNG(OBJ))THEN
X TOTING = .TRUE.
X RETURN
X ENDIF
X CONTNR=-PLACE(OBJ)
X IF(CONTNR.LE.0)RETURN
X IF(HOLDNG(CONTNR))THEN
X TOTING = .TRUE.
X RETURN
X ENDIF
X OUTER=-PLACE(CONTNR)
X IF(OUTER.LE.0)RETURN
X IF(HOLDNG(OUTER))THEN
X TOTING = .TRUE.
X RETURN
X ENDIF
X OUTER2=-PLACE(OUTER)
X IF(OUTER2.LE.0)RETURN
X IF(HOLDNG(OUTER2))THEN
X TOTING = .TRUE.
X RETURN
X ENDIF
X RETURN
X
X END
X
X
X
X
X
XC*** TRAVL
XC FIGURE OUT THE NEW LOCATION
XC
XC GIVEN THE CURRENT LOCATION IN "LOC", AND A MOTION VERB NUMBER IN "K", PUT
XC THE NEW LOCATION IN "NEWLOC". THE CURRENT LOC IS SAVED IN "OLDLOC" IN CASE
XC HE WANTS TO RETREAT. THE CURRENT OLDLOC IS SAVED IN OLDLC2, IN CASE HE
XC DIES. (IF HE DOES, NEWLOC WILL BE LIMBO, AND OLDLOC WILL BE WHAT KILLED
XC HIM, SO WE NEED OLDLC2, WHICH IS THE LAST PLACE HE WAS SAFE.)
X
X SUBROUTINE TRAVL(K,BCROSS,TALLY2)
X IMPLICIT INTEGER(A-Z)
X
X LOGICAL KILLED,PCT,HOLDNG,ENCLSD
X LOGICAL INSIDE,OUTSID,PORTAL,TOTING,HERE,AT,FORCED
X
X COMMON /DIECOM/ NUMDIE,MAXDIE,TURNS,KILLED
X COMMON /TRVCOM/ TRAVEL(1600)
X COMMON /LTXCOM/ LTEXT(250),STEXT(250),KEY(250),ABB(250),LOCSIZ
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X COMMON /MNECOM/ BACK,CAVE,DPRSSN,ENTRNC,EXIT,GO,LOOK,NULL,
X 1 AXE,BEAR,BOAT,BOOK,BOOK2,BOOTH,CARVNG,CHASM,CHASM2,DOOR,GNOME,
X 2 GRATE,LAMP,PDOOR,PLANT,PLANT2,ROCKS,ROD,ROD2,SAFE,
X 3 TDOOR,TDOOR2,TROLL,TROLL2,EMRALD,SPICES,
X 4 FIND,YELL,INVENT,LEAVE,POUR,SAY,TAKE,THROW,
X 5 IWEST,PHUCE(2,4),TK(20)
X
X KILLED=.FALSE.
X KK=KEY(LOC)
X NEWLOC=LOC
X IF(KK.EQ.0)CALL BUG(26)
X IF(K.EQ.NULL)RETURN
X IF(K.EQ.BACK)GOTO 20
X IF(K.EQ.CAVE)GOTO 40
X OLDLC2=OLDLOC
X OLDLOC=LOC
X
X9 LL=IABS(TRAVEL(KK))
X IF(MOD(LL,0001000).EQ.1.OR.MOD(LL,0001000).EQ.K)
X 1 GOTO 10
X IF(TRAVEL(KK).LT.0000000)GOTO 50
X KK=KK+1
X GOTO 9
X
X10 LL=LL/0001000
X11 NEWLOC=LL/0001000
X K=MOD(NEWLOC,100)
X IF(NEWLOC.LE.MAXLOC)GOTO 13
X IF(PROP(K).NE.NEWLOC/100-3)GOTO 16
X12 IF(TRAVEL(KK).LT.0)CALL BUG(25)
X KK=KK+1
X NEW1=IABS(TRAVEL(KK))/1000
X IF(NEW1.EQ.LL)GOTO 12
X LL=NEW1
X GOTO 11
X
X13 IF(NEWLOC.LE.100)GOTO 14
X IF(TOTING(K).OR.(NEWLOC.GT.200.AND.AT(K)))GOTO 16
X GOTO 12
X
X14 IF(NEWLOC.NE.0.AND..NOT.PCT(NEWLOC))GOTO 12
X16 NEWLOC=MOD(LL,1000)
X IF(NEWLOC.LE.MAXLOC)GO TO 2000
X IF(NEWLOC.LE.500)GOTO 30000
X CALL RSPEAK(NEWLOC-500)
X NEWLOC=LOC
X RETURN
XC HANDLE "GO BACK". LOOK FOR VERB WHICH GOES FROM LOC TO OLDLOC, OR TO OLDLC2
XC IF OLDLOC HAS FORCED-MOTION. K2 SAVES ENTRY -> FORCED LOC -> PREVIOUS LOC.
X
X20 K=OLDLOC
X IF(FORCED(K))K=OLDLC2
X OLDLC2=OLDLOC
X OLDLOC=LOC
X K2=0
X IF(K.NE.LOC)GOTO 21
X CALL RSPEAK(91)
X GO TO 2000
X
X21 LL=MOD((IABS(TRAVEL(KK))/1000),1000)
X IF(LL.EQ.K)GOTO 25
X IF(LL.GT.MAXLOC)GOTO 22
X J=KEY(LL)
X IF(FORCED(LL).AND.MOD((IABS(TRAVEL(J))/1000),1000).EQ.K)
X 1 K2=KK
X22 IF(TRAVEL(KK).LT.000000)GOTO 23
X KK=KK+1
X GOTO 21
X
X23 KK=K2
X IF(KK.NE.0)GOTO 25
X CALL RSPEAK(140)
X2000 IF(NEWLOC.LT.242.OR.NEWLOC.GT.247)RETURN
X IF(NEWLOC.NE.242)GOTO 2010
X KALFLG=0
X RETURN
X2010 IF(NEWLOC.NE.OLDLOC+1)GOTO 2020
X KALFLG=KALFLG+1
X RETURN
X2020 KALFLG=-10
X RETURN
X
X25 K=MOD(IABS(TRAVEL(KK)),1000)
X KK=KEY(LOC)
X GOTO 9
X
XC CAVE. DIFFERENT MESSAGES DEPENDING ON WHETHER ABOVE GROUND.
X
X40 IF(OUTSID(LOC))CALL RSPEAK(57)
X IF(.NOT.OUTSID(LOC))CALL RSPEAK(58)
X RETURN
X
XC NON-APPLICABLE MOTION. VARIOUS MESSAGES DEPENDING ON WORD GIVEN.
X
X50 SPK=12
X IF(K.GE.43.AND.K.LE.50)SPK=9
X IF(K.EQ.29.OR.K.EQ.30)SPK=9
X IF(K.EQ.7.OR.K.EQ.36.OR.K.EQ.37)SPK=10
X IF(K.EQ.11.OR.K.EQ.19)SPK=11
X IF(K.EQ.62.OR.K.EQ.65.OR.K.EQ.82)SPK=42
X IF(K.EQ.17)SPK=80
X CALL RSPEAK(SPK)
X RETURN
XC SPECIAL MOTIONS COME HERE. LABELLING CONVENTION: STATEMENT NUMBERS NNNXX
XC (XX=00-99) ARE USED FOR SPECIAL CASE NUMBER NNN (NNN=301-500).
X
X30000 NEWLOC=NEWLOC-MAXLOC
X GOTO (30100,30200,30300,30400,30500,30600,30700),NEWLOC
XC ALCOV PLOVR TROLL PHUCE BOOTH BRDGE
X WRITE(*,1001)NEWLOC
X1001 FORMAT('BUG IN TRAVEL TABLES. NEWLOC= ',I5)
X CALL BUG(20)
X
XC TRAVEL 301. PLOVER-ALCOVE PASSAGE. CAN CARRY ONLY EMERALD. NOTE: TRAVEL
XC TABLE MUST INCLUDE "USELESS" ENTRIES GOING THROUGH PASSAGE, WHICH CAN NEVER
XC BE USED FOR ACTUAL MOTION, BUT CAN BE SPOTTED BY "GO BACK".
X
X30100 NEWLOC=99+100-LOC
X KK=BURDEN(0)
X IF(KK.EQ.0.OR.(KK.EQ.BURDEN(EMRALD).AND.HOLDNG(EMRALD)))RETURN
X NEWLOC=LOC
X CALL RSPEAK(117)
X RETURN
X
XC TRAVEL 302. PLOVER TRANSPORT. DROP THE EMERALD (ONLY USE SPECIAL TRAVEL IF
XC TOTING IT), SO HE'S FORCED TO USE THE PLOVER-PASSAGE TO GET IT OUT. HAVING
XC DROPPED IT, GO BACK AND PRETEND HE WASN'T CARRYING IT AFTER ALL.
X
X30200 IF(ENCLSD(EMRALD))CALL REMOVE(EMRALD)
X CALL DROP(EMRALD,LOC)
X GOTO 12
X
XC TRAVEL 303. TROLL BRIDGE. MUST BE DONE ONLY AS SPECIAL MOTION SO THAT
XC DWARVES WON'T WANDER ACROSS AND ENCOUNTER THE BEAR. (THEY WON'T FOLLOW THE
XC PLAYER THERE BECAUSE THAT REGION IS FORBIDDEN TO THE PIRATE.) IF
XC PROP(TROLL)=1, HE'S CROSSED SINCE PAYING, SO STEP OUT AND BLOCK HIM.
XC (STANDARD TRAVEL ENTRIES CHECK FOR PROP(TROLL)=0.) SPECIAL STUFF FOR BEAR.
X
X30300 IF(PROP(TROLL).NE.1)GOTO 30310
X CALL PSPEAK(TROLL,1)
X PROP(TROLL)=0
X CALL MOVE(TROLL2,0)
X CALL MOVE(TROLL2+MAXOBJ,0)
X CALL MOVE(TROLL,PLAC(TROLL))
X CALL MOVE(TROLL+MAXOBJ,FIXD(TROLL))
X CALL JUGGLE(CHASM)
X NEWLOC=LOC
X RETURN
X
X30310 NEWLOC=PLAC(TROLL)+FIXD(TROLL)-LOC
X IF(PROP(TROLL).EQ.0)PROP(TROLL)=1
X IF(.NOT.HOLDNG(BEAR))RETURN
X CALL RSPEAK(162)
X PROP(CHASM)=1
X PROP(TROLL)=2
X CALL DROP(BEAR,NEWLOC)
X FIXED(BEAR)=-1
X PROP(BEAR)=3
X IF(PROP(SPICES).LT.0)TALLY2=TALLY2+1
X OLDLC2=NEWLOC
X KILLED=.TRUE.
X RETURN
XC TRAVEL 304. GROWING OR SHRINKING IN AREA OF TINY DOOR. EACH TIME
XC HE DOES THIS, EVERYTHING MUST BE MOVED TO THE NEW LOC. PRESUMABLY,
XC ALL HIS POSSESIONS ARE SHRUNK OR STRECHED ALONG WITH HIM.
XC PHUCE(2,4) IS AN ARRAY CONTAINING FOUR PAIRS OF "HERE" (K) AND
XC "THERE" (KK) LOCATIONS.
X
X30400 K=PHUCE(1,LOC-161+1)
X NEWLOC=PHUCE(2,LOC-161+1)
X DO 30410 OBJ=1,MAXOBJ
X IF(OBJ.EQ.BOAT)GOTO 30410
X IF(PLACE(OBJ).EQ.K.AND.(FIXED(OBJ).EQ.0.OR.FIXED(OBJ).EQ.-1))
X 1 CALL MOVE(OBJ,NEWLOC)
X30410 CONTINUE
X RETURN
X
XC TRAVEL #5. PHONE BOOTH IN ROTUNDA.
XC TRYING TO SHOVE PAST GNOME, TO GET INTO PHONE BOOTH.
X
X30500 IF((PROP(BOOTH).EQ.0.AND.PCT(55)).OR.ABB(LOC).EQ.1)GOTO 30510
X NEWLOC=189
X IF(PROP(BOOTH).NE.1)RETURN
X CALL RSPEAK(253)
X GOTO 30512
X
X30510 CALL RSPEAK(263)
X PROP(BOOTH)=1
X CALL MOVE(GNOME,188)
X30512 NEWLOC=LOC
X RETURN
X
XC TRAVEL #6. COLLAPSING CLAY BRIDGE. HE CAN CROSS WITH THREE (OR FEWER)
XC THINGS. IF MORE, OR IF CARRYING OBVIOUSLY HEAVY THINGS, HE MAY END UP
XC IN THE DRINK.
X
X30600 NEWLOC=235
X IF(LOC.EQ.235)NEWLOC=190
X BCROSS=BCROSS+1
X KK=BURDEN(0)
X IF(KK.LE.4)RETURN
X K=MAX0( ((KK+BCROSS)**2)/10, 10)
X30605 IF(PCT(K))GOTO 30610
X CALL RSPEAK(318)
X RETURN
X
X30610 CALL RSPEAK(319)
X NEWLOC=236
X IF(HOLDNG(LAMP))CALL MOVE(LAMP,236)
X IF(TOTING(AXE).AND.ENCLSD(AXE))CALL REMOVE(AXE)
X IF(HOLDNG(AXE))CALL MOVE(AXE,208)
X DO 30620 OBJ=1,MAXOBJ
X30620 IF(TOTING(OBJ))CALL DSTROY(OBJ)
X PROP(CHASM2)=1
X RETURN
XC THE KALEIDOSCOPE CODE IS HERE
X30700 IF(KALFLG.NE.5)GOTO 30701
X NEWLOC=248
X OLDLOC=247
X RETURN
X30701 NEWLOC=242+RANZ(5)
X OLDLOC=NEWLOC-1
X CALL RSPEAK(406)
X KALFLG=-10
X IF(NEWLOC.EQ.242)KALFLG=0
X RETURN
X
XC END OF SPECIALS.
X
X END
X
X
XC*** TREASR .TRUE. IF OBJ IS VALUABLE FOR POINTS
X
X
X LOGICAL FUNCTION TREASR(OBJ)
X
XC TREASR(OBJ) = TRUE IF OBJECT IS A TREASURE
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X TREASR=BITSET(OBJCON(OBJ),14)
X
X RETURN
X END
X
X
X
X
X
X
X
XC*** VAL
X
X
X INTEGER FUNCTION VAL(WORD)
X
XC RETURNS THE 'VALUE' OF A WORD, MODULO 1000.
X
X IMPLICIT INTEGER(A-Z)
X VAL=MOD(WORD,1000)
X RETURN
X END
X
X
X
X
XC*** VESSEL .TRUE. IF OBJ CAN HOLD A LIQUID
X
X
X LOGICAL FUNCTION VESSEL(OBJ)
X
XC VESSEL(OBJ) = TRUE IF OBJECT IS A CONTAINER
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X VESSEL=BITSET(OBJCON(OBJ),15)
X
X RETURN
X END
X
X
X
X
X
XC*** VOCABX
X
X
X INTEGER FUNCTION VOCABX(ID,INIT)
X
XC LOOK UP ID IN THE VOCABULARY (ATAB) AND RETURN ITS "DEFINITION" (KTAB
XC -1 IF NOT FOUND. IF INIT IS POSITIVE, THIS IS AN INITIALISATION CALL
XC UP A KEYWORD VARIABLE, AND NOT FINDING IT CONSTITUTES A BUG. IT ALSO
XC THAT ONLY KTAB VALUES WHICH TAKEN OVER 1000 EQUAL INIT MAY BE CONSIDE
XC (THUS "STEPS", WHICH IS A MOTION VERB AS WELL AS AN OBJECT, MAY BE LO
XC AS AN OBJECT.) AND IT ALSO MEANS THE KTAB VALUE IS TAKEN MOD 1000.
X
X IMPLICIT INTEGER(A-Z)
X CHARACTER*6 ATAB,DTK,ID,VTXT,OTXT,IOTXT,TXT
X COMMON /VOCCOM/ KTAB(600),TABSIZ
X COMMON /SV3COM/DTK(9),ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2)
X 1 ,TXT(35,2)
X
XC HASH=ID.XOR.'PHROG' (DONE BY CALLER)
X WDCLAS=INIT
X IF(INIT.LT.0)WDCLAS=-INIT-1
X DO 1 I=1,TABSIZ
X IF(KTAB(I).EQ.-1)GOTO 2
X IF(ATAB(I).NE.ID)GOTO 1
X IF(CLASS(KTAB(I)).GE.WDCLAS)GOTO 3
X1 CONTINUE
X CALL BUG(21)
X
X2 VOCABX=-1
X IF(INIT.LT.0)RETURN
X WRITE(*,4)ID
X4 FORMAT (' VOCAB ERROR: CAN''T FIND WORD ''',A5,''' IN TABLE.')
X CALL BUG(5)
X
X3 VOCABX=KTAB(I)
X IF(INIT.GE.0)VOCABX=MOD(VOCABX,1000)
X RETURN
X END
X
X
X
XC*** WEARNG .TRUE. IF WEARING OBJ
X
X
X LOGICAL FUNCTION WEARNG(OBJ)
X
XC WEARNG(OBJ) = TRUE IF THE OBJ IS BEING WORN
X
X IMPLICIT INTEGER(A-Z)
X COMMON /BITCOM/ OPENBT,UNLKBT,BURNBT,WEARBT
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X LOGICAL BITSET
X
X WEARNG=BITSET(OBJCON(OBJ),WEARBT)
X RETURN
X END
X
X
X
X
X
XC*** WORN .TRUE. IF OBJ IS BEING WORN
X
X LOGICAL FUNCTION WORN(OBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON/CONCOM/LOCCON(250),OBJCON(150)
X WORN=BITSET(OBJCON(OBJ),11)
X RETURN
X END
X
X
X
X
XC*** YES
X
X
X
X LOGICAL FUNCTION YES(X,Y,Z)
X
XC PRINT MESSAGE X, WAIT FOR YES/NO ANSWER.
X
X IMPLICIT INTEGER(A-Z)
X CHARACTER*6 REPLY
X
X1 IF(X.NE.0)CALL RSPEAK(X)
X WRITE(*,338)
X338 FORMAT(/,' >')
XC??????????????? THE FOLLOWING WORKS BETTER ON VAXES, ETC:
XC338 FORMAT(/,' >',$)
X READ(*,30)REPLY
X30 FORMAT(A6)
X DO 2 I=1,6
X IF(REPLY(I:I).GE.'a'.AND.REPLY(I:I).LE.'z')
X 1 REPLY(I:I) = CHAR(ICHAR(REPLY(I:I)) -32)
X2 CONTINUE
X IF(REPLY.EQ.'YES '.OR.REPLY.EQ.'Y ')GOTO 10
X IF(REPLY.EQ.'NO '.OR.REPLY.EQ.'N ')GOTO 20
X
X WRITE(*,*)' Please answer the question.'
X GOTO 1
X10 YES=.TRUE.
X IF(Y.NE.0)CALL RSPEAK(Y)
X RETURN
X20 YES=.FALSE.
X IF(Z.NE.0)CALL RSPEAK(Z)
X RETURN
X END
X
X
X
END_OF_FILE
if test 25642 -ne `wc -c <'asubs.f.xab'`; then
echo shar: \"'asubs.f.xab'\" unpacked with wrong size!
fi
# end of 'asubs.f.xab'
fi
echo shar: End of archive 6 \(of 7\).
cp /dev/null ark6isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 7 archives.
echo "now type 'sh combine.sh'"
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0