home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / games / volume2 / dungeon / part05 / dsub.F < prev    next >
Text File  |  1987-09-01  |  10KB  |  533 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 UP TO TWO SUBSTITUTABLE ARGUMENTS
  32. C
  33. C CALLED BY--
  34. C
  35. C    CALL RSPSB2(MSGNUM,SUBNUM1,SUBNUM2)
  36. C
  37.     SUBROUTINE    RSPSB2(N,S1,S2)
  38.     IMPLICIT      INTEGER(A-Z)
  39. #ifndef PDP
  40.     CHARACTER*74  B1,B2,B3
  41.     INTEGER*2     OLDREC,NEWREC,JREC
  42. #endif PDP
  43. C
  44. C DECLARATIONS
  45. C
  46. #include "gamestate.h"
  47. C
  48. #ifdef PDP
  49.     TELFLG=.TRUE.
  50. C
  51. C    use C routine to access data base
  52. C
  53.     call    rspsb3(N,S1,S2)
  54.     return
  55. #else
  56. #include "mindex.h"
  57. #include "io.h"
  58. C
  59. C CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE)
  60. C TO ABSOLUTE RECORD NUMBERS.
  61. C
  62.     X=N
  63. C                        !SET UP WORK VARIABLES.
  64.     Y=S1
  65.     Z=S2
  66.     IF(X.GT.0) X=RTEXT(X)
  67. C                        !IF >0, LOOK UP IN RTEXT.
  68.     IF(Y.GT.0) Y=RTEXT(Y)
  69.     IF(Z.GT.0) Z=RTEXT(Z)
  70.     X=IABS(X)
  71. C                        !TAKE ABS VALUE.
  72.     Y=IABS(Y)
  73.     Z=IABS(Z)
  74.     IF(X.EQ.0) RETURN
  75. C                        !ANYTHING TO DO?
  76.     TELFLG=.TRUE.
  77. C                        !SAID SOMETHING.
  78. C
  79.     READ(UNIT=DBCH,REC=X) OLDREC,B1
  80. C
  81. 100    DO 150 I=1,74
  82.       X1=and(X,31)+I
  83.       B1(I:I)=char(xor(ichar(B1(I:I)),X1))
  84. 150    CONTINUE
  85. C
  86. 200    IF(Y.EQ.0) GO TO 400
  87. C                        !ANY SUBSTITUTABLE?
  88.     DO 300 I=1,74
  89. C                        !YES, LOOK FOR #.
  90.       IF(B1(I:I).EQ.'#') GO TO 1000
  91. 300    CONTINUE
  92. C
  93. 400    DO 500 I=74,1,-1
  94. C                        !BACKSCAN FOR BLANKS.
  95.       IF(B1(I:I).NE.' ') GO TO 600
  96. 500    CONTINUE
  97. C
  98. 600    WRITE(OUTCH,650) (B1(J:J),J=1,I)
  99. 650    FORMAT(1X,74A1)
  100.     X=X+1
  101. C                        !ON TO NEXT RECORD.
  102.     READ(UNIT=DBCH,REC=X) NEWREC,B1
  103.     IF(OLDREC.EQ.NEWREC) GO TO 100
  104. C                        !CONTINUATION?
  105.     RETURN
  106. C                        !NO, EXIT.
  107. C
  108. C SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE.
  109. C I IS INDEX OF # IN B1.
  110. C Y IS NUMBER OF RECORD TO SUBSTITUTE.
  111. C
  112. C PROCEDURE:
  113. C   1) COPY REST OF B1 TO B2
  114. C   2) READ SUBSTITUTABLE OVER B1
  115. C   3) RESTORE TAIL OF ORIGINAL B1
  116. C
  117. C THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING
  118. C IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD).
  119. C
  120. 1000    K2=1
  121. C                        !TO
  122.     DO 1100 K1=I+1,74
  123. C                        !COPY REST OF B1.
  124.       B2(K2:K2)=B1(K1:K1)
  125.       K2=K2+1
  126. 1100    CONTINUE
  127. C
  128. C   READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT:
  129. C
  130.     READ(UNIT=DBCH,REC=Y) JREC,B3
  131.     DO 1150 K1=1,74
  132.       X1=and(Y,31)+K1
  133.       B3(K1:K1)=char(xor(ICHAR(B3(K1:K1)),X1))
  134. 1150    CONTINUE
  135. C
  136. C   FILL REMAINDER OF B1 WITH CHARACTERS FROM B3:
  137. C
  138.     K2=1
  139.     DO 1180 K1=I,74
  140.       B1(K1:K1)=B3(K2:K2)
  141.       K2=K2+1
  142. 1180    CONTINUE
  143. C
  144. C   FIND END OF SUBSTITUTE STRING IN B1:
  145. C
  146.     DO 1200 J=74,1,-1
  147. C                        !ELIM TRAILING BLANKS.
  148.       IF(B1(J:J).NE.' ') GO TO 1300
  149. 1200    CONTINUE
  150. C
  151. C   PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING:
  152. C
  153. 1300    K1=1
  154. C                        !FROM
  155.     DO 1400 K2=J+1,74
  156. C                        !COPY REST OF B1 BACK.
  157.       B1(K2:K2)=B2(K1:K1)
  158.       K1=K1+1
  159. 1400    CONTINUE
  160. C
  161.     Y=Z
  162. C                        !SET UP FOR NEXT
  163.     Z=0
  164. C                        !SUBSTITUTION AND
  165.     GO TO 200
  166. C                        !RECHECK LINE.
  167. #endif PDP
  168. C
  169.     END
  170. C OBJACT-- APPLY OBJECTS FROM PARSE VECTOR
  171. C
  172. C DECLARATIONS
  173. C
  174.     LOGICAL FUNCTION OBJACT(X)
  175.     IMPLICIT INTEGER (A-Z)
  176.     LOGICAL OAPPLI
  177. #include "parser.h"
  178. #include "objects.h"
  179. C
  180.     OBJACT=.TRUE.
  181. C                        !ASSUME WINS.
  182.     IF(PRSI.EQ.0) GO TO 100
  183. C                        !IND OBJECT?
  184.     IF(OAPPLI(OACTIO(PRSI),0)) RETURN
  185. C                        !YES, LET IT HANDLE.
  186. C
  187. 100    IF(PRSO.EQ.0) GO TO 200
  188. C                        !DIR OBJECT?
  189.     IF(OAPPLI(OACTIO(PRSO),0)) RETURN
  190. C                        !YES, LET IT HANDLE.
  191. C
  192. 200    OBJACT=.FALSE.
  193. C                        !LOSES.
  194.     RETURN
  195.     END
  196. #ifndef PDP
  197. C BUG-- REPORT FATAL SYSTEM ERROR
  198. C
  199. C CALLED BY--
  200. C
  201. C    CALL BUG(NO,PAR)
  202. C
  203.     SUBROUTINE BUG(A,B)
  204.     IMPLICIT INTEGER(A-Z)
  205. #include "debug.h"
  206. C
  207.     PRINT 100,A,B
  208.     IF(DBGFLG.NE.0) RETURN
  209.     CALL EXIT
  210. C
  211. 100    FORMAT(' PROGRAM ERROR ',I2,', PARAMETER=',I6)
  212.     END
  213. #endif PDP
  214. C NEWSTA-- SET NEW STATUS FOR OBJECT
  215. C
  216. C CALLED BY--
  217. C
  218. C    CALL NEWSTA(OBJECT,STRING,NEWROOM,NEWCON,NEWADV)
  219. C
  220.     SUBROUTINE NEWSTA(O,R,RM,CN,AD)
  221.     IMPLICIT INTEGER(A-Z)
  222. #include "objects.h"
  223. C
  224.     CALL RSPEAK(R)
  225.     OROOM(O)=RM
  226.     OCAN(O)=CN
  227.     OADV(O)=AD
  228.     RETURN
  229.     END
  230. C QHERE-- TEST FOR OBJECT IN ROOM
  231. C
  232. C DECLARATIONS
  233. C
  234.     LOGICAL FUNCTION QHERE(OBJ,RM)
  235.     IMPLICIT INTEGER (A-Z)
  236. #include "objects.h"
  237. C
  238.     QHERE=.TRUE.
  239.     IF(OROOM(OBJ).EQ.RM) RETURN
  240. C                        !IN ROOM?
  241.     DO 100 I=1,R2LNT
  242. C                        !NO, SCH ROOM2.
  243.       IF((OROOM2(I).EQ.OBJ).AND.(RROOM2(I).EQ.RM)) RETURN
  244. 100    CONTINUE
  245.     QHERE=.FALSE.
  246. C                        !NOT PRESENT.
  247.     RETURN
  248.     END
  249. C QEMPTY-- TEST FOR OBJECT EMPTY
  250. C
  251. C DECLARATIONS
  252. C
  253.     LOGICAL FUNCTION QEMPTY(OBJ)
  254.     IMPLICIT INTEGER (A-Z)
  255. #include "objects.h"
  256. C
  257.     QEMPTY=.FALSE.
  258. C                        !ASSUME LOSE.
  259.     DO 100 I=1,OLNT
  260.       IF(OCAN(I).EQ.OBJ) RETURN
  261. C                        !INSIDE TARGET?
  262. 100    CONTINUE
  263.     QEMPTY=.TRUE.
  264.     RETURN
  265.     END
  266. C JIGSUP- YOU ARE DEAD
  267. C
  268. C DECLARATIONS
  269. C
  270.     SUBROUTINE JIGSUP(DESC)
  271.     IMPLICIT INTEGER (A-Z)
  272.     LOGICAL YESNO,MOVETO,QHERE,F
  273.     INTEGER RLIST(9)
  274. #include "parser.h"
  275. #include "gamestate.h"
  276. #include "state.h"
  277. #include "io.h"
  278. #include "debug.h"
  279. #include "rooms.h"
  280. #include "rflag.h"
  281. #include "rindex.h"
  282. #include "objects.h"
  283. #include "oflags.h"
  284. #include "oindex.h"
  285. #include "advers.h"
  286. #include "flags.h"
  287. C
  288. C FUNCTIONS AND DATA
  289. C
  290.     DATA RLIST/8,6,36,35,34,4,34,6,5/
  291. C JIGSUP, PAGE 2
  292. C
  293.     CALL RSPEAK(DESC)
  294. C                        !DESCRIBE SAD STATE.
  295.     PRSCON=1
  296. C                        !STOP PARSER.
  297.     IF(DBGFLG.NE.0) RETURN
  298. C                        !IF DBG, EXIT.
  299.     AVEHIC(WINNER)=0
  300. C                        !GET RID OF VEHICLE.
  301.     IF(WINNER.EQ.PLAYER) GO TO 100
  302. C                        !HIMSELF?
  303.     CALL RSPSUB(432,ODESC2(AOBJ(WINNER)))
  304. C                        !NO, SAY WHO DIED.
  305.     CALL NEWSTA(AOBJ(WINNER),0,0,0,0)
  306. C                        !SEND TO HYPER SPACE.
  307.     RETURN
  308. C
  309. 100    IF(ENDGMF) GO TO 900
  310. C                        !NO RECOVERY IN END GAME.
  311.     IF(DEATHS.GE.2) GO TO 1000
  312. C                        !DEAD TWICE? KICK HIM OFF.
  313.     IF(.NOT.YESNO(10,9,8)) GO TO 1100
  314. C                        !CONTINUE?
  315. C
  316.     DO 50 J=1,OLNT
  317. C                        !TURN OFF FIGHTING.
  318.       IF(QHERE(J,HERE))   OFLAG2(J)=and(OFLAG2(J),not(FITEBT))
  319. 50    CONTINUE
  320. C
  321.     DEATHS=DEATHS+1
  322.     CALL SCRUPD(-10)
  323. C                        !CHARGE TEN POINTS.
  324.     F=MOVETO(FORE1,WINNER)
  325. C                        !REPOSITION HIM.
  326.     EGYPTF=.TRUE.
  327. C                        !RESTORE COFFIN.
  328.     IF(OADV(COFFI).EQ.WINNER) CALL NEWSTA(COFFI,0,EGYPT,0,0)
  329.     OFLAG2(DOOR)=and(OFLAG2(DOOR),not(TCHBT))
  330.     OFLAG1(ROBOT)=and(or(OFLAG1(ROBOT),VISIBT),not(NDSCBT))
  331.     IF((OROOM(LAMP).NE.0).OR.(OADV(LAMP).EQ.WINNER))
  332. &        CALL NEWSTA(LAMP,0,LROOM,0,0)
  333. C
  334. C NOW REDISTRIBUTE HIS VALUABLES AND OTHER BELONGINGS.
  335. C
  336. C THE LAMP HAS BEEN PLACED IN THE LIVING ROOM.
  337. C THE FIRST 8 NON-VALUABLES ARE PLACED IN LOCATIONS AROUND THE HOUSE.
  338. C HIS VALUABLES ARE PLACED AT THE END OF THE MAZE.
  339. C REMAINING NON-VALUABLES ARE PLACED AT THE END OF THE MAZE.
  340. C
  341.     I=1
  342.     DO 200 J=1,OLNT
  343. C                        !LOOP THRU OBJECTS.
  344.       IF((OADV(J).NE.WINNER).OR.(OTVAL(J).NE.0))
  345. &        GO TO 200
  346.       I=I+1
  347.       IF(I.GT.9) GO TO 400
  348. C                        !MOVE TO RANDOM LOCATIONS.
  349.       CALL NEWSTA(J,0,RLIST(I),0,0)
  350. 200    CONTINUE
  351. C
  352. 400    I=RLNT+1
  353. C                        !NOW MOVE VALUABLES.
  354.     NONOFL=RAIR+RWATER+RSACRD+REND
  355. C                        !DONT MOVE HERE.
  356.     DO 300 J=1,OLNT
  357.       IF((OADV(J).NE.WINNER).OR.(OTVAL(J).EQ.0))
  358. &        GO TO 300
  359. 250      I=I-1
  360. C                        !FIND NEXT ROOM.
  361.       IF(and(RFLAG(I),NONOFL).NE.0) GO TO 250
  362.       CALL NEWSTA(J,0,I,0,0)
  363. C                        !YES, MOVE.
  364. 300    CONTINUE
  365. C
  366.     DO 500 J=1,OLNT
  367. C                        !NOW GET RID OF REMAINDER.
  368.       IF(OADV(J).NE.WINNER) GO TO 500
  369. 450      I=I-1
  370. C                        !FIND NEXT ROOM.
  371.       IF(and(RFLAG(I),NONOFL).NE.0) GO TO 450
  372.       CALL NEWSTA(J,0,I,0,0)
  373. 500    CONTINUE
  374.     RETURN
  375. C
  376. C CAN'T OR WON'T CONTINUE, CLEAN UP AND EXIT.
  377. C
  378. 900    CALL RSPEAK(625)
  379. C                        !IN ENDGAME, LOSE.
  380.     GO TO 1100
  381. C
  382. 1000    CALL RSPEAK(7)
  383. C                        !INVOLUNTARY EXIT.
  384. 1100    CALL SCORE(.FALSE.)
  385. C                        !TELL SCORE.
  386. #ifdef PDP
  387. C    file closed in exit routine
  388. #else
  389.     CLOSE(DBCH)
  390. #endif PDP
  391.     CALL EXIT
  392. C
  393.     END
  394. C OACTOR-    GET ACTOR ASSOCIATED WITH OBJECT
  395. C
  396. C DECLARATIONS
  397. C
  398.     INTEGER FUNCTION OACTOR(OBJ)
  399.     IMPLICIT INTEGER(A-Z)
  400. #include "advers.h"
  401. C
  402.     DO 100 I=1,ALNT
  403. C                        !LOOP THRU ACTORS.
  404.       OACTOR=I
  405. C                        !ASSUME FOUND.
  406.       IF(AOBJ(I).EQ.OBJ) RETURN
  407. C                        !FOUND IT?
  408. 100    CONTINUE
  409.     CALL BUG(40,OBJ)
  410. C                        !NO, DIE.
  411.     RETURN
  412.     END
  413. C PROB-        COMPUTE PROBABILITY
  414. C
  415. C DECLARATIONS
  416. C
  417.     LOGICAL FUNCTION PROB(G,B)
  418.     IMPLICIT INTEGER(A-Z)
  419. #include "flags.h"
  420. C
  421.     I=G
  422. C                        !ASSUME GOOD LUCK.
  423.     IF(BADLKF) I=B
  424. C                        !IF BAD, TOO BAD.
  425.     PROB=RND(100).LT.I
  426. C                        !COMPUTE.
  427.     RETURN
  428.     END
  429. C RMDESC-- PRINT ROOM DESCRIPTION
  430. C
  431. C RMDESC PRINTS A DESCRIPTION OF THE CURRENT ROOM.
  432. C IT IS ALSO THE PROCESSOR FOR VERBS 'LOOK' AND 'EXAMINE'.
  433. C
  434.     LOGICAL FUNCTION RMDESC(FULL)
  435. C
  436. C FULL=    0/1/2/3=    SHORT/OBJ/ROOM/FULL
  437. C
  438. C DECLARATIONS
  439. C
  440.     IMPLICIT INTEGER (A-Z)
  441.     LOGICAL PROB,LIT,RAPPLI
  442. #include "parser.h"
  443. #include "gamestate.h"
  444. #include "screen.h"
  445. #include "rooms.h"
  446. #include "rflag.h"
  447. #include "xsrch.h"
  448. #include "objects.h"
  449. #include "advers.h"
  450. #include "verbs.h"
  451. #include "flags.h"
  452. C RMDESC, PAGE 2
  453. C
  454.     RMDESC=.TRUE.
  455. C                        !ASSUME WINS.
  456.     IF(PRSO.LT.XMIN) GO TO 50
  457. C                        !IF DIRECTION,
  458.     FROMDR=PRSO
  459. C                        !SAVE AND
  460.     PRSO=0
  461. C                        !CLEAR.
  462. 50    IF(HERE.EQ.AROOM(PLAYER)) GO TO 100
  463. C                        !PLAYER JUST MOVE?
  464.     CALL RSPEAK(2)
  465. C                        !NO, JUST SAY DONE.
  466.     PRSA=WALKIW
  467. C                        !SET UP WALK IN ACTION.
  468.     RETURN
  469. C
  470. 100    IF(LIT(HERE)) GO TO 300
  471. C                        !LIT?
  472.     CALL RSPEAK(430)
  473. C                        !WARN OF GRUE.
  474.     RMDESC=.FALSE.
  475.     RETURN
  476. C
  477. 300    RA=RACTIO(HERE)
  478. C                        !GET ROOM ACTION.
  479.     IF(FULL.EQ.1) GO TO 600
  480. C                        !OBJ ONLY?
  481.     I=RDESC2-HERE
  482. C                        !ASSUME SHORT DESC.
  483.     IF((FULL.EQ.0)
  484. &        .AND.(SUPERF.OR.(((and(RFLAG(HERE),RSEEN)).NE.0)
  485. &                .AND.(BRIEFF.OR.PROB(80,80)))))       GO TO 400
  486.     I=RDESC1(HERE)
  487. C                        !USE LONG.
  488.     IF((I.NE.0).OR.(RA.EQ.0)) GO TO 400
  489. C                        !IF GOT DESC, SKIP.
  490.     PRSA=LOOKW
  491. C                        !PRETEND LOOK AROUND.
  492.     IF(.NOT.RAPPLI(RA)) GO TO 100
  493. C                        !ROOM HANDLES, NEW DESC?
  494.     PRSA=FOOW
  495. C                        !NOP PARSER.
  496.     GO TO 500
  497. C
  498. 400    CALL RSPEAK(I)
  499. C                        !OUTPUT DESCRIPTION.
  500. 500    IF(AVEHIC(WINNER).NE.0) CALL RSPSUB(431,ODESC2(AVEHIC(WINNER)))
  501. C
  502. 600    IF(FULL.NE.2) CALL PRINCR(FULL.NE.0,HERE)
  503.     RFLAG(HERE)=or(RFLAG(HERE),RSEEN)
  504.     IF((FULL.NE.0).OR.(RA.EQ.0)) RETURN
  505. C                        !ANYTHING MORE?
  506.     PRSA=WALKIW
  507. C                        !GIVE HIM A SURPISE.
  508.     IF(.NOT.RAPPLI(RA)) GO TO 100
  509. C                        !ROOM HANDLES, NEW DESC?
  510.     PRSA=FOOW
  511.     RETURN
  512. C
  513.     END
  514. C RAPPLI-    ROUTING ROUTINE FOR ROOM APPLICABLES
  515. C
  516. C DECLARATIONS
  517. C
  518.     LOGICAL FUNCTION RAPPLI(RI)
  519.     IMPLICIT INTEGER(A-Z)
  520.     LOGICAL RAPPL1,RAPPL2
  521.     DATA NEWRMS/38/
  522. C
  523.     RAPPLI=.TRUE.
  524. C                        !ASSUME WINS.
  525.     IF(RI.EQ.0) RETURN
  526. C                        !IF ZERO, WIN.
  527.     IF(RI.LT.NEWRMS) RAPPLI=RAPPL1(RI)
  528. C                        !IF OLD, PROCESSOR 1.
  529.     IF(RI.GE.NEWRMS) RAPPLI=RAPPL2(RI)
  530. C                        !IF NEW, PROCESSOR 2.
  531.     RETURN
  532.     END
  533.