C Subroutines for DUNGEON
C
C COPYRIGHT 1980, 1990, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA.
C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
C WRITTEN BY R. M. SUPNIK
C
C 27-Sep-94     RMS     Fixed bugs in WEIGHR, JIGSUP, SCORE.
C                       Added GRANITE WALL to GHERE.
C 30-Jan-94     RMS     Fixed bugs from MS DOS port.
C 30-Jun-92     RMS     Changed file names to lower case.
C 29-Jun-92     RMS     Removed extraneous declaration in RMDESC.
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
C
      END
C
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
C
      END

C RSPSB2-- Output random message with substitutable arguments
C
C Called by--
C
C       CALL RSPSB2(MSGNUM,S1,S2)
C
      SUBROUTINE RSPSB2(A,B,C)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      CHARACTER*(TEXLNT) B1,B2
C
C Convert all arguments from dictionary numbers (if positive)
c to absolute record numbers.
C
      X=A                                       ! set up work variables.
      Y=B
      Z=C
      IF(X.GT.0) X=RTEXT(X)                     ! if >0, look up in rtext.
      IF(Y.GT.0) Y=RTEXT(Y)
      IF(Z.GT.0) Z=RTEXT(Z)
      X=IABS(X)                                 ! take abs value.
      Y=IABS(Y)
      Z=IABS(Z)
      IF(X.EQ.0) RETURN                         ! anything to do?
      TELFLG=.TRUE.                             ! said something.
C
      READ(DBCH,REC=X) OLDREC,B1                ! read first line.
100   CALL TXCRYP(X,B1)                         ! decrypt line.
C
200   IF(Y.EQ.0) GO TO 400                      ! any substitutable?
      I=INDEX(B1,'#')                           ! look for #.
      IF(I.GT.0) GO TO 1000                     ! found?
C
400   WRITE(OUTCH,650) B1(1:MAX0(1,NBLEN(B1)))! output line.
650   FORMAT(1X,A)
      X=X+1                                     ! on to next record.
      READ(DBCH,REC=X) NEWREC,B1                ! read next record.
      IF(OLDREC.EQ.NEWREC) GO TO 100            ! continuation?
      RETURN                                    ! no, exit.

C RSPSB2, PAGE 2
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.
C
1000  B2(1:(TEXLNT-I))=B1(I+1:TEXLNT)           ! copy rest of B1.
C
      READ(DBCH,REC=Y) J,B1(I:TEXLNT)           ! read sub record.
      CALL TXCRYP(Y,B1(I:TEXLNT))               ! decrypt sub record.
      J=NBLEN(B1)                               ! backscan for blanks.
      B1(J+1:TEXLNT)=B2(1:TEXLNT-J)
C
      Y=Z                                       ! set up for next
      Z=0                                       ! substitution and
      GO TO 200                                 ! recheck line.
C
      END

C OBJACT-- Apply objects from parse vector
C
C Declarations
C
      LOGICAL FUNCTION OBJACT(X)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL OAPPLI
C
      OBJACT=.TRUE.                             ! assume wins.
      IF(PRSI.EQ.0) GO TO 100                   ! ind object?
      IF(OAPPLI(OACTIO(PRSI),0)) RETURN         ! yes, let it handle.
C
100   IF(PRSO.EQ.0) GO TO 200                   ! dir object?
      IF(OAPPLI(OACTIO(PRSO),0)) RETURN         ! yes, let it handle.
C
200   OBJACT=.FALSE.                            ! loses.
      RETURN
C
      END

C BUG-- Report fatal system error
C
C Declarations
C
      SUBROUTINE BUG(A,B)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      WRITE(OUTCH,100) A,B                      ! gonzo
      IF(DBGFLG.NE.0) RETURN
      SUBBUF='CRASH.DAT'                        ! set up crash save name.
      SUBLNT=NBLEN(SUBBUF)
      CALL SAVEGM                               ! do final save.
      WRITE(OUTCH,200)
      STOP ' '
C
100   FORMAT(' Program error ',I2,', parameter =',I6)
200   FORMAT(' Game state saved in "CRASH.DAT".')
C
      END

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 'dparam.for'
C
      CALL RSPEAK(R)
      OROOM(O)=RM
      OCAN(O)=CN
      OADV(O)=AD
      RETURN
C
      END

C QHERE-- Test for object in room
C
C Declarations
C
      LOGICAL FUNCTION QHERE(OBJ,RM)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      QHERE=.TRUE.
      IF(OROOM(OBJ).EQ.RM) RETURN               ! in room?
      DO 100 I=1,R2LNT                          ! no, sch room2.
        IF((O2(I).EQ.OBJ).AND.(R2(I).EQ.RM)) RETURN
100   CONTINUE
      QHERE=.FALSE.                             ! not present.
      RETURN
C
      END

C QEMPTY-- Test for object empty
C
C Declarations
C
      LOGICAL FUNCTION QEMPTY(OBJ)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      QEMPTY=.FALSE.                            ! assume lose.
      DO 100 I=1,OLNT
        IF(OCAN(I).EQ.OBJ) RETURN               ! inside target?
100   CONTINUE
      QEMPTY=.TRUE.
      RETURN
C
      END

C JIGSUP- You are dead
C
C Declarations
C
      SUBROUTINE JIGSUP(DESC)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL MOVETO,QHERE,F
      INTEGER RLIST(8)
C
C Functions and data
C
      DATA RLIST/KITCH,CLEAR,FORE3,FORE2,SHOUS,FORE2,KITCH,EHOUS/
