1 C Subroutines for DUNGEON
  2 C
  3 C COPYRIGHT 1980, 1990, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA.
  4 C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  5 C WRITTEN BY R. M. SUPNIK
  6 C
  7 C 27-Sep-94         RMS       Fixed bugs in WEIGHR, JIGSUP, SCORE.
  8 C                             Added GRANITE WALL to GHERE.
  9 C 30-Jan-94         RMS       Fixed bugs from MS DOS port.
 10 C 30-Jun-92         RMS       Changed file names to lower case.
 11 C 29-Jun-92         RMS       Removed extraneous declaration in RMDESC.
 12 C
 13 C RSPEAK-- Output random message routine
 14 C
 15 C Called by--
 16 C
 17 C         CALL RSPEAK(MSGNUM)
 18 C
 19           SUBROUTINE RSPEAK(N)
 20           IMPLICIT INTEGER (A-Z)
 21 C
 22           CALL RSPSB2(N,0,0)
 23           RETURN
 24 C
 25           END
 26 C
 27 C RSPSUB-- Output random message with substitutable argument
 28 C
 29 C Called by--
 30 C
 31 C         CALL RSPSUB(MSGNUM,SUBNUM)
 32 C
 33           SUBROUTINE RSPSUB(N,S1)
 34           IMPLICIT INTEGER (A-Z)
 35 C
 36           CALL RSPSB2(N,S1,0)
 37           RETURN
 38 C
 39           END
 40 C page
 41 C RSPSB2-- Output random message with substitutable arguments
 42 C
 43 C Called by--
 44 C
 45 C         CALL RSPSB2(MSGNUM,S1,S2)
 46 C
 47           SUBROUTINE RSPSB2(A,B,C)
 48           IMPLICIT INTEGER (A-Z)
 49           %include dparam
 50           CHARACTER*(TEXLNT) B1,B2
 51           external dtext_$read (descriptors)
 52 C
 53 C Convert all arguments from dictionary numbers (if positive)
 54 c to absolute record numbers.
 55 C
 56           X=A                                               ! set up work variables.
 57           Y=B
 58           Z=C
 59           IF(X.GT.0) X=RTEXT(X)                             ! if >0, look up in rtext.
 60           IF(Y.GT.0) Y=RTEXT(Y)
 61           IF(Z.GT.0) Z=RTEXT(Z)
 62           X=IABS(X)                               ! take abs value.
 63           Y=IABS(Y)
 64           Z=IABS(Z)
 65           IF(X.EQ.0) RETURN                       ! anything to do?
 66           TELFLG=.TRUE.                                     ! said something.
 67 C
 68 C old     READ(DBCH,REC=X) OLDREC,B1              ! read first line.
 69           call dtext_$read (x, oldrec, b1)        ! read first line.
 70 100       CALL TXCRYP(X,B1)                       ! decrypt line.
 71 C
 72 200       IF(Y.EQ.0) GO TO 400                              ! any substitutable?
 73           I=INDEX(B1,'#')                                   ! look for #.
 74           IF(I.GT.0) GO TO 1000                             ! found?
 75 C
 76 400       WRITE(OUTCH,650) B1(1:MAX0(1,NBLEN(B1)))! output line.
 77 650       FORMAT(1X,A)
 78           X=X+1                                             ! on to next record.
 79 C old     READ(DBCH,REC=X) NEWREC,B1              ! read next record.
 80           call dtext_$read (x, newrec, b1)        ! read next record.
 81           IF(OLDREC.EQ.NEWREC) GO TO 100                    ! continuation?
 82           RETURN                                            ! no, exit.
 83 C page
 84 C RSPSB2, PAGE 2
 85 C
 86 C Substitution with substitutable available.
 87 C I is index of # in B1.
 88 C Y is number of record to substitute.
 89 C
 90 C Procedure:
 91 C   1) Copy rest of B1 to B2
 92 C   2) Read substitutable over B1
 93 C   3) Restore tail of original B1
 94 C
 95 C The implicit assumption here is that the substitutable string
 96 c is very short.
 97 C
 98 1000      B2(1:(TEXLNT-I))=B1(I+1:TEXLNT)                   ! copy rest of B1.
 99 C
