![[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.