C
      CALL RSPEAK(DESC)                         ! describe sad state.
      PRSCON=0                                  ! stop parser.
      IF(DBGFLG.NE.0) RETURN                    ! if dbg, exit.
      AVEHIC(WINNER)=0                          ! get rid of vehicle.
      IF(WINNER.EQ.PLAYER) GO TO 10             ! himself?
      CALL RSPSUB(432,ODESC2(AOBJ(WINNER)))     ! no, say who died.
      CALL NEWSTA(AOBJ(WINNER),0,0,0,0)         ! send object to hyper space.
      AROOM(WINNER)=0                           ! send actor to hyper space.
      RETURN
C
10    CALL SCRUPD(-10)                          ! charge 10 points.
      IF(ENDGMF) GO TO 900                      ! no recovery in end game.
      IF(DEATHS.GE.2) GO TO 1000                ! dead twice? kick him off.
      DEATHS=DEATHS+1                           ! record deaths.
      DEADF=.TRUE.                              ! flag dead player.
      I=8                                       ! normal message.
      IF(LLDF) I=1074                           ! ghosts exorcised?
      CALL RSPEAK(I)                            ! tell him bad news.
      AACTIO(PLAYER)=PLAYER                     ! turn on dead player func.
C
      DO 50 J=1,OLNT                            ! turn off fighting.
        IF(QHERE(J,HERE)) OFLAG2(J)=OFLAG2(J).AND. .NOT.FITEBT
50    CONTINUE
C
      F=MOVETO(LLD1,WINNER)                     ! reposition him.
      EGYPTF=.TRUE.                             ! restore coffin.
      IF(OADV(COFFI).EQ.WINNER) CALL NEWSTA(COFFI,0,EGYPT,0,0)
      OFLAG2(DOOR)=OFLAG2(DOOR).AND. .NOT.TCHBT ! restore door.
      OFLAG1(ROBOT)=(OFLAG1(ROBOT).OR.VISIBT) .AND. .NOT.NDSCBT
      CALL NEWSTA(LAMP,0,LROOM,0,0)             ! lamp to living room,
      OFLAG1(LAMP)=OFLAG1(LAMP).OR.VISIBT       ! visible
      DO 100 I=1,CLNT                           ! disable cevnts if needed.
        IF(CCNCEL(I)) CFLAG(I)=.FALSE.
100   CONTINUE

C JIGSUP, PAGE 2
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 starting at Troll Room.
C Remaining non-valuables are after that.
C
      I=0
      DO 200 J=1,OLNT                           ! loop thru objects.
        IF((OADV(J).NE.WINNER).OR.(OTVAL(J).NE.0))
     1GO TO 200                                 ! get his non-val objs.
        I=I+1
        IF(I.GT.8) GO TO 400                    ! move to random locations.
        CALL NEWSTA(J,0,RLIST(I),0,0)
200   CONTINUE
C
400   I=MTROL                                   ! now move valuables.
      NONOFL=RAIR+RWATER+REND                   ! dont move here.
      DO 300 J=1,OLNT
        IF((OADV(J).NE.WINNER).OR.(OTVAL(J).EQ.0))
     1GO TO 300                                 ! on adv and valuable?
250     I=I+1                                   ! find next room.
        IF((RFLAG(I).AND.NONOFL).NE.0) GO TO 250 ! skip if nono.
        CALL NEWSTA(J,0,I,0,0)                  ! yes, move.
300   CONTINUE
C
      DO 500 J=1,OLNT                           ! now get rid of remainder.
        IF(OADV(J).NE.WINNER) GO TO 500
450     I=I+1                                   ! find next room.
        IF((RFLAG(I).AND.NONOFL).NE.0) GO TO 450 ! skip if nono.
        CALL NEWSTA(J,0,I,0,0)
500   CONTINUE
      RETURN
C
C Cant or wont continue, clean up and exit.
C
900   CALL RSPEAK(625)                          ! in endgame, lose.
      GO TO 1100
C
1000  CALL RSPEAK(7)                            ! involuntary exit.
1100  CALL SCORE(.FALSE.)                       ! tell score.
      STOP ' '
C
      END

C OACTOR-       Get actor associated with object
C
C Declarations
C
      INTEGER FUNCTION OACTOR(OBJ)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      DO 100 OACTOR=1,ALNT                      ! loop thru actors.
        IF(AOBJ(OACTOR).EQ.OBJ) RETURN          ! found it?
100   CONTINUE
      CALL BUG(40,OBJ)                          ! no, die.
      RETURN
C
      END

C PROB-         Compute probability
C
C Declarations
C
      LOGICAL FUNCTION PROB(G,B)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      I=G                                       ! assume good luck.
      IF(BADLKF) I=B                            ! if bad, too bad.
      PROB=RND(100).LT.I                        ! compute.
      RETURN
C
      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 when there is no direct object.
C
      LOGICAL FUNCTION RMDESC(FULL)
C
C FULL= 0/1/2/3=        full/obj/room/full but no applicable
C
C Declarations
C
      IMPLICIT INTEGER (A-Z)
      LOGICAL PROB,LIT
      INCLUDE 'dparam.for'
C
      RMDESC=.TRUE.                             ! assume wins.
      RA=RACTIO(HERE)                           ! get room action.
      IF(PRSO.LT.XMIN) GO TO 50                 ! if direction,
      FROMDR=PRSO                               ! save and
      PRSO=0                                    ! clear.
50    IF(FULL.EQ.1) GO TO 600                   ! objects only?
      IF(HERE.EQ.AROOM(PLAYER)) GO TO 100       ! player just move?
      CALL RSPEAK(2)                            ! no, just say done.
      PRSA=WALKIW                               ! set up walk in action.
      RETURN
C
100   IF(LIT(HERE)) GO TO 300                   ! lit?
      CALL RSPEAK(430)                          ! warn of grue.
      RMDESC=.FALSE.
      RETURN