100 C old     READ(DBCH,REC=Y) J,B1(I:TEXLNT)                   ! read sub record.
101           call dtext_$read (y, j, B1(I:TEXLNT))             ! read sub record.
102           CALL TXCRYP(Y,B1(I:TEXLNT))             ! decrypt sub record.
103           J=NBLEN(B1)                                       ! backscan for blanks.
104           B1(J+1:TEXLNT)=B2(1:TEXLNT-J)
105 C
106           Y=Z                                               ! set up for next
107           Z=0                                               ! substitution and
108           GO TO 200                               ! recheck line.
109 C
110           END
111 C page
112 C OBJACT-- Apply objects from parse vector
113 C
114 C Declarations
115 C
116           LOGICAL FUNCTION OBJACT(X)
117           IMPLICIT INTEGER (A-Z)
118           %include dparam
119           LOGICAL OAPPLI
120 C
121           OBJACT=.TRUE.                                     ! assume wins.
122           IF(PRSI.EQ.0) GO TO 100                           ! ind object?
123           IF(OAPPLI(OACTIO(PRSI),0)) RETURN       ! yes, let it handle.
124 C
125 100       IF(PRSO.EQ.0) GO TO 200                           ! dir object?
126           IF(OAPPLI(OACTIO(PRSO),0)) RETURN       ! yes, let it handle.
127 C
128 200       OBJACT=.FALSE.                                    ! loses.
129           RETURN
130 C
131           END
132 C page
133 C BUG-- Report fatal system error
134 C
135 C Declarations
136 C
137           SUBROUTINE BUG(A,B)
138           IMPLICIT INTEGER (A-Z)
139           %include dparam
140 C
141           WRITE(OUTCH,100) A,B                              ! gonzo
142           IF(DBGFLG.NE.0) RETURN
143           SUBBUF='CRASH.DAT'                      ! set up crash save name.
144           SUBLNT=NBLEN(SUBBUF)
145           CALL SAVEGM                                       ! do final save.
146           WRITE(OUTCH,200)
147           CALL EXIT
148 C
149 100       FORMAT(' Program error ',I2,', parameter =',I6)
150 200       FORMAT(' Game state saved in "CRASH.DAT".')
151 C
152           END
153 C page
154 C NEWSTA-- Set new status for object
155 C
156 C Called by--
157 C
158 C         CALL NEWSTA(OBJECT,STRING,NEWROOM,NEWCON,NEWADV)
159 C
160           SUBROUTINE NEWSTA(O,R,RM,CN,AD)
161           IMPLICIT INTEGER (A-Z)
162           %include dparam
163 C
164           CALL RSPEAK(R)
165           OROOM(O)=RM
166           OCAN(O)=CN
167           OADV(O)=AD
168           RETURN
169 C
170           END
171 C page
172 C QHERE-- Test for object in room
173 C
174 C Declarations
175 C
176           LOGICAL FUNCTION QHERE(OBJ,RM)
177           IMPLICIT INTEGER (A-Z)
178           %include dparam
179 C
180           QHERE=.TRUE.
181           IF(OROOM(OBJ).EQ.RM) RETURN             ! in room?
182           DO 100 I=1,R2LNT                        ! no, sch room2.
183             IF((O2(I).EQ.OBJ).AND.(R2(I).EQ.RM)) RETURN
184 100       CONTINUE
185           QHERE=.FALSE.                                     ! not present.
186           RETURN
187 C
188           END
189 C page
190 C QEMPTY-- Test for object empty
191 C
192 C Declarations
193 C
194           LOGICAL FUNCTION QEMPTY(OBJ)
195           IMPLICIT INTEGER (A-Z)
196           %include dparam
197 C
198           QEMPTY=.FALSE.                                    ! assume lose.
199           DO 100 I=1,OLNT
200             IF(OCAN(I).EQ.OBJ) RETURN             ! inside target?
201 100       CONTINUE
202           QEMPTY=.TRUE.
203           RETURN
204 C
205           END