usr/src/contrib/dungeon/dsub.F

C RESIDENT SUBROUTINES FOR DUNGEON
C
C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
C WRITTEN BY R. M. SUPNIK
C
C RSPEAK-- OUTPUT RANDOM MESSAGE ROUTINE
C
C CALLED BY--
C
C       CALL RSPEAK(MSGNUM)
C
        SUBROUTINE RSPEAK(N)
        IMPLICIT INTEGER(A-Z)
C
        CALL RSPSB2(N,0,0)
        RETURN
        END
C RSPSUB-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENT
C
C CALLED BY--
C
C       CALL RSPSUB(MSGNUM,SUBNUM)
C
        SUBROUTINE RSPSUB(N,S1)
        IMPLICIT INTEGER(A-Z)
C
        CALL RSPSB2(N,S1,0)
        RETURN
        END
C RSPSB2-- OUTPUT RANDOM MESSAGE WITH UP TO TWO SUBSTITUTABLE ARGUMENTS
C
C CALLED BY--
C
C       CALL RSPSB2(MSGNUM,SUBNUM1,SUBNUM2)
C
        SUBROUTINE    RSPSB2(N,S1,S2)
        IMPLICIT      INTEGER(A-Z)
#ifndef PDP
        CHARACTER*74  B1,B2,B3
        INTEGER*2     OLDREC,NEWREC,JREC
#endif PDP
C
C DECLARATIONS
C
#include "gamestate.h"
C
#ifdef PDP
        TELFLG=.TRUE.
C
C       use C routine to access data base
C
        call    rspsb3(N,S1,S2)
        return
#else
#include "mindex.h"
#include "io.h"
C
C CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE)
C TO ABSOLUTE RECORD NUMBERS.
C
        X=N
C                                               !SET UP WORK VARIABLES.
        Y=S1
        Z=S2
        IF(X.GT.0) X=RTEXT(X)
C                                               !IF >0, LOOK UP IN RTEXT.
        IF(Y.GT.0) Y=RTEXT(Y)
        IF(Z.GT.0) Z=RTEXT(Z)
        X=IABS(X)
C                                               !TAKE ABS VALUE.
        Y=IABS(Y)
        Z=IABS(Z)
        IF(X.EQ.0) RETURN
C                                               !ANYTHING TO DO?
        TELFLG=.TRUE.
C                                               !SAID SOMETHING.
C
        READ(UNIT=DBCH,REC=X) OLDREC,B1
C
100     DO 150 I=1,74
          X1=and(X,31)+I
          B1(I:I)=char(xor(ichar(B1(I:I)),X1))
150     CONTINUE
C
200     IF(Y.EQ.0) GO TO 400
C                                               !ANY SUBSTITUTABLE?
        DO 300 I=1,74
C                                               !YES, LOOK FOR #.
          IF(B1(I:I).EQ.'#') GO TO 1000
300     CONTINUE
C
400     DO 500 I=74,1,-1
C                                               !BACKSCAN FOR BLANKS.
          IF(B1(I:I).NE.' ') GO TO 600
500     CONTINUE
C
600     WRITE(OUTCH,650) (B1(J:J),J=1,I)
#ifdef NOCC
650     FORMAT(74A1)
#else NOCC
650     FORMAT(1X,74A1)
#endif NOCC
        X=X+1
C                                               !ON TO NEXT RECORD.
        READ(UNIT=DBCH,REC=X) NEWREC,B1
        IF(OLDREC.EQ.NEWREC) GO TO 100
C                                               !CONTINUATION?
        RETURN
C                                               !NO, EXIT.
C
C SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE.
C I IS INDEX OF # IN B1.
C Y IS NUMBER OF RECORD TO SUBSTITUTE.
C
C PROCEDURE:
C   1) COPY REST OF B1 TO B2
C   2) READ SUBSTITUTABLE OVER B1
C   3) RESTORE TAIL OF ORIGINAL B1
C
C THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING
C IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD).
C
1000    K2=1
C                                               !TO
        DO 1100 K1=I+1,74