C
300   I=RDESC2-HERE                             ! assume short desc.
      IF((FULL.EQ.0)
     1.AND. (SUPERF.OR.(((RFLAG(HERE).AND.RSEEN).NE.0)
     1.AND. (BRIEFF.OR.PROB(80,80))))) GO TO 400
      I=RDESC1(HERE)                            ! use long.
      IF((I.NE.0).OR.(RA.EQ.0)) GO TO 400       ! if got desc, skip.
      PRSA=LOOKW                                ! pretend look around.
      PRSO=0                                    ! no object referenced.
      CALL RAPPLI(RA)                           ! let room handle.
      PRSA=FOOW                                 ! nop parser.
      GO TO 500
C
400   CALL RSPEAK(I)                            ! output description.
500   IF(AVEHIC(WINNER).NE.0) CALL RSPSUB(431,ODESC2(AVEHIC(WINNER)))
      RFLAG(HERE)=RFLAG(HERE).OR.RSEEN          ! indicate room seen.
C
600   IF(LIT(HERE)) GO TO 700                   ! if lit, do objects
      CALL RSPEAK(1036)                         ! can't see anything
      RETURN
C
700   IF(FULL.NE.2) CALL PRINCR(FULL,HERE)      ! print room contents
      IF((FULL.NE.0).OR.(RA.EQ.0)) RETURN       ! anything more?
      PRSA=WALKIW                               ! give him a surpise.
      CALL RAPPLI(RA)                           ! let room handle
      PRSA=FOOW
      RETURN
C
      END

C PRINCR- Print contents of room
C
C Declarations
C
      SUBROUTINE PRINCR(FULL,RM)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL QEMPTY,QHERE
C
      J=329                                     ! assume superbrief format.
      DO 500 I=1,OLNT                           ! loop on objects
        IF(.NOT.QHERE(I,RM).OR.((OFLAG1(I).AND.VISIBT).EQ.0).OR.
     1(((OFLAG1(I).AND.NDSCBT).NE.0).AND.(FULL.NE.1)).OR.
     2(I.EQ.AVEHIC(WINNER))) GO TO 500
        IF((FULL.EQ.0).AND.(SUPERF.OR.(BRIEFF.AND.
     1((RFLAG(HERE).AND.RSEEN).NE.0)))) GO TO 200
C
C Do long description of object.
C
        K=ODESCO(I)                             ! get untouched.
        IF((K.EQ.0).OR.((OFLAG2(I).AND.TCHBT).NE.0)) K=ODESC1(I)
        IF((K.EQ.0).AND.(FULL.EQ.1)) CALL RSPSUB(936,ODESC2(I))
        CALL RSPEAK(K)                          ! describe.
        GO TO 500
C
C Do short description of object.
C
200     CALL RSPSUB(J,ODESC2(I))                ! you can see it.
        J=502
C
500   CONTINUE
C
C Now loop to print contents of objects in room.
C
      DO 1000 I=1,OLNT                          ! loop on objects.
        IF(.NOT.QHERE(I,RM).OR.((OFLAG1(I).AND.VISIBT).EQ.0).OR.
     1(((OFLAG1(I).AND.NDSCBT).NE.0).AND.(FULL.NE.1)))
     2GO TO 1000
        IF((OFLAG2(I).AND.ACTRBT).NE.0) CALL INVENT(OACTOR(I))
        IF((((OFLAG1(I).AND.TRANBT).EQ.0).AND.((OFLAG2(I).AND.OPENBT)
     1.EQ.0)).OR.QEMPTY(I)) GO TO 1000
C
C Object is not empty and is open or transparent.
C
        IF(I.NE.TCASE) GO TO 600                ! trophy case?
        IF((.NOT.(BRIEFF.OR.SUPERF)).OR.(FULL.EQ.1))
     1CALL PRINCO(I,1053,.FALSE.)               ! print contents.
        GO TO 1000
600     CALL PRINCO(I,573,.TRUE.)               ! print contents
1000  CONTINUE
      RETURN
C
      END

C INVENT- Print contents of adventurer
C
C Declarations
C
      SUBROUTINE INVENT(ADV)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL QEMPTY
C
      I=575                                     ! first line.
      IF(ADV.NE.PLAYER) I=576                   ! if not me.
      DO 10 J=1,OLNT                            ! loop
        IF((OADV(J).NE.ADV).OR.((OFLAG1(J).AND.VISIBT).EQ.0))
     1GO TO 10
        CALL RSPSUB(I,ODESC2(AOBJ(ADV)))
        I=0
        CALL RSPSUB(502,ODESC2(J))
10    CONTINUE
C
      IF(I.EQ.0) GO TO 25                       ! any objects?
      IF(ADV.EQ.PLAYER) CALL RSPEAK(578)        ! no, tell him.
      RETURN
C
25    DO 100 J=1,OLNT                           ! loop.
        IF((OADV(J).NE.ADV).OR.((OFLAG1(J).AND.VISIBT).EQ.0).OR.
     1(((OFLAG1(J).AND.TRANBT).EQ.0).AND.
     2((OFLAG2(J).AND.OPENBT).EQ.0))) GO TO 100
        IF(.NOT.QEMPTY(J)) CALL PRINCO(J,573,.TRUE.) ! if not empty, list.
100   CONTINUE
      RETURN
C
      END

C PRINCO-       Print contents of object
C
C Declarations
C
      SUBROUTINE PRINCO(OBJ,DESC,LDESCF)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL QEMPTY,LDESCF,MOREF,QSEEIN,QUAL
C
C Functions and data
C
      QSEEIN(X)=((OFLAG1(X).AND.TRANBT).NE.0).OR.
     1  ((OFLAG2(X).AND.OPENBT).NE.0)
      QUAL(X,Y)=((OFLAG1(X).AND.VISIBT).NE.0).AND.
     1   (OCAN(X).EQ.Y).AND.(X.NE.AOBJ(WINNER))
