1 C VALUAC- Handles valuables/everything/possessions/bunch object
  2 C           for take, put, drop, count
  3 C
  4 C Declarations
  5 C
  6           SUBROUTINE VALUAC(V)
  7           IMPLICIT INTEGER (A-Z)
  8           %include dparam
  9           LOGICAL LIT,F,F1,TAKE,PUT,DROP,NOTHIS,NOHERE,QHERE,QBUNCH
 10 C
 11 C Functions and data
 12 C
 13           NOTHIS(R)=((SAVEP.EQ.BUNOBJ).AND.QBUNCH(R)) .OR.
 14           &           ((OTVAL(R).LE.0).AND.((SAVEP.EQ.VALUA).OR.
 15           &            ((SAVEP.EQ.BUNOBJ).AND.(BUNSUB.EQ.VALUA)))) .OR.
 16           &           ((OADV(R).NE.WINNER).AND.((SAVEP.EQ.POSSE).OR.
 17           &            ((SAVEP.EQ.BUNOBJ).AND.(BUNSUB.EQ.POSSE))))
 18 
 19           NOHERE(R)=((AV.EQ.0).AND..NOT.QHERE(R,HERE)) .OR.
 20           &           ((AV.NE.0).AND.(OCAN(R).NE.AV))
 21 C page
 22 C VALUAC, PAGE 2
 23 C Count
 24 C
 25           IF((PRSA.NE.COUNTW).OR.(PRSO.NE.POSSE)) GO TO 100
 26           K=0
 27           DO 50 J=1,OLNT                                    ! count possessions.
 28             IF(OADV(J).EQ.WINNER) K=K+1
 29 50        CONTINUE
 30           IF(K.EQ.1) WRITE(OUTCH,60) K
 31           IF(K.NE.1) WRITE(OUTCH,70) K
 32 60        FORMAT(' You have ',I1,' possession.')
 33 70        FORMAT(' You have ',I2,' possessions.')
 34           TELFLG=.TRUE.
 35           RETURN
 36 C
 37 100       IF((PRSA.NE.COUNTW).OR.(PRSO.NE.VALUA)) GO TO 200
 38           K=0
 39           L=0
 40           DO 150 J=1,OLNT                                   ! count treasures.
 41             IF((OADV(J).EQ.WINNER).AND.(OTVAL(J).GT.0)) K=K+1
 42             IF((OCAN(J).EQ.TCASE).AND.(OTVAL(J).GT.0)) L=L+1
 43 150       CONTINUE
 44           IF(K.EQ.1) WRITE(OUTCH,160) K
 45           IF(K.NE.1) WRITE(OUTCH,170) K
 46 160       FORMAT(' You have ',I1,' valuable.')
 47 170       FORMAT(' You have ',I2,' valuables.')
 48           TELFLG=.TRUE.
 49           IF(HERE.NE.LROOM) RETURN
 50           IF(L.EQ.1) WRITE(OUTCH,180) L
 51           IF(L.NE.1) WRITE(OUTCH,190) L
 52 180       FORMAT(' Your adventure has netted ',I1,' treasure.')
 53 190       FORMAT(' Your adventure has netted ',I2,' treasures.')
 54           RETURN
 55 C page
 56 C VALUAC, PAGE 3
 57 C Take
 58 C
 59 200       SAVEP=PRSO                                        ! save prso.
 60           SAVEH=HERE                                        ! save here.
 61           F=.TRUE.                                ! assume no actions.
 62           I=579                                             ! assume not lit.
 63           AV=AVEHIC(WINNER)                       ! get vehicle.
 64 C
 65           IF(PRSA.NE.TAKEW) GO TO 1000            ! take?
 66           IF(.NOT.LIT(HERE)) GO TO 4500           ! if not lit, punt.
 67           IF((PRSO.NE.BUNOBJ).OR.(BUNSUB.NE.0)) GO TO 400   ! bunch, no except?
 68           DO 300 I=1,BUNLNT                       ! loop through bunch.
 69             PRSO=BUNVEC(I)                        ! get next item.
 70             F=.FALSE.
 71             CALL RSPSUB(580,ODESC2(PRSO))
 72             F1=TAKE(.TRUE.)
 73             IF(SAVEH.NE.HERE) GO TO 4500
 74 300       CONTINUE
 75           GO TO 4000                                        ! go clean up.
 76 C
 77 400       DO 500 PRSO=1,OLNT                      ! loop thru objects.
 78 C old       IF((((OFLAG1(PRSO).AND.TAKEBT).EQ.0).AND.
 79 C old     &         ((OFLAG2(PRSO).AND.TRYBT).EQ.0)).OR.
 80 C old     &         ((OFLAG1(PRSO).AND.VISIBT).EQ.0).OR.
 81 C old     &         ((OFLAG2(PRSO).AND.ACTRBT).NE.0).OR.
 82 C old     &         NOTHIS(PRSO)) GO TO 500
 83             IF(((AND(OFLAG1(PRSO),TAKEBT).EQ.0).AND.
 84           &         (AND(OFLAG2(PRSO),TRYBT).EQ.0)).OR.
 85           &         (AND(OFLAG1(PRSO),VISIBT).EQ.0).OR.
 86           &         (AND(OFLAG2(PRSO),ACTRBT).NE.0).OR.
 87           &         NOTHIS(PRSO)) GO TO 500
 88             IF(.NOT.NOHERE(PRSO)) GO TO 450       ! is it here?
 89             J=OCAN(PRSO)                                    ! get container.
 90             IF((J.EQ.0).OR.(PRSO.EQ.WATER)) GO TO 500       ! in a cont?
 91 C old       IF(((OFLAG2(J).AND.OPENBT).EQ.0).OR.
 92 C old     &         (NOHERE(J).AND.(OADV(J).NE.WINNER)))
 93 C old     &         GO TO 500                     ! in open cont here?
 94             IF((AND(OFLAG2(J),OPENBT).EQ.0).OR.
 95           &         (NOHERE(J).AND.(OADV(J).NE.WINNER)))
 96           &         GO TO 500                     ! in open cont here?
 97 C
 98 450         F=.FALSE.
 99             CALL RSPSUB(580,ODESC2(PRSO))
