billr@saab.CNA.TEK.COM (Bill Randle) (08/23/90)
Submitted-by: Doug McDonald <mcdonald@aries.scs.uiuc.edu>
Posting-number: Volume 11, Issue 31
Archive-name: adven2/Part05
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 5 (of 7)."
# Contents: asubs.f.xaa
# Wrapped by billr@saab on Wed Aug 22 16:47:43 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'asubs.f.xaa' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'asubs.f.xaa'\"
else
echo shar: Extracting \"'asubs.f.xaa'\" \(37415 characters\)
sed "s/^X//" >'asubs.f.xaa' <<'END_OF_FILE'
X
X
X
X
X
XC*** A5TOA1
X
X SUBROUTINE A5TOA1(A,B,C,QQ,LENG)
X
XC A AND B CONTAIN A 1- TO 12-CHARACTER WORD IN A6 FORMAT, C CONTAINS ANOTHER
XC WORD AND/OR PUNCTUATION. THEY ARE UNPACKED TO ONE CHARACTER PER WORD IN THE
XC ARRAY "CHARS".
XC THE INDEX OF THE LAST NON-BLANK CHAR IN CHARS IS RETURNED IN LENG.
X
X IMPLICIT INTEGER(A-Z)
X CHARACTER*6 A,B,C
X CHARACTER QQ(20)
X DO 300 JJ=1,6
X QQ(JJ)=A(JJ:JJ)
X300 QQ(JJ+6)=B(JJ:JJ)
X DO 5 I=1,12
X IF(QQ(I).EQ.' ')GOTO 10
X5 CONTINUE
X LENG=12
X GOTO 15
X10 CONTINUE
X LENG=I-1
X15 DO 20 I=1,6
X IF(C(I:I).NE.' ')THEN
X LENG=LENG+1
X QQ(LENG) = C(I:I)
X ENDIF
X20 CONTINUE
X DO 21 I= LENG+1,20
X21 QQ(I) = ' '
X DO 22 I= 1,20
X22 IF(QQ(I).EQ.'_')QQ(I) = ' '
X
X RETURN
X END
X
X
X
XC*** AJAR .TRUE. IF OBJ IS CONTAINER AND IS OPEN
XC THE NEXT LOGICAL FUNCTIONS DESCRIBE ATTRIBUTES OF OBJECTS.
XC (AJAR, HINGED, OPAQUE, PRINTD, TREASR, VESSEL, WEARNG)
X
X LOGICAL FUNCTION AJAR(OBJ)
X
XC AJAR(OBJ) = TRUE IF OBJECT IS AN OPEN OR UNHINGED CONTAINER.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET,HINGED,VESSEL
X COMMON /BITCOM/ OPENBT,UNLKBT,BURNBT,WEARBT
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X AJAR=BITSET(OBJCON(OBJ),OPENBT).OR.
X 1 (VESSEL(OBJ).AND..NOT.HINGED(OBJ))
X RETURN
X END
X
X
XC*** AT .TRUE. IF AT OBJ
X LOGICAL FUNCTION AT(OBJ)
X
XC AT(OBJ) = TRUE IF ON EITHER SIDE OF TWO-PLACED OBJECT
X
X IMPLICIT INTEGER(A-Z)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X AT = .FALSE.
X IF(OBJ.LT.1.OR.OBJ.GT.MAXOBJ)RETURN
X AT=PLACE(OBJ).EQ.LOC.OR.FIXED(OBJ).EQ.LOC
X RETURN
X END
X
X
X
XC*** ATHAND .TRUE. IF OBJ READILY AVAILABLE
X
X
X LOGICAL FUNCTION ATHAND(OBJ)
X
XC ATHAND(OBJ) = TRUE IF OBJ IS READILY REACHABLE.
XC IT CAN BE LYING HERE, IN HAND OR IN OPEN CONTAINER.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X LOGICAL TOTING,AJAR,ENCLSD,HOLDNG,AAA
X
X ATHAND = .FALSE.
X IF(PLACE(OBJ).EQ.LOC.OR.HOLDNG(OBJ))THEN
X ATHAND = .TRUE.
X RETURN
X ENDIF
X IF(.NOT.ENCLSD(OBJ))RETURN
X CONTNR=-PLACE(OBJ)
X
X
X ATHAND=
X 1 (AJAR(CONTNR).AND.
X 2 (PLACE(CONTNR).EQ.LOC.OR.
X 3 (TOTING(OBJ).AND.HOLDNG(CONTNR))))
X
X RETURN
X END
X
X
X
X
XC*** BITOFF
X
X
X SUBROUTINE BITOFF(OBJ,BIT)
X
XC TURNS OFF (SETS=0) A BIT IN OBJCON.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
XC OBJCON(OBJ)=IAND(OBJCON(OBJ),INOT(BITS(BIT)))
XC THE FOLLOWING SHOULD BE EQUIVALENT TO THE ABOVE
X OBJCON(OBJ)=IOR(OBJCON(OBJ),(BITS(BIT)))-BITS(BIT)
X RETURN
X END
X
X
X
X
XC*** BITON
X
X
X SUBROUTINE BITON(OBJ,BIT)
X
XC TURNS ON (SETS=1) A BIT IN OBJCON.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X OBJCON(OBJ)=IOR(OBJCON(OBJ),BITS(BIT))
X RETURN
X END
X
X
X
X
X
X
XC*** BITS
X INTEGER FUNCTION BITS(SHIFT)
X IMPLICIT INTEGER (A-Z)
X BITS=(2**SHIFT)
X RETURN
X END
X
X
X
X
XC*** BITSET
XC MISCELLANEOUS LOGICAL FUNCTIONS (BITSET, PCT)
XC ALSO, SUBROUTINES FOR TURNING BITS ON AND OFF (BITON, BITOFF).
X
X LOGICAL FUNCTION BITSET(WORD,N)
X
XC BITSET(COND,L,N) = TRUE IF COND(L) HAS BIT N SET
X
X IMPLICIT INTEGER(A-Z)
X BITSET=IAND(WORD,2**N).NE.0
X5 RETURN
X END
X
X
X
X
X
X
XC*** BLIND .TRUE. IF YOU CAN'T SEE AT THIS LOC
XC LOCATION ATTRIBUTES. (BLIND, DARK, FORCED, INSIDE, OUTSID, PORTAL)
X
X
X LOGICAL FUNCTION BLIND(DUMMY)
X
XC TRUE IF ADVENTURER IS "BLIND" AT THIS LOC, (DARKNESS OR GLARE)
X
X IMPLICIT INTEGER(A-Z)
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X LOGICAL DARK,ATHAND
X DATA LAMP /2/
X
X BLIND=DARK(0).OR.(LOC.EQ.200.AND.ATHAND(LAMP).AND.PROP(LAMP)
X 1 .EQ.1)
X
X RETURN
X END
X
X
X
X
X
XC*** BUG
X
X SUBROUTINE BUG(NUM)
X IMPLICIT INTEGER(A-Z)
X
XC THE FOLLOWING CONDITIONS ARE CURRENTLY CONSIDERED FATAL BUGS. NUMBERS < 20
XC ARE DETECTED WHILE READING THE DATABASE; THE OTHERS OCCUR AT "RUN TIME".
XC 0 MESSAGE LINE > 70 CHARACTERS
XC 1 NULL LINE IN MESSAGE
XC 2 TOO MANY WORDS OF MESSAGES
XC 3 TOO MANY TRAVEL OPTIONS
XC 4 TOO MANY VOCABULARY WORDS
XC 5 REQUIRED VOCABULARY WORD NOT FOUND
XC 6 TOO MANY RTEXT OR MTEXT MESSAGES
XC 7 TOO MANY HINTS
XC 8 LOCATION HAS COND BIT BEING SET TWICE
XC 9 INVALID SECTION NUMBER IN DATABASE
XC 10 OUT OF ORDER LOCS OR RSPEAK ENTRIES.
XC 11 ILLEGAL MOTION WORD IN TRAVEL TABLE
XC 12 ** UNUSED **.
XC 13 UNKNOWN OR ILLEGAL WORD IN ADJECTIVE TABLE.
XC 14 ILLEGAL WORD IN PREP/OBJ TABLE
XC 15 TOO MANY ENTRIES IN PREP/OBJ TABLE
XC 16 OBJECT HAS CONDITION BIT SET TWICE
XC 17 OBJECT NUMBER TOO LARGE
XC 18 TOO MANY ENTRIES IN ADJECTIVE/NOUN TABLE.
XC 20 SPECIAL TRAVEL (500>L>300) EXCEEDS GOTO LIST
XC 21 RAN OFF END OF VOCABULARY TABLE
XC 22 VERB CLASS (N/1000) NOT BETWEEN 1 AND 3
XC 23 INTRANSITIVE ACTION VERB EXCEEDS GOTO LIST
XC 24 TRANSITIVE ACTION VERB EXCEEDS GOTO LIST
XC 25 CONDITIONAL TRAVEL ENTRY WITH NO ALTERNATIVE
XC 26 LOCATION HAS NO TRAVEL ENTRIES
XC 27 HINT NUMBER EXCEEDS GOTO LIST
XC 28 INVALID MONTH RETURNED BY DATE FUNCTION
XC 29 ACTION VERB 'LEAVE' HAS NO OBJECT.
XC 30 PREPOSITION FOUND IN UNEXPECTED TABLE
XC 31 RECEIVED AN UNEXPECTED WORD TERMINATOR FROM A1TOA5
XC 32 TRYING TO PUT A CONTAINER INTO ITSELF (TRICKY!)
XC 33 UNKNOWN WORD CLASS IN GETWDS
XC 35 TRYING TO CARRY A NON-EXISTENT OBJECT
X
X WRITE(*,1) NUM
X1 FORMAT (' FATAL ERROR, SEE SOURCE CODE FOR INTERPRETATION.'/
X 1 ' PROBABLE CAUSE: ERRONEOUS INFO IN DATABASE OR BAD ASAVE.DAT'/
X 2 ' ERROR CODE =',I2/)
X STOP
X END
X
X
XC*** BURDEN .. RETURNS WEIGHT OF ITEMS BEING CARRIED
X
X INTEGER FUNCTION BURDEN(OBJ)
X
XC IF OBJ=0, BURDEN CALCULATES THE TOTAL WEIGHT OF THE ADVENTURER'S BURDEN,
XC INCLUDING EVERYTHING IN ALL CONTAINERS (EXCEPT THE BOAT) THAT HE IS
XC CARRYING.
XC IF OBJ#0 AND OBJ IS A CONTAINER, CALCULATE THE WEIGHT OF EVERYTHING INSIDE
XC THE CONTAINER (INCLUDING THE CONTAINER ITSELF). SINCE DONKEY FORTRAN
XC ISN'T RECURSIVE, WE WILL ONLY CALCULATE WEIGHTS OF CONTAINED CONTAINERS
XC ONE LEVEL DOWN. THE ONLY SERIOUS CONTAINED CONTAINER WOULD BE THE SACK
XC THE ONLY THINGS WE'LL MISS WILL BE FILLED VS EMPTY BOTTLE OR CAGE.
XC IF OBJ#0 AND ISN'T A CONTAINER, RETURN ITS WEIGHT.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X COMMON /HLDCOM/ HOLDER(150),HLINK(150)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X LOGICAL TOTING,WEARNG
X DATA BOAT /48/
X
X BURDEN=0
X IF(OBJ.NE.0)GOTO 200
X DO 100 I=1,MAXOBJ
X IF(.NOT.TOTING(I).OR.PLACE(I).EQ.-BOAT)GOTO 100
X BURDEN=BURDEN+WEIGHT(I)
X100 CONTINUE
X RETURN
X
X200 BURDEN=WEIGHT(OBJ)
X IF(OBJ.EQ.BOAT)RETURN
X TEMP=HOLDER(OBJ)
X210 IF(TEMP.EQ.0)RETURN
X BURDEN=BURDEN+WEIGHT(TEMP)
X TEMP=HLINK(TEMP)
X GOTO 210
X
X END
X
X
X
X
X
X
XC*** CARRY
X
X SUBROUTINE CARRY(OBJECT,WHERE)
X
XC START TOTING AN OBJECT, REMOVING IT FROM THE LIST OF THINGS AT ITS FORMER
XC LOCATION. IF OBJECT>MAXOBJ (MOVING "FIXED" SECOND LOC),
XC DON'T CHANGE PLACE.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X
X IF(OBJECT.GT.MAXOBJ)GOTO 5
X IF(PLACE(OBJECT).EQ.-1)RETURN
X PLACE(OBJECT)=-1
X5 IF(ATLOC(WHERE).NE.OBJECT)GOTO 6
X ATLOC(WHERE)=LINK(OBJECT)
X RETURN
X
X6 TEMP=ATLOC(WHERE)
X7 IF(LINK(TEMP).EQ.OBJECT)GOTO 8
X TEMP=LINK(TEMP)
X IF(TEMP.NE.0)GOTO 7
X CALL BUG(35)
X
X8 LINK(TEMP)=LINK(OBJECT)
X RETURN
X END
X
X
XC*** CLASS
X
X
X INTEGER FUNCTION CLASS(WORD)
X
XC RETURNS WORD CLASS NUMBER (1=MOTION VERB; 2=NOUN; 3=ACTION VERB;
XC 4=MISCELLANEOUS WORD; 5=PREPOSITION; 6=ADJECTIVE; 7=CONJUNCTION).
X
X
X IMPLICIT INTEGER(A-Z)
X
X CLASS=WORD/1000 +1
X IF(WORD.LT.0)CLASS=-1
X RETURN
X END
X
X
X
XC*** CLRLIN
X
X SUBROUTINE CLRLIN
X
XC CLEARS OUT ALL CURRENT SYNTAX ARGS IN PREPARATION FOR A NEW INPUT LINE
X
X IMPLICIT INTEGER(A-Z)
X CHARACTER*6 VTXT,OTXT,IOTXT,DTK,ATAB,TXT,ALLZERO
X COMMON /WRDCOM/ VERBS(45),VRBX,OBJS(45),
X 1 OBJX,IOBJS(15),IOBX,PREP,WORDS(45)
X COMMON /SV3COM/DTK(9),ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2)
X 1 ,TXT(35,2)
X
X DO 3333 I=1,6
X3333 ALLZERO(I:I) = CHAR(0)
X DO 1 I=1,45
X OBJS(I)=0
X VERBS(I)=0
X DO 1 J=1,2
X1 VTXT(I,J)=ALLZERO
X
X DO 3 I=1,15
X IOBJS(I)=0
X DO 3 J=1,2
X IOTXT(I,J)=ALLZERO
X3 OTXT(I,J)=ALLZERO
X
X VRBX=0
X OBJX=0
X IOBX=0
X PREP=0
X RETURN
X
X END
X
X
X
XC*** CONFUZ
X
X
X INTEGER FUNCTION CONFUZ(DUMMY)
X
XC GENERATES SOME VARIANT OF "DON'T UNDERSTAND THAT" MESSAGE.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL PCT
X CONFUZ=60
X IF(PCT(50))CONFUZ=61
X IF(PCT(33))CONFUZ=13
X IF(PCT(25))CONFUZ=347
X IF(PCT(20))CONFUZ=195
X RETURN
X END
X
X
X
X
XC*** DARK .TRUE. IF THERE IS NO LIGHT HERE
X
X
X LOGICAL FUNCTION DARK(DUMMY)
X
XC TRUE IF LOCATION "LOC" IS DARK
X
X IMPLICIT INTEGER(A-Z)
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X LOGICAL ATHAND
X DATA LAMP /2/
X
X DARK=MOD(LOCCON(LOC),2).EQ.0.AND.(PROP(LAMP).EQ.0.OR.
X 1 .NOT.ATHAND(LAMP))
X RETURN
X END
X
X
X
X
X
X
X
XC*** DEAD .TRUE. IF OBJ IS NOW DEAD
X LOGICAL FUNCTION DEAD(OBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON/CONCOM/LOCCON(250),OBJCON(150)
X DEAD=BITSET(OBJCON(OBJ),10)
X RETURN
X END
X
XC*** DROP
X
X
X
X SUBROUTINE DROP(OBJECT,WHERE)
X
XC PLACE AN OBJECT AT A GIVEN LOC, PREFIXING IT ONTO THE ATLOC LIST.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X
X IF(OBJECT.GT.MAXOBJ)GOTO 1
X PLACE(OBJECT)=WHERE
X GOTO 2
X
X1 FIXED(OBJECT-MAXOBJ)=WHERE
X2 IF(WHERE.LE.0)RETURN
X LINK(OBJECT)=ATLOC(WHERE)
X ATLOC(WHERE)=OBJECT
X RETURN
X END
X
X
X
X
XC*** DSTROY
X
X
X SUBROUTINE DSTROY(OBJECT)
X
XC PERMANENTLY ELIMINATE "OBJECT" BY MOVING TO A NON-EXISTENT LOCATION.
X
X IMPLICIT INTEGER(A-Z)
X
X CALL MOVE(OBJECT,0)
X RETURN
X END
X
X
X
X
XC*** EDIBLE .TRUE. IF OBJ CAN BE EATEN
X
X LOGICAL FUNCTION EDIBLE(OBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON/CONCOM/LOCCON(250),OBJCON(150)
X EDIBLE=BITSET(OBJCON(OBJ),7)
X RETURN
X END
X
X
XC*** ENCLSD .TURE. IF OBJ INSIDE SOMETHING
X
X
X LOGICAL FUNCTION ENCLSD(OBJECT)
X
XC ENCLSD(OBJ) = TRUE IF THE OBJ IS IN A CONTAINER
X
X IMPLICIT INTEGER(A-Z)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X ENCLSD=.FALSE.
X IF(OBJECT.LT.1.OR.OBJECT.GT.MAXOBJ)RETURN
X ENCLSD=PLACE(OBJECT).LT.-1
X RETURN
X END
X
X
X
X
X
XC*** FORCED
X
X
X LOGICAL FUNCTION FORCED(LOC)
X
XC A FORCED LOCATION IS ONE FROM WHICH HE IS IMMEDIATELY BOUNCED TO ANOTHER.
XC NORMAL USE IS FOR DEATH (FORCE TO LOC ZERO) AND FOR DESCRIPTIONS OF
XC JOURNEY FROM ONE PLACE TO ANOTHER.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X FORCED=LOCCON(LOC).EQ.2
X
X RETURN
X END
X
X
X
XC*** GETLIN
X
X SUBROUTINE GETLIN
X
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BLKLIN
X COMMON /BLKCOM/ BLKLIN
X CHARACTER*6 TXT,WDS(2),KK,DTK,ATAB,VTXT,OTXT,IOTXT,TXT2(35,2)
X LOGICAL ACTIVE
X COMMON /UTXCOM/ WDX
X CHARACTER CHRS(150), CHR2(150),CHRX(70)
X COMMON /SV3COM/DTK(9),ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2)
X 1 ,TXT(35,2)
X
X10 DO 15 I=1,35
X DO 15 J=1,2
X TXT2(I,J) = ' '
X15 TXT(I,J) = ' '
X
X20 IF(BLKLIN)WRITE(*,*)' '
X WRITE(*,1266)
X1266 FORMAT(' >')
XC??????????????????????????????? THE FOLLOWING WORKS ON MANY COMPUTERS:
XC1266 FORMAT(' >',$)
X30 READ (*,50)CHRX
X50 FORMAT(70A1)
X DO 1 I=1,70
X CHRX(I) = CHAR(IAND(ICHAR(CHRX(I)), 127))
X IF(CHRX(I).LT.' ')CHRX(I) = ' '
X IF(CHRX(I).GE.'`')CHRX(I) = CHAR(ICHAR(CHRX(I)) - 32)
X1 CONTINUE
X
X DO 4 I=1,70
X IF(CHRX(I).NE.' ') GOTO 6
X4 CONTINUE
X GOTO 20
X6 CONTINUE
X
X INDX = 1
X DO 2 I=1,70
X IF(CHRX(I).EQ.'.'.OR.CHRX(I).EQ.';'.OR.CHRX(I).EQ.',')THEN
X CHR2(INDX) = ' '
X INDX = INDX + 1
X CHR2(INDX) = 'A'
X INDX = INDX + 1
X CHR2(INDX) = 'N'
X INDX = INDX + 1
X CHR2(INDX) = 'D'
X INDX = INDX + 1
X CHR2(INDX) = ' '
X INDX = INDX + 1
X ELSE
X CHR2(INDX) = CHRX(I)
X INDX = INDX + 1
X ENDIF
X2 CONTINUE
X CHR2(INDX) = '.'
X
X
X DO 70 INDX2= 1,INDX
X70 IF(CHR2(INDX2).NE.' ') GOTO 73
X73 CONTINUE
X J = 1
X DO 71 I = INDX2,INDX
X IF(I.NE.INDX2.AND.CHRS(J-1).EQ.' '.AND.CHR2(I).EQ.' ')GOTO71
X CHRS(J) = CHR2(I)
X J = J+1
X71 CONTINUE
X IF(CHRS(1).EQ.'.') GOTO 20
X
X WDX = 1
X J = 1
X DO 100 I=1,100
X IF(CHRS(I).EQ.'.') GO TO 200
X IF(CHRS(I).EQ.' ') GO TO 120
X IF(J.LE.6)TXT2(WDX,1)(J:J) = CHRS(I)
X IF(J.GT.6.AND.J.LE.12)TXT2(WDX,2)(J-6:J-6) = CHRS(I)
X J = J+1
X GOTO 100
X120 CONTINUE
X J = 1
X WDX = WDX + 1
X100 CONTINUE
X200 CONTINUE
X TXT(1,1) = TXT2(1,1)
X TXT(1,2) = TXT2(1,2)
X J = 1
X DO 210 I=2,35
X IF(TXT(J,1).NE.'AND '.OR.TXT2(I,1).NE.'AND ')THEN
X J = J+1
X TXT(J,1) = TXT2(I,1)
X TXT(J,2) = TXT2(I,2)
X ELSE
X WDX = WDX - 1
X ENDIF
X210 CONTINUE
X
XC WRITE(*,12345)(TXT(IQQ,1),IQQ = 1,35)
XC12345 FORMAT(' ',5A6)
X
X
X END
X
X
X
XC*** GETOBJ
X
X SUBROUTINE GETOBJ(OBJ)
X
XC ANALYSE AN OBJECT WORD. SEE IF THE THING IS HERE, WHETHER WE'VE GOT A VERB
XC YET, AND SO ON. OBJECT MUST BE HERE UNLESS VERB IS "FIND" OR "INVENT(ORY)"
XC (AND NO NEW VERB YET TO BE ANALYSED). WATER, OIL AND WINE ARE ALSO
XC FUNNY, SINCE THEY ARE NEVER ACTUALLY DROPPED AT ANY LOCATION, BUT MIGHT
XC BE HERE INSIDE THE BOTTLE OR AS A FEATURE OF THE LOCATION.
XC
XC HAS THREE POSSIBLE RETURN VALUES FOR 'OBJ':
XC VAL > 0 :: A POSITIVE OBJECT NUMBER
XC VAL = 0 :: OBJECT NOT FOUND HERE. ERROR MESSAGE PRINTED.
XC VAL < 0 :: OBJECT WORD REALLY SOMETHING ELSE. RETURN NEGATIVE
XC VALUE OF SUBSTITUTED WORD.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL AT
X CHARACTER ZAPP(20)
X COMMON /DWFCOM/ DWARF,KNIFE,KNFLOC,DFLAG,DSEEN(6),DLOC(6),
X 1 ODLOC(6),DWFMAX
X COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5)
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 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 CHARACTER*6 TXT
X COMMON /UTXCOM/ WDX
X CHARACTER*6 VTXT,OTXT,IOTXT,DTK,ATAB
X COMMON /WRDCOM/ VERBS(45),VRBX,OBJS(45),
X 1 OBJX,IOBJS(15),IOBX,PREP,WORDS(45)
X LOGICAL ATHAND,BLIND,HERE,HOLDNG,PLURAL
X COMMON /SV3COM/DTK(9),ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2)
X 1 ,TXT(35,2)
X
X
X IF(HOLDNG(OBJ))RETURN
X IF(BLIND(0))GOTO 280
X IF(FIXED(OBJ).EQ.LOC.OR.ATHAND(OBJ))GOTO 290
X IF(.NOT.HERE(OBJ))GOTO 205
X K=335
X IF(PLURAL(OBJ))K=373
X OBJ=0
X CALL RSPEAK(K)
X RETURN
X
X205 IF(OBJ.NE.GRATE)GOTO 210
X IF(LOC.EQ.1.OR.LOC.EQ.4.OR.LOC.EQ.7)OBJ=-DPRSSN
X IF(LOC.GT.9.AND.LOC.LT.15)OBJ=-ENTRNC
X IF(OBJ.EQ.GRATE)GOTO 280
X RETURN
X
X210 IF(OBJ.NE.DWARF)GOTO 220
X L1=DWFMAX-1
X DO 212 I=1,L1
X IF(DLOC(I).EQ.LOC.AND.DFLAG.GE.2)GOTO 290
X212 CONTINUE
X GOTO 280
X
X220 IF(OBJ.EQ.LIQLOC(LOC).OR.
X 1 (ATHAND(BOTTLE).AND.LIQ(BOTTLE).EQ.OBJ).OR.
X 2 (ATHAND(CASK).AND.LIQ(CASK).EQ.OBJ))GOTO 290
X IF(OBJ.NE.PLANT.OR..NOT.AT(PLANT2).OR.PROP(PLANT2).EQ.0)GOTO 230
X OBJ=PLANT2
X GOTO 290
X
X230 IF(OBJ.NE.ROCKS.OR..NOT.AT(CARVNG))GOTO 240
X OBJ=CARVNG
X GOTO 290
X
X240 IF(OBJ.NE.ROD.OR..NOT.ATHAND(ROD2))GOTO 250
X OBJ=ROD2
X GOTO 290
X
X250 IF(OBJ.NE.DOOR.OR..NOT.
X 1 (AT(SAFE).OR.AT(TDOOR).OR.AT(TDOOR2).OR.AT(PDOOR)))
X 2 GOTO 260
X OBJ=TDOOR
X IF(AT(TDOOR2))OBJ=TDOOR2
X IF(AT(PDOOR))OBJ=PDOOR
X IF(AT(SAFE))OBJ=SAFE
X GOTO 290
X
X260 IF(OBJ.NE.BOOK.OR..NOT.ATHAND(BOOK2))GOTO 270
X OBJ=BOOK2
X GOTO 290
X
X270 IF(VERBS(VRBX).EQ.FIND.OR.VERBS(VRBX).EQ.INVENT)GOTO 290
X
XC IT ISN'T HERE. TELL HIM & RETURN.
X280 OBJ=0
X CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'_here.',ZAPP,K)
X WRITE(*,282)(ZAPP(I),I=1,K)
X282 FORMAT(/' I see no ',20A1)
X
X290 RETURN
X
X END
X
X
X
X
X
XC*** GETWDS
X SUBROUTINE GETWDS
X
XC WHEN CALLED, CHECKS IF PREVIOUS WORDS VECTOR HAS BEEN EXHAUSTED.
XC IF NOT, BRANCH AROUND THE CODE WHICH READS IN A NEW LINE. IF VECTOR IS EMPTY
XC SUCK UP A LINE FROM THE TTY, THEN CHECK EACH WORD FOR INTELLIGIBILITY.
XC IF THE WORD IS VALID, ITS NUMBER GETS STUCK INTO THE WORDS VECTOR.
XC THEN EACH WORD IS PARSED BY THE APPROPRIATE CODE. THE LABELS BELOW ARE
XC 100 TIMES THE WORD CLASS.
XC
XC THE FOLLOWING VECTORS ARE USED:
XC TXT(WDX,2) HOLD THE RAW TEXT FROM GETLIN
XC WORDS(WDX) LIST OF WORD NUMBERS, CONVERTED FROM TXT(WDX,1).
XC VTXT(VRBX,2) HOLD THE TEXT FOR VERB VRBX.
XC VERBS(VRBX) IS THE LIST OF VALIDATED VERB NUMBERS.
XC OTXT(OBJX,2) HOLDS THE TEXT OF THE OBJECT OBJX.
XC OBJX(OBJX) IS THE LIST OF VALIDATED OBJECT NUMBERS.
XC IOTXT(IOBX,2) HOLDS THE TEXT FOR PREP'S IOBJ.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BLIND,LIVING,PCT,PFLAG,HINGED,AT,ATHAND,TOTING,K1,ISWIZ
X LOGICAL KILLED
X CHARACTER*6 WORD1,WORD2,DKK,DK
X CHARACTER ZAPP(20)
X
X COMMON/IZWIZ/ISWIZ
X COMMON /ADJCOM/ ADJKEY(50),ADJTAB(150),ADJSIZ
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 /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5)
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 COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X COMMON /PRPCOM/ VKEY(60),PTAB(300),VKYSIZ,PTBSIZ
X CHARACTER*6 TXT,DTK(9),ATAB
X COMMON /UTXCOM/ WDX
X CHARACTER*6 VTXT,OTXT,IOTXT
X COMMON /WRDCOM/ VERBS(45),VRBX,OBJS(45),
X 1 OBJX,IOBJS(15),IOBX,PREP,WORDS(45)
X DIMENSION TAKDIR(20)
X COMMON /SV3COM/DTK,ATAB(600),VTXT(45,2),OTXT(45,2),IOTXT(15,2)
X 1 ,TXT(35,2)
X
XC MOTION NOUN ACTION MISC PREP ADJ CONJ
X DATA CLASSD,CLASSN,CLASSA,CLASSM,CLASSP,CLASSJ,CLASSC
X 1 /1,2,3,4,5,6,7/
XC
XC A FEW MORE ACTION VERBS NOT IN COMMON.
X DATA DROP,FEED,NOTHNG,LIGHT,DRINK,SCORE /02,21,05,07,15,24/
X DATA PICK,PUT,GET /41,42,44/
XC
XC AND A MOTION VERB:
X DATA ENTER /3/
XC
XC AND TO GET/DROP EVERYTHING IN SIGHT:
X DATA ALL /109/
XC
XC TAKDIR IS A LIST OF MOTION VERBS WHICH ARE ACCEPTABLE AFTER 'TAKE'.
X DATA TAKDIR/2,6,9,10,11,13,14,17,23,25,33,34,
X 1 36,37,39,78,79,80,89,-1/
XC
XC IF WORDS(WDX+1) HAS SOMETHING IN IT, WE ARE STILL PROCESSING OLD INPUT LINE.
XC IF WORDS(1) = -2, SOMEONE ELSE HAS CALLED GETLIN (E.G., KILL DRAGON).
X
X POUR = 13
X IF(WORDS(WDX+1).GT.0)GOTO 30
X
XC IF WORDS(1) HAS BEEN SET TO -2, SOMEONE ELSE HAS ALREADY READ IN
XC THE NEW LINE, PRESUMABLY TO CHECK FOR SOME NON-STANDARD WORD.
XC (THIS HAPPENS WHEN KILLING DRAGON WITH BARE HANDS.)
X20 IF(WORDS(1).NE.-2)CALL GETLIN
X WDX=0
X DO 25 I=1,35
X WORDS(I)=0
X IF(TXT(I,1).NE.' ')WORDS(I)=VOCABX(TXT(I,1),-1)
X25 CONTINUE
X
XC THE FIRST WORD OF EACH CLAUSE GETS SPECIAL CHECKING, MOSTLY LOOKING
XC FOR IDIOMS.
X
XC SPECIAL HANDLING FOR 'SAY' AND 'CALL'. WIN IF SAYING/CALLING
XC MAGIC WORDS. NARKY IF UTTERING ANYTHING ELSE. IF NO OBJ, PASS
XC ON FOR HIGHER LEVEL PARSING.
X30 PFLAG=.FALSE.
X WDX=WDX+1
X WORD=WORDS(WDX)
X IF(WORD)830,800,32
X
X32 KK=CLASS(WORD)
X IF(KK.EQ.-1)GOTO 91
X IF(KK.EQ.CLASSA.OR.KK.EQ.CLASSD.OR.KK.EQ.CLASSM)CALL CLRLIN
X K=VAL(WORD)
X IF(KK.NE.CLASSA.OR.(K.NE.SAY.AND.K.NE.YELL))GOTO 40
X
XC 'SAY' OR 'CALL'. IF NO NEXT WORD, PASS ON TO HIGHER POWERS.
XC IF OBJECT IS MAGIC WORD ('SAY XYZZY'), FLUSH 'SAY' & TAKE NEXT WORD.
X IF(WORDS(WDX+1).EQ.0.OR.CLASS(WORDS(WDX+1)).EQ.CLASSC)GOTO 99
X WDX=WDX+1
X IF(K.EQ.SAY)CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'". ',ZAPP,K)
X IF(K.EQ.YELL)CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'"!!!!!',ZAPP,K)
X WORD=WORDS(WDX)
X IF(WORD.EQ.62.OR.WORD.EQ.65.OR.WORD.EQ.71.OR.WORD.EQ.82
X 1 .OR.WORD.EQ.2025)GOTO 99
X WRITE(*,37)(ZAPP(I),I=1,K)
X37 FORMAT(/' Okay, "',20A1)
X GOTO 860
X
XC SPECIAL STUFF FOR 'ENTER'. CAN'T GO INTO WATER.
XC 'ENTER BOAT' MEANS 'TAKE BOAT'.
X40 WORD1=TXT(WDX,1)
X WORD2=TXT(WDX+1,1)
X IF(WORD1.NE.'ENTER ')GOTO 50
X IF(WORD2.EQ.' ')GOTO 91
X SPK=43
X IF(LIQLOC(LOC).EQ.WATER)SPK=70
X IF(WORD2.EQ.'STREAM'.OR.WORD2.EQ.'WATER '.OR.WORD2.EQ.
X 1 'RESERV'.OR.WORD2.EQ.'OCEAN '.OR.WORD2.EQ.'SEA '
X 2 .OR.WORD2.EQ.'POOL ')GOTO 810
X IF(WORD2.NE.'BOAT '.AND.WORD2.NE.'ROWBOA')GOTO 99
X WORD=TAKE+2000
X GOTO 99
X
XC 'LEAVE' IS A MOTION VERB, UNLESS LEAVING AN OBJECT,
XC E.G., 'LEAVE BOAT' OR 'LEAVE BOTTLE'. BUT MAKE SURE TO LEAVE ('DROP')
XC ONLY TOTABLE OBJECTS.
X50 KK=WORDS(WDX+1)
X IF(WORD1.NE.'LEAVE '.OR.CLASS(KK).NE.CLASSN)
X 1 GOTO 55
X IF(HINGED(VAL(KK)).OR.FIXED(VAL(KK)).NE.0)GOTO 99
X WORD=LEAVE+2000
X GOTO 99
X
XC IF 'LIGHT LAMP', LIGHT MUST BE TAKEN AS AN ACTION VERB, NOT A NOUN.
X55 IF(WORD1.NE.'LIGHT'.OR.WORDS(WDX+1).NE.(LAMP+1000))GOTO 60
X WORD=LIGHT+2000
X GOTO 99
X
XC 'WATER PLANT' BECOMES 'POUR WATER', IF WE ARE AT PLANT.
XC 'OIL DOOR' BECOMES 'POUR OIL', ETC., ETC.
X60 IF((WORD1.NE.'WATER '.AND.WORD1.NE.'OIL ')
X 1 .OR.(WORD2.NE.'PLANT '.AND.WORD2.NE.'DOOR '
X 2 .AND.WORD2.NE.'SWORD '.AND.WORD2.NE.'ANVIL '))GOTO 65
X IF(.NOT.AT(VOCABX(WORD2,CLASSN)))GOTO 61
X WORDS(WDX+1)=WORDS(WDX)
X TXT(WDX+1,1)=WORD1
X TXT(WDX+1,2)=TXT(WDX,2)
X61 WORD=POUR+2000
X GOTO 99
X
XC CHECK FILLING OR EMPTYING A CONTAINER.
X65 IF((WORD1.NE.'EMPTY ').OR.
X 1 (CLASS(WORDS(WDX+1)).NE.CLASSN))GOTO 91
X KK=VAL(WORDS(WDX+1))
XC IF(KK.NE.SACK.AND.KK.NE.SAFE.AND.KK.NE.BOAT.AND.KK.NE.CHEST)
XC 1 GOTO 91
XC *** UNFINISHED CODE HERE ***
XC ALL THAT ACTUALLY HAPPENS IS OFF ERROR MESSAGES. THE STOOGE
XC SIMPLY CAN'T SAY 'EMPTY SACK OR 'TAKE ALL FROM SACK' ETC
X GOTO 91
X
X
XC THIS IS THE 'INNER' LOOP. DISPATCHING OF ALL WORDS IN A CLAUSE AFTER
XC THE FIRST COMES THRU HERE.
X
X90 WDX=WDX+1
X WORD=WORDS(WDX)
X91 IF(WORD)830,900,92
X
X96 WCLASS=WCLASS+1
X WORD=VOCABX(TXT(WDX,1),-(WCLASS+1))
X IF(WORD.EQ.-1)GOTO 800
X WORDS(WDX)=WORD
X92 IF(CLASS(WORD).NE.CLASSN)GOTO 99
X
XC IT'S NOT THE FIRST: MAKE SURE HE INCLUDED A COMMA OR 'AND'.
XC DIFFERENTIATE BETWEEN DIR & INDIR OBJECTS.
XC CHECK FOR SPECIAL CASE OF MULTIPLE OBJECTS: 'FEED BEAR HONEY' OR
XC 'THROW TROLL NUGGET'.
X K=OBJX
X IF(PFLAG)K=IOBX
X IF(K.EQ.0.OR.CLASS(WORDS(WDX-1)).EQ.CLASSC)GOTO 99
X KK=VAL(VERBS(VRBX))
X IF(.NOT.LIVING(OBJS(OBJX)).OR.(KK.NE.THROW.AND.KK.NE.FEED))
X 1 GOTO 800
X IOBX=IOBX+1
X IOBJS(IOBX)=OBJS(OBJX)
X OBJS(OBJX)=0
X OBJX=OBJX-1
X
X99 WCLASS=CLASS(WORD)
X GOTO(100,200,300,400,500,600,700),WCLASS
XC MWD OBJ AVB MVB PRP ADJ CNJ
X CALL BUG(33)
XC MOTION VERB.
XC A MOTION VERB IS EITHER A DIRECTION ('WEST') OR A MOTION ('JUMP').
XC MULTIPLE MOTIONS MUST BE SEPARATED BY COMMAS OR AND'S. THERE ARE
XC SOME IDIOMATIC USES WHICH MUST BE SCANNED FOR, SUCH AS 'TAKE BRIDGE',
XC WHICH BECOMES 'BRIDGE' AND 'GO WEST', WHICH BECOMES 'WEST', AND 'LEAVE THING'
XC IS DIFFERENT FROM JUST 'LEAVE'.
XC
XC IF ORIGINAL VERB WAS 'GO', FLUSH IT & REPLACE WITH THIS ONE.
XC I.E., 'GO WEST' BECOMES 'WEST'.
XC
XC CHECK TAKDIR(20) LIST FOR VALID OBJECT MOTION VERBS FOR 'TAKE'.
XC IF FOUND, THROW AWAY 'TAKE' AND USE THE MOTION VERB.
XC
XC SINCE THE ORIGINAL VERB IS AN ACTION VERB, CHECK THIS WORD IN THE
XC NOUN TABLE. MAYBE IT IS AN OBJECT SYNONYMOUS WITH A VERB ('ROCKS').
XC
XC IF IT ISN'T A VALID MOTION-OBJECT OF 'TAKE' OR 'GO', NOR AN OBJECT,
XC CHECK THE PREP TABLE. IF FOUND, HAND IT TO THE PREPOSITION ANALYZER.
X
X100 IF(VRBX.EQ.0)GOTO 180
X K=VERBS(VRBX)
X IF(CLASS(K).GT.CLASSA)GOTO 800
X IF(CLASS(K).NE.CLASSA)GOTO 140
X IF(VAL(K).EQ.GO)GOTO 180
X
X IF(VAL(K).NE.TAKE)GOTO 96
X KK=VAL(WORD)
X DO 110 I=1,20
X IF(TAKDIR(I).EQ.KK)GOTO 180
X110 CONTINUE
X GOTO 96
X
XC IF ORIGINAL MOTION VERB WAS CRAWL, JUMP OR CLIMB, IGNORE CURRENT WORD.
XC I.E., 'CLIMB UP' OR 'JUMP OVER' BECOME 'CLIMB' & 'JUMP' ONLY.
X140 IF(K.EQ.17.OR.K.EQ.39.OR.K.EQ.56)GOTO 90
XC 'CRAWL' 'JUMP' 'CLIMB'
X
X180 VERBS(1)=WORD
X VRBX=1
X IF(TXT(WDX,1).NE.'WEST ')GOTO 90
X IWEST=IWEST+1
X IF(IWEST.EQ.10)CALL RSPEAK(17)
X K=VAL(WORD)
X IF(K.EQ.EXIT.OR.K.EQ.ENTER)GOTO 860
X GOTO 90
XC ANALYZE OBJECT.
XC IF PFLAG IS TRUE, THEN WE ARE PROCESSING A SET OF INDIRECT (PREP)
XC OBJECTS, NOT DIRECT OBJS.
X
X200 IF(PFLAG)GOTO 503
X IF(VRBX.NE.0)GOTO 220
X K=VOCABX(TXT(WDX,1),-(CLASSA+1))
X IF(K.EQ.-1)GOTO 220
X WORD=K
X GOTO 300
X
X220 WORD=VAL(WORD)
X IF(WORD.EQ.ALL)GOTO 280
X222 CALL GETOBJ(WORD)
X IF(WORD)230,860,240
X
XC IT WASN'T REALLY AN OBJECT. GO SEE WHAT IT WAS.
X230 WORD=-WORD
X GOTO 99
X
XC IT WAS REALLY AN OBJECT & IT IS HERE.
X240 OBJX=OBJX+1
X OBJS(OBJX)=WORD
X OTXT(OBJX,1)=TXT(WDX,1)
X OTXT(OBJX,2)=TXT(WDX,2)
X GOTO 90
X
XC TAKE EVERYTHING NOT BATTENED DOWN.
X
X280 KK=VAL(VERBS(VRBX))
X K1=.FALSE.
X IF(KK.EQ.DROP.OR.KK.EQ.PUT.OR.KK.EQ.LEAVE)GOTO 281
X K1=.TRUE.
X IF(KK.NE.TAKE.AND.KK.NE.PICK.AND.KK.NE.GET)GOTO 800
X SPK=357
X IF(BLIND(0))GOTO 810
X281 DO 289 I=1,MAXOBJ
X IF(.NOT.ATHAND(I).OR.FIXED(I).NE.0)GOTO 289
X IF(I.GE.WATER.AND.I.LE.WINE+1)GOTO 289
X IF((K1.AND.TOTING(I)) .OR. (.NOT.K1.AND..NOT.TOTING(I)) )GOTO 289
X OBJX=OBJX+1
X OBJS(OBJX)=I
XC OTXT(OBJX,1)=NTXT(I,1)
XC OTXT(OBJX,2)=NTXT(I,2)
X OTXT(OBJX,1)='BUG???'
X OTXT(OBJX,2)=' '
X IF(OBJX.EQ.44)GOTO 90
X289 CONTINUE
X GOTO 90
XC ACTION VERB.
X300 IF(VRBX.EQ.0)GOTO 370
X IF(VAL(VERBS(VRBX)).NE.TAKE)GOTO 320
X K=VAL(WORD)
X IF(K.EQ.DRINK.OR.K.EQ.INVENT.OR.K.EQ.SCORE.OR.K.EQ.NOTHNG
X 1 .OR.K.EQ.LOOK)GOTO 371
X IF(K.NE.GO)GOTO 800
X DK=TXT(WDX,1)
X IF(DK.EQ.'WALK '.OR.DK.EQ.'RUN '.OR.DK.EQ.'HIKE ')
X 1 GOTO 371
X GOTO 800
X
X320 IF(OBJX.NE.0.OR.CLASS(WORDS(WDX-1)).NE.CLASSC)GOTO 800
X370 VRBX=VRBX+1
X371 VERBS(VRBX)=WORD
X VTXT(VRBX,1)=TXT(WDX,1)
X VTXT(VRBX,2)=TXT(WDX,2)
X GOTO 90
X
X
XC MISCELLANEOUS WORDS/VERBS.
X400 IF(VRBX.NE.0)GOTO 800
X VERBS(1)=WORD
X VRBX=1
X GOTO 90
XC ANALYZE A PREPOSITION AND ITS OBJECT. CHECK THAT PREP
XC IS VALID FOR THIS VERB, AND THEN CHECK THAT THE OBJECT IS VALID
XC FOR THIS PREPOSITION. IF FIRST CHECK FAILS, SYNTAX IS MESSED
XC UP; IF SECOND PART FAILS, IT MAY MERELY BE AN IMPOSSIBLE ACT.
X
X500 IF(CLASS(VERBS(VRBX)).NE.CLASSA.OR.IOBX.NE.0)GOTO 800
X IF(PFLAG)GOTO 503
X VRBKEY=VKEY(VAL(VERBS(VRBX)))
X IF(VRBKEY.EQ.0)GOTO 800
X PREP=VAL(WORD)
X PFLAG=.TRUE.
X WDX=WDX+1
X WORD=WORDS(WDX)
X IF(WORD.EQ.0)GOTO 510
X GOTO(800,503,800,800,800,600,510),CLASS(WORD)
X GOTO 840
X
X503 WORD=VAL(WORD)
X IF(WORD.EQ.ALL)GOTO 510
X504 CALL GETOBJ(WORD)
X IF(WORD)570,860,505
X
X505 IOBX=IOBX+1
X IOBJS(IOBX)=WORD
X IOTXT(IOBX,1)=TXT(WDX,1)
X IOTXT(IOBX,2)=TXT(WDX,2)
X510 KK=IABS(PTAB(VRBKEY)/1000)
X IF(KK.NE.PREP)GOTO 525
X
XC PREP IS VALID WITH THIS VERB. NOW CHECK OBJECT OF PREP.
X IF(WORD.EQ.0.OR.CLASS(WORD).EQ.CLASSC)GOTO 530
X
XC AN OBJ FOLLOWS THE PREP. SEE IF IT'S PLAUSIBLE.
X520 KK=IABS((MOD(PTAB(VRBKEY),0001000)))
X IF(KK.EQ.WORD.AND.KK.EQ.ALL)GOTO 280
X IF(KK.EQ.WORD.OR.KK.EQ.999)GOTO 90
X525 VRBKEY=VRBKEY+1
X IF(PTAB(VRBKEY-1).GE.0)GOTO 510
X GOTO 570
X
XC NO OBJ FOLLOWS PREP. CHECK SPECIAL CASES.
X530 PFLAG=.FALSE.
X WDX=WDX-1
X DK=TXT(WDX,1)
X DKK=VTXT(VRBX,1)
X IF((DK.NE.'ON '.AND.DK.NE.'OFF ').AND.
X 1 (DKK.NE.'TURN '.OR.OBJS(OBJX).NE.LAMP) .AND.
X 2 (DKK.NE.'TAKE '.AND.DKK.NE.'PUT ') )GOTO 570
X IF((DK.EQ.'UP '.AND.DKK.NE.'PICK ').OR.
X 1 (DK.EQ.'DOWN '.AND.(DKK.NE.'PUT '.AND.VERBS(VRBX).NE.THROW
X 2 )))GOTO 570
X WDX=WDX+1
X WORD=WORDS(WDX)
X IF(WORD.EQ.0)GOTO 900
X IF(CLASS(WORD).NE.CLASSC)GOTO 800
X GOTO 91
X
XC YOU CAN'T DO THAT!!
X570 SPK=NOWAY(0)
X GOTO 810
XC ADJECTIVE HANDLER.
XC SCARF THE NEXT WORD, MAKE SURE IT IS A VALID OBJECT FOR THIS ADJ.
XC THEN CALL GETOBJ TO SEE IF IT IS REALLY THERE, THEN LINK INTO OBJ
XC CODE.
X
X600 ADJ=VAL(WORD)
X WDX=WDX+1
X WORD=WORDS(WDX)
X IF(WORD)840,640,605
X
X605 IF(CLASS(WORD).EQ.CLASSC) GOTO 640
X IF(CLASS(WORD).NE.CLASSN) WORD=VOCABX(TXT(WDX,1),-(CLASSN+1))
X IF(WORD.EQ.-1.OR.CLASS(WORD).NE.CLASSN.OR.VAL(WORD).EQ.ALL)
X 1 GOTO 800
X WORDS(WDX)=WORD
X KK=VAL(WORD)
X K=ADJKEY(ADJ)
X610 IF(KK.EQ.IABS(ADJTAB(K)))GOTO 92
X IF(ADJTAB(K).LT.0)GOTO 800
X K=K+1
X GOTO 610
X
X640 CALL A5TOA1(TXT(WDX-1,1),TXT(WDX-1,2),'_WHAT?',ZAPP,K)
X WRITE(*,642)(ZAPP(I),I=1,K)
X642 FORMAT(1X, 20A1)
X GOTO 20
X
X
XC ANALYZE A CONJUNCTION. MAY BE A COMMA OR AN EXPLICIT "AND".
XC LOOK AHEAD AT NEXT WORD. IF IT IS AN ACTION VERB AND NO OBJECT
XC HAS YET BEEN SPECIFIED, PUT IT INTO THE VERB STACK. IF IT IS
XC AN OBJECT, ADD IT TO THE PILE.
XC ELSE, BUMP BACK THE WORD POINTER, ASSUME END OF CLAUSE, AND
XC RETURN.
X700 WDX=WDX+1
X WORD=WORDS(WDX)
X IF(WORD)840,800,710
X
X710 GOTO(790,92,720,790,800,92,800),CLASS(WORD)
X
XC A NEW ACTION VERB FOLLOWS. IF NO PREVIOUS VERB HAS BEEN TYPED,
XC HE LOSES. IF PREVIOUS VERB IS NOT AN ACTION VERB, HE LOSES.
XC IF AN OBJ/IOBJ WAS SPECIFIED FOR PREV ACT VERB, HE LOSES. ONLY
XC VALID SYNTAX IS: 'GET AND OPEN CAGE'.
X720 IF(VRBX.NE.0.AND.CLASS(VERBS(VRBX)).EQ.CLASSA
X 1 .AND.OBJX.EQ.0.AND.IOBX.EQ.0)GOTO 92
X790 WDX=WDX-1
X GOTO 900
XC GEE, I DON'T UNDERSTAND. FLUSH REST OF CURRENT CLAUSE, UP TO
XC EOL OR CONJUNCTION & CONTINUE.
X800 SPK=CONFUZ(0)
X810 CALL RSPEAK(SPK)
X820 CALL CLRLIN
X GOTO 20
X
XC AN IRREGULAR WORD WAS TYPED IN BY USER. CHECK FOR WIZARDRY.
X830 CONTINUE
X
X840 CONTINUE
X841 IF(PCT(25))GOTO 850
X CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'. ',ZAPP,K)
X WRITE(*,842)(ZAPP(I),I=1,K)
X842 FORMAT(/' I don''t understand the word ',20A1)
X CALL CLRLIN
X GOTO 20
X
X850 CALL A5TOA1(TXT(WDX,1),TXT(WDX,2),'? ',ZAPP,K)
X WRITE(*,852)(ZAPP(I),I=1,K)
X852 FORMAT(/' Mumble? ',20A1)
X CALL CLRLIN
X GOTO 20
X
X
XC SCAN TO CONJ OR END OF LINE.
X860 CALL CLRLIN
X PFLAG=.FALSE.
X862 WDX=WDX+1
X IF(WORDS(WDX).EQ.0)GOTO 20
X IF(CLASS(WORDS(WDX)).EQ.CLASSC)GOTO 90
X GOTO 862
X
XC END OF CLAUSE. WE APPEAR TO HAVE REACHED THE END OF A SENTENCE.
XC IT WAS TERMINATED EITHER BY CRLF OR A CONJUNCTION. IF A CONJ,
XC THE CONJ ANALYZER CLAIMS THAT THE NEXT WORDS ARE NOT PART OF
XC THIS CLAUSE. DECIDE WHETHER OR NOT WE HAVE ENOUGH TO WORK WITH.
X900 PFLAG=.FALSE.
X IF(VERBS(1).NE.0)GOTO 930
X IF(OBJS(1).EQ.0)GOTO 800
X IF(OBJS(2).NE.0)GOTO 920
X CALL A5TOA1(OTXT(1,1),OTXT(1,2),'? ',ZAPP,K)
X WRITE(*,915)(ZAPP(I),I=1,K)
X915 FORMAT(/' What do you want to do with the ',20A1)
X GOTO 20
X
X920 WRITE(*,*)' What do you want to do with them'
X GOTO 20
X
X930 IF(OBJX.GT.1.AND.IOBX.GT.1)GOTO 800
X RETURN
X
X END
X
X
X
X
X
XC*** HERE .TRUE. IF OBJ AT THIS LOCATION
X
X
X LOGICAL FUNCTION HERE(OBJ)
X
XC HERE(OBJ) = TRUE IF THE OBJ IS AT "LOC" (OR IS BEING CARRIED)
X
X IMPLICIT INTEGER(A-Z)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X LOGICAL TOTING
X HERE = .FALSE.
X IF(OBJ.LT.1.OR.OBJ.GT.MAXOBJ)RETURN
X HERE=PLACE(OBJ).EQ.LOC.OR.TOTING(OBJ)
X RETURN
X END
X
X
X
X
X
XC*** HINGED .TRUE. IF OBJ CAN BE OPENED
X
X
X LOGICAL FUNCTION HINGED(OBJ)
X
XC HINGED(OBJ) = TRUE IF OBJECT CAN BE OPENED/SHUT.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X HINGED=BITSET(OBJCON(OBJ),1)
X
X RETURN
X END
X
X
X
X
XC*** HOLDNG .TRUE. IF HOLDING OBJ
X
X
X LOGICAL FUNCTION HOLDNG(OBJ)
X
XC HOLDNG(OBJ) = TRUE IF THE OBJ IS BEING CARRIED IN HAND.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X HOLDNG = .FALSE.
X IF(OBJ.LT.1.OR.OBJ.GT.MAXOBJ)RETURN
X HOLDNG=PLACE(OBJ).EQ.-1
X RETURN
X END
X
X
X
X
X
X
X
XC*** INSERT
X
X SUBROUTINE INSERT(OBJECT,CONTNR)
X
X IMPLICIT INTEGER(A-Z)
X COMMON /HLDCOM/ HOLDER(150),HLINK(150)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X
X IF(CONTNR.EQ.OBJECT)CALL BUG(32)
X CALL CARRY(OBJECT,LOC)
X
X TEMP=HOLDER(CONTNR)
X HOLDER(CONTNR)=OBJECT
X HLINK(OBJECT)=TEMP
X PLACE(OBJECT)=-CONTNR
X RETURN
X
X END
XC*** INSIDE .TRUE. IF LOCATION IS WELL WITHIN THE CAVE
X
X
X LOGICAL FUNCTION INSIDE(LOC)
X
XC INSIDE(LOC) = TRUE IF LOCATION IS WELL WITHIN THE CAVE
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL OUTSID,PORTAL
X INSIDE=.NOT.OUTSID(LOC).AND..NOT.PORTAL(LOC)
X RETURN
X END
X
X
X
X
X
X
X
X
XC*** JUGGLE
X
X SUBROUTINE JUGGLE(OBJECT)
X
XC JUGGLE AN OBJECT BY PICKING IT UP AND PUTTING IT DOWN AGAIN, THE PURPOSE
XC BEING TO GET THE OBJECT TO THE FRONT OF THE CHAIN OF THINGS AT ITS LOC.
X
X IMPLICIT INTEGER(A-Z)
X COMMON /PLACOM/ ATLOC(250),LINK(300),PLACE(150),
X 1 FIXED(150),MAXOBJ
X
X I=PLACE(OBJECT)
X J=FIXED(OBJECT)
X CALL MOVE(OBJECT,I)
X CALL MOVE(OBJECT+MAXOBJ,J)
X RETURN
X END
X
X
X
XC*** LIQ
X
X
X INTEGER FUNCTION LIQ(OBJ)
X IMPLICIT INTEGER(A-Z)
X COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5)
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X
XC LIQ=LIQ2(MAX0(PROP(OBJ),-1-PROP(OBJ)))
X LIQ = 0
X IF(OBJ.NE.BOTTLE.AND.OBJ.NE.CASK)RETURN
X IQ = MAX0(PROP(OBJ)+1,-1-(PROP(OBJ)+1))
X IF(IQ.LE.0)RETURN
X LIQ=LIQTYP(IQ)
X RETURN
X END
X
X
X
X
X
XC*** LIQ2
XC NON-LOGICAL (ILLOGICAL?) FUNCTIONS (CLASS,LIQ,LIQ2,LIQLOC,VAL)
X
X INTEGER FUNCTION LIQ2(PBOTL)
X IMPLICIT INTEGER(A-Z)
X COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5)
X
X LIQ2=(1-PBOTL)*WATER+(PBOTL/2)*(WATER+OIL)+(PBOTL/4)
X 1 *(WATER+WINE-2*OIL)
X RETURN
X END
X
X
X
X
X
X
X
X
X
XC*** LIQLOC
END_OF_FILE
if test 37415 -ne `wc -c <'asubs.f.xaa'`; then
echo shar: \"'asubs.f.xaa'\" unpacked with wrong size!
fi
# end of 'asubs.f.xaa'
fi
echo shar: End of archive 5 \(of 7\).
cp /dev/null ark5isdone
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