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: 2203 |
|