100             F1=TAKE(.TRUE.)
101             IF(SAVEH.NE.HERE) GO TO 4500
102 500       CONTINUE
103           GO TO 4000                                        ! go clean up.
104 C page
105 C VALUAC, PAGE 4
106 C Drop
107 C
108 1000      IF(PRSA.NE.DROPW) GO TO 2000            ! drop?
109           IF((PRSO.NE.BUNOBJ).OR.(BUNSUB.NE.0)) GO TO 1400 ! bunch, no except?
110           DO 1300 I=1,BUNLNT                      ! loop through bunch.
111             PRSO=BUNVEC(I)                        ! get next item.
112             F=.FALSE.
113             CALL RSPSUB(580,ODESC2(PRSO))
114             F1=DROP(.TRUE.)
115             IF(SAVEH.NE.HERE) GO TO 4500
116 1300      CONTINUE
117           GO TO 4000                                        ! go clean up.
118 C
119 1400      DO 1500 PRSO=1,OLNT                     ! loop through inventory.
120             IF((OADV(PRSO).NE.WINNER).OR.NOTHIS(PRSO))
121           &         GO TO 1500
122             F=.FALSE.
123             CALL RSPSUB(580,ODESC2(PRSO))
124             F1=DROP(.TRUE.)
125             IF(SAVEH.NE.HERE) GO TO 4500
126 1500      CONTINUE
127           GO TO 4000                                        ! go clean up.
128 C page
129 C VALUAC, PAGE 5
130 C Put
131 C
132 2000      IF(PRSA.NE.PUTW) GO TO 3000             ! put?
133           IF(.NOT.LIT(HERE)) GO TO 4500           ! if not lit, punt.
134           IF((PRSO.NE.BUNOBJ).OR.(BUNSUB.NE.0)) GO TO 2400 ! bunch, no except?
135           DO 2300 I=1,BUNLNT                      ! loop through bunch.
136             PRSO=BUNVEC(I)                        ! get next item.
137             F=.FALSE.
138             CALL RSPSUB(580,ODESC2(PRSO))
139             F1=PUT(.TRUE.)
140             IF(SAVEH.NE.HERE) GO TO 4500
141 2300      CONTINUE
142           GO TO 4000                                        ! go clean up.
143 C
144 2400      DO 2500 PRSO=1,OLNT                     ! loop thru objects.
145 C old       IF(((OADV(PRSO).NE.WINNER).AND.
146 C old     &         (NOHERE(PRSO).OR.
147 C old     &         (((OFLAG1(PRSO).AND.TAKEBT).EQ.0).AND.
148 C old     &          ((OFLAG2(PRSO).AND.TRYBT).EQ.0)))) .OR.
149 C old     &         (PRSO.EQ.PRSI).OR.NOTHIS(PRSO).OR.
150 C old     &         ((OFLAG1(PRSO).AND.VISIBT).EQ.0)) GO TO 2500
151             IF(((OADV(PRSO).NE.WINNER).AND.
152           &         (NOHERE(PRSO).OR.
153           &         ((AND(OFLAG1(PRSO),TAKEBT).EQ.0).AND.
154           &          (AND(OFLAG2(PRSO),TRYBT).EQ.0)))) .OR.
155           &         (PRSO.EQ.PRSI).OR.NOTHIS(PRSO).OR.
156           &         (AND(OFLAG1(PRSO),VISIBT).EQ.0)) GO TO 2500
157             F=.FALSE.
158             CALL RSPSUB(580,ODESC2(PRSO))
159             F1=PUT(.TRUE.)
160             IF(SAVEH.NE.HERE) GO TO 4500
161 2500      CONTINUE
162           GO TO 4000                                        ! go clean up.
163 C
164 C Wrong verb.
165 C
166 3000      I=677                                             ! wrong verb.
167           GO TO 4500
168 C
169 C Clean up.
170 C
171 4000      I=581                                             ! right verb, choose
172           IF(SAVEP.EQ.VALUA) I=582                ! nothing happened message.
173 4500      IF(F) CALL RSPEAK(I)                              ! not lit, nothing, wrong verb?
174           PRSO=SAVEP                                        ! restore PRSO.
175           BUNSUB=0                                ! cancel EXCEPT/BUT.
176           RETURN
177           END
178 C page
179 C QBUNCH- Is object in bunch vector?
180 C
181 C Declarations
182 C
183           LOGICAL FUNCTION QBUNCH(OBJ)
184           IMPLICIT INTEGER (A-Z)
185           %include dparam
186 C
187           IF(BUNLNT.EQ.0) GO TO 200               ! bunch vector empty?
188           QBUNCH=.TRUE.                                     ! assume found.
189           DO 100 I=1,BUNLNT                       ! search bunch vector.
190             IF(OBJ.EQ.BUNVEC(I)) RETURN           ! got one.
191 100       CONTINUE
192 200       QBUNCH=.FALSE.                                    ! not found.
193           RETURN
194 C
195           END
196 C page
197 C SAVE- Save game state
198 C
199 C Declarations
200 C
201           SUBROUTINE SAVEGM
202           IMPLICIT INTEGER (A-Z)
203           %include dparam
204 C
205           IF(SUBLNT.EQ.0) SUBBUF='DSAVE.DAT'
206 C old     OPEN (UNIT=1,NAME=SUBBUF,ACCESS='SEQUENTIAL',
207 C old     &         STATUS='UNKNOWN',FORM='UNFORMATTED',ERR=100)
208           OPEN (UNIT=1,FILE=SUBBUF,ACCESS='SEQUENTIAL',
209           &         STATUS='UNKNOWN',FORM='UNFORMATTED',ERR=100)
210 C
211           CALL GTTIME(I)                                    ! get time.
212           WRITE(1) VMAJ,VMIN
213           WRITE(1) WINNER,HERE,THFPOS,TELFLG,THFFLG,THFACT,
214           &         SWDACT,SWDSTA,CPVEC
215           WRITE(1) I,MOVES,DEATHS,RWSCOR,EGSCOR,MXLOAD,
216           &         LTSHFT,BLOC,MUNGRM,HS,FROMDR,SCOLRM,SCOLAC
217           WRITE(1) ODESC1,ODESC2,OFLAG1,OFLAG2,OFVAL,OTVAL,
218           &         OSIZE,OCAPAC,OROOM,OADV,OCAN
219           WRITE(1) RDESC1,RVAL,RFLAG,TRAVEL
220           WRITE(1) AROOM,ASCORE,AVEHIC,ASTREN,AFLAG
221           WRITE(1) FLAGS,SWITCH,VPROB,CFLAG,CTICK,CCNCEL
222 C
223           CALL RSPEAK(597)
224           CLOSE (UNIT=1)
225           RETURN
226 C
227 100       CALL RSPEAK(598)                        ! cant do it.
228           RETURN
229           END
230 C page
231 C RESTORE- Restore game state
232 C
233 C Declarations
234 C
235           SUBROUTINE RSTRGM
236           IMPLICIT INTEGER (A-Z)
237           %include dparam
238 C
239           IF(SUBLNT.EQ.0) SUBBUF='DSAVE.DAT'
240 C old     OPEN (UNIT=1,NAME=SUBBUF,ACCESS='SEQUENTIAL',
241 C old     &         STATUS='OLD',FORM='UNFORMATTED',ERR=100)
242           OPEN (UNIT=1,FILE=SUBBUF,ACCESS='SEQUENTIAL',
243           &         STATUS='OLD',FORM='UNFORMATTED',ERR=100)
244 C
245           READ(1) I,J
246           IF((I.NE.VMAJ).OR.(J.NE.VMIN)) GO TO 200
247 C
248           READ(1) WINNER,HERE,THFPOS,TELFLG,THFFLG,THFACT,
249           &         SWDACT,SWDSTA,CPVEC
250           READ(1) PLTIME,MOVES,DEATHS,RWSCOR,EGSCOR,MXLOAD,
251           &         LTSHFT,BLOC,MUNGRM,HS,FROMDR,SCOLRM,SCOLAC
252           READ(1) ODESC1,ODESC2,OFLAG1,OFLAG2,OFVAL,OTVAL,
253           &         OSIZE,OCAPAC,OROOM,OADV,OCAN
254           READ(1) RDESC1,RVAL,RFLAG,TRAVEL
255           READ(1) AROOM,ASCORE,AVEHIC,ASTREN,AFLAG
256           READ(1) FLAGS,SWITCH,VPROB,CFLAG,CTICK,CCNCEL
257 C
258           CALL RSPEAK(599)
259           CLOSE (UNIT=1)
260           RETURN
261 C
262 100       CALL RSPEAK(598)                        ! cant do it.
263           RETURN
264 C
265 200       CALL RSPEAK(600)                        ! obsolete version
266           CLOSE (UNIT=1)
267           RETURN
268           END
269 C page
270 C WALK- Move in specified direction
271 C
272 C Declarations
273 C
274           LOGICAL FUNCTION WALK(X)
275           IMPLICIT INTEGER (A-Z)
276           %include dparam
277           LOGICAL FINDXT,QOPEN,LIT,PROB,MOVETO,RMDESC
278 C
279 C Functions and data
280 C
281 C old     QOPEN(O)=(OFLAG2(O).AND.OPENBT).NE.0
282           QOPEN(O)=AND(OFLAG2(O),OPENBT).NE.0
283 C page
284 C WALK, PAGE 2
285 C
286           WALK=.TRUE.                                       ! assume wins.
287           IF((WINNER.NE.PLAYER).OR.LIT(HERE).OR.PROB(25,25))
288           &         GO TO 500
289           IF(.NOT.FINDXT(PRSO,HERE)) GO TO 450    ! invalid exit? grue!
290           GO TO (400,200,100,300),XTYPE           ! decode exit type.
291           CALL BUG(9,XTYPE)
292 C
293 100       IF(CXAPPL(XACTIO).NE.0) GO TO 400       ! cexit... returned room?
294           IF(FLAGS(XFLAG)) GO TO 400              ! no, flag on?
295 200       CALL JIGSUP(523)                        ! bad exit, grue!
296           RETURN
297 C
298 300       IF(CXAPPL(XACTIO).NE.0) GO TO 400       ! door... returned room?
299           IF(QOPEN(XOBJ)) GO TO 400               ! no, door open?
300           CALL JIGSUP(523)                        ! bad exit, grue!
301           RETURN
302 C
303 400       IF(LIT(XROOM1)) GO TO 900               ! valid room, is it lit?
304 450       CALL JIGSUP(522)                        ! no, grue!
305           RETURN
306 C
307 C Room is lit, or winner is not player (no grue).
308 C
309 500       IF(FINDXT(PRSO,HERE)) GO TO 550                   ! exit exist?
310 525       XSTRNG=678                                        ! assume wall.
311           IF(PRSO.EQ.XUP) XSTRNG=679              ! if up, cant.
312           IF(PRSO.EQ.XDOWN) XSTRNG=680            ! if down, cant.
313 C old     IF(((RFLAG(HERE).AND.RNWALL).NE.0).AND.(WINNER.EQ.PLAYER))
314 C old     &         XSTRNG=524                              ! no wall for player.
315           IF((AND(RFLAG(HERE),RNWALL).NE.0).AND.(WINNER.EQ.PLAYER))
316           &         XSTRNG=524                              ! no wall for player.
317           CALL RSPEAK(XSTRNG)
318           PRSCON=0                                ! stop cmd stream.
319           RETURN
320 C
321 550       GO TO (900,600,700,800),XTYPE           ! branch on exit type.
322           CALL BUG(9,XTYPE)
323 C
324 700       IF(CXAPPL(XACTIO).NE.0) GO TO 900       ! cexit... returned room?
325           IF(FLAGS(XFLAG)) GO TO 900              ! no, flag on?
326 600       IF(XSTRNG.EQ.0) GO TO 525               ! if no reason, use std.
327           CALL RSPEAK(XSTRNG)                     ! deny exit.
328           PRSCON=0                                ! stop cmd stream.
329           RETURN
330 C
331 800       IF(CXAPPL(XACTIO).NE.0) GO TO 900       ! door... returned room?
332           IF(QOPEN(XOBJ)) GO TO 900               ! no, door open?
333           IF(XSTRNG.EQ.0) XSTRNG=525              ! if no reason, use std.
334           CALL RSPSUB(XSTRNG,ODESC2(XOBJ))
335           PRSCON=0                                ! stop cmd stream.
336           RETURN
337 C
338 900       WALK=MOVETO(XROOM1,WINNER)              ! move to room.
339           IF(WALK) WALK=RMDESC(0)                           ! describe room.
340           RETURN
341           END