games-request@tekred.UUCP (09/01/87)
Submitted by: Bill Randle <games-request@tekred.TEK.COM>
Comp.sources.games: Volume 2, Issue 39
Archive-name: dungeon/Part06
[Due to a messup on my part, the first five parts of the
distribution will say "Part n of 7" when unshared. They are
really "Part n of 14". Sorry for the inconvenience. -br]
#! /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 14)."
# Contents: History actors.F dgame.F dmain.F dverb1.F np.F np2.F
# nrooms.F oflags.h speak.F
# Wrapped by billr@tekred on Tue Apr 21 10:24:34 1987
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f History -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"History\"
else
echo shar: Extracting \"History\" \(4401 characters\)
sed "s/^X//" >History <<'END_OF_History'
X History of the Unix f77 Implementation of Dungeon
X =================================================
X
XThis version of dungeon has been modified from the original source
Xso that it will compile and execute on Unix[TM] Systems using the
Xf77 FORTRAN Compiler. The original was written in DEC FORTRAN,
Xtranslated from MDL. See the file "dungeon.doc" for the complete
Xoriginal documentation. See the file "PDP.doc" for notes on the
XUnix/pdp implementation.
X
XI. From the original documentation...
X
XTo: Dungeon Players
XFrom: "The Translator"
XSubj: Game Information
XDate: 8-OCT-80
X
X
XThis is the first (and last) source release of the PDP-11 version of
XDungeon.
X
XPlease note that Dungeon has been superceded by the game ZORK(tm).
XThe following is an extract from the new product announcement for
XZORK in the September, 1980 issue of the RT-11 SIG newsletter:
X
X "'ZORK: The Great Underground Empire - Part I' ...was developed
X by the original authors based on their ZORK (Dungeon) game for
X the PDP-10. It features a greatly improved parser; command
X input and transcript output files; SAVEs to any device and
X file name; and adaptation to different terminal types,
X including a status line on VT100s. Note: this is not the
X FORTRAN version that has been available through DECUS. This
X version has been completely rewritten to run efficiently on
X small machines - up to 10 times as fast as the DECUS version.
X
X ...ZORK runs under RT-ll, HT-ll, or RSTS/E and requires as
X little as 20K words of memory and a single floppy disk drive.
X The game package, consisting of an RX01-format diskette and
X an instruction booklet, is available from Infocom, Inc.,
X P.O. Box 120, Kendall Station, Cambridge, Ma. 02142."
X
XZORK(tm) is a trademark of Infocom, Inc. It is available for several
Xpopular personal computers as well as for the PDP-ll.
X
X
XSUMMARY
X-------
X
X Welcome to Dungeon!
X
X Dungeon is a game of adventure, danger, and low cunning. In it
Xyou will explore some of the most amazing territory ever seen by mortal
Xman. Hardened adventurers have run screaming from the terrors contained
Xwithin.
X
X In Dungeon, the intrepid explorer delves into the forgotten secrets
Xof a lost labyrinth deep in the bowels of the earth, searching for
Xvast treasures long hidden from prying eyes, treasures guarded by
Xfearsome monsters and diabolical traps!
X
X No DECsystem should be without one!
X
X Dungeon was created at the Programming Technology Division of the MIT
XLaboratory for Computer Science by Tim Anderson, Marc Blank, Bruce
XDaniels, and Dave Lebling. It was inspired by the Adventure game of
XCrowther and Woods, and the Dungeons and Dragons game of Gygax
Xand Arneson. The original version was written in MDL (alias MUDDLE).
XThe current version was translated from MDL into FORTRAN IV by
Xa somewhat paranoid DEC engineer who prefers to remain anonymous.
X
X On-line information may be obtained with the commands HELP and INFO.
X
XII. DEC FORTRAN to f77 Conversion (17-nov-81)
X
XThe conversion from DEC FORTRAN to Unix f77 was done by Randy Dietrich,
XLynn Cochran and Sig Peterson. Much hacking was done to get it to fit
Xin the limited address space of a PDP-11/44 (split I/D). See the
Xfile "PDP.doc" for all the gory details. Suffice it to say that by
Xleaving out the debugging package and not linking in the f77 i/o
Xlibrary they managed to get it to run.
X
XIII. PDP to VAX (dec-85)
X
XBased on the work of Randy, Lynn and Sig, Bill Randle folded in the
Xfull save/restore functions and the game debugging package (gdt) into
Xthe pdp version to create a Vax/Unix version. This version also uses
Xf77 i/o, thus eliminating the extra speak and listen processes needed
Xon the pdp.
X
XIV. Cleanup I (11-dec-86)
X
XJohn Gilmore (hoptoad!gnu) cleaned up the source files by moving
Xmost of the common declarations into include files and added
Xcomments from the original (FORTRAN or MDL?) source. His efforts
Xare greatly appreciated.
X
XV. Cleanup II (9-feb-87)
X
XBill Randle (billr@tekred.tek.com) added the pdp dependencies back
Xinto the Vax source files with #ifdefs in order to have just one
Xset of sources. Previously, there were two sets of source: one for
Xthe pdp and one for the Vax. In addition, a shell escape of the
Xform !cmd was added and the wizard can enter the gdt without having
Xto recompile the source. Finally, a man page was generated, based
Xon the dungeon.doc file.
END_OF_History
if test 4401 -ne `wc -c <History`; then
echo shar: \"History\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f actors.F -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"actors.F\"
else
echo shar: Extracting \"actors.F\" \(6949 characters\)
sed "s/^X//" >actors.F <<'END_OF_actors.F'
XC AAPPLI- APPLICABLES FOR ADVENTURERS
XC
XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
XC WRITTEN BY R. M. SUPNIK
XC
XC DECLARATIONS
XC
X LOGICAL FUNCTION AAPPLI(RI)
X IMPLICIT INTEGER (A-Z)
X LOGICAL F,MOVETO
X#include "parser.h"
X#include "gamestate.h"
X#include "rooms.h"
X#include "rflag.h"
X#include "rindex.h"
X#include "xsrch.h"
X#include "objects.h"
X#include "oflags.h"
X#include "oindex.h"
X#include "clock.h"
X#include "advers.h"
X#include "verbs.h"
X#include "flags.h"
XC AAPPLI, PAGE 2
XC
X IF(RI.EQ.0) GO TO 10
XC !IF ZERO, NO APP.
X AAPPLI=.TRUE.
XC !ASSUME WINS.
X GO TO (1000,2000),RI
XC !BRANCH ON ADV.
X CALL BUG(11,RI)
XC
XC COMMON FALSE RETURN.
XC
X10 AAPPLI=.FALSE.
X RETURN
XC
XC A1-- ROBOT. PROCESS MOST COMMANDS GIVEN TO ROBOT.
XC
X1000 IF((PRSA.NE.RAISEW).OR.(PRSO.NE.RCAGE)) GO TO 1200
X CFLAG(CEVSPH)=.FALSE.
XC !ROBOT RAISED CAGE.
X WINNER=PLAYER
XC !RESET FOR PLAYER.
X F=MOVETO(CAGER,WINNER)
XC !MOVE TO NEW ROOM.
X CALL NEWSTA(CAGE,567,CAGER,0,0)
XC !INSTALL CAGE IN ROOM.
X CALL NEWSTA(ROBOT,0,CAGER,0,0)
XC !INSTALL ROBOT IN ROOM.
X AROOM(AROBOT)=CAGER
XC !ALSO MOVE ROBOT/ADV.
X CAGESF=.TRUE.
XC !CAGE SOLVED.
X OFLAG1(ROBOT)=and(OFLAG1(ROBOT),not(NDSCBT))
X OFLAG1(SPHER)=or(OFLAG1(SPHER),TAKEBT)
X RETURN
XC
X1200 IF((PRSA.NE.DRINKW).AND.(PRSA.NE.EATW)) GO TO 1300
X CALL RSPEAK(568)
XC !EAT OR DRINK, JOKE.
X RETURN
XC
X1300 IF(PRSA.NE.READW) GO TO 1400
XC !READ,
X CALL RSPEAK(569)
XC !JOKE.
X RETURN
XC
X1400 IF((PRSA.EQ.WALKW).OR.(PRSA.EQ.TAKEW).OR.(PRSA.EQ.DROPW)
X& .OR.(PRSA.EQ.PUTW).OR.(PRSA.EQ.PUSHW).OR.(PRSA.EQ.THROWW)
X& .OR.(PRSA.EQ.TURNW).OR.(PRSA.EQ.LEAPW)) GO TO 10
X CALL RSPEAK(570)
XC !JOKE.
X RETURN
XC AAPPLI, PAGE 3
XC
XC A2-- MASTER. PROCESS MOST COMMANDS GIVEN TO MASTER.
XC
X2000 IF(and(OFLAG2(QDOOR),OPENBT).NE.0) GO TO 2100
X CALL RSPEAK(783)
XC !NO MASTER YET.
X RETURN
XC
X2100 IF(PRSA.NE.WALKW) GO TO 2200
XC !WALK?
X I=784
XC !ASSUME WONT.
X IF(((HERE.EQ.SCORR).AND.
X& ((PRSO.EQ.XNORTH).OR.(PRSO.EQ.XENTER))).OR.
X& ((HERE.EQ.NCORR).AND.
X& ((PRSO.EQ.XSOUTH).OR.(PRSO.EQ.XENTER))))
X& I=785
X CALL RSPEAK(I)
X RETURN
XC
X2200 IF((PRSA.EQ.TAKEW).OR.(PRSA.EQ.DROPW).OR.(PRSA.EQ.PUTW).OR.
X& (PRSA.EQ.THROWW).OR.(PRSA.EQ.PUSHW).OR.(PRSA.EQ.TURNW).OR.
X& (PRSA.EQ.SPINW).OR.(PRSA.EQ.TRNTOW).OR.(PRSA.EQ.FOLLOW).OR.
X& (PRSA.EQ.STAYW).OR.(PRSA.EQ.OPENW).OR.(PRSA.EQ.CLOSEW).OR.
X& (PRSA.EQ.KILLW)) GO TO 10
X CALL RSPEAK(786)
XC !MASTER CANT DO IT.
X RETURN
XC
X END
XC THIEFD- INTERMOVE THIEF DEMON
XC
XC DECLARATIONS
XC
X SUBROUTINE THIEFD
X IMPLICIT INTEGER (A-Z)
X LOGICAL ONCE,PROB,QHERE,QSTILL,LIT,WINNIN
X#include "gamestate.h"
XC
X#include "debug.h"
X#include "rooms.h"
X#include "rflag.h"
X#include "rindex.h"
X#include "objects.h"
X#include "oflags.h"
X#include "oindex.h"
X#include "villians.h"
X#include "flags.h"
XC
XC FUNCTIONS AND DATA
XC
X QSTILL(R)=(QHERE(STILL,R).OR.(OADV(STILL).EQ.-THIEF))
XC THIEFD, PAGE 2
XC
X#ifdef debug
X DFLAG=and(PRSFLG, 32768).NE.0
X#endif debug
XC !SET UP DETAIL FLAG.
X ONCE=.FALSE.
XC !INIT FLAG.
X1025 RHERE=OROOM(THIEF)
XC !VISIBLE POS.
X IF(RHERE.NE.0) THFPOS=RHERE
XC
X IF(THFPOS.EQ.HERE) GO TO 1100
XC !THIEF IN WIN RM?
X IF(THFPOS.NE.TREAS) GO TO 1400
XC !THIEF NOT IN TREAS?
XC
XC THIEF IS IN TREASURE ROOM, AND WINNER IS NOT.
XC
X#ifdef debug
X IF(DFLAG) PRINT 10
X10 FORMAT(' THIEFD-- IN TREASURE ROOM')
X#endif debug
X IF(RHERE.EQ.0) GO TO 1050
XC !VISIBLE?
X CALL NEWSTA(THIEF,0,0,0,0)
XC !YES, VANISH.
X RHERE=0
X IF(QSTILL(TREAS)) CALL NEWSTA(STILL,0,0,THIEF,0)
X1050 I=ROBADV(-THIEF,THFPOS,0,0)
XC !DROP VALUABLES.
X IF(QHERE(EGG,THFPOS)) OFLAG2(EGG)=or(OFLAG2(EGG),OPENBT)
X GO TO 1700
XC
XC THIEF AND WINNER IN SAME ROOM.
XC
X1100 IF(THFPOS.EQ.TREAS) GO TO 1700
XC !IF TREAS ROOM, NOTHING.
X IF(and(RFLAG(THFPOS),RLIGHT).NE.0) GO TO 1400
X#ifdef debug
X IF(DFLAG) PRINT 20
X20 FORMAT(' THIEFD-- IN ADV ROOM')
X#endif debug
X IF(THFFLG) GO TO 1300
XC !THIEF ANNOUNCED?
X IF((RHERE.NE.0).OR.PROB(70,70)) GO TO 1150
XC !IF INVIS AND 30%.
X IF(OCAN(STILL).NE.THIEF) GO TO 1700
XC !ABORT IF NO STILLETTO.
X CALL NEWSTA(THIEF,583,THFPOS,0,0)
XC !INSERT THIEF INTO ROOM.
X THFFLG=.TRUE.
XC !THIEF IS ANNOUNCED.
X RETURN
XC
X1150 IF((RHERE.EQ.0).OR.(and(OFLAG2(THIEF),FITEBT).EQ.0))
X& GO TO 1200
X IF(WINNIN(THIEF,WINNER)) GO TO 1175
XC !WINNING?
X CALL NEWSTA(THIEF,584,0,0,0)
XC !NO, VANISH THIEF.
X OFLAG2(THIEF)=and(OFLAG2(THIEF), not(FITEBT))
X IF(QSTILL(THFPOS)) CALL NEWSTA(STILL,0,0,THIEF,0)
X RETURN
XC
X1175 IF(PROB(90,90)) GO TO 1700
XC !90% CHANCE TO STAY.
XC
X1200 IF((RHERE.EQ.0).OR.PROB(70,70)) GO TO 1250
XC !IF VISIBLE AND 30%
X CALL NEWSTA(THIEF,585,0,0,0)
XC !VANISH THIEF.
X IF(QSTILL(THFPOS)) CALL NEWSTA(STILL,0,0,THIEF,0)
X RETURN
XC
X1300 IF(RHERE.EQ.0) GO TO 1700
XC !ANNOUNCED. VISIBLE?
X1250 IF(PROB(70,70)) RETURN
XC !70% CHANCE TO DO NOTHING.
X THFFLG=.TRUE.
X NR=ROBRM(THFPOS,100,0,0,-THIEF)+ROBADV(WINNER,0,0,-THIEF)
X I=586
XC !ROBBED EM.
X IF(RHERE.NE.0) I=588
XC !WAS HE VISIBLE?
X IF(NR.NE.0) I=I+1
XC !DID HE GET ANYTHING?
X CALL NEWSTA(THIEF,I,0,0,0)
XC !VANISH THIEF.
X IF(QSTILL(THFPOS))
X& CALL NEWSTA(STILL,0,0,THIEF,0)
X IF((NR.NE.0).AND..NOT.LIT(THFPOS)) CALL RSPEAK(406)
X RHERE=0
X GO TO 1700
XC !ONWARD.
XC
XC NOT IN ADVENTURERS ROOM.
XC
X1400 CALL NEWSTA(THIEF,0,0,0,0)
XC !VANISH.
X RHERE=0
X#ifdef debug
X IF(DFLAG) PRINT 30,THFPOS
X30 FORMAT(' THIEFD-- IN ROOM ',I4)
X#endif debug
X IF(QSTILL(THFPOS))
X& CALL NEWSTA(STILL,0,0,THIEF,0)
X IF(and(RFLAG(THFPOS),RSEEN).EQ.0) GO TO 1700
X I=ROBRM(THFPOS,75,0,0,-THIEF)
XC !ROB ROOM 75%.
X IF((THFPOS.LT.MAZE1).OR.(THFPOS.GT.MAZ15).OR.
X& (HERE.LT.MAZE1).OR.(HERE.GT.MAZ15)) GO TO 1500
X DO 1450 I=1,OLNT
XC !BOTH IN MAZE.
X IF(.NOT.QHERE(I,THFPOS).OR.PROB(60,60).OR.
X& (and(OFLAG1(I),(VISIBT+TAKEBT)).NE.(VISIBT+TAKEBT)))
X& GO TO 1450
X CALL RSPSUB(590,ODESC2(I))
XC !TAKE OBJECT.
X IF(PROB(40,20)) GO TO 1700
X CALL NEWSTA(I,0,0,0,-THIEF)
XC !MOST OF THE TIME.
X OFLAG2(I)=or(OFLAG2(I),TCHBT)
X GO TO 1700
X1450 CONTINUE
X GO TO 1700
XC
X1500 DO 1550 I=1,OLNT
XC !NOT IN MAZE.
X IF(.NOT.QHERE(I,THFPOS).OR.(OTVAL(I).NE.0).OR.PROB(80,60).OR.
X& (and(OFLAG1(I),(VISIBT+TAKEBT)).NE.(VISIBT+TAKEBT)))
X& GO TO 1550
X CALL NEWSTA(I,0,0,0,-THIEF)
X OFLAG2(I)=or(OFLAG2(I),TCHBT)
X GO TO 1700
X1550 CONTINUE
XC
XC NOW MOVE TO NEW ROOM.
XC
X1700 IF(OADV(ROPE).EQ.-THIEF) DOMEF=.FALSE.
X IF(ONCE) GO TO 1800
X ONCE=.NOT.ONCE
X1750 THFPOS=THFPOS-1
XC !NEXT ROOM.
X IF(THFPOS.LE.0) THFPOS=RLNT
X IF(and(RFLAG(THFPOS),(RLAND+RSACRD+REND)).NE.RLAND)
X& GO TO 1750
X THFFLG=.FALSE.
XC !NOT ANNOUNCED.
X GO TO 1025
XC !ONCE MORE.
XC
XC ALL DONE.
XC
X1800 IF(THFPOS.EQ.TREAS) RETURN
XC !IN TREASURE ROOM?
X J=591
XC !NO, DROP STUFF.
X IF(THFPOS.NE.HERE) J=0
X DO 1850 I=1,OLNT
X IF((OADV(I).NE.-THIEF).OR.PROB(70,70).OR.
X& (OTVAL(I).GT.0)) GO TO 1850
X CALL NEWSTA(I,J,THFPOS,0,0)
X J=0
X1850 CONTINUE
X RETURN
XC
X END
END_OF_actors.F
if test 6949 -ne `wc -c <actors.F`; then
echo shar: \"actors.F\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f dgame.F -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"dgame.F\"
else
echo shar: Extracting \"dgame.F\" \(4492 characters\)
sed "s/^X//" >dgame.F <<'END_OF_dgame.F'
XC GAME- MAIN COMMAND LOOP FOR DUNGEON
XC
XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
XC WRITTEN BY R. M. SUPNIK
XC
XC DECLARATIONS
XC
X SUBROUTINE GAME
X IMPLICIT INTEGER (A-Z)
X LOGICAL RMDESC,VAPPLI,RAPPLI,AAPPLI
X LOGICAL F,PARSE,FINDXT,XVEHIC,LIT
X CHARACTER SECHO(4)
X CHARACTER GDTSTR(3)
X#include "parser.h"
X#include "gamestate.h"
X#include "state.h"
X#include "io.h"
X#include "rooms.h"
X#include "rindex.h"
X#include "objects.h"
X#include "oflags.h"
X#include "oindex.h"
X#include "advers.h"
X#include "verbs.h"
X#include "flags.h"
XC
XC FUNCTIONS AND DATA
XC
X DATA SECHO/'E','C','H','O'/
X DATA GDTSTR/'G','D','T'/
XC GAME, PAGE 2
XC
XC START UP, DESCRIBE CURRENT LOCATION.
XC
X CALL RSPEAK(1)
XC !WELCOME ABOARD.
X F=RMDESC(3)
XC !START GAME.
XC
XC NOW LOOP, READING AND EXECUTING COMMANDS.
XC
X100 WINNER=PLAYER
XC !PLAYER MOVING.
X TELFLG=.FALSE.
XC !ASSUME NOTHING TOLD.
X IF(PRSCON.LE.1) CALL RDLINE(INBUF,INLNT,1)
XC
X DO 150 I=1,3
XC !CALL ON GDT?
X IF(INBUF(I+PRSCON-1).NE.GDTSTR(I)) GO TO 200
X150 CONTINUE
X CALL GDT
XC !YES, INVOKE.
X GO TO 100
XC !ONWARD.
XC
X200 MOVES=MOVES+1
X PRSWON=PARSE(INBUF,INLNT,.TRUE.)
X IF(.NOT.PRSWON) GO TO 400
XC !PARSE LOSES?
X IF(XVEHIC(1)) GO TO 400
XC !VEHICLE HANDLE?
XC
X IF(PRSA.EQ.TELLW) GO TO 2000
XC !TELL?
X300 IF((PRSO.EQ.VALUA).OR.(PRSO.EQ.EVERY)) GO TO 900
X IF(.NOT.VAPPLI(PRSA)) GO TO 400
XC !VERB OK?
X350 IF(.NOT.ECHOF.AND.(HERE.EQ.ECHOR)) GO TO 1000
X F=RAPPLI(RACTIO(HERE))
XC
X400 CALL XENDMV(TELFLG)
XC !DO END OF MOVE.
X IF(.NOT.LIT(HERE)) PRSCON=1
X GO TO 100
XC
X900 CALL VALUAC(VALUA)
X GO TO 350
XC GAME, PAGE 3
XC
XC SPECIAL CASE-- ECHO ROOM.
XC IF INPUT IS NOT 'ECHO' OR A DIRECTION, JUST ECHO.
XC
X1000 CALL RDLINE(INBUF,INLNT,0)
X MOVES=MOVES+1
XC !CHARGE FOR MOVES.
X DO 1100 I=1,4
XC !INPUT = ECHO?
X IF(INBUF(I).NE.SECHO(I)) GO TO 1300
X1100 CONTINUE
XC
XC Note: the following DO loop was changed from DO 1200 I=5,78
XC The change was necessary because the RDLINE function was changed,
XC and no longer provides a 78 character buffer padded with blanks.
XC
X DO 1200 I=5,INLNT
X IF(INBUF(I).NE.' ') GO TO 1300
X1200 CONTINUE
XC
X CALL RSPEAK(571)
XC !KILL THE ECHO.
X ECHOF=.TRUE.
X OFLAG2(BAR)=and(OFLAG2(BAR), not(SCRDBT))
X PRSWON=.TRUE.
XC !FAKE OUT PARSER.
X PRSCON=1
XC !FORCE NEW INPUT.
X GO TO 400
XC
X1300 PRSWON=PARSE(INBUF,INLNT,.FALSE.)
X IF(.NOT.PRSWON .OR. (PRSA.NE.WALKW))
X& GO TO 1400
X IF(FINDXT(PRSO,HERE)) GO TO 300
XC !VALID EXIT?
XC
X#ifdef PDP
X1400 call outstr(INLINE, INLNT)
X#else
X1400 WRITE(OUTCH,1410) (INBUF(J),J=1,INLNT)
X1410 FORMAT(1X,78A1)
X#endif PDP
X TELFLG=.TRUE.
XC !INDICATE OUTPUT.
X GO TO 1000
XC !MORE ECHO ROOM.
XC GAME, PAGE 4
XC
XC SPECIAL CASE-- TELL <ACTOR>, NEW COMMAND
XC NOTE THAT WE CANNOT BE IN THE ECHO ROOM.
XC
X2000 IF(and(OFLAG2(PRSO),ACTRBT).NE.0) GO TO 2100
X CALL RSPEAK(602)
XC !CANT DO IT.
X GO TO 350
XC !VAPPLI SUCCEEDS.
XC
X2100 WINNER=OACTOR(PRSO)
XC !NEW PLAYER.
X HERE=AROOM(WINNER)
XC !NEW LOCATION.
X IF(PRSCON.LE.1) GO TO 2700
XC !ANY INPUT?
X IF(PARSE(INBUF,INLNT,.TRUE.)) GO TO 2150
X2700 I=341
XC !FAILS.
X IF(TELFLG) I=604
XC !GIVE RESPONSE.
X CALL RSPEAK(I)
X2600 WINNER=PLAYER
XC !RESTORE STATE.
X HERE=AROOM(WINNER)
X GO TO 350
XC
X2150 IF(AAPPLI(AACTIO(WINNER))) GO TO 2400
XC !ACTOR HANDLE?
X IF(XVEHIC(1)) GO TO 2400
XC !VEHICLE HANDLE?
X IF((PRSO.EQ.VALUA).OR.(PRSO.EQ.EVERY)) GO TO 2900
X IF(.NOT.VAPPLI(PRSA)) GO TO 2400
XC !VERB HANDLE?
X2350 F=RAPPLI(RACTIO(HERE))
XC
X2400 CALL XENDMV(TELFLG)
XC !DO END OF MOVE.
X GO TO 2600
XC !DONE.
XC
X2900 CALL VALUAC(VALUA)
XC !ALL OR VALUABLES.
X GO TO 350
XC
X END
XC XENDMV- EXECUTE END OF MOVE FUNCTIONS.
XC
XC DECLARATIONS
XC
X SUBROUTINE XENDMV(FLAG)
X IMPLICIT INTEGER(A-Z)
X LOGICAL F,CLOCKD,FLAG,XVEHIC
X#include "parser.h"
X#include "villians.h"
XC
X IF(.NOT.FLAG) CALL RSPEAK(341)
XC !DEFAULT REMARK.
X IF(THFACT) CALL THIEFD
XC !THIEF DEMON.
X IF(PRSWON) CALL FIGHTD
XC !FIGHT DEMON.
X IF(SWDACT) CALL SWORDD
XC !SWORD DEMON.
X IF(PRSWON) F=CLOCKD(X)
XC !CLOCK DEMON.
X IF(PRSWON) F=XVEHIC(2)
XC !VEHICLE READOUT.
X RETURN
X END
XC XVEHIC- EXECUTE VEHICLE FUNCTION
XC
XC DECLARATIONS
XC
X LOGICAL FUNCTION XVEHIC(N)
X IMPLICIT INTEGER(A-Z)
X LOGICAL OAPPLI
X#include "gamestate.h"
X#include "objects.h"
X#include "advers.h"
XC
X XVEHIC=.FALSE.
XC !ASSUME LOSES.
X AV=AVEHIC(WINNER)
XC !GET VEHICLE.
X IF(AV.NE.0) XVEHIC=OAPPLI(OACTIO(AV),N)
X RETURN
X END
END_OF_dgame.F
if test 4492 -ne `wc -c <dgame.F`; then
echo shar: \"dgame.F\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f dmain.F -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"dmain.F\"
else
echo shar: Extracting \"dmain.F\" \(6633 characters\)
sed "s/^X//" >dmain.F <<'END_OF_dmain.F'
XC DUNGEON-- MAIN PROGRAM
XC
XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
XC WRITTEN BY R. M. SUPNIK
XC
X PROGRAM DUNGEO
XC
XC DECLARATIONS
XC
X IMPLICIT INTEGER (A-Z)
X LOGICAL INIT
X#include "parser.h"
X#include "gamestate.h"
X#include "state.h"
X#include "screen.h"
X#include "puzzle.h"
XC
XC MISCELLANEOUS VARIABLES
XC
X CHARACTER VEDIT
X COMMON /STAR/ MBASE,STRBIT
X COMMON /VERS/ VMAJ,VMIN,VEDIT
X COMMON /BATS/ BATDRP(9)
X#include "io.h"
X#include "debug.h"
X COMMON /HYPER/ HFACTR
X#include "rooms.h"
X#include "rflag.h"
X#include "rindex.h"
X#include "exits.h"
X#include "curxt.h"
X#include "xpars.h"
X#include "xsrch.h"
X#include "objects.h"
X#include "oflags.h"
X#include "oindex.h"
X#include "clock.h"
X
X#include "villians.h"
X#include "advers.h"
X#include "verbs.h"
X#include "flags.h"
XC DUNGEON, PAGE 2
XC
XC DATA STATEMENTS FOR CONSTANT ARRAYS
XC
X DATA VMAJ/2/,VMIN/6/,VEDIT/'A'/
XC
X DATA SDIR/o'40000'/,SIND/o'20000'/,SSTD/o'10000'/,
X& SFLIP/o'4000'/,SDRIV/o'2000'/,SVMASK/o'777'/
X DATA VABIT/o'40000'/,VRBIT/o'20000'/,VTBIT/o'10000'/,
X& VCBIT/o'4000'/,VEBIT/o'2000'/,VFBIT/o'1000'/,
X& VPMASK/o'777'/
XC
X DATA BATDRP/66,67,68,69,70,71,72,65,73/
XC
X DATA SCOLDR/o'2000',153,o'12000',154,o'6000',152,o'16000',151/
X DATA SCOLWL/151,207,o'6000',152,208,o'16000',
X& 153,206,o'12000',154,205,o'2000'/
XC
X DATA HFACTR/500/
XC
X DATA CPDR/o'2000',-8,o'4000',-7,o'6000',1,o'10000',9,
X& o'12000',8,o'14000',7,o'16000',-1,o'20000',-9/
X DATA CPWL/205,-8,206,8,207,1,208,-1/
X DATA CPVEC/1,1,1,1,1,1,1,1,
X& 1,0,-1,0,0,-1,0,1,
X& 1,-1,0,1,0,-2,0,1,
X& 1,0,0,0,0,1,0,1,
X& 1,-3,0,0,-1,-1,0,1,
X& 1,0,0,-1,0,0,0,1,
X& 1,1,1,0,0,0,1,1,
X& 1,1,1,1,1,1,1,1/
XC
X DATA CEVCUR/1/,CEVMNT/2/,CEVLNT/3/,CEVMAT/4/,
X& CEVCND/5/,CEVBAL/6/,CEVBRN/7/,CEVFUS/8/,
X& CEVLED/9/,CEVSAF/10/,CEVVLG/11/,CEVGNO/12/,
X& CEVBUC/13/,CEVSPH/14/,CEVEGH/15/,
X& CEVFOR/16/,CEVSCL/17/,CEVZGI/18/,CEVZGO/19/,
X& CEVSTE/20/,CEVMRS/21/,CEVPIN/22/,CEVINQ/23/,
X& CEVFOL/24/
XC
X DATA XRMASK/o'377'/,XDMASK/o'76000'/,XFMASK/3/
X DATA XFSHFT/256/,XASHFT/256/
X DATA XNORM/1/,XNO/2/,XCOND/3/,XDOOR/4/
X DATA XELNT/1,2,3,3/,XLFLAG/o'100000'/
X DATA XMIN/o'2000'/,XMAX/o'40000'/,XUP/o'22000'/,XDOWN/o'24000'/
X DATA XNORTH/o'2000'/,XSOUTH/o'12000'/,XENTER/o'32000'/,
X& XEXIT/o'34000'/
X DATA XEAST/o'6000'/,XWEST/o'16000'/
XC
X DATA PLAYER/1/,AROBOT/2/,AMASTR/3/
X DATA ASTAG/o'100000'/
XC
X DATA RSEEN/o'100000'/,RLIGHT/o'40000'/,RLAND/o'20000'/
X DATA RWATER/o'10000'/,RAIR/o'4000'/,RSACRD/o'2000'/,
X& RFILL/o'1000'/
X DATA RMUNG/o'400'/,RBUCK/o'200'/,RHOUSE/o'100'/,
X& RNWALL/o'40'/,REND/o'20'/
XC
X DATA WHOUS/2/,LROOM/8/,CELLA/9/
X DATA MTROL/10/,MAZE1/11/
X DATA MGRAT/25/,MAZ15/30/
X DATA FORE1/31/,FORE3/33/,CLEAR/36/,RESER/40/
X DATA STREA/42/,EGYPT/44/,ECHOR/49/
X DATA TSHAF/61/
X DATA BSHAF/76/,MMACH/77/,DOME/79/,MTORC/80/
X DATA CAROU/83/
X DATA RIDDL/91/,LLD2/94/,TEMP1/96/,TEMP2/97/,MAINT/100/
X DATA MCYCL/101/,BLROO/102/,TREAS/103/,RIVR1/107/,RIVR2/108/
X DATA RIVR3/109/
X DATA RIVR4/112/,RIVR5/113/,FCHMP/114/,MBARR/119/,FALLS/120/
X DATA MRAIN/121/,POG/122/,VLBOT/126/,VAIR1/127/,VAIR2/128/
X DATA VAIR3/129/,VAIR4/130/
X DATA LEDG2/131/,LEDG3/132/,LEDG4/133/,MSAFE/135/,CAGER/140/
X DATA CAGED/141/,TWELL/142/,BWELL/143/,ALICE/144/,ALISM/145/
X DATA ALITR/146/,MTREE/147/,BKENT/148/
X DATA BKVW/151/,BKTWI/153/,BKVAU/154/,BKBOX/155/
X DATA CRYPT/157/,TSTRS/158/,MRANT/159/
X DATA MREYE/160/,MRA/161/,MRB/162/,MRC/163/,MRG/164/
X DATA MRD/165/,FDOOR/166/,MRAE/167/
X DATA MRCE/171/,MRCW/172/,MRGE/173/,MRGW/174/,MRDW/176/
X DATA INMIR/177/,SCORR/179/
X DATA NCORR/182/,PARAP/183/,CELL/184/,PCELL/185/,NCELL/186/
X DATA CPANT/188/,CPOUT/189/
X DATA CPUZZ/190/
XC
X DATA CINTW/1/,DEADXW/2/,FRSTQW/3/,INXW/4/
X DATA OUTXW/5/,WALKIW/6/,FIGHTW/7/,FOOW/8/
XC
X DATA READW/100/,MELTW/101/
X DATA INFLAW/102/,DEFLAW/103/,ALARMW/104/,EXORCW/105/
X DATA PLUGW/106/,KICKW/107/,WAVEW/108/,RAISEW/109/,LOWERW/110/
X DATA RUBW/111/,PUSHW/112/,UNTIEW/113/,TIEW/114/,TIEUPW/115/
X DATA TURNW/116/,BREATW/117/,KNOCKW/118/,LOOKW/119/
X DATA EXAMIW/120/,SHAKEW/121/,MOVEW/122/,TRNONW/123/,TRNOFW/124/
X DATA OPENW/125/,CLOSEW/126/,FINDW/127/,WAITW/128/,SPINW/129/
X DATA BOARDW/130/,UNBOAW/131/,TAKEW/132/,INVENW/133/
X DATA FILLW/134/,EATW/135/,DRINKW/136/,BURNW/137/
X DATA MUNGW/138/,KILLW/139/,ATTACW/141/
X DATA SWINGW/140/,WALKW/142/,TELLW/143/,PUTW/144/
X DATA DROPW/145/,GIVEW/146/,POURW/147/,THROWW/148/
XC
X DATA DIGW/89/,LEAPW/91/,STAYW/73/,FOLLOW/85/
X DATA HELLOW/151/,LOOKIW/152/,LOOKUW/153/,PUMPW/154/
X DATA WINDW/155/,CLMBW/156/,CLMBUW/157/,CLMBDW/158/,TRNTOW/159/
XC
X DATA VISIBT/o'100000'/,READBT/o'40000'/,TAKEBT/o'20000'/,
X& DOORBT/o'10000'/,TRANBT/o'4000'/,FOODBT/o'2000'/,
X& NDSCBT/o'1000'/,DRNKBT/o'400'/, CONTBT/o'200'/,
X& LITEBT/o'100'/,VICTBT/o'40'/,BURNBT/o'20'/,
X& FLAMBT/o'10'/,TOOLBT/o'4'/,TURNBT/o'2'/,ONBT/o'1'/
XC
X DATA FINDBT/o'100000'/,SLEPBT/o'40000'/,SCRDBT/o'20000'/,
X& TIEBT/o'10000'/, CLMBBT/o'4000'/,ACTRBT/o'2000'/,
X& WEAPBT/o'1000'/,FITEBT/o'400'/, VILLBT/o'200'/,
X& STAGBT/o'100'/,TRYBT/o'40'/,NOCHBT/o'20'/,
X& OPENBT/o'10'/,TCHBT/o'4'/,VEHBT/o'2'/,SCHBT/o'1'/
XC
X DATA GARLI/2/,FOOD/3/,GUNK/4/,COAL/5/,MACHI/7/,DIAMO/8/
X DATA TCASE/9/,BOTTL/10/
X DATA WATER/11/,ROPE/12/,KNIFE/13/,SWORD/14/,LAMP/15/,BLAMP/16/
X DATA RUG/17/,LEAVE/18/,TROLL/19/,AXE/20/
X DATA RKNIF/21/,KEYS/23/,BAR/26/,ICE/30/
X DATA COFFI/33/,TORCH/34/,TBASK/35/,FBASK/36/,IRBOX/39/
X DATA GHOST/42/,TRUNK/45/,BELL/46/,BOOK/47/,CANDL/48/
X DATA MATCH/51/,TUBE/54/,PUTTY/55/,WRENC/56/,SCREW/57/
X DATA CYCLO/58/,CHALI/59/
X DATA THIEF/61/,STILL/62/,WINDO/63/,GRATE/65/,DOOR/66/
X DATA HPOLE/71/,RBUTT/79/,LEAK/78/,RAILI/75/
X DATA POT/85/,STATU/86/,IBOAT/87/,DBOAT/88/,PUMP/89/,RBOAT/90/
X DATA STICK/92/,BUOY/94/,SHOVE/96/,GUANO/97/,BALLO/98/,RECEP/99/
X DATA BROPE/101/,HOOK1/102/,HOOK2/103/,SAFE/105/,SSLOT/107/
X DATA BRICK/109/,FUSE/110/
X DATA GNOME/111/,BLABE/112/,DBALL/113/,TOMB/119/
X DATA LCASE/123/,CAGE/124/,RCAGE/125/,SPHER/126/,SQBUT/127/
X DATA FLASK/132/,POOL/133/,SAFFR/134/,BUCKE/137/,ORICE/139/
X DATA ECAKE/138/,RDICE/140/
X DATA BLICE/141/,ROBOT/142/,FTREE/145/,BILLS/148/,PORTR/149/
X DATA SCOL/151/,ZGNOM/152/,EGG/154/,BEGG/155/,BAUBL/156/
X DATA CANAR/157/,BCANA/158/,YLWAL/159/
X DATA RDWAL/161/,PINDR/164/
X DATA RBEAM/171/,ODOOR/172/,QDOOR/173/,CDOOR/175/
X DATA NUM1/178/
X DATA NUM8/185/,WARNI/186/,CSLIT/187/,GCARD/188/,STLDR/189/
X DATA ITOBJ/192/,OPLAY/193/,EVERY/194/
X DATA VALUA/195/,SAILO/196/,TEETH/197/,WALL/198/
X DATA HANDS/200/,LUNGS/201/,AVIAT/202/
X DATA WNORT/205/,GWATE/209/,MASTER/215/
XC DUNGEON, PAGE 3
XC
XC 1) INITIALIZE DATA STRUCTURES
XC 2) PLAY GAME
XC
X IF(INIT(X)) CALL GAME
XC !IF INIT, PLAY GAME.
X CALL EXIT
XC !DONE
X END
END_OF_dmain.F
if test 6633 -ne `wc -c <dmain.F`; then
echo shar: \"dmain.F\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f dverb1.F -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"dverb1.F\"
else
echo shar: Extracting \"dverb1.F\" \(6815 characters\)
sed "s/^X//" >dverb1.F <<'END_OF_dverb1.F'
XC TAKE-- BASIC TAKE SEQUENCE
XC
XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
XC WRITTEN BY R. M. SUPNIK
XC
XC TAKE AN OBJECT (FOR VERBS TAKE, PUT, DROP, READ, ETC.)
XC
X LOGICAL FUNCTION TAKE(FLG)
XC
XC DECLARATIONS
XC
X IMPLICIT INTEGER (A-Z)
X LOGICAL FLG,OBJACT,OAPPLI,QOPEN,QHERE
X#include "parser.h"
X#include "gamestate.h"
X#include "state.h"
X COMMON /STAR/ MBASE,STRBIT
X#include "objects.h"
X#include "oflags.h"
XC
X#include "advers.h"
XC
XC FUNCTIONS AND DATA
XC
X QOPEN(O)=(and(OFLAG2(O),OPENBT).NE.0)
XC TAKE, PAGE 2
XC
X TAKE=.FALSE.
XC !ASSUME LOSES.
X OA=OACTIO(PRSO)
XC !GET OBJECT ACTION.
X IF(PRSO.LE.STRBIT) GO TO 100
XC !STAR?
X TAKE=OBJACT(X)
XC !YES, LET IT HANDLE.
X RETURN
XC
X100 X=OCAN(PRSO)
XC !INSIDE?
X IF(PRSO.NE.AVEHIC(WINNER)) GO TO 400
XC !HIS VEHICLE?
X CALL RSPEAK(672)
XC !DUMMY.
X RETURN
XC
X400 IF(and(OFLAG1(PRSO),TAKEBT).NE.0) GO TO 500
X IF(.NOT.OAPPLI(OA,0)) CALL RSPEAK(552+RND(5))
X RETURN
XC
XC OBJECT IS TAKEABLE AND IN POSITION TO BE TAKEN.
XC
X500 IF((X.NE.0).OR. QHERE(PRSO,HERE)) GO TO 600
X IF(OADV(PRSO).EQ.WINNER) CALL RSPEAK(557)
XC !ALREADY GOT IT?
X RETURN
XC
X600 IF(((X.NE.0).AND.(OADV(X).EQ.WINNER)).OR.
X& ((WEIGHT(0,PRSO,WINNER)+OSIZE(PRSO)).LE.MXLOAD))
X& GO TO 700
X CALL RSPEAK(558)
XC !TOO MUCH WEIGHT.
X RETURN
XC
X700 TAKE=.TRUE.
XC !AT LAST.
X IF(OAPPLI(OA,0)) RETURN
XC !DID IT HANDLE?
X CALL NEWSTA(PRSO,0,0,0,WINNER)
XC !TAKE OBJECT FOR WINNER.
X OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
X CALL SCRUPD(OFVAL(PRSO))
XC !UPDATE SCORE.
X OFVAL(PRSO)=0
XC !CANT BE SCORED AGAIN.
X IF(FLG) CALL RSPEAK(559)
XC !TELL TAKEN.
X RETURN
XC
X END
XC DROP- DROP VERB PROCESSOR
XC
XC DECLARATIONS
XC
X LOGICAL FUNCTION DROP(Z)
X IMPLICIT INTEGER (A-Z)
X LOGICAL F,PUT,OBJACT
X#include "parser.h"
X#include "gamestate.h"
XC
XC ROOMS
X#include "rindex.h"
X#include "objects.h"
X#include "oflags.h"
XC
X#include "advers.h"
X#include "verbs.h"
XC DROP, PAGE 2
XC
X DROP=.TRUE.
XC !ASSUME WINS.
X X=OCAN(PRSO)
XC !GET CONTAINER.
X IF(X.EQ.0) GO TO 200
XC !IS IT INSIDE?
X IF(OADV(X).NE.WINNER) GO TO 1000
XC !IS HE CARRYING CON?
X IF(and(OFLAG2(X),OPENBT).NE.0) GO TO 300
X CALL RSPSUB(525,ODESC2(X))
XC !CANT REACH.
X RETURN
XC
X200 IF(OADV(PRSO).NE.WINNER) GO TO 1000
XC !IS HE CARRYING OBJ?
X300 IF(AVEHIC(WINNER).EQ.0) GO TO 400
XC !IS HE IN VEHICLE?
X PRSI=AVEHIC(WINNER)
XC !YES,
X F=PUT(.TRUE.)
XC !DROP INTO VEHICLE.
X PRSI=0
XC !DISARM PARSER.
X RETURN
XC !DONE.
XC
X400 CALL NEWSTA(PRSO,0,HERE,0,0)
XC !DROP INTO ROOM.
X IF(HERE.EQ.MTREE) CALL NEWSTA(PRSO,0,FORE3,0,0)
X CALL SCRUPD(OFVAL(PRSO))
XC !SCORE OBJECT.
X OFVAL(PRSO)=0
XC !CANT BE SCORED AGAIN.
X OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
XC
X IF(OBJACT(X)) RETURN
XC !DID IT HANDLE?
X I=0
XC !ASSUME NOTHING TO SAY.
X IF(PRSA.EQ.DROPW) I=528
X IF(PRSA.EQ.THROWW) I=529
X IF((I.NE.0).AND.(HERE.EQ.MTREE)) I=659
X CALL RSPSUB(I,ODESC2(PRSO))
X RETURN
XC
X1000 CALL RSPEAK(527)
XC !DONT HAVE IT.
X RETURN
XC
X END
XC PUT- PUT VERB PROCESSOR
XC
XC DECLARATIONS
XC
X LOGICAL FUNCTION PUT(FLG)
X IMPLICIT INTEGER (A-Z)
X LOGICAL TAKE,QOPEN,QHERE,OBJACT,FLG
X#include "parser.h"
X#include "gamestate.h"
XC
XC MISCELLANEOUS VARIABLES
XC
X COMMON /STAR/ MBASE,STRBIT
X#include "objects.h"
X#include "oflags.h"
X#include "advers.h"
X#include "verbs.h"
XC
XC FUNCTIONS AND DATA
XC
X QOPEN(R)=((and(OFLAG2(R),OPENBT)).NE.0)
XC PUT, PAGE 2
XC
X PUT=.FALSE.
X IF((PRSO.LE.STRBIT).AND.(PRSI.LE.STRBIT)) GO TO 200
X IF(.NOT.OBJACT(X)) CALL RSPEAK(560)
XC !STAR
X PUT=.TRUE.
X RETURN
XC
X200 IF((QOPEN(PRSI))
X& .OR.(and(OFLAG1(PRSI),(DOORBT+CONTBT)).NE.0)
X& .OR.(and(OFLAG2(PRSI),VEHBT).NE.0)) GO TO 300
X CALL RSPEAK(561)
XC !CANT PUT IN THAT.
X RETURN
XC
X300 IF(QOPEN(PRSI)) GO TO 400
XC !IS IT OPEN?
X CALL RSPEAK(562)
XC !NO, JOKE
X RETURN
XC
X400 IF(PRSO.NE.PRSI) GO TO 500
XC !INTO ITSELF?
X CALL RSPEAK(563)
XC !YES, JOKE.
X RETURN
XC
X500 IF(OCAN(PRSO).NE.PRSI) GO TO 600
XC !ALREADY INSIDE.
X CALL RSPSB2(564,ODESC2(PRSO),ODESC2(PRSI))
X PUT=.TRUE.
X RETURN
XC
X600 IF((WEIGHT(0,PRSO,0)+WEIGHT(0,PRSI,0)+OSIZE(PRSO))
X& .LE.OCAPAC(PRSI)) GO TO 700
X CALL RSPEAK(565)
XC !THEN CANT DO IT.
X RETURN
XC
XC NOW SEE IF OBJECT (OR ITS CONTAINER) IS IN ROOM
XC
X700 J=PRSO
XC !START SEARCH.
X725 IF(QHERE(J,HERE)) GO TO 750
XC !IS IT HERE?
X J=OCAN(J)
X IF(J.NE.0) GO TO 725
XC !MORE TO DO?
X GO TO 800
XC !NO, SCH FAILS.
XC
X750 SVO=PRSO
XC !SAVE PARSER.
X SVI=PRSI
X PRSA=TAKEW
X PRSI=0
X IF(.NOT.TAKE(.FALSE.)) RETURN
XC !TAKE OBJECT.
X PRSA=PUTW
X PRSO=SVO
X PRSI=SVI
X GO TO 1000
XC
XC NOW SEE IF OBJECT IS ON PERSON.
XC
X800 IF(OCAN(PRSO).EQ.0) GO TO 1000
XC !INSIDE?
X IF(QOPEN(OCAN(PRSO))) GO TO 900
XC !OPEN?
X CALL RSPSUB(566,ODESC2(PRSO))
XC !LOSE.
X RETURN
XC
X900 CALL SCRUPD(OFVAL(PRSO))
XC !SCORE OBJECT.
X OFVAL(PRSO)=0
X OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
X CALL NEWSTA(PRSO,0,0,0,WINNER)
XC !TEMPORARILY ON WINNER.
XC
X1000 IF(OBJACT(X)) RETURN
XC !NO, GIVE OBJECT A SHOT.
X CALL NEWSTA(PRSO,2,0,PRSI,0)
XC !CONTAINED INSIDE.
X PUT=.TRUE.
X RETURN
XC
X END
XC VALUAC- HANDLES VALUABLES/EVERYTHING
XC
XC DECLARATIONS
XC
X SUBROUTINE VALUAC(V)
X IMPLICIT INTEGER (A-Z)
X LOGICAL LIT,F,F1,TAKE,PUT,DROP,NOTVAL,QHERE
X#include "parser.h"
X#include "gamestate.h"
X#include "objects.h"
X#include "oflags.h"
X#include "verbs.h"
XC
XC FUNCTIONS AND DATA
XC
X NOTVAL(R)=(SAVEP.EQ.V).AND.(OTVAL(R).LE.0)
XC VALUAC, PAGE 2
XC
X F=.TRUE.
XC !ASSUME NO ACTIONS.
X I=579
XC !ASSUME NOT LIT.
X IF(.NOT.LIT(HERE)) GO TO 4000
XC !IF NOT LIT, PUNT.
X I=677
XC !ASSUME WRONG VERB.
X SAVEP=PRSO
XC !SAVE PRSO.
X SAVEH=HERE
XC !SAVE HERE.
XC
X100 IF(PRSA.NE.TAKEW) GO TO 1000
XC !TAKE EVERY/VALUA?
X DO 500 PRSO=1,OLNT
XC !LOOP THRU OBJECTS.
X IF(.NOT.QHERE(PRSO,HERE).OR.
X& (and(OFLAG1(PRSO),VISIBT).EQ.0).OR.
X& (and(OFLAG2(PRSO),ACTRBT).NE.0).OR.
X& NOTVAL(PRSO)) GO TO 500
X IF((and(OFLAG1(PRSO),TAKEBT).EQ.0).AND.
X& (and(OFLAG2(PRSO),TRYBT).EQ.0)) GO TO 500
X F=.FALSE.
X CALL RSPSUB(580,ODESC2(PRSO))
X F1=TAKE(.TRUE.)
X IF(SAVEH.NE.HERE) RETURN
X500 CONTINUE
X GO TO 3000
XC
X1000 IF(PRSA.NE.DROPW) GO TO 2000
XC !DROP EVERY/VALUA?
X DO 1500 PRSO=1,OLNT
X IF((OADV(PRSO).NE.WINNER).OR.NOTVAL(PRSO))
X& GO TO 1500
X F=.FALSE.
X CALL RSPSUB(580,ODESC2(PRSO))
X F1=DROP(.TRUE.)
X IF(SAVEH.NE.HERE) RETURN
X1500 CONTINUE
X GO TO 3000
XC
X2000 IF(PRSA.NE.PUTW) GO TO 3000
XC !PUT EVERY/VALUA?
X DO 2500 PRSO=1,OLNT
XC !LOOP THRU OBJECTS.
X IF((OADV(PRSO).NE.WINNER)
X& .OR.(PRSO.EQ.PRSI).OR.NOTVAL(PRSO).OR.
X& (and(OFLAG1(PRSO),VISIBT).EQ.0)) GO TO 2500
X F=.FALSE.
X CALL RSPSUB(580,ODESC2(PRSO))
X F1=PUT(.TRUE.)
X IF(SAVEH.NE.HERE) RETURN
X2500 CONTINUE
XC
X3000 I=581
X IF(SAVEP.EQ.V) I=582
XC !CHOOSE MESSAGE.
X4000 IF(F) CALL RSPEAK(I)
XC !IF NOTHING, REPORT.
X RETURN
X END
END_OF_dverb1.F
if test 6815 -ne `wc -c <dverb1.F`; then
echo shar: \"dverb1.F\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f np.F -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"np.F\"
else
echo shar: Extracting \"np.F\" \(4769 characters\)
sed "s/^X//" >np.F <<'END_OF_np.F'
XC RDLINE- READ INPUT LINE
XC
XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
XC WRITTEN BY R. M. SUPNIK
XC
XC DECLARATIONS
XC
X SUBROUTINE RDLINE(BUFFER,LENGTH,WHO)
X IMPLICIT INTEGER(A-Z)
X CHARACTER BUFFER(78)
X#ifndef PDP
X character*78 sysbuf
X#endif
X#include "parser.h"
X#include "io.h"
X
X#ifdef PDP
X5 if (WHO .eq. 1) call prompt
XC read a line of input
X90 call rdlin(BUFFER,LENGTH,WHO)
X#else
X5 GO TO (90,10),WHO+1
XC !SEE WHO TO PROMPT FOR.
X10 WRITE(OUTCH,50)
XC !PROMPT FOR GAME.
X50 FORMAT(' >',$)
X
X90 READ(INPCH,100) BUFFER
X100 FORMAT(78A1)
X
X DO 200 LENGTH=78,1,-1
X IF(BUFFER(LENGTH).NE.' ') GO TO 250
X200 CONTINUE
X GO TO 5
XC !TRY AGAIN.
X
XC
XC check for shell escape here before things are
XC converted to upper case
XC
X250 if (buffer(1) .ne. '!') go to 300
X do 275 j=2,length
X sysbuf(j-1:j-1) = buffer(j)
X275 continue
X sysbuf(j:j) = char(0)
X call system(sysbuf)
X go to 5
X
XC CONVERT TO UPPER CASE
X300 DO 400 I=1,LENGTH
X IF(and((BUFFER(I).GE.'a'),(BUFFER(I).LE.'z')))
X& BUFFER(I)=char(ichar(BUFFER(I))-32)
X400 CONTINUE
X#endif PDP
X
X if(LENGTH.EQ.0) GO TO 5
X PRSCON=1
XC !RESTART LEX SCAN.
X RETURN
X END
XC PARSE- TOP LEVEL PARSE ROUTINE
XC
XC DECLARATIONS
XC
XC THIS ROUTINE DETAILS ON BIT 0 OF PRSFLG
XC
X LOGICAL FUNCTION PARSE(INBUF,INLNT,VBFLAG)
X IMPLICIT INTEGER(A-Z)
X CHARACTER INBUF(78)
X LOGICAL LEX,SYNMCH,VBFLAG
X INTEGER OUTBUF(40)
X#include "debug.h"
X#include "parser.h"
X#include "xsrch.h"
XC
X#ifdef debug
X DFLAG=and(PRSFLG,1).NE.0
X#endif
X PARSE=.FALSE.
XC !ASSUME FAILS.
X PRSA=0
XC !ZERO OUTPUTS.
X PRSI=0
X PRSO=0
XC
X#ifdef PDP
XC LEX recoded in C for pdp version (see lex.c)
X if(.not. lex(INBUF,INLNT,OUTBUF,OUTLNT,VBFLAG,PRSCON)) goto 100
X#else
X IF(.NOT.LEX(INBUF,INLNT,OUTBUF,OUTLNT,VBFLAG)) GO TO 100
X#endif
X IF(SPARSE(OUTBUF,OUTLNT,VBFLAG)) 100,200,300
XC !DO SYN SCAN.
XC
XC PARSE REQUIRES VALIDATION
XC
X200 IF(.NOT.VBFLAG) GO TO 350
XC !ECHO MODE, FORCE FAIL.
X IF(.NOT.SYNMCH(X)) GO TO 100
XC !DO SYN MATCH.
X IF(and((PRSO.GT.0),(PRSO.LT.XMIN))) LASTIT=PRSO
XC
XC SUCCESSFUL PARSE OR SUCCESSFUL VALIDATION
XC
X300 PARSE=.TRUE.
X350 CALL ORPHAN(0,0,0,0,0)
XC !CLEAR ORPHANS.
X#ifdef debug
X if(dflag) write(0,*) "parse good"
X IF(DFLAG) PRINT 10,PARSE,PRSA,PRSO,PRSI
X10 FORMAT(' PARSE RESULTS- ',L7,3I7)
X#endif
X RETURN
XC
XC PARSE FAILS, DISALLOW CONTINUATION
XC
X100 PRSCON=1
X#ifdef debug
X if(dflag) write(0,*) "parse failed"
X IF(DFLAG) PRINT 10,PARSE,PRSA,PRSO,PRSI
X#endif
X RETURN
XC
X END
XC ORPHAN- SET UP NEW ORPHANS
XC
XC DECLARATIONS
XC
X SUBROUTINE ORPHAN(O1,O2,O3,O4,O5)
X IMPLICIT INTEGER(A-Z)
X COMMON /ORPHS/ A,B,C,D,E
XC
X A=O1
XC !SET UP NEW ORPHANS.
X B=O2
X C=O3
X D=O4
X E=O5
X RETURN
X END
X#ifndef PDP
XC LEX- LEXICAL ANALYZER
XC
XC
XC THIS ROUTINE DETAILS ON BIT 1 OF PRSFLAG
XC
X LOGICAL FUNCTION LEX(INBUF,INLNT,OUTBUF,OP,VBFLAG)
X IMPLICIT INTEGER(A-Z)
X CHARACTER INBUF(78),J,DLIMIT(9)
X INTEGER OUTBUF(40)
X LOGICAL VBFLAG
X#include "parser.h"
XC
X#include "debug.h"
XC
X DATA DLIMIT/'A','Z',o'100','1','9',o'22','-','-',o'22'/
XC
X DO 100 I=1,40
XC !CLEAR OUTPUT BUF.
X OUTBUF(I)=0
X100 CONTINUE
XC
X#ifdef debug
X DFLAG=and(PRSFLG,2).NE.0
X#endif debug
X LEX=.FALSE.
XC !ASSUME LEX FAILS.
X OP=-1
XC !OUTPUT PTR.
X50 OP=OP+2
XC !ADV OUTPUT PTR.
X CP=0
XC !CHAR PTR=0.
XC
X200 IF(PRSCON.GT.INLNT) GO TO 1000
XC !END OF INPUT?
X J=INBUF(PRSCON)
XC !NO, GET CHARACTER,
X PRSCON=PRSCON+1
XC !ADVANCE PTR.
X IF(J.EQ.'.') GO TO 1000
XC !END OF COMMAND?
X IF(J.EQ.',') GO TO 1000
XC !END OF COMMAND?
X IF(J.EQ.' ') GO TO 6000
XC !SPACE?
X DO 500 I=1,9,3
XC !SCH FOR CHAR.
X IF(and((J.GE.DLIMIT(I)),(J.LE.DLIMIT(I+1))))
X& GO TO 4000
X500 CONTINUE
XC
X IF(VBFLAG) CALL RSPEAK(601)
XC !GREEK TO ME, FAIL.
X RETURN
XC
XC END OF INPUT, SEE IF PARTIAL WORD AVAILABLE.
XC
X1000 IF(PRSCON.GT.INLNT) PRSCON=1
XC !FORCE PARSE RESTART.
X IF(and((CP.EQ.0),(OP.EQ.1))) RETURN
X IF(CP.EQ.0) OP=OP-2
XC !ANY LAST WORD?
X LEX=.TRUE.
X#ifdef debug
X IF(DFLAG) PRINT 10,CP,OP,PRSCON,(OUTBUF(I),I=1,OP+1)
X10 FORMAT(' LEX RESULTS- ',3I7/1X,10O7)
X#endif debug
X RETURN
XC
XC LEGITIMATE CHARACTERS: LETTER, DIGIT, OR HYPHEN.
XC
X4000 J1=ichar(J)-ichar(DLIMIT(I+2))
X#ifdef debug
X IF(DFLAG) PRINT 20,J,J1,CP
X20 FORMAT(' LEX- CHAR= ',3I7)
X#endif debug
X IF(CP.GE.6) GO TO 200
XC !IGNORE IF TOO MANY CHAR.
X K=OP+(CP/3)
XC !COMPUTE WORD INDEX.
X GO TO (4100,4200,4300),(MOD(CP,3)+1)
XC !BRANCH ON CHAR.
X4100 J2=J1*780
XC !CHAR 1... *780
X OUTBUF(K)=OUTBUF(K)+J2+J2
XC !*1560 (40 ADDED BELOW).
X4200 OUTBUF(K)=OUTBUF(K)+(J1*39)
XC !*39 (1 ADDED BELOW).
X4300 OUTBUF(K)=OUTBUF(K)+J1
XC !*1.
X CP=CP+1
X GO TO 200
XC !GET NEXT CHAR.
XC
XC SPACE
XC
X6000 IF(CP.EQ.0) GO TO 200
XC !ANY WORD YET?
X GO TO 50
XC !YES, ADV OP.
XC
X END
X#endif PDP
END_OF_np.F
if test 4769 -ne `wc -c <np.F`; then
echo shar: \"np.F\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f np2.F -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"np2.F\"
else
echo shar: Extracting \"np2.F\" \(4830 characters\)
sed "s/^X//" >np2.F <<'END_OF_np2.F'
XC GETOBJ-- FIND OBJ DESCRIBED BY ADJ, NAME PAIR
XC
XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
XC WRITTEN BY R. M. SUPNIK
XC
XC DECLARATIONS
XC
XC THIS ROUTINE DETAILS ON BIT 3 OF PRSFLG
XC
X INTEGER FUNCTION GETOBJ(OIDX,AIDX,SPCOBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL THISIT,GHERE,LIT,CHOMP
X#include "parser.h"
X#include "gamestate.h"
XC
XC MISCELLANEOUS VARIABLES
XC
X COMMON /STAR/ MBASE,STRBIT
X#include "debug.h"
X#include "objects.h"
X#include "oflags.h"
X#include "advers.h"
X#include "vocab.h"
XC GETOBJ, PAGE 2
XC
X#ifdef debug
X DFLAG=and(PRSFLG, 8).NE.0
X#endif debug
X CHOMP=.FALSE.
X AV=AVEHIC(WINNER)
X OBJ=0
XC !ASSUME DARK.
X IF(.NOT.LIT(HERE)) GO TO 200
XC !LIT?
XC
X OBJ=SCHLST(OIDX,AIDX,HERE,0,0,SPCOBJ)
XC !SEARCH ROOM.
X#ifdef debug
X IF(DFLAG) PRINT 10,OBJ
X10 FORMAT(' SCHLST- ROOM SCH ',I6)
X#endif debug
X IF(OBJ) 1000,200,100
XC !TEST RESULT.
X100 IF((AV.EQ.0).OR.(AV.EQ.OBJ).OR.
X& (and(OFLAG2(OBJ),FINDBT).NE.0)) GO TO 200
X IF(OCAN(OBJ).EQ.AV) GO TO 200
XC !TEST IF REACHABLE.
X CHOMP=.TRUE.
XC !PROBABLY NOT.
XC
X200 IF(AV.EQ.0) GO TO 400
XC !IN VEHICLE?
X NOBJ=SCHLST(OIDX,AIDX,0,AV,0,SPCOBJ)
XC !SEARCH VEHICLE.
X#ifdef debug
X IF(DFLAG) PRINT 20,NOBJ
X20 FORMAT(' SCHLST- VEH SCH ',I6)
X#endif debug
X IF(NOBJ) 1100,400,300
XC !TEST RESULT.
X300 CHOMP=.FALSE.
XC !REACHABLE.
X IF(OBJ.EQ.NOBJ) GO TO 400
XC !SAME AS BEFORE?
X IF(OBJ.NE.0) NOBJ=-NOBJ
XC !AMB RESULT?
X OBJ=NOBJ
XC
X400 NOBJ=SCHLST(OIDX,AIDX,0,0,WINNER,SPCOBJ)
XC !SEARCH ADVENTURER.
X#ifdef debug
X IF(DFLAG) PRINT 30,NOBJ
X30 FORMAT(' SCHLST- ADV SCH ',I6)
X#endif debug
X IF(NOBJ) 1100,600,500
XC !TEST RESULT
X500 IF(OBJ.NE.0) NOBJ=-NOBJ
XC !AMB RESULT?
X1100 OBJ=NOBJ
XC !RETURN NEW OBJECT.
X600 IF(CHOMP) OBJ=-10000
XC !UNREACHABLE.
X1000 GETOBJ=OBJ
XC
X IF(GETOBJ.NE.0) GO TO 1500
XC !GOT SOMETHING?
X DO 1200 I=STRBIT+1,OLNT
XC !NO, SEARCH GLOBALS.
X IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 1200
X IF(.NOT.GHERE(I,HERE)) GO TO 1200
XC !CAN IT BE HERE?
X IF(GETOBJ.NE.0) GETOBJ=-I
XC !AMB MATCH?
X IF(GETOBJ.EQ.0) GETOBJ=I
X1200 CONTINUE
XC
X1500 CONTINUE
XC !END OF SEARCH.
X#ifdef debug
X IF(DFLAG) PRINT 40,GETOBJ
X40 FORMAT(' SCHLST- RESULT ',I6)
X#endif debug
X RETURN
X END
XC SCHLST-- SEARCH FOR OBJECT
XC
XC DECLARATIONS
XC
X INTEGER FUNCTION SCHLST(OIDX,AIDX,RM,CN,AD,SPCOBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL THISIT,QHERE,NOTRAN,NOVIS
XC
X COMMON /STAR/ MBASE,STRBIT
X#include "objects.h"
X#include "oflags.h"
XC
XC FUNCTIONS AND DATA
XC
X NOTRAN(O)=(and(OFLAG1(O),TRANBT).EQ.0).AND.
X& (and(OFLAG2(O),OPENBT).EQ.0)
X NOVIS(O)=(and(OFLAG1(O),VISIBT).EQ.0)
XC
X SCHLST=0
XC !NO RESULT.
X DO 1000 I=1,OLNT
XC !SEARCH OBJECTS.
X IF(NOVIS(I).OR.
X& (((RM.EQ.0).OR.(.NOT.QHERE(I,RM))).AND.
X& ((CN.EQ.0).OR.(OCAN(I).NE.CN)).AND.
X& ((AD.EQ.0).OR.(OADV(I).NE.AD)))) GO TO 1000
X IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 200
X IF(SCHLST.NE.0) GO TO 2000
XC !GOT ONE ALREADY?
X SCHLST=I
XC !NO.
XC
XC IF OPEN OR TRANSPARENT, SEARCH THE OBJECT ITSELF.
XC
X200 IF(NOTRAN(I)) GO TO 1000
XC
XC SEARCH IS CONDUCTED IN REVERSE. ALL OBJECTS ARE CHECKED TO
XC SEE IF THEY ARE AT SOME LEVEL OF CONTAINMENT INSIDE OBJECT 'I'.
XC IF THEY ARE AT LEVEL 1, OR IF ALL LINKS IN THE CONTAINMENT
XC CHAIN ARE OPEN, VISIBLE, AND HAVE SEARCHME SET, THEY CAN QUALIFY
XC AS A POTENTIAL MATCH.
XC
X DO 500 J=1,OLNT
XC !SEARCH OBJECTS.
X IF(NOVIS(J).OR. (.NOT.THISIT(OIDX,AIDX,J,SPCOBJ)))
X& GO TO 500
X X=OCAN(J)
XC !GET CONTAINER.
X300 IF(X.EQ.I) GO TO 400
XC !INSIDE TARGET?
X IF(X.EQ.0) GO TO 500
XC !INSIDE ANYTHING?
X IF(NOVIS(X).OR.NOTRAN(X).OR.
X& (and(OFLAG2(X),SCHBT).EQ.0)) GO TO 500
X X=OCAN(X)
XC !GO ANOTHER LEVEL.
X GO TO 300
XC
X400 IF(SCHLST.NE.0) GO TO 2000
XC !ALREADY GOT ONE?
X SCHLST=J
XC !NO.
X500 CONTINUE
XC
X1000 CONTINUE
X RETURN
XC
X2000 SCHLST=-SCHLST
XC !AMB RETURN.
X RETURN
XC
X END
XC
XC THISIT-- VALIDATE OBJECT VS DESCRIPTION
XC
XC DECLARATIONS
XC
X LOGICAL FUNCTION THISIT(OIDX,AIDX,OBJ,SPCOBJ)
X IMPLICIT INTEGER(A-Z)
X LOGICAL NOTEST
X#include "vocab.h"
XC
XC FUNCTIONS AND DATA
XC
X NOTEST(O)=(O.LE.0).OR.(O.GE.R50MIN)
XC
XC THE FOLLOWING DATA STATEMENT USED RADIX-50 NOTATION (R50MIN/1RA/)
XC IN RADIX-50 NOTATION, AN "A" IN THE FIRST POSITION IS
XC ENCODED AS 1*40*40 = 1600.
XC
X DATA R50MIN/1600/
XC
X THISIT=.FALSE.
XC !ASSUME NO MATCH.
X IF((SPCOBJ.NE.0).AND.(OBJ.EQ.SPCOBJ)) GO TO 500
XC
XC CHECK FOR OBJECT NAMES
XC
X I=OIDX+1
X100 I=I+1
X IF(NOTEST(OVOC(I))) RETURN
XC !IF DONE, LOSE.
X IF(OVOC(I).NE.OBJ) GO TO 100
XC !IF FAIL, CONT.
XC
X IF(AIDX.EQ.0) GO TO 500
XC !ANY ADJ?
X I=AIDX+1
X200 I=I+1
X IF(NOTEST(AVOC(I))) RETURN
XC !IF DONE, LOSE.
X IF(AVOC(I).NE.OBJ) GO TO 200
XC !IF FAIL, CONT.
XC
X500 THISIT=.TRUE.
X RETURN
X END
END_OF_np2.F
if test 4830 -ne `wc -c <np2.F`; then
echo shar: \"np2.F\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f nrooms.F -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"nrooms.F\"
else
echo shar: Extracting \"nrooms.F\" \(6745 characters\)
sed "s/^X//" >nrooms.F <<'END_OF_nrooms.F'
XC RAPPL2- SPECIAL PURPOSE ROOM ROUTINES, PART 2
XC
XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
XC WRITTEN BY R. M. SUPNIK
XC
XC DECLARATIONS
XC
X LOGICAL FUNCTION RAPPL2(RI)
X IMPLICIT INTEGER (A-Z)
X LOGICAL QOPEN,QHERE
X#include "parser.h"
X#include "gamestate.h"
X#include "state.h"
X#include "io.h"
X#include "rooms.h"
X#include "rflag.h"
X#include "rindex.h"
X#include "objects.h"
X#include "oflags.h"
X#include "oindex.h"
X#include "xsrch.h"
X#include "clock.h"
X#include "advers.h"
X#include "verbs.h"
X#include "flags.h"
XC
XC FUNCTIONS AND DATA
XC
X QOPEN(R)=and(OFLAG2(R),OPENBT).NE.0
X DATA NEWRMS/38/
XC RAPPL2, PAGE 2
XC
X RAPPL2=.TRUE.
X GO TO (38000,39000,40000,41000,42000,43000,44000,
X& 45000,46000,47000,48000,49000,50000,
X& 51000,52000,53000,54000,55000,56000,
X& 57000,58000,59000,60000),
X& (RI-NEWRMS+1)
X CALL BUG(70,RI)
X RETURN
XC
XC R38-- MIRROR D ROOM
XC
X38000 IF(PRSA.EQ.LOOKW) CALL LOOKTO(FDOOR,MRG,0,682,681)
X RETURN
XC
XC R39-- MIRROR G ROOM
XC
X39000 IF(PRSA.EQ.WALKIW) CALL JIGSUP(685)
X RETURN
XC
XC R40-- MIRROR C ROOM
XC
X40000 IF(PRSA.EQ.LOOKW) CALL LOOKTO(MRG,MRB,683,0,681)
X RETURN
XC
XC R41-- MIRROR B ROOM
XC
X41000 IF(PRSA.EQ.LOOKW) CALL LOOKTO(MRC,MRA,0,0,681)
X RETURN
XC
XC R42-- MIRROR A ROOM
XC
X42000 IF(PRSA.EQ.LOOKW) CALL LOOKTO(MRB,0,0,684,681)
X RETURN
XC RAPPL2, PAGE 3
XC
XC R43-- MIRROR C EAST/WEST
XC
X43000 IF(PRSA.EQ.LOOKW) CALL EWTELL(HERE,683)
X RETURN
XC
XC R44-- MIRROR B EAST/WEST
XC
X44000 IF(PRSA.EQ.LOOKW) CALL EWTELL(HERE,686)
X RETURN
XC
XC R45-- MIRROR A EAST/WEST
XC
X45000 IF(PRSA.EQ.LOOKW) CALL EWTELL(HERE,687)
X RETURN
XC
XC R46-- INSIDE MIRROR
XC
X46000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X CALL RSPEAK(688)
XC !DESCRIBE
XC
XC NOW DESCRIBE POLE STATE.
XC
XC CASES 1,2-- MDIR=270 & MLOC=MRB, POLE IS UP OR IN HOLE
XC CASES 3,4-- MDIR=0 V MDIR=180, POLE IS UP OR IN CHANNEL
XC CASE 5-- POLE IS UP
XC
X I=689
XC !ASSUME CASE 5.
X IF((MDIR.EQ.270).AND.(MLOC.EQ.MRB))
X& I=690+MIN0(POLEUF,1)
X IF(MOD(MDIR,180).EQ.0)
X& I=692+MIN0(POLEUF,1)
X CALL RSPEAK(I)
XC !DESCRIBE POLE.
X CALL RSPSUB(694,695+(MDIR/45))
XC !DESCRIBE ARROW.
X RETURN
XC RAPPL2, PAGE 4
XC
XC R47-- MIRROR EYE ROOM
XC
X47000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X I=704
XC !ASSUME BEAM STOP.
X DO 47100 J=1,OLNT
X IF(QHERE(J,HERE).AND.(J.NE.RBEAM)) GO TO 47200
X47100 CONTINUE
X I=703
X47200 CALL RSPSUB(I,ODESC2(J))
XC !DESCRIBE BEAM.
X CALL LOOKTO(MRA,0,0,0,0)
XC !LOOK NORTH.
X RETURN
XC
XC R48-- INSIDE CRYPT
XC
X48000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X I=46
XC !CRYPT IS OPEN/CLOSED.
X IF(QOPEN(TOMB)) I=12
X CALL RSPSUB(705,I)
X RETURN
XC
XC R49-- SOUTH CORRIDOR
XC
X49000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X CALL RSPEAK(706)
XC !DESCRIBE.
X I=46
XC !ODOOR IS OPEN/CLOSED.
X IF(QOPEN(ODOOR)) I=12
X IF(LCELL.EQ.4) CALL RSPSUB(707,I)
XC !DESCRIBE ODOOR IF THERE.
X RETURN
XC
XC R50-- BEHIND DOOR
XC
X50000 IF(PRSA.NE.WALKIW) GO TO 50100
XC !WALK IN?
X CFLAG(CEVFOL)=.TRUE.
XC !MASTER FOLLOWS.
X CTICK(CEVFOL)=-1
X RETURN
XC
X50100 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X I=46
XC !QDOOR IS OPEN/CLOSED.
X IF(QOPEN(QDOOR)) I=12
X CALL RSPSUB(708,I)
X RETURN
XC RAPPL2, PAGE 5
XC
XC R51-- FRONT DOOR
XC
X51000 IF(PRSA.EQ.WALKIW) CTICK(CEVFOL)=0
XC !IF EXITS, KILL FOLLOW.
X IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X CALL LOOKTO(0,MRD,709,0,0)
XC !DESCRIBE SOUTH.
X I=46
XC !PANEL IS OPEN/CLOSED.
X IF(INQSTF) I=12
XC !OPEN IF INQ STARTED.
X J=46
XC !QDOOR IS OPEN/CLOSED.
X IF(QOPEN(QDOOR)) J=12
X CALL RSPSB2(710,I,J)
X RETURN
XC
XC R52-- NORTH CORRIDOR
XC
X52000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X I=46
X IF(QOPEN(CDOOR)) I=12
XC !CDOOR IS OPEN/CLOSED.
X CALL RSPSUB(711,I)
X RETURN
XC
XC R53-- PARAPET
XC
X53000 IF(PRSA.EQ.LOOKW) CALL RSPSUB(712,712+PNUMB)
X RETURN
XC
XC R54-- CELL
XC
X54000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X I=721
XC !CDOOR IS OPEN/CLOSED.
X IF(QOPEN(CDOOR)) I=722
X CALL RSPEAK(I)
X I=46
XC !ODOOR IS OPEN/CLOSED.
X IF(QOPEN(ODOOR)) I=12
X IF(LCELL.EQ.4) CALL RSPSUB(723,I)
XC !DESCRIBE.
X RETURN
XC
XC R55-- PRISON CELL
XC
X55000 IF(PRSA.EQ.LOOKW) CALL RSPEAK(724)
XC !LOOK?
X RETURN
XC
XC R56-- NIRVANA CELL
XC
X56000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X I=46
XC !ODOOR IS OPEN/CLOSED.
X IF(QOPEN(ODOOR)) I=12
X CALL RSPSUB(725,I)
X RETURN
XC RAPPL2, PAGE 6
XC
XC R57-- NIRVANA AND END OF GAME
XC
X57000 IF(PRSA.NE.WALKIW) RETURN
XC !WALKIN?
X CALL RSPEAK(726)
X CALL SCORE(.FALSE.)
XC moved to exit routine CLOSE(DBCH)
X CALL EXIT
XC
XC R58-- TOMB ROOM
XC
X58000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X I=46
XC !TOMB IS OPEN/CLOSED.
X IF(QOPEN(TOMB)) I=12
X CALL RSPSUB(792,I)
X RETURN
XC
XC R59-- PUZZLE SIDE ROOM
XC
X59000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X I=861
XC !ASSUME DOOR CLOSED.
X IF(CPOUTF) I=862
XC !OPEN?
X CALL RSPEAK(I)
XC !DESCRIBE.
X RETURN
XC
XC R60-- PUZZLE ROOM
XC
X60000 IF(PRSA.NE.LOOKW) RETURN
XC !LOOK?
X IF(CPUSHF) GO TO 60100
XC !STARTED PUZZLE?
X CALL RSPEAK(868)
XC !NO, DESCRIBE.
X IF(and(OFLAG2(WARNI),TCHBT).NE.0) CALL RSPEAK(869)
X RETURN
XC
X60100 CALL CPINFO(880,CPHERE)
XC !DESCRIBE ROOM.
X RETURN
XC
X END
XC LOOKTO-- DESCRIBE VIEW IN MIRROR HALLWAY
XC
XC DECLARATIONS
XC
X SUBROUTINE LOOKTO(NRM,SRM,NT,ST,HT)
X IMPLICIT INTEGER(A-Z)
X#include "gamestate.h"
X#include "flags.h"
XC LOOKTO, PAGE 2
XC
X CALL RSPEAK(HT)
XC !DESCRIBE HALL.
X CALL RSPEAK(NT)
XC !DESCRIBE NORTH VIEW.
X CALL RSPEAK(ST)
XC !DESCRIBE SOUTH VIEW.
X DIR=0
XC !ASSUME NO DIRECTION.
X IF(IABS(MLOC-HERE).NE.1) GO TO 200
XC !MIRROR TO N OR S?
X IF(MLOC.EQ.NRM) DIR=695
X IF(MLOC.EQ.SRM) DIR=699
XC !DIR=N/S.
X IF(MOD(MDIR,180).NE.0) GO TO 100
XC !MIRROR N-S?
X CALL RSPSUB(847,DIR)
XC !YES, HE SEES PANEL
X CALL RSPSB2(848,DIR,DIR)
XC !AND NARROW ROOMS.
X GO TO 200
XC
X100 M1=MRHERE(HERE)
XC !WHICH MIRROR?
X MRBF=0
XC !ASSUME INTACT.
X IF(((M1.EQ.1).AND..NOT.MR1F).OR.
X& ((M1.EQ.2).AND..NOT.MR2F)) MRBF=1
X CALL RSPSUB(849+MRBF,DIR)
XC !DESCRIBE.
X IF((M1.EQ.1).AND.MROPNF) CALL RSPEAK(823+MRBF)
X IF(MRBF.NE.0) CALL RSPEAK(851)
XC
X200 I=0
XC !ASSUME NO MORE TO DO.
X IF((NT.EQ.0).AND.((DIR.EQ.0).OR.(DIR.EQ.699))) I=852
X IF((ST.EQ.0).AND.((DIR.EQ.0).OR.(DIR.EQ.695))) I=853
X IF((NT+ST+DIR).EQ.0) I=854
X IF(HT.NE.0) CALL RSPEAK(I)
XC !DESCRIBE HALLS.
X RETURN
XC
X END
XC EWTELL-- DESCRIBE E/W NARROW ROOMS
XC
XC DECLARATIONS
XC
X SUBROUTINE EWTELL(RM,ST)
X IMPLICIT INTEGER(A-Z)
X LOGICAL M1
XC
XC ROOMS
X#include "rindex.h"
X#include "flags.h"
XC EWTELL, PAGE 2
XC
XC NOTE THAT WE ARE EAST OR WEST OF MIRROR, AND
XC MIRROR MUST BE N-S.
XC
X M1=(MDIR+(MOD(RM-MRAE,2)*180)).EQ.180
X I=819+MOD(RM-MRAE,2)
XC !GET BASIC E/W STRING.
X IF((M1.AND..NOT.MR1F).OR.(.NOT.M1.AND..NOT.MR2F))
X& I=I+2
X CALL RSPEAK(I)
X IF(M1.AND.MROPNF) CALL RSPEAK(823+((I-819)/2))
X CALL RSPEAK(825)
X CALL RSPEAK(ST)
X RETURN
XC
X END
END_OF_nrooms.F
if test 6745 -ne `wc -c <nrooms.F`; then
echo shar: \"nrooms.F\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f oflags.h -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"oflags.h\"
else
echo shar: Extracting \"oflags.h\" \(269 characters\)
sed "s/^X//" >oflags.h <<'END_OF_oflags.h'
XC
X COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
X& NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
X& TOOLBT,TURNBT,ONBT
X COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
X& WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
X& TCHBT,VEHBT,SCHBT
END_OF_oflags.h
if test 269 -ne `wc -c <oflags.h`; then
echo shar: \"oflags.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f speak.F -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"speak.F\"
else
echo shar: Extracting \"speak.F\" \(3842 characters\)
sed "s/^X//" >speak.F <<'END_OF_speak.F'
X#include "files.h"
X
X#ifndef RTEXTFILE
X#define RTEXTFILE '/usr/games/lib/dunlib/rtext.dat'
X#endif
X
X#ifndef TEXTFILE
X#define TEXTFILE '/usr/games/lib/dunlib/dtext.dat'
X#endif
X
XC
XC manual speak routine
XC gets dungeon messages and prints them
XC (only used for pdp version)
XC
X program speak
X IMPLICIT INTEGER(A-Z)
XC
X COMMON /CHAN/ INPCH,OUTCH,DBCH
X#include "mindex.h"
XC
XC load the lookup table
XC
X OPEN(UNIT=9,file=RTEXTFILE,
X& status='OLD',IOSTAT=IO,
X& FORM='formatted',ACCESS='SEQUENTIAL',err=50)
XC
X call load
XC
XC open the message file
XC
X DBCH=2
XC
X OPEN(UNIT=DBCH,file=TEXTFILE,
X& status='OLD',IOSTAT=IO,
X& FORM='UNFORMATTED',ACCESS='DIRECT',recl=76,err=60)
XC
X print 20
X20 format('Sigh... '/)
XC
XC get numbers and call speaking program
XC
X10 continue
XC
X call inprd(mesage,i,j)
X call RSPSB2(mesage,i,j)
X goto 10
XC
XC INITIALIZATION ERROR
XC
X50 print 960
X print 980
X goto 99
X60 print 970
X print 980
X goto 99
X960 FORMAT(' I can''t open ',RTEXTFILE,'.')
X970 FORMAT(' I can''t open ',TEXTFILE,'.')
X980 FORMAT(' Suddenly a sinister, wraithlike figure appears before '
X& 'you,'/' seeming to float in the air. In a low, sorrowful voice'
X& ' he says,'/' "Alas, the very nature of the world has changed, '
X& 'and the dungeon'/' cannot be found. All must now pass away."'
X& ' Raising his oaken staff'/' in farewell, he fades into the '
X& 'spreading darkness. In his place'/' appears a tastefully '
X& 'lettered sign reading:'//23X,'INITIALIZATION FAILURE'//
X& ' The darkness becomes all encompassing, and your vision fails.')
X99 stop
X end
XC
XC RSPSB2-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENTS
XC
XC CALLED BY--
XC
XC CALL RSPSB2(MSGNUM,S1,S2)
XC
X SUBROUTINE RSPSB2(A,B,C)
X IMPLICIT INTEGER(A-Z)
X CHARACTER*74 B1,B2,B3
X INTEGER*2 OLDREC,NEWREC,JREC
XC
XC DECLARATIONS
XC
XC
X COMMON /RMSG/ MLNT,RTEXT(1050)
X COMMON /CHAN/ INPCH,OUTCH,DBCH
XC
XC CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE)
XC TO ABSOLUTE RECORD NUMBERS.
XC
X X=A
X Y=B
X Z=C
X IF(X.GT.0) X=RTEXT(X)
X IF(Y.GT.0) Y=RTEXT(Y)
X IF(Z.GT.0) Z=RTEXT(Z)
X X=IABS(X)
X Y=IABS(Y)
X Z=IABS(Z)
X IF(X.EQ.0) RETURN
XC
X READ(UNIT=DBCH,REC=X) OLDREC,B1
XC
X100 DO 150 I=1,74
X X1=and(X,31)+I
X B1(I:I)=char(xor(ichar(B1(I:I)),X1))
X150 CONTINUE
XC
X200 IF(Y.EQ.0) GO TO 400
X DO 300 I=1,74
X IF(B1(I:I).EQ.'#') GO TO 1000
X300 CONTINUE
XC
X400 DO 500 I=74,1,-1
X IF(B1(I:I).NE.' ') GO TO 600
X500 CONTINUE
XC
XC 600 WRITE(OUTCH,650) (B1(J:J),J=1,I)
X600 PRINT 650, (B1(J:J),J=1,I)
X650 FORMAT(1X,74A1)
X X=X+1
X READ(UNIT=DBCH,REC=X) NEWREC,B1
X IF(OLDREC.EQ.NEWREC) GO TO 100
X RETURN
XC
XC SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE.
XC I IS INDEX OF # IN B1.
XC Y IS NUMBER OF RECORD TO SUBSTITUTE.
XC
XC PROCEDURE:
XC 1) COPY REST OF B1 TO B2
XC 2) READ SUBSTITUTABLE OVER B1
XC 3) RESTORE TAIL OF ORIGINAL B1
XC
XC THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING
XC IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD).
XC
X1000 K2=1
X DO 1100 K1=I+1,74
X B2(K2:K2)=B1(K1:K1)
X K2=K2+1
X1100 CONTINUE
XC
XC READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT:
XC
X READ(UNIT=DBCH,REC=Y) JREC,B3
X DO 1150 K1=1,74
X X1=and(Y,31)+K1
X B3(K1:K1)=char(xor(ICHAR(B3(K1:K1)),X1))
X1150 CONTINUE
XC
XC FILL REMAINDER OF B1 WITH CHARACTERS FROM B3:
XC
X K2=1
X DO 1180 K1=I,74
X B1(K1:K1)=B3(K2:K2)
X K2=K2+1
X1180 CONTINUE
XC
XC FIND END OF SUBSTITUTE STRING IN B1:
XC
X DO 1200 J=74,1,-1
X IF(B1(J:J).NE.' ') GO TO 1300
X1200 CONTINUE
XC
XC PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING:
XC
X1300 K1=1
X DO 1400 K2=J+1,74
X B1(K2:K2)=B2(K1:K1)
X K1=K1+1
X1400 CONTINUE
XC
X Y=Z
X Z=0
X GO TO 200
XC
X END
X SUBROUTINE LOAD
X IMPLICIT INTEGER (A-Z)
XC
XC load rtext data
XC
XC
XC MESSAGE INDEX
XC
X COMMON /RMSG/ MLNT,RTEXT(1050)
XC
XC
X rewind 9
XC
XC load the data
XC
XC
X READ(9,130) RTEXT
X130 FORMAT(I8)
X close(9)
XC
XC
X return
X END
END_OF_speak.F
if test 3842 -ne `wc -c <speak.F`; then
echo shar: \"speak.F\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 6 \(of 14\).
cp /dev/null ark6isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 14 archives.
rm -f ark[1-9]isdone ark1[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0