1C RESIDENT SUBROUTINES FOR DUNGEON 2C 3C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142 4C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED 5C WRITTEN BY R. M. SUPNIK 6C 7C RSPEAK-- OUTPUT RANDOM MESSAGE ROUTINE 8C 9C CALLED BY-- 10C 11C CALL RSPEAK(MSGNUM) 12C 13 SUBROUTINE RSPEAK(N) 14 IMPLICIT INTEGER(A-Z) 15C 16 CALL RSPSB2(N,0,0) 17 RETURN 18 END 19C RSPSUB-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENT 20C 21C CALLED BY-- 22C 23C CALL RSPSUB(MSGNUM,SUBNUM) 24C 25 SUBROUTINE RSPSUB(N,S1) 26 IMPLICIT INTEGER(A-Z) 27C 28 CALL RSPSB2(N,S1,0) 29 RETURN 30 END 31C RSPSB2-- OUTPUT RANDOM MESSAGE WITH UP TO TWO SUBSTITUTABLE ARGUMENTS 32C 33C CALLED BY-- 34C 35C CALL RSPSB2(MSGNUM,SUBNUM1,SUBNUM2) 36C 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 43C 44C DECLARATIONS 45C 46#include "gamestate.h" 47C 48#ifdef PDP 49 TELFLG=.TRUE. 50C 51C use C routine to access data base 52C 53 call rspsb3(N,S1,S2) 54 return 55#else 56#include "mindex.h" 57#include "io.h" 58C 59C CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE) 60C TO ABSOLUTE RECORD NUMBERS. 61C 62 X=N 63C !SET UP WORK VARIABLES. 64 Y=S1 65 Z=S2 66 IF(X.GT.0) X=RTEXT(X) 67C !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) 71C !TAKE ABS VALUE. 72 Y=IABS(Y) 73 Z=IABS(Z) 74 IF(X.EQ.0) RETURN 75C !ANYTHING TO DO? 76 TELFLG=.TRUE. 77C !SAID SOMETHING. 78C 79 READ(UNIT=DBCH,REC=X) OLDREC,B1 80C 81100 DO 150 I=1,74 82 X1=and(X,31)+I 83 B1(I:I)=char(xor(ichar(B1(I:I)),X1)) 84150 CONTINUE 85C 86200 IF(Y.EQ.0) GO TO 400 87C !ANY SUBSTITUTABLE? 88 DO 300 I=1,74 89C !YES, LOOK FOR #. 90 IF(B1(I:I).EQ.'#') GO TO 1000 91300 CONTINUE 92C 93400 DO 500 I=74,1,-1 94C !BACKSCAN FOR BLANKS. 95 IF(B1(I:I).NE.' ') GO TO 600 96500 CONTINUE 97C 98600 WRITE(OUTCH,650) (B1(J:J),J=1,I) 99#ifdef NOCC 100650 FORMAT(74A1) 101#else NOCC 102650 FORMAT(1X,74A1) 103#endif NOCC 104 X=X+1 105C !ON TO NEXT RECORD. 106 READ(UNIT=DBCH,REC=X) NEWREC,B1 107 IF(OLDREC.EQ.NEWREC) GO TO 100 108C !CONTINUATION? 109 RETURN 110C !NO, EXIT. 111C 112C SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE. 113C I IS INDEX OF # IN B1. 114C Y IS NUMBER OF RECORD TO SUBSTITUTE. 115C 116C PROCEDURE: 117C 1) COPY REST OF B1 TO B2 118C 2) READ SUBSTITUTABLE OVER B1 119C 3) RESTORE TAIL OF ORIGINAL B1 120C 121C THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING 122C IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD). 123C 1241000 K2=1 125C !TO 126 DO 1100 K1=I+1,74 127C !COPY REST OF B1. 128 B2(K2:K2)=B1(K1:K1) 129 K2=K2+1 1301100 CONTINUE 131C 132C READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT: 133C 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)) 1381150 CONTINUE 139C 140C FILL REMAINDER OF B1 WITH CHARACTERS FROM B3: 141C 142 K2=1 143 DO 1180 K1=I,74 144 B1(K1:K1)=B3(K2:K2) 145 K2=K2+1 1461180 CONTINUE 147C 148C FIND END OF SUBSTITUTE STRING IN B1: 149C 150 DO 1200 J=74,1,-1 151C !ELIM TRAILING BLANKS. 152 IF(B1(J:J).NE.' ') GO TO 1300 1531200 CONTINUE 154C 155C PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING: 156C 1571300 K1=1 158C !FROM 159 DO 1400 K2=J+1,74 160C !COPY REST OF B1 BACK. 161 B1(K2:K2)=B2(K1:K1) 162 K1=K1+1 1631400 CONTINUE 164C 165 Y=Z 166C !SET UP FOR NEXT 167 Z=0 168C !SUBSTITUTION AND 169 GO TO 200 170C !RECHECK LINE. 171#endif PDP 172C 173 END 174C OBJACT-- APPLY OBJECTS FROM PARSE VECTOR 175C 176C DECLARATIONS 177C 178 LOGICAL FUNCTION OBJACT(X) 179 IMPLICIT INTEGER (A-Z) 180 LOGICAL OAPPLI 181#include "parser.h" 182#include "objects.h" 183C 184 OBJACT=.TRUE. 185C !ASSUME WINS. 186 IF(PRSI.EQ.0) GO TO 100 187C !IND OBJECT? 188 IF(OAPPLI(OACTIO(PRSI),0)) RETURN 189C !YES, LET IT HANDLE. 190C 191100 IF(PRSO.EQ.0) GO TO 200 192C !DIR OBJECT? 193 IF(OAPPLI(OACTIO(PRSO),0)) RETURN 194C !YES, LET IT HANDLE. 195C 196200 OBJACT=.FALSE. 197C !LOSES. 198 RETURN 199 END 200#ifndef PDP 201C BUG-- REPORT FATAL SYSTEM ERROR 202C 203C CALLED BY-- 204C 205C CALL BUG(NO,PAR) 206C 207 SUBROUTINE BUG(A,B) 208 IMPLICIT INTEGER(A-Z) 209#include "debug.h" 210C 211 PRINT 100,A,B 212 IF(DBGFLG.NE.0) RETURN 213 CALL EXIT 214C 215#ifdef NOCC 216100 FORMAT('PROGRAM ERROR ',I2,', PARAMETER=',I6) 217#else NOCC 218100 FORMAT(' PROGRAM ERROR ',I2,', PARAMETER=',I6) 219#endif NOCC 220 END 221#endif PDP 222C NEWSTA-- SET NEW STATUS FOR OBJECT 223C 224C CALLED BY-- 225C 226C CALL NEWSTA(OBJECT,STRING,NEWROOM,NEWCON,NEWADV) 227C 228 SUBROUTINE NEWSTA(O,R,RM,CN,AD) 229 IMPLICIT INTEGER(A-Z) 230#include "objects.h" 231C 232 CALL RSPEAK(R) 233 OROOM(O)=RM 234 OCAN(O)=CN 235 OADV(O)=AD 236 RETURN 237 END 238C QHERE-- TEST FOR OBJECT IN ROOM 239C 240C DECLARATIONS 241C 242 LOGICAL FUNCTION QHERE(OBJ,RM) 243 IMPLICIT INTEGER (A-Z) 244#include "objects.h" 245C 246 QHERE=.TRUE. 247 IF(OROOM(OBJ).EQ.RM) RETURN 248C !IN ROOM? 249 DO 100 I=1,R2LNT 250C !NO, SCH ROOM2. 251 IF((OROOM2(I).EQ.OBJ).AND.(RROOM2(I).EQ.RM)) RETURN 252100 CONTINUE 253 QHERE=.FALSE. 254C !NOT PRESENT. 255 RETURN 256 END 257C QEMPTY-- TEST FOR OBJECT EMPTY 258C 259C DECLARATIONS 260C 261 LOGICAL FUNCTION QEMPTY(OBJ) 262 IMPLICIT INTEGER (A-Z) 263#include "objects.h" 264C 265 QEMPTY=.FALSE. 266C !ASSUME LOSE. 267 DO 100 I=1,OLNT 268 IF(OCAN(I).EQ.OBJ) RETURN 269C !INSIDE TARGET? 270100 CONTINUE 271 QEMPTY=.TRUE. 272 RETURN 273 END 274C JIGSUP- YOU ARE DEAD 275C 276C DECLARATIONS 277C 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" 295C 296C FUNCTIONS AND DATA 297C 298 DATA RLIST/8,6,36,35,34,4,34,6,5/ 299C JIGSUP, PAGE 2 300C 301 CALL RSPEAK(DESC) 302C !DESCRIBE SAD STATE. 303 PRSCON=1 304C !STOP PARSER. 305 IF(DBGFLG.NE.0) RETURN 306C !IF DBG, EXIT. 307 AVEHIC(WINNER)=0 308C !GET RID OF VEHICLE. 309 IF(WINNER.EQ.PLAYER) GO TO 100 310C !HIMSELF? 311 CALL RSPSUB(432,ODESC2(AOBJ(WINNER))) 312C !NO, SAY WHO DIED. 313 CALL NEWSTA(AOBJ(WINNER),0,0,0,0) 314C !SEND TO HYPER SPACE. 315 RETURN 316C 317100 IF(ENDGMF) GO TO 900 318C !NO RECOVERY IN END GAME. 319 IF(DEATHS.GE.2) GO TO 1000 320C !DEAD TWICE? KICK HIM OFF. 321 IF(.NOT.YESNO(10,9,8)) GO TO 1100 322C !CONTINUE? 323C 324 DO 50 J=1,OLNT 325C !TURN OFF FIGHTING. 326 IF(QHERE(J,HERE)) OFLAG2(J)=and(OFLAG2(J),not(FITEBT)) 32750 CONTINUE 328C 329 DEATHS=DEATHS+1 330 CALL SCRUPD(-10) 331C !CHARGE TEN POINTS. 332 F=MOVETO(FORE1,WINNER) 333C !REPOSITION HIM. 334 EGYPTF=.TRUE. 335C !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) 341C 342C NOW REDISTRIBUTE HIS VALUABLES AND OTHER BELONGINGS. 343C 344C THE LAMP HAS BEEN PLACED IN THE LIVING ROOM. 345C THE FIRST 8 NON-VALUABLES ARE PLACED IN LOCATIONS AROUND THE HOUSE. 346C HIS VALUABLES ARE PLACED AT THE END OF THE MAZE. 347C REMAINING NON-VALUABLES ARE PLACED AT THE END OF THE MAZE. 348C 349 I=1 350 DO 200 J=1,OLNT 351C !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 356C !MOVE TO RANDOM LOCATIONS. 357 CALL NEWSTA(J,0,RLIST(I),0,0) 358200 CONTINUE 359C 360400 I=RLNT+1 361C !NOW MOVE VALUABLES. 362 NONOFL=RAIR+RWATER+RSACRD+REND 363C !DONT MOVE HERE. 364 DO 300 J=1,OLNT 365 IF((OADV(J).NE.WINNER).OR.(OTVAL(J).EQ.0)) 366& GO TO 300 367250 I=I-1 368C !FIND NEXT ROOM. 369 IF(and(RFLAG(I),NONOFL).NE.0) GO TO 250 370 CALL NEWSTA(J,0,I,0,0) 371C !YES, MOVE. 372300 CONTINUE 373C 374 DO 500 J=1,OLNT 375C !NOW GET RID OF REMAINDER. 376 IF(OADV(J).NE.WINNER) GO TO 500 377450 I=I-1 378C !FIND NEXT ROOM. 379 IF(and(RFLAG(I),NONOFL).NE.0) GO TO 450 380 CALL NEWSTA(J,0,I,0,0) 381500 CONTINUE 382 RETURN 383C 384C CAN'T OR WON'T CONTINUE, CLEAN UP AND EXIT. 385C 386900 CALL RSPEAK(625) 387C !IN ENDGAME, LOSE. 388 GO TO 1100 389C 3901000 CALL RSPEAK(7) 391C !INVOLUNTARY EXIT. 3921100 CALL SCORE(.FALSE.) 393C !TELL SCORE. 394#ifdef PDP 395C file closed in exit routine 396#else 397 CLOSE(DBCH) 398#endif PDP 399 CALL EXIT 400C 401 END 402C OACTOR- GET ACTOR ASSOCIATED WITH OBJECT 403C 404C DECLARATIONS 405C 406 INTEGER FUNCTION OACTOR(OBJ) 407 IMPLICIT INTEGER(A-Z) 408#include "advers.h" 409C 410 DO 100 I=1,ALNT 411C !LOOP THRU ACTORS. 412 OACTOR=I 413C !ASSUME FOUND. 414 IF(AOBJ(I).EQ.OBJ) RETURN 415C !FOUND IT? 416100 CONTINUE 417 CALL BUG(40,OBJ) 418C !NO, DIE. 419 RETURN 420 END 421C PROB- COMPUTE PROBABILITY 422C 423C DECLARATIONS 424C 425 LOGICAL FUNCTION PROB(G,B) 426 IMPLICIT INTEGER(A-Z) 427#include "flags.h" 428C 429 I=G 430C !ASSUME GOOD LUCK. 431 IF(BADLKF) I=B 432C !IF BAD, TOO BAD. 433 PROB=RND(100).LT.I 434C !COMPUTE. 435 RETURN 436 END 437C RMDESC-- PRINT ROOM DESCRIPTION 438C 439C RMDESC PRINTS A DESCRIPTION OF THE CURRENT ROOM. 440C IT IS ALSO THE PROCESSOR FOR VERBS 'LOOK' AND 'EXAMINE'. 441C 442 LOGICAL FUNCTION RMDESC(FULL) 443C 444C FULL= 0/1/2/3= SHORT/OBJ/ROOM/FULL 445C 446C DECLARATIONS 447C 448 IMPLICIT INTEGER (A-Z) 449 LOGICAL LIT,RAPPLI 450C 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" 461C RMDESC, PAGE 2 462C 463 RMDESC=.TRUE. 464C !ASSUME WINS. 465 IF(PRSO.LT.XMIN) GO TO 50 466C !IF DIRECTION, 467 FROMDR=PRSO 468C !SAVE AND 469 PRSO=0 470C !CLEAR. 47150 IF(HERE.EQ.AROOM(PLAYER)) GO TO 100 472C !PLAYER JUST MOVE? 473 CALL RSPEAK(2) 474C !NO, JUST SAY DONE. 475 PRSA=WALKIW 476C !SET UP WALK IN ACTION. 477 RETURN 478C 479100 IF(LIT(HERE)) GO TO 300 480C !LIT? 481 CALL RSPEAK(430) 482C !WARN OF GRUE. 483 RMDESC=.FALSE. 484 RETURN 485C 486300 RA=RACTIO(HERE) 487C !GET ROOM ACTION. 488 IF(FULL.EQ.1) GO TO 600 489C !OBJ ONLY? 490 I=RDESC2-HERE 491C !ASSUME SHORT DESC. 492 IF((FULL.EQ.0) 493& .AND.(SUPERF.OR.(((and(RFLAG(HERE),RSEEN)).NE.0) 494C 495C The next line means that when you request VERBOSE mode, you 496C only get long room descriptions 20% of the time. I don't either 497C like or understand this, so the mod. ensures VERBOSE works 498C all the time. jmh@ukc.ac.uk 22/10/87 499C 500C& .AND.(BRIEFF.OR.PROB(80,80))))) GO TO 400 501& .AND.BRIEFF))) GO TO 400 502 I=RDESC1(HERE) 503C !USE LONG. 504 IF((I.NE.0).OR.(RA.EQ.0)) GO TO 400 505C !IF GOT DESC, SKIP. 506 PRSA=LOOKW 507C !PRETEND LOOK AROUND. 508 IF(.NOT.RAPPLI(RA)) GO TO 100 509C !ROOM HANDLES, NEW DESC? 510 PRSA=FOOW 511C !NOP PARSER. 512 GO TO 500 513C 514400 CALL RSPEAK(I) 515C !OUTPUT DESCRIPTION. 516500 IF(AVEHIC(WINNER).NE.0) CALL RSPSUB(431,ODESC2(AVEHIC(WINNER))) 517C 518600 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 521C !ANYTHING MORE? 522 PRSA=WALKIW 523C !GIVE HIM A SURPISE. 524 IF(.NOT.RAPPLI(RA)) GO TO 100 525C !ROOM HANDLES, NEW DESC? 526 PRSA=FOOW 527 RETURN 528C 529 END 530C RAPPLI- ROUTING ROUTINE FOR ROOM APPLICABLES 531C 532C DECLARATIONS 533C 534 LOGICAL FUNCTION RAPPLI(RI) 535 IMPLICIT INTEGER(A-Z) 536 LOGICAL RAPPL1,RAPPL2 537 DATA NEWRMS/38/ 538C 539 RAPPLI=.TRUE. 540C !ASSUME WINS. 541 IF(RI.EQ.0) RETURN 542C !IF ZERO, WIN. 543 IF(RI.LT.NEWRMS) RAPPLI=RAPPL1(RI) 544C !IF OLD, PROCESSOR 1. 545 IF(RI.GE.NEWRMS) RAPPLI=RAPPL2(RI) 546C !IF NEW, PROCESSOR 2. 547 RETURN 548 END 549