4.4BSD/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