C
      MOREF=.FALSE.                             ! no additional printouts.
      ALSO=0                                    ! no untouched descriptions.
      IF(SUPERF.OR..NOT.LDESCF) GO TO 2000      ! skip long descriptions?
      DO 1000 I=1,OLNT                          ! loop thru objects.
        IF(.NOT.QUAL(I,OBJ)) GO TO 1000         ! inside target?
        IF((ODESCO(I).EQ.0).OR.
     1  ((OFLAG2(I).AND.TCHBT).NE.0)) GO TO 700
        CALL RSPEAK(ODESCO(I))                  ! print untouched descr.
        ALSO=1                                  ! flag.
        IF(.NOT.QSEEIN(I).OR.QEMPTY(I)) GO TO 1000
        CALL RSPSUB(573,ODESC2(I))              ! object, which contains:
        DO 500 J=1,OLNT                         ! loop thru objects.
          IF(QUAL(J,I)) CALL RSPSUB(502,ODESC2(J))
500     CONTINUE
        GO TO 1000
700     MOREF=.TRUE.
1000  CONTINUE
      IF(.NOT.MOREF) RETURN                     ! more to do?
C
2000  CALL RSPSUB(DESC+ALSO,ODESC2(OBJ))        ! print header.
      DO 3000 I=1,OLNT                          ! loop thru objects.
        IF(.NOT.QUAL(I,OBJ)) GO TO 3000         ! inside target?
        IF((ALSO.NE.0).AND.(ODESCO(I).NE.0).AND.
     1   ((OFLAG2(I).AND.TCHBT).EQ.0)) GO TO 3000
        IF(.NOT.QSEEIN(I).OR.QEMPTY(I)) GO TO 2700
        CALL RSPSUB(1050,ODESC2(I))             ! object, which contains:
        DO 2500 J=1,OLNT                        ! loop thru objects.
          IF(QUAL(J,I)) CALL RSPSUB(1051,ODESC2(J))
2500    CONTINUE
        GO TO 3000
2700    CALL RSPSUB(502,ODESC2(I))              ! object, nothing inside.
3000  CONTINUE
      RETURN
C
      END

C MOVETO- Move player to new room
C
C Declarations
C
      LOGICAL FUNCTION MOVETO(NR,WHO)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL NLV,LHR,LNR
C
      MOVETO=.FALSE.                            ! assume fails.
      LHR=(RFLAG(HERE).AND.RLAND).NE.0          ! land  here flag.
      LNR=(RFLAG(NR).AND.RLAND).NE.0            ! land there flag.
      J=AVEHIC(WHO)                             ! his vehicle
C
      IF(J.NE.0) GO TO 100                      ! in vehicle?
      IF(LNR) GO TO 500                         ! no, going to land?
      CALL RSPEAK(427)                          ! can't go without vehicle.
      RETURN
C
100   BITS=0                                    ! assume nowhere.
      IF(J.EQ.RBOAT) BITS=RWATER                ! in boat?
      IF(J.EQ.BALLO) BITS=RAIR                  ! in balloon?
      IF(J.EQ.BUCKE) BITS=RBUCK                 ! in bucket?
      NLV=(RFLAG(NR).AND.BITS).EQ.0             ! got wrong vehicle flag.
      IF((.NOT.LNR .AND.NLV) .OR.
     1(LNR.AND.LHR.AND.NLV.AND.(BITS.NE.RLAND)))
     2GO TO 800                                 ! got wrong vehicle?
C
500   MOVETO=.TRUE.                             ! move should succeed.
      IF((RFLAG(NR).AND.RMUNG).EQ.0) GO TO 600  ! room munged?
      CALL RSPEAK(RDESC1(NR))                   ! yes, tell how.
      RETURN
C
600   IF(WHO.NE.PLAYER) CALL NEWSTA(AOBJ(WHO),0,NR,0,0)
      IF(J.NE.0) CALL NEWSTA(J,0,NR,0,0)
      HERE=NR
      AROOM(WHO)=HERE
      CALL SCRUPD(RVAL(NR))                     ! score room
      RVAL(NR)=0
      RETURN
C
800   CALL RSPSUB(428,ODESC2(J))                ! wrong vehicle.
      RETURN
C
      END

C SCORE-- Print out current score
C
C Declarations
C
      SUBROUTINE SCORE(FLG)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL FLG
      INTEGER RANK(10),ERANK(5)
C
C Functions and data
C
      DATA RANK/20,19,18,16,12,8,4,2,1,0/
      DATA ERANK/20,15,10,5,0/
C
      AS=ASCORE(WINNER)
      IF(ENDGMF) GO TO 60                       ! endgame?
      IF(FLG) WRITE(OUTCH,100)
      IF(.NOT.FLG) WRITE(OUTCH,110)
      IF(MOVES.NE.1) WRITE(OUTCH,120) AS,MXSCOR,MOVES
      IF(MOVES.EQ.1) WRITE(OUTCH,130) AS,MXSCOR,MOVES
      IF(AS.LT.0) GO TO 50                      ! negative score?
      DO 10 I=1,10                              ! find rank.
        IF((AS*20/MXSCOR).GE.RANK(I)) GO TO 20
10    CONTINUE
      I=10                                      ! beginner.
20    CALL RSPEAK(484+I)                        ! print rank.
      RETURN
C
50    CALL RSPEAK(886)                          ! negative score.
      RETURN
C
60    IF(FLG) WRITE(OUTCH,140)
      IF(.NOT.FLG) WRITE(OUTCH,150)
      WRITE(OUTCH,120) EGSCOR,EGMXSC,MOVES
      DO 70 I=1,5
        IF((EGSCOR*20/EGMXSC).GE.ERANK(I)) GO TO 80
70    CONTINUE
      I=5                                       ! beginner.