C                                               !COPY REST OF B1.
          B2(K2:K2)=B1(K1:K1)
          K2=K2+1
1100    CONTINUE
C
C   READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT:
C
        READ(UNIT=DBCH,REC=Y) JREC,B3
        DO 1150 K1=1,74
          X1=and(Y,31)+K1
          B3(K1:K1)=char(xor(ICHAR(B3(K1:K1)),X1))
1150    CONTINUE
C
C   FILL REMAINDER OF B1 WITH CHARACTERS FROM B3:
C
        K2=1
        DO 1180 K1=I,74
          B1(K1:K1)=B3(K2:K2)
          K2=K2+1
1180    CONTINUE
C
C   FIND END OF SUBSTITUTE STRING IN B1:
C
        DO 1200 J=74,1,-1
C                                               !ELIM TRAILING BLANKS.
          IF(B1(J:J).NE.' ') GO TO 1300
1200    CONTINUE
C
C   PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING:
C
1300    K1=1
C                                               !FROM
        DO 1400 K2=J+1,74
C                                               !COPY REST OF B1 BACK.
          B1(K2:K2)=B2(K1:K1)
          K1=K1+1
1400    CONTINUE
C
        Y=Z
C                                               !SET UP FOR NEXT
        Z=0
C                                               !SUBSTITUTION AND
        GO TO 200
C                                               !RECHECK LINE.
#endif PDP
C
        END
C OBJACT-- APPLY OBJECTS FROM PARSE VECTOR
C
C DECLARATIONS
C
        LOGICAL FUNCTION OBJACT(X)
        IMPLICIT INTEGER (A-Z)
        LOGICAL OAPPLI
#include "parser.h"
#include "objects.h"
C
        OBJACT=.TRUE.
C                                               !ASSUME WINS.
        IF(PRSI.EQ.0) GO TO 100
C                                               !IND OBJECT?
        IF(OAPPLI(OACTIO(PRSI),0)) RETURN
C                                               !YES, LET IT HANDLE.
C
100     IF(PRSO.EQ.0) GO TO 200
C                                               !DIR OBJECT?
        IF(OAPPLI(OACTIO(PRSO),0)) RETURN
C                                               !YES, LET IT HANDLE.
C
200     OBJACT=.FALSE.
C                                               !LOSES.
        RETURN
        END
#ifndef PDP
C BUG-- REPORT FATAL SYSTEM ERROR
C
C CALLED BY--
C
C       CALL BUG(NO,PAR)
C
        SUBROUTINE BUG(A,B)
        IMPLICIT INTEGER(A-Z)
#include "debug.h"
C
        PRINT 100,A,B
        IF(DBGFLG.NE.0) RETURN
        CALL EXIT
C
#ifdef NOCC
100     FORMAT('PROGRAM ERROR ',I2,', PARAMETER=',I6)
#else NOCC
100     FORMAT(' PROGRAM ERROR ',I2,', PARAMETER=',I6)
#endif NOCC
        END
#endif PDP
C NEWSTA-- SET NEW STATUS FOR OBJECT
C
C CALLED BY--
C
C       CALL NEWSTA(OBJECT,STRING,NEWROOM,NEWCON,NEWADV)
C
        SUBROUTINE NEWSTA(O,R,RM,CN,AD)
        IMPLICIT INTEGER(A-Z)
#include "objects.h"
C
        CALL RSPEAK(R)
        OROOM(O)=RM
        OCAN(O)=CN
        OADV(O)=AD
        RETURN
        END
C QHERE-- TEST FOR OBJECT IN ROOM
C
C DECLARATIONS
C
        LOGICAL FUNCTION QHERE(OBJ,RM)
        IMPLICIT INTEGER (A-Z)
#include "objects.h"
C
        QHERE=.TRUE.
        IF(OROOM(OBJ).EQ.RM) RETURN
