home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol045 / dsub.ftn < prev    next >
Encoding:
Text File  |  1984-04-29  |  17.9 KB  |  647 lines
  1. C RESIDENT SUBROUTINES FOR DUNGEON
  2. C
  3. C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  4. C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  5. C WRITTEN BY R. M. SUPNIK
  6. C
  7. C RSPEAK-- OUTPUT RANDOM MESSAGE ROUTINE
  8. C
  9. C CALLED BY--
  10. C
  11. C    CALL RSPEAK(MSGNUM)
  12. C
  13.     SUBROUTINE RSPEAK(N)
  14.     IMPLICIT INTEGER(A-Z)
  15. C
  16.     CALL RSPSB2(N,0,0)
  17.     RETURN
  18.     END
  19. C RSPSUB-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENT
  20. C
  21. C CALLED BY--
  22. C
  23. C    CALL RSPSUB(MSGNUM,SUBNUM)
  24. C
  25.     SUBROUTINE RSPSUB(N,S1)
  26.     IMPLICIT INTEGER(A-Z)
  27. C
  28.     CALL RSPSB2(N,S1,0)
  29.     RETURN
  30.     END
  31. C RSPSB2-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENTS
  32. C
  33. C CALLED BY--
  34. C
  35. C    CALL RSPSB2(MSGNUM,S1,S2)
  36. C
  37.     SUBROUTINE RSPSB2(A,B,C)
  38.     IMPLICIT INTEGER(A-Z)
  39.     LOGICAL*1 B1(74),B2(74),X1
  40. C
  41. C DECLARATIONS
  42. C
  43.     LOGICAL TELFLG
  44.     COMMON /PLAY/ WINNER,HERE,TELFLG
  45. C
  46.     COMMON /RMSG/ MLNT,RTEXT(1050)
  47.     COMMON /CHAN/ INPCH,OUTCH,DBCH
  48. C
  49. C CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE)
  50. C TO ABSOLUTE RECORD NUMBERS.
  51. C
  52.     X=A                    !SET UP WORK VARIABLES.
  53.     Y=B
  54.     Z=C
  55.     IF(X.GT.0) X=RTEXT(X)            !IF >0, LOOK UP IN RTEXT.
  56.     IF(Y.GT.0) Y=RTEXT(Y)
  57.     IF(Z.GT.0) Z=RTEXT(Z)
  58.     X=IABS(X)                !TAKE ABS VALUE.
  59.     Y=IABS(Y)
  60.     Z=IABS(Z)
  61.     IF(X.EQ.0) RETURN            !ANYTHING TO DO?
  62.     TELFLG=.TRUE.                !SAID SOMETHING.
  63. C
  64.     READ(DBCH'X) OLDREC,B1            !READ FIRST LINE.
  65. 100    DO 150 I=1,74
  66.       X1=(X.AND.31)+I
  67.       B1(I)=B1(I).XOR.X1
  68. 150    CONTINUE
  69. C
  70. 200    IF(Y.EQ.0) GO TO 400            !ANY SUBSTITUTABLE?
  71.     DO 300 I=1,74                !YES, LOOK FOR #.
  72.       IF(B1(I).EQ.'#') GO TO 1000
  73. 300    CONTINUE
  74. C
  75. 400    DO 500 I=74,1,-1            !BACKSCAN FOR BLANKS.
  76.       IF(B1(I).NE.' ') GO TO 600
  77. 500    CONTINUE
  78. C
  79. 600    WRITE(OUTCH,650) (B1(J),J=1,I)        !OUTPUT LINE.
  80. 650    FORMAT(1X,74A1)
  81.     X=X+1                    !ON TO NEXT RECORD.
  82.     READ(DBCH'X) NEWREC,B1            !READ NEXT RECORD.
  83.     IF(OLDREC.EQ.NEWREC) GO TO 100        !CONTINUATION?
  84.     RETURN                    !NO, EXIT.
  85. C
  86. C SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE.
  87. C I IS INDEX OF # IN B1.
  88. C Y IS NUMBER OF RECORD TO SUBSTITUTE.
  89. C
  90. C PROCEDURE:
  91. C   1) COPY REST OF B1 TO B2
  92. C   2) READ SUBSTITUTABLE OVER B1
  93. C   3) RESTORE TAIL OF ORIGINAL B1
  94. C
  95. C THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING
  96. C IS VERY SHORT.
  97. C
  98. 1000    K2=1                    !TO
  99.     DO 1100 K1=I+1,74            !COPY REST OF B1.
  100.       B2(K2)=B1(K1)
  101.       K2=K2+1
  102. 1100    CONTINUE
  103. C
  104.     READ(DBCH'Y) J,(B1(K1),K1=I,74)        !READ SUB RECORD.
  105.     DO 1150 K1=I,74
  106.       X1=(Y.AND.31)+K1-I+1
  107.       B1(K1)=B1(K1).XOR.X1
  108. 1150    CONTINUE
  109. C
  110.     DO 1200 J=74,1,-1            !ELIM TRAILING BLANKS.
  111.       IF(B1(J).NE.' ') GO TO 1300
  112. 1200    CONTINUE
  113. C
  114. 1300    K1=1                    !FROM
  115.     DO 1400 K2=J+1,74            !COPY REST OF B1 BACK.
  116.       B1(K2)=B2(K1)
  117.       K1=K1+1
  118. 1400    CONTINUE
  119. C
  120.     Y=Z                    !SET UP FOR NEXT
  121.     Z=0                    !SUBSTITUTION AND
  122.     GO TO 200                !RECHECK LINE.
  123. C
  124.     END
  125. C OBJACT-- APPLY OBJECTS FROM PARSE VECTOR
  126. C
  127. C DECLARATIONS
  128. C
  129.     LOGICAL FUNCTION OBJACT(X)
  130.     IMPLICIT INTEGER (A-Z)
  131.     LOGICAL OAPPLI
  132. C
  133. C PARSER OUTPUT
  134. C
  135.     LOGICAL PRSWON
  136.     COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
  137. C
  138. C OBJECTS
  139. C
  140.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  141.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  142.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  143.     3    OADV(220),OCAN(220),OREAD(220)
  144. C
  145.     OBJACT=.TRUE.                !ASSUME WINS.
  146.     IF(PRSI.EQ.0) GO TO 100            !IND OBJECT?
  147.     IF(OAPPLI(OACTIO(PRSI),0)) RETURN    !YES, LET IT HANDLE.
  148. C
  149. 100    IF(PRSO.EQ.0) GO TO 200            !DIR OBJECT?
  150.     IF(OAPPLI(OACTIO(PRSO),0)) RETURN    !YES, LET IT HANDLE.
  151. C
  152. 200    OBJACT=.FALSE.                !LOSES.
  153.     RETURN
  154.     END
  155. C BUG-- REPORT FATAL SYSTEM ERROR
  156. C
  157. C CALLED BY--
  158. C
  159. C    CALL BUG(NO,PAR)
  160. C
  161.     SUBROUTINE BUG(A,B)
  162.     IMPLICIT INTEGER(A-Z)
  163. C
  164.     COMMON /DEBUG/ DBGFLG
  165. C
  166.     TYPE 100,A,B
  167.     IF(DBGFLG.NE.0) RETURN
  168.     CALL EXIT
  169. C
  170. 100    FORMAT(' PROGRAM ERROR ',I2,', PARAMETER=',I6)
  171.     END
  172. C NEWSTA-- SET NEW STATUS FOR OBJECT
  173. C
  174. C CALLED BY--
  175. C
  176. C    CALL NEWSTA(OBJECT,STRING,NEWROOM,NEWCON,NEWADV)
  177. C
  178.     SUBROUTINE NEWSTA(O,R,RM,CN,AD)
  179.     IMPLICIT INTEGER(A-Z)
  180. C
  181. C OBJECTS
  182. C
  183.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  184.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  185.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  186.     3    OADV(220),OCAN(220),OREAD(220)
  187. C
  188.     CALL RSPEAK(R)
  189.     OROOM(O)=RM
  190.     OCAN(O)=CN
  191.     OADV(O)=AD
  192.     RETURN
  193.     END
  194. C QHERE-- TEST FOR OBJECT IN ROOM
  195. C
  196. C DECLARATIONS
  197. C
  198.     LOGICAL FUNCTION QHERE(OBJ,RM)
  199.     IMPLICIT INTEGER (A-Z)
  200. C
  201. C OBJECTS
  202. C
  203.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  204.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  205.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  206.     3    OADV(220),OCAN(220),OREAD(220)
  207. C
  208.     COMMON /OROOM2/ R2LNT,O2(20),R2(20)
  209. C
  210.     QHERE=.TRUE.
  211.     IF(OROOM(OBJ).EQ.RM) RETURN        !IN ROOM?
  212.     DO 100 I=1,R2LNT            !NO, SCH ROOM2.
  213.       IF((O2(I).EQ.OBJ).AND.(R2(I).EQ.RM)) RETURN
  214. 100    CONTINUE
  215.     QHERE=.FALSE.                !NOT PRESENT.
  216.     RETURN
  217.     END
  218. C QEMPTY-- TEST FOR OBJECT EMPTY
  219. C
  220. C DECLARATIONS
  221. C
  222.     LOGICAL FUNCTION QEMPTY(OBJ)
  223.     IMPLICIT INTEGER (A-Z)
  224. C
  225. C OBJECTS
  226. C
  227.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  228.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  229.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  230.     3    OADV(220),OCAN(220),OREAD(220)
  231. C
  232.     QEMPTY=.FALSE.                !ASSUME LOSE.
  233.     DO 100 I=1,OLNT
  234.       IF(OCAN(I).EQ.OBJ) RETURN        !INSIDE TARGET?
  235. 100    CONTINUE
  236.     QEMPTY=.TRUE.
  237.     RETURN
  238.     END
  239. C JIGSUP- YOU ARE DEAD
  240. C
  241. C DECLARATIONS
  242. C
  243.     SUBROUTINE JIGSUP(DESC)
  244.     IMPLICIT INTEGER (A-Z)
  245.     LOGICAL YESNO,MOVETO,QHERE,F
  246.     INTEGER RLIST(9)
  247. C
  248. C PARSER OUTPUT
  249. C
  250.     LOGICAL PRSWON
  251.     COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
  252. C
  253. C GAME STATE
  254. C
  255.     LOGICAL TELFLG
  256.     COMMON /PLAY/ WINNER,HERE,TELFLG
  257.     COMMON /STATE/ MOVES,DEATHS,RWSCOR,MXSCOR,MXLOAD,
  258.     1    LTSHFT,BLOC,MUNGRM,HS,EGSCOR,EGMXSC
  259. C
  260.     COMMON /CHAN/ INPCH,OUTCH,DBCH
  261.     COMMON /DEBUG/ DBGFLG
  262. C
  263. C ROOMS
  264. C
  265.     COMMON /ROOMS/ RLNT,RDESC2,RDESC1(200),REXIT(200),
  266.     1    RACTIO(200),RVAL(200),RFLAG(200)
  267.     INTEGER RRAND(200)
  268.     EQUIVALENCE (RVAL,RRAND)
  269. C
  270.     COMMON /RFLAG/ RSEEN,RLIGHT,RLAND,RWATER,RAIR,
  271.     1    RSACRD,RFILL,RMUNG,RBUCK,RHOUSE,RNWALL,REND
  272. C
  273.     COMMON /RINDEX/ WHOUS,LROOM,CELLA
  274.     COMMON /RINDEX/ MTROL,MAZE1    
  275.     COMMON /RINDEX/ MGRAT,MAZ15    
  276.     COMMON /RINDEX/ FORE1,FORE3,CLEAR,RESER
  277.     COMMON /RINDEX/ STREA,EGYPT,ECHOR
  278.     COMMON /RINDEX/ TSHAF    
  279.     COMMON /RINDEX/ BSHAF,MMACH,DOME,MTORC
  280.     COMMON /RINDEX/ CAROU    
  281.     COMMON /RINDEX/ RIDDL,LLD2,TEMP1,TEMP2,MAINT
  282.     COMMON /RINDEX/ BLROO,TREAS,RIVR1,RIVR2,RIVR3,MCYCL
  283.     COMMON /RINDEX/ RIVR4,RIVR5,FCHMP,FALLS,MBARR
  284.     COMMON /RINDEX/ MRAIN,POG,VLBOT,VAIR1,VAIR2,VAIR3,VAIR4
  285.     COMMON /RINDEX/ LEDG2,LEDG3,LEDG4,MSAFE,CAGER
  286.     COMMON /RINDEX/ CAGED,TWELL,BWELL,ALICE,ALISM,ALITR
  287.     COMMON /RINDEX/ MTREE,BKENT,BKVW,BKTWI,BKVAU,BKBOX
  288.     COMMON /RINDEX/ CRYPT,TSTRS,MRANT,MREYE
  289.     COMMON /RINDEX/ MRA,MRB,MRC,MRG,MRD,FDOOR
  290.     COMMON /RINDEX/ MRAE,MRCE,MRCW,MRGE,MRGW,MRDW,INMIR
  291.     COMMON /RINDEX/ SCORR,NCORR,PARAP,CELL,PCELL,NCELL
  292.     COMMON /RINDEX/ CPANT,CPOUT,CPUZZ
  293. C
  294. C OBJECTS
  295. C
  296.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  297.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  298.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  299.     3    OADV(220),OCAN(220),OREAD(220)
  300. C
  301.     COMMON /OFLAGS/ VISIBT,READBT,TAKEBT,DOORBT,TRANBT,FOODBT,
  302.     1    NDSCBT,DRNKBT,CONTBT,LITEBT,VICTBT,BURNBT,FLAMBT,
  303.     2    TOOLBT,TURNBT,ONBT
  304.     COMMON /OFLAGS/ FINDBT,SLEPBT,SCRDBT,TIEBT,CLMBBT,ACTRBT,
  305.     1    WEAPBT,FITEBT,VILLBT,STAGBT,TRYBT,NOCHBT,OPENBT,
  306.     2    TCHBT,VEHBT,SCHBT
  307. C
  308.     COMMON /OINDEX/ GARLI,FOOD,GUNK,COAL,MACHI,DIAMO,TCASE,BOTTL
  309.     COMMON /OINDEX/ WATER,ROPE,KNIFE,SWORD,LAMP,BLAMP,RUG
  310.     COMMON /OINDEX/    LEAVE,TROLL,AXE
  311.     COMMON /OINDEX/ RKNIF,KEYS,ICE,BAR
  312.     COMMON /OINDEX/ COFFI,TORCH,TBASK,FBASK,IRBOX
  313.     COMMON /OINDEX/ GHOST,TRUNK,BELL,BOOK,CANDL
  314.     COMMON /OINDEX/ MATCH,TUBE,PUTTY,WRENC,SCREW,CYCLO,CHALI
  315.     COMMON /OINDEX/ THIEF,STILL,WINDO,GRATE,DOOR
  316.     COMMON /OINDEX/ HPOLE,LEAK,RBUTT,RAILI
  317.     COMMON /OINDEX/ POT,STATU,IBOAT,DBOAT,PUMP,RBOAT
  318.     COMMON /OINDEX/ STICK,BUOY,SHOVE,BALLO,RECEP,GUANO
  319.     COMMON /OINDEX/ BROPE,HOOK1,HOOK2,SAFE,SSLOT,BRICK,FUSE
  320.     COMMON /OINDEX/ GNOME,BLABE,DBALL,TOMB
  321.     COMMON /OINDEX/ LCASE,CAGE,RCAGE,SPHER,SQBUT
  322.     COMMON /OINDEX/ FLASK,POOL,SAFFR,BUCKE,ECAKE,ORICE,RDICE,BLICE
  323.     COMMON /OINDEX/ ROBOT,FTREE,BILLS,PORTR,SCOL,ZGNOM
  324.     COMMON /OINDEX/ EGG,BEGG,BAUBL,CANAR,BCANA
  325.     COMMON /OINDEX/ YLWAL,RDWAL,PINDR,RBEAM
  326.     COMMON /OINDEX/ ODOOR,QDOOR,CDOOR,NUM1,NUM8
  327.     COMMON /OINDEX/ WARNI,CSLIT,GCARD,STLDR
  328.     COMMON /OINDEX/ HANDS,WALL,LUNGS,SAILO,AVIAT,TEETH
  329.     COMMON /OINDEX/ ITOBJ,EVERY,VALUA,OPLAY,WNORT,GWATE,MASTER
  330. C
  331. C ADVENTURERS
  332. C
  333.     COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
  334.     1    AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
  335. C
  336.     COMMON /AINDEX/ PLAYER,AROBOT,AMASTR
  337. C
  338. C FLAGS
  339. C
  340.     LOGICAL*1 TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF
  341.     LOGICAL*1 DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF
  342.     LOGICAL*1 MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF
  343.     LOGICAL*1 EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF
  344.     LOGICAL*1 GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF
  345.     LOGICAL*1 GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF
  346.     LOGICAL*1 MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF
  347.     LOGICAL*1 FOLLWF,SPELLF,CPOUTF,CPUSHF
  348.     COMMON /FINDEX/ TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF,
  349.     1    DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF,
  350.     2    MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF,
  351.     3    EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF,
  352.     4    GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF,
  353.     5    GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF,
  354.     6    MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF,
  355.     7    FOLLWF,SPELLF,CPOUTF,CPUSHF
  356.     COMMON /FINDEX/ BTIEF,BINFF
  357.     COMMON /FINDEX/ RVMNT,RVCLR,RVCYC,RVSND,RVGUA
  358.     COMMON /FINDEX/ ORRUG,ORCAND,ORMTCH,ORLAMP
  359.     COMMON /FINDEX/ MDIR,MLOC,POLEUF
  360.     COMMON /FINDEX/ QUESNO,NQATT,CORRCT
  361.     COMMON /FINDEX/ LCELL,PNUMB,ACELL,DCELL,CPHERE
  362. C
  363. C FUNCTIONS AND DATA
  364. C
  365.     DATA RLIST/8,6,36,35,34,4,34,6,5/
  366. C JIGSUP, PAGE 2
  367. C
  368.     CALL RSPEAK(DESC)            !DESCRIBE SAD STATE.
  369.     PRSCON=1                !STOP PARSER.
  370.     IF(DBGFLG.NE.0) RETURN            !IF DBG, EXIT.
  371.     AVEHIC(WINNER)=0            !GET RID OF VEHICLE.
  372.     IF(WINNER.EQ.PLAYER) GO TO 100        !HIMSELF?
  373.     CALL RSPSUB(432,ODESC2(AOBJ(WINNER)))    !NO, SAY WHO DIED.
  374.     CALL NEWSTA(AOBJ(WINNER),0,0,0,0)    !SEND TO HYPER SPACE.
  375.     RETURN
  376. C
  377. 100    IF(ENDGMF) GO TO 900            !NO RECOVERY IN END GAME.
  378.     IF(DEATHS.GE.2) GO TO 1000        !DEAD TWICE? KICK HIM OFF.
  379.     IF(.NOT.YESNO(10,9,8)) GO TO 1100    !CONTINUE?
  380. C
  381.     DO 50 J=1,OLNT                !TURN OFF FIGHTING.
  382.       IF(QHERE(J,HERE)) OFLAG2(J)=OFLAG2(J).AND. .NOT.FITEBT
  383. 50    CONTINUE
  384. C
  385.     DEATHS=DEATHS+1
  386.     CALL SCRUPD(-10)            !CHARGE TEN POINTS.
  387.     F=MOVETO(FORE1,WINNER)            !REPOSITION HIM.
  388.     EGYPTF=.TRUE.                !RESTORE COFFIN.
  389.     IF(OADV(COFFI).EQ.WINNER) CALL NEWSTA(COFFI,0,EGYPT,0,0)
  390.     OFLAG2(DOOR)=OFLAG2(DOOR).AND. .NOT.TCHBT !RESTORE DOOR.
  391.     OFLAG1(ROBOT)=(OFLAG1(ROBOT).OR.VISIBT) .AND. .NOT.NDSCBT
  392.     IF((OROOM(LAMP).NE.0).OR.(OADV(LAMP).EQ.WINNER))
  393.     1    CALL NEWSTA(LAMP,0,LROOM,0,0)    !RESTORE LAMP.
  394. C
  395. C NOW REDISTRIBUTE HIS VALUABLES AND OTHER BELONGINGS.
  396. C
  397. C THE LAMP HAS BEEN PLACED IN THE LIVING ROOM.
  398. C THE FIRST 8 NON-VALUABLES ARE PLACED IN LOCATIONS AROUND THE HOUSE.
  399. C HIS VALUABLES ARE PLACED AT THE END OF THE MAZE.
  400. C REMAINING NON-VALUABLES ARE PLACED AT THE END OF THE MAZE.
  401. C
  402.     I=1
  403.     DO 200 J=1,OLNT                !LOOP THRU OBJECTS.
  404.       IF((OADV(J).NE.WINNER).OR.(OTVAL(J).NE.0))
  405.     1    GO TO 200            !GET HIS NON-VAL OBJS.
  406.       I=I+1
  407.       IF(I.GT.9) GO TO 400            !MOVE TO RANDOM LOCATIONS.
  408.       CALL NEWSTA(J,0,RLIST(I),0,0)
  409. 200    CONTINUE
  410. C
  411. 400    I=RLNT+1                !NOW MOVE VALUABLES.
  412.     NONOFL=RAIR+RWATER+RSACRD+REND        !DONT MOVE HERE.
  413.     DO 300 J=1,OLNT
  414.       IF((OADV(J).NE.WINNER).OR.(OTVAL(J).EQ.0))
  415.     1    GO TO 300            !ON ADV AND VALUABLE?
  416. 250      I=I-1                    !FIND NEXT ROOM.
  417.       IF((RFLAG(I).AND.NONOFL).NE.0) GO TO 250    !SKIP IF NONO.
  418.       CALL NEWSTA(J,0,I,0,0)        !YES, MOVE.
  419. 300    CONTINUE
  420. C
  421.     DO 500 J=1,OLNT                !NOW GET RID OF REMAINDER.
  422.       IF(OADV(J).NE.WINNER) GO TO 500
  423. 450      I=I-1                    !FIND NEXT ROOM.
  424.       IF((RFLAG(I).AND.NONOFL).NE.0) GO TO 450    !SKIP IF NONO.
  425.       CALL NEWSTA(J,0,I,0,0)
  426. 500    CONTINUE
  427.     RETURN
  428. C
  429. C CANT OR WONT CONTINUE, CLEAN UP AND EXIT.
  430. C
  431. 900    CALL RSPEAK(625)            !IN ENDGAME, LOSE.
  432.     GO TO 1100
  433. C
  434. 1000    CALL RSPEAK(7)                !INVOLUNTARY EXIT.
  435. 1100    CALL SCORE(.FALSE.)            !TELL SCORE.
  436.     CLOSE (UNIT=DBCH)
  437.     CALL EXIT
  438. C
  439.     END
  440. C OACTOR-    GET ACTOR ASSOCIATED WITH OBJECT
  441. C
  442. C DECLARATIONS
  443. C
  444.     INTEGER FUNCTION OACTOR(OBJ)
  445.     IMPLICIT INTEGER(A-Z)
  446. C
  447. C ADVENTURERS
  448. C
  449.     COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
  450.     1    AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
  451. C
  452.     DO 100 I=1,ALNT                !LOOP THRU ACTORS.
  453.       OACTOR=I                !ASSUME FOUND.
  454.       IF(AOBJ(I).EQ.OBJ) RETURN        !FOUND IT?
  455. 100    CONTINUE
  456.     CALL BUG(40,OBJ)            !NO, DIE.
  457.     RETURN
  458.     END
  459. C PROB-        COMPUTE PROBABILITY
  460. C
  461. C DECLARATIONS
  462. C
  463.     LOGICAL FUNCTION PROB(G,B)
  464.     IMPLICIT INTEGER(A-Z)
  465. C
  466. C FLAGS
  467. C
  468.     LOGICAL*1 TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF
  469.     LOGICAL*1 DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF
  470.     LOGICAL*1 MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF
  471.     LOGICAL*1 EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF
  472.     LOGICAL*1 GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF
  473.     LOGICAL*1 GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF
  474.     LOGICAL*1 MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF
  475.     LOGICAL*1 FOLLWF,SPELLF,CPOUTF,CPUSHF
  476.     COMMON /FINDEX/ TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF,
  477.     1    DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF,
  478.     2    MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF,
  479.     3    EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF,
  480.     4    GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF,
  481.     5    GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF,
  482.     6    MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF,
  483.     7    FOLLWF,SPELLF,CPOUTF,CPUSHF
  484.     COMMON /FINDEX/ BTIEF,BINFF
  485.     COMMON /FINDEX/ RVMNT,RVCLR,RVCYC,RVSND,RVGUA
  486.     COMMON /FINDEX/ ORRUG,ORCAND,ORMTCH,ORLAMP
  487.     COMMON /FINDEX/ MDIR,MLOC,POLEUF
  488.     COMMON /FINDEX/ QUESNO,NQATT,CORRCT
  489.     COMMON /FINDEX/ LCELL,PNUMB,ACELL,DCELL,CPHERE
  490. C
  491.     I=G                    !ASSUME GOOD LUCK.
  492.     IF(BADLKF) I=B                !IF BAD, TOO BAD.
  493.     PROB=RND(100).LT.I            !COMPUTE.
  494.     RETURN
  495.     END
  496. C RMDESC-- PRINT ROOM DESCRIPTION
  497. C
  498. C RMDESC PRINTS A DESCRIPTION OF THE CURRENT ROOM.
  499. C IT IS ALSO THE PROCESSOR FOR VERBS 'LOOK' AND 'EXAMINE'.
  500. C
  501.     LOGICAL FUNCTION RMDESC(FULL)
  502. C
  503. C FULL=    0/1/2/3=    SHORT/OBJ/ROOM/FULL
  504. C
  505. C DECLARATIONS
  506. C
  507.     IMPLICIT INTEGER (A-Z)
  508.     LOGICAL PROB,LIT,RAPPLI
  509. C
  510. C PARSER OUTPUT
  511. C
  512.     LOGICAL PRSWON
  513.     COMMON /PRSVEC/ PRSA,PRSI,PRSO,PRSWON,PRSCON
  514. C
  515. C GAME STATE
  516. C
  517.     LOGICAL TELFLG
  518.     COMMON /PLAY/ WINNER,HERE,TELFLG
  519. C
  520. C SCREEN OF LIGHT
  521. C
  522.     COMMON /SCREEN/ FROMDR,SCOLRM,SCOLAC
  523. C
  524. C ROOMS
  525. C
  526.     COMMON /ROOMS/ RLNT,RDESC2,RDESC1(200),REXIT(200),
  527.     1    RACTIO(200),RVAL(200),RFLAG(200)
  528.     INTEGER RRAND(200)
  529.     EQUIVALENCE (RVAL,RRAND)
  530. C
  531.     COMMON /RFLAG/ RSEEN,RLIGHT,RLAND,RWATER,RAIR,
  532.     1    RSACRD,RFILL,RMUNG,RBUCK,RHOUSE,RNWALL,REND
  533. C
  534.     COMMON /XSRCH/ XMIN,XMAX,XDOWN,XUP,
  535.     1    XNORTH,XSOUTH,XENTER,XEXIT,XEAST,XWEST
  536. C
  537. C OBJECTS
  538. C
  539.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  540.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  541.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  542.     3    OADV(220),OCAN(220),OREAD(220)
  543. C
  544. C ADVENTURERS
  545. C
  546.     COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
  547.     1    AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
  548. C
  549.     COMMON /AINDEX/ PLAYER,AROBOT,AMASTR
  550. C
  551. C VERBS
  552. C
  553.     COMMON /VINDEX/ CINTW,DEADXW,FRSTQW,INXW,OUTXW
  554.     COMMON /VINDEX/ WALKIW,FIGHTW,FOOW
  555.     COMMON /VINDEX/ MELTW,READW,INFLAW,DEFLAW,ALARMW,EXORCW
  556.     COMMON /VINDEX/ PLUGW,KICKW,WAVEW,RAISEW,LOWERW,RUBW
  557.     COMMON /VINDEX/ PUSHW,UNTIEW,TIEW,TIEUPW,TURNW,BREATW
  558.     COMMON /VINDEX/ KNOCKW,LOOKW,EXAMIW,SHAKEW,MOVEW,TRNONW,TRNOFW
  559.     COMMON /VINDEX/ OPENW,CLOSEW,FINDW,WAITW,SPINW,BOARDW,UNBOAW,TAKEW
  560.     COMMON /VINDEX/ INVENW,FILLW,EATW,DRINKW,BURNW
  561.     COMMON /VINDEX/ MUNGW,KILLW,ATTACW,SWINGW
  562.     COMMON /VINDEX/ WALKW,TELLW,PUTW,DROPW,GIVEW,POURW,THROWW
  563.     COMMON /VINDEX/ DIGW,LEAPW,STAYW,FOLLOW
  564.     COMMON /VINDEX/ HELLOW,LOOKIW,LOOKUW,PUMPW,WINDW
  565.     COMMON /VINDEX/ CLMBW,CLMBUW,CLMBDW,TRNTOW
  566. C
  567. C FLAGS
  568. C
  569.     LOGICAL*1 TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF
  570.     LOGICAL*1 DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF
  571.     LOGICAL*1 MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF
  572.     LOGICAL*1 EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF
  573.     LOGICAL*1 GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF
  574.     LOGICAL*1 GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF
  575.     LOGICAL*1 MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF
  576.     LOGICAL*1 FOLLWF,SPELLF,CPOUTF,CPUSHF
  577.     COMMON /FINDEX/ TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF,
  578.     1    DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF,
  579.     2    MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF,
  580.     3    EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF,
  581.     4    GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF,
  582.     5    GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF,
  583.     6    MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF,
  584.     7    FOLLWF,SPELLF,CPOUTF,CPUSHF
  585.     COMMON /FINDEX/ BTIEF,BINFF
  586.     COMMON /FINDEX/ RVMNT,RVCLR,RVCYC,RVSND,RVGUA
  587.     COMMON /FINDEX/ ORRUG,ORCAND,ORMTCH,ORLAMP
  588.     COMMON /FINDEX/ MDIR,MLOC,POLEUF
  589.     COMMON /FINDEX/ QUESNO,NQATT,CORRCT
  590.     COMMON /FINDEX/ LCELL,PNUMB,ACELL,DCELL,CPHERE
  591. C RMDESC, PAGE 2
  592. C
  593.     RMDESC=.TRUE.                !ASSUME WINS.
  594.     IF(PRSO.LT.XMIN) GO TO 50        !IF DIRECTION,
  595.     FROMDR=PRSO                !SAVE AND
  596.     PRSO=0                    !CLEAR.
  597. 50    IF(HERE.EQ.AROOM(PLAYER)) GO TO 100    !PLAYER JUST MOVE?
  598.     CALL RSPEAK(2)                !NO, JUST SAY DONE.
  599.     PRSA=WALKIW                !SET UP WALK IN ACTION.
  600.     RETURN
  601. C
  602. 100    IF(LIT(HERE)) GO TO 300            !LIT?
  603.     CALL RSPEAK(430)            !WARN OF GRUE.
  604.     RMDESC=.FALSE.
  605.     RETURN
  606. C
  607. 300    RA=RACTIO(HERE)                !GET ROOM ACTION.
  608.     IF(FULL.EQ.1) GO TO 600            !OBJ ONLY?
  609.     I=RDESC2-HERE                !ASSUME SHORT DESC.
  610.     IF((FULL.EQ.0)
  611.     1    .AND. (SUPERF.OR.(((RFLAG(HERE).AND.RSEEN).NE.0)
  612.     1    .AND. (BRIEFF.OR.PROB(80,80))))) GO TO 400
  613.     I=RDESC1(HERE)                !USE LONG.
  614.     IF((I.NE.0).OR.(RA.EQ.0)) GO TO 400    !IF GOT DESC, SKIP.
  615.     PRSA=LOOKW                !PRETEND LOOK AROUND.
  616.     IF(.NOT.RAPPLI(RA)) GO TO 100        !ROOM HANDLES, NEW DESC?
  617.     PRSA=FOOW                !NOP PARSER.
  618.     GO TO 500
  619. C
  620. 400    CALL RSPEAK(I)                !OUTPUT DESCRIPTION.
  621. 500    IF(AVEHIC(WINNER).NE.0) CALL RSPSUB(431,ODESC2(AVEHIC(WINNER)))
  622. C
  623. 600    IF(FULL.NE.2) CALL PRINCR(FULL.NE.0,HERE)
  624.     RFLAG(HERE)=RFLAG(HERE).OR.RSEEN    !INDICATE ROOM SEEN.
  625.     IF((FULL.NE.0).OR.(RA.EQ.0)) RETURN    !ANYTHING MORE?
  626.     PRSA=WALKIW                !GIVE HIM A SURPISE.
  627.     IF(.NOT.RAPPLI(RA)) GO TO 100        !ROOM HANDLES, NEW DESC?
  628.     PRSA=FOOW
  629.     RETURN
  630. C
  631.     END
  632. C RAPPLI-    ROUTING ROUTINE FOR ROOM APPLICABLES
  633. C
  634. C DECLARATIONS
  635. C
  636.     LOGICAL FUNCTION RAPPLI(RI)
  637.     IMPLICIT INTEGER(A-Z)
  638.     LOGICAL RAPPL1,RAPPL2
  639.     DATA NEWRMS/38/
  640. C
  641.     RAPPLI=.TRUE.                !ASSUME WINS.
  642.     IF(RI.EQ.0) RETURN            !IF ZERO, WIN.
  643.     IF(RI.LT.NEWRMS) RAPPLI=RAPPL1(RI)    !IF OLD, PROCESSOR 1.
  644.     IF(RI.GE.NEWRMS) RAPPLI=RAPPL2(RI)    !IF NEW, PROCESSOR 2.
  645.     RETURN
  646.     END
  647.