80    CALL RSPEAK(786+I)
      RETURN
C
100   FORMAT(' Your score would be',$)
110   FORMAT(' Your score is',$)
120   FORMAT('+',I4,' [total of',I4,' points], in',I5,' moves.')
130   FORMAT('+',I4,' [total of',I4,' points], in',I5,' move.')
140   FORMAT(' Your score in the endgame would be',$)
150   FORMAT(' Your score in the endgame is',$)
C
      END

C SCRUPD- Update winner's score
C
C Declarations
C
      SUBROUTINE SCRUPD(N)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      IF(ENDGMF) GO TO 100                      ! endgame?
      ASCORE(WINNER)=ASCORE(WINNER)+N           ! update score
      RWSCOR=RWSCOR+N                           ! update raw score
      IF(ASCORE(WINNER).LT.(MXSCOR-(10*MIN0(1,DEATHS)))) RETURN
      CFLAG(CEVEGH)=.TRUE.                      ! turn on end game
      CTICK(CEVEGH)=15
      RETURN
C
100   EGSCOR=EGSCOR+N                           ! update eg score.
      RETURN
C
      END

C FINDXT- Find exit from room
C
C Declarations
C
      LOGICAL FUNCTION FINDXT(DIR,RM)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      FINDXT=.TRUE.                             ! assume wins.
      XI=REXIT(RM)                              ! find first entry.
      IF(XI.EQ.0) GO TO 1000                    ! no exits?
C
100   I=TRAVEL(XI)                              ! get entry.
      XROOM1=I.AND.XRMASK                       ! isolate room.
      XTYPE=(((I.AND..NOT.XLFLAG)/XFSHFT).AND.XFMASK)+1
      GO TO (110,120,130,130),XTYPE             ! branch on entry.
      CALL BUG(10,XTYPE)
C
130   XOBJ=TRAVEL(XI+2).AND.XRMASK              ! door/cexit- get obj/flag.
      XACTIO=TRAVEL(XI+2)/XASHFT
120   XSTRNG=TRAVEL(XI+1)                       ! door/cexit/nexit - string.
110   XI=XI+XELNT(XTYPE)                        ! advance to next entry.
      IF((I.AND.XDMASK).EQ.DIR) RETURN          ! match?
      IF((I.AND.XLFLAG).EQ.0) GO TO 100         ! last entry?
1000  FINDXT=.FALSE.                            ! yes, lose.
      RETURN
C
      END

C FWIM- Find what I mean
C
C Declarations
C
      INTEGER FUNCTION FWIM(F1,F2,RM,CON,ADV,NOCARE)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL NOCARE,QHERE
C
      FWIM=0                                    ! assume nothing.
      DO 1000 I=1,OLNT                          ! loop
        IF(((RM.EQ.0).OR.(.NOT.QHERE(I,RM))) .AND.
     1((ADV.EQ.0).OR.(OADV(I).NE.ADV)) .AND.
     2((CON.EQ.0).OR.(OCAN(I).NE.CON)))
     3GO TO 1000
C
C Object is on list... is it a match?
C
        IF((OFLAG1(I).AND.VISIBT).EQ.0) GO TO 1000
        IF((.NOT.NOCARE .AND.((OFLAG1(I).AND.TAKEBT).EQ.0)) .OR.
     1(((OFLAG1(I).AND.F1).EQ.0).AND.
     2 ((OFLAG2(I).AND.F2).EQ.0))) GO TO 500
        IF(FWIM.EQ.0) GO TO 400                 ! already got something?
        FWIM=-FWIM                              ! yes, ambiguous.
        RETURN
C
400     FWIM=I                                  ! note match.
C
C Does object contain a match?
C
500     IF((OFLAG2(I).AND.OPENBT).EQ.0) GO TO 1000 ! closed?
        DO 700 J=1,OLNT                         ! no, search contents.
          IF((OCAN(J).NE.I).OR.((OFLAG1(J).AND.VISIBT).EQ.0) .OR.
     1(((OFLAG1(J).AND.F1).EQ.0).AND.
     2 ((OFLAG2(J).AND.F2).EQ.0))) GO TO 700
          IF(FWIM.EQ.0) GO TO 600
          FWIM=-FWIM
          RETURN
C
600       FWIM=J
700     CONTINUE
1000  CONTINUE
      RETURN
C
      END

C ORPHAN- Set up orphans for parser
C
C Declarations
C
      SUBROUTINE ORPHAN(OR1,OR2,OR3,OR4,OR5,OR6,OR7,OR8)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      CHARACTER*(*) OR6
C
      OFLAG=OR1
      OACT=OR2
      OPREP1=OR3
      OOBJ1=OR4
      OPREP=OR5
      ONAME=OR6
      OPREP2=OR7
      OOBJ2=OR8
      RETURN
C
      END

C YESNO- Obtain yes/no answer
C
C Called by-
C
C       YES-IS-TRUE=YESNO(QUESTION,YES-STRING,NO-STRING)
C
      LOGICAL FUNCTION YESNO(Q,Y,N)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      CHARACTER*1 ANS
C
100   CALL RSPEAK(Q)                            ! ask
      READ(INPCH,110,END=120) ANS               ! get answer
110   FORMAT(A)
      IF((ANS.EQ.'Y').OR.(ANS.EQ.'y')) GO TO 200
      IF((ANS.EQ.'N').OR.(ANS.EQ.'n')) GO TO 300
120   CALL RSPEAK(6)                            ! scold.
      GO TO 100
C
200   YESNO=.TRUE.                              ! yes,
      CALL RSPEAK(Y)                            ! out with it.
      RETURN
C
300   YESNO=.FALSE.                             ! no,
      CALL RSPEAK(N)                            ! likewise.
      RETURN
C
      END