C                                               !IN ROOM?
        DO 100 I=1,R2LNT
C                                               !NO, SCH ROOM2.
          IF((OROOM2(I).EQ.OBJ).AND.(RROOM2(I).EQ.RM)) RETURN
100     CONTINUE
        QHERE=.FALSE.
C                                               !NOT PRESENT.
        RETURN
        END
C QEMPTY-- TEST FOR OBJECT EMPTY
C
C DECLARATIONS
C
        LOGICAL FUNCTION QEMPTY(OBJ)
        IMPLICIT INTEGER (A-Z)
#include "objects.h"
C
        QEMPTY=.FALSE.
C                                               !ASSUME LOSE.
        DO 100 I=1,OLNT
          IF(OCAN(I).EQ.OBJ) RETURN
C                                               !INSIDE TARGET?
100     CONTINUE
        QEMPTY=.TRUE.
        RETURN
        END
C JIGSUP- YOU ARE DEAD
C
C DECLARATIONS
C
        SUBROUTINE JIGSUP(DESC)
        IMPLICIT INTEGER (A-Z)
        LOGICAL YESNO,MOVETO,QHERE,F
        INTEGER RLIST(9)
#include "parser.h"
#include "gamestate.h"
#include "state.h"
#include "io.h"
#include "debug.h"
#include "rooms.h"
#include "rflag.h"
#include "rindex.h"
#include "objects.h"
#include "oflags.h"
#include "oindex.h"
#include "advers.h"
#include "flags.h"
C
C FUNCTIONS AND DATA
C
        DATA RLIST/8,6,36,35,34,4,34,6,5/
C JIGSUP, PAGE 2
C
        CALL RSPEAK(DESC)
C                                               !DESCRIBE SAD STATE.
        PRSCON=1
C                                               !STOP PARSER.
        IF(DBGFLG.NE.0) RETURN
C                                               !IF DBG, EXIT.
        AVEHIC(WINNER)=0
C                                               !GET RID OF VEHICLE.
        IF(WINNER.EQ.PLAYER) GO TO 100
C                                               !HIMSELF?
        CALL RSPSUB(432,ODESC2(AOBJ(WINNER)))
C                                               !NO, SAY WHO DIED.
        CALL NEWSTA(AOBJ(WINNER),0,0,0,0)
C                                               !SEND TO HYPER SPACE.
        RETURN
C
100     IF(ENDGMF) GO TO 900
C                                               !NO RECOVERY IN END GAME.
        IF(DEATHS.GE.2) GO TO 1000
C                                               !DEAD TWICE? KICK HIM OFF.
        IF(.NOT.YESNO(10,9,8)) GO TO 1100
C                                               !CONTINUE?
C
        DO 50 J=1,OLNT
C                                               !TURN OFF FIGHTING.
          IF(QHERE(J,HERE))   OFLAG2(J)=and(OFLAG2(J),not(FITEBT))
50      CONTINUE
C
        DEATHS=DEATHS+1
        CALL SCRUPD(-10)
C                                               !CHARGE TEN POINTS.
        F=MOVETO(FORE1,WINNER)
C                                               !REPOSITION HIM.
        EGYPTF=.TRUE.
C                                               !RESTORE COFFIN.
        IF(OADV(COFFI).EQ.WINNER) CALL NEWSTA(COFFI,0,EGYPT,0,0)
        OFLAG2(DOOR)=and(OFLAG2(DOOR),not(TCHBT))
        OFLAG1(ROBOT)=and(or(OFLAG1(ROBOT),VISIBT),not(NDSCBT))
        IF((OROOM(LAMP).NE.0).OR.(OADV(LAMP).EQ.WINNER))
