1 C Command loop, initialization 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 17-Sep-94         RMS       Fixed TELL/parse fail bug.  Fixed VMS/UNIX
  8 C                             compatibility problem.
  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
 12 C GAME- Main command loop
 13 C
 14 C Declarations
 15 C
 16           SUBROUTINE GAME
 17           IMPLICIT INTEGER (A-Z)
 18           %include dparam
 19           LOGICAL RMDESC,VAPPLI,AAPPLI,OBJACT
 20           LOGICAL F,PARSE,FINDXT,XVEHIC,LIT,PRVLIT
 21 C page
 22 C GAME, PAGE 2
 23 C
 24 C Start up, describe current location.
 25 C
 26           CALL RSPEAK(1)                                    ! welcome aboard.
 27           F=RMDESC(3)                                       ! start game.
 28 C
 29 C Now loop, reading and executing commands.
 30 C
 31 100       WINNER=PLAYER                                     ! player moving.
 32           TELFLG=.FALSE.                                    ! assume nothing told.
 33           IF(PRSCON.LE.1) CALL RDLINE(INBUF,INLNT,1) ! read command.
 34 C
 35           IF(INBUF(PRSCON:INLNT).NE.'GDT') GO TO 200        ! call on gdt?
 36           CALL GDT                                ! yes, invoke.
 37           PRSCON=1                                ! force restart.
 38           GO TO 100                               ! onward.
 39 C
 40 200       MOVES=MOVES+1
 41           SUBLNT=0                                ! no substrings.
 42           PRVHER=HERE                                       ! save current location.
 43           PRVLIT=LIT(HERE)                        ! save current lighting.
 44           PRSWON=PARSE(INBUF,INLNT,.TRUE.)        ! parse input, normal mode.
 45           IF(.NOT.PRSWON) GO TO 400               ! parse lose?
 46           IF(AAPPLI(AACTIO(WINNER))) GO TO 400    ! player handle?
 47           IF(XVEHIC(1)) GO TO 400                           ! vehicle handle?
 48 C
 49           IF(PRSA.EQ.TELLW) GO TO 2000            ! tell?
 50 300       IF((PRSO.EQ.VALUA).OR.(PRSO.EQ.EVERY).OR.(PRSO.EQ.POSSE)
 51           &         .OR.(PRSO.EQ.BUNOBJ)) GO TO 900         ! collective object?
 52           IF(.NOT.VAPPLI(PRSA)) GO TO 400                   ! verb ok?
 53           IF(.NOT.PRVLIT.AND.(HERE.EQ.PRVHER)
 54           &         .AND.LIT(HERE)) F=RMDESC(0)   ! now lit
 55 350       IF(.NOT.(ECHOF.OR.DEADF).AND.(HERE.EQ.ECHOR)) GO TO 1000
 56           CALL RAPPLI(RACTIO(HERE))               ! room action?
 57 C
 58 400       CALL XENDMV(TELFLG)                     ! do end of move.
 59           IF(.NOT.LIT(HERE)) PRSCON=1             ! if not lit, restart.
 60           GO TO 100
 61 C
 62 900       CALL VALUAC(PRSO)                       ! collective object.
 63           GO TO 350
 64 C page
 65 C GAME, PAGE 3
 66 C
 67 C Special case-- Echo Room.
 68 C If input is not 'ECHO' or a direction, just echo.
 69 C
 70 1000      CALL RDLINE(INBUF,INLNT,0)              ! read line.
 71           MOVES=MOVES+1                                     ! charge for moves.
 72           IF(INBUF.NE.'ECHO') GO TO 1100                    ! input = echo?
 73 C
 74           CALL RSPEAK(571)                        ! kill the echo.
 75           ECHOF=.TRUE.
 76 C old     OFLAG2(BAR)=OFLAG2(BAR).AND. .NOT.SCRDBT ! let thief steal bar.
 77           OFLAG2(BAR)=AND (OFLAG2(BAR), COMPL(SCRDBT)) ! let thief steal bar.
 78           PRSWON=.TRUE.                                     ! fake out parser.
 79           PRSCON=1                                ! force new input.
 80           GO TO 400
 81 C
 82 1100      IF(INBUF.NE.'BUG') GO TO 1200           ! bug request?
 83           CALL RSPEAK(913)                        ! wrong, jack.
 84           GO TO 1000                                        ! try again.
 85 C
 86 1200      IF(INBUF.NE.'FEATURE') GO TO 1300       ! feature request?
 87           CALL RSPEAK(914)                        ! right, jack.
 88           GO TO 1000                                        ! try again
 89 C
 90 1300      PRSWON=PARSE(INBUF,INLNT,.FALSE.)       ! parse input, echo mode.
 91           IF(.NOT.PRSWON .OR. (PRSA.NE.WALKW))
 92           &         GO TO 1400                              ! walk?
 93           IF(FINDXT(PRSO,HERE)) GO TO 300                   ! valid exit?
 94 C
 95 1400      WRITE(OUTCH,1410) INBUF(1:INLNT)        ! echo input.
 96 1410      FORMAT(1X,A)
 97           TELFLG=.TRUE.                                     ! indicate output.
 98           GO TO 1000                                        ! more echo room.
 99 C page