C ROBADV-- Steal winner's valuables
C
C Declarations
C
      INTEGER FUNCTION ROBADV(ADV,NR,NC,NA)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      ROBADV=0                                  ! count objects
      DO 100 I=1,OLNT
        IF((OADV(I).NE.ADV).OR.(OTVAL(I).LE.0).OR.
     1((OFLAG2(I).AND.SCRDBT).NE.0)) GO TO 100
        CALL NEWSTA(I,0,NR,NC,NA)               ! steal object
        ROBADV=ROBADV+1
100   CONTINUE
      RETURN
C
      END

C ROBRM-- Steal room valuables
C
C Declarations
C
      INTEGER FUNCTION ROBRM(RM,PR,NR,NC,NA)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL PROB,QHERE
C
      ROBRM=0                                   ! count objects
      DO 100 I=1,OLNT                           ! loop on objects.
        IF(.NOT. QHERE(I,RM)) GO TO 100
        IF((OTVAL(I).LE.0).OR.((OFLAG2(I).AND.SCRDBT).NE.0).OR.
     1((OFLAG1(I).AND.VISIBT).EQ.0).OR.(.NOT.PROB(PR,PR)))
     2GO TO 50
        CALL NEWSTA(I,0,NR,NC,NA)
        ROBRM=ROBRM+1
        OFLAG2(I)=OFLAG2(I).OR.TCHBT
        GO TO 100
50      IF((OFLAG2(I).AND.ACTRBT).NE.0)
     1ROBRM=ROBRM+ROBADV(OACTOR(I),NR,NC,NA)
100   CONTINUE
      RETURN
C
      END

C WINNIN-- See if villain is winning
C
C Declarations
C
      LOGICAL FUNCTION WINNIN(VL,HR)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL PROB
C
      VS=OCAPAC(VL)                             ! villain strength
      PS=VS-FIGHTS(HR,.TRUE.)                   ! his margin over hero
      WINNIN=PROB(90,100)
      IF(PS.GT.3) RETURN                        ! +3... 90% winning
      WINNIN=PROB(75,85)
      IF(PS.GT.0) RETURN                        ! >0... 75% winning
      WINNIN=PROB(50,30)
      IF(PS.EQ.0) RETURN                        ! =0... 50% winning
      WINNIN=PROB(25,25)
      IF(VS.GT.1) RETURN                        ! any villain strength.
      WINNIN=PROB(10,0)
      RETURN
C
      END

C FIGHTS-- Compute fight strength
C
C Declarations
C
      INTEGER FUNCTION FIGHTS(H,FLG)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      PARAMETER (STRMAX=7)
      PARAMETER (STRMIN=2)
      LOGICAL FLG
C
      FIGHTS=STRMIN+((((STRMAX-STRMIN)*ASCORE(H))+(MXSCOR/2))/MXSCOR)
      IF(FLG) FIGHTS=FIGHTS+ASTREN(H)
      RETURN
C
      END

C VILSTR-       Compute villain strength
C
C Declarations
C
      INTEGER FUNCTION VILSTR(V)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      VILSTR=OCAPAC(V)
      IF(VILSTR.LE.0) RETURN
      IF((V.NE.THIEF).OR..NOT.THFENF) GO TO 100
      THFENF=.FALSE.                            ! thief unengrossed.
      VILSTR=MIN0(VILSTR,2)                     ! no better than 2.
C
100   DO 200 I=1,VLNT                           ! see if best weapon.
        IF((VILLNS(I).EQ.V).AND.(PRSI.EQ.VBEST(I)))
     1VILSTR=MAX0(1,VILSTR-1)
200   CONTINUE
      RETURN
C
      END

C GTTIME-- Get total time played
C
C Declarations
C
      SUBROUTINE GTTIME(T)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      CALL ITIME(H,M,S)
      T=((H*60)+M)-((SHOUR*60)+SMIN)
      IF(T.LT.0) T=T+1440
      T=T+PLTIME
      RETURN
C
      END

C OPNCLS-- Process open/close for doors
C
C Declarations
C
      LOGICAL FUNCTION OPNCLS(OBJ,SO,SC)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL QOPEN
C
C Functions and data
C
      QOPEN(O)=(OFLAG2(O).AND.OPENBT).NE.0
C
      OPNCLS=.TRUE.                             ! assume wins.
      IF(PRSA.EQ.CLOSEW) GO TO 100              ! close?
      IF(PRSA.EQ.OPENW) GO TO 50                ! open?
      OPNCLS=.FALSE.                            ! lose
      RETURN
C
50    IF(QOPEN(OBJ)) GO TO 200                  ! open... is it?
      CALL RSPEAK(SO)
      OFLAG2(OBJ)=OFLAG2(OBJ).OR.OPENBT
      RETURN
C
100   IF(.NOT.QOPEN(OBJ)) GO TO 200             ! close... is it?
      CALL RSPEAK(SC)
      OFLAG2(OBJ)=OFLAG2(OBJ).AND..NOT.OPENBT
      RETURN
C
200   CALL RSPEAK(125+RND(3))                   ! dummy.
      RETURN
C
      END

C LIT-- Is room lit?
C
C Declarations
C
      LOGICAL FUNCTION LIT(RM)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL QHERE
C
      LIT=.TRUE.                                ! assume wins
      IF(DEADF.OR.((RFLAG(RM).AND.RLIGHT).NE.0)) RETURN ! room lit?
C
      DO 1000 I=1,OLNT                          ! look for lit obj
        IF(QHERE(I,RM)) GO TO 100               ! in room?
        OA=OADV(I)                              ! no
        IF(OA.LE.0) GO TO 1000                  ! on adv?
        IF(AROOM(OA).NE.RM) GO TO 1000          ! adv in room?
