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