# 2.11BSD#431 - /usr/src/new/PORT/dungeon/dsub.F

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