C
C Obj in room or on adv in room
C
100     IF((OFLAG1(I).AND.ONBT).NE.0) RETURN    ! lit?
        IF(((OFLAG1(I).AND.VISIBT).EQ.0).OR.
     1(((OFLAG1(I).AND.TRANBT).EQ.0).AND.
     2((OFLAG2(I).AND.OPENBT).EQ.0))) GO TO 1000
C
C Obj is visible and open or transparent
C
        DO 500 J=1,OLNT
          IF((OCAN(J).EQ.I).AND.((OFLAG1(J).AND.ONBT).NE.0))
     1RETURN
500     CONTINUE
1000  CONTINUE
      LIT=.FALSE.
      RETURN
C
      END

C WEIGHR- Returns sum of weight of qualifying objects
C
C Declarations
C
      INTEGER FUNCTION WEIGHR(CN,AD)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      LOGICAL QHERE
C
      WEIGHR=0
      DO 100 I=1,OLNT                           ! omit big fixed items.
        IF(OSIZE(I).GE.10000) GO TO 100         ! if fixed, forget it.
        IF((OADV(I).EQ.AD).AND.(AD.NE.0)) GO TO 50 ! on adv?
        J=I                                     ! see if contained.
25      J=OCAN(J)                               ! get next level up.
        IF(J.EQ.0) GO TO 100                    ! end of list?
        IF(((OADV(J).NE.AD).OR.(AD.EQ.0)) .AND.
     1(J.NE.CN)) GO TO 25                       ! cont on adv, or argument?
50      WEIGHR=WEIGHR+OSIZE(I)                  ! add in weight.
100   CONTINUE
      RETURN
C
      END

C GHERE--       Is global actually in this room?
C
C Declarations
C
      LOGICAL FUNCTION GHERE(OBJ,RM)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      GHERE=.TRUE.                              ! assume wins.
      IF(OBJ.LE.GLOBAL) RETURN                  ! if untested, return.
      GO TO (  100,1000,2000,3000,4000,5000,5000,5000,6000,
     37000,8000,9000,9100,8000,10000,11000,12000,
     413000,14000,15000),OBJ-GLOBAL
      CALL BUG(60,OBJ)
C
C 100-- Granite Wall
C
100   GHERE=(RM.EQ.TEMP1).OR.(RM.EQ.TREAS).OR.(RM.EQ.SLIDE)
      RETURN
C
C 1000--        House
C
1000  GHERE=((RM.GE.WHOUS).AND.(RM.LE.EHOUS)).OR.
     1((RM.GE.FORE1).AND.(RM.LE.CLEAR)).OR.(RM.EQ.MTREE)
      RETURN
C
C 2000--        Bird
C
2000  GHERE=((RM.GE.FORE1).AND.(RM.LT.CLEAR)).OR.(RM.EQ.MTREE)
      RETURN
C
C 3000--        Tree
C
3000  GHERE=((RM.GE.FORE1).AND.(RM.LT.CLEAR)).AND.(RM.NE.FORE3)
      RETURN
C
C 4000--        North wall
C
4000  GHERE=((RM.GE.BKVW).AND.(RM.LE.BKBOX)).OR.(RM.EQ.CPUZZ)
      RETURN
C
C 5000--        East, south, west walls
C
5000  GHERE=((RM.GE.BKVW).AND.(RM.LT.BKBOX)).OR.(RM.EQ.CPUZZ)
      RETURN
C
C 6000--        Global water
C
6000  GHERE=(RFLAG(RM).AND.(RWATER+RFILL)).NE.0
      RETURN
C
C 7000--        Global guardians
C
7000  GHERE=((RM.GE.MRC).AND.(RM.LE.MRD)).OR.
     1((RM.GE.MRCE).AND.(RM.LE.MRDW)).OR.(RM.EQ.INMIR)
      RETURN
C
C 8000--        Rose/channel
C
8000  GHERE=((RM.GE.MRA).AND.(RM.LE.MRD)).OR.(RM.EQ.INMIR)
      RETURN
C
C 9000--        Mirror
C 9100          Panel
C
9100  IF(RM.EQ.FDOOR) RETURN                    ! panel at fdoor.
9000  GHERE=((RM.GE.MRA).AND.(RM.LE.MRC)).OR.
     1((RM.GE.MRAE).AND.(RM.LE.MRCW))
      RETURN
C
C 10000--       Master
C
10000 GHERE=(RM.EQ.FDOOR).OR.(RM.EQ.NCORR).OR.(RM.EQ.PARAP).OR.
     1(RM.EQ.CELL).OR.(RM.EQ.PCELL).OR.(RM.EQ.NCELL)
      RETURN
C
C 11000--       Ladder
C
11000 GHERE=(RM.EQ.CPUZZ)
      RETURN
C
C 12000--       Well
C
12000 GHERE=(RM.EQ.TWELL).OR.(RM.EQ.BWELL)
      RETURN
C
C 13000--       Rope in slide
C
13000 GHERE=(RM.GE.SLID1).AND.(RM.LE.SLEDG)
      RETURN
C
C 14000--       Slide
C
14000 GHERE=(RM.GE.SLIDE).OR.((RM.GE.SLID1).AND.(RM.LE.SLEDG))
      RETURN
C
C 15000--       Bunch pseudo object
C
15000 GHERE=.FALSE.                     ! never present
      RETURN
C
      END

C MRHERE--      Is mirror here?
C
C Declarations
C
      INTEGER FUNCTION MRHERE(RM)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      IF((RM.LT.MRAE).OR.(RM.GT.MRDW)) GO TO 100
C
C Room is an e-w room, mirror must be n-s (mdir= 0 or 180)
C
      MRHERE=1                                  ! assume mirror 1 here.
      IF(MOD(RM-MRAE,2).EQ.(MDIR/180)) MRHERE=2
      RETURN