&               CALL NEWSTA(LAMP,0,LROOM,0,0)
C
C NOW REDISTRIBUTE HIS VALUABLES AND OTHER BELONGINGS.
C
C THE LAMP HAS BEEN PLACED IN THE LIVING ROOM.
C THE FIRST 8 NON-VALUABLES ARE PLACED IN LOCATIONS AROUND THE HOUSE.
C HIS VALUABLES ARE PLACED AT THE END OF THE MAZE.
C REMAINING NON-VALUABLES ARE PLACED AT THE END OF THE MAZE.
C
        I=1
        DO 200 J=1,OLNT
C                                               !LOOP THRU OBJECTS.
          IF((OADV(J).NE.WINNER).OR.(OTVAL(J).NE.0))
&               GO TO 200
          I=I+1
          IF(I.GT.9) GO TO 400
C                                               !MOVE TO RANDOM LOCATIONS.
          CALL NEWSTA(J,0,RLIST(I),0,0)
200     CONTINUE
C
400     I=RLNT+1
C                                               !NOW MOVE VALUABLES.
        NONOFL=RAIR+RWATER+RSACRD+REND
C                                               !DONT MOVE HERE.
        DO 300 J=1,OLNT
          IF((OADV(J).NE.WINNER).OR.(OTVAL(J).EQ.0))
&               GO TO 300
250       I=I-1
C                                               !FIND NEXT ROOM.
          IF(and(RFLAG(I),NONOFL).NE.0) GO TO 250
          CALL NEWSTA(J,0,I,0,0)
C                                               !YES, MOVE.
300     CONTINUE
C
        DO 500 J=1,OLNT
C                                               !NOW GET RID OF REMAINDER.
          IF(OADV(J).NE.WINNER) GO TO 500
450       I=I-1
C                                               !FIND NEXT ROOM.
          IF(and(RFLAG(I),NONOFL).NE.0) GO TO 450
          CALL NEWSTA(J,0,I,0,0)
500     CONTINUE
        RETURN
C
C CAN'T OR WON'T CONTINUE, CLEAN UP AND EXIT.
C
900     CALL RSPEAK(625)
C                                               !IN ENDGAME, LOSE.
        GO TO 1100
C
1000    CALL RSPEAK(7)
C                                               !INVOLUNTARY EXIT.
1100    CALL SCORE(.FALSE.)
C                                               !TELL SCORE.
#ifdef PDP
C       file closed in exit routine
#else
        CLOSE(DBCH)
#endif PDP
        CALL EXIT
C
        END
C OACTOR-       GET ACTOR ASSOCIATED WITH OBJECT
C
C DECLARATIONS
C
        INTEGER FUNCTION OACTOR(OBJ)
        IMPLICIT INTEGER(A-Z)
#include "advers.h"
C
        DO 100 I=1,ALNT
C                                               !LOOP THRU ACTORS.
          OACTOR=I
C                                               !ASSUME FOUND.
          IF(AOBJ(I).EQ.OBJ) RETURN
C                                               !FOUND IT?
100     CONTINUE
        CALL BUG(40,OBJ)
C                                               !NO, DIE.
        RETURN
        END
C PROB-         COMPUTE PROBABILITY
C
C DECLARATIONS
C
        LOGICAL FUNCTION PROB(G,B)
        IMPLICIT INTEGER(A-Z)
#include "flags.h"
C
        I=G
C                                               !ASSUME GOOD LUCK.
        IF(BADLKF) I=B
C                                               !IF BAD, TOO BAD.
        PROB=RND(100).LT.I
C                                               !COMPUTE.
        RETURN
        END
C RMDESC-- PRINT ROOM DESCRIPTION
C
C RMDESC PRINTS A DESCRIPTION OF THE CURRENT ROOM.
C IT IS ALSO THE PROCESSOR FOR VERBS 'LOOK' AND 'EXAMINE'.
C
        LOGICAL FUNCTION RMDESC(FULL)
C
C FULL= 0/1/2/3=        SHORT/OBJ/ROOM/FULL
C
C DECLARATIONS
C
        IMPLICIT INTEGER (A-Z)
        LOGICAL LIT,RAPPLI
C       LOGICAL PROB
#include "parser.h"
#include "gamestate.h"
#include "screen.h"
#include "rooms.h"
#include "rflag.h"
#include "xsrch.h"
#include "objects.h"
#include "advers.h"
#include "verbs.h"
#include "flags.h"
C RMDESC, PAGE 2
C
        RMDESC=.TRUE.
C                                               !ASSUME WINS.
        IF(PRSO.LT.XMIN) GO TO 50
C                                               !IF DIRECTION,
        FROMDR=PRSO
C                                               !SAVE AND
        PRSO=0
C                                               !CLEAR.
50      IF(HERE.EQ.AROOM(PLAYER)) GO TO 100
C                                               !PLAYER JUST MOVE?
        CALL RSPEAK(2)
C                                               !NO, JUST SAY DONE.
        PRSA=WALKIW
C                                               !SET UP WALK IN ACTION.
        RETURN
C
100     IF(LIT(HERE)) GO TO 300
C                                               !LIT?
        CALL RSPEAK(430)
C                                               !WARN OF GRUE.
        RMDESC=.FALSE.
        RETURN
C
300     RA=RACTIO(HERE)
C                                               !GET ROOM ACTION.
        IF(FULL.EQ.1) GO TO 600
C                                               !OBJ ONLY?
        I=RDESC2-HERE
C                                               !ASSUME SHORT DESC.
        IF((FULL.EQ.0)
&               .AND.(SUPERF.OR.(((and(RFLAG(HERE),RSEEN)).NE.0)
C
C  The next line means that when you request VERBOSE mode, you
C  only get long room descriptions 20% of the time. I don't either
C  like or understand this, so the mod. ensures VERBOSE works
C  all the time.                        jmh@ukc.ac.uk 22/10/87
C
C&                      .AND.(BRIEFF.OR.PROB(80,80)))))       GO TO 400
&                       .AND.BRIEFF)))       GO TO 400
        I=RDESC1(HERE)
C                                               !USE LONG.
        IF((I.NE.0).OR.(RA.EQ.0)) GO TO 400
C                                               !IF GOT DESC, SKIP.
        PRSA=LOOKW
C                                               !PRETEND LOOK AROUND.
        IF(.NOT.RAPPLI(RA)) GO TO 100
C                                               !ROOM HANDLES, NEW DESC?
        PRSA=FOOW
C                                               !NOP PARSER.
        GO TO 500
C
400     CALL RSPEAK(I)
C                                               !OUTPUT DESCRIPTION.
500     IF(AVEHIC(WINNER).NE.0) CALL RSPSUB(431,ODESC2(AVEHIC(WINNER)))
C
600     IF(FULL.NE.2) CALL PRINCR(FULL.NE.0,HERE)
        RFLAG(HERE)=or(RFLAG(HERE),RSEEN)
        IF((FULL.NE.0).OR.(RA.EQ.0)) RETURN
C                                               !ANYTHING MORE?
        PRSA=WALKIW
C                                               !GIVE HIM A SURPISE.
        IF(.NOT.RAPPLI(RA)) GO TO 100
C                                               !ROOM HANDLES, NEW DESC?
        PRSA=FOOW
        RETURN
C
        END
C RAPPLI-       ROUTING ROUTINE FOR ROOM APPLICABLES
C
C DECLARATIONS
C
        LOGICAL FUNCTION RAPPLI(RI)
        IMPLICIT INTEGER(A-Z)
        LOGICAL RAPPL1,RAPPL2
        DATA NEWRMS/38/
C
        RAPPLI=.TRUE.
C                                               !ASSUME WINS.
        IF(RI.EQ.0) RETURN
C                                               !IF ZERO, WIN.
        IF(RI.LT.NEWRMS) RAPPLI=RAPPL1(RI)
C                                               !IF OLD, PROCESSOR 1.
        IF(RI.GE.NEWRMS) RAPPLI=RAPPL2(RI)
C                                               !IF NEW, PROCESSOR 2.
        RETURN
        END