home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / games / vmsnet / dungeon / part24 < prev    next >
Encoding:
Internet Message Format  |  1992-02-23  |  47.0 KB
  1. Path: uunet!paladin.american.edu!gatech!nntp.msstate.edu!emory!dragon.com!cts
  2. From: cts@dragon.com
  3. Newsgroups: vmsnet.sources.games
  4. Subject: Dungeon Part 24/30
  5. Message-ID: <1992Feb24.013538.817@dragon.com>
  6. Date: 24 Feb 92 06:35:38 GMT
  7. Organization: Computer Projects Unlimited
  8. Lines: 1655
  9.  
  10. -+-+-+-+-+-+-+-+ START OF PART 24 -+-+-+-+-+-+-+-+
  11. X      CALL RSPEAK(6)
  12. XC                                               !SCOLD.
  13. X      GO TO 100
  14. XC
  15. X200   YESNO=.TRUE.
  16. XC                                               !YES,
  17. X      CALL RSPEAK(Y)
  18. XC                                               !OUT WITH IT.
  19. X      RETURN
  20. XC
  21. X300   YESNO=.FALSE.
  22. XC                                               !NO,
  23. X      CALL RSPEAK(N)
  24. XC                                               !LIKEWISE.
  25. X      RETURN
  26. XC
  27. X      END
  28. $ CALL UNPACK [.SRC]DSO3.FOR;1 907628295
  29. $ create 'f'
  30. XC ROBADV-- STEAL WINNER'S VALUABLES
  31. XC
  32. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  33. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  34. XC WRITTEN BY R. M. SUPNIK
  35. XC
  36. XC DECLARATIONS
  37. XC
  38. X      INTEGER FUNCTION ROBADV(ADV,NR,NC,NA)
  39. X      IMPLICIT INTEGER (A-Z)
  40. X
  41. X      INCLUDE 'OBJECTS.LIB'
  42. X      INCLUDE 'OFLAGS.LIB'
  43. XC
  44. X      ROBADV=0
  45. XC                                               !COUNT OBJECTS
  46. X      DO 100 I=1,OLNT
  47. X        IF((OADV(I).NE.ADV).OR.(OTVAL(I).LE.0).OR.
  48. X     &          (and(OFLAG2(I),SCRDBT).NE.0)) GO TO 100
  49. X        CALL NEWSTA(I,0,NR,NC,NA)
  50. XC                                               !STEAL OBJECT
  51. X        ROBADV=ROBADV+1
  52. X100   CONTINUE
  53. X      RETURN
  54. X      END
  55. X`0C
  56. XC ROBRM-- STEAL ROOM VALUABLES
  57. XC
  58. XC DECLARATIONS
  59. XC
  60. X      INTEGER FUNCTION ROBRM(RM,PR,NR,NC,NA)
  61. X      IMPLICIT INTEGER (A-Z)
  62. X      LOGICAL PROB,QHERE
  63. X
  64. X      INCLUDE 'OBJECTS.LIB'
  65. X      INCLUDE 'OFLAGS.LIB'
  66. XC
  67. X      ROBRM=0
  68. XC                                               !COUNT OBJECTS
  69. X      DO 100 I=1,OLNT
  70. XC                                               !LOOP ON OBJECTS.
  71. X        IF(.NOT. QHERE(I,RM)) GO TO 100
  72. X        IF((OTVAL(I).LE.0).OR.(and(OFLAG2(I),SCRDBT).NE.0).OR.
  73. X     &          (and(OFLAG1(I),VISIBT).EQ.0).OR.(.NOT.PROB(PR,PR)))
  74. X     &          GO TO 50
  75. X        CALL NEWSTA(I,0,NR,NC,NA)
  76. X        ROBRM=ROBRM+1
  77. X        OFLAG2(I)=or(OFLAG2(I),TCHBT)
  78. X        GO TO 100
  79. X50      IF(and(OFLAG2(I),ACTRBT).NE.0)
  80. X     &    ROBRM=ROBRM+ROBADV(OACTOR(I),NR,NC,NA)
  81. X100   CONTINUE
  82. X      RETURN
  83. X      END
  84. X`0C
  85. XC WINNIN-- SEE IF VILLAIN IS WINNING
  86. XC
  87. XC DECLARATIONS
  88. XC
  89. X      LOGICAL FUNCTION WINNIN(VL,HR)
  90. X      IMPLICIT INTEGER (A-Z)
  91. X      LOGICAL PROB
  92. X
  93. X      INCLUDE 'OBJECTS.LIB'
  94. XC
  95. X      VS=OCAPAC(VL)
  96. XC                                               !VILLAIN STRENGTH
  97. X      PS=VS-FIGHTS(HR,.TRUE.)
  98. XC                                               !HIS MARGIN OVER HERO
  99. X      WINNIN=PROB(90,100)
  100. X      IF(PS.GT.3) RETURN
  101. XC                                               !+3... 90% WINNING
  102. X      WINNIN=PROB(75,85)
  103. X      IF(PS.GT.0) RETURN
  104. XC                                               !>0... 75% WINNING
  105. X      WINNIN=PROB(50,30)
  106. X      IF(PS.EQ.0) RETURN
  107. XC                                               !=0... 50% WINNING
  108. X      WINNIN=PROB(25,25)
  109. X      IF(VS.GT.1) RETURN
  110. XC                                               !ANY VILLAIN STRENGTH.
  111. X      WINNIN=PROB(10,0)
  112. X      RETURN
  113. X      END
  114. X`0C
  115. XC FIGHTS-- COMPUTE FIGHT STRENGTH
  116. XC
  117. XC DECLARATIONS
  118. XC
  119. X      INTEGER FUNCTION FIGHTS(H,FLG)
  120. X      IMPLICIT INTEGER (A-Z)
  121. X      LOGICAL FLG
  122. XC
  123. XC GAME STATE
  124. XC
  125. X      INCLUDE 'STATE.LIB'
  126. X      INCLUDE 'ADVERS.LIB'
  127. XC
  128. XC FUNCTIONS AND DATA
  129. XC
  130. X      DATA SMAX/7/,SMIN/2/
  131. XC
  132. X      FIGHTS=SMIN+((((SMAX-SMIN)*ASCORE(H))+(MXSCOR/2))/MXSCOR)
  133. X      IF(FLG) FIGHTS=FIGHTS+ASTREN(H)
  134. X      RETURN
  135. X      END
  136. X`0C
  137. XC VILSTR-       COMPUTE VILLAIN STRENGTH
  138. XC
  139. XC DECLARATIONS
  140. XC
  141. X      INTEGER FUNCTION VILSTR(V)
  142. X      IMPLICIT INTEGER (A-Z)
  143. X
  144. X      INCLUDE 'PARSER.LIB'
  145. X      INCLUDE 'OBJECTS.LIB'
  146. X      INCLUDE 'OFLAGS.LIB'
  147. X      INCLUDE 'OINDEX.LIB'
  148. X      INCLUDE 'VILLIANS.LIB'
  149. X      INCLUDE 'FLAGS.LIB'
  150. X`0C
  151. XC VILSTR, PAGE 2
  152. XC
  153. X      VILSTR=OCAPAC(V)
  154. X      IF(VILSTR.LE.0) RETURN
  155. X      IF((V.NE.THIEF).OR..NOT.THFENF) GO TO 100
  156. X      THFENF=.FALSE.
  157. XC                                               !THIEF UNENGROSSED.
  158. X      VILSTR=MIN0(VILSTR,2)
  159. XC                                               !NO BETTER THAN 2.
  160. XC
  161. X100     DO 200 I=1,VLNT
  162. XC                                               !SEE IF  BEST WEAPON.
  163. X        IF((VILLNS(I).EQ.V).AND.(PRSI.EQ.VBEST(I)))
  164. X     &    VILSTR=MAX0(1,VILSTR-1)
  165. X200   CONTINUE
  166. X      RETURN
  167. X      END
  168. $ CALL UNPACK [.SRC]DSO4.FOR;1 1364595686
  169. $ create 'f'
  170. XC
  171. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  172. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  173. XC WRITTEN BY R. M. SUPNIK
  174. XC
  175. XC GTTIME-- GET TOTAL TIME PLAYED
  176. XC
  177. XC DECLARATIONS
  178. XC
  179. X        SUBROUTINE GTTIME(T)
  180. X        IMPLICIT INTEGER(A-Z)
  181. XC
  182. X        COMMON /TIME/ PLTIME,SHOUR,SMIN,SSEC
  183. XC
  184. X        CALL ITIME(H,M,S)
  185. X        T=((H*60)+M)-((SHOUR*60)+SMIN)
  186. X        IF(T.LT.0) T=T+1440
  187. X        T=T+PLTIME
  188. X        RETURN
  189. X        END
  190. X`0C
  191. XC OPNCLS-- PROCESS OPEN/CLOSE FOR DOORS
  192. XC
  193. XC DECLARATIONS
  194. XC
  195. X      LOGICAL FUNCTION OPNCLS(OBJ,SO,SC)
  196. X      IMPLICIT INTEGER (A-Z)
  197. X      LOGICAL QOPEN
  198. X
  199. X      INCLUDE 'PARSER.LIB'
  200. X      INCLUDE 'OBJECTS.LIB'
  201. X      INCLUDE 'OFLAGS.LIB'
  202. X      INCLUDE 'VERBS.LIB'
  203. XC
  204. XC FUNCTIONS AND DATA
  205. XC
  206. X      QOPEN(O)=and(OFLAG2(O),OPENBT).NE.0
  207. XC
  208. X      OPNCLS=.TRUE.
  209. XC                                               !ASSUME WINS.
  210. X      IF(PRSA.EQ.CLOSEW) GO TO 100
  211. XC                                               !CLOSE?
  212. X      IF(PRSA.EQ.OPENW) GO TO 50
  213. XC                                               !OPEN?
  214. X      OPNCLS=.FALSE.
  215. XC                                               !LOSE
  216. X      RETURN
  217. XC
  218. X50    IF(QOPEN(OBJ)) GO TO 200
  219. XC                                               !OPEN... IS IT?
  220. X      CALL RSPEAK(SO)
  221. X      OFLAG2(OBJ)=or(OFLAG2(OBJ),OPENBT)
  222. X      RETURN
  223. XC
  224. X100   IF(.NOT.QOPEN(OBJ)) GO TO 200
  225. XC                                               !CLOSE... IS IT?
  226. X      CALL RSPEAK(SC)
  227. X      OFLAG2(OBJ)=and(OFLAG2(OBJ),not(OPENBT))
  228. X      RETURN
  229. XC
  230. X200   CALL RSPEAK(125+RND(3))
  231. XC                                               !DUMMY.
  232. X      RETURN
  233. X      END
  234. X`0C
  235. XC LIT-- IS ROOM LIT?
  236. XC
  237. XC DECLARATIONS
  238. XC
  239. X      LOGICAL FUNCTION LIT(RM)
  240. X      IMPLICIT INTEGER (A-Z)
  241. X      LOGICAL QHERE
  242. X
  243. X      INCLUDE 'ROOMS.LIB'
  244. X      INCLUDE 'RFLAG.LIB'
  245. X      INCLUDE 'OBJECTS.LIB'
  246. X      INCLUDE 'OFLAGS.LIB'
  247. X      INCLUDE 'ADVERS.LIB'
  248. XC
  249. X      LIT=.TRUE.
  250. XC                                               !ASSUME WINS
  251. X      IF(and(RFLAG(RM),RLIGHT).NE.0) RETURN
  252. XC
  253. X      DO 1000 I=1,OLNT
  254. XC                                               !LOOK FOR LIT OBJ
  255. X        IF(QHERE(I,RM)) GO TO 100
  256. XC                                               !IN ROOM?
  257. X        OA=OADV(I)
  258. XC                                               !NO
  259. X        IF(OA.LE.0) GO TO 1000
  260. XC                                               !ON ADV?
  261. X        IF(AROOM(OA).NE.RM) GO TO 1000
  262. XC                                               !ADV IN ROOM?
  263. XC
  264. XC OBJ IN ROOM OR ON ADV IN ROOM
  265. XC
  266. X100     IF(and(OFLAG1(I),ONBT).NE.0) RETURN
  267. X        IF((and(OFLAG1(I),VISIBT).EQ.0).OR.
  268. X     &     ((and(OFLAG1(I),TRANBT).EQ.0).AND.
  269. X     &     (and(OFLAG2(I),OPENBT).EQ.0))) GO TO 1000
  270. XC
  271. XC OBJ IS VISIBLE AND OPEN OR TRANSPARENT
  272. XC
  273. X        DO 500 J=1,OLNT
  274. X          IF((OCAN(J).EQ.I).AND.(and(OFLAG1(J),ONBT).NE.0))
  275. X     &          RETURN
  276. X500     CONTINUE
  277. X1000  CONTINUE
  278. X      LIT=.FALSE.
  279. X      RETURN
  280. X      END
  281. X`0C
  282. XC WEIGHT- RETURNS SUM OF WEIGHT OF QUALIFYING OBJECTS
  283. XC
  284. XC DECLARATIONS
  285. XC
  286. X      INTEGER FUNCTION WEIGHT(RM,CN,AD)
  287. X      IMPLICIT INTEGER (A-Z)
  288. X      LOGICAL QHERE
  289. X
  290. X      INCLUDE 'OBJECTS.LIB'
  291. XC
  292. X      WEIGHT=0
  293. X      DO 100 I=1,OLNT
  294. XC                                               !OMIT BIG FIXED ITEMS.
  295. X        IF(OSIZE(I).GE.10000) GO TO 100
  296. XC                                               !IF FIXED, FORGET IT.
  297. X        IF((QHERE(I,RM).AND.(RM.NE.0)).OR.
  298. X     &          ((OADV(I).EQ.AD).AND.(AD.NE.0))) GO TO 50
  299. X        J=I
  300. XC                                               !SEE IF CONTAINED.
  301. X25      J=OCAN(J)
  302. XC                                               !GET NEXT LEVEL UP.
  303. X        IF(J.EQ.0) GO TO 100
  304. XC                                               !END OF LIST?
  305. X        IF(J.NE.CN) GO TO 25
  306. X50      WEIGHT=WEIGHT+OSIZE(I)
  307. X100   CONTINUE
  308. X      RETURN
  309. X      END
  310. $ CALL UNPACK [.SRC]DSO5.FOR;1 642858250
  311. $ create 'f'
  312. XC GHERE--       IS GLOBAL ACTUALLY IN THIS ROOM?
  313. XC
  314. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  315. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  316. XC WRITTEN BY R. M. SUPNIK
  317. XC
  318. XC DECLARATIONS
  319. XC
  320. X      LOGICAL FUNCTION GHERE(OBJ,RM)
  321. X      IMPLICIT INTEGER(A-Z)
  322. X
  323. X      INCLUDE 'ROOMS.LIB'
  324. X      INCLUDE 'RFLAG.LIB'
  325. X      INCLUDE 'RINDEX.LIB'
  326. XC
  327. X      COMMON /STAR/ MBASE,STRBIT
  328. X`0C
  329. XC GHERE, PAGE 2
  330. XC
  331. X      GHERE=.TRUE.
  332. XC                                               !ASSUME WINS.
  333. X      GO TO (1000,1000,1000,1000,1000,1000,
  334. X     &       1000,1000,1000,1000,1000,
  335. X     &       2000,3000,4000,5000,5000,5000,6000,
  336. X     &       7000,8000,9000,9100,8000,10000,11000),OBJ-STRBIT
  337. X      CALL BUG(60,OBJ)
  338. XC
  339. XC 1000--        STARS ARE ALWAYS HERE
  340. XC
  341. X1000    RETURN
  342. XC
  343. XC 2000--        BIRD
  344. XC
  345. X2000  GHERE=((RM.GE.FORE1).AND.(RM.LT.CLEAR)).OR.(RM.EQ.MTREE)
  346. X      RETURN
  347. XC
  348. XC 3000--        TREE
  349. XC
  350. X3000  GHERE=((RM.GE.FORE1).AND.(RM.LT.CLEAR)).AND.(RM.NE.FORE3)
  351. X      RETURN
  352. XC
  353. XC 4000--        NORTH WALL
  354. XC
  355. X4000  GHERE=((RM.GE.BKVW).AND.(RM.LE.BKBOX)).OR.(RM.EQ.CPUZZ)
  356. X      RETURN
  357. XC
  358. XC 5000--        EAST, SOUTH, WEST WALLS
  359. XC
  360. X5000  GHERE=((RM.GE.BKVW).AND.(RM.LT.BKBOX)).OR.(RM.EQ.CPUZZ)
  361. X      RETURN
  362. XC
  363. XC 6000--        GLOBAL WATER
  364. XC
  365. X6000  GHERE=and(RFLAG(RM),(RWATER+RFILL)).NE.0
  366. X      RETURN
  367. XC
  368. XC 7000--        GLOBAL GUARDIANS
  369. XC
  370. X7000  GHERE=((RM.GE.MRC).AND.(RM.LE.MRD)).OR.
  371. X     &       ((RM.GE.MRCE).AND.(RM.LE.MRDW)).OR.(RM.EQ.INMIR)
  372. X      RETURN
  373. XC
  374. XC 8000--        ROSE/CHANNEL
  375. XC
  376. X8000  GHERE=((RM.GE.MRA).AND.(RM.LE.MRD)).OR.(RM.EQ.INMIR)
  377. X      RETURN
  378. XC
  379. XC 9000--        MIRROR
  380. XC 9100          PANEL
  381. XC
  382. X9100  IF(RM.EQ.FDOOR) RETURN
  383. XC                                               !PANEL AT FDOOR.
  384. X9000  GHERE=((RM.GE.MRA).AND.(RM.LE.MRC)).OR.
  385. X     &          ((RM.GE.MRAE).AND.(RM.LE.MRCW))
  386. X      RETURN
  387. XC
  388. XC 10000--       MASTER
  389. XC
  390. X10000 GHERE=(RM.EQ.FDOOR).OR.(RM.EQ.NCORR).OR.(RM.EQ.PARAP).OR.
  391. X     &          (RM.EQ.CELL)
  392. X      RETURN
  393. XC
  394. XC 11000--       LADDER
  395. XC
  396. X11000 GHERE=(RM.EQ.CPUZZ)
  397. X      RETURN
  398. XC
  399. X      END
  400. X`0C
  401. XC MRHERE--      IS MIRROR HERE?
  402. XC
  403. XC DECLARATIONS
  404. XC
  405. X      INTEGER FUNCTION MRHERE(RM)
  406. X      IMPLICIT INTEGER(A-Z)
  407. XC
  408. XC ROOMS
  409. X
  410. X      INCLUDE 'RINDEX.LIB'
  411. X      INCLUDE 'FLAGS.LIB'
  412. X`0C
  413. XC MRHERE, PAGE 2
  414. XC
  415. X      IF((RM.LT.MRAE).OR.(RM.GT.MRDW)) GO TO 100
  416. XC
  417. XC RM IS AN E-W ROOM, MIRROR MUST BE N-S (MDIR= 0 OR 180)
  418. XC
  419. X      MRHERE=1
  420. XC                                               !ASSUME MIRROR 1 HERE.
  421. X      IF(MOD(RM-MRAE,2).EQ.(MDIR/180)) MRHERE=2
  422. X      RETURN
  423. XC
  424. XC RM IS NORTH OR SOUTH OF MIRROR.  IF MIRROR IS N-S OR NOT
  425. XC WITHIN ONE ROOM OF RM, LOSE.
  426. XC
  427. X100   MRHERE=0
  428. X      IF((IABS(MLOC-RM).NE.1).OR.(MOD(MDIR,180).EQ.0)) RETURN
  429. XC
  430. XC RM IS WITHIN ONE OF MLOC, AND MDIR IS E-W
  431. XC
  432. X      MRHERE=1
  433. X      IF(((RM.LT.MLOC).AND.(MDIR.LT.180)).OR.
  434. X     &   ((RM.GT.MLOC).AND.(MDIR.GT.180))) MRHERE=2
  435. X      RETURN
  436. X      END
  437. $ CALL UNPACK [.SRC]DSO6.FOR;1 738401312
  438. $ create 'f'
  439. XC ENCRYP--      ENCRYPT PASSWORD
  440. XC
  441. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  442. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  443. XC WRITTEN BY R. M. SUPNIK
  444. XC
  445. XC DECLARATIONS
  446. XC
  447. X      SUBROUTINE ENCRYP(INW,OUTW)
  448. X      IMPLICIT INTEGER(A-Z)
  449. X      CHARACTER INW(6),OUTW(6)
  450. X      CHARACTER  KEYW(6),UKEYW(6)
  451. X      INTEGER UINW(6)
  452. X      DATA KEYW/'E','C','O','R','M','S'/
  453. XC
  454. X      UINWS=0
  455. XC                                               !UNBIASED INW SUM.
  456. X      UKEYWS=0
  457. XC                                               !UNBIASED KEYW SUM.
  458. X      J=1
  459. XC                                               !POINTER IN KEYWORD.
  460. X      DO 100 I=1,6
  461. XC                                               !UNBIAS, COMPUTE SUMS.
  462. X        UKEYW(I)=char(ichar(KEYW(I))-64)
  463. X        IF(INW(J).LE.char(64)) J=1
  464. X        UINW(I)=ichar(char(ichar(INW(J))-64))
  465. X        UKEYWS=UKEYWS+ichar(UKEYW(I))
  466. X        UINWS=UINWS+UINW(I)
  467. X        J=J+1
  468. X100   CONTINUE
  469. XC
  470. X      USUM=MOD(UINWS,8)+(8*MOD(UKEYWS,8))
  471. XC                                               !COMPUTE MASK.
  472. X      DO 200 I=1,6
  473. X        J=and(xor(xor(ichar(char(UINW(I))),ichar(UKEYW(I))),USUM),31)
  474. X        USUM=MOD(USUM+1,32)
  475. X        IF(J.GT.26) J=MOD(J,26)
  476. X        OUTW(I)=char(MAX0(1,J)+64)
  477. X200   CONTINUE
  478. X      RETURN
  479. XC
  480. X      END
  481. X`0C
  482. XC CPGOTO--      MOVE TO NEXT STATE IN PUZZLE ROOM
  483. XC
  484. XC DECLARATIONS
  485. XC
  486. X      SUBROUTINE CPGOTO(ST)
  487. X      IMPLICIT INTEGER(A-Z)
  488. XC
  489. X      COMMON /HYPER/ HFACTR
  490. X
  491. X      INCLUDE 'ROOMS.LIB'
  492. X      INCLUDE 'RFLAG.LIB'
  493. X      INCLUDE 'RINDEX.LIB'
  494. X      INCLUDE 'OBJECTS.LIB'
  495. X      INCLUDE 'OFLAGS.LIB'
  496. X      INCLUDE 'FLAGS.LIB'
  497. X`0C
  498. XC CPGOTO, PAGE 2
  499. XC
  500. X      RFLAG(CPUZZ)=and(RFLAG(CPUZZ),not(RSEEN))
  501. X      DO 100 I=1,OLNT
  502. XC                                               !RELOCATE OBJECTS.
  503. X        IF((OROOM(I).EQ.CPUZZ).AND.
  504. X     &     (and(OFLAG2(I),(ACTRBT+VILLBT)).EQ.0))
  505. X     &    CALL NEWSTA(I,0,CPHERE*HFACTR,0,0)
  506. X        IF(OROOM(I).EQ.(ST*HFACTR))
  507. X     &    CALL NEWSTA(I,0,CPUZZ,0,0)
  508. X100   CONTINUE
  509. X      CPHERE=ST
  510. X      RETURN
  511. XC
  512. X      END
  513. X`0C
  514. XC CPINFO--      DESCRIBE PUZZLE ROOM
  515. XC
  516. XC DECLARATIONS
  517. XC
  518. X      SUBROUTINE CPINFO(RMK,ST)
  519. X      IMPLICIT INTEGER(A-Z)
  520. X      INTEGER DGMOFT(8)
  521. X      CHARACTER  DGM(8),PICT(5),QMK
  522. XC
  523. X      COMMON /CHAN/ INPCH,OUTCH,DBCH
  524. XC
  525. XC PUZZLE ROOM
  526. XC
  527. X      COMMON /PUZZLE/ CPDR(16),CPWL(8),CPVEC(64)
  528. X
  529. X      INCLUDE 'FLAGS.LIB'
  530. XC
  531. XC FUNCTIONS AND LOCAL DATA
  532. XC
  533. XC
  534. X      DATA DGMOFT/-9,-8,-7,-1,1,7,8,9/
  535. X      DATA PICT/'SS','SS','SS','  ','MM'/
  536. X      DATA QMK/'??'/
  537. X`0C
  538. XC CPINFO, PAGE 2
  539. XC
  540. X      CALL RSPEAK(RMK)
  541. X      DO 100 I=1,8
  542. X        J=DGMOFT(I)
  543. X        DGM(I)=PICT(CPVEC(ST+J)+4)
  544. XC                                               !GET PICTURE ELEMENT.
  545. X        IF((IABS(J).EQ.1).OR.(IABS(J).EQ.8)) GO TO 100
  546. X        K=8
  547. X        IF(J.LT.0) K=-8
  548. XC                                               !GET ORTHO DIR.
  549. X        L=J-K
  550. X        IF((CPVEC(ST+K).NE.0).AND.(CPVEC(ST+L).NE.0))
  551. X     &    DGM(I)=QMK
  552. X100   CONTINUE
  553. X      WRITE(OUTCH,10) DGM
  554. XC
  555. X      IF(ST.EQ.10) CALL RSPEAK(870)
  556. XC                                               !AT HOLE?
  557. X      IF(ST.EQ.37) CALL RSPEAK(871)
  558. XC                                               !AT NICHE?
  559. X      I=872
  560. XC                                               !DOOR OPEN?
  561. X      IF(CPOUTF) I=873
  562. X      IF(ST.EQ.52) CALL RSPEAK(I)
  563. XC                                               !AT DOOR?
  564. X      IF(CPVEC(ST+1).EQ.-2) CALL RSPEAK(874)
  565. XC                                               !EAST LADDER?
  566. X      IF(CPVEC(ST-1).EQ.-3) CALL RSPEAK(875)
  567. XC                                               !WEST LADDER?
  568. X      RETURN
  569. XC
  570. X10    FORMAT('       `7C',A2,1X,A2,1X,A2,'`7C'/,
  571. X     &       ' West  `7C',A2,' .. ',A2,'`7C  East',/
  572. X     &       '       `7C',A2,1X,A2,1X,A2,'`7C')
  573. XC
  574. X      END
  575. $ CALL UNPACK [.SRC]DSO7.FOR;1 1929780502
  576. $ create 'f'
  577. XC RESIDENT SUBROUTINES FOR DUNGEON
  578. XC
  579. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  580. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  581. XC WRITTEN BY R. M. SUPNIK
  582. XC
  583. XC RSPEAK-- OUTPUT RANDOM MESSAGE ROUTINE
  584. XC
  585. XC CALLED BY--
  586. XC
  587. XC     CALL RSPEAK(MSGNUM)
  588. XC
  589. X      SUBROUTINE RSPEAK(N)
  590. X      IMPLICIT INTEGER(A-Z)
  591. XC
  592. X      CALL RSPSB2(N,0,0)
  593. X      RETURN
  594. X      END
  595. X`0C
  596. XC RSPSUB-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENT
  597. XC
  598. XC CALLED BY--
  599. XC
  600. XC     CALL RSPSUB(MSGNUM,SUBNUM)
  601. XC
  602. X      SUBROUTINE RSPSUB(N,S1)
  603. X      IMPLICIT INTEGER(A-Z)
  604. XC
  605. X      CALL RSPSB2(N,S1,0)
  606. X      RETURN
  607. X      END
  608. X`0C
  609. XC RSPSB2-- OUTPUT RANDOM MESSAGE WITH UP TO TWO SUBSTITUTABLE ARGUMENTS
  610. XC
  611. XC CALLED BY--
  612. XC
  613. XC     CALL RSPSB2(MSGNUM,SUBNUM1,SUBNUM2)
  614. XC
  615. X      SUBROUTINE    RSPSB2(N,S1,S2)
  616. X      IMPLICIT      INTEGER(A-Z)
  617. X      CHARACTER*74  B1,B2,B3
  618. X      INTEGER*2     OLDREC,NEWREC,JREC
  619. XC
  620. XC DECLARATIONS
  621. XC
  622. X      INCLUDE 'GAMESTATE.LIB'
  623. XC
  624. X      INCLUDE 'MINDEX.LIB'
  625. X      INCLUDE 'IO.LIB'
  626. XC
  627. XC CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE)
  628. XC TO ABSOLUTE RECORD NUMBERS.
  629. XC
  630. X      X=N
  631. XC                                               !SET UP WORK VARIABLES.
  632. X      Y=S1
  633. X      Z=S2
  634. X      IF(X.GT.0) X=RTEXT(X)
  635. XC                                               !IF >0, LOOK UP IN RTEXT.
  636. X      IF(Y.GT.0) Y=RTEXT(Y)
  637. X      IF(Z.GT.0) Z=RTEXT(Z)
  638. X      X=IABS(X)
  639. XC                                               !TAKE ABS VALUE.
  640. X      Y=IABS(Y)
  641. X      Z=IABS(Z)
  642. X      IF(X.EQ.0) RETURN
  643. XC                                               !ANYTHING TO DO?
  644. X      TELFLG=.TRUE.
  645. XC                                               !SAID SOMETHING.
  646. XC
  647. X      READ(UNIT=DBCH,REC=X) OLDREC,B1
  648. XC
  649. X100   DO 150 I=1,74
  650. X        X1=and(X,31)+I
  651. X        B1(I:I)=char(xor(ichar(B1(I:I)),X1))
  652. X150   CONTINUE
  653. XC
  654. X200   IF(Y.EQ.0) GO TO 400
  655. XC                                               !ANY SUBSTITUTABLE?
  656. X      DO 300 I=1,74
  657. XC                                               !YES, LOOK FOR #.
  658. X        IF(B1(I:I).EQ.'#') GO TO 1000
  659. X300   CONTINUE
  660. XC
  661. X400   DO 500 I=74,1,-1
  662. XC                                               !BACKSCAN FOR BLANKS.
  663. X        IF(B1(I:I).NE.' ') GO TO 600
  664. X500   CONTINUE
  665. XC
  666. X600   WRITE(OUTCH,650) (B1(J:J),J=1,I)
  667. X650   FORMAT(1X,74A1)
  668. X      X=X+1
  669. XC                                               !ON TO NEXT RECORD.
  670. X      READ(UNIT=DBCH,REC=X) NEWREC,B1
  671. X      IF(OLDREC.EQ.NEWREC) GO TO 100
  672. XC                                               !CONTINUATION?
  673. X      RETURN
  674. XC                                               !NO, EXIT.
  675. XC
  676. XC SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE.
  677. XC I IS INDEX OF # IN B1.
  678. XC Y IS NUMBER OF RECORD TO SUBSTITUTE.
  679. XC
  680. XC PROCEDURE:
  681. XC   1) COPY REST OF B1 TO B2
  682. XC   2) READ SUBSTITUTABLE OVER B1
  683. XC   3) RESTORE TAIL OF ORIGINAL B1
  684. XC
  685. XC THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING
  686. XC IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD).
  687. XC
  688. X1000  K2=1
  689. XC                                               !TO
  690. X      DO 1100 K1=I+1,74
  691. XC                                               !COPY REST OF B1.
  692. X        B2(K2:K2)=B1(K1:K1)
  693. X        K2=K2+1
  694. X1100  CONTINUE
  695. XC
  696. XC   READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT:
  697. XC
  698. X      READ(UNIT=DBCH,REC=Y) JREC,B3
  699. X      DO 1150 K1=1,74
  700. X        X1=and(Y,31)+K1
  701. X        B3(K1:K1)=char(xor(ICHAR(B3(K1:K1)),X1))
  702. X1150  CONTINUE
  703. XC
  704. XC   FILL REMAINDER OF B1 WITH CHARACTERS FROM B3:
  705. XC
  706. X      K2=1
  707. X      DO 1180 K1=I,74
  708. X        B1(K1:K1)=B3(K2:K2)
  709. X        K2=K2+1
  710. X1180  CONTINUE
  711. XC
  712. XC   FIND END OF SUBSTITUTE STRING IN B1:
  713. XC
  714. X      DO 1200 J=74,1,-1
  715. XC                                               !ELIM TRAILING BLANKS.
  716. X        IF(B1(J:J).NE.' ') GO TO 1300
  717. X1200  CONTINUE
  718. XC
  719. XC   PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING:
  720. XC
  721. X1300  K1=1
  722. XC                                               !FROM
  723. X      DO 1400 K2=J+1,74
  724. XC                                               !COPY REST OF B1 BACK.
  725. X        B1(K2:K2)=B2(K1:K1)
  726. X        K1=K1+1
  727. X1400  CONTINUE
  728. XC
  729. X      Y=Z
  730. XC                                               !SET UP FOR NEXT
  731. X      Z=0
  732. XC                                               !SUBSTITUTION AND
  733. X      GO TO 200
  734. XC                                               !RECHECK LINE.
  735. X      END
  736. X`0C
  737. XC OBJACT-- APPLY OBJECTS FROM PARSE VECTOR
  738. XC
  739. XC DECLARATIONS
  740. XC
  741. X      LOGICAL FUNCTION OBJACT(X)
  742. X      IMPLICIT INTEGER (A-Z)
  743. X      LOGICAL OAPPLI
  744. X
  745. X      INCLUDE 'PARSER.LIB'
  746. X      INCLUDE 'OBJECTS.LIB'
  747. XC
  748. X      OBJACT=.TRUE.
  749. XC                                               !ASSUME WINS.
  750. X      IF(PRSI.EQ.0) GO TO 100
  751. XC                                               !IND OBJECT?
  752. X      IF(OAPPLI(OACTIO(PRSI),0)) RETURN
  753. XC                                               !YES, LET IT HANDLE.
  754. XC
  755. X100   IF(PRSO.EQ.0) GO TO 200
  756. XC                                               !DIR OBJECT?
  757. X      IF(OAPPLI(OACTIO(PRSO),0)) RETURN
  758. XC                                               !YES, LET IT HANDLE.
  759. XC
  760. X200   OBJACT=.FALSE.
  761. XC                                               !LOSES.
  762. X      RETURN
  763. X      END
  764. X`0C
  765. XC BUG-- REPORT FATAL SYSTEM ERROR
  766. XC
  767. XC CALLED BY--
  768. XC
  769. XC     CALL BUG(NO,PAR)
  770. XC
  771. X      SUBROUTINE BUG(A,B)
  772. X      IMPLICIT INTEGER(A-Z)
  773. X
  774. X      INCLUDE 'DEBUG.LIB'
  775. XC
  776. X      PRINT 100,A,B
  777. X      IF(DBGFLG.NE.0) RETURN
  778. X      CALL EXIT
  779. XC
  780. X100   FORMAT(' PROGRAM ERROR ',I2,', PARAMETER=',I6)
  781. X      END
  782. X`0C
  783. XC NEWSTA-- SET NEW STATUS FOR OBJECT
  784. XC
  785. XC CALLED BY--
  786. XC
  787. XC     CALL NEWSTA(OBJECT,STRING,NEWROOM,NEWCON,NEWADV)
  788. XC
  789. X      SUBROUTINE NEWSTA(O,R,RM,CN,AD)
  790. X      IMPLICIT INTEGER(A-Z)
  791. X
  792. X      INCLUDE 'OBJECTS.LIB'
  793. XC
  794. X      CALL RSPEAK(R)
  795. X      OROOM(O)=RM
  796. X      OCAN(O)=CN
  797. X      OADV(O)=AD
  798. X      RETURN
  799. X      END
  800. X`0C
  801. XC QHERE-- TEST FOR OBJECT IN ROOM
  802. XC
  803. XC DECLARATIONS
  804. XC
  805. X      LOGICAL FUNCTION QHERE(OBJ,RM)
  806. X      IMPLICIT INTEGER (A-Z)
  807. X
  808. X      INCLUDE 'OBJECTS.LIB'
  809. XC
  810. X      QHERE=.TRUE.
  811. X      IF(OROOM(OBJ).EQ.RM) RETURN
  812. XC                                               !IN ROOM?
  813. X      DO 100 I=1,R2LNT
  814. XC                                               !NO, SCH ROOM2.
  815. X        IF((OROOM2(I).EQ.OBJ).AND.(RROOM2(I).EQ.RM)) RETURN
  816. X100   CONTINUE
  817. X      QHERE=.FALSE.
  818. XC                                               !NOT PRESENT.
  819. X      RETURN
  820. X      END
  821. X`0C
  822. XC QEMPTY-- TEST FOR OBJECT EMPTY
  823. XC
  824. XC DECLARATIONS
  825. XC
  826. X      LOGICAL FUNCTION QEMPTY(OBJ)
  827. X      IMPLICIT INTEGER (A-Z)
  828. X
  829. X      INCLUDE 'OBJECTS.LIB'
  830. XC
  831. X      QEMPTY=.FALSE.
  832. XC                                               !ASSUME LOSE.
  833. X      DO 100 I=1,OLNT
  834. X        IF(OCAN(I).EQ.OBJ) RETURN
  835. XC                                               !INSIDE TARGET?
  836. X100   CONTINUE
  837. X      QEMPTY=.TRUE.
  838. X      RETURN
  839. X      END
  840. X`0C
  841. XC JIGSUP- YOU ARE DEAD
  842. XC
  843. XC DECLARATIONS
  844. XC
  845. X      SUBROUTINE JIGSUP(DESC)
  846. X      IMPLICIT INTEGER (A-Z)
  847. X      LOGICAL YESNO,MOVETO,QHERE,F
  848. X      INTEGER RLIST(9)
  849. X
  850. X      INCLUDE 'PARSER.LIB'
  851. X      INCLUDE 'GAMESTATE.LIB'
  852. X      INCLUDE 'STATE.LIB'
  853. X      INCLUDE 'IO.LIB'
  854. X      INCLUDE 'DEBUG.LIB'
  855. X      INCLUDE 'ROOMS.LIB'
  856. X      INCLUDE 'RFLAG.LIB'
  857. X      INCLUDE 'RINDEX.LIB'
  858. X      INCLUDE 'OBJECTS.LIB'
  859. X      INCLUDE 'OFLAGS.LIB'
  860. X      INCLUDE 'OINDEX.LIB'
  861. X      INCLUDE 'ADVERS.LIB'
  862. X      INCLUDE 'FLAGS.LIB'
  863. XC
  864. XC FUNCTIONS AND DATA
  865. XC
  866. X      DATA RLIST/8,6,36,35,34,4,34,6,5/
  867. X`0C
  868. XC JIGSUP, PAGE 2
  869. XC
  870. X      CALL RSPEAK(DESC)
  871. XC                                               !DESCRIBE SAD STATE.
  872. X      PRSCON=1
  873. XC                                               !STOP PARSER.
  874. X      IF(DBGFLG.NE.0) RETURN
  875. XC                                               !IF DBG, EXIT.
  876. X      AVEHIC(WINNER)=0
  877. XC                                               !GET RID OF VEHICLE.
  878. X      IF(WINNER.EQ.PLAYER) GO TO 100
  879. XC                                               !HIMSELF?
  880. X      CALL RSPSUB(432,ODESC2(AOBJ(WINNER)))
  881. XC                                               !NO, SAY WHO DIED.
  882. X      CALL NEWSTA(AOBJ(WINNER),0,0,0,0)
  883. XC                                               !SEND TO HYPER SPACE.
  884. X      RETURN
  885. XC
  886. X100   IF(ENDGMF) GO TO 900
  887. XC                                               !NO RECOVERY IN END GAME.
  888. X      IF(DEATHS.GE.2) GO TO 1000
  889. XC                                               !DEAD TWICE? KICK HIM OFF.
  890. X      IF(.NOT.YESNO(10,9,8)) GO TO 1100
  891. XC                                               !CONTINUE?
  892. XC
  893. X      DO 50 J=1,OLNT
  894. XC                                               !TURN OFF FIGHTING.
  895. X        IF(QHERE(J,HERE))   OFLAG2(J)=and(OFLAG2(J),not(FITEBT))
  896. X50    CONTINUE
  897. XC
  898. X      DEATHS=DEATHS+1
  899. X      CALL SCRUPD(-10)
  900. XC                                               !CHARGE TEN POINTS.
  901. X      F=MOVETO(FORE1,WINNER)
  902. XC                                               !REPOSITION HIM.
  903. X      EGYPTF=.TRUE.
  904. XC                                               !RESTORE COFFIN.
  905. X      IF(OADV(COFFI).EQ.WINNER) CALL NEWSTA(COFFI,0,EGYPT,0,0)
  906. X      OFLAG2(DOOR)=and(OFLAG2(DOOR),not(TCHBT))
  907. X      OFLAG1(ROBOT)=and(or(OFLAG1(ROBOT),VISIBT),not(NDSCBT))
  908. X      IF((OROOM(LAMP).NE.0).OR.(OADV(LAMP).EQ.WINNER))
  909. X     &  CALL NEWSTA(LAMP,0,LROOM,0,0)
  910. XC
  911. XC NOW REDISTRIBUTE HIS VALUABLES AND OTHER BELONGINGS.
  912. XC
  913. XC THE LAMP HAS BEEN PLACED IN THE LIVING ROOM.
  914. XC THE FIRST 8 NON-VALUABLES ARE PLACED IN LOCATIONS AROUND THE HOUSE.
  915. XC HIS VALUABLES ARE PLACED AT THE END OF THE MAZE.
  916. XC REMAINING NON-VALUABLES ARE PLACED AT THE END OF THE MAZE.
  917. XC
  918. X      I=1
  919. X      DO 200 J=1,OLNT
  920. XC                                               !LOOP THRU OBJECTS.
  921. X        IF((OADV(J).NE.WINNER).OR.(OTVAL(J).NE.0))
  922. X     &          GO TO 200
  923. X        I=I+1
  924. X        IF(I.GT.9) GO TO 400
  925. XC                                               !MOVE TO RANDOM LOCATIONS.
  926. X        CALL NEWSTA(J,0,RLIST(I),0,0)
  927. X200   CONTINUE
  928. XC
  929. X400   I=RLNT+1
  930. XC                                               !NOW MOVE VALUABLES.
  931. X      NONOFL=RAIR+RWATER+RSACRD+REND
  932. XC                                               !DONT MOVE HERE.
  933. X      DO 300 J=1,OLNT
  934. X        IF((OADV(J).NE.WINNER).OR.(OTVAL(J).EQ.0))
  935. X     &    GO TO 300
  936. X250     I=I-1
  937. XC                                               !FIND NEXT ROOM.
  938. X        IF(and(RFLAG(I),NONOFL).NE.0) GO TO 250
  939. X        CALL NEWSTA(J,0,I,0,0)
  940. XC                                               !YES, MOVE.
  941. X300   CONTINUE
  942. XC
  943. X      DO 500 J=1,OLNT
  944. XC                                               !NOW GET RID OF REMAINDER.
  945. X        IF(OADV(J).NE.WINNER) GO TO 500
  946. X450     I=I-1
  947. XC                                               !FIND NEXT ROOM.
  948. X        IF(and(RFLAG(I),NONOFL).NE.0) GO TO 450
  949. X        CALL NEWSTA(J,0,I,0,0)
  950. X500   CONTINUE
  951. X      RETURN
  952. XC
  953. XC CAN'T OR WON'T CONTINUE, CLEAN UP AND EXIT.
  954. XC
  955. X900   CALL RSPEAK(625)
  956. XC                                               !IN ENDGAME, LOSE.
  957. X      GO TO 1100
  958. XC
  959. X1000  CALL RSPEAK(7)
  960. XC                                               !INVOLUNTARY EXIT.
  961. X1100  CALL SCORE(.FALSE.)
  962. XC                                               !TELL SCORE.
  963. X      CLOSE(DBCH)
  964. X      CALL EXIT
  965. XC
  966. X      END
  967. X`0C
  968. XC OACTOR-       GET ACTOR ASSOCIATED WITH OBJECT
  969. XC
  970. XC DECLARATIONS
  971. XC
  972. X      INTEGER FUNCTION OACTOR(OBJ)
  973. X      IMPLICIT INTEGER(A-Z)
  974. X
  975. X      INCLUDE 'ADVERS.LIB'
  976. XC
  977. X      DO 100 I=1,ALNT
  978. XC                                               !LOOP THRU ACTORS.
  979. X        OACTOR=I
  980. XC                                               !ASSUME FOUND.
  981. X        IF(AOBJ(I).EQ.OBJ) RETURN
  982. XC                                               !FOUND IT?
  983. X100   CONTINUE
  984. X      CALL BUG(40,OBJ)
  985. XC                                               !NO, DIE.
  986. X      RETURN
  987. X      END
  988. X`0C
  989. XC PROB-         COMPUTE PROBABILITY
  990. XC
  991. XC DECLARATIONS
  992. XC
  993. X      LOGICAL FUNCTION PROB(G,B)
  994. X      IMPLICIT INTEGER(A-Z)
  995. X
  996. X      INCLUDE 'FLAGS.LIB'
  997. XC
  998. X      I=G
  999. XC                                               !ASSUME GOOD LUCK.
  1000. X      IF(BADLKF) I=B
  1001. XC                                               !IF BAD, TOO BAD.
  1002. X      PROB=RND(100).LT.I
  1003. XC                                               !COMPUTE.
  1004. X      RETURN
  1005. X      END
  1006. X`0C
  1007. XC RMDESC-- PRINT ROOM DESCRIPTION
  1008. XC
  1009. XC RMDESC PRINTS A DESCRIPTION OF THE CURRENT ROOM.
  1010. XC IT IS ALSO THE PROCESSOR FOR VERBS 'LOOK' AND 'EXAMINE'.
  1011. XC
  1012. X      LOGICAL FUNCTION RMDESC(FULL)
  1013. XC
  1014. XC FULL= 0/1/2/3=        SHORT/OBJ/ROOM/FULL
  1015. XC
  1016. XC DECLARATIONS
  1017. XC
  1018. X      IMPLICIT INTEGER (A-Z)
  1019. X      LOGICAL LIT,RAPPLI
  1020. XC     LOGICAL PROB
  1021. X
  1022. X      INCLUDE 'PARSER.LIB'
  1023. X      INCLUDE 'GAMESTATE.LIB'
  1024. X      INCLUDE 'SCREEN.LIB'
  1025. X      INCLUDE 'ROOMS.LIB'
  1026. X      INCLUDE 'RFLAG.LIB'
  1027. X      INCLUDE 'XSRCH.LIB'
  1028. X      INCLUDE 'OBJECTS.LIB'
  1029. X      INCLUDE 'ADVERS.LIB'
  1030. X      INCLUDE 'VERBS.LIB'
  1031. X      INCLUDE 'FLAGS.LIB'
  1032. X`0C
  1033. XC RMDESC, PAGE 2
  1034. XC
  1035. X      RMDESC=.TRUE.
  1036. XC                                               !ASSUME WINS.
  1037. X      IF(PRSO.LT.XMIN) GO TO 50
  1038. XC                                               !IF DIRECTION,
  1039. X      FROMDR=PRSO
  1040. XC                                               !SAVE AND
  1041. X      PRSO=0
  1042. XC                                               !CLEAR.
  1043. X50    IF(HERE.EQ.AROOM(PLAYER)) GO TO 100
  1044. XC                                               !PLAYER JUST MOVE?
  1045. X      CALL RSPEAK(2)
  1046. XC                                               !NO, JUST SAY DONE.
  1047. X      PRSA=WALKIW
  1048. XC                                               !SET UP WALK IN ACTION.
  1049. X      RETURN
  1050. XC
  1051. X100   IF(LIT(HERE)) GO TO 300
  1052. XC                                               !LIT?
  1053. X      CALL RSPEAK(430)
  1054. XC                                               !WARN OF GRUE.
  1055. X      RMDESC=.FALSE.
  1056. X      RETURN
  1057. XC
  1058. X300   RA=RACTIO(HERE)
  1059. XC                                               !GET ROOM ACTION.
  1060. X      IF(FULL.EQ.1) GO TO 600
  1061. XC                                               !OBJ ONLY?
  1062. X      I=RDESC2-HERE
  1063. XC                                               !ASSUME SHORT DESC.
  1064. X      IF((FULL.EQ.0)
  1065. X     &   .AND.(SUPERF.OR.(((and(RFLAG(HERE),RSEEN)).NE.0)
  1066. XC
  1067. XC  The next line means that when you request VERBOSE mode, you
  1068. XC  only get long room descriptions 20% of the time. I don't either
  1069. XC  like or understand this, so the mod. ensures VERBOSE works
  1070. XC  all the time.                        jmh@ukc.ac.uk 22/10/87
  1071. XC
  1072. XC    &   .AND.(BRIEFF.OR.PROB(80,80))))) GO TO 400
  1073. X     &   .AND.BRIEFF))) GO TO 400
  1074. X      I=RDESC1(HERE)
  1075. XC                                               !USE LONG.
  1076. X      IF((I.NE.0).OR.(RA.EQ.0)) GO TO 400
  1077. XC                                               !IF GOT DESC, SKIP.
  1078. X      PRSA=LOOKW
  1079. XC                                               !PRETEND LOOK AROUND.
  1080. X      IF(.NOT.RAPPLI(RA)) GO TO 100
  1081. XC                                               !ROOM HANDLES, NEW DESC?
  1082. X      PRSA=FOOW
  1083. XC                                               !NOP PARSER.
  1084. X      GO TO 500
  1085. XC
  1086. X400   CALL RSPEAK(I)
  1087. XC                                               !OUTPUT DESCRIPTION.
  1088. X500   IF(AVEHIC(WINNER).NE.0) CALL RSPSUB(431,ODESC2(AVEHIC(WINNER)))
  1089. XC
  1090. X600   IF(FULL.NE.2) CALL PRINCR(FULL.NE.0,HERE)
  1091. X      RFLAG(HERE)=or(RFLAG(HERE),RSEEN)
  1092. X      IF((FULL.NE.0).OR.(RA.EQ.0)) RETURN
  1093. XC                                               !ANYTHING MORE?
  1094. X      PRSA=WALKIW
  1095. XC                                               !GIVE HIM A SURPISE.
  1096. X      IF(.NOT.RAPPLI(RA)) GO TO 100
  1097. XC                                               !ROOM HANDLES, NEW DESC?
  1098. X      PRSA=FOOW
  1099. X      RETURN
  1100. XC
  1101. X      END
  1102. X`0C
  1103. XC RAPPLI-       ROUTING ROUTINE FOR ROOM APPLICABLES
  1104. XC
  1105. XC DECLARATIONS
  1106. XC
  1107. X      LOGICAL FUNCTION RAPPLI(RI)
  1108. X      IMPLICIT INTEGER(A-Z)
  1109. X      LOGICAL RAPPL1,RAPPL2
  1110. X      DATA NEWRMS/38/
  1111. XC
  1112. X      RAPPLI=.TRUE.
  1113. XC                                               !ASSUME WINS.
  1114. X      IF(RI.EQ.0) RETURN
  1115. XC                                               !IF ZERO, WIN.
  1116. X      IF(RI.LT.NEWRMS) RAPPLI=RAPPL1(RI)
  1117. XC                                               !IF OLD, PROCESSOR 1.
  1118. X      IF(RI.GE.NEWRMS) RAPPLI=RAPPL2(RI)
  1119. XC                                               !IF NEW, PROCESSOR 2.
  1120. X      RETURN
  1121. X      END
  1122. $ CALL UNPACK [.SRC]DSUB.FOR;1 309946393
  1123. $ create 'f'
  1124. XC TAKE-- BASIC TAKE SEQUENCE
  1125. XC
  1126. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  1127. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  1128. XC WRITTEN BY R. M. SUPNIK
  1129. XC
  1130. XC TAKE AN OBJECT (FOR VERBS TAKE, PUT, DROP, READ, ETC.)
  1131. XC
  1132. X      LOGICAL FUNCTION TAKE(FLG)
  1133. XC
  1134. XC DECLARATIONS
  1135. XC
  1136. X      IMPLICIT INTEGER (A-Z)
  1137. X      LOGICAL FLG,OBJACT,OAPPLI,QOPEN,QHERE
  1138. X
  1139. X      INCLUDE 'PARSER.LIB'
  1140. X      INCLUDE 'GAMESTATE.LIB'
  1141. X      INCLUDE 'STATE.LIB'
  1142. X
  1143. X      COMMON /STAR/ MBASE,STRBIT
  1144. X
  1145. X      INCLUDE 'OBJECTS.LIB'
  1146. X      INCLUDE 'OFLAGS.LIB'
  1147. XC
  1148. X      INCLUDE 'ADVERS.LIB'
  1149. XC
  1150. XC FUNCTIONS AND DATA
  1151. XC
  1152. X      QOPEN(O)=(and(OFLAG2(O),OPENBT).NE.0)
  1153. X`0C
  1154. XC TAKE, PAGE 2
  1155. XC
  1156. X      TAKE=.FALSE.
  1157. XC                                               !ASSUME LOSES.
  1158. X      OA=OACTIO(PRSO)
  1159. XC                                               !GET OBJECT ACTION.
  1160. X      IF(PRSO.LE.STRBIT) GO TO 100
  1161. XC                                               !STAR?
  1162. X      TAKE=OBJACT(X)
  1163. XC                                               !YES, LET IT HANDLE.
  1164. X      RETURN
  1165. XC
  1166. X100   X=OCAN(PRSO)
  1167. XC                                               !INSIDE?
  1168. X      IF(PRSO.NE.AVEHIC(WINNER)) GO TO 400
  1169. XC                                               !HIS VEHICLE?
  1170. X      CALL RSPEAK(672)
  1171. XC                                               !DUMMY.
  1172. X      RETURN
  1173. XC
  1174. X400   IF(and(OFLAG1(PRSO),TAKEBT).NE.0) GO TO 500
  1175. X      IF(.NOT.OAPPLI(OA,0)) CALL RSPEAK(552+RND(5))
  1176. X      RETURN
  1177. XC
  1178. XC OBJECT IS TAKEABLE AND IN POSITION TO BE TAKEN.
  1179. XC
  1180. X500   IF((X.NE.0).OR. QHERE(PRSO,HERE)) GO TO 600
  1181. X      IF(OADV(PRSO).EQ.WINNER) CALL RSPEAK(557)
  1182. XC                                               !ALREADY GOT IT?
  1183. X      RETURN
  1184. XC
  1185. X600   IF(((X.NE.0).AND.(OADV(X).EQ.WINNER)).OR.
  1186. X     &   ((WEIGHT(0,PRSO,WINNER)+OSIZE(PRSO)).LE.MXLOAD))
  1187. X     &  GO TO 700
  1188. X      CALL RSPEAK(558)
  1189. XC                                               !TOO MUCH WEIGHT.
  1190. X      RETURN
  1191. XC
  1192. X700   TAKE=.TRUE.
  1193. XC                                               !AT LAST.
  1194. X      IF(OAPPLI(OA,0)) RETURN
  1195. XC                                               !DID IT HANDLE?
  1196. X      CALL NEWSTA(PRSO,0,0,0,WINNER)
  1197. XC                                               !TAKE OBJECT FOR WINNER.
  1198. X      OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
  1199. X      CALL SCRUPD(OFVAL(PRSO))
  1200. XC                                               !UPDATE SCORE.
  1201. X      OFVAL(PRSO)=0
  1202. XC                                               !CANT BE SCORED AGAIN.
  1203. X      IF(FLG) CALL RSPEAK(559)
  1204. XC                                               !TELL TAKEN.
  1205. X      RETURN
  1206. XC
  1207. X      END
  1208. X`0C
  1209. XC DROP- DROP VERB PROCESSOR
  1210. XC
  1211. XC DECLARATIONS
  1212. XC
  1213. X      LOGICAL FUNCTION DROP(Z)
  1214. X      IMPLICIT INTEGER (A-Z)
  1215. X      LOGICAL F,PUT,OBJACT
  1216. X
  1217. X      INCLUDE 'PARSER.LIB'
  1218. X      INCLUDE 'GAMESTATE.LIB'
  1219. XC
  1220. XC ROOMS
  1221. X      INCLUDE 'RINDEX.LIB'
  1222. X      INCLUDE 'OBJECTS.LIB'
  1223. X      INCLUDE 'OFLAGS.LIB'
  1224. XC
  1225. X      INCLUDE 'ADVERS.LIB'
  1226. X      INCLUDE 'VERBS.LIB'
  1227. X`0C
  1228. XC DROP, PAGE 2
  1229. XC
  1230. X      DROP=.TRUE.
  1231. XC                                               !ASSUME WINS.
  1232. X      X=OCAN(PRSO)
  1233. XC                                               !GET CONTAINER.
  1234. X      IF(X.EQ.0) GO TO 200
  1235. XC                                               !IS IT INSIDE?
  1236. X      IF(OADV(X).NE.WINNER) GO TO 1000
  1237. XC                                               !IS HE CARRYING CON?
  1238. X      IF(and(OFLAG2(X),OPENBT).NE.0) GO TO 300
  1239. X      CALL RSPSUB(525,ODESC2(X))
  1240. XC                                               !CANT REACH.
  1241. X      RETURN
  1242. XC
  1243. X200   IF(OADV(PRSO).NE.WINNER) GO TO 1000
  1244. XC                                               !IS HE CARRYING OBJ?
  1245. X300   IF(AVEHIC(WINNER).EQ.0) GO TO 400
  1246. XC                                               !IS HE IN VEHICLE?
  1247. X      PRSI=AVEHIC(WINNER)
  1248. XC                                               !YES,
  1249. X      F=PUT(.TRUE.)
  1250. XC                                               !DROP INTO VEHICLE.
  1251. X      PRSI=0
  1252. XC                                               !DISARM PARSER.
  1253. X      RETURN
  1254. XC                                               !DONE.
  1255. XC
  1256. X400   CALL NEWSTA(PRSO,0,HERE,0,0)
  1257. XC                                               !DROP INTO ROOM.
  1258. X      IF(HERE.EQ.MTREE) CALL NEWSTA(PRSO,0,FORE3,0,0)
  1259. X      CALL SCRUPD(OFVAL(PRSO))
  1260. XC                                               !SCORE OBJECT.
  1261. X      OFVAL(PRSO)=0
  1262. XC                                               !CANT BE SCORED AGAIN.
  1263. X      OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
  1264. XC
  1265. X      IF(OBJACT(X)) RETURN
  1266. XC                                               !DID IT HANDLE?
  1267. X      I=0
  1268. XC                                               !ASSUME NOTHING TO SAY.
  1269. X      IF(PRSA.EQ.DROPW) I=528
  1270. X      IF(PRSA.EQ.THROWW) I=529
  1271. X      IF((I.NE.0).AND.(HERE.EQ.MTREE)) I=659
  1272. X      CALL RSPSUB(I,ODESC2(PRSO))
  1273. X      RETURN
  1274. XC
  1275. X1000  CALL RSPEAK(527)
  1276. XC                                               !DONT HAVE IT.
  1277. X      RETURN
  1278. XC
  1279. X      END
  1280. X`0C
  1281. XC PUT- PUT VERB PROCESSOR
  1282. XC
  1283. XC DECLARATIONS
  1284. XC
  1285. X      LOGICAL FUNCTION PUT(FLG)
  1286. X      IMPLICIT INTEGER (A-Z)
  1287. X      LOGICAL TAKE,QOPEN,QHERE,OBJACT,FLG
  1288. X
  1289. X      INCLUDE 'PARSER.LIB'
  1290. X      INCLUDE 'GAMESTATE.LIB'
  1291. XC
  1292. XC MISCELLANEOUS VARIABLES
  1293. XC
  1294. X      COMMON /STAR/ MBASE,STRBIT
  1295. X
  1296. X      INCLUDE 'OBJECTS.LIB'
  1297. X      INCLUDE 'OFLAGS.LIB'
  1298. X      INCLUDE 'ADVERS.LIB'
  1299. X      INCLUDE 'VERBS.LIB'
  1300. XC
  1301. XC FUNCTIONS AND DATA
  1302. XC
  1303. X      QOPEN(R)=((and(OFLAG2(R),OPENBT)).NE.0)
  1304. X`0C
  1305. XC PUT, PAGE 2
  1306. XC
  1307. X      PUT=.FALSE.
  1308. X      IF((PRSO.LE.STRBIT).AND.(PRSI.LE.STRBIT)) GO TO 200
  1309. X      IF(.NOT.OBJACT(X)) CALL RSPEAK(560)
  1310. XC                                               !STAR
  1311. X      PUT=.TRUE.
  1312. X      RETURN
  1313. XC
  1314. X200   IF((QOPEN(PRSI))
  1315. X     &   .OR.(and(OFLAG1(PRSI),(DOORBT+CONTBT)).NE.0)
  1316. X     &   .OR.(and(OFLAG2(PRSI),VEHBT).NE.0)) GO TO 300
  1317. X      CALL RSPEAK(561)
  1318. XC                                               !CANT PUT IN THAT.
  1319. X      RETURN
  1320. XC
  1321. X300   IF(QOPEN(PRSI)) GO TO 400
  1322. XC                                               !IS IT OPEN?
  1323. X      CALL RSPEAK(562)
  1324. XC                                               !NO, JOKE
  1325. X      RETURN
  1326. XC
  1327. X400   IF(PRSO.NE.PRSI) GO TO 500
  1328. XC                                               !INTO ITSELF?
  1329. X      CALL RSPEAK(563)
  1330. XC                                               !YES, JOKE.
  1331. X      RETURN
  1332. XC
  1333. X500   IF(OCAN(PRSO).NE.PRSI) GO TO 600
  1334. XC                                               !ALREADY INSIDE.
  1335. X      CALL RSPSB2(564,ODESC2(PRSO),ODESC2(PRSI))
  1336. X      PUT=.TRUE.
  1337. X      RETURN
  1338. XC
  1339. X600   IF((WEIGHT(0,PRSO,0)+WEIGHT(0,PRSI,0)+OSIZE(PRSO))
  1340. X     &   .LE.OCAPAC(PRSI)) GO TO 700
  1341. X      CALL RSPEAK(565)
  1342. XC                                               !THEN CANT DO IT.
  1343. X      RETURN
  1344. XC
  1345. XC NOW SEE IF OBJECT (OR ITS CONTAINER) IS IN ROOM
  1346. XC
  1347. X700   J=PRSO
  1348. XC                                               !START SEARCH.
  1349. X725   IF(QHERE(J,HERE)) GO TO 750
  1350. XC                                               !IS IT HERE?
  1351. X      J=OCAN(J)
  1352. X      IF(J.NE.0) GO TO 725
  1353. XC                                               !MORE TO DO?
  1354. X      GO TO 800
  1355. XC                                               !NO, SCH FAILS.
  1356. XC
  1357. X750   SVO=PRSO
  1358. XC                                               !SAVE PARSER.
  1359. X      SVI=PRSI
  1360. X      PRSA=TAKEW
  1361. X      PRSI=0
  1362. X      IF(.NOT.TAKE(.FALSE.)) RETURN
  1363. XC                                               !TAKE OBJECT.
  1364. X      PRSA=PUTW
  1365. X      PRSO=SVO
  1366. X      PRSI=SVI
  1367. X      GO TO 1000
  1368. XC
  1369. XC NOW SEE IF OBJECT IS ON PERSON.
  1370. XC
  1371. X800   IF(OCAN(PRSO).EQ.0) GO TO 1000
  1372. XC                                               !INSIDE?
  1373. X      IF(QOPEN(OCAN(PRSO))) GO TO 900
  1374. XC                                               !OPEN?
  1375. X      CALL RSPSUB(566,ODESC2(PRSO))
  1376. XC                                               !LOSE.
  1377. X      RETURN
  1378. XC
  1379. X900   CALL SCRUPD(OFVAL(PRSO))
  1380. XC                                               !SCORE OBJECT.
  1381. X      OFVAL(PRSO)=0
  1382. X      OFLAG2(PRSO)=or(OFLAG2(PRSO),TCHBT)
  1383. X      CALL NEWSTA(PRSO,0,0,0,WINNER)
  1384. XC                                               !TEMPORARILY ON WINNER.
  1385. XC
  1386. X1000  IF(OBJACT(X)) RETURN
  1387. XC                                               !NO, GIVE OBJECT A SHOT.
  1388. X      CALL NEWSTA(PRSO,2,0,PRSI,0)
  1389. XC                                               !CONTAINED INSIDE.
  1390. X      PUT=.TRUE.
  1391. X      RETURN
  1392. XC
  1393. X      END
  1394. X`0C
  1395. XC VALUAC- HANDLES VALUABLES/EVERYTHING
  1396. XC
  1397. XC DECLARATIONS
  1398. XC
  1399. X      SUBROUTINE VALUAC(V)
  1400. X      IMPLICIT INTEGER (A-Z)
  1401. X      LOGICAL LIT,F,F1,TAKE,PUT,DROP,NOTVAL,QHERE
  1402. X
  1403. X      INCLUDE 'PARSER.LIB'
  1404. X      INCLUDE 'GAMESTATE.LIB'
  1405. X      INCLUDE 'OBJECTS.LIB'
  1406. X      INCLUDE 'OFLAGS.LIB'
  1407. X      INCLUDE 'VERBS.LIB'
  1408. XC
  1409. XC FUNCTIONS AND DATA
  1410. XC
  1411. X      NOTVAL(R)=(SAVEP.EQ.V).AND.(OTVAL(R).LE.0)
  1412. X`0C
  1413. XC VALUAC, PAGE 2
  1414. XC
  1415. X      F=.TRUE.
  1416. XC                                               !ASSUME NO ACTIONS.
  1417. X      I=579
  1418. XC                                               !ASSUME NOT LIT.
  1419. X      IF(.NOT.LIT(HERE)) GO TO 4000
  1420. XC                                               !IF NOT LIT, PUNT.
  1421. X      I=677
  1422. XC                                               !ASSUME WRONG VERB.
  1423. X      SAVEP=PRSO
  1424. XC                                               !SAVE PRSO.
  1425. X      SAVEH=HERE
  1426. XC                                               !SAVE HERE.
  1427. XC
  1428. X100   IF(PRSA.NE.TAKEW) GO TO 1000
  1429. XC                                               !TAKE EVERY/VALUA?
  1430. X      DO 500 PRSO=1,OLNT
  1431. XC                                               !LOOP THRU OBJECTS.
  1432. X        IF(.NOT.QHERE(PRSO,HERE).OR.
  1433. X     &     (and(OFLAG1(PRSO),VISIBT).EQ.0).OR.
  1434. X     &     (and(OFLAG2(PRSO),ACTRBT).NE.0).OR.
  1435. X     &     NOTVAL(PRSO)) GO TO 500
  1436. X        IF((and(OFLAG1(PRSO),TAKEBT).EQ.0).AND.
  1437. X     &     (and(OFLAG2(PRSO),TRYBT).EQ.0)) GO TO 500
  1438. X        F=.FALSE.
  1439. X        CALL RSPSUB(580,ODESC2(PRSO))
  1440. X        F1=TAKE(.TRUE.)
  1441. X        IF(SAVEH.NE.HERE) RETURN
  1442. X500   CONTINUE
  1443. X      GO TO 3000
  1444. XC
  1445. X1000  IF(PRSA.NE.DROPW) GO TO 2000
  1446. XC                                               !DROP EVERY/VALUA?
  1447. X      DO 1500 PRSO=1,OLNT
  1448. X        IF((OADV(PRSO).NE.WINNER).OR.NOTVAL(PRSO))
  1449. X     &          GO TO 1500
  1450. X        F=.FALSE.
  1451. X        CALL RSPSUB(580,ODESC2(PRSO))
  1452. X        F1=DROP(.TRUE.)
  1453. X        IF(SAVEH.NE.HERE) RETURN
  1454. X1500  CONTINUE
  1455. X      GO TO 3000
  1456. XC
  1457. X2000  IF(PRSA.NE.PUTW) GO TO 3000
  1458. XC                                               !PUT EVERY/VALUA?
  1459. X      DO 2500 PRSO=1,OLNT
  1460. XC                                               !LOOP THRU OBJECTS.
  1461. X        IF((OADV(PRSO).NE.WINNER)
  1462. X     &     .OR.(PRSO.EQ.PRSI).OR.NOTVAL(PRSO).OR.
  1463. X     &     (and(OFLAG1(PRSO),VISIBT).EQ.0)) GO TO 2500
  1464. X        F=.FALSE.
  1465. X        CALL RSPSUB(580,ODESC2(PRSO))
  1466. X        F1=PUT(.TRUE.)
  1467. X        IF(SAVEH.NE.HERE) RETURN
  1468. X2500  CONTINUE
  1469. XC
  1470. X3000  I=581
  1471. X      IF(SAVEP.EQ.V) I=582
  1472. XC                                               !CHOOSE MESSAGE.
  1473. X4000  IF(F) CALL RSPEAK(I)
  1474. XC                                               !IF NOTHING, REPORT.
  1475. X      RETURN
  1476. X      END
  1477. $ CALL UNPACK [.SRC]DVERB1.FOR;1 1063942022
  1478. $ create 'f'
  1479. XC SAVE- SAVE GAME STATE
  1480. XC
  1481. XC COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  1482. XC ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  1483. XC WRITTEN BY R. M. SUPNIK
  1484. XC
  1485. XC DECLARATIONS
  1486. XC
  1487. X      SUBROUTINE SAVEGM
  1488. X      IMPLICIT INTEGER (A-Z)
  1489. X
  1490. X      INCLUDE 'PARSER.LIB'
  1491. X      INCLUDE 'GAMESTATE.LIB'
  1492. X      INCLUDE 'STATE.LIB'
  1493. X      INCLUDE 'SCREEN.LIB'
  1494. X      INCLUDE 'PUZZLE.LIB'
  1495. X      INCLUDE 'ROOMS.LIB'
  1496. X      INCLUDE 'EXITS.LIB'
  1497. X      INCLUDE 'OBJECTS.LIB'
  1498. X      INCLUDE 'CLOCK.LIB'
  1499. X      INCLUDE 'VILLIANS.LIB'
  1500. X      INCLUDE 'ADVERS.LIB'
  1501. X      INCLUDE 'FLAGS.LIB'
  1502. XC
  1503. XC MISCELLANEOUS VARIABLES
  1504. XC
  1505. X      COMMON /VERS/ VMAJ,VMIN,VEDIT
  1506. X      COMMON /TIME/ PLTIME,SHOUR,SMIN,SSEC
  1507. XC
  1508. X      PRSWON=.FALSE.
  1509. XC                                               !DISABLE GAME.
  1510. X
  1511. X      OPEN (UNIT=1,file='dsave.dat',ACCESS='SEQUENTIAL',
  1512. X     &          status='UNKNOWN',FORM='UNFORMATTED',ERR=100)
  1513. X      rewind (unit=1, err=100)
  1514. XC
  1515. X      CALL GTTIME(I)
  1516. XC                                               !GET TIME.
  1517. X      WRITE(1) VMAJ,VMIN,VEDIT
  1518. X      WRITE(1) WINNER,HERE,THFPOS,TELFLG,THFFLG,THFACT,
  1519. X     &          SWDACT,SWDSTA,CPVEC
  1520. X      WRITE(1) I,MOVES,DEATHS,RWSCOR,EGSCOR,MXLOAD,
  1521. X     &          LTSHFT,BLOC,MUNGRM,HS,FROMDR,SCOLRM,SCOLAC
  1522. X      WRITE(1) ODESC1,ODESC2,OFLAG1,OFLAG2,OFVAL,OTVAL,
  1523. X     &          OSIZE,OCAPAC,OROOM,OADV,OCAN
  1524. X      WRITE(1) RVAL,RFLAG
  1525. X      WRITE(1) AROOM,ASCORE,AVEHIC,ASTREN,AFLAG
  1526. X      WRITE(1) FLAGS,SWITCH,VPROB,CFLAG,CTICK
  1527. XC
  1528. X      CLOSE(UNIT=1)
  1529. X      CALL RSPEAK(597)
  1530. X      RETURN
  1531. XC
  1532. X100     CALL RSPEAK(598)
  1533. XC                                               !CANT DO IT.
  1534. X      RETURN
  1535. X      END
  1536. X`0C
  1537. XC RESTORE- RESTORE GAME STATE
  1538. XC
  1539. XC DECLARATIONS
  1540. XC
  1541. X      SUBROUTINE RSTRGM
  1542. X      IMPLICIT INTEGER (A-Z)
  1543. X
  1544. X      INCLUDE 'PARSER.LIB'
  1545. X      INCLUDE 'GAMESTATE.LIB'
  1546. X      INCLUDE 'STATE.LIB'
  1547. X      INCLUDE 'SCREEN.LIB'
  1548. X      INCLUDE 'PUZZLE.LIB'
  1549. X      INCLUDE 'ROOMS.LIB'
  1550. X      INCLUDE 'EXITS.LIB'
  1551. X      INCLUDE 'OBJECTS.LIB'
  1552. X      INCLUDE 'CLOCK.LIB'
  1553. X      INCLUDE 'VILLIANS.LIB'
  1554. X      INCLUDE 'ADVERS.LIB'
  1555. X      INCLUDE 'FLAGS.LIB'
  1556. XC
  1557. XC MISCELLANEOUS VARIABLES
  1558. XC
  1559. X      COMMON /VERS/ VMAJ,VMIN,VEDIT
  1560. X      COMMON /TIME/ PLTIME,SHOUR,SMIN,SSEC
  1561. XC
  1562. X      PRSWON=.FALSE.
  1563. XC                                               !DISABLE GAME.
  1564. X
  1565. X      OPEN (UNIT=1,file='dsave.dat',ACCESS='SEQUENTIAL',
  1566. X     &            status='OLD',FORM='UNFORMATTED',ERR=100)
  1567. X      rewind (unit=1, err=100)
  1568. XC
  1569. X      READ(1) I,J,K
  1570. X      IF(or((I.NE.VMAJ),(J.NE.VMIN))) GO TO 200
  1571. XC
  1572. X      READ(1) WINNER,HERE,THFPOS,TELFLG,THFFLG,THFACT,
  1573. X     &        SWDACT,SWDSTA,CPVEC
  1574. X      READ(1) PLTIME,MOVES,DEATHS,RWSCOR,EGSCOR,MXLOAD,
  1575. X     &        LTSHFT,BLOC,MUNGRM,HS,FROMDR,SCOLRM,SCOLAC
  1576. X      READ(1) ODESC1,ODESC2,OFLAG1,OFLAG2,OFVAL,OTVAL,
  1577. X     &        OSIZE,OCAPAC,OROOM,OADV,OCAN
  1578. X      READ(1) RVAL,RFLAG
  1579. X      READ(1) AROOM,ASCORE,AVEHIC,ASTREN,AFLAG
  1580. X      READ(1) FLAGS,SWITCH,VPROB,CFLAG,CTICK
  1581. XC
  1582. X      CLOSE(UNIT=1)
  1583. X      CALL RSPEAK(599)
  1584. X      RETURN
  1585. XC
  1586. X100   CALL RSPEAK(598)
  1587. XC                                               !CANT DO IT.
  1588. X      RETURN
  1589. XC
  1590. X200   CALL RSPEAK(600)
  1591. XC                                               !OBSOLETE VERSION
  1592. X      CLOSE (UNIT=1)
  1593. X      RETURN
  1594. X      END
  1595. X`0C
  1596. XC WALK- MOVE IN SPECIFIED DIRECTION
  1597. XC
  1598. XC DECLARATIONS
  1599. XC
  1600. X      LOGICAL FUNCTION WALK(X)
  1601. X      IMPLICIT INTEGER(A-Z)
  1602. X      LOGICAL FINDXT,QOPEN,LIT,PROB,MOVETO,RMDESC
  1603. X
  1604. X      INCLUDE 'PARSER.LIB'
  1605. X      INCLUDE 'GAMESTATE.LIB'
  1606. X      INCLUDE 'ROOMS.LIB'
  1607. X      INCLUDE 'RFLAG.LIB'
  1608. X      INCLUDE 'CURXT.LIB'
  1609. X      INCLUDE 'XSRCH.LIB'
  1610. X      INCLUDE 'OBJECTS.LIB'
  1611. X      INCLUDE 'OFLAGS.LIB'
  1612. X      INCLUDE 'CLOCK.LIB'
  1613. X
  1614. X      INCLUDE 'VILLIANS.LIB'
  1615. X      INCLUDE 'ADVERS.LIB'
  1616. X      INCLUDE 'FLAGS.LIB'
  1617. XC
  1618. XC FUNCTIONS AND DATA
  1619. XC
  1620. X      QOPEN(O)=and(OFLAG2(O),OPENBT).NE.0
  1621. X`0C
  1622. XC WALK, PAGE 2
  1623. XC
  1624. X      WALK=.TRUE.
  1625. XC                                               !ASSUME WINS.
  1626. X      IF((WINNER.NE.PLAYER).OR.LIT(HERE).OR.PROB(25,25))
  1627. X     &  GO TO 500
  1628. X      IF(.NOT.FINDXT(PRSO,HERE)) GO TO 450
  1629. XC                                               !INVALID EXIT? GRUE
  1630. XC                                               !
  1631. X      GO TO (400,200,100,300),XTYPE
  1632. XC                                               !DECODE EXIT TYPE.
  1633. X      CALL BUG(9,XTYPE)
  1634. XC
  1635. X100   IF(CXAPPL(XACTIO).NE.0) GO TO 400
  1636. XC                                               !CEXIT... RETURNED ROOM?
  1637. X      IF(FLAGS(XFLAG)) GO TO 400
  1638. XC                                               !NO, FLAG ON?
  1639. X200   CALL JIGSUP(523)
  1640. XC                                               !BAD EXIT, GRUE
  1641. XC                                               !
  1642. X      RETURN
  1643. XC
  1644. X300   IF(CXAPPL(XACTIO).NE.0) GO TO 400
  1645. XC                                               !DOOR... RETURNED ROOM?
  1646. X      IF(QOPEN(XOBJ)) GO TO 400
  1647. XC                                               !NO, DOOR OPEN?
  1648. X      CALL JIGSUP(523)
  1649. XC                                               !BAD EXIT, GRUE
  1650. XC                                               !
  1651. X      RETURN
  1652. XC
  1653. X400   IF(LIT(XROOM1)) GO TO 900
  1654. XC                                               !VALID ROOM, IS IT LIT?
  1655. X450   CALL JIGSUP(522)
  1656. XC                                               !NO, GRUE
  1657. XC                                               !
  1658. X      RETURN
  1659. XC
  1660. XC ROOM IS LIT, OR WINNER IS NOT PLAYER (NO GRUE).
  1661. XC
  1662. X500   IF(FINDXT(PRSO,HERE)) GO TO 550
  1663. XC                                               !EXIT EXIST?
  1664. +-+-+-+-+-+-+-+-  END  OF PART 24 +-+-+-+-+-+-+-+-
  1665.