C
C Room is north or south of mirror.  If mirror is n-s or not
c within one room of room, lose.
C
100   MRHERE=0
      IF((IABS(MLOC-RM).NE.1).OR.(MOD(MDIR,180).EQ.0)) RETURN
C
C Room is within one of mloc, and mdir is e-w
C
      MRHERE=1
      IF(((RM.LT.MLOC).AND.(MDIR.LT.180)).OR.
     1 ((RM.GT.MLOC).AND.(MDIR.GT.180))) MRHERE=2
      RETURN
C
      END

C ENCRYP--      Encrypt password
C
C Declarations
C
      SUBROUTINE ENCRYP(INW,OUTW)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      CHARACTER*(WRDLNT) INW,OUTW,KEYW
      INTEGER UINW(8),UKEYW(8)
      DATA KEYW/'ECOVXRMS'/
C
      ICHARA=ICHAR('A')-1                       ! character base.
      UINWS=0                                   ! unbiased inw sum.
      UKEYWS=0                                  ! unbiased keyw sum.
      J=1                                       ! pointer in keyword.
      DO 100 I=1,WRDLNT                         ! unbias, compute sums.
        UKEYW(I)=ICHAR(KEYW(I:I))-ICHARA        ! strip ascii.
        IF(ICHAR(INW(J:J)).LE.ICHARA) J=1       ! recycle on bad.
        UINW(I)=ICHAR(INW(J:J))-ICHARA
        UKEYWS=UKEYWS+UKEYW(I)
        UINWS=UINWS+UINW(I)
        J=J+1
100   CONTINUE
C
      USUM=MOD(UINWS,8)+(8*MOD(UKEYWS,8))       ! compute mask.
      DO 200 I=1,8
        J=(UINW(I).XOR.UKEYW(I).XOR.USUM).AND.31
        USUM=MOD(USUM+1,32)
        IF(J.GT.26) J=MOD(J,26)
        OUTW(I:I)=CHAR(MAX0(1,J)+ICHARA)
200   CONTINUE
      RETURN
C
      END

C CPGOTO--      Move to next state in puzzle room
C
C Declarations
C
      SUBROUTINE CPGOTO(ST)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
C
      RFLAG(CPUZZ)=RFLAG(CPUZZ).AND..NOT.RSEEN
      DO 100 I=1,OLNT                           ! relocate objects.
        IF((OROOM(I).EQ.CPUZZ).AND.
     1((OFLAG2(I).AND.(ACTRBT+VILLBT)).EQ.0))
     2CALL NEWSTA(I,0,CPHERE*HFACTR,0,0)
        IF(OROOM(I).EQ.(ST*HFACTR))
     1CALL NEWSTA(I,0,CPUZZ,0,0)
100   CONTINUE
      CPHERE=ST
      RETURN
C
      END

C CPINFO--      Describe puzzle room
C
C Declarations
C
      SUBROUTINE CPINFO(RMK,ST)
      IMPLICIT INTEGER (A-Z)
      INCLUDE 'dparam.for'
      INTEGER DGMOFT(8)
      CHARACTER*2 DGM(8),PICT(5),QMK
C
C Functions and local data
C
      DATA DGMOFT/-9,-8,-7,-1,1,7,8,9/
      DATA PICT/'SS','SS','SS','  ','MM'/
      DATA QMK/'??'/
C
      CALL RSPEAK(RMK)
      DO 100 I=1,8
        J=DGMOFT(I)
        DGM(I)=PICT(CPVEC(ST+J)+4)              ! get picture element.
        IF((IABS(J).EQ.1).OR.(IABS(J).EQ.8)) GO TO 100
        K=8
        IF(J.LT.0) K=-8                         ! get ortho dir.
        L=J-K
        IF((CPVEC(ST+K).NE.0).AND.(CPVEC(ST+L).NE.0))
     1DGM(I)=QMK
100   CONTINUE
      WRITE(OUTCH,10) DGM
C
      IF(ST.EQ.10) CALL RSPEAK(870)             ! at hole?
      IF(ST.EQ.37) CALL RSPEAK(871)             ! at niche?
      I=872                                     ! door open?
      IF(CPOUTF) I=873
      IF(ST.EQ.52) CALL RSPEAK(I)               ! at door?
      IF(CPVEC(ST+1).EQ.-2) CALL RSPEAK(874)    ! east ladder?
      IF(CPVEC(ST-1).EQ.-3) CALL RSPEAK(875)    ! west ladder?
      RETURN
C
10    FORMAT('       |',A,1X,A,1X,A,'|'/,
     1' West  |',A,' .. ',A,'|  East'/,
     2'       |',A,1X,A,1X,A,'|')
C
      END

C NBLEN-        Compute string length without trailing blanks
C
C Declarations
C
      INTEGER FUNCTION NBLEN(STRING)
      IMPLICIT INTEGER (A-Z)
      CHARACTER*(*) STRING
C
      NBLEN=LEN(STRING)                         ! get nominal length
100   IF(NBLEN.LE.0) RETURN                     ! any string left?
      IF(STRING(NBLEN:NBLEN).NE.' ') RETURN     ! found a non-blank?
      NBLEN=NBLEN-1                             ! no, trim len by 1
      GO TO 100                                 ! and continue.
C
      END

C
C RND - Return a random integer mod n
C
      INTEGER FUNCTION RND (N)
      IMPLICIT INTEGER (A-Z)
      REAL R

      CALL RANDOM(R)
      RND = R*FLOAT(N)
      RETURN

      END
C
C INIRND - Initialize random number seed
C
      SUBROUTINE INIRND (LOW, HIGH)
      IMPLICIT INTEGER (A-Z)

      CALL SEED((ISHFT(HIGH,16)+LOW).OR.1)
      RETURN

      END
