Path: uunet!zephyr.ens.tek.com!tekred!saab!billr
From: billr@saab.CNA.TEK.COM (Bill Randle)
Newsgroups: comp.sources.games
Subject: v09i095: adven - original adventure game in FORTRAN, Part07/08
Message-ID: <5634@tekred.CNA.TEK.COM>
Date: 18 May 90 18:22:11 GMT
Sender: news@tekred.CNA.TEK.COM
Lines: 1949
Approved: billr@saab.CNA.TEK.COM
Submitted-by: Chris Rende <cfctech!rphroy!trux!car@uunet.uu.net>
Posting-number: Volume 9, Issue 95
Archive-name: adven/Part07
#! /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 7 (of 8)."
# Contents: carry.f class.f clrlin.f confuz.f dark.f datime.f
# drop.f enclsd.f forced.f getin.f gspeak.f here.f hinged.f
# holding.f hours.f hoursx.f insert.f inside.f juggle.f liq.f liq2.f
# liqloc.f living.f locked.f login.f logout.f lookin.f move.f
# mspeak.f newhrs.f newhrx.f noway.f opaque.f outsid.f plural.f
# pma1.pma pma2.pma poof.f portal.f printd.f pspeak.f put.f ran.f
# remove.f rspeak.f small.f speak.f toting.f treasr.f vessel.f
# vocab.f vocabx.f wearing.f xspeak.f yesm.f yesx.f
# Wrapped by billr@saab on Thu May 17 14:47:30 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'carry.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'carry.f'\"
else
echo shar: Extracting \"'carry.f'\" \(711 characters\)
sed "s/^X//" >'carry.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 711 -ne `wc -c <'carry.f'`; then
echo shar: \"'carry.f'\" unpacked with wrong size!
fi
# end of 'carry.f'
fi
if test -f 'class.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'class.f'\"
else
echo shar: Extracting \"'class.f'\" \(301 characters\)
sed "s/^X//" >'class.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 301 -ne `wc -c <'class.f'`; then
echo shar: \"'class.f'\" unpacked with wrong size!
fi
# end of 'class.f'
fi
if test -f 'clrlin.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'clrlin.f'\"
else
echo shar: Extracting \"'clrlin.f'\" \(571 characters\)
sed "s/^X//" >'clrlin.f' <<'END_OF_FILE'
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 REAL*8 VTXT,OTXT,IOTXT
X COMMON /WRDCOM/ VERBS(45),VTXT(45,2),VRBX,OBJS(45),OTXT(45,2),
X 1 OBJX,IOBJS(15),IOTXT(15,2),IOBX,PREP,WORDS(45)
X
X DO 1 I=1,45
X OBJS(I)=0
X VERBS(I)=0
X DO 1 J=1,2
X1 VTXT(I,J)=0
X
X DO 3 I=1,15
X IOBJS(I)=0
X DO 3 J=1,2
X IOTXT(I,J)=0
X3 OTXT(I,J)=0
X
X VRBX=0
X OBJX=0
X IOBX=0
X PREP=0
X RETURN
X
X END
END_OF_FILE
if test 571 -ne `wc -c <'clrlin.f'`; then
echo shar: \"'clrlin.f'\" unpacked with wrong size!
fi
# end of 'clrlin.f'
fi
if test -f 'confuz.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'confuz.f'\"
else
echo shar: Extracting \"'confuz.f'\" \(321 characters\)
sed "s/^X//" >'confuz.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 321 -ne `wc -c <'confuz.f'`; then
echo shar: \"'confuz.f'\" unpacked with wrong size!
fi
# end of 'confuz.f'
fi
if test -f 'dark.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'dark.f'\"
else
echo shar: Extracting \"'dark.f'\" \(554 characters\)
sed "s/^X//" >'dark.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X COMMON /LOCCOM/ LOC,OLDLOC,OLDLC2,NEWLOC,MAXLOC
X INTEGER*4 POINTS
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
END_OF_FILE
if test 554 -ne `wc -c <'dark.f'`; then
echo shar: \"'dark.f'\" unpacked with wrong size!
fi
# end of 'dark.f'
fi
if test -f 'datime.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'datime.f'\"
else
echo shar: Extracting \"'datime.f'\" \(852 characters\)
sed "s/^X//" >'datime.f' <<'END_OF_FILE'
X SUBROUTINE DATIME(D,T)
X
XC RETURN THE DATE AND TIME IN D AND T. D IS NUMBER OF DAYS SINCE 01-JAN-77,
XC T IS MINUTES PAST MIDNIGHT. THIS IS HARDER THAN IT SOUNDS, BECAUSE THE
XC FINAGLED DEC FUNCTIONS RETURN THE VALUES ONLY AS ASCII STRINGS!
X
X IMPLICIT INTEGER(A-Z)
X DIMENSION DAT(4),HATH(12)
XC DATA MONTHS/'-JAN-','-FEB-','-MAR-','-APR-','-MAY-','-JUN-',
XC 1 '-JUL-','-AUG-','-SEP-','-OCT-','-NOV-','-DEC-'/
X DATA HATH/31,28,31,30,31,30,31,31,30,31,30,31/
X
X CALL TIMDAT(DAT,4)
X T=DAT(4)
X D=(RS(DAT(2),8)-:260)*10+RT(DAT(2),8)-:260
X Y=(RS(DAT(3),8)-:260)*10+(RT(DAT(3),8)-:260)
X Y=Y-77
X M=(RS(DAT(1),8)-:260)*10+RT(DAT(1),8)-:260
X DO 1 I=1,12
X IF(I.EQ.M)GO TO 2
X1 D=D+HATH(I)
X CALL BUG(28)
X
X2 D=D+Y*365-1
X
X RETURN
X END
END_OF_FILE
if test 852 -ne `wc -c <'datime.f'`; then
echo shar: \"'datime.f'\" unpacked with wrong size!
fi
# end of 'datime.f'
fi
if test -f 'drop.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'drop.f'\"
else
echo shar: Extracting \"'drop.f'\" \(468 characters\)
sed "s/^X//" >'drop.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 468 -ne `wc -c <'drop.f'`; then
echo shar: \"'drop.f'\" unpacked with wrong size!
fi
# end of 'drop.f'
fi
if test -f 'enclsd.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'enclsd.f'\"
else
echo shar: Extracting \"'enclsd.f'\" \(316 characters\)
sed "s/^X//" >'enclsd.f' <<'END_OF_FILE'
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=PLACE(OBJECT).LT.-1
X RETURN
X END
END_OF_FILE
if test 316 -ne `wc -c <'enclsd.f'`; then
echo shar: \"'enclsd.f'\" unpacked with wrong size!
fi
# end of 'enclsd.f'
fi
if test -f 'forced.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'forced.f'\"
else
echo shar: Extracting \"'forced.f'\" \(404 characters\)
sed "s/^X//" >'forced.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X FORCED=LOCCON(LOC).EQ.2
X
X RETURN
X END
END_OF_FILE
if test 404 -ne `wc -c <'forced.f'`; then
echo shar: \"'forced.f'\" unpacked with wrong size!
fi
# end of 'forced.f'
fi
if test -f 'getin.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'getin.f'\"
else
echo shar: Extracting \"'getin.f'\" \(1172 characters\)
sed "s/^X//" >'getin.f' <<'END_OF_FILE'
X SUBROUTINE GETIN(WORD1,WORD1X,WORD2,WORD2X)
X
XC GET A COMMAND FROM THE ADVENTURER. SNARF OUT THE FIRST WORD, PAD IT WITH
XC BLANKS, AND RETURN IT IN WORD1. CHARS 6 THRU 10 ARE RETURNED IN WORD1X, IN
XC CASE WE NEED TO PRINT OUT THE WHOLE WORD IN AN ERROR MESSAGE. ANY NUMBER OF
XC BLANKS MAY FOLLOW THE WORD. IF A SECOND WORD APPEARS, IT IS RETURNED IN
XC WORD2 (CHARS 6 THRU 10 IN WORD2X), ELSE WORD2 IS SET TO ZERO.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL BLKLIN
X COMMON /BLKCOM/ BLKLIN
X DIMENSION A(70),TEMP(70)
X REAL*8 WRD(2),WORD1,WORD1X,WORD2,WORD2X
X
X IF(BLKLIN)PRINT 1
X1 FORMAT()
X READ(1,3)A
X3 FORMAT(70A1)
X DO 1001 I=1,70
XC **************************
XC convert lowercase to upper
XC **************************
XC IF(A(I).GE.'a'.AND.A(I).LE.'z')A(I)=AND(A(I),:157777)
X1001 CONTINUE
X WORD1=' '
X WORD1X=' '
X WORD2=0
X10 J=1
X CALL A1TOA5(A,J,WRD,TERM)
X IF(TERM.EQ.'; '.OR.TERM.EQ.0)RETURN
X WORD1=WRD(1)
X WORD1X=WRD(2)
X CALL A1TOA5(A,J,WRD,TERM)
X IF(TERM.EQ.'; '.OR.TERM.EQ.0)RETURN
X WORD2=WRD(1)
X WORD2X=WRD(2)
X RETURN
X END
END_OF_FILE
if test 1172 -ne `wc -c <'getin.f'`; then
echo shar: \"'getin.f'\" unpacked with wrong size!
fi
# end of 'getin.f'
fi
if test -f 'gspeak.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'gspeak.f'\"
else
echo shar: Extracting \"'gspeak.f'\" \(1696 characters\)
sed "s/^X//" >'gspeak.f' <<'END_OF_FILE'
XC*** GSPEAK
X
X SUBROUTINE GSPEAK(LOC)
X
XC PRINT LOCATION DESCRIPTIONS. WORKS JUST LIKE SPEAK, EXCEPT THAT
XC LOCATION NUMBER IS PREFIXED TO EACH LINE. THIS IS A SLAVE RTN FOR
XC GRIPE. WOULD USE XSPEAK, EXCEPT THAT XSPEAK USES 'PRINT' STMTS
XC INSTEAD OF WRITES, THANX TO LOSING '$' FEATURE WHEN TRYING TO SEND
XC MULTI-PART LINES TO A DISK FILE.
X
X IMPLICIT INTEGER(A-Z)
X INTEGER*4 RTEXT,PTEXT,MTEXT
X INTEGER*4 LINES
X COMMON /TXTCOM/ LINES(25000),RTEXT(400),PTEXT(150),MTEXT(45)
X INTEGER*4 LTEXT,STEXT,M,OLINE
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 INTEGER*4 POINTS,K,L
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X DIMENSION OLINE(18)
X
X K=STEXT(LOC)
X IF(K.EQ.0.OR.LINES(K+1).EQ.XOR('>$< ','CLYD'))K=LTEXT(LOC)
X1 L=IABS(LINES(K))-K-1
X DO 2 I=1,L
X2 OLINE(I)=XOR(LINES(K+I),'CLYD')
X WRITE (14,3)LOC,(OLINE(I),I=1,L)
X3 FORMAT (1X,I3,' ',18A4)
X K=K+L+1
X IF(LINES(K).GE.0)GOTO 1
X
XC NOW PRINT OUT NAMES OF OBJECTS AT THIS LOCATION
X
X DO 7 OBJ=1,MAXOBJ
X IF(LOC.NE.PLACE(OBJ).AND.LOC.NE.FIXED(OBJ))GOTO 7
X SKIP=PROP(OBJ)
X IF(OBJ.EQ.STEPS.AND.LOC.EQ.FIXED(STEPS))SKIP=1
XC*
X M=PTEXT(OBJ)
X IF(SKIP.LT.0)GOTO 40
X DO 30 I=0,SKIP
X10 M=IABS(LINES(M))
X IF(LINES(M).GE.0)GOTO 10
X30 CONTINUE
XC*
X40 L=IABS(LINES(M))-M-1
X DO 6 I=1,L
X6 OLINE(I)=XOR(LINES(M+I),'CLYD')
X WRITE (14,9)(OLINE(J),J=1,L)
X9 FORMAT (8X,18A4)
X7 CONTINUE
X RETURN
X
X END
END_OF_FILE
if test 1696 -ne `wc -c <'gspeak.f'`; then
echo shar: \"'gspeak.f'\" unpacked with wrong size!
fi
# end of 'gspeak.f'
fi
if test -f 'here.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'here.f'\"
else
echo shar: Extracting \"'here.f'\" \(416 characters\)
sed "s/^X//" >'here.f' <<'END_OF_FILE'
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=PLACE(OBJ).EQ.LOC.OR.TOTING(OBJ)
X RETURN
X END
END_OF_FILE
if test 416 -ne `wc -c <'here.f'`; then
echo shar: \"'here.f'\" unpacked with wrong size!
fi
# end of 'here.f'
fi
if test -f 'hinged.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hinged.f'\"
else
echo shar: Extracting \"'hinged.f'\" \(324 characters\)
sed "s/^X//" >'hinged.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X HINGED=BITSET(OBJCON(OBJ),1)
X
X RETURN
X END
END_OF_FILE
if test 324 -ne `wc -c <'hinged.f'`; then
echo shar: \"'hinged.f'\" unpacked with wrong size!
fi
# end of 'hinged.f'
fi
if test -f 'holding.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'holding.f'\"
else
echo shar: Extracting \"'holding.f'\" \(310 characters\)
sed "s/^X//" >'holding.f' <<'END_OF_FILE'
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=PLACE(OBJ).EQ.-1
X RETURN
X END
END_OF_FILE
if test 310 -ne `wc -c <'holding.f'`; then
echo shar: \"'holding.f'\" unpacked with wrong size!
fi
# end of 'holding.f'
fi
if test -f 'hours.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hours.f'\"
else
echo shar: Extracting \"'hours.f'\" \(1139 characters\)
sed "s/^X//" >'hours.f' <<'END_OF_FILE'
XC*** HOURS
X
X SUBROUTINE HOURS
X
XC ANNOUNCE THE CURRENT HOURS WHEN THE CAVE IS OPEN FOR ADVENTURING. THIS INFO
XC IS STORED IN WKDAY, WKEND, AND HOLID, WHERE BIT SHIFT(1,N) IS ON IFF THE
XC HOUR FROM N:00 TO N:59 IS "PRIME TIME" (CAVE CLOSED). WKDAY IS FOR
XC WEEKDAYS, WKEND FOR WEEKENDS, HOLID FOR HOLIDAYS. NEXT HOLIDAY IS FROM
XC HBEGIN TO HEND.
X
X IMPLICIT INTEGER(A-Z)
X REAL*8 T1
X DIMENSION HNAME(10),VAL(5)
X INTEGER*4 WKDAY,WKEND,HOLID
X DOUBLE PRECISION MAGIC
X COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
X 1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
X PRINT 1
X1 FORMAT()
X CALL HOURSX(WKDAY,'MON - FRI:')
X CALL HOURSX(WKEND,'SAT - SUN:')
X CALL HOURSX(HOLID,'HOLIDAYS: ')
X CALL DATIME(D,T)
X IF(HEND.LT.D.OR.HEND.LT.HBEGIN)RETURN
X IF(HBEGIN.GT.D)GOTO 10
X PRINT 5,HNAME
X5 FORMAT(/' Today is a holiday, namely ',10A2)
X RETURN
X
X10 D=HBEGIN-D
X T1='DAYS,'
X IF(D.EQ.1)T1='DAY, '
X PRINT 15,D,T,HNAME
X15 FORMAT(/' The next holiday will be in',I3,' ',A5,' namely ',10A2)
X RETURN
X END
END_OF_FILE
if test 1139 -ne `wc -c <'hours.f'`; then
echo shar: \"'hours.f'\" unpacked with wrong size!
fi
# end of 'hours.f'
fi
if test -f 'hoursx.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hoursx.f'\"
else
echo shar: Extracting \"'hoursx.f'\" \(918 characters\)
sed "s/^X//" >'hoursx.f' <<'END_OF_FILE'
XC*** HOURSX
X
X
X
X SUBROUTINE HOURSX(H,DDAY)
X
XC USED BY HOURS (ABOVE) TO PRINT HOURS FOR EITHER WEEKDAYS OR WEEKENDS.
X
X IMPLICIT INTEGER(A-Z)
X LOGICAL FIRST
X DIMENSION DAY(5), DDAY(5)
X INTEGER*4 H
X
X FIRST=.TRUE.
X FROM=-1
X DO 1 I=1,5
X1 DAY(I)=DDAY(I)
X IF(H.NE.0)GOTO 10
X PRINT 2, DAY
X2 FORMAT(10X,5A2,' Open all day')
X RETURN
X
X10 FROM=FROM+1
X IF(AND(H,LS(0000001,FROM)).NE.0) GOTO 10
X IF(FROM.GE.24)GOTO 20
X TILL=FROM
X14 TILL=TILL+1
X IF(AND(H,LS(0000001,TILL)).EQ.0.AND.TILL.NE.24) GOTO 14
X IF(FIRST)PRINT 16,DAY,FROM,TILL
X IF(.NOT.FIRST)PRINT 18,FROM,TILL
X16 FORMAT(10X,5A2,I4,':00 to',I3,':00')
X18 FORMAT(20X,I4,':00 to',I3,':00')
X FIRST=.FALSE.
X FROM=TILL
X GOTO 10
X
X20 IF(FIRST)PRINT 22,DAY1,DAY2
X22 FORMAT(10X,2A5,' Closed all day')
X RETURN
X END
END_OF_FILE
if test 918 -ne `wc -c <'hoursx.f'`; then
echo shar: \"'hoursx.f'\" unpacked with wrong size!
fi
# end of 'hoursx.f'
fi
if test -f 'insert.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'insert.f'\"
else
echo shar: Extracting \"'insert.f'\" \(485 characters\)
sed "s/^X//" >'insert.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 485 -ne `wc -c <'insert.f'`; then
echo shar: \"'insert.f'\" unpacked with wrong size!
fi
# end of 'insert.f'
fi
if test -f 'inside.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'inside.f'\"
else
echo shar: Extracting \"'inside.f'\" \(291 characters\)
sed "s/^X//" >'inside.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 291 -ne `wc -c <'inside.f'`; then
echo shar: \"'inside.f'\" unpacked with wrong size!
fi
# end of 'inside.f'
fi
if test -f 'juggle.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'juggle.f'\"
else
echo shar: Extracting \"'juggle.f'\" \(453 characters\)
sed "s/^X//" >'juggle.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 453 -ne `wc -c <'juggle.f'`; then
echo shar: \"'juggle.f'\" unpacked with wrong size!
fi
# end of 'juggle.f'
fi
if test -f 'liq.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'liq.f'\"
else
echo shar: Extracting \"'liq.f'\" \(425 characters\)
sed "s/^X//" >'liq.f' <<'END_OF_FILE'
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 INTEGER*4 POINTS
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=LIQTYP(MAX0(PROP(OBJ)+1,-1-(PROP(OBJ)+1)))
X IF(OBJ.NE.BOTTLE.AND.OBJ.NE.CASK)LIQ=0
X RETURN
X END
END_OF_FILE
if test 425 -ne `wc -c <'liq.f'`; then
echo shar: \"'liq.f'\" unpacked with wrong size!
fi
# end of 'liq.f'
fi
if test -f 'liq2.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'liq2.f'\"
else
echo shar: Extracting \"'liq2.f'\" \(318 characters\)
sed "s/^X//" >'liq2.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 318 -ne `wc -c <'liq2.f'`; then
echo shar: \"'liq2.f'\" unpacked with wrong size!
fi
# end of 'liq2.f'
fi
if test -f 'liqloc.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'liqloc.f'\"
else
echo shar: Extracting \"'liqloc.f'\" \(445 characters\)
sed "s/^X//" >'liqloc.f' <<'END_OF_FILE'
XC*** LIQLOC
X
X INTEGER FUNCTION LIQLOC(LOC)
X IMPLICIT INTEGER(A-Z)
X COMMON /LIQCOM/ BOTTLE,CASK,WATER,OIL,WINE,LIQTYP(5)
X INTEGER*4 LOCCON,OBJCON
X INTEGER*2 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(INTS(MOD(LOCCON(LOC)/8,2)*(MOD(LOCCON(LOC)/2*2,16)-9)
X 1 +1))
X
X RETURN
X END
END_OF_FILE
if test 445 -ne `wc -c <'liqloc.f'`; then
echo shar: \"'liqloc.f'\" unpacked with wrong size!
fi
# end of 'liqloc.f'
fi
if test -f 'living.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'living.f'\"
else
echo shar: Extracting \"'living.f'\" \(339 characters\)
sed "s/^X//" >'living.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X LIVING=BITSET(OBJCON(OBJ),9)
X
X RETURN
X END
END_OF_FILE
if test 339 -ne `wc -c <'living.f'`; then
echo shar: \"'living.f'\" unpacked with wrong size!
fi
# end of 'living.f'
fi
if test -f 'locked.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'locked.f'\"
else
echo shar: Extracting \"'locked.f'\" \(265 characters\)
sed "s/^X//" >'locked.f' <<'END_OF_FILE'
XC*** LOCKED .TRUE. IF LOCKABLE OBJ IS LOCKED
X
X LOGICAL FUNCTION LOCKED(OBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL BITSET
X INTEGER*4 LOCCON,OBJCON
X COMMON/CONCOM/LOCCON(250),OBJCON(150)
X LOCKED=BITSET(OBJCON(OBJ),4)
X RETURN
X END
END_OF_FILE
if test 265 -ne `wc -c <'locked.f'`; then
echo shar: \"'locked.f'\" unpacked with wrong size!
fi
# end of 'locked.f'
fi
if test -f 'login.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'login.f'\"
else
echo shar: Extracting \"'login.f'\" \(369 characters\)
sed "s/^X//" >'login.f' <<'END_OF_FILE'
XC*** LOGIN
X SUBROUTINE LOGIN
X IMPLICIT INTEGER(A-Z)
X DIMENSION VEC(15)
X LOGICAL ACTIVE
X INTEGER*4 MESSGS
X COMMON/LNKCOM/ACTIVE(32),USER(15,32),MESSGS(32),MONITO(32),
X 1 TEXT(70,32)
X COMMON/WRUCOM/ME
X CALL TIMDAT(VEC,15)
X ME=VEC(12)
X CALL TIMDAT(USER(1,ME),15)
X ACTIVE(VEC(12))=.TRUE.
X RETURN
X END
END_OF_FILE
if test 369 -ne `wc -c <'login.f'`; then
echo shar: \"'login.f'\" unpacked with wrong size!
fi
# end of 'login.f'
fi
if test -f 'logout.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'logout.f'\"
else
echo shar: Extracting \"'logout.f'\" \(284 characters\)
sed "s/^X//" >'logout.f' <<'END_OF_FILE'
XC*** LOGOUT
X LOGICAL FUNCTION LOGOUT(DUMMY)
X IMPLICIT INTEGER(A-Z)
X COMMON/LNKCOM/ACTIVE(32),USER(15,32),MESSGS(32),MONITO(32),
X 1 TEXT(70,32)
X COMMON/WRUCOM/ME
X LOGICAL ACTIVE
X INTEGER*4 MESSGS
X LOGOUT=.NOT.ACTIVE(ME)
X RETURN
X END
END_OF_FILE
if test 284 -ne `wc -c <'logout.f'`; then
echo shar: \"'logout.f'\" unpacked with wrong size!
fi
# end of 'logout.f'
fi
if test -f 'lookin.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'lookin.f'\"
else
echo shar: Extracting \"'lookin.f'\" \(722 characters\)
sed "s/^X//" >'lookin.f' <<'END_OF_FILE'
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(' ',5)
X CALL PSPEAK(TEMP,-1)
X BLKLIN=BSAVE
X TEMP=HLINK(TEMP)
X LOOP=-1
X GOTO 20
X
X END
END_OF_FILE
if test 722 -ne `wc -c <'lookin.f'`; then
echo shar: \"'lookin.f'\" unpacked with wrong size!
fi
# end of 'lookin.f'
fi
if test -f 'move.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'move.f'\"
else
echo shar: Extracting \"'move.f'\" \(675 characters\)
sed "s/^X//" >'move.f' <<'END_OF_FILE'
XC*** MOVE
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(ENCLSD(OBJECT))CALL REMOVE(OBJECT)
X FROM=PLACE(OBJECT)
X IF(OBJECT.GT.MAXOBJ)FROM=FIXED(OBJECT-MAXOBJ)
X IF(FROM.GT.0.AND.FROM.LE.MAXOBJ*2)CALL CARRY(OBJECT,FROM)
X CALL DROP(OBJECT,WHERE)
X RETURN
X END
END_OF_FILE
if test 675 -ne `wc -c <'move.f'`; then
echo shar: \"'move.f'\" unpacked with wrong size!
fi
# end of 'move.f'
fi
if test -f 'mspeak.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'mspeak.f'\"
else
echo shar: Extracting \"'mspeak.f'\" \(326 characters\)
sed "s/^X//" >'mspeak.f' <<'END_OF_FILE'
XC*** MSPEAK
X
X
X
X SUBROUTINE MSPEAK(I)
X
XC PRINT THE I-TH "MAGIC" MESSAGE (SECTION 12 OF DATABASE).
X
X IMPLICIT INTEGER(A-Z)
X INTEGER*4 RTEXT,PTEXT,MTEXT,M
X INTEGER*4 LINES
X COMMON /TXTCOM/ LINES(25000),RTEXT(400),PTEXT(150),MTEXT(45)
X
X IF(I.NE.0)CALL SPEAK(MTEXT(I))
X RETURN
X END
END_OF_FILE
if test 326 -ne `wc -c <'mspeak.f'`; then
echo shar: \"'mspeak.f'\" unpacked with wrong size!
fi
# end of 'mspeak.f'
fi
if test -f 'newhrs.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'newhrs.f'\"
else
echo shar: Extracting \"'newhrs.f'\" \(616 characters\)
sed "s/^X//" >'newhrs.f' <<'END_OF_FILE'
XC*** NEWHRS
X
X
X
X SUBROUTINE NEWHRS
X
XC SET UP NEW HOURS FOR THE CAVE. SPECIFIED AS INVERSE--I.E., WHEN IS IT
XC CLOSED DUE TO PRIME TIME? SEE HOURS (ABOVE) FOR DESC OF VARIABLES.
X
X IMPLICIT INTEGER(A-Z)
X DIMENSION HNAME(10)
X INTEGER*4 WKDAY,WKEND,HOLID,NEWHRX
X DOUBLE PRECISION MAGIC
X COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
X 1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
X CALL MSPEAK(21)
X WKDAY=NEWHRX('WEEKDAYS: ')
X WKEND=NEWHRX('WEEKENDS: ')
X HOLID=NEWHRX('HOLIDAYS: ')
X CALL MSPEAK(22)
X CALL HOURS
X RETURN
X END
END_OF_FILE
if test 616 -ne `wc -c <'newhrs.f'`; then
echo shar: \"'newhrs.f'\" unpacked with wrong size!
fi
# end of 'newhrs.f'
fi
if test -f 'newhrx.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'newhrx.f'\"
else
echo shar: Extracting \"'newhrx.f'\" \(627 characters\)
sed "s/^X//" >'newhrx.f' <<'END_OF_FILE'
XC*** NEWHRX
X
X
X
X INTEGER*4 FUNCTION NEWHRX(DAY)
X
XC INPUT PRIME TIME SPECS AND SET UP A WORD OF INTERNAL FORMAT.
X
X IMPLICIT INTEGER(A-Z)
X DIMENSION DDAY(5), DAY(5)
X
X NEWHRX=0
X DO 8 I=1,5
X8 DDAY(I)=DAY(I)
X PRINT 9,DDAY
X9 FORMAT(' PRIME TIME ON ',5A2)
X10 PRINT 2
X2 FORMAT(' FROM:')
X READ(1,3)FROM
X3 FORMAT(I4)
X IF(FROM.LT.0.OR.FROM.GE.24)RETURN
X PRINT 4
X4 FORMAT(' TILL:')
X READ(1,3)TILL
X TILL=TILL-1
X IF(TILL.LT.FROM.OR.TILL.GE.24)RETURN
X DO 5 I=FROM,TILL
X5 NEWHRX=OR(NEWHRX,LS(0000001,I))
X GOTO 10
X END
END_OF_FILE
if test 627 -ne `wc -c <'newhrx.f'`; then
echo shar: \"'newhrx.f'\" unpacked with wrong size!
fi
# end of 'newhrx.f'
fi
if test -f 'noway.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'noway.f'\"
else
echo shar: Extracting \"'noway.f'\" \(393 characters\)
sed "s/^X//" >'noway.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 393 -ne `wc -c <'noway.f'`; then
echo shar: \"'noway.f'\" unpacked with wrong size!
fi
# end of 'noway.f'
fi
if test -f 'opaque.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'opaque.f'\"
else
echo shar: Extracting \"'opaque.f'\" \(430 characters\)
sed "s/^X//" >'opaque.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X OPAQUE=BITSET(OBJCON(OBJ),17)
X
X RETURN
X END
END_OF_FILE
if test 430 -ne `wc -c <'opaque.f'`; then
echo shar: \"'opaque.f'\" unpacked with wrong size!
fi
# end of 'opaque.f'
fi
if test -f 'outsid.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'outsid.f'\"
else
echo shar: Extracting \"'outsid.f'\" \(339 characters\)
sed "s/^X//" >'outsid.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X OUTSID=BITSET(LOCCON(LOC),6)
X
X RETURN
X END
END_OF_FILE
if test 339 -ne `wc -c <'outsid.f'`; then
echo shar: \"'outsid.f'\" unpacked with wrong size!
fi
# end of 'outsid.f'
fi
if test -f 'plural.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'plural.f'\"
else
echo shar: Extracting \"'plural.f'\" \(347 characters\)
sed "s/^X//" >'plural.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X PLURAL=BITSET(OBJCON(OBJ),13)
X
X RETURN
X END
END_OF_FILE
if test 347 -ne `wc -c <'plural.f'`; then
echo shar: \"'plural.f'\" unpacked with wrong size!
fi
# end of 'plural.f'
fi
if test -f 'pma1.pma' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pma1.pma'\"
else
echo shar: Extracting \"'pma1.pma'\" \(1804 characters\)
sed "s/^X//" >'pma1.pma' <<'END_OF_FILE'
X SEG
X ENT ENTER
XECBENT ARGT
X D64V
X E64V
X CALL GETTIM
X STA STIME
XREAD JMP LOOP
XCHAR BSZ 1
XCHKS LDX =8
XCHK CAS SPEC-1,1
X SKP
X JMP BL-1,1
X DRX
X JMP CHK
X JMP STORE
XRRED JMP READ
XERASEC LDA CP,*
X SZE
X S1A
X STA CP,*
X JMP READ
XKILLC CRA
X STA CP,*
X JMP READ
XEND LDA FLAG
X SPL
X PRTN
X CALL GETTIM
X SUB STIME
X STA ETIME,*
X PRTN
XSTORE LDA CP,*
X LGR 1
X STA 0
X ERA BS,*
X SNZ
X JMP RRED
X LDA BA,*1
X SSC
X ICA
X CAR
X ERA CHAR
X SSC
X ICA
X STA BA,*1
X IRS CP,*
X JMP RRED
XSPEC DATA '377
X DATA '223
X DATA '200
X DATA '222
X DATA '224
XERASE DATA '210
XKILL DATA '230
X DATA '212
XBL JMP READ
X JMP READ
X JMP READ
X JMP READ
X JMP READ
X JMP ERASEC
X JMP KILLC
X JMP END
XFLAG BSZ 1
XLOOP E64R
X SKS '704 CHAR PRESENT
X JMP TSTTIM NO TEST TIMEOUT
X E64V
X LDA ='200
XININ E64R
X INA 4
X JMP ININ
X E64V
XT1RET STA CHAR RETURN CHAR
X JMP CHKS
XTSTTIM E64V
X CALL GETTIM
X SUB STIME
X SPL
X ADD =3600
X SUB LIMIT,*
X SPL
X JMP LOOP
X LDA LIMIT,*
X TCA
X STA FLAG
X STA ETIME,*
X LDA ='212
X JMP T1RET
X*
X*
X LINK
XSTIME BSZ 1
XENTER ECB ECBENT,,BA,5
X DYNM BA(3),BS(3),LIMIT(3),ETIME(3),CP(3)
X END
END_OF_FILE
if test 1804 -ne `wc -c <'pma1.pma'`; then
echo shar: \"'pma1.pma'\" unpacked with wrong size!
fi
# end of 'pma1.pma'
fi
if test -f 'pma2.pma' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pma2.pma'\"
else
echo shar: Extracting \"'pma2.pma'\" \(326 characters\)
sed "s/^X//" >'pma2.pma' <<'END_OF_FILE'
X SEG
X ENT GETTIM
XIGTM NOP
X D64V
X E64V
X PCL TIMDAT
X EXT TIMDAT
X AP TIMBUF,S
X AP =5,SL
X LDA TIMBUF+3
X PID
X DIV =60
X XCB
X MPY =60
X ADD TIMBUF+4
X PRTN
XGETTIM ECB IGTM,,0
X LINK
XTIMBUF BSZ 7
X END
X
END_OF_FILE
if test 326 -ne `wc -c <'pma2.pma'`; then
echo shar: \"'pma2.pma'\" unpacked with wrong size!
fi
# end of 'pma2.pma'
fi
if test -f 'poof.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'poof.f'\"
else
echo shar: Extracting \"'poof.f'\" \(599 characters\)
sed "s/^X//" >'poof.f' <<'END_OF_FILE'
XC*** POOF
X
X SUBROUTINE POOF
X
XC AS PART OF DATABASE INITIALISATION, WE CALL POOF TO SET UP SOME DUMMY
XC PRIME-TIME SPECS, MAGIC WORDS, ETC.
X
X IMPLICIT INTEGER(A-Z)
X DIMENSION HNAME(10)
X INTEGER*4 WKDAY,WKEND,HOLID
X DOUBLE PRECISION MAGIC
X COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
X 1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
X
XC WKDAY="00177000 [CLOSES FROM 9AM - 5PM]
X WKDAY=0
X WKEND=0
X HOLID=0
X HBEGIN=0
X HEND=-1
X SHORT=35
X MAGIC='HOBBIT'
X MAGNM=1
X LATNCY=90
X RETURN
X END
END_OF_FILE
if test 599 -ne `wc -c <'poof.f'`; then
echo shar: \"'poof.f'\" unpacked with wrong size!
fi
# end of 'poof.f'
fi
if test -f 'portal.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'portal.f'\"
else
echo shar: Extracting \"'portal.f'\" \(341 characters\)
sed "s/^X//" >'portal.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X PORTAL=BITSET(LOCCON(LOC),5)
X
X RETURN
X END
END_OF_FILE
if test 341 -ne `wc -c <'portal.f'`; then
echo shar: \"'portal.f'\" unpacked with wrong size!
fi
# end of 'portal.f'
fi
if test -f 'printd.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'printd.f'\"
else
echo shar: Extracting \"'printd.f'\" \(315 characters\)
sed "s/^X//" >'printd.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X PRINTD=BITSET(OBJCON(OBJ),8)
X
X RETURN
X END
END_OF_FILE
if test 315 -ne `wc -c <'printd.f'`; then
echo shar: \"'printd.f'\" unpacked with wrong size!
fi
# end of 'printd.f'
fi
if test -f 'pspeak.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pspeak.f'\"
else
echo shar: Extracting \"'pspeak.f'\" \(555 characters\)
sed "s/^X//" >'pspeak.f' <<'END_OF_FILE'
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 INTEGER*4 RTEXT,PTEXT,MTEXT,M
X INTEGER*4 LINES
X COMMON /TXTCOM/ LINES(25000),RTEXT(400),PTEXT(150),MTEXT(45)
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
END_OF_FILE
if test 555 -ne `wc -c <'pspeak.f'`; then
echo shar: \"'pspeak.f'\" unpacked with wrong size!
fi
# end of 'pspeak.f'
fi
if test -f 'put.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'put.f'\"
else
echo shar: Extracting \"'put.f'\" \(294 characters\)
sed "s/^X//" >'put.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 294 -ne `wc -c <'put.f'`; then
echo shar: \"'put.f'\" unpacked with wrong size!
fi
# end of 'put.f'
fi
if test -f 'ran.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ran.f'\"
else
echo shar: Extracting \"'ran.f'\" \(664 characters\)
sed "s/^X//" >'ran.f' <<'END_OF_FILE'
XC*** RAN
XC UTILITY ROUTINES (SHIFT, RAN, DATIME, CIAO, BUG, LOG)
X
X
X INTEGER FUNCTION RAN(RANGE)
X
XC SINCE THE RAN FUNCTION IN LIB40 SEEMS TO BE A REAL LOSE, WE'LL USE ONE OF
XC OUR OWN. IT'S BEEN RUN THROUGH MANY OF THE TESTS IN KNUTH VOL. 2 AND
XC SEEMS TO BE QUITE RELIABLE. RAN RETURNS A VALUE UNIFORMLY SELECTED
XC BETWEEN 0 AND RANGE-1. NOTE RESEMBLANCE TO ALG USED IN WIZARD.
X
X IMPLICIT INTEGER(A-Z)
X INTEGER*4 R
X DATA R/0/
X
X D=1
X IF(R.NE.0)GOTO 1
X CALL DATIME(D,T)
X R=18*T+5
X D=1000+MOD(D,1000)
X1 DO 2 T=1,D
X2 R=MOD(R*1021,1048576)
X RAN=(RANGE*R)/1048576
X RETURN
X END
END_OF_FILE
if test 664 -ne `wc -c <'ran.f'`; then
echo shar: \"'ran.f'\" unpacked with wrong size!
fi
# end of 'ran.f'
fi
if test -f 'remove.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'remove.f'\"
else
echo shar: Extracting \"'remove.f'\" \(529 characters\)
sed "s/^X//" >'remove.f' <<'END_OF_FILE'
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
END_OF_FILE
if test 529 -ne `wc -c <'remove.f'`; then
echo shar: \"'remove.f'\" unpacked with wrong size!
fi
# end of 'remove.f'
fi
if test -f 'rspeak.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'rspeak.f'\"
else
echo shar: Extracting \"'rspeak.f'\" \(334 characters\)
sed "s/^X//" >'rspeak.f' <<'END_OF_FILE'
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 INTEGER*4 RTEXT,PTEXT,MTEXT,M
X INTEGER*4 LINES
X COMMON /TXTCOM/ LINES(25000),RTEXT(400),PTEXT(150),MTEXT(45)
X
X M=RTEXT(I)
X IF(I.NE.0)CALL SPEAK(M)
X RETURN
X END
END_OF_FILE
if test 334 -ne `wc -c <'rspeak.f'`; then
echo shar: \"'rspeak.f'\" unpacked with wrong size!
fi
# end of 'rspeak.f'
fi
if test -f 'small.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'small.f'\"
else
echo shar: Extracting \"'small.f'\" \(275 characters\)
sed "s/^X//" >'small.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON/CONCOM/LOCCON(250),OBJCON(150)
X SMALL=BITSET(OBJCON(OBJ),16)
X RETURN
X END
END_OF_FILE
if test 275 -ne `wc -c <'small.f'`; then
echo shar: \"'small.f'\" unpacked with wrong size!
fi
# end of 'small.f'
fi
if test -f 'speak.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'speak.f'\"
else
echo shar: Extracting \"'speak.f'\" \(1377 characters\)
sed "s/^X//" >'speak.f' <<'END_OF_FILE'
XC*** SPEAK
XC I/O ROUTINES
XC (SPEAK, PSPEAK, RSPEAK, GETIN, YES, A5TOA1, GETLIN, A1TOA5, CONFUZ, CLRLIN, N
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 INTEGER*4 RTEXT,PTEXT,MTEXT,N,K,I,L
X INTEGER*4 LINES,OLINE,MESSGS
X COMMON /TXTCOM/ LINES(25000),RTEXT(400),PTEXT(150),MTEXT(45)
X COMMON /BLKCOM/ BLKLIN
X DIMENSION OLINE(36),ILINE(70)
X LOGICAL ACTIVE
X COMMON/LNKCOM/ACTIVE(32),USER(15,32),MESSGS(32),MONITO(32),
X 1 TEXT(70,32)
X COMMON/WRUCOM/ME
X
X M=0
X IF(MONITO(ME).LE.0)GOTO 100
X CALL SEM$WT(MONITO(ME),CODE)
X MESSGS(ME)=N
X100 IF(N.EQ.0)GOTO 4
X IF(LINES(N+1).EQ.XOR('>$< ','CLYD'))GOTO 4
X IF(BLKLIN)PRINT 3
X K=N
XC next line gutted as i can't imagine what it means. dt.
XC1 IF(M.GT.22)CALL DUPLX$(:30000)
XC so add a new label 1
X1 CONTINUE
X IF(M.GT.22)M=0
X L=IABS(LINES(K))-K-1
X DO 2 I=1,L
X2 OLINE(I)=XOR(LINES(K+I),'CLYD')
X PRINT 3,(OLINE(I),I=1,L)
X3 FORMAT(' ',19A4)
X M=M+1
X K=K+L+1
X IF(LINES(K).GE.0)GOTO 1
X4 IF(MONITO(ME).GE.0)RETURN
X DO 10 I=1,70
X10 ILINE(I)=TEXT(I,IABS(MONITO(ME)))
X MONITO(ME)=0
X WRITE(1,101)ILINE
X101 FORMAT(70A1)
X RETURN
X END
END_OF_FILE
if test 1377 -ne `wc -c <'speak.f'`; then
echo shar: \"'speak.f'\" unpacked with wrong size!
fi
# end of 'speak.f'
fi
if test -f 'toting.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'toting.f'\"
else
echo shar: Extracting \"'toting.f'\" \(711 characters\)
sed "s/^X//" >'toting.f' <<'END_OF_FILE'
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 CONTNR=-PLACE(OBJ)
X OUTER=-PLACE(CONTNR)
X OUTER2=-PLACE(OUTER)
X
X AAA=HOLDNG(CONTNR)
X BBB=ENCLSD(CONTNR).AND.HOLDNG(OUTER)
X CCC=ENCLSD(OUTER).AND.HOLDNG(OUTER2)
X
X TOTING=HOLDNG(OBJ).OR.(ENCLSD(OBJ).AND.(AAA.OR.BBB.OR.CCC))
X RETURN
X END
END_OF_FILE
if test 711 -ne `wc -c <'toting.f'`; then
echo shar: \"'toting.f'\" unpacked with wrong size!
fi
# end of 'toting.f'
fi
if test -f 'treasr.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'treasr.f'\"
else
echo shar: Extracting \"'treasr.f'\" \(329 characters\)
sed "s/^X//" >'treasr.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X TREASR=BITSET(OBJCON(OBJ),14)
X
X RETURN
X END
END_OF_FILE
if test 329 -ne `wc -c <'treasr.f'`; then
echo shar: \"'treasr.f'\" unpacked with wrong size!
fi
# end of 'treasr.f'
fi
if test -f 'vessel.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'vessel.f'\"
else
echo shar: Extracting \"'vessel.f'\" \(325 characters\)
sed "s/^X//" >'vessel.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X
X VESSEL=BITSET(OBJCON(OBJ),15)
X
X RETURN
X END
END_OF_FILE
if test 325 -ne `wc -c <'vessel.f'`; then
echo shar: \"'vessel.f'\" unpacked with wrong size!
fi
# end of 'vessel.f'
fi
if test -f 'vocab.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'vocab.f'\"
else
echo shar: Extracting \"'vocab.f'\" \(375 characters\)
sed "s/^X//" >'vocab.f' <<'END_OF_FILE'
XC*** VOCAB
XC DATA STRUCTURE ROUTINES
XC (VOCAB, VOCABX, DSTROY, JUGGLE, MOVE, PUT, CARRY, DROP, INSERT, REMOVE)
X
X
X INTEGER FUNCTION VOCAB(ID,INIT)
X
XC THIS DECRYPTS THE WORD BEFORE SENDING IT TO VOCABX, WHO DOES ALL
XC THE REAL WORK. SEE COMMENTS IN VOCABX.
X
X IMPLICIT INTEGER(A-Z)
X REAL*8 ID
X VOCAB=VOCABX(ID,INIT)
X
X RETURN
X END
END_OF_FILE
if test 375 -ne `wc -c <'vocab.f'`; then
echo shar: \"'vocab.f'\" unpacked with wrong size!
fi
# end of 'vocab.f'
fi
if test -f 'vocabx.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'vocabx.f'\"
else
echo shar: Extracting \"'vocabx.f'\" \(1145 characters\)
sed "s/^X//" >'vocabx.f' <<'END_OF_FILE'
XC*** VOCABX
X
X
X INTEGER FUNCTION VOCABX(ID,INIT)
X
XC LOOK UP ID IN THE VOCABULARY (ATAB) AND RETURN ITS "DEFINITION" (KTAB), OR
XC -1 IF NOT FOUND. IF INIT IS POSITIVE, THIS IS AN INITIALISATION CALL SETTING
XC UP A KEYWORD VARIABLE, AND NOT FINDING IT CONSTITUTES A BUG. IT ALSO MEANS
XC THAT ONLY KTAB VALUES WHICH TAKEN OVER 1000 EQUAL INIT MAY BE CONSIDERED.
XC (THUS "STEPS", WHICH IS A MOTION VERB AS WELL AS AN OBJECT, MAY BE LOCATED
XC AS AN OBJECT.) AND IT ALSO MEANS THE KTAB VALUE IS TAKEN MOD 1000.
X
X IMPLICIT INTEGER(A-Z)
X REAL*8 ATAB,ID
X COMMON /VOCCOM/ KTAB(600),ATAB(600),TABSIZ
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 PRINT 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
END_OF_FILE
if test 1145 -ne `wc -c <'vocabx.f'`; then
echo shar: \"'vocabx.f'\" unpacked with wrong size!
fi
# end of 'vocabx.f'
fi
if test -f 'wearing.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'wearing.f'\"
else
echo shar: Extracting \"'wearing.f'\" \(368 characters\)
sed "s/^X//" >'wearing.f' <<'END_OF_FILE'
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 INTEGER*4 LOCCON,OBJCON
X COMMON /CONCOM/ LOCCON(250),OBJCON(150)
X LOGICAL BITSET
X
X WEARNG=BITSET(OBJCON(OBJ),WEARBT)
X RETURN
X END
END_OF_FILE
if test 368 -ne `wc -c <'wearing.f'`; then
echo shar: \"'wearing.f'\" unpacked with wrong size!
fi
# end of 'wearing.f'
fi
if test -f 'xspeak.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'xspeak.f'\"
else
echo shar: Extracting \"'xspeak.f'\" \(1511 characters\)
sed "s/^X//" >'xspeak.f' <<'END_OF_FILE'
XC*** XSPEAK
XC UTILITY ROUTINES FOR CREATING A READABLE CAVE MAP. (XSPEAK, XMAP)
X
X SUBROUTINE XSPEAK(LOC)
X
XC PRINT LOCATION DESCRIPTIONS. WORKS JUST LIKE SPEAK, EXCEPT THAT
XC LOCATION NUMBER IS PREFIXED TO EACH LINE.
X
X IMPLICIT INTEGER(A-Z)
X INTEGER*4 RTEXT,PTEXT,MTEXT
X INTEGER*4 LINES
X COMMON /TXTCOM/ LINES(25000),RTEXT(400),PTEXT(150),MTEXT(45)
X INTEGER*4 LTEXT,STEXT,K,L
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 INTEGER*4 POINTS,OLINE
X COMMON /OBJCOM/ PLAC(150),FIXD(150),WEIGHT(150),PROP(150),
X 1 POINTS(150)
X DIMENSION OLINE(18)
X
X K=STEXT(LOC)
X IF(K.EQ.0.OR.LINES(K+1).EQ.XOR('>$< ','CLYD'))K=LTEXT(LOC)
XC WRITE (22,5)
X WRITE(5,5)
XC WRITE (22,5)
X WRITE(5,5)
X5 FORMAT (1H )
X1 L=IABS(LINES(K))-K-1
X DO 2 I=1,L
X2 OLINE(I)=XOR(LINES(K+I),'CLYD')
XC WRITE (22,3),LOC,(OLINE(I),I=1,L)
X WRITE(5,3)LOC,(OLINE(I),I=1,L)
X3 FORMAT (1X,I3,' ',18A4)
X K=K+L+1
X IF(LINES(K).GE.0)GOTO 1
X DO 7 OBJ=1,MAXOBJ
X IF(LOC.NE.PLAC(OBJ).AND.LOC.NE.FIXD(OBJ))GOTO 7
X K=PTEXT(OBJ)
X L=IABS(LINES(K))-K-1
X DO 6 I=1,L
X6 OLINE(I)=XOR(LINES(K+I),'CLYD')
XC WRITE (22,9),(OLINE(J),J=1,L)
X WRITE(5,9)(OLINE(J),J=1,L)
X7 CONTINUE
XC WRITE (22,5)
X WRITE(5,5)
X RETURN
X
X9 FORMAT (8X,18A4)
X END
END_OF_FILE
if test 1511 -ne `wc -c <'xspeak.f'`; then
echo shar: \"'xspeak.f'\" unpacked with wrong size!
fi
# end of 'xspeak.f'
fi
if test -f 'yesm.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'yesm.f'\"
else
echo shar: Extracting \"'yesm.f'\" \(234 characters\)
sed "s/^X//" >'yesm.f' <<'END_OF_FILE'
XC*** YESM
X
X
X
X LOGICAL FUNCTION YESM(X,Y,Z)
X
XC CALL YESX (BELOW) WITH MESSAGES FROM SECTION 12.
X
X IMPLICIT INTEGER(A-Z)
X EXTERNAL MSPEAK
X LOGICAL YESX
X
X YESM=YESX(X,Y,Z,MSPEAK)
X RETURN
X END
END_OF_FILE
if test 234 -ne `wc -c <'yesm.f'`; then
echo shar: \"'yesm.f'\" unpacked with wrong size!
fi
# end of 'yesm.f'
fi
if test -f 'yesx.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'yesx.f'\"
else
echo shar: Extracting \"'yesx.f'\" \(706 characters\)
sed "s/^X//" >'yesx.f' <<'END_OF_FILE'
XC*** YESX
X
X
X
X LOGICAL FUNCTION YESX(X,Y,Z,SPK)
X
XC PRINT MESSAGE X, WAIT FOR YES/NO ANSWER. IF YES, PRINT Y AND LEAVE YEA
XC TRUE; IF NO, PRINT Z AND LEAVE YEA FALSE. SPK IS EITHER RSPEAK OR MSPEAK.
X
X IMPLICIT INTEGER(A-Z)
X REAL*8 REPLY,JUNK1,JUNK2,JUNK3
X EXTERNAL SPK
X
X1 IF(X.NE.0)CALL SPK(X)
X CALL GETIN(REPLY,JUNK1,JUNK2,JUNK3)
X IF(REPLY.EQ.'YES '.OR.REPLY.EQ.'Y ')GOTO 10
X IF(REPLY.EQ.'NO '.OR.REPLY.EQ.'N ')GOTO 20
X PRINT 9
X9 FORMAT(/' Please answer the question.')
X GOTO 1
X10 YESX=.TRUE.
X IF(Y.NE.0)CALL SPK(Y)
X RETURN
X20 YESX=.FALSE.
X IF(Z.NE.0)CALL SPK(Z)
X RETURN
X END
END_OF_FILE
if test 706 -ne `wc -c <'yesx.f'`; then
echo shar: \"'yesx.f'\" unpacked with wrong size!
fi
# end of 'yesx.f'
fi
echo shar: End of archive 7 \(of 8\).
cp /dev/null ark7isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 8 archives.
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