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.			jmh@ukc.ac.uk 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
Last modified: 1988-10-21
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 475
Valid CSS Valid XHTML 1.0 Strict