100 C GAME, PAGE 4
101 C
102 C Special case-- TELL <ACTOR> "NEW COMMAND".
103 C Note that we cannot be in the Echo Room.
104 C
105 2000      IF(SUBLNT.NE.0) GO TO 2050              ! any substring?
106           CALL RSPSUB(946,ODESC2(PRSO))           ! no, joke.
107           GO TO 2150                                        ! done.
108 C
109 2050      IF(PRSO.NE.OPLAY) GO TO 2100            ! to self?
110           WRITE(OUTCH,2060) SUBBUF(1:SUBLNT)      ! ok, tell it.
111 2060      FORMAT(' Ok: "',A,'".')
112           TELFLG=.TRUE.
113           GO TO 2150
114 C
115 2100      IF(OBJACT(X)) GO TO 350                           ! object handle?
116 C old     IF((OFLAG2(PRSO).AND.ACTRBT).NE.0) GO TO 2200 ! actor?
117           IF(AND (OFLAG2(PRSO),ACTRBT).NE.0) GO TO 2200 ! actor?
118           I=602
119 C old     IF((OFLAG1(PRSO).AND.VICTBT).NE.0) I=888
120           IF(AND (OFLAG1(PRSO),VICTBT).NE.0) I=888
121           CALL RSPSUB(I,ODESC2(PRSO))             ! no, joke.
122 2150      PRSCON=0                                ! disable cmd stream.
123           GO TO 350
124 C
125 2200      SVPRSC=PRSCON                                     ! save prscon.
126           SVPRSO=PRSO                                       ! save prso.
127           PRSCON=1                                ! start of substring.
128 2300      WINNER=OACTOR(SVPRSO)                             ! new player.
129           HERE=AROOM(WINNER)                      ! new location.
130           PRSWON=PARSE(SUBBUF,SUBLNT,.TRUE.)      ! parse command.
131           IF(.NOT.PRSWON) GO TO 2600              ! parse succeed?
132 C
133           IF(AAPPLI(AACTIO(WINNER))) GO TO 2400   ! actor handle?
134           IF(XVEHIC(1)) GO TO 2400                ! vehicle handle?
135           IF((PRSO.EQ.VALUA).OR.(PRSO.EQ.EVERY).OR.(PRSO.EQ.POSSE)
136           &         .OR.(PRSO.EQ.BUNOBJ)) GO TO 2900 ! collective object?
137           IF(.NOT.VAPPLI(PRSA)) GO TO 2400        ! verb handle?
138 2350      CALL RAPPLI(RACTIO(HERE))               ! room action?
139 2400      IF(PRSCON-1) 2700,2550,2500             ! parser reset?
140 2500      CALL XENDMV(TELFLG)                     ! more to do, end of move.
141           GO TO 2300                                        ! do next command.
142 C
143 2550      PRSCON=SVPRSC                                     ! substring exhausted.
144           GO TO 2700                                        ! restore state.
145 C
146 2600      IF(OFLAG.NE.0) CALL RSPEAK(604)                   ! parse fails, orphans?
147           OFLAG=0                                           ! invalidate orphans.
148 2700      WINNER=PLAYER                                     ! restore state.
149           HERE=AROOM(WINNER)
150           GO TO 400                               ! rejoin main loop.
151 C
152 2900      CALL VALUAC(PRSO)                       ! collective object.
153           GO TO 2350
154 C
155           END
156 C page
157 C XENDMV- Execute end of move functions.
158 C
159 C Declarations
160 C
161           SUBROUTINE XENDMV(FLAG)
162           IMPLICIT INTEGER (A-Z)
163           %include dparam
164           LOGICAL F,CLOCKD,FLAG,XVEHIC
165 C
166           IF(.NOT.FLAG) CALL RSPEAK(341)                    ! default remark.
167           IF(THFACT) CALL THIEFD                            ! thief demon.
168           IF(PRSWON.AND..NOT.DEADF) CALL FIGHTD   ! fight demon.
169           IF(SWDACT) CALL SWORDD                            ! sword demon.
170           IF(PRSWON) F=CLOCKD(X)                            ! clock demon.
171           IF(PRSWON) F=XVEHIC(2)                            ! vehicle readout.
172           RETURN
173           END
174 C page
175 C XVEHIC- Execute vehicle function
176 C
177 C Declarations
178 C
179           LOGICAL FUNCTION XVEHIC(N)
180           IMPLICIT INTEGER (A-Z)
181           %include dparam
182           LOGICAL OAPPLI
183 C
184           XVEHIC=.FALSE.                                    ! assume loses.
185           AV=AVEHIC(WINNER)                       ! get vehicle.
186           IF(AV.NE.0) XVEHIC=OAPPLI(OACTIO(AV),N)
187           RETURN
188           END
189 C page
190 C INITFL-- DUNGEON file initialization subroutine
191 C
192 C Declarations
193 C
194           LOGICAL FUNCTION INITFL(X)
195           IMPLICIT INTEGER (A-Z)
196           %include dparam
197           LOGICAL PROTCT
198           CHARACTER*1 KEDIT
199           external dtext_$dindx_path (descriptors)
200           CHARACTER*(168) DINDXP
201 
202 C page
203 C INITFL, PAGE 2
204 C
205 C First check for protection violation.
206 C
207           INITFL=.FALSE.                                    ! assume init fails.
208           IF(PROTCT(X)) GO TO 10000               ! protection violation?
209           WRITE(OUTCH,10100)                      ! yes, throw him off.
210 10100     FORMAT(
211           & ' There appears before you a threatening figure clad all'/
212           & ' over in heavy black armor.  His legs seem like the massive'/
213           & ' trunk of the oak tree.  His broad shoulders and helmeted'/
214           & ' head loom high over your own puny frame, and you realize'/
215           & ' that his powerful arms could easily crush the very life'/
216           & ' from your body.  There hangs from his belt a veritable'/
217           & ' arsenal of deadly weapons: sword, mace, ball and chain'/
218           & ' dagger, lance, and trident.  He speaks with a commanding'/
219           & ' voice:'//20X,'"You shall not pass."'//
220           & ' As he grabs you by the neck all grows dim about you.')
221           RETURN
222 C
223 C Now restore from existing index file.
224 C
225 C old 10000         OPEN (UNIT=1,NAME='dindx',STATUS='OLD',
226 C old     &         FORM='FORMATTED',ACCESS='SEQUENTIAL',ERR=1900)
227 10000     call dtext_$dindx_path (DINDXP)
228           OPEN (UNIT=1,FILE=DINDXP,STATUS='OLD',BLANK='NULL',
229           &         FORM='FORMATTED',ACCESS='SEQUENTIAL',ERR=1900)
230           READ(1,130) I,J                                   ! get version.
231           READ(1,125) KEDIT                       ! get minor edit.
232           IF((I.NE.VMAJ).OR.(J.NE.VMIN))
233           &         GO TO 1925                              ! match to ours?
234 C
235 C old     OPEN (UNIT=DBCH,NAME='dtext',STATUS='OLD',
236 C old     &         FORM='UNFORMATTED',ACCESS='DIRECT',
237 C old     &         RECL=RECLNT,ERR=1950)
238           call dtext_$open
239 C
240           READ(1,130) MXSCOR,STRBIT,EGMXSC
241           READ(1,130) RLNT,RDESC2,RDESC1,REXIT,RACTIO,RVAL,RFLAG
242           READ(1,130) XLNT,TRAVEL
243           READ(1,130) OLNT,ODESC1,ODESC2,ODESCO,OACTIO,OFLAG1,OFLAG2,
244           &         OFVAL,OTVAL,OSIZE,OCAPAC,OROOM,OADV,OCAN,OREAD
245           READ(1,130) R2LNT,O2,R2
246           READ(1,130) CLNT,CTICK,CACTIO
247           READ(1,135) CFLAG,CCNCEL
248           READ(1,130) VLNT,VILLNS,VPROB,VOPPS,VBEST,VMELEE
249           READ(1,130) ALNT,AROOM,ASCORE,AVEHIC,AOBJ,AACTIO,ASTREN,AFLAG
250           READ(1,130) MBASE,MLNT,RTEXT
251 C
252           CLOSE (UNIT=1)
253           GO TO 1025                                        ! init done.
254 C
255 125       FORMAT(A)
256 130       FORMAT(I8)
257 135       FORMAT(L4)
258 C page
259 C INITFL, PAGE 3
260 C
261 C The internal data base is now established.
262 C Set up to play the game-- INITFL succeeds.
263 C
264 C
265 C cac 2018-may-1. This code is just wrong. SHOUR and SMIN are
266 c "start hour" and "start minute" and are used in calculating play
267 c time.
268 C old 1025          CALL IDATE(SHOUR,SMIN,SSEC)             ! get date (and toss).
269 C old     I=(SHOUR*64)+(SMIN*8)+SSEC              ! first seed
270 C old     CALL ITIME(TMARRAY)                     ! get time.
271 C old     J=(TMARRAY(1)*64)+(TMARRAY(2)*8)+TMARRAY(3)       ! second seed
272 
273 C New code
274 1025      CONTINUe
275           CALL IDATE (CAC_Y, CAC_M, CAC_D)
276           I=(CAC_Y*64)+(CAC_M*8)+CAC_D            ! first seed
277           CALL ITIME(TMARRAY)                     ! get time.
278           J=(TMARRAY(1)*64)+(TMARRAY(2)*8)+TMARRAY(3)       ! second seed
279           SHOUR = TMARRAY(1)
280           SMIN = TMARRAY(2)
281 C End of new code
282           CALL INIRND(I,J)                        ! init random number gen.
283 C
284           WINNER=PLAYER
285           THFPOS=OROOM(THIEF)
286           BLOC=OROOM(BALLO)
287           HERE=AROOM(WINNER)
288           LASTIT=AOBJ(PLAYER)
289 C
290           INITFL=.TRUE.
291           RETURN
292 C
293 C Errors-- INITFL fails.
294 C
295 1900      WRITE(OUTCH,910)                        ! dindx.dat open err
296           WRITE(OUTCH,980)
297           RETURN
298 1925      WRITE(OUTCH,920) I,J,KEDIT,VMAJ,VMIN,VEDIT        ! wrong dindx.dat ver
299           WRITE(OUTCH,980)
300           RETURN
301 1950      WRITE(OUTCH,960)                        ! dtext.dat open err
302           WRITE(OUTCH,980)
303           RETURN
304 910       FORMAT(' I can''t open "DINDX.DAT".')
305 920       FORMAT(' "DINDX.DAT" is version ',I1,'.',I1,A,'.'/
306           &         ' I require version ',I1,'.',I1,A,'.')
307 960       FORMAT(' I can''t open "DTEXT.DAT".')
308 980       FORMAT(
309           & ' Suddenly a sinister, wraithlike figure appears before you'/
310           & ' seeming to float in the air.  In a low, sorrowful voice he'/
311           & ' says, "Alas, the very nature of the world has changed, and'/
312           & ' the dungeon cannot be found.  All must now pass away."'/
313           & ' Raising his oaken staff in farewell, he fades into the'/
314           & ' spreading darkness.  In his place appears a tastefully'/
315           & ' lettered sign reading:'//20X,'INITIALIZATION FAILURE'//
316           & ' The darkness becomes all encompassing, and your vision fails.')
317 C
318           END
319 C page
320 C PROTCT-- Check for user violation
321 C
322 C This routine should be modified if you wish to add system
323 c dependant protection against abuse.
324 C
325 C At the moment, play is permitted under all circumstances.
326 C
327           LOGICAL FUNCTION PROTCT(X)
328           IMPLICIT INTEGER (A-Z)
329 C
330           PROTCT=.TRUE.
331           RETURN
332           END