API tools faq
paste
Advertisement
Silent-Hunter

adventure.f

Silent-Hunter
Apr 15th, 2015
67
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Fortran 116.44 KB | None | 0 0
raw download clone embed print report
  1. C
  2. C        PROGRAM MODIFIED 7/82 BY BILL SMITH OF GOULD, SEL
  3. C        TO ALLOW COMPILATION AND RUNNING IN MPX 1.X OR MPX 2.0.
  4. C
  5. C        CONSIDERATIONS FOR USING 'SUSPEND' AND 'RESTORE':
  6. C
  7. C        SUSPENDED FILES WILL BE PLACED INTO THE USERS CURRENT
  8. C        DIRECTORY.
  9. C
  10. C
  11. C  CURRENT LIMITS:
  12. C      9800 WORDS OF MESSAGE TEXT (LINES, LINSIZ).
  13. C       750 TRAVEL OPTIONS (TRAVEL, TRVSIZ).
  14. C       300 VOCABULARY WORDS (KTAB, ATAB, TABSIZ).
  15. C       150 LOCATIONS (LTEXT, STEXT, KEY, COND, ABB, ATLOC, LOCSIZ).
  16. C       100 OBJECTS (PLAC, PLACE, FIXD, FIXED, LINK (TWICE), PTEXT, PROP
  17. C        35 "ACTION" VERBS (ACTSPK, VRBSIZ).
  18. C       205 RANDOM MESSAGES (RTEXT, RTXSIZ).
  19. C        12 DIFFERENT PLAYER CLASSIFICATIONS (CTEXT, CVAL, CLSMAX).
  20. C        20 HINTS, LESS 3 (HINTLC, HINTED, HINTS, HNTSIZ).
  21. C        35 MAGIC MESSAGES (MTEXT, MAGSIZ).
  22. C  THERE ARE ALSO LIMITS WHICH CANNOT BE EXCEEDED DUE TO THE STRUCTURE O
  23. C  THE DATABASE.  (E.G., THE VOCABULARY USES N/1000 TO DETERMINE WORD TY
  24. C  SO THERE CAN'T BE MORE THAN 1000 WORDS.)  THESE UPPER LIMITS ARE:
  25. C      1000 NON-SYNONYMOUS VOCABULARY WORDS
  26. C       300 LOCATIONS
  27. C       100 OBJECTS
  28. C
  29.       IMPLICIT INTEGER*4(A-Z)
  30.       LOGICAL DSEEN,BLKLIN,HINTED,YESX,START
  31. C
  32. C!!!  COMMON /TXTCOM/ RTEXT,LINES
  33.       COMMON /TXTCOM/ RTEXT
  34.       COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
  35.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,COND,PROP,LOC,LAMP,HOLDNG
  36.       COMMON /MTXCOM/ MTEXT
  37.       COMMON /PTXCOM/ PTEXT
  38.       COMMON /ABBCOM/ ABB
  39.       COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
  40.      1SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
  41.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  42.       COMMON /MTDCOM/ MTDTXT
  43.       COMMON /RANCOM/ R
  44.       COMMON /MSCCOM/ TRAVEL,LTEXT,STEXT,KEY,ACTSPK,
  45.      1CTEXT,CVAL,HINTLC,HINTED,HINTS,DSEEN,DLOC,CLSSES,HNTMAX,
  46.      2PLAC,FIXD,MAXTRS,TALLY,TALLY2,
  47.      3KEYS,GRATE,CAGE,ROD,ROD2,STEPS,BIRD,DOOR,PILLOW,SNAKE,
  48.      4FISSUR,TABLET,CLAM,OYSTER,MAGZIN,DWARF,KNIFE,FOOD,BOTTLE,
  49.      5WATER,OIL,PLANT,PLANT2,AXE,MIRROR,DRAGON,CHASM,TROLL,TROLL2,
  50.      6BEAR,MESSAG,VEND,BATTER,NUGGET,COINS,CHEST,EGGS,TRIDNT,VASE,
  51.      7EMRALD,PYRAM,PEARL,RUG,CHAIN,BACK,LOOK,CAVE,NULL,ENTRNC,
  52.      8DPRSSN,SAY,LOCK,THROW,FIND,INVENT,CHLOC,CHLOC2,DFLAG,DALTLC,
  53.      9SUSPND,TURNS,LMWARN,IWEST,KNFLOC,DETAIL,ABBNUM,SCORNG,NUMDIE,
  54.      1DKILL,FOOBAR,BONUS,CLOCK1,CLOCK2,CLOSNG,PANIC,
  55.      2DEMO,HINT,LIMIT,NEWLOC,OBJ,ODLOC,OLDLC2,OLDLOC,SCORE,
  56.      3SPICES,STICK,VERB,WD1,WD1X,WD2,WD2X,WZDARK,
  57.      4ATTACK,DTOTAL,FOO,HINTM3,I,J,K,K1,K2,KK,KQ,L,LL,MXSCOR,SPK,TK,
  58.      5YEA,CLOSED,GAVEUP,MAXDIE,XXD,XXT,YYD,YYT
  59. C
  60. C!!!  DIMENSION LINES(9800)
  61.       DIMENSION TRAVEL(750)
  62.       DIMENSION KTAB(300),ATAB(300)
  63.       DIMENSION LTEXT(150),STEXT(150),KEY(150),COND(150),ABB(150),
  64.      1ATLOC(150)
  65.       DIMENSION PLAC(100),PLACE(100),FIXD(100),FIXED(100),LINK(200),
  66.      1PTEXT(100),PROP(100)
  67.       DIMENSION ACTSPK(35)
  68.       DIMENSION RTEXT(205)
  69.       DIMENSION CTEXT(12),CVAL(12)
  70.       DIMENSION HINTLC(20),HINTED(20),HINTS(20,4)
  71.       DIMENSION MTEXT(35)
  72.       DIMENSION TK(20),DSEEN(6),DLOC(6),ODLOC(6),HNAME(20)
  73.       DIMENSION MTDTXT(100)
  74.       DIMENSION CMADRS(4,11),CMSZES(11),TEXT(70),FNAME(10),FDUMY(10)
  75. C
  76.       LOGICAL TOTING,HERE,AT,BITSET,DARK,WZDARK,LMWARN,CLOSNG,PANIC,
  77.      1CLOSED,GAVEUP,SCORNG,DEMO,YEA,FORCED,PCT
  78. C
  79.       DATA LINSIZ/9800/,TRVSIZ/750/,LOCSIZ/150/,
  80.      1VRBSIZ/35/,RTXSIZ/205/,CLSMAX/12/,HNTSIZ/20/,MAGSIZ/35/
  81.       DATA BLANK/' '/
  82. C
  83. C  STATEMENT FUNCTIONS
  84. C
  85. C
  86. C  TOTING(OBJ)  = TRUE IF THE OBJ IS BEING CARRIED
  87. C  HERE(OBJ)    = TRUE IF THE OBJ IS AT "LOC" (OR IS BEING CARRIED)
  88. C  AT(OBJ)      = TRUE IF ON EITHER SIDE OF TWO-PLACED OBJECT
  89. C  LIQ(DUMY)   = OBJECT NUMBER OF LIQUID IN BOTTLE
  90. C  LIQLOC(LOC)  = OBJECT NUMBER OF LIQUID (IF ANY) AT LOC
  91. C  BITSET(L,N)  = TRUE IF COND(L) HAS BIT N SET (BIT 0 IS UNITS BIT)
  92. C  FORCED(LOC)  = TRUE IF LOC MOVES WITHOUT ASKING FOR INPUT (COND=2)
  93. C  DARK(DUMY)  = TRUE IF LOCATION "LOC" IS DARK
  94. C  PCT(N)       = TRUE N% OF THE TIME (N INTEGER*4 FROM 0 TO 100)
  95. C
  96. C  WZDARK SAYS WHETHER THE LOC HE'S LEAVING WAS DARK
  97. C  LMWARN SAYS WHETHER HE'S BEEN WARNED ABOUT LAMP GOING DIM
  98. C  CLOSNG SAYS WHETHER ITS CLOSING TIME YET
  99. C  PANIC SAYS WHETHER HE'S FOUND OUT HE'S TRAPPED IN THE CAVE
  100. C  CLOSED SAYS WHETHER WE'RE ALL THE WAY CLOSED
  101. C  GAVEUP SAYS WHETHER HE EXITED VIA "QUIT"
  102. C  SCORNG INDICATES TO THE SCORE ROUTINE WHETHER WE'RE DOING A "SCORE" C
  103. C  DEMO IS TRUE IF THIS IS A PRIME-TIME DEMONSTRATION GAME
  104. C  YEA IS RANDOM YES/NO REPLY
  105. c     SIZE(UNIQ1,UNIQ2)=(ADDR(UNIQ2)-ADDR(UNIQ1))/4+1
  106.       SIZE(UNIQ1,UNIQ2)=(UNIQ2-UNIQ1)/4+1
  107.       TOTING(OBJ)=PLACE(OBJ).EQ.-1
  108.       HERE(OBJ)=PLACE(OBJ).EQ.LOC.OR.TOTING(OBJ)
  109.       AT(OBJ)=PLACE(OBJ).EQ.LOC.OR.FIXED(OBJ).EQ.LOC
  110.       LIQ2(PBOTL)=(1-PBOTL)*WATER+(PBOTL/2)*(WATER+OIL)
  111.       LIQ(DUMY)=LIQ2(MAX0(PROP(BOTTLE),-1-PROP(BOTTLE)))
  112.       LIQLOC(LOC)=LIQ2((MOD(COND(LOC)/2*2,8)-5)*MOD(COND(LOC)/4,2)
  113.      1+1)
  114.       BITSET(L,N)=AND(COND(L),ISHFT(1,N)).NE.0
  115.       FORCED(LOC)=COND(LOC).EQ.2
  116.       DARK(DUMY)=MOD(COND(LOC),2).EQ.0.AND.(PROP(LAMP).EQ.0.OR.
  117.      1.NOT.HERE(LAMP))
  118.       PCT(N)=RAN(100).LT.N
  119. C
  120. C  SETUP ADDRESSES AND LENGTHS OF COMMON BLOCKS IN CMADRS AND CMSZES
  121. C  RESPECTIVELY.
  122. C
  123. C  CMADRS ALLOWS  FOUR CONTIGUOUS INTEGER*4 VARIABLES FOR EACH "POINTER"
  124. C  ADDR AND SIZE ARE SITE-SUPPLIED FUNCTIONS.
  125. C
  126. C  FURTHER INFORMATION WILL BE FOUND IN THE CONVERSION GUIDE ACCOMPANYIN
  127. C  THIS PROGRAM.  FOR STILL FURTHER INFORMATION, CONTACT:
  128. C       GARY M. PALTER, MIT    (617) 253-7728
  129. C                (PALTER@MIT-MULTICS)
  130. C
  131. c     CMADRS(1,1) = ADDR(RTEXT(1))
  132. C!!!  CMSZES(1) = SIZE(RTEXT(1),LINES(9800)))/4 + 1
  133. c     CMSZES(1) = SIZE(RTEXT(1),RTEXT(205)))/4 + 1
  134.       CMADRS(1,1) = iaddr(RTEXT(1))
  135.       cmadrs(2,1) = iaddr(RTEXT(205))
  136. C
  137. c     CMADRS(1,2) = ADDR(KTAB(1))
  138. c     CMSZES(2) = SIZE(KTAB(1),TABSIZ))/4 + 1
  139.       CMADRS(1,2) = iaddr(KTAB(1))
  140.       cmadrs(2,2) = iaddr(TABSIZ)
  141. C
  142. c     CMADRS(1,3) = ADDR(ATLOC(1))
  143. c     CMSZES(3) = SIZE(AT(iaddr(1),HOLDNG))/4 + 1
  144.       CMADRS(1,3) = iaddr(ATLOC(1))
  145.       cmadrs(2,3) = iaddr(HOLDNG)
  146. C
  147. c     CMADRS(1,4) = ADDR(MTEXT(1))
  148. c     CMSZES(4) = SIZE(MTEXT(1),MTEXT(34)))/4 + 1
  149.       CMADRS(1,4) = iaddr(MTEXT(1))
  150.       cmadrs(2,4) = iaddr(MTEXT(34))
  151. C
  152. c     CMADRS(1,5) = ADDR(PTEXT(1))
  153. c     CMSZES(5) = SIZE(PTEXT(1),PTEXT(100)))/4 + 1
  154.       CMADRS(1,5) = iaddr(PTEXT(1))
  155.       cmadrs(2,5) = iaddr(PTEXT(100))
  156. C
  157. c     CMADRS(1,6) = ADDR(ABB(1))
  158. c     CMSZES(6) = SIZE(ABB(1),ABB(150)))/4 + 1
  159.       CMADRS(1,6) = iaddr(ABB(1))
  160.       cmadrs(2,6) = iaddr(ABB(150))
  161. C
  162. c     CMADRS(1,7) = ADDR(WKDAY)
  163. c     CMSZES(7) = SIZE(WKDAY,SETUP))/4 + 1
  164.       CMADRS(1,7) = iaddr(WKDAY)
  165.       cmadrs(2,7) = iaddr(SETUP)
  166. C
  167. c     CMADRS(1,8) = ADDR(TTYI)
  168. c     CMSZES(8) = SIZE(TTYI,DBFI))/4 + 1
  169.       CMADRS(1,8) = iaddr(TTYI)
  170.       cmadrs(2,8) = iaddr(DBFI)
  171. C
  172. c     CMADRS(1,9) = ADDR(MTDTXT(1))
  173. c     CMSZES(9) = SIZE(MTDTXT(1),MTDTXT(90)))/4 + 1
  174.       CMADRS(1,9) = iaddr(MTDTXT(1))
  175.       cmadrs(2,9) = iaddr(MTDTXT(90))
  176. C
  177. c     CMADRS(1,10) = ADDR(R)
  178. c     CMSZES(10) = SIZE(R,R))/4 + 1
  179.       CMADRS(1,10) = iaddr(R)
  180.       cmadrs(2,10) = iaddr(R)
  181. C
  182. c     CMADRS(1,11) = ADDR(TRAVEL(1))
  183. c     CMSZES(11) = SIZE(TRAVEL(1),MAXDIE))/4 + 1
  184.       CMADRS(1,11) = iaddr(TRAVEL(1))
  185.       cmadrs(2,11) = iaddr(MAXDIE)
  186. c
  187. c     write (0,9997)
  188. c9997 format (' In MAIN:')
  189.       do 9999 i=1,11
  190.       cmszes(i) = size(cmadrs(1,i),cmadrs(2,i))
  191. c     write (0,9998) i, cmszes(i), cmadrs(1,i), cmadrs(2,i)
  192. c9998 format (' i = ',i3,', cmszes = ',i10,', cmadrs = ',2z9.8)
  193. 9999  continue
  194. C
  195. C
  196. C  LOAD 'SYSTEM' COMMON BLOCKS.  THESE COMMON BLOCKS DEFINE THE STATE
  197. C  OF A GAME WHICH HAS YET TO BE STARTED...
  198. C
  199.       CALL IOINIT(0)
  200.       CALL LDCOMN(.TRUE.,FDUMY,CMADRS,CMSZES)
  201. C
  202. C  DESCRIPTION OF THE DATABASE FORMAT
  203. C
  204. C
  205. C  THE DATA FILE CONTAINS SEVERAL SECTIONS.  EACH BEGINS WITH A LINE CON
  206. C  A NUMBER IDENTIFYING THE SECTION, AND ENDS WITH A LINE CONTAINING "-1
  207. C
  208. C  SECTION 1: LONG FORM DESCRIPTIONS.  EACH LINE CONTAINS A LOCATION NUM
  209. C       A TAB, AND A LINE OF TEXT.  THE SET OF (NECESSARILY ADJACENT) LI
  210. C       WHOSE NUMBERS ARE X FORM THE LONG DESCRIPTION OF LOCATION X.
  211. C  SECTION 2: SHORT FORM DESCRIPTIONS.  SAME FORMAT AS LONG FORM.  NOT A
  212. C       PLACES HAVE SHORT DESCRIPTIONS.
  213. C  SECTION 3: TRAVEL TABLE.  EACH LINE CONTAINS A LOCATION NUMBER (X), A
  214. C       LOCATION NUMBER (Y), AND A LIST OF MOTION NUMBERS (SEE SECTION 4
  215. C       EACH MOTION REPRESENTS A VERB WHICH WILL GO TO Y IF CURRENTLY AT
  216. C       Y, IN TURN, IS INTERPRETED AS FOLLOWS.  LET M=Y/1000, N=Y MOD
  217. C               IF N<=300       IT IS THE LOCATION TO GO TO.
  218. C               IF 300<N<=500   N-300 IS USED IN A COMPUTED GO TO TO
  219. C                                       A SECTION OF SPECIAL CODE.
  220. C               IF N>500        MESSAGE N-500 FROM SECTION 6 IS PRINTED,
  221. C                                       AND HE STAYS WHEREVER HE IS.
  222. C       MEANWHILE, M SPECIFIES THE CONDITIONS ON THE MOTION.
  223. C               IF M=0          IT'S UNCONDITIONAL.
  224. C               IF 0<M<100      IT IS DONE WITH M% PROBABILITY.
  225. C               IF M=100        UNCONDITIONAL, BUT FORBIDDEN TO DWARVES.
  226. C               IF 100<M<=200   HE MUST BE CARRYING OBJECT M-100.
  227. C               IF 200<M<=300   MUST BE CARRYING OR IN SAME ROOM AS M-20
  228. C               IF 300<M<=400   PROP(M MOD 100) MUST *NOT* BE 0.
  229. C               IF 400<M<=500   PROP(M MOD 100) MUST *NOT* BE 1.
  230. C               IF 500<M<=600   PROP(M MOD 100) MUST *NOT* BE 2, ETC.
  231. C       IF THE CONDITION (IF ANY) IS NOT MET, THEN THE NEXT *DIFFERENT*
  232. C       "DESTINATION" VALUE IS USED (UNLESS IT FAILS TO MEET *ITS* CONDI
  233. C       IN WHICH CASE THE NEXT IS FOUND, ETC.).  TYPICALLY, THE NEXT DES
  234. C       BE FOR ONE OF THE SAME VERBS, SO THAT ITS ONLY USE IS AS THE ALT
  235. C       DESTINATION FOR THOSE VERBS.  FOR INSTANCE:
  236. C               15      110022  29      31      34      35      23
  237. C               15      14      29
  238. C       THIS SAYS THAT, FROM LOC 15, ANY OF THE VERBS 29, 31, ETC., WILL
  239. C       HIM TO 22 IF HE'S CARRYING OBJECT 10, AND OTHERWISE WILL GO TO 1
  240. C               11      303008  49
  241. C               11      9       50
  242. C       THIS SAYS THAT, FROM 11, 49 TAKES HIM TO 8 UNLESS PROP(3)=0, IN
  243. C       CASE HE GOES TO 9.  VERB 50 TAKES HIM TO 9 REGARDLESS OF PROP(3)
  244. C  SECTION 4: VOCABULARY.  EACH LINE CONTAINS A NUMBER (N), A TAB, AND A
  245. C       FIVE-LETTER WORD.  CALL M=N/1000.  IF M=0, THEN THE WORD IS A MO
  246. C       VERB FOR USE IN TRAVELLING (SEE SECTION 3).  ELSE, IF M=1, THE W
  247. C       AN OBJECT.  ELSE, IF M=2, THE WORD IS AN ACTION VERB (SUCH AS "C
  248. C       OR "ATTACK").  ELSE, IF M=3, THE WORD IS A SPECIAL CASE VERB (SU
  249. C       "DIG") AND N MOD 1000 IS AN INDEX INTO SECTION 6.  OBJECTS FRO
  250. C       (CURRENTLY, ANYWAY) 79 ARE CONSIDERED TREASURES (FOR PIRATE, CLO
  251. C  SECTION 5: OBJECT DESCRIPTIONS.  EACH LINE CONTAINS A NUMBER (N), A T
  252. C       AND A MESSAGE.  IF N IS FROM 1 TO 100, THE MESSAGE IS THE "INVEN
  253. C       MESSAGE FOR OBJECT N.  OTHERWISE, N SHOULD BE 000, 100, 200, ETC
  254. C       THE MESSAGE SHOULD BE THE DESCRIPTION OF THE PRECEDING OBJECT WH
  255. C       PROP VALUE IS N/100.  THE N/100 IS USED ONLY TO DISTINGUISH MULT
  256. C       MESSAGES FROM MULTI-LINE MESSAGES; THE PROP INFO ACTUALLY REQUIR
  257. C       MESSAGES FOR AN OBJECT TO BE PRESENT AND CONSECUTIVE.  PROPERTIE
  258. C       PRODUCE NO MESSAGE SHOULD BE GIVEN THE MESSAGE ">$<".
  259. C  SECTION 6: ARBITRARY MESSAGES.  SAME FORMAT AS SECTIONS 1, 2, AND 5,
  260. C       THE NUMBERS BEAR NO RELATION TO ANYTHING (EXCEPT FOR SPECIAL VER
  261. C       IN SECTION 4).
  262. C  SECTION 7: OBJECT LOCATIONS.  EACH LINE CONTAINS AN OBJECT NUMBER AND
  263. C       INITIAL LOCATION (ZERO (OR OMITTED) IF NONE).  IF THE OBJECT IS
  264. C       IMMOVABLE, THE LOCATION IS FOLLOWED BY A "-1".  IF IT HAS TWO LO
  265. C       (E.G. THE GRATE) THE FIRST LOCATION IS FOLLOWED WITH THE SECOND,
  266. C       THE OBJECT IS ASSUMED TO BE IMMOVABLE.
  267. C  SECTION 8: ACTION DEFAULTS.  EACH LINE CONTAINS AN "ACTION-VERB" NUMB
  268. C       THE INDEX (IN SECTION 6) OF THE DEFAULT MESSAGE FOR THE VERB.
  269. C  SECTION 9: LIQUID ASSETS, ETC.  EACH LINE CONTAINS A NUMBER (N) AND U
  270. C       LOCATION NUMBERS.  BIT N (WHERE 0 IS THE UNITS BIT) IS SET IN CO
  271. C       FOR EACH LOC GIVEN.  THE COND BITS CURRENTLY ASSIGNED ARE:
  272. C               0       LIGHT
  273. C               1       IF BIT 2 IS ON: ON FOR OIL, OFF FOR WATER
  274. C               2       LIQUID ASSET, SEE BIT 1
  275. C               3       PIRATE DOESN'T GO HERE UNLESS FOLLOWING PLAYER
  276. C       OTHER BITS ARE USED TO INDICATE AREAS OF INTEREST TO "HINT" ROUT
  277. C               4       TRYING TO GET INTO CAVE
  278. C               5       TRYING TO CATCH BIRD
  279. C               6       TRYING TO DEAL WITH SNAKE
  280. C               7       LOST IN MAZE
  281. C               8       PONDERING DARK ROOM
  282. C               9       AT WITT'S END
  283. C       COND(LOC) IS SET TO 2, OVERRIDING ALL OTHER BITS, IF LOC HAS FOR
  284. C       MOTION.
  285. C  SECTION 10: CLASS MESSAGES.  EACH LINE CONTAINS A NUMBER (N), A TAB,
  286. C       MESSAGE DESCRIBING A CLASSIFICATION OF PLAYER.  THE SCORING SECT
  287. C       SELECTS THE APPROPRIATE MESSAGE, WHERE EACH MESSAGE IS CONSIDERE
  288. C       APPLY TO PLAYERS WHOSE SCORES ARE HIGHER THAN THE PREVIOUS N BUT
  289. C       HIGHER THAN THIS N.  NOTE THAT THESE SCORES PROBABLY CHANGE WITH
  290. C       MODIFICATION (AND PARTICULARLY EXPANSION) OF THE PROGRAM.
  291. C  SECTION 11: HINTS.  EACH LINE CONTAINS A HINT NUMBER (CORRESPONDING T
  292. C       COND BIT, SEE SECTION 9), THE NUMBER OF TURNS HE MUST BE AT THE
  293. C       LOC(S) BEFORE TRIGGERING THE HINT, THE POINTS DEDUCTED FOR TAKIN
  294. C       HINT, THE MESSAGE NUMBER (SECTION 6) OF THE QUESTION, AND THE ME
  295. C       NUMBER OF THE HINT.  THESE VALUES ARE STASHED IN THE "HINTS" ARR
  296. C       HNTMAX IS SET TO THE MAX0 HINT NUMBER (<= HNTSIZ).  NUMBERS 1-3
  297. C       UNUSABLE SINCE COND BITS ARE OTHERWISE ASSIGNED, SO 2 IS USED TO
  298. C       REMEMBER IF HE'S READ THE CLUE IN THE REPOSITORY, AND 3 IS USED
  299. C       REMEMBER WHETHER HE ASKED FOR INSTRUCTIONS (GETS MORE TURNS, BUT
  300. C       POINTS).
  301. C  SECTION 12: MAGIC MESSAGES. IDENTICAL TO SECTION 6 EXCEPT PUT IN A SE
  302. C       SECTION FOR EASIER REFERENCE.  MAGIC MESSAGES ARE USED BY THE ST
  303. C       MAINTENANCE MODE, AND RELATED ROUTINES.
  304. C  SECTION 0: END OF DATABASE.
  305. C
  306. C  READ THE DATABASE IF WE HAVE NOT YET DONE SO
  307. C
  308.  8500 IF(SETUP.NE.0)GO TO 1100
  309.       CALL IOINIT(1)
  310.       WRITE(TTYO,1000)
  311.  1000 FORMAT(' INITIALIZING...')
  312. C
  313. C  CLEAR OUT THE VARIOUS TEXT-POINTER ARRAYS.  ALL TEXT IS STORED IN ARR
  314. C  LINES; EACH LINE IS PRECEDED BY A WORD POINTING TO THE NEXT POINTER (
  315. C  THE WORD FOLLOWING THE END OF THE LINE).  THE POINTER IS NEGATIVE IF
  316. C  FIRST LINE OF A MESSAGE.  THE TEXT-POINTER ARRAYS CONTAIN INDICES OF
  317. C  POINTER-WORDS IN LINES.  STEXT(N) IS SHORT DESCRIPTION OF LOCATION N.
  318. C  LTEXT(N) IS LONG DESCRIPTION.  PTEXT(N) POINTS TO MESSAGE FOR PROP(N)
  319. C  SUCCESSIVE PROP MESSAGES ARE FOUND BY CHASING POINTERS.  RTEXT CONTAI
  320. C  SECTION 6'S STUFF.  CTEXT(N) POINTS TO A PLAYER-CLASS MESSAGE.  MTEXT
  321. C  SECTION 12.  WE ALSO CLEAR COND.  SEE DESCRIPTION OF SECTION 9 FOR DE
  322. C
  323. C
  324.       TABSIZ=300
  325.       BLKLIN=.TRUE.
  326.       R=0
  327. C
  328.       DO 1001 I=1,300
  329.          IF(I.LE.100)PTEXT(I)=0
  330.          IF(I.LE.100)MTDTXT(I)=-1
  331.          IF(I.LE.RTXSIZ)RTEXT(I)=0
  332.          IF(I.LE.CLSMAX)CTEXT(I)=0
  333.          IF(I.LE.MAGSIZ)MTEXT(I)=0
  334.          IF(I.GT.LOCSIZ)GO TO 1001
  335.          STEXT(I)=0
  336.          LTEXT(I)=0
  337.          COND(I)=0
  338.  1001 CONTINUE
  339. C
  340.       SETUP=1
  341.       LINUSE=1
  342.       TRVS=1
  343.       CLSSES=1
  344. C
  345. C  START NEW DATA SECTION.  SECT IS THE SECTION NUMBER.
  346. C
  347.  1002 READ(DBFI,1003)SECT
  348.  1003 FORMAT(I8)
  349.       IF(SECT.EQ.-37)GO TO 1002
  350. c     WRITE (0,9990) SECT
  351. c9990 FORMAT (' READING SECTION',I4)
  352.       OLDLOC=-1
  353.       SECT1=SECT+1
  354.       IF ((SECT1.LT.1).OR.(SECT1.GT.13)) CALL BUG(9)
  355.       GO TO(1100,1004,1004,1030,1040,1004,1004,1050,1060,1070,1004,
  356.      11080,1004),SECT1
  357. C           (0)  (1)  (2)  (3)  (4)  (5)  (6)  (7)  (8)  (9)  (10)
  358. C     (11) (12)
  359.       CALL BUG(9)
  360. C
  361. C  SECTIONS 1, 2, 5, 6, 10, 12.  READ MESSAGES AND SET UP POINTERS.
  362. C
  363.  1004 READ(DBFI,1005)LOC,TEXT,KK
  364.  1005 FORMAT(1I8,70A1,A1)
  365.       IF(KK.NE.BLANK)CALL BUG(0)
  366.       IF(LOC.EQ.-1)GO TO 1002
  367.       DO 1006 K=1,70
  368.          KK=71-K
  369.          IF(TEXT(KK).NE.BLANK)GO TO 1007
  370.  1006 CONTINUE
  371.       CALL BUG(1)
  372.  1007 KK=(KK+4)/5
  373.       DO 10071 K=1,KK
  374.          K1=LINUSE+K
  375.          K2=5*(K-1)+1
  376.          CALL SETLINES(K1,CODE2(TEXT(K2)))
  377. 10071 CONTINUE
  378.       KK=LINUSE+KK
  379.       CALL SETLINES(LINUSE,KK+1)
  380.       IF(LOC.EQ.OLDLOC)GO TO 1020
  381.       CALL SETLINES(LINUSE,-LINES(LINUSE))
  382.       IF(SECT.EQ.12)GO TO 1013
  383.       IF(SECT.EQ.10)GO TO 1012
  384.       IF(SECT.EQ.6)GO TO 1011
  385.       IF(SECT.EQ.5)GO TO 1010
  386.       IF(SECT.EQ.1)GO TO 1008
  387. C
  388.       STEXT(LOC)=LINUSE
  389.       GO TO 1020
  390. C
  391.  1008 LTEXT(LOC)=LINUSE
  392.       GO TO 1020
  393. C
  394.  1010 IF(LOC.GT.0.AND.LOC.LE.100)PTEXT(LOC)=LINUSE
  395.       GO TO 1020
  396. C
  397.  1011 IF(LOC.GT.RTXSIZ)CALL BUG(6)
  398.       RTEXT(LOC)=LINUSE
  399.       GO TO 1020
  400. C
  401.  1012 CTEXT(CLSSES)=LINUSE
  402.       CVAL(CLSSES)=LOC
  403.       CLSSES=CLSSES+1
  404.       GO TO 1020
  405. C
  406.  1013 IF(LOC.GT.MAGSIZ)CALL BUG(6)
  407.       MTEXT(LOC)=LINUSE
  408. C
  409.  1020 LINUSE=KK+1
  410.       CALL SETLINES(LINUSE,-1)
  411.       OLDLOC=LOC
  412.       IF(LINUSE+14.GT.LINSIZ)CALL BUG(2)
  413.       GO TO 1004
  414. C
  415. C  THE STUFF FOR SECTION 3 IS ENCODED HERE.  EACH "FROM-LOCATION" GETS A
  416. C  CONTIGUOUS SECTION OF THE "TRAVEL" ARRAY.  EACH ENTRY IN TRAVEL IS
  417. C  NEWLOC*1000 + KEYWORD (FROM SECTION 4, MOTION VERBS), AND IS NEGATED
  418. C  THIS IS THE LAST ENTRY FOR THIS LOCATION.  KEY(N) IS THE INDEX IN TRA
  419. C  OF THE FIRST OPTION AT LOCATION N.
  420. C
  421. 1030  READ(DBFI,1031)LOC,NEWLOC,(TK(I),I=1,8)
  422.  1031 FORMAT(I8,9I8)
  423.       IF(LOC.EQ.-1)GO TO 1002
  424.       IF(KEY(LOC).NE.0)GO TO 1033
  425.       KEY(LOC)=TRVS
  426.       GO TO 1035
  427.  1033 TRAVEL(TRVS-1)=-TRAVEL(TRVS-1)
  428.  1035 DO 1037 L=1,8
  429.          IF(TK(L).EQ.0)GO TO 1039
  430.          TRAVEL(TRVS)=NEWLOC*1000+TK(L)
  431.          TRVS=TRVS+1
  432.          IF(TRVS.EQ.TRVSIZ)CALL BUG(3)
  433.  1037 CONTINUE
  434.  1039 TRAVEL(TRVS-1)=-TRAVEL(TRVS-1)
  435.       GO TO 1030
  436. C
  437. C  HERE WE READ IN THE VOCABULARY.  KTAB(N) IS THE WORD NUMBER, ATAB(N)
  438. C  THE CORRESPONDING WORD.  THE -1 AT THE END OF SECTION 4 IS LEFT IN KT
  439. C  AS AN END-MARKER.  THE WORDS ARE GIVEN A MINIMAL HASH TO MAKE READING
  440. C  CORE-IMAGE HARDER.  NOTE THAT '/7-08' HAD BETTER NOT BE IN THE LIST,
  441. C  IT COULD HASH TO -1.
  442. C
  443.  1040 DO 1042 TABNDX=1,TABSIZ
  444.  1043    READ(DBFI,1041)KTAB(TABNDX),(TEXT(I),I=1,5)
  445.  1041    FORMAT(I8,5A1)
  446.          IF(KTAB(TABNDX).EQ.-1)GO TO 1002
  447. C     SCRAMBLE THE CODE
  448.  1042 ATAB(TABNDX)=-(CODE2(TEXT(1)))
  449.       CALL BUG(4)
  450. C
  451. C  READ IN THE INITIAL LOCATIONS FOR EACH OBJECT.  ALSO THE IMMOVABILITY
  452. C  PLAC CONTAINS INITIAL LOCATIONS OF OBJECTS.  FIXD IS -1 FOR IMMOVABLE
  453. C  OBJECTS (INCLUDING THE SNAKE), OR = SECOND LOC FOR TWO-PLACED OBJECTS
  454. C
  455.  1050 READ(DBFI,1031)OBJ,J,K
  456.       IF(OBJ.EQ.-1)GO TO 1002
  457.       PLAC(OBJ)=J
  458.       FIXD(OBJ)=K
  459.       GO TO 1050
  460. C
  461. C  READ DEFAULT MESSAGE NUMBERS FOR ACTION VERBS, STORE IN ACTSPK.
  462. C
  463.  1060 READ(DBFI,1031)VERB,J
  464.       IF(VERB.EQ.-1)GO TO 1002
  465.       ACTSPK(VERB)=J
  466.       GO TO 1060
  467. C
  468. C  READ INFO ABOUT AVAILABLE LIQUIDS AND OTHER CONDITIONS, STORE IN COND
  469. C
  470.  1070 READ(DBFI,1031)K,(TK(I),I=1,9)
  471.       IF(K.EQ.-1)GO TO 1002
  472.       DO 1071 I=1,9
  473.          LOC=TK(I)
  474.          IF(LOC.EQ.0)GO TO 1070
  475.          IF(BITSET(LOC,K))CALL BUG(8)
  476.  1071 COND(LOC)=COND(LOC)+ISHFT(1,K)
  477.       GO TO 1070
  478. C
  479. C  READ DATA FOR HINTS.
  480. C
  481.  1080 HNTMAX=0
  482.  1081 READ(DBFI,1031)K,(TK(I),I=1,4)
  483.       IF(K.EQ.-1)GO TO 1002
  484.       IF(K.EQ.0)GO TO 1081
  485.       IF(K.LT.0.OR.K.GT.HNTSIZ)CALL BUG(7)
  486.       DO 1083 I=1,4
  487.  1083 HINTS(K,I)=TK(I)
  488.       HNTMAX=MAX0(HNTMAX,K)
  489.       GO TO 1081
  490. C
  491. C  FINISH CONSTRUCTING INTERNAL DATA FORMAT
  492. C
  493. C  IF SETUP=2 WE DON'T NEED TO DO THIS.  IT'S ONLY NECESSARY IF WE HAVEN
  494. C  IT AT ALL OR IF THE PROGRAM HAS BEEN RUN SINCE THEN.
  495. C
  496. 1100  CLOSE (UNIT=DBFI)
  497.       IF(SETUP.EQ.2)GO TO 1
  498.       IF(SETUP.EQ.-1)GO TO 8305
  499. C
  500. C  HAVING READ IN THE DATABASE, CERTAIN THINGS ARE NOW CONSTRUCTED.  PRO
  501. C  SET TO ZERO.  WE FINISH SETTING UP COND BY CHECKING FOR FORCED-MOTION
  502. C  ENTRIES.  THE PLAC AND FIXD ARRAYS ARE USED TO SET UP ATLOC(N) AS THE
  503. C  OBJECT AT LOCATION N, AND LINK(OBJ) AS THE NEXT OBJECT AT THE SAME LO
  504. C  AS OBJ.  (OBJ>100 INDICATES THAT FIXED(OBJ-100)=LOC; LINK(OBJ) IS STI
  505. C  CORRECT LINK TO USE.)  ABB IS ZEROED; IT CONTROLS WHETHER THE ABBREVI
  506. C  DESCRIPTION IS PRINTED.  COUNTS MOD 5 UNLESS "LOOK" IS USED.
  507. C
  508.       DO 1101 I=1,100
  509.          PLACE(I)=0
  510.          PROP(I)=0
  511.          LINK(I)=0
  512.  1101 LINK(I+100)=0
  513. C
  514.       DO 1102 I=1,LOCSIZ
  515.          ABB(I)=0
  516.          IF(LTEXT(I).EQ.0.OR.KEY(I).EQ.0)GO TO 1102
  517.          K=KEY(I)
  518.          IF(MOD(IABS(TRAVEL(K)),1000).EQ.1)COND(I)=2
  519.  1102 ATLOC(I)=0
  520. C
  521. C  SET UP THE ATLOC AND LINK ARRAYS AS DESCRIBED ABOVE.  WE'LL USE THE D
  522. C  SUBROUTINE, WHICH PREFACES NEW OBJECTS ON THE LISTS.  SINCE WE WANT T
  523. C  IN THE OTHER ORDER, WE'LL RUN THE LOOP BACKWARDS.  IF THE OBJECT IS I
  524. C  LOCS, WE DROP IT TWICE.  THIS ALSO SETS UP "PLACE" AND "FIXED" AS COP
  525. C  "PLAC" AND "FIXD".  ALSO, SINCE TWO-PLACED OBJECTS ARE TYPICALLY BEST
  526. C  DESCRIBED LAST, WE'LL DROP THEM FIRST.
  527. C
  528.       DO 1106 I=1,100
  529.          K=101-I
  530.          IF(FIXD(K).LE.0)GO TO 1106
  531.          CALL DROP(K+100,FIXD(K))
  532.          CALL DROP(K,PLAC(K))
  533.  1106 CONTINUE
  534. C
  535.       DO 1107 I=1,100
  536.          K=101-I
  537.          FIXED(K)=FIXD(K)
  538.  1107 IF(PLAC(K).NE.0.AND.FIXD(K).LE.0)CALL DROP(K,PLAC(K))
  539. C
  540. C  TREASURES, AS NOTED EARLIER, ARE OBJECTS 50 THROUGH MAXTRS (CURRENTLY
  541. C  THEIR PROPS ARE INITIALLY -1, AND ARE SET TO 0 THE FIRST TIME THEY AR
  542. C  DESCRIBED.  TALLY KEEPS TRACK OF HOW MANY ARE NOT YET FOUND, SO WE KN
  543. C  WHEN TO CLOSE THE CAVE.  TALLY2 COUNTS HOW MANY CAN NEVER BE FOUND (E
  544. C  LOST BIRD OR BRIDGE).
  545. C
  546.       MAXTRS=79
  547.       TALLY=0
  548.       TALLY2=0
  549.       DO 1200 I=50,MAXTRS
  550.          IF(PTEXT(I).NE.0)PROP(I)=-1
  551.  1200 TALLY=TALLY-PROP(I)
  552. C
  553. C  CLEAR THE HINT STUFF.  HINTLC(I) IS HOW LONG HE'S BEEN AT LOC WITH CO
  554. C  I.  HINTED(I) IS TRUE IFF HINT I HAS BEEN USED.
  555. C
  556.       DO 1300 I=1,HNTMAX
  557.          HINTED(I)=.FALSE.
  558.  1300 HINTLC(I)=0
  559. C
  560. C  DEFINE SOME HANDY MNEMONICS.  THESE CORRESPOND TO OBJECT NUMBERS.
  561. C
  562. c     WRITE (0,9992)
  563. c9992 FORMAT (' DEFINE OBJECT MNEMONICS')
  564. C
  565.       KEYS=VOCAB(CODE1('KEYS     '),1)
  566. c     WRITE (0,9993)
  567. c9993 FORMAT (' DEFINED KEYS')
  568.       LAMP=VOCAB(CODE1('LAMP     '),1)
  569.       GRATE=VOCAB(CODE1('GRATE    '),1)
  570.       CAGE=VOCAB(CODE1('CAGE     '),1)
  571.       ROD=VOCAB(CODE1('ROD      '),1)
  572.       ROD2=ROD+1
  573.       STEPS=VOCAB(CODE1('STEPS    '),1)
  574.       BIRD=VOCAB(CODE1('BIRD     '),1)
  575.       DOOR=VOCAB(CODE1('DOOR     '),1)
  576.       PILLOW=VOCAB(CODE1('PILLO    '),1)
  577.       SNAKE=VOCAB(CODE1('SNAKE    '),1)
  578.       FISSUR=VOCAB(CODE1('FISSU    '),1)
  579.       TABLET=VOCAB(CODE1('TABLE    '),1)
  580.       CLAM=VOCAB(CODE1('CLAM     '),1)
  581.       OYSTER=VOCAB(CODE1('OYSTE    '),1)
  582.       MAGZIN=VOCAB(CODE1('MAGAZ    '),1)
  583.       DWARF=VOCAB(CODE1('DWARF    '),1)
  584.       KNIFE=VOCAB(CODE1('KNIFE    '),1)
  585.       FOOD=VOCAB(CODE1('FOOD     '),1)
  586.       BOTTLE=VOCAB(CODE1('BOTTL    '),1)
  587.       WATER=VOCAB(CODE1('WATER    '),1)
  588.       OIL=VOCAB(CODE1('OIL      '),1)
  589.       PLANT=VOCAB(CODE1('PLANT    '),1)
  590.       PLANT2=PLANT+1
  591.       AXE=VOCAB(CODE1('AXE      '),1)
  592.       MIRROR=VOCAB(CODE1('MIRRO    '),1)
  593.       DRAGON=VOCAB(CODE1('DRAGO    '),1)
  594.       CHASM=VOCAB(CODE1('CHASM    '),1)
  595.       TROLL=VOCAB(CODE1('TROLL    '),1)
  596.       TROLL2=TROLL+1
  597.       BEAR=VOCAB(CODE1('BEAR     '),1)
  598.       MESSAG=VOCAB(CODE1('MESSA    '),1)
  599.       VEND=VOCAB(CODE1('VENDI    '),1)
  600.       BATTER=VOCAB(CODE1('BATTE    '),1)
  601. C
  602. C  OBJECTS FROM 50 THROUGH WHATEVER ARE TREASURES.  HERE ARE A FEW.
  603. C
  604. c     WRITE (0,9994)
  605. c9994 FORMAT (' DEFINE TREASURE MNEMONICS')
  606. C
  607.       NUGGET=VOCAB(CODE1('GOLD     '),1)
  608.       COINS=VOCAB(CODE1('COINS    '),1)
  609.       CHEST=VOCAB(CODE1('CHEST    '),1)
  610.       EGGS=VOCAB(CODE1('EGGS     '),1)
  611.       TRIDNT=VOCAB(CODE1('TRIDE    '),1)
  612.       VASE=VOCAB(CODE1('VASE     '),1)
  613.       EMRALD=VOCAB(CODE1('EMERA    '),1)
  614.       PYRAM=VOCAB(CODE1('PYRAM    '),1)
  615.       PEARL=VOCAB(CODE1('PEARL    '),1)
  616.       RUG=VOCAB(CODE1('RUG      '),1)
  617.       CHAIN=VOCAB(CODE1('CHAIN    '),1)
  618.       SPICES=VOCAB(CODE1('SPICE    '),1)
  619. C
  620. C  THESE ARE MOTION-VERB NUMBERS.
  621. C
  622.       BACK=VOCAB(CODE1('BACK      '),0)
  623.       LOOK=VOCAB(CODE1('LOOK      '),0)
  624.       CAVE=VOCAB(CODE1('CAVE      '),0)
  625.       NULL=VOCAB(CODE1('NULL     '),0)
  626.       ENTRNC=VOCAB(CODE1('ENTRA    '),0)
  627.       DPRSSN=VOCAB(CODE1('DEPRE    '),0)
  628. C
  629. C  AND SOME ACTION VERBS.
  630. C
  631. c     WRITE (0,9995)
  632. c9995 FORMAT (' DEFINE ACTION MNEMONICS')
  633. C
  634.       SAY=VOCAB(CODE1('SAY      '),2)
  635.       LOCK=VOCAB(CODE1('LOCK     '),2)
  636.       THROW=VOCAB(CODE1('THROW    '),2)
  637.       FIND=VOCAB(CODE1('FIND     '),2)
  638.       INVENT=VOCAB(CODE1('INVEN    '),2)
  639.       SUSPND=VOCAB(CODE1('SUSPE    '),2)
  640. C
  641. c     WRITE (0,9996)
  642. c9996 FORMAT (' END MNEMONICS')
  643. C
  644. C  INITIALIZE THE DWARVES.  DLOC IS LOC OF DWARVES, HARD-WIRED IN.  ODLO
  645. C  PRIOR LOC OF EACH DWARF, INITIALLY GARBAGE.  DALTLC IS ALTERNATE INIT
  646. C  FOR DWARF, IN CASE ONE OF THEM STARTS OUT ON TOP OF THE ADVENTURER.
  647. C  OF THE 5 INITIAL LOCS ARE ADJACENT.)  DSEEN IS TRUE IF DWARF HAS SEEN
  648. C  DFLAG CONTROLS THE LEVEL OF ACTIVATION OF ALL THIS:
  649. C       0       NO DWARF STUFF YET (WAIT UNTIL REACHES HALL OF MISTS)
  650. C       1       REACHED HALL OF MISTS, BUT HASN'T MET FIRST DWARF
  651. C       2       MET FIRST DWARF, OTHERS START MOVING, NO KNIVES THROWN Y
  652. C       3       A KNIFE HAS BEEN THROWN (FIRST SET ALWAYS MISSES)
  653. C       3+      DWARVES ARE MAD (INCREASES THEIR ACCURACY)
  654. C  SIXTH DWARF IS SPECIAL (THE PIRATE).  HE ALWAYS STARTS AT HIS CHEST'S
  655. C  EVENTUAL LOCATION INSIDE THE MAZE.  THIS LOC IS SAVED IN CHLOC FOR RE
  656. C  THE DEAD END IN THE OTHER MAZE HAS ITS LOC STORED IN CHLOC2.
  657. C
  658.       CHLOC=114
  659.       CHLOC2=140
  660.       DO 1700 I=1,6
  661.  1700 DSEEN(I)=.FALSE.
  662.       DFLAG=0
  663.       DLOC(1)=19
  664.       DLOC(2)=27
  665.       DLOC(3)=33
  666.       DLOC(4)=44
  667.       DLOC(5)=64
  668.       DLOC(6)=CHLOC
  669.       DALTLC=18
  670. C
  671. C  OTHER RANDOM FLAGS AND COUNTERS, AS FOLLOWS:
  672. C       TURNS   TALLIES HOW MANY COMMANDS HE'S GIVEN (IGNORES YES/NO)
  673. C       LIMIT   LIFETIME OF LAMP (NOT SET HERE)
  674. C       IWEST   HOW MANY TIMES HE'S SAID "WEST" INSTEAD OF "W"
  675. C       KNFLOC  0 IF NO KNIFE HERE, LOC IF KNIFE HERE, -1 AFTER CAVEAT
  676. C       DETAIL  HOW OFTEN WE'VE SAID "NOT ALLOWED TO GIVE MORE DETAIL"
  677. C       ABBNUM  HOW OFTEN WE SHOULD PRINT NON-ABBREVIATED DESCRIPTIONS
  678. C       MAXDIE  NUMBER OF REINCARNATION MESSAGES AVAILABLE (UP TO 5)
  679. C       NUMDIE  NUMBER OF TIMES KILLED SO FAR
  680. C       HOLDNG  NUMBER OF OBJECTS BEING CARRIED
  681. C       DKILL   NUMBER OF DWARVES KILLED (UNUSED IN SCORING, NEEDED FOR
  682. C       FOOBAR  CURRENT PROGRESS IN SAYING "FEE FIE FOE FOO".
  683. C       BONUS   USED TO DETERMINE AMOUNT OF BONUS IF HE REACHES CLOSING
  684. C       CLOCK1  NUMBER OF TURNS FROM FINDING LAST TREASURE TILL CLOSING
  685. C       CLOCK2  NUMBER OF TURNS FROM FIRST WARNING TILL BLINDING FLASH
  686. C       LOGICALS WERE EXPLAINED EARLIER
  687. C
  688.       TURNS=0
  689.       LMWARN=.FALSE.
  690.       IWEST=0
  691.       KNFLOC=0
  692.       DETAIL=0
  693.       ABBNUM=5
  694.       DO 1800 I=0,4
  695.  1800 IF(RTEXT(2*I+81).NE.0)MAXDIE=I+1
  696.       NUMDIE=0
  697.       HOLDNG=0
  698.       DKILL=0
  699.       FOOBAR=0
  700.       BONUS=0
  701.       CLOCK1=30
  702.       CLOCK2=50
  703.       SAVED=0
  704.       CLOSNG=.FALSE.
  705.       PANIC=.FALSE.
  706.       CLOSED=.FALSE.
  707.       GAVEUP=.FALSE.
  708.       SCORNG=.FALSE.
  709. C
  710. C  IF SETUP=1, REPORT ON AMOUNT OF ARRAYS ACTUALLY USED, TO PERMIT REDUC
  711. C
  712.       IF(SETUP.NE.1)GO TO 19990
  713.       SETUP=2
  714. C
  715.       DO 1998 K=1,LOCSIZ
  716.          KK=LOCSIZ+1-K
  717.          IF(LTEXT(KK).NE.0)GO TO 1997
  718.  1998 CONTINUE
  719. C
  720.       OBJ=0
  721.  1997 DO 1996 K=1,100
  722.  1996 IF(PTEXT(K).NE.0)OBJ=OBJ+1
  723. C
  724.       DO 1995 K=1,TABNDX
  725.  1995 IF(KTAB(K)/1000.EQ.2)VERB=KTAB(K)-2000
  726. C
  727.       DO 1994 K=1,RTXSIZ
  728.          J=RTXSIZ+1-K
  729.          IF(RTEXT(J).NE.0)GO TO 1993
  730.  1994 CONTINUE
  731. C
  732.  1993 DO 1992 K=1,MAGSIZ
  733.          I=MAGSIZ+1-K
  734.          IF(MTEXT(I).NE.0)GO TO 1991
  735.  1992 CONTINUE
  736. C
  737.  1991 K=100
  738.       WRITE(TTYO,1999)LINUSE,LINSIZ,TRVS,TRVSIZ,TABNDX,TABSIZ,KK
  739.      1,LOCSIZ,OBJ,K,VERB,VRBSIZ,J,RTXSIZ,CLSSES,CLSMAX
  740.      2,HNTMAX,HNTSIZ,I,MAGSIZ
  741.  1999 FORMAT (' TABLE SPACE USED:',/
  742.      1' ',I6,' OF ',I6,' WORDS OF MESSAGES',/
  743.      2' ',I6,' OF ',I6,' TRAVEL OPTIONS',/
  744.      3' ',I6,' OF ',I6,' VOCABULARY WORDS',/
  745.      4' ',I6,' OF ',I6,' LOCATIONS',/
  746.      5' ',I6,' OF ',I6,' OBJECTS',/
  747.      6' ',I6,' OF ',I6,' ACTION VERBS',/
  748.      7' ',I6,' OF ',I6,' RTEXT MESSAGES',/
  749.      8' ',I6,' OF ',I6,' CLASS MESSAGES',/
  750.      9' ',I6,' OF ',I6,' HINTS',/
  751.      1' ',I6,' OF ',I6,' MAGIC MESSAGES',/
  752.      2)
  753. C
  754. C  FINALLY, SINCE WE'RE CLEARLY SETTING THINGS UP FOR THE FIRST TIME...
  755. C
  756.       CALL POOF
  757. 19990 CALL MAINT(CMADRS,CMSZES)
  758. C
  759.       WRITE(TTYO,19991)
  760. 19991 FORMAT(' INITIALIZATION COMPLETED.')
  761. C
  762. C  START-UP, DWARF STUFF
  763. C
  764.     1 DEMO=START(0)
  765.       CALL MOTD(.FALSE.)
  766.       I=RAN(1)
  767.       HINTED(3)=YESX(65,1,0,1)
  768.       NEWLOC=1
  769.       SETUP=3
  770.       LIMIT=330
  771.       IF(HINTED(3))LIMIT=1000
  772. C
  773. C  CAN'T LEAVE CAVE ONCE IT'S CLOSING (EXCEPT BY MAIN OFFICE).
  774. C
  775.     2 IF(NEWLOC.GE.9.OR.NEWLOC.EQ.0.OR..NOT.CLOSNG)GO TO 71
  776.       CALL RSPEAK(130)
  777.       NEWLOC=LOC
  778.       IF(.NOT.PANIC)CLOCK2=15
  779.       PANIC=.TRUE.
  780. C
  781. C  SEE IF A DWARF HAS SEEN HIM AND HAS COME FROM WHERE HE WANTS TO GO.
  782. C  THE DWARF'S BLOCKING HIS WAY.  IF COMING FROM PLACE FORBIDDEN TO PIRA
  783. C  (DWARVES ROOTED IN PLACE) LET HIM GET OUT (AND ATTACKED).
  784. C
  785.    71 IF(NEWLOC.EQ.LOC.OR.FORCED(LOC).OR.BITSET(LOC,3))GO TO 74
  786.       DO 73 I=1,5
  787.          IF(ODLOC(I).NE.NEWLOC.OR..NOT.DSEEN(I))GO TO 73
  788.          NEWLOC=LOC
  789.          CALL RSPEAK(2)
  790.          GO TO 74
  791.    73 CONTINUE
  792.    74 LOC=NEWLOC
  793. C
  794. C  DWARF STUFF.  SEE EARLIER COMMENTS FOR DESCRIPTION OF VARIABLES.  REM
  795. C  SIXTH DWARF IS PIRATE AND IS THUS VERY DIFFERENT EXCEPT FOR MOTION RU
  796. C
  797. C  FIRST OFF, DON'T LET THE DWARVES FOLLOW HIM INTO A PIT OR A WALL.  AC
  798. C  THE WHOLE MESS THE FIRST TIME HE GETS AS FAR AS THE HALL OF MISTS (LO
  799. C  IF NEWLOC IS FORBIDDEN TO PIRATE (IN PARTICULAR, IF IT'S BEYOND THE T
  800. C  BRIDGE), BYPASS DWARF STUFF.  THAT WAY PIRATE CAN'T STEAL RETURN TOLL
  801. C  DWARVES CAN'T MEET THE BEAR.  ALSO MEANS DWARVES WON'T FOLLOW HIM INT
  802. C  END IN MAZE, BUT C'EST LA VIE.  THEY'LL WAIT FOR HIM OUTSIDE THE DEAD
  803. C
  804.       IF(LOC.EQ.0.OR.FORCED(LOC).OR.BITSET(NEWLOC,3))GO TO 2000
  805.       IF(DFLAG.NE.0)GO TO 6000
  806.       IF(LOC.GE.15)DFLAG=1
  807.       GO TO 2000
  808. C
  809. C  WHEN WE ENCOUNTER THE FIRST DWARF, WE KILL 0, 1, OR 2 OF THE 5 DWARVE
  810. C  ANY OF THE SURVIVORS IS AT LOC, REPLACE HIM WITH THE ALTERNATE.
  811. C
  812.  6000 IF(DFLAG.NE.1)GO TO 6010
  813.       IF(LOC.LT.15.OR.PCT(95))GO TO 2000
  814.       DFLAG=2
  815.       DO 6001 I=1,2
  816.          J=1+RAN(5)
  817. C  IF SAVED NOT = -1, HE BYPASSED THE "START" CALL.
  818.  6001 IF(PCT(50).AND.SAVED.EQ.-1)DLOC(J)=0
  819.       DO 6002 I=1,5
  820.          IF(DLOC(I).EQ.LOC)DLOC(I)=DALTLC
  821.  6002 ODLOC(I)=DLOC(I)
  822.       CALL RSPEAK(3)
  823.       CALL DROP(AXE,LOC)
  824.       GO TO 2000
  825. C
  826. C  THINGS ARE IN FULL SWING.  MOVE EACH DWARF AT RANDOM, EXCEPT IF HE'S
  827. C  HE STICKS WITH US.  DWARVES NEVER GO TO LOCS <15.  IF WANDERING AT RA
  828. C  THEY DON'T BACK UP UNLESS THERE'S NO ALTERNATIVE.  IF THEY DON'T HAVE
  829. C  MOVE, THEY ATTACK.  AND, OF COURSE, DEAD DWARVES DON'T DO MUCH OF ANY
  830. C
  831.  6010 DTOTAL=0
  832.       ATTACK=0
  833.       STICK=0
  834.       DO 6030 I=1,6
  835.          IF(DLOC(I).EQ.0)GO TO 6030
  836.          J=1
  837.          KK=DLOC(I)
  838.          KK=KEY(KK)
  839.          IF(KK.EQ.0)GO TO 6016
  840.  6012    NEWLOC=MOD(IABS(TRAVEL(KK))/1000,1000)
  841.          IF(NEWLOC.GT.300.OR.NEWLOC.LT.15.OR.NEWLOC.EQ.ODLOC(I)
  842.      1   .OR.(J.GT.1.AND.NEWLOC.EQ.TK(J-1)).OR.J.GE.20
  843.      2   .OR.NEWLOC.EQ.DLOC(I).OR.FORCED(NEWLOC)
  844.      3   .OR.(I.EQ.6.AND.BITSET(NEWLOC,3))
  845.      4   .OR.IABS(TRAVEL(KK))/1000000.EQ.100)GO TO 6014
  846.          TK(J)=NEWLOC
  847.          J=J+1
  848.  6014    KK=KK+1
  849.          IF(TRAVEL(KK-1).GE.0)GO TO 6012
  850.  6016    TK(J)=ODLOC(I)
  851.          IF(J.GE.2)J=J-1
  852.          J=1+RAN(J)
  853.          ODLOC(I)=DLOC(I)
  854.          DLOC(I)=TK(J)
  855.          DSEEN(I)=(DSEEN(I).AND.LOC.GE.15)
  856.      1   .OR.(DLOC(I).EQ.LOC.OR.ODLOC(I).EQ.LOC)
  857.          IF(.NOT.DSEEN(I))GO TO 6030
  858.          DLOC(I)=LOC
  859.          IF(I.NE.6)GO TO 6027
  860. C
  861. C  THE PIRATE'S SPOTTED HIM.  HE LEAVES HIM ALONE ONCE WE'VE FOUND CHEST
  862. C  K COUNTS IF A TREASURE IS HERE.  IF NOT, AND TALLY=TALLY2 PLUS ONE FO
  863. C  AN UNSEEN CHEST, LET THE PIRATE BE SPOTTED.
  864. C
  865.          IF(LOC.EQ.CHLOC.OR.PROP(CHEST).GE.0)GO TO 6030
  866.          K=0
  867.          DO 6020 J=50,MAXTRS
  868. C  PIRATE WON'T TAKE PYRAMID FROM PLOVER ROOM OR DARK ROOM (TOO EASY!).
  869.             IF(J.EQ.PYRAM.AND.(LOC.EQ.PLAC(PYRAM)
  870.      1      .OR.LOC.EQ.PLAC(EMRALD)))GO TO 6020
  871.             IF(TOTING(J))GO TO 6022
  872.  6020    IF(HERE(J))K=1
  873.          IF(TALLY.EQ.TALLY2+1.AND.K.EQ.0.AND.PLACE(CHEST).EQ.0
  874.      1   .AND.HERE(LAMP).AND.PROP(LAMP).EQ.1)GO TO 6025
  875.          IF(ODLOC(6).NE.DLOC(6).AND.PCT(20))CALL RSPEAK(127)
  876.          GO TO 6030
  877. C
  878.  6022    CALL RSPEAK(128)
  879. C  DON'T STEAL CHEST BACK FROM TROLL!
  880.          IF(PLACE(MESSAG).EQ.0)CALL MOVE(CHEST,CHLOC)
  881.          CALL MOVE(MESSAG,CHLOC2)
  882.          DO 6023 J=50,MAXTRS
  883.             IF(J.EQ.PYRAM.AND.(LOC.EQ.PLAC(PYRAM)
  884.      1      .OR.LOC.EQ.PLAC(EMRALD)))GO TO 6023
  885.             IF(AT(J).AND.FIXED(J).EQ.0)CALL CARRY(J,LOC)
  886.             IF(TOTING(J))CALL DROP(J,CHLOC)
  887.  6023    CONTINUE
  888.  6024    DLOC(6)=CHLOC
  889.          ODLOC(6)=CHLOC
  890.          DSEEN(6)=.FALSE.
  891.          GO TO 6030
  892. C
  893.  6025    CALL RSPEAK(186)
  894.          CALL MOVE(CHEST,CHLOC)
  895.          CALL MOVE(MESSAG,CHLOC2)
  896.          GO TO 6024
  897. C
  898. C  THIS THREATENING LITTLE DWARF IS IN THE ROOM WITH HIM!
  899. C
  900.  6027    DTOTAL=DTOTAL+1
  901.          IF(ODLOC(I).NE.DLOC(I))GO TO 6030
  902.          ATTACK=ATTACK+1
  903.          IF(KNFLOC.GE.0)KNFLOC=LOC
  904.          IF(RAN(1000).LT.95*(DFLAG-2))STICK=STICK+1
  905.  6030 CONTINUE
  906. C
  907. C  NOW WE KNOW WHAT'S HAPPENING.  LET'S TELL THE POOR SUCKER ABOUT IT.
  908. C
  909.       IF(DTOTAL.EQ.0)GO TO 2000
  910.       IF(DTOTAL.EQ.1)GO TO 75
  911.       WRITE(TTYO,67)DTOTAL
  912.    67 FORMAT(/,' THERE ARE ',I1,' THREATENING LITTLE DWARVES IN THE'
  913.      1,' ROOM WITH YOU.')
  914.       GO TO 77
  915.    75 CALL RSPEAK(4)
  916.    77 IF(ATTACK.EQ.0)GO TO 2000
  917.       IF(DFLAG.EQ.2)DFLAG=3
  918. C  IF SAVED NOT = -1, HE BYPASSED THE "START" CALL.  DWARVES GET *VERY*
  919.       IF(SAVED.NE.-1)DFLAG=20
  920.       IF(ATTACK.EQ.1)GO TO 79
  921.       WRITE(TTYO,78)ATTACK
  922.    78 FORMAT(/,' ',I1,' OF THEM THROW KNIVES AT YOU!')
  923.       K=6
  924.    82 IF(STICK.GT.1)GO TO 83
  925.       CALL RSPEAK(K+STICK)
  926.       IF(STICK.EQ.0)GO TO 2000
  927.       GO TO 84
  928.    83 WRITE(TTYO,68)STICK
  929.    68 FORMAT(/,' ',I1,' OF THEM GET YOU!')
  930.    84 OLDLC2=LOC
  931.       GO TO 99
  932. C
  933.    79 CALL RSPEAK(5)
  934.       K=52
  935.       GO TO 82
  936. C
  937. C  DESCRIBE THE CURRENT LOCATION AND (MAYBE) GET NEXT COMMAND.
  938. C
  939. C  PRINT TEXT FOR CURRENT LOC.
  940. C
  941.  2000 IF(LOC.EQ.0)GO TO 99
  942.       KK=STEXT(LOC)
  943.       IF(MOD(ABB(LOC),ABBNUM).EQ.0.OR.KK.EQ.0)KK=LTEXT(LOC)
  944.       IF(FORCED(LOC).OR..NOT.DARK(0))GO TO 2001
  945.       IF(WZDARK.AND.PCT(35))GO TO 90
  946.       KK=RTEXT(16)
  947.  2001 IF(TOTING(BEAR))CALL RSPEAK(141)
  948.       CALL SPEAK(KK)
  949.       K=1
  950.       IF(FORCED(LOC))GO TO 8
  951.       IF(LOC.EQ.33.AND.PCT(25).AND..NOT.CLOSNG)CALL RSPEAK(8)
  952. C
  953. C  PRINT OUT DESCRIPTIONS OF OBJECTS AT THIS LOCATION.  IF NOT CLOSING A
  954. C  PROPERTY VALUE IS NEGATIVE, TALLY OFF ANOTHER TREASURE.  RUG IS SPECI
  955. C  CASE; ONCE SEEN, ITS PROP IS 1 (DRAGON ON IT) TILL DRAGON IS KILLED.
  956. C  SIMILARLY FOR CHAIN; PROP IS INITIALLY 1 (LOCKED TO BEAR).  THESE HAC
  957. C  ARE BECAUSE PROP=0 IS NEEDED TO GET FULL SCORE.
  958. C
  959.       IF(DARK(0))GO TO 2012
  960.       ABB(LOC)=ABB(LOC)+1
  961.       I=ATLOC(LOC)
  962.  2004 IF(I.EQ.0)GO TO 2012
  963.       OBJ=I
  964.       IF(OBJ.GT.100)OBJ=OBJ-100
  965.       IF(OBJ.EQ.STEPS.AND.TOTING(NUGGET))GO TO 2008
  966.       IF(PROP(OBJ).GE.0)GO TO 2006
  967.       IF(CLOSED)GO TO 2008
  968.       PROP(OBJ)=0
  969.       IF(OBJ.EQ.RUG.OR.OBJ.EQ.CHAIN)PROP(OBJ)=1
  970.       TALLY=TALLY-1
  971. C  IF REMAINING TREASURES TOO ELUSIVE, ZAP HIS LAMP.
  972.       IF(TALLY.EQ.TALLY2.AND.TALLY.NE.0)LIMIT=MIN0(35,LIMIT)
  973.  2006 KK=PROP(OBJ)
  974.       IF(OBJ.EQ.STEPS.AND.LOC.EQ.FIXED(STEPS))KK=1
  975.       CALL PSPEAK(OBJ,KK)
  976.  2008 I=LINK(I)
  977.       GO TO 2004
  978. C
  979.  2009 K=54
  980.  2010 SPK=K
  981.  2011 CALL RSPEAK(SPK)
  982. C
  983.  2012 VERB=0
  984.       OBJ=0
  985. C
  986. C  CHECK IF THIS LOC IS ELIGIBLE FOR ANY HINTS.  IF BEEN HERE LONG ENOUG
  987. C  BRANCH TO HELP SECTION (ON LATER PAGE).  HINTS ALL COME BACK HERE EVE
  988. C  TO FINISH THE LOOP.  IGNORE "HINTS" < 4 (SPECIAL STUFF, SEE DATABASE
  989. C
  990.  2600 DO 2602 HINT=4,HNTMAX
  991.       IF(HINTED(HINT))GO TO 2602
  992.       IF(.NOT.BITSET(LOC,HINT))HINTLC(HINT)=-1
  993.       HINTLC(HINT)=HINTLC(HINT)+1
  994.       IF(HINTLC(HINT).GE.HINTS(HINT,1))GO TO 40000
  995.  2602 CONTINUE
  996. C
  997. C  KICK THE RANDOM NUMBER GENERATOR JUST TO ADD VARIETY TO THE CHASE.  A
  998. C  IF CLOSING TIME, CHECK FOR ANY OBJECTS BEING TOTED WITH PROP < 0 AND
  999. C  THE PROP TO -1-PROP.  THIS WAY OBJECTS WON'T BE DESCRIBED UNTIL THEY'
  1000. C  BEEN PICKED UP AND PUT DOWN SEPARATE FROM THEIR RESPECTIVE PILES.  DO
  1001. C  TICK CLOCK1 UNLESS WELL INTO CAVE (AND NOT AT Y2).
  1002. C
  1003.       IF(.NOT.CLOSED)GO TO 2605
  1004.       IF(PROP(OYSTER).LT.0.AND.TOTING(OYSTER))
  1005.      1CALL PSPEAK(OYSTER,1)
  1006.       DO 2604 I=1,100
  1007.  2604 IF(TOTING(I).AND.PROP(I).LT.0)PROP(I)=-1-PROP(I)
  1008.  2605 WZDARK=DARK(0)
  1009.       IF(KNFLOC.GT.0.AND.KNFLOC.NE.LOC)KNFLOC=0
  1010.       I=RAN(1)
  1011.       CALL GETIN(WD1,WD1X,WD2,WD2X,.FALSE.)
  1012. C
  1013. C  EVERY INPUT, CHECK "FOOBAR" FLAG.  IF ZERO, NOTHING'S GOING ON.  IF P
  1014. C  MAKE NEG.  IF NEG, HE SKIPPED A WORD, SO MAKE IT ZERO.
  1015. C
  1016.  2608 FOOBAR=MIN0(0,-FOOBAR)
  1017.       IF(TURNS.EQ.0.AND.WD1.EQ.CODE1('MAGIC    ').AND.
  1018.      1WD2.EQ.CODE1('MODE     '))CALL MAINT(CMADRS,CMSZES)
  1019.       IF(TURNS.EQ.0.AND.WD1.EQ.CODE1('RESTO    '))GO TO 8400
  1020. C
  1021.       TURNS=TURNS+1
  1022.       IF(DEMO.AND.TURNS.GE.SHORT)GO TO 13000
  1023. C
  1024.       IF(TURNS.EQ.3)CALL DATIME(XXD,XXT)
  1025.       IF(TURNS.NE.45)GO TO 2609
  1026. C  CHECK IF PLAYER HAS ZAPPED TIMING ROUTINE;  IF SO, HE'S CHEATING.
  1027.       CALL DATIME(YYD,YYT)
  1028.       IF(XXD.EQ.YYD.AND.XXT.EQ.YYT)SAVED=0
  1029. C
  1030.  2609 IF(VERB.EQ.SAY.AND.WD2.NE.0)VERB=0
  1031.       IF(VERB.EQ.SAY)GO TO 4090
  1032.       IF(TALLY.EQ.0.AND.LOC.GE.15.AND.LOC.NE.33)CLOCK1=CLOCK1-1
  1033.       IF(CLOCK1.EQ.0)GO TO 10000
  1034.       IF(CLOCK1.LT.0)CLOCK2=CLOCK2-1
  1035.       IF(CLOCK2.EQ.0)GO TO 11000
  1036.       IF(PROP(LAMP).EQ.1)LIMIT=LIMIT-1
  1037.       IF(LIMIT.LE.30.AND.HERE(BATTER).AND.PROP(BATTER).EQ.0
  1038.      1.AND.HERE(LAMP))GO TO 12000
  1039.       IF(LIMIT.EQ.0)GO TO 12400
  1040.       IF(LIMIT.LT.0.AND.LOC.LE.8)GO TO 12600
  1041.       IF(LIMIT.LE.30)GO TO 12200
  1042. 19999 K=43
  1043.       IF(LIQLOC(LOC).EQ.WATER)K=70
  1044.       IF(WD1.EQ.CODE1('ENTER    ').AND.
  1045.      1(WD2.EQ.CODE1('STREA    ').OR.WD2.EQ.CODE1('WATER    ')))
  1046.      2GO TO 2010
  1047.       IF(WD1.EQ.CODE1('ENTER    ').AND.WD2.NE.0)GO TO 2800
  1048.       IF((WD1.NE.CODE1('WATER    ').AND.WD1.NE.CODE1('OIL      '))
  1049.      1.OR.(WD2.NE.CODE1('PLANT    ').AND.WD2.NE.CODE1('DOOR     ')))
  1050.      *GO TO 2610
  1051.       IF(AT(VOCAB(WD2,1)))WD2=CODE1('POUR     ')
  1052.  2610 IF(WD1.NE.CODE1('WEST     '))GO TO 2630
  1053.       IWEST=IWEST+1
  1054.       IF(IWEST.EQ.10)CALL RSPEAK(17)
  1055.  2630 I=VOCAB(WD1,-1)
  1056.       IF(I.EQ.-1)GO TO 3000
  1057.       K=MOD(I,1000)
  1058.       KQ=I/1000+1
  1059.       IF ((KQ.LT.1).OR.(KQ.GT.4)) CALL BUG(22)
  1060.       GO TO (8,5000,4000,2010),KQ
  1061. C
  1062. C  GET SECOND WORD FOR ANALYSIS.
  1063. C
  1064.  2800 WD1=WD2
  1065.       WD1X=WD2X
  1066.       WD2=0
  1067.       GO TO 2610
  1068. C
  1069. C  GEE, I DON'T UNDERSTAND.
  1070. C
  1071.  3000 SPK=60
  1072.       IF(PCT(20))SPK=61
  1073.       IF(PCT(20))SPK=13
  1074.       CALL RSPEAK(SPK)
  1075.       GO TO 2600
  1076. C
  1077. C  ANALYSE A VERB.  REMEMBER WHAT IT WAS, GO BACK FOR OBJECT IF SECOND W
  1078. C  UNLESS VERB IS "SAY" OR "SUSPEND", WHICH SNARFS ARBITRARY SECOND WORD
  1079. C
  1080.  4000 VERB=K
  1081.       SPK=ACTSPK(VERB)
  1082.       IF(WD2.NE.0.AND.
  1083.      1(VERB.NE.SAY.AND.VERB.NE.SUSPND))GO TO 2800
  1084.       IF(VERB.EQ.SAY.OR.VERB.EQ.SUSPND)OBJ=WD2
  1085.       IF(OBJ.NE.0)GO TO 4090
  1086. C
  1087. C  ANALYSE AN INTRANSITIVE VERB (IE, NO OBJECT GIVEN YET).
  1088. C
  1089.       IF ((VERB.LT.1).OR.(VERB.GT.31)) CALL BUG(23)
  1090.  4080 GO TO(8010,8000,8000,8040,2009,8040,9070,9080,8000,8000,
  1091.      12011,9120,9130,8140,9150,8000,8000,8180,8000,8200,
  1092.      28000,9220,9230,8240,8250,8260,8270,8000,8000,8300,
  1093.      38310),VERB
  1094. C          TAKE DROP  SAY OPEN NOTH LOCK   ON  OFF WAVE CALM
  1095. C     WALK KILL POUR  EAT DRNK  RUB TOSS QUIT FIND INVN
  1096. C     FEED FILL BLST SCOR  FOO  BRF READ BREK WAKE SUSP
  1097. C     HOUR
  1098. C
  1099. C  ANALYSE A TRANSITIVE VERB.
  1100. C
  1101.       IF ((VERB.LT.1).OR.(VERB.GT.31)) CALL BUG(24)
  1102.  4090 GO TO(9010,9020,9030,9040,2009,9040,9070,9080,9090,2011,
  1103.      12011,9120,9130,9140,9150,9160,9170,2011,9190,9190,
  1104.      29210,9220,9230,2011,2011,2011,9270,9280,9290,8300,
  1105.      32011),VERB
  1106. C          TAKE DROP  SAY OPEN NOTH LOCK   ON  OFF WAVE CALM
  1107. C     WALK KILL POUR  EAT DRNK  RUB TOSS QUIT FIND INVN
  1108. C     FEED FILL BLST SCOR  FOO  BRF READ BREK WAKE SUSP
  1109. C     HOUR
  1110. C
  1111. C  ANALYSE AN OBJECT WORD.  SEE IF THE THING IS HERE, WHETHER WE'VE GOT
  1112. C  YET, AND SO ON.  OBJECT MUST BE HERE UNLESS VERB IS "FIND" OR "INVENT
  1113. C  (AND NO NEW VERB YET TO BE ANALYSED).  WATER AND OIL ARE ALSO FUNNY,
  1114. C  THEY ARE NEVER ACTUALLY DROPPED AT ANY LOCATION, BUT MIGHT BE HERE IN
  1115. C  THE BOTTLE OR AS A FEATURE OF THE LOCATION.
  1116. C
  1117.  5000 OBJ=K
  1118.       IF(FIXED(K).NE.LOC.AND..NOT.HERE(K))GO TO 5100
  1119.  5010 IF(WD2.NE.0)GO TO 2800
  1120.       IF(VERB.NE.0)GO TO 4090
  1121.       CALL A5TOA1(WD1,WD1X,CODE1('?        '),.FALSE.,TK,K)
  1122.       WRITE(TTYO,5015)(TK(I),I=1,K)
  1123.  5015 FORMAT(/,' WHAT DO YOU WANT TO DO WITH THE ',20A1)
  1124.       GO TO 2600
  1125. C
  1126.  5100 IF(K.NE.GRATE)GO TO 5110
  1127.       IF(LOC.EQ.1.OR.LOC.EQ.4.OR.LOC.EQ.7)K=DPRSSN
  1128.       IF(LOC.GT.9.AND.LOC.LT.15)K=ENTRNC
  1129.       IF(K.NE.GRATE)GO TO 8
  1130.  5110 IF(K.NE.DWARF)GO TO 5120
  1131.       DO 5112 I=1,5
  1132.          IF(DLOC(I).EQ.LOC.AND.DFLAG.GE.2)GO TO 5010
  1133.  5112 CONTINUE
  1134.  5120 IF((LIQ(0).EQ.K.AND.HERE(BOTTLE)).OR.K.EQ.LIQLOC(LOC))GO TO 5010
  1135.       IF(OBJ.NE.PLANT.OR..NOT.AT(PLANT2).OR.PROP(PLANT2).EQ.0)GO TO 5130
  1136.       OBJ=PLANT2
  1137.       GO TO 5010
  1138.  5130 IF(OBJ.NE.KNIFE.OR.KNFLOC.NE.LOC)GO TO 5140
  1139.       KNFLOC=-1
  1140.       SPK=116
  1141.       GO TO 2011
  1142.  5140 IF(OBJ.NE.ROD.OR..NOT.HERE(ROD2))GO TO 5190
  1143.       OBJ=ROD2
  1144.       GO TO 5010
  1145.  5190 IF((VERB.EQ.FIND.OR.VERB.EQ.INVENT).AND.WD2.EQ.0)GO TO 5010
  1146.       CALL A5TOA1(WD1,WD1X,CODE1('HERE.    '),.TRUE.,TK,K)
  1147.       WRITE(TTYO,5199)(TK(I),I=1,K)
  1148.  5199 FORMAT(/,' I SEE NO ',20A1)
  1149.       GO TO 2012
  1150. C
  1151. C  FIGURE OUT THE NEW LOCATION
  1152. C
  1153. C  GIVEN THE CURRENT LOCATION IN "LOC", AND A MOTION VERB NUMBER IN "K",
  1154. C  THE NEW LOCATION IN "NEWLOC".  THE CURRENT LOC IS SAVED IN "OLDLOC" I
  1155. C  HE WANTS TO RETREAT.  THE CURRENT OLDLOC IS SAVED IN OLDLC2, IN CASE
  1156. C  DIES.  (IF HE DOES, NEWLOC WILL BE LIMBO, AND OLDLOC WILL BE WHAT KIL
  1157. C  HIM, SO WE NEED OLDLC2, WHICH IS THE LAST PLACE HE WAS SAFE.)
  1158. C
  1159.     8 KK=KEY(LOC)
  1160.       NEWLOC=LOC
  1161.       IF(KK.EQ.0)CALL BUG(26)
  1162.       IF(K.EQ.NULL)GO TO 2
  1163.       IF(K.EQ.BACK)GO TO 20
  1164.       IF(K.EQ.LOOK)GO TO 30
  1165.       IF(K.EQ.CAVE)GO TO 40
  1166.       OLDLC2=OLDLOC
  1167.       OLDLOC=LOC
  1168. C
  1169.     9 LL=IABS(TRAVEL(KK))
  1170.       IF(MOD(LL,1000).EQ.1.OR.MOD(LL,1000).EQ.K)GO TO 10
  1171.       IF(TRAVEL(KK).LT.0)GO TO 50
  1172.       KK=KK+1
  1173.       GO TO 9
  1174. C
  1175.    10 LL=LL/1000
  1176.    11 NEWLOC=LL/1000
  1177.       K=MOD(NEWLOC,100)
  1178.       IF(NEWLOC.LE.300)GO TO 13
  1179.       IF(PROP(K).NE.NEWLOC/100-3)GO TO 16
  1180.    12 IF(TRAVEL(KK).LT.0)CALL BUG(25)
  1181.       KK=KK+1
  1182.       NEWLOC=IABS(TRAVEL(KK))/1000
  1183.       IF(NEWLOC.EQ.LL)GO TO 12
  1184.       LL=NEWLOC
  1185.       GO TO 11
  1186. C
  1187.    13 IF(NEWLOC.LE.100)GO TO 14
  1188.       IF(TOTING(K).OR.(NEWLOC.GT.200.AND.AT(K)))GO TO 16
  1189.       GO TO 12
  1190. C
  1191.    14 IF(NEWLOC.NE.0.AND..NOT.PCT(NEWLOC))GO TO 12
  1192.    16 NEWLOC=MOD(LL,1000)
  1193.       IF(NEWLOC.LE.300)GO TO 2
  1194.       IF(NEWLOC.LE.500)GO TO 30000
  1195.       CALL RSPEAK(NEWLOC-500)
  1196.       NEWLOC=LOC
  1197.       GO TO 2
  1198. C
  1199. C  SPECIAL MOTIONS COME HERE.  LABELLING CONVENTION: STATEMENT NUMBERS N
  1200. C  (XX=00-99) ARE USED FOR SPECIAL CASE NUMBER NNN (NNN=301-500).
  1201. C
  1202. 30000 NEWLOC=NEWLOC-300
  1203.       IF ((NEWLOC.LT.1).OR.(NEWLOC.GT.3)) CALL BUG(20)
  1204.       GO TO (30100,30200,30300),NEWLOC
  1205. C
  1206. C  TRAVEL 301.  PLOVER-ALCOVE PASSAGE.  CAN CARRY ONLY EMERALD.  NOTE: T
  1207. C  TABLE MUST INCLUDE "USELESS" ENTRIES GOING THROUGH PASSAGE, WHICH CAN
  1208. C  BE USED FOR ACTUAL MOTION, BUT CAN BE SPOTTED BY "GO BACK".
  1209. C
  1210. 30100 NEWLOC=99+100-LOC
  1211.       IF(HOLDNG.EQ.0.OR.(HOLDNG.EQ.1.AND.TOTING(EMRALD)))GO TO 2
  1212.       NEWLOC=LOC
  1213.       CALL RSPEAK(117)
  1214.       GO TO 2
  1215. C
  1216. C  TRAVEL 302.  PLOVER TRANSPORT.  DROP THE EMERALD (ONLY USE SPECIAL TR
  1217. C  TOTING IT), SO HE'S FORCED TO USE THE PLOVER-PASSAGE TO GET IT OUT.
  1218. C  DROPPED IT, GO BACK AND PRETEND HE WASN'T CARRYING IT AFTER ALL.
  1219. C
  1220. 30200 CALL DROP(EMRALD,LOC)
  1221.       GO TO 12
  1222. C
  1223. C  TRAVEL 303.  TROLL BRIDGE.  MUST BE DONE ONLY AS SPECIAL MOTION SO TH
  1224. C  DWARVES WON'T WANDER ACROSS AND ENCOUNTER THE BEAR.  (THEY WON'T FOLL
  1225. C  PLAYER THERE BECAUSE THAT REGION IS FORBIDDEN TO THE PIRATE.)  IF
  1226. C  PROP(TROLL)=1, HE'S CROSSED SINCE PAYING, SO STEP OUT AND BLOCK HIM.
  1227. C  (STANDARD TRAVEL ENTRIES CHECK FOR PROP(TROLL)=0.)  SPECIAL STUFF FOR
  1228. C
  1229. 30300 IF(PROP(TROLL).NE.1)GO TO 30310
  1230.       CALL PSPEAK(TROLL,1)
  1231.       PROP(TROLL)=0
  1232.       CALL MOVE(TROLL2,0)
  1233.       CALL MOVE(TROLL2+100,0)
  1234.       CALL MOVE(TROLL,PLAC(TROLL))
  1235.       CALL MOVE(TROLL+100,FIXD(TROLL))
  1236.       CALL JUGGLE(CHASM)
  1237.       NEWLOC=LOC
  1238.       GO TO 2
  1239. C
  1240. 30310 NEWLOC=PLAC(TROLL)+FIXD(TROLL)-LOC
  1241.       IF(PROP(TROLL).EQ.0)PROP(TROLL)=1
  1242.       IF(.NOT.TOTING(BEAR))GO TO 2
  1243.       CALL RSPEAK(162)
  1244.       PROP(CHASM)=1
  1245.       PROP(TROLL)=2
  1246.       CALL DROP(BEAR,NEWLOC)
  1247.       FIXED(BEAR)=-1
  1248.       PROP(BEAR)=3
  1249.       IF(PROP(SPICES).LT.0)TALLY2=TALLY2+1
  1250.       OLDLC2=NEWLOC
  1251.       GO TO 99
  1252. C
  1253. C  END OF SPECIALS.
  1254. C
  1255. C  HANDLE "GO BACK".  LOOK FOR VERB WHICH GOES FROM LOC TO OLDLOC, OR TO
  1256. C  IF OLDLOC HAS FORCED-MOTION.  K2 SAVES ENTRY -> FORCED LOC -> PREVIOU
  1257. C
  1258.    20 K=OLDLOC
  1259.       IF(FORCED(K))K=OLDLC2
  1260.       OLDLC2=OLDLOC
  1261.       OLDLOC=LOC
  1262.       K2=0
  1263.       IF(K.NE.LOC)GO TO 21
  1264.       CALL RSPEAK(91)
  1265.       GO TO 2
  1266. C
  1267.    21 LL=MOD((IABS(TRAVEL(KK))/1000),1000)
  1268.       IF(LL.EQ.K)GO TO 25
  1269.       IF(LL.GT.300)GO TO 22
  1270.       J=KEY(LL)
  1271.       IF(FORCED(LL).AND.MOD((IABS(TRAVEL(J))/1000),1000).EQ.K)K2=KK
  1272.    22 IF(TRAVEL(KK).LT.0)GO TO 23
  1273.       KK=KK+1
  1274.       GO TO 21
  1275. C
  1276.    23 KK=K2
  1277.       IF(KK.NE.0)GO TO 25
  1278.       CALL RSPEAK(140)
  1279.       GO TO 2
  1280. C
  1281.    25 K=MOD(IABS(TRAVEL(KK)),1000)
  1282.       KK=KEY(LOC)
  1283.       GO TO 9
  1284. C
  1285. C  LOOK.  CAN'T GIVE MORE DETAIL.  PRETEND IT WASN'T DARK (THOUGH IT MAY
  1286. C  BE DARK) SO HE WON'T FALL INTO A PIT WHILE STARING INTO THE GLOOM.
  1287. C
  1288.    30 IF(DETAIL.LT.3)CALL RSPEAK(15)
  1289.       DETAIL=DETAIL+1
  1290.       WZDARK=.FALSE.
  1291.       ABB(LOC)=0
  1292.       GO TO 2
  1293. C
  1294. C  CAVE.  DIFFERENT MESSAGES DEPENDING ON WHETHER ABOVE GROUND.
  1295. C
  1296.    40 IF(LOC.LT.8)CALL RSPEAK(57)
  1297.       IF(LOC.GE.8)CALL RSPEAK(58)
  1298.       GO TO 2
  1299. C
  1300. C  NON-APPLICABLE MOTION.  VARIOUS MESSAGES DEPENDING ON WORD GIVEN.
  1301. C
  1302.    50 SPK=12
  1303.       IF(K.GE.43.AND.K.LE.50)SPK=9
  1304.       IF(K.EQ.29.OR.K.EQ.30)SPK=9
  1305.       IF(K.EQ.7.OR.K.EQ.36.OR.K.EQ.37)SPK=10
  1306.       IF(K.EQ.11.OR.K.EQ.19)SPK=11
  1307.       IF(VERB.EQ.FIND.OR.VERB.EQ.INVENT)SPK=59
  1308.       IF(K.EQ.62.OR.K.EQ.65)SPK=42
  1309.       IF(K.EQ.17)SPK=80
  1310.       CALL RSPEAK(SPK)
  1311.       GO TO 2
  1312. C
  1313. C  "YOU'RE DEAD, JIM."
  1314. C
  1315. C  IF THE CURRENT LOC IS ZERO, IT MEANS THE CLOWN GOT HIMSELF KILLED.  W
  1316. C  ALLOW THIS MAXDIE TIMES.  MAXDIE IS AUTOMATICALLY SET BASED ON THE NU
  1317. C  SNIDE MESSAGES AVAILABLE.  EACH DEATH RESULTS IN A MESSAGE (81, 83, E
  1318. C  WHICH OFFERS REINCARNATION; IF ACCEPTED, THIS RESULTS IN MESSAGE 82,
  1319. C  ETC.  THE LAST TIME, IF HE WANTS ANOTHER CHANCE, HE GETS A SNIDE REMA
  1320. C  WE EXIT.  WHEN REINCARNATED, ALL OBJECTS BEING CARRIED GET DROPPED AT
  1321. C  (PRESUMABLY THE LAST PLACE PRIOR TO BEING KILLED) WITHOUT CHANGE OF P
  1322. C  THE LOOP RUNS BACKWARDS TO ASSURE THAT THE BIRD IS DROPPED BEFORE THE
  1323. C  (THIS KLUGE COULD BE CHANGED ONCE WE'RE SURE ALL REFERENCES TO BIRD A
  1324. C  ARE DONE BY KEYWORDS.)  THE LAMP IS A SPECIAL CASE (IT WOULDN'T DO TO
  1325. C  IT IN THE CAVE).  IT IS TURNED OFF AND LEFT OUTSIDE THE BUILDING (ONL
  1326. C  WAS CARRYING IT, OF COURSE).  HE HIMSELF IS LEFT INSIDE THE BUILDING
  1327. C  HEAVEN HELP HIM IF HE TRIES TO XYZZY BACK INTO THE CAVE WITHOUT THE L
  1328. C  OLDLOC IS ZAPPED SO HE CAN'T JUST "RETREAT".
  1329. C
  1330. C  THE EASIEST WAY TO GET KILLED IS TO FALL INTO A PIT IN PITCH DARKNESS
  1331. C
  1332.    90 CALL RSPEAK(23)
  1333.       OLDLC2=LOC
  1334. C
  1335. C  OKAY, HE'S DEAD.  LET'S GET ON WITH IT.
  1336. C
  1337.    99 IF(CLOSNG)GO TO 95
  1338.       YEA=YESX(81+NUMDIE*2,82+NUMDIE*2,54,1)
  1339.       NUMDIE=NUMDIE+1
  1340.       IF(NUMDIE.EQ.MAXDIE.OR..NOT.YEA)GO TO 20000
  1341.       PLACE(WATER)=0
  1342.       PLACE(OIL)=0
  1343.       IF(TOTING(LAMP))PROP(LAMP)=0
  1344.       DO 98 J=1,100
  1345.          I=101-J
  1346.          IF(.NOT.TOTING(I))GO TO 98
  1347.          K=OLDLC2
  1348.          IF(I.EQ.LAMP)K=1
  1349.          CALL DROP(I,K)
  1350.    98 CONTINUE
  1351.       LOC=3
  1352.       OLDLOC=LOC
  1353.       GO TO 2000
  1354. C
  1355. C  HE DIED DURING CLOSING TIME.  NO RESURRECTION.  TALLY UP A DEATH AND
  1356. C
  1357.    95 CALL RSPEAK(131)
  1358.       NUMDIE=NUMDIE+1
  1359.       GO TO 20000
  1360. C
  1361. C  ROUTINES FOR PERFORMING THE VARIOUS ACTION VERBS
  1362. C
  1363. C  STATEMENT NUMBERS IN THIS SECTION ARE 8000 FOR INTRANSITIVE VERBS, 90
  1364. C  TRANSITIVE, PLUS TEN TIMES THE VERB NUMBER.  MANY INTRANSITIVE VERBS
  1365. C  TRANSITIVE CODE, AND SOME VERBS USE CODE FOR OTHER VERBS, AS NOTED BE
  1366. C
  1367. C  RANDOM INTRANSITIVE VERBS COME HERE.  CLEAR OBJ JUST IN CASE (SEE "AT
  1368. C
  1369.  8000 CALL A5TOA1(WD1,WD1X,CODE1('WHAT?    '),.TRUE.,TK,K)
  1370.       WRITE(TTYO,8002)(TK(I),I=1,K)
  1371.  8002 FORMAT(/,' ',20A1)
  1372.       OBJ=0
  1373.       GO TO 2600
  1374. C
  1375. C  CARRY, NO OBJECT GIVEN YET.  OK IF ONLY ONE OBJECT PRESENT.
  1376. C
  1377.  8010 IF(ATLOC(LOC).EQ.0.OR.LINK(ATLOC(LOC)).NE.0)GO TO 8000
  1378.       DO 8012 I=1,5
  1379.          IF(DLOC(I).EQ.LOC.AND.DFLAG.GE.2)GO TO 8000
  1380.  8012 CONTINUE
  1381.       OBJ=ATLOC(LOC)
  1382. C
  1383. C  CARRY AN OBJECT.  SPECIAL CASES FOR BIRD AND CAGE (IF BIRD IN CAGE, C
  1384. C  TAKE ONE WITHOUT THE OTHER.  LIQUIDS ALSO SPECIAL, SINCE THEY DEPEND
  1385. C  STATUS OF BOTTLE.  ALSO VARIOUS SIDE EFFECTS, ETC.
  1386. C
  1387.  9010 IF(TOTING(OBJ))GO TO 2011
  1388.       SPK=25
  1389.       IF(OBJ.EQ.PLANT.AND.PROP(PLANT).LE.0)SPK=115
  1390.       IF(OBJ.EQ.BEAR.AND.PROP(BEAR).EQ.1)SPK=169
  1391.       IF(OBJ.EQ.CHAIN.AND.PROP(BEAR).NE.0)SPK=170
  1392.       IF(FIXED(OBJ).NE.0)GO TO 2011
  1393.       IF(OBJ.NE.WATER.AND.OBJ.NE.OIL)GO TO 9017
  1394.       IF(HERE(BOTTLE).AND.LIQ(0).EQ.OBJ)GO TO 9018
  1395.       OBJ=BOTTLE
  1396.       IF(TOTING(BOTTLE).AND.PROP(BOTTLE).EQ.1)GO TO 9220
  1397.       IF(PROP(BOTTLE).NE.1)SPK=105
  1398.       IF(.NOT.TOTING(BOTTLE))SPK=104
  1399.       GO TO 2011
  1400.  9018 OBJ=BOTTLE
  1401.  9017 IF(HOLDNG.LT.7)GO TO 9016
  1402.       CALL RSPEAK(92)
  1403.       GO TO 2012
  1404.  9016 IF(OBJ.NE.BIRD)GO TO 9014
  1405.       IF(PROP(BIRD).NE.0)GO TO 9014
  1406.       IF(.NOT.TOTING(ROD))GO TO 9013
  1407.       CALL RSPEAK(26)
  1408.       GO TO 2012
  1409.  9013 IF(TOTING(CAGE))GO TO 9015
  1410.       CALL RSPEAK(27)
  1411.       GO TO 2012
  1412.  9015 PROP(BIRD)=1
  1413.  9014 IF((OBJ.EQ.BIRD.OR.OBJ.EQ.CAGE).AND.PROP(BIRD).NE.0)
  1414.      1CALL CARRY(BIRD+CAGE-OBJ,LOC)
  1415.       CALL CARRY(OBJ,LOC)
  1416.       K=LIQ(0)
  1417.       IF(OBJ.EQ.BOTTLE.AND.K.NE.0)PLACE(K)=-1
  1418.       GO TO 2009
  1419. C
  1420. C  DISCARD OBJECT.  "THROW" ALSO COMES HERE FOR MOST OBJECTS.  SPECIAL C
  1421. C  BIRD (MIGHT ATTACK SNAKE OR DRAGON) AND CAGE (MIGHT CONTAIN BIRD) AND
  1422. C  DROP COINS AT VENDING MACHINE FOR EXTRA BATTERIES.
  1423. C
  1424.  9020 IF(TOTING(ROD2).AND.OBJ.EQ.ROD.AND..NOT.TOTING(ROD))OBJ=ROD2
  1425.       IF(.NOT.TOTING(OBJ))GO TO 2011
  1426.       IF(OBJ.NE.BIRD.OR..NOT.HERE(SNAKE))GO TO 9024
  1427.       CALL RSPEAK(30)
  1428.       IF(CLOSED)GO TO 19000
  1429.       CALL MOVE(SNAKE,0)
  1430. C  SET PROP FOR USE BY TRAVEL OPTIONS
  1431.       PROP(SNAKE)=1
  1432.  9021 K=LIQ(0)
  1433.       IF(K.EQ.OBJ)OBJ=BOTTLE
  1434.       IF(OBJ.EQ.BOTTLE.AND.K.NE.0)PLACE(K)=0
  1435.       IF(OBJ.EQ.CAGE.AND.PROP(BIRD).NE.0)CALL DROP(BIRD,LOC)
  1436.       IF(OBJ.EQ.BIRD)PROP(BIRD)=0
  1437.       CALL DROP(OBJ,LOC)
  1438.       GO TO 2012
  1439. C
  1440.  9024 IF(OBJ.NE.COINS.OR..NOT.HERE(VEND))GO TO 9025
  1441.       CALL MOVE(COINS,0)
  1442.       CALL DROP(BATTER,LOC)
  1443.       CALL PSPEAK(BATTER,0)
  1444.       GO TO 2012
  1445. C
  1446.  9025 IF(OBJ.NE.BIRD.OR..NOT.AT(DRAGON).OR.PROP(DRAGON).NE.0)GO TO 9026
  1447.       CALL RSPEAK(154)
  1448.       CALL MOVE(BIRD,0)
  1449.       PROP(BIRD)=0
  1450.       IF(PLACE(SNAKE).EQ.PLAC(SNAKE))TALLY2=TALLY2+1
  1451.       GO TO 2012
  1452. C
  1453.  9026 IF(OBJ.NE.BEAR.OR..NOT.AT(TROLL))GO TO 9027
  1454.       CALL RSPEAK(163)
  1455.       CALL MOVE(TROLL,0)
  1456.       CALL MOVE(TROLL+100,0)
  1457.       CALL MOVE(TROLL2,PLAC(TROLL))
  1458.       CALL MOVE(TROLL2+100,FIXD(TROLL))
  1459.       CALL JUGGLE(CHASM)
  1460.       PROP(TROLL)=2
  1461.       GO TO 9021
  1462. C
  1463.  9027 IF(OBJ.EQ.VASE.AND.LOC.NE.PLAC(PILLOW))GO TO 9028
  1464.       CALL RSPEAK(54)
  1465.       GO TO 9021
  1466. C
  1467.  9028 PROP(VASE)=2
  1468.       IF(AT(PILLOW))PROP(VASE)=0
  1469.       CALL PSPEAK(VASE,PROP(VASE)+1)
  1470.       IF(PROP(VASE).NE.0)FIXED(VASE)=-1
  1471.       GO TO 9021
  1472. C
  1473. C  SAY.  ECHO WD2 (OR WD1 IF NO WD2 (SAY WHAT?, ETC.).)  MAGIC WORDS OVE
  1474. C
  1475.  9030 CALL A5TOA1(WD2,WD2X,CODE1('".       '),.FALSE.,TK,K)
  1476.       IF(WD2.EQ.0)CALL A5TOA1(WD1,WD1X,CODE1('".       '),.FALSE.,TK,K)
  1477.       IF(WD2.NE.0)WD1=WD2
  1478.       I=VOCAB(WD1,-1)
  1479.       IF(I.EQ.62.OR.I.EQ.65.OR.I.EQ.71.OR.I.EQ.2025)GO TO 9035
  1480.       WRITE(TTYO,9032)(TK(I),I=1,K)
  1481.  9032 FORMAT(/,' OKAY, "',20A1)
  1482.       GO TO 2012
  1483. C
  1484.  9035 WD2=0
  1485.       OBJ=0
  1486.       GO TO 2630
  1487. C
  1488. C  LOCK, UNLOCK, NO OBJECT GIVEN.  ASSUME VARIOUS THINGS IF PRESENT.
  1489. C
  1490.  8040 SPK=28
  1491.       IF(HERE(CLAM))OBJ=CLAM
  1492.       IF(HERE(OYSTER))OBJ=OYSTER
  1493.       IF(AT(DOOR))OBJ=DOOR
  1494.       IF(AT(GRATE))OBJ=GRATE
  1495.       IF(OBJ.NE.0.AND.HERE(CHAIN))GO TO 8000
  1496.       IF(HERE(CHAIN))OBJ=CHAIN
  1497.       IF(OBJ.EQ.0)GO TO 2011
  1498. C
  1499. C  LOCK, UNLOCK OBJECT.  SPECIAL STUFF FOR OPENING CLAM/OYSTER AND FOR C
  1500. C
  1501.  9040 IF(OBJ.EQ.CLAM.OR.OBJ.EQ.OYSTER)GO TO 9046
  1502.       IF(OBJ.EQ.DOOR)SPK=111
  1503.       IF(OBJ.EQ.DOOR.AND.PROP(DOOR).EQ.1)SPK=54
  1504.       IF(OBJ.EQ.CAGE)SPK=32
  1505.       IF(OBJ.EQ.KEYS)SPK=55
  1506.       IF(OBJ.EQ.GRATE.OR.OBJ.EQ.CHAIN)SPK=31
  1507.       IF(SPK.NE.31.OR..NOT.HERE(KEYS))GO TO 2011
  1508.       IF(OBJ.EQ.CHAIN)GO TO 9048
  1509.       IF(.NOT.CLOSNG)GO TO 9043
  1510.       K=130
  1511.       IF(.NOT.PANIC)CLOCK2=15
  1512.       PANIC=.TRUE.
  1513.       GO TO 2010
  1514. C
  1515.  9043 K=34+PROP(GRATE)
  1516.       PROP(GRATE)=1
  1517.       IF(VERB.EQ.LOCK)PROP(GRATE)=0
  1518.       K=K+2*PROP(GRATE)
  1519.       GO TO 2010
  1520. C
  1521. C  CLAM/OYSTER.
  1522.  9046 K=0
  1523.       IF(OBJ.EQ.OYSTER)K=1
  1524.       SPK=124+K
  1525.       IF(TOTING(OBJ))SPK=120+K
  1526.       IF(.NOT.TOTING(TRIDNT))SPK=122+K
  1527.       IF(VERB.EQ.LOCK)SPK=61
  1528.       IF(SPK.NE.124)GO TO 2011
  1529.       CALL MOVE(CLAM,0)
  1530.       CALL DROP(OYSTER,LOC)
  1531.       CALL DROP(PEARL,105)
  1532.       GO TO 2011
  1533. C
  1534. C  CHAIN.
  1535.  9048 IF(VERB.EQ.LOCK)GO TO 9049
  1536.       SPK=171
  1537.       IF(PROP(BEAR).EQ.0)SPK=41
  1538.       IF(PROP(CHAIN).EQ.0)SPK=37
  1539.       IF(SPK.NE.171)GO TO 2011
  1540.       PROP(CHAIN)=0
  1541.       FIXED(CHAIN)=0
  1542.       IF(PROP(BEAR).NE.3)PROP(BEAR)=2
  1543.       FIXED(BEAR)=2-PROP(BEAR)
  1544.       GO TO 2011
  1545. C
  1546.  9049 SPK=172
  1547.       IF(PROP(CHAIN).NE.0)SPK=34
  1548.       IF(LOC.NE.PLAC(CHAIN))SPK=173
  1549.       IF(SPK.NE.172)GO TO 2011
  1550.       PROP(CHAIN)=2
  1551.       IF(TOTING(CHAIN))CALL DROP(CHAIN,LOC)
  1552.       FIXED(CHAIN)=-1
  1553.       GO TO 2011
  1554. C
  1555. C  LIGHT LAMP
  1556. C
  1557.  9070 IF(.NOT.HERE(LAMP))GO TO 2011
  1558.       SPK=184
  1559.       IF(LIMIT.LT.0)GO TO 2011
  1560.       PROP(LAMP)=1
  1561.       CALL RSPEAK(39)
  1562.       IF(WZDARK)GO TO 2000
  1563.       GO TO 2012
  1564. C
  1565. C  LAMP OFF
  1566. C
  1567.  9080 IF(.NOT.HERE(LAMP))GO TO 2011
  1568.       PROP(LAMP)=0
  1569.       CALL RSPEAK(40)
  1570.       IF(DARK(0))CALL RSPEAK(16)
  1571.       GO TO 2012
  1572. C
  1573. C  WAVE.  NO EFFECT UNLESS WAVING ROD AT FISSURE.
  1574. C
  1575.  9090 IF((.NOT.TOTING(OBJ)).AND.(OBJ.NE.ROD.OR..NOT.TOTING(ROD2)))
  1576.      1SPK=29
  1577.       IF(OBJ.NE.ROD.OR..NOT.AT(FISSUR).OR..NOT.TOTING(OBJ)
  1578.      1.OR.CLOSNG)GO TO 2011
  1579.       PROP(FISSUR)=1-PROP(FISSUR)
  1580.       CALL PSPEAK(FISSUR,2-PROP(FISSUR))
  1581.       GO TO 2012
  1582. C
  1583. C  ATTACK.  ASSUME TARGET IF UNAMBIGUOUS.  "THROW" ALSO LINKS HERE.  ATT
  1584. C  OBJECTS FALL INTO TWO CATEGORIES: ENEMIES (SNAKE, DWARF, ETC.)  AND O
  1585. C  (BIRD, CLAM).  AMBIGUOUS IF TWO ENEMIES, OR IF NO ENEMIES BUT TWO OTH
  1586. C
  1587.  9120 DO 9121 I=1,5
  1588.          IF(DLOC(I).EQ.LOC.AND.DFLAG.GE.2)GO TO 9122
  1589.  9121 CONTINUE
  1590.       I=0
  1591.  9122 IF(OBJ.NE.0)GO TO 9124
  1592.       IF(I.NE.0)OBJ=DWARF
  1593.       IF(HERE(SNAKE))OBJ=OBJ*100+SNAKE
  1594.       IF(AT(DRAGON).AND.PROP(DRAGON).EQ.0)OBJ=OBJ*100+DRAGON
  1595.       IF(AT(TROLL))OBJ=OBJ*100+TROLL
  1596.       IF(HERE(BEAR).AND.PROP(BEAR).EQ.0)OBJ=OBJ*100+BEAR
  1597.       IF(OBJ.GT.100)GO TO 8000
  1598.       IF(OBJ.NE.0)GO TO 9124
  1599. C  CAN'T ATTACK BIRD BY THROWING AXE.
  1600.       IF(HERE(BIRD).AND.VERB.NE.THROW)OBJ=BIRD
  1601. C  CLAM AND OYSTER BOTH TREATED AS CLAM FOR INTRANSITIVE CASE; NO HARM D
  1602.       IF(HERE(CLAM).OR.HERE(OYSTER))OBJ=100*OBJ+CLAM
  1603.       IF(OBJ.GT.100)GO TO 8000
  1604.  9124 IF(OBJ.NE.BIRD)GO TO 9125
  1605.       SPK=137
  1606.       IF(CLOSED)GO TO 2011
  1607.       CALL MOVE(BIRD,0)
  1608.       PROP(BIRD)=0
  1609.       IF(PLACE(SNAKE).EQ.PLAC(SNAKE))TALLY2=TALLY2+1
  1610.       SPK=45
  1611.  9125 IF(OBJ.EQ.0)SPK=44
  1612.       IF(OBJ.EQ.CLAM.OR.OBJ.EQ.OYSTER)SPK=150
  1613.       IF(OBJ.EQ.SNAKE)SPK=46
  1614.       IF(OBJ.EQ.DWARF)SPK=49
  1615.       IF(OBJ.EQ.DWARF.AND.CLOSED)GO TO 19000
  1616.       IF(OBJ.EQ.DRAGON)SPK=167
  1617.       IF(OBJ.EQ.TROLL)SPK=157
  1618.       IF(OBJ.EQ.BEAR)SPK=165+(PROP(BEAR)+1)/2
  1619.       IF(OBJ.NE.DRAGON.OR.PROP(DRAGON).NE.0)GO TO 2011
  1620. C  FUN STUFF FOR DRAGON.  IF HE INSISTS ON ATTACKING IT, WIN!  SET PROP
  1621. C  MOVE DRAGON TO CENTRAL LOC (STILL FIXED), MOVE RUG THERE (NOT FIXED),
  1622. C  MOVE HIM THERE, TOO.  THEN DO A NULL MOTION TO GET NEW DESCRIPTION.
  1623.       CALL RSPEAK(49)
  1624.       VERB=0
  1625.       OBJ=0
  1626.       CALL GETIN(WD1,WD1X,WD2,WD2X,.FALSE.)
  1627.       IF(WD1.NE.CODE1('Y        ').AND.WD1.NE.CODE1('YES      '))
  1628.      *GO TO 2608
  1629.       CALL PSPEAK(DRAGON,1)
  1630.       PROP(DRAGON)=2
  1631.       PROP(RUG)=0
  1632.       K=(PLAC(DRAGON)+FIXD(DRAGON))/2
  1633.       CALL MOVE(DRAGON+100,-1)
  1634.       CALL MOVE(RUG+100,0)
  1635.       CALL MOVE(DRAGON,K)
  1636.       CALL MOVE(RUG,K)
  1637.       DO 9126 OBJ=1,100
  1638.          IF(PLACE(OBJ).EQ.PLAC(DRAGON).OR.PLACE(OBJ).EQ.FIXD(DRAGON))
  1639.      1   CALL MOVE(OBJ,K)
  1640.  9126 CONTINUE
  1641.       LOC=K
  1642.       K=NULL
  1643.       GO TO 8
  1644. C
  1645. C  POUR.  IF NO OBJECT, OR OBJECT IS BOTTLE, ASSUME CONTENTS OF BOTTLE.
  1646. C  SPECIAL TESTS FOR POURING WATER OR OIL ON PLANT OR RUSTY DOOR.
  1647. C
  1648.  9130 IF(OBJ.EQ.BOTTLE.OR.OBJ.EQ.0)OBJ=LIQ(0)
  1649.       IF(OBJ.EQ.0)GO TO 8000
  1650.       IF(.NOT.TOTING(OBJ))GO TO 2011
  1651.       SPK=78
  1652.       IF(OBJ.NE.OIL.AND.OBJ.NE.WATER)GO TO 2011
  1653.       PROP(BOTTLE)=1
  1654.       PLACE(OBJ)=0
  1655.       SPK=77
  1656.       IF(.NOT.(AT(PLANT).OR.AT(DOOR)))GO TO 2011
  1657. C
  1658.       IF(AT(DOOR))GO TO 9132
  1659.       SPK=112
  1660.       IF(OBJ.NE.WATER)GO TO 2011
  1661.       CALL PSPEAK(PLANT,PROP(PLANT)+1)
  1662.       PROP(PLANT)=MOD(PROP(PLANT)+2,6)
  1663.       PROP(PLANT2)=PROP(PLANT)/2
  1664.       K=NULL
  1665.       GO TO 8
  1666. C
  1667.  9132 PROP(DOOR)=0
  1668.       IF(OBJ.EQ.OIL)PROP(DOOR)=1
  1669.       SPK=113+PROP(DOOR)
  1670.       GO TO 2011
  1671. C
  1672. C  EAT.  INTRANSITIVE: ASSUME FOOD IF PRESENT, ELSE ASK WHAT.  TRANSITIV
  1673. C  OK, SOME THINGS LOSE APPETITE, REST ARE RIDICULOUS.
  1674. C
  1675.  8140 IF(.NOT.HERE(FOOD))GO TO 8000
  1676.  8142 CALL MOVE(FOOD,0)
  1677.       SPK=72
  1678.       GO TO 2011
  1679. C
  1680.  9140 IF(OBJ.EQ.FOOD)GO TO 8142
  1681.       IF(OBJ.EQ.BIRD.OR.OBJ.EQ.SNAKE.OR.OBJ.EQ.CLAM.OR.OBJ.EQ.OYSTER
  1682.      1.OR.OBJ.EQ.DWARF.OR.OBJ.EQ.DRAGON.OR.OBJ.EQ.TROLL
  1683.      2.OR.OBJ.EQ.BEAR)SPK=71
  1684.       GO TO 2011
  1685. C
  1686. C  DRINK.  IF NO OBJECT, ASSUME WATER AND LOOK FOR IT HERE.  IF WATER IS
  1687. C  THE BOTTLE, DRINK THAT, ELSE MUST BE AT A WATER LOC, SO DRINK STREAM.
  1688. C
  1689.  9150 IF(OBJ.EQ.0.AND.LIQLOC(LOC).NE.WATER.AND.(LIQ(0).NE.WATER
  1690.      1.OR..NOT.HERE(BOTTLE)))GO TO 8000
  1691.       IF(OBJ.NE.0.AND.OBJ.NE.WATER)SPK=110
  1692.       IF(SPK.EQ.110.OR.LIQ(0).NE.WATER.OR..NOT.HERE(BOTTLE))GO TO 2011
  1693.       PROP(BOTTLE)=1
  1694.       PLACE(WATER)=0
  1695.       SPK=74
  1696.       GO TO 2011
  1697. C
  1698. C  RUB.  YIELDS VARIOUS SNIDE REMARKS.
  1699. C
  1700.  9160 IF(OBJ.NE.LAMP)SPK=76
  1701.       GO TO 2011
  1702. C
  1703. C  THROW.  SAME AS DISCARD UNLESS AXE.  THEN SAME AS ATTACK EXCEPT IGNOR
  1704. C  AND IF DWARF IS PRESENT THEN ONE MIGHT BE KILLED.  (ONLY WAY TO DO SO
  1705. C  AXE ALSO SPECIAL FOR DRAGON, BEAR, AND TROLL.  TREASURES SPECIAL FOR
  1706. C
  1707.  9170 IF(TOTING(ROD2).AND.OBJ.EQ.ROD.AND..NOT.TOTING(ROD))OBJ=ROD2
  1708.       IF(.NOT.TOTING(OBJ))GO TO 2011
  1709.       IF(OBJ.GE.50.AND.OBJ.LE.MAXTRS.AND.AT(TROLL))GO TO 9178
  1710.       IF(OBJ.EQ.FOOD.AND.HERE(BEAR))GO TO 9177
  1711.       IF(OBJ.NE.AXE)GO TO 9020
  1712.       DO 9171 I=1,5
  1713. C  NEEDN'T CHECK DFLAG IF AXE IS HERE.
  1714.          IF(DLOC(I).EQ.LOC)GO TO 9172
  1715.  9171 CONTINUE
  1716.       SPK=152
  1717.       IF(AT(DRAGON).AND.PROP(DRAGON).EQ.0)GO TO 9175
  1718.       SPK=158
  1719.       IF(AT(TROLL))GO TO 9175
  1720.       IF(HERE(BEAR).AND.PROP(BEAR).EQ.0)GO TO 9176
  1721.       OBJ=0
  1722.       GO TO 9120
  1723. C
  1724.  9172 SPK=48
  1725. C  IF SAVED NOT = -1, HE BYPASSED THE "START" CALL.
  1726.       IF(RAN(3).EQ.0.OR.SAVED.NE.-1)GO TO 9175
  1727.       DSEEN(I)=.FALSE.
  1728.       DLOC(I)=0
  1729.       SPK=47
  1730.       DKILL=DKILL+1
  1731.       IF(DKILL.EQ.1)SPK=149
  1732.  9175 CALL RSPEAK(SPK)
  1733.       CALL DROP(AXE,LOC)
  1734.       K=NULL
  1735.       GO TO 8
  1736. C
  1737. C  THIS'LL TEACH HIM TO THROW THE AXE AT THE BEAR!
  1738.  9176 SPK=164
  1739.       CALL DROP(AXE,LOC)
  1740.       FIXED(AXE)=-1
  1741.       PROP(AXE)=1
  1742.       CALL JUGGLE(BEAR)
  1743.       GO TO 2011
  1744. C
  1745. C  BUT THROWING FOOD IS ANOTHER STORY.
  1746.  9177 OBJ=BEAR
  1747.       GO TO 9210
  1748. C
  1749.  9178 SPK=159
  1750. C  SNARF A TREASURE FOR THE TROLL.
  1751.       CALL DROP(OBJ,0)
  1752.       CALL MOVE(TROLL,0)
  1753.       CALL MOVE(TROLL+100,0)
  1754.       CALL DROP(TROLL2,PLAC(TROLL))
  1755.       CALL DROP(TROLL2+100,FIXD(TROLL))
  1756.       CALL JUGGLE(CHASM)
  1757.       GO TO 2011
  1758. C
  1759. C  QUIT.  INTRANSITIVE ONLY.  VERIFY INTENT AND EXIT IF THAT'S WHAT HE W
  1760. C
  1761.  8180 GAVEUP=YESX(22,54,54,1)
  1762.  8185 IF(GAVEUP)GO TO 20000
  1763.       GO TO 2012
  1764. C
  1765. C  FIND.  MIGHT BE CARRYING IT, OR IT MIGHT BE HERE.  ELSE GIVE CAVEAT.
  1766. C
  1767.  9190 IF(AT(OBJ).OR.(LIQ(0).EQ.OBJ.AND.AT(BOTTLE))
  1768.      1.OR.K.EQ.LIQLOC(LOC))SPK=94
  1769.       DO 9192 I=1,5
  1770.  9192 IF(DLOC(I).EQ.LOC.AND.DFLAG.GE.2.AND.OBJ.EQ.DWARF)SPK=94
  1771.       IF(CLOSED)SPK=138
  1772.       IF(TOTING(OBJ))SPK=24
  1773.       GO TO 2011
  1774. C
  1775. C  INVENTORY.  IF OBJECT, TREAT SAME AS FIND.  ELSE REPORT ON CURRENT BU
  1776. C
  1777.  8200 SPK=98
  1778.       DO 8201 I=1,100
  1779.          IF(I.EQ.BEAR.OR..NOT.TOTING(I))GO TO 8201
  1780.          IF(SPK.EQ.98)CALL RSPEAK(99)
  1781.          BLKLIN=.FALSE.
  1782.          CALL PSPEAK(I,-1)
  1783.          BLKLIN=.TRUE.
  1784.          SPK=0
  1785.  8201 CONTINUE
  1786.       IF(TOTING(BEAR))SPK=141
  1787.       GO TO 2011
  1788. C
  1789. C  FEED.  IF BIRD, NO SEED.  SNAKE, DRAGON, TROLL: QUIP.  IF DWARF, MAKE
  1790. C  MAD.  BEAR, SPECIAL.
  1791. C
  1792.  9210 IF(OBJ.NE.BIRD)GO TO 9212
  1793.       SPK=100
  1794.       GO TO 2011
  1795. C
  1796.  9212 IF(OBJ.NE.SNAKE.AND.OBJ.NE.DRAGON.AND.OBJ.NE.TROLL)GO TO 9213
  1797.       SPK=102
  1798.       IF(OBJ.EQ.DRAGON.AND.PROP(DRAGON).NE.0)SPK=110
  1799.       IF(OBJ.EQ.TROLL)SPK=182
  1800.       IF(OBJ.NE.SNAKE.OR.CLOSED.OR..NOT.HERE(BIRD))GO TO 2011
  1801.       SPK=101
  1802.       CALL MOVE(BIRD,0)
  1803.       PROP(BIRD)=0
  1804.       TALLY2=TALLY2+1
  1805.       GO TO 2011
  1806. C
  1807.  9213 IF(OBJ.NE.DWARF)GO TO 9214
  1808.       IF(.NOT.HERE(FOOD))GO TO 2011
  1809.       SPK=103
  1810.       DFLAG=DFLAG+1
  1811.       GO TO 2011
  1812. C
  1813.  9214 IF(OBJ.NE.BEAR)GO TO 9215
  1814.       IF(PROP(BEAR).EQ.0)SPK=102
  1815.       IF(PROP(BEAR).EQ.3)SPK=110
  1816.       IF(.NOT.HERE(FOOD))GO TO 2011
  1817.       CALL MOVE(FOOD,0)
  1818.       PROP(BEAR)=1
  1819.       FIXED(AXE)=0
  1820.       PROP(AXE)=0
  1821.       SPK=168
  1822.       GO TO 2011
  1823. C
  1824.  9215 SPK=14
  1825.       GO TO 2011
  1826. C
  1827. C  FILL.  BOTTLE MUST BE EMPTY, AND SOME LIQUID AVAILABLE.  (VASE IS NAS
  1828. C
  1829.  9220 IF(OBJ.EQ.VASE)GO TO 9222
  1830.       IF(OBJ.NE.0.AND.OBJ.NE.BOTTLE)GO TO 2011
  1831.       IF(OBJ.EQ.0.AND..NOT.HERE(BOTTLE))GO TO 8000
  1832.       SPK=107
  1833.       IF(LIQLOC(LOC).EQ.0)SPK=106
  1834.       IF(LIQ(0).NE.0)SPK=105
  1835.       IF(SPK.NE.107)GO TO 2011
  1836.       PROP(BOTTLE)=MOD(COND(LOC),4)/2*2
  1837.       K=LIQ(0)
  1838.       IF(TOTING(BOTTLE))PLACE(K)=-1
  1839.       IF(K.EQ.OIL)SPK=108
  1840.       GO TO 2011
  1841. C
  1842.  9222 SPK=29
  1843.       IF(LIQLOC(LOC).EQ.0)SPK=144
  1844.       IF(LIQLOC(LOC).EQ.0.OR..NOT.TOTING(VASE))GO TO 2011
  1845.       CALL RSPEAK(145)
  1846.       PROP(VASE)=2
  1847.       FIXED(VASE)=-1
  1848.       GO TO 9024
  1849. C
  1850. C  BLAST.  NO EFFECT UNLESS YOU'VE GOT DYNAMITE, WHICH IS A NEAT TRICK!
  1851. C
  1852.  9230 IF(PROP(ROD2).LT.0.OR..NOT.CLOSED)GO TO 2011
  1853.       BONUS=133
  1854.       IF(LOC.EQ.115)BONUS=134
  1855.       IF(HERE(ROD2))BONUS=135
  1856.       CALL RSPEAK(BONUS)
  1857.       GO TO 20000
  1858. C
  1859. C  SCORE.  GO TO SCORING SECTION, WHICH WILL RETURN TO 8241 IF SCORNG IS
  1860. C
  1861.  8240 SCORNG=.TRUE.
  1862.       GO TO 20000
  1863. C
  1864.  8241 SCORNG=.FALSE.
  1865.       WRITE(TTYO,8243)SCORE,MXSCOR
  1866.  8243 FORMAT(/,' IF YOU WERE TO QUIT NOW, YOU WOULD SCORE',I4
  1867.      1,' OUT OF A POSSIBLE',I4,'.')
  1868. C     GAVEUP=YESX(143,54,54,1)
  1869.       GAVEUP=.FALSE.
  1870.       GO TO 8185
  1871. C
  1872. C  FEE FIE FOE FOO (AND FUM).  ADVANCE TO NEXT STATE IF GIVEN IN PROPER
  1873. C  LOOK UP WD1 IN SECTION 3 OF VOCAB TO DETERMINE WHICH WORD WE'VE GOT.
  1874. C  WORD ZIPS THE EGGS BACK TO THE GIANT ROOM (UNLESS ALREADY THERE).
  1875. C
  1876.  8250 K=VOCAB(WD1,3)
  1877.       SPK=42
  1878.       IF(FOOBAR.EQ.1-K)GO TO 8252
  1879.       IF(FOOBAR.NE.0)SPK=151
  1880.       GO TO 2011
  1881. C
  1882.  8252 FOOBAR=K
  1883.       IF(K.NE.4)GO TO 2009
  1884.       FOOBAR=0
  1885.       IF(PLACE(EGGS).EQ.PLAC(EGGS)
  1886.      1.OR.(TOTING(EGGS).AND.LOC.EQ.PLAC(EGGS)))GO TO 2011
  1887. C  BRING BACK TROLL IF WE STEAL THE EGGS BACK FROM HIM BEFORE CROSSING.
  1888.       IF(PLACE(EGGS).EQ.0.AND.PLACE(TROLL).EQ.0.AND.PROP(TROLL).EQ.0)
  1889.      1PROP(TROLL)=1
  1890.       K=2
  1891.       IF(HERE(EGGS))K=1
  1892.       IF(LOC.EQ.PLAC(EGGS))K=0
  1893.       CALL MOVE(EGGS,PLAC(EGGS))
  1894.       CALL PSPEAK(EGGS,K)
  1895.       GO TO 2012
  1896. C
  1897. C  BRIEF.  INTRANSITIVE ONLY.  SUPPRESS LONG DESCRIPTIONS AFTER FIRST TI
  1898. C
  1899.  8260 SPK=156
  1900.       ABBNUM=10000
  1901.       DETAIL=3
  1902.       GO TO 2011
  1903. C
  1904. C  READ.  MAGAZINES IN DWARVISH, MESSAGE WE'VE SEEN, AND . . . OYSTER?
  1905. C
  1906.  8270 IF(HERE(MAGZIN))OBJ=MAGZIN
  1907.       IF(HERE(TABLET))OBJ=OBJ*100+TABLET
  1908.       IF(HERE(MESSAG))OBJ=OBJ*100+MESSAG
  1909.       IF(CLOSED.AND.TOTING(OYSTER))OBJ=OYSTER
  1910.       IF(OBJ.GT.100.OR.OBJ.EQ.0.OR.DARK(0))GO TO 8000
  1911. C
  1912.  9270 IF(DARK(0))GO TO 5190
  1913.       IF(OBJ.EQ.MAGZIN)SPK=190
  1914.       IF(OBJ.EQ.TABLET)SPK=196
  1915.       IF(OBJ.EQ.MESSAG)SPK=191
  1916.       IF(OBJ.EQ.OYSTER.AND.HINTED(2).AND.TOTING(OYSTER))SPK=194
  1917.       IF(OBJ.NE.OYSTER.OR.HINTED(2).OR..NOT.TOTING(OYSTER)
  1918.      1.OR..NOT.CLOSED)GO TO 2011
  1919.       HINTED(2)=YESX(192,193,54,1)
  1920.       GO TO 2012
  1921. C
  1922. C  BREAK.  ONLY WORKS FOR MIRROR IN REPOSITORY AND, OF COURSE, THE VASE.
  1923. C
  1924.  9280 IF(OBJ.EQ.MIRROR)SPK=148
  1925.       IF(OBJ.EQ.VASE.AND.PROP(VASE).EQ.0)GO TO 9282
  1926.       IF(OBJ.NE.MIRROR.OR..NOT.CLOSED)GO TO 2011
  1927.       CALL RSPEAK(197)
  1928.       GO TO 19000
  1929. C
  1930.  9282 SPK=198
  1931.       IF(TOTING(VASE))CALL DROP(VASE,LOC)
  1932.       PROP(VASE)=2
  1933.       FIXED(VASE)=-1
  1934.       GO TO 2011
  1935. C
  1936. C  WAKE.  ONLY USE IS TO DISTURB THE DWARVES.
  1937. C
  1938.  9290 IF(OBJ.NE.DWARF.OR..NOT.CLOSED)GO TO 2011
  1939.       CALL RSPEAK(199)
  1940.       GO TO 19000
  1941. C
  1942. C  SUSPEND.  OFFER TO EXIT LEAVING THINGS RESTARTABLE, BUT REQUIRING A D
  1943. C  BEFORE RESTARTING (SO CAN'T SAVE THE WORLD BEFORE TRYING SOMETHING RI
  1944. C  UPON RESTARTING, SETUP=-1 CAUSES RETURN TO 8305 TO PICK UP AGAIN.
  1945. C
  1946.  8300 SPK=201
  1947.       IF(DEMO)GO TO 2011
  1948.       IF (WD2 .EQ. CODE1('         ')) THEN
  1949.          WRITE (TTYO,8303)
  1950. 8303     FORMAT (/' YOU MUST SPECIFY A FILE NAME WITH YOUR COMMAND')
  1951.          GO TO 2012
  1952.       END IF
  1953.       WRITE(TTYO,8302)LATNCY
  1954.  8302 FORMAT(/,' I CAN SUSPEND YOUR ADVENTURE FOR YOU SO THAT YOU CAN',
  1955.      1' RESUME LATER, BUT',/,' YOU WILL HAVE TO WAIT AT LEAST ',
  1956.      2I3,' MINUTES BEFORE CONTINUING.')
  1957.       IF(.NOT.YESX(200,54,54,1))GO TO 2012
  1958.       CALL DATIME(SAVED,SAVET)
  1959.       SETUP=-1
  1960.       R=0
  1961.       CALL DCODE1(WD2,FNAME(1))
  1962.       CALL DCODE1(WD2X,FNAME(6))
  1963.       CALL SVCOMN(.FALSE.,FNAME,CMADRS,CMSZES)
  1964.       STOP
  1965. C
  1966.  8305 YEA=START(0)
  1967.       SETUP=3
  1968.       K=NULL
  1969.       GO TO 8
  1970. C
  1971. C
  1972. C  HOURS.  REPORT CURRENT NON-PRIME-TIME HOURS.
  1973. C
  1974.  8310 CALL MSPEAK(6)
  1975.       CALL HOURS
  1976.       GO TO 2012
  1977. C
  1978. C
  1979. C  RESTORE.  ATTEMPT TO RESTORE THE GAME WHOSE NAME IS SUPPLIED BY THE
  1980. C  USER.  IF THE RESTORE DOES NOT WORK, THE USER WILL BE LEFT IN A FRESH
  1981. C  GAME.
  1982. C
  1983.  8400 CALL DCODE1(WD2,FNAME(1))
  1984.       CALL DCODE1(WD2X,FNAME(6))
  1985.       CALL LDCOMN(.FALSE.,FNAME,CMADRS,CMSZES)
  1986.       GO TO 8500
  1987. C
  1988. C  HINTS
  1989. C
  1990. C  COME HERE IF HE'S BEEN LONG ENOUGH AT REQUIRED LOC(S) FOR SOME UNUSED
  1991. C  HINT NUMBER IS IN VARIABLE "HINT".  BRANCH TO QUICK TEST FOR ADDITION
  1992. C  CONDITIONS, THEN COME BACK TO DO NEAT STUFF.  GOTO 40010 IF CONDITION
  1993. C  MET AND WE WANT TO OFFER THE HINT.  GOTO 40020 TO CLEAR HINTLC BACK T
  1994. C  40030 TO TAKE NO ACTION YET.
  1995. C
  1996. 40000 HINTM3=HINT-3
  1997.       IF((HINTM3.LT.1).OR.(HINTM3.GT.6)) CALL BUG(27)
  1998.       GO TO (40400,40500,40600,40700,40800,40900),HINTM3
  1999. C           CAVE  BIRD  SNAKE MAZE  DARK  WITT
  2000. C
  2001. 40010 HINTLC(HINT)=0
  2002.       IF(.NOT.YESX(HINTS(HINT,3),0,54,1))GO TO 2602
  2003.       WRITE(TTYO,40012)HINTS(HINT,2)
  2004. 40012 FORMAT(/,' I AM PREPARED TO GIVE YOU A HINT, BUT IT WILL COST YOU'
  2005.      1,I2,' POINTS.')
  2006.       HINTED(HINT)=YESX(175,HINTS(HINT,4),54,1)
  2007.       IF(HINTED(HINT).AND.LIMIT.GT.30)LIMIT=LIMIT+30*HINTS(HINT,2)
  2008. 40020 HINTLC(HINT)=0
  2009. 40030 GO TO 2602
  2010. C
  2011. C  NOW FOR THE QUICK TESTS.  SEE DATABASE DESCRIPTION FOR ONE-LINE NOTES
  2012. C
  2013. 40400 IF(PROP(GRATE).EQ.0.AND..NOT.HERE(KEYS))GO TO 40010
  2014.       GO TO 40020
  2015. C
  2016. 40500 IF(HERE(BIRD).AND.TOTING(ROD).AND.OBJ.EQ.BIRD)GO TO 40010
  2017.       GO TO 40030
  2018. C
  2019. 40600 IF(HERE(SNAKE).AND..NOT.HERE(BIRD))GO TO 40010
  2020.       GO TO 40020
  2021. C
  2022. 40700 IF(ATLOC(LOC).EQ.0.AND.ATLOC(OLDLOC).EQ.0
  2023.      1.AND.ATLOC(OLDLC2).EQ.0.AND.HOLDNG.GT.1)GO TO 40010
  2024.       GO TO 40020
  2025. C
  2026. 40800 IF(PROP(EMRALD).NE.-1.AND.PROP(PYRAM).EQ.-1)GO TO 40010
  2027.       GO TO 40020
  2028. C
  2029. 40900 GO TO 40010
  2030. C
  2031. C  CAVE CLOSING AND SCORING
  2032. C
  2033. C
  2034. C  THESE SECTIONS HANDLE THE CLOSING OF THE CAVE.  THE CAVE CLOSES "CLOC
  2035. C  TURNS AFTER THE LAST TREASURE HAS BEEN LOCATED (INCLUDING THE PIRATE'
  2036. C  CHEST, WHICH MAY OF COURSE NEVER SHOW UP).  NOTE THAT THE TREASURES N
  2037. C  HAVE BEEN TAKEN YET, JUST LOCATED.  HENCE CLOCK1 MUST BE LARGE ENOUGH
  2038. C  OUT OF THE CAVE (IT ONLY TICKS WHILE INSIDE THE CAVE).  WHEN IT HITS
  2039. C  WE BRANCH TO 10000 TO START CLOSING THE CAVE, AND THEN SIT BACK AND W
  2040. C  HIM TO TRY TO GET OUT.  IF HE DOESN'T WITHIN CLOCK2 TURNS, WE CLOSE T
  2041. C  CAVE; IF HE DOES TRY, WE ASSUME HE PANICS, AND GIVE HIM A FEW ADDITIO
  2042. C  TURNS TO GET FRANTIC BEFORE WE CLOSE.  WHEN CLOCK2 HITS ZERO, WE BRAN
  2043. C  11000 TO TRANSPORT HIM INTO THE FINAL PUZZLE.  NOTE THAT THE PUZZLE D
  2044. C  UPON ALL SORTS OF RANDOM THINGS.  FOR INSTANCE, THERE MUST BE NO WATE
  2045. C  OIL, SINCE THERE ARE BEANSTALKS WHICH WE DON'T WANT TO BE ABLE TO WAT
  2046. C  SINCE THE CODE CAN'T HANDLE IT.  ALSO, WE CAN HAVE NO KEYS, SINCE THE
  2047. C  GRATE (HAVING MOVED THE FIXED OBJECT!) THERE SEPARATING HIM FROM ALL
  2048. C  TREASURES.  MOST OF THESE PROBLEMS ARISE FROM THE USE OF NEGATIVE PRO
  2049. C  NUMBERS TO SUPPRESS THE OBJECT DESCRIPTIONS UNTIL HE'S ACTUALLY MOVED
  2050. C  OBJECTS.
  2051. C
  2052. C  WHEN THE FIRST WARNING COMES, WE LOCK THE GRATE, DESTROY THE BRIDGE,
  2053. C  ALL THE DWARVES (AND THE PIRATE), REMOVE THE TROLL AND BEAR (UNLESS D
  2054. C  AND SET "CLOSNG" TO TRUE.  LEAVE THE DRAGON; TOO MUCH TROUBLE TO MOVE
  2055. C  FROM NOW UNTIL CLOCK2 RUNS OUT, HE CANNOT UNLOCK THE GRATE, MOVE TO A
  2056. C  LOCATION OUTSIDE THE CAVE (LOC<9), OR CREATE THE BRIDGE.  NOR CAN HE
  2057. C  RESURRECTED IF HE DIES.  NOTE THAT THE SNAKE IS ALREADY GONE, SINCE H
  2058. C  TO THE TREASURE ACCESSIBLE ONLY VIA THE HALL OF THE MT. KING.  ALSO,
  2059. C  BEEN IN GIANT ROOM (TO GET EGGS), SO WE CAN REFER TO IT.  ALSO ALSO,
  2060. C  GOTTEN THE PEARL, SO WE KNOW THE BIVALVE IS AN OYSTER.  *AND*, THE DW
  2061. C  MUST HAVE BEEN ACTIVATED, SINCE WE'VE FOUND CHEST.
  2062. C
  2063. 10000 PROP(GRATE)=0
  2064.       PROP(FISSUR)=0
  2065.       DO 10010 I=1,6
  2066.          DSEEN(I)=.FALSE.
  2067. 10010 DLOC(I)=0
  2068.       CALL MOVE(TROLL,0)
  2069.       CALL MOVE(TROLL+100,0)
  2070.       CALL MOVE(TROLL2,PLAC(TROLL))
  2071.       CALL MOVE(TROLL2+100,FIXD(TROLL))
  2072.       CALL JUGGLE(CHASM)
  2073.       IF(PROP(BEAR).NE.3)CALL MOVE(BEAR,0)
  2074.       PROP(CHAIN)=0
  2075.       FIXED(CHAIN)=0
  2076.       PROP(AXE)=0
  2077.       FIXED(AXE)=0
  2078.       CALL RSPEAK(129)
  2079.       CLOCK1=-1
  2080.       CLOSNG=.TRUE.
  2081.       GO TO 19999
  2082. C
  2083. C  ONCE HE'S PANICKED, AND CLOCK2 HAS RUN OUT, WE COME HERE TO SET UP TH
  2084. C  STORAGE ROOM.  THE ROOM HAS TWO LOCS, HARDWIRED AS 115 (NE) AND 116 (
  2085. C  AT THE NE END, WE PLACE EMPTY BOTTLES, A NURSERY OF PLANTS, A BED OF
  2086. C  OYSTERS, A PILE OF LAMPS, RODS WITH STARS, SLEEPING DWARVES, AND HIM.
  2087. C  THE SW END WE PLACE GRATE OVER TREASURES, SNAKE PIT, COVEY OF CAGED B
  2088. C  MORE RODS, AND PILLOWS.  A MIRROR STRETCHES ACROSS ONE WALL.  MANY OF
  2089. C  OBJECTS COME FROM KNOWN LOCATIONS AND/OR STATES (E.G. THE SNAKE IS KN
  2090. C  HAVE BEEN DESTROYED AND NEEDN'T BE CARRIED AWAY FROM ITS OLD "PLACE")
  2091. C  MAKING THE VARIOUS OBJECTS BE HANDLED DIFFERENTLY.  WE ALSO DROP ALL
  2092. C  OBJECTS HE MIGHT BE CARRYING (LEST HE HAVE SOME WHICH COULD CAUSE TRO
  2093. C  SUCH AS THE KEYS).  WE DESCRIBE THE FLASH OF LIGHT AND TRUNDLE BACK.
  2094. C
  2095. 11000 PROP(BOTTLE)=PUT(BOTTLE,115,1)
  2096.       PROP(PLANT)=PUT(PLANT,115,0)
  2097.       PROP(OYSTER)=PUT(OYSTER,115,0)
  2098.       PROP(LAMP)=PUT(LAMP,115,0)
  2099.       PROP(ROD)=PUT(ROD,115,0)
  2100.       PROP(DWARF)=PUT(DWARF,115,0)
  2101.       LOC=115
  2102.       OLDLOC=115
  2103.       NEWLOC=115
  2104. C
  2105. C  LEAVE THE GRATE WITH NORMAL (NON-NEGATIVE PROPERTY).
  2106. C
  2107.       FOO=PUT(GRATE,116,0)
  2108.       PROP(SNAKE)=PUT(SNAKE,116,1)
  2109.       PROP(BIRD)=PUT(BIRD,116,1)
  2110.       PROP(CAGE)=PUT(CAGE,116,0)
  2111.       PROP(ROD2)=PUT(ROD2,116,0)
  2112.       PROP(PILLOW)=PUT(PILLOW,116,0)
  2113. C
  2114.       PROP(MIRROR)=PUT(MIRROR,115,0)
  2115.       FIXED(MIRROR)=116
  2116. C
  2117.       DO 11010 I=1,100
  2118. 11010 IF(TOTING(I))CALL MOVE(I,0)
  2119. C
  2120.       CALL RSPEAK(132)
  2121.       CLOSED=.TRUE.
  2122.       GO TO 2
  2123. C
  2124. C  ANOTHER WAY WE CAN FORCE AN END TO THINGS IS BY HAVING THE LAMP GIVE
  2125. C  WHEN IT GETS CLOSE, WE COME HERE TO WARN HIM.  WE GO TO 12000 IF THE
  2126. C  AND FRESH BATTERIES ARE HERE, IN WHICH CASE WE REPLACE THE BATTERIES
  2127. C  CONTINUE.  12200 IS FOR OTHER CASES OF LAMP DYING.  12400 IS WHEN IT
  2128. C  OUT, AND 12600 IS IF HE'S WANDERED OUTSIDE AND THE LAMP IS USED UP, I
  2129. C  CASE WE FORCE HIM TO GIVE UP.
  2130. C
  2131. 12000 CALL RSPEAK(188)
  2132.       PROP(BATTER)=1
  2133.       IF(TOTING(BATTER))CALL DROP(BATTER,LOC)
  2134.       LIMIT=LIMIT+2500
  2135.       LMWARN=.FALSE.
  2136.       GO TO 19999
  2137. C
  2138. 12200 IF(LMWARN.OR..NOT.HERE(LAMP))GO TO 19999
  2139.       LMWARN=.TRUE.
  2140.       SPK=187
  2141.       IF(PLACE(BATTER).EQ.0)SPK=183
  2142.       IF(PROP(BATTER).EQ.1)SPK=189
  2143.       CALL RSPEAK(SPK)
  2144.       GO TO 19999
  2145. C
  2146. 12400 LIMIT=-1
  2147.       PROP(LAMP)=0
  2148.       IF(HERE(LAMP))CALL RSPEAK(184)
  2149.       GO TO 19999
  2150. C
  2151. 12600 CALL RSPEAK(185)
  2152.       GAVEUP=.TRUE.
  2153.       GO TO 20000
  2154. C
  2155. C  AND, OF COURSE, DEMO GAMES ARE ENDED BY THE WIZARD.
  2156. C
  2157. 13000 CALL MSPEAK(1)
  2158.       GAVEUP=.TRUE.
  2159.       GO TO 20000
  2160. C
  2161. C  OH DEAR, HE'S DISTURBED THE DWARVES.
  2162. C
  2163. 19000 CALL RSPEAK(136)
  2164. C
  2165. C  EXIT CODE.  WILL EVENTUALLY INCLUDE SCORING.  FOR NOW, HOWEVER, ...
  2166. C
  2167. C  THE PRESENT SCORING ALGORITHM IS AS FOLLOWS:
  2168. C     OBJECTIVE:          POINTS:        PRESENT TOTAL POSSIBLE:
  2169. C  GETTING WELL INTO CAVE   25                    25
  2170. C  EACH TREASURE < CHEST    12                    60
  2171. C  TREASURE CHEST ITSELF    14                    14
  2172. C  EACH TREASURE > CHEST    16                   144
  2173. C  SURVIVING             (MAX0-NUM)*10             30
  2174. C  NOT QUITTING              4                     4
  2175. C  REACHING "CLOSNG"        25                    25
  2176. C  "CLOSED": QUIT/KILLED    10
  2177. C            KLUTZED        25
  2178. C            WRONG WAY      30
  2179. C            SUCCESS        45                    45
  2180. C  CAME TO WITT'S END        1                     1
  2181. C  ROUND OUT THE TOTAL       2                     2
  2182. C                                       TOTAL:   350
  2183. C  (POINTS CAN ALSO BE DEDUCTED FOR USING HINTS.)
  2184. C
  2185. 20000 SCORE=0
  2186.       MXSCOR=0
  2187. C
  2188. C  FIRST TALLY UP THE TREASURES.  MUST BE IN BUILDING AND NOT BROKEN.
  2189. C  GIVE THE POOR GUY 2 POINTS JUST FOR FINDING EACH TREASURE.
  2190. C
  2191.       DO 20010 I=50,MAXTRS
  2192.          IF(PTEXT(I).EQ.0)GO TO 20010
  2193.          K=12
  2194.          IF(I.EQ.CHEST)K=14
  2195.          IF(I.GT.CHEST)K=16
  2196.          IF(PROP(I).GE.0)SCORE=SCORE+2
  2197.          IF(PLACE(I).EQ.3.AND.PROP(I).EQ.0)SCORE=SCORE+K-2
  2198.          MXSCOR=MXSCOR+K
  2199. 20010 CONTINUE
  2200. C
  2201. C  NOW LOOK AT HOW HE FINISHED AND HOW FAR HE GOT.  MAXDIE AND NUMDIE TE
  2202. C  HOW WELL HE SURVIVED.  GAVEUP SAYS WHETHER HE EXITED VIA QUIT.  DFLAG
  2203. C  TELL US IF HE EVER GOT SUITABLY DEEP INTO THE CAVE.  CLOSNG STILL IND
  2204. C  WHETHER HE REACHED THE ENDGAME.  AND IF HE GOT AS FAR AS "CAVE CLOSED
  2205. C  (INDICATED BY "CLOSED"), THEN BONUS IS ZERO FOR MUNDANE EXITS OR 133,
  2206. C  135 IF HE BLEW IT (SO TO SPEAK).
  2207. C
  2208.       SCORE=SCORE+(MAXDIE-NUMDIE)*10
  2209.       MXSCOR=MXSCOR+MAXDIE*10
  2210.       IF(.NOT.(SCORNG.OR.GAVEUP))SCORE=SCORE+4
  2211.       MXSCOR=MXSCOR+4
  2212.       IF(DFLAG.NE.0)SCORE=SCORE+25
  2213.       MXSCOR=MXSCOR+25
  2214.       IF(CLOSNG)SCORE=SCORE+25
  2215.       MXSCOR=MXSCOR+25
  2216.       IF(.NOT.CLOSED)GO TO 20020
  2217.       IF(BONUS.EQ.0)SCORE=SCORE+10
  2218.       IF(BONUS.EQ.135)SCORE=SCORE+25
  2219.       IF(BONUS.EQ.134)SCORE=SCORE+30
  2220.       IF(BONUS.EQ.133)SCORE=SCORE+45
  2221. 20020 MXSCOR=MXSCOR+45
  2222. C
  2223. C  DID HE COME TO WITT'S END AS HE SHOULD?
  2224. C
  2225.       IF(PLACE(MAGZIN).EQ.108)SCORE=SCORE+1
  2226.       MXSCOR=MXSCOR+1
  2227. C
  2228. C  ROUND IT OFF.
  2229. C
  2230.       SCORE=SCORE+2
  2231.       MXSCOR=MXSCOR+2
  2232. C
  2233. C  DEDUCT POINTS FOR HINTS.  HINTS < 4 ARE SPECIAL; SEE DATABASE DESCRIP
  2234. C
  2235.       DO 20030 I=1,HNTMAX
  2236. 20030 IF(HINTED(I))SCORE=SCORE-HINTS(I,2)
  2237. C
  2238. C  RETURN TO SCORE COMMAND IF THAT'S WHERE WE CAME FROM.
  2239. C
  2240.       IF(SCORNG)GO TO 8241
  2241. C
  2242. C  THAT SHOULD BE GOOD ENOUGH.  LET'S TELL HIM ALL ABOUT IT.
  2243. C
  2244.       WRITE(TTYO,20100)SCORE,MXSCOR,TURNS
  2245. 20100 FORMAT(///,' YOU SCORED',I4,' OUT OF A POSSIBLE',I4,
  2246.      1', USING',I5,' TURNS.')
  2247. C
  2248.       DO 20200 I=1,CLSSES
  2249.          IF(CVAL(I).GE.SCORE)GO TO 20210
  2250. 20200 CONTINUE
  2251.       WRITE(TTYO,20202)
  2252. 20202 FORMAT(/,' YOU JUST WENT OFF MY SCALE!!',/)
  2253.       GO TO 25000
  2254. C
  2255. 20210 CALL SPEAK(CTEXT(I))
  2256.       IF(I.EQ.CLSSES-1)GO TO 20220
  2257.       K=CVAL(I)+1-SCORE
  2258.       KK='S.'
  2259.       IF(K.EQ.1)KK='. '
  2260.       WRITE(TTYO,20212)K,KK
  2261. 20212 FORMAT(/,' TO ACHIEVE THE NEXT HIGHER RATING, YOU NEED',I3,
  2262.      1' MORE POINT',A2/)
  2263.       GO TO 25000
  2264. C
  2265. 20220 WRITE(TTYO,20222)
  2266. 20222 FORMAT(/,' TO ACHIEVE THE NEXT HIGHER RATING ',
  2267.      1'WOULD BE A NEAT TRICK!',//,' CONGRATULATIONS!!',/)
  2268. C
  2269. 25000 STOP
  2270. C
  2271.       END
  2272. C
  2273. C  INTERNAL/EXTERNAL CHARACTER SET CONVERSION UTILITIES (CODE1, CODE2,
  2274. C   DCODE1, CVLTUC, CVSTB)
  2275. C
  2276.       INTEGER*4 FUNCTION CODE1(QQQ)
  2277. C
  2278. C  CONVERT EXTERNAL CHARACTERS TO INTERNAL FORMAT (5 CHARS/INTEGER*4).
  2279. C
  2280. C  THE FIRST FIVE CHARACTERS OF WORDS ARE CONVERTED TO THEIR INTERNAL
  2281. C  REPRESENTATION (SIXBIT).  IF A CHARACTER HAS NO REPRESENTATION, IT IS
  2282. C  REPLACED BY A PERIOD.
  2283. C
  2284. C  DEFINITION OF CONSTANTS:
  2285. C       NWORDS = NUMBER OF INTEGER*4 VARIABLES NEEDED TO HOLD FIVE CHARS
  2286. C       NCHARS = NUMBER OF CHARACTERS STORED IN AN INTEGER*4 VARIABLE
  2287. C       CHRSIZ = NUMBER OF BITS REQUIRED TO REPRESENT A CHARACTER
  2288. C       CHRMSK = NUMBER TO AND WITH AN INTEGER*4 TO OBTAIN HIGH-ORDER
  2289. C                CHARACTER.
  2290. C
  2291. C  (SEE CONVERSION GUIDE)
  2292. C
  2293.       IMPLICIT INTEGER*4(A-Z)
  2294.       character QQQ*(*),SSS*8
  2295.       DIMENSION WORDS(2)
  2296.       DIMENSION CHRSET(64)
  2297.       EQUIVALENCE(SSS,WORDS(1))
  2298. C
  2299.       DATA NWORDS/2/,NCHARS/4/,CHRSIZ/8/,CHRMSK/Z'FF000000'/
  2300. C
  2301.       DATA CHRSET/1H ,1H!,1H",1H#,1H$,1H%,1H&,1H',
  2302.      1            1H(,1H),1H*,1H+,1H,,1H-,1H.,1H/,
  2303.      2            1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,
  2304.      3            1H8,1H9,1H:,1H;,1H<,1H=,1H>,1H?,
  2305.      4            1H@,1HA,1HB,1HC,1HD,1HE,1HF,1HG,
  2306.      5            1HH,1HI,1HJ,1HK,1HL,1HM,1HN,1HO,
  2307.      6            1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,
  2308.      7            1HX,1HY,1HZ,1H[,Z'5C202020',1H],1H^,Z'07202020'/
  2309. C ABOVE LINE SCROGGED FOR TSS EDITOR; 5C=BACKSLASH, 5F=UNDERBAR
  2310. C
  2311.          DO 1234 I=1,5
  2312. 1234     SSS(I:I)=QQQ(I:I)
  2313.       RESULT=0
  2314.       COUNT=0
  2315. C
  2316.       DO 10 I=1,NWORDS
  2317.          WORD=WORDS(I)
  2318. C
  2319.          DO 5 J=1,NCHARS
  2320.             COUNT=COUNT+1
  2321.             IF(COUNT.GT.5)GO TO 20
  2322.             CHAR=AND(WORD,CHRMSK)
  2323.             WORD=ISHFT(WORD,CHRSIZ)
  2324.             DO 1 CHRIDX=1,64
  2325.                IF(CHAR.EQ.AND(CHRSET(CHRIDX),CHRMSK))GO TO 2
  2326.     1       CONTINUE
  2327.             CHRIDX=15
  2328.     2       RESULT=ISHFT(RESULT,6)+CHRIDX-1
  2329.     5    CONTINUE
  2330.    10 CONTINUE
  2331. C
  2332.    20 CODE1=RESULT
  2333.       RETURN
  2334.       END
  2335.       INTEGER*4 FUNCTION CODE2(CHARS)
  2336. C
  2337. C  CONVERT EXTERNAL CHARACTERS TO INTERNAL FORMAT (5 CHARS/INTEGER*4).
  2338. C
  2339. C  CHARS CONTAINS FIVE CHARACTERS IN A1 FORMAT.  THEY ARE CONVERTED TO
  2340. C  THEIR INTERNAL REPRESENTATION (SIXBIT).  IF A CHARACTER
  2341. C  HAS NO REPRESENTATION, IT IS REPLACED BY A PERIOD.
  2342. C
  2343. C  (SEE CONVERSION GUIDE)
  2344. C
  2345.       IMPLICIT INTEGER*4(A-Z)
  2346.       DIMENSION CHARS(5)
  2347. C
  2348.       DIMENSION CHRSET(64)
  2349.       DATA CHRSET/1H ,1H!,1H",1H#,1H$,1H%,1H&,1H',
  2350.      1            1H(,1H),1H*,1H+,1H,,1H-,1H.,1H/,
  2351.      2            1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,
  2352.      3            1H8,1H9,1H:,1H;,1H<,1H=,1H>,1H?,
  2353.      4            1H@,1HA,1HB,1HC,1HD,1HE,1HF,1HG,
  2354.      5            1HH,1HI,1HJ,1HK,1HL,1HM,1HN,1HO,
  2355.      6            1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,
  2356.      7            1HX,1HY,1HZ,1H[,Z'5C202020',1H],1H^,Z'07202020'/
  2357. C ABOVE LINE SCROGGED FOR TSS EDITOR; 5C=BACKSLASH, 5F=UNDERBAR
  2358. C
  2359.       RESULT=0
  2360. C
  2361.       DO 10 I=1,5
  2362.          DO 1 CHRIDX=1,64
  2363.             IF(CHARS(I).EQ.CHRSET(CHRIDX))GO TO 2
  2364.     1    CONTINUE
  2365.          CHRIDX=15
  2366.     2    RESULT=ISHFT(RESULT,6)+CHRIDX-1
  2367.    10 CONTINUE
  2368. C
  2369.       CODE2=RESULT
  2370.       RETURN
  2371.       END
  2372.       SUBROUTINE DCODE1(VALUE,RESULT)
  2373. C
  2374. C  CONVERT INTERNAL CHARACTERS TO EXTERNAL FORMAT.
  2375. C
  2376. C  VALUE CONTAINS FIVE CHARACTERS IN SIXBIT.  THEY ARE CONVERTED
  2377. C  TO A1 FORMAT AND PLACED INTO RESULT(1) TO RESULT(5).
  2378. C
  2379. C  (SEE CONVERSION GUIDE)
  2380. C
  2381.       IMPLICIT INTEGER*4(A-Z)
  2382.       DIMENSION RESULT(5)
  2383. C
  2384.       DIMENSION CHRSET(64)
  2385.       DATA CHRSET/1H ,1H!,1H",1H#,1H$,1H%,1H&,1H',
  2386.      1            1H(,1H),1H*,1H+,1H,,1H-,1H.,1H/,
  2387.      2            1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,
  2388.      3            1H8,1H9,1H:,1H;,1H<,1H=,1H>,1H?,
  2389.      4            1H@,1HA,1HB,1HC,1HD,1HE,1HF,1HG,
  2390.      5            1HH,1HI,1HJ,1HK,1HL,1HM,1HN,1HO,
  2391.      6            1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,
  2392.      7            1HX,1HY,1HZ,1H[,Z'5C202020',1H],1H^,Z'07202020'/
  2393. C ABOVE LINE SCROGGED FOR TSS EDITOR; 5C=BACKSLASH, 5F=UNDERBAR
  2394. C
  2395.       VALCPY=VALUE
  2396. C
  2397.       DO 10 I=1,5
  2398.          II=6-I
  2399.          CHRIDX=AND(VALCPY,Z'0000003F')+1
  2400.          VALCPY=VALCPY/64
  2401.          RESULT(II)=CHRSET(CHRIDX)
  2402.    10 CONTINUE
  2403. C
  2404.       RETURN
  2405.       END
  2406.       SUBROUTINE CVLTUC(TEXT,LTEXT)
  2407. C
  2408. C  CONVERT LOWER CASE CHARACTERS TO UPPER CASE.
  2409. C
  2410. C (SEE CONVERSION GUIDE)
  2411. C
  2412.       IMPLICIT INTEGER*4(A-Z)
  2413.       DIMENSION TEXT(70)
  2414. C
  2415.       DIMENSION UPPER(26),LOWER(26)
  2416.       DATA UPPER/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,1HK,1HL,1HM,
  2417.      1           1HN,1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ/,
  2418.      2     LOWER/1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,1Hk,1Hl,1Hm,
  2419.      3           1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,1Hu,1Hv,1Hw,1Hx,1Hy,1Hz/
  2420. C
  2421. C
  2422.       DO 10 I=1,LTEXT
  2423.          CHR=TEXT(I)
  2424.          DO 5 J=1,26
  2425.              IF(CHR.NE.LOWER(J))GO TO 5
  2426.              TEXT(I)=UPPER(J)
  2427.              GO TO 10
  2428.     5    CONTINUE
  2429.    10 CONTINUE
  2430. C
  2431.       RETURN
  2432.       END
  2433.       INTEGER*4 FUNCTION CVSTB(WORD1,WORD1X)
  2434. C
  2435. C  INTERNAL CHARACTER SET TO INTEGER*4 VALUE (BINARY NUMBER).
  2436. C
  2437. C  WORD1 AND WORD1X CONTAIN UP TO TEN NON-BLANK CHARACTERS IN SIXBIT
  2438. C  REPRESENTING AN INTEGER*4 VALUE.  IF A NON-DIGIT IS ENCOUNTERED IN TH
  2439. C  STRING, IT IS IGNORED.
  2440. C
  2441. C  (SEE CONVERSION GUIDE)
  2442. C
  2443.       IMPLICIT INTEGER*4(A-Z)
  2444.       LOGICAL NEGATE
  2445.       DIMENSION TEXT(10)
  2446. C
  2447.       DIMENSION DIGITS(10)
  2448.       DATA DIGITS/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
  2449.       DATA BLANK,MINUS,PLUS/' ','-','+'/
  2450. C
  2451. C
  2452.       CALL DCODE1(WORD1,TEXT(1))
  2453.       CALL DCODE1(WORD1X,TEXT(6))
  2454.       RESULT=0
  2455.       NEGATE=.FALSE.
  2456.       S=1
  2457. C
  2458.       IF(TEXT(1).NE.MINUS)GO TO 1
  2459.       NEGATE=.TRUE.
  2460.       S=2
  2461.       GO TO 2
  2462. C
  2463.     1 IF(TEXT(1).NE.PLUS)GO TO 2
  2464.       NEGATE=.FALSE.
  2465.       S=2
  2466. C
  2467.     2 DO 10 I=S,10
  2468.          IF(TEXT(I).EQ.BLANK)GO TO 20
  2469.          DO 5 J=1,10
  2470.             IF(TEXT(I).EQ.DIGITS(J))GO TO 6
  2471.     5    CONTINUE
  2472.          GO TO 10
  2473.     6    RESULT=10*RESULT+J-1
  2474.    10 CONTINUE
  2475. C
  2476.    20 IF(NEGATE)RESULT=-RESULT
  2477.       CVSTB=RESULT
  2478.       RETURN
  2479.       END
  2480.       SUBROUTINE SPEAK(N)
  2481. C
  2482. C  PRINT THE MESSAGE WHICH STARTS AT LINES(N).  PRECEDE IT WITH A BLANK
  2483. C  UNLESS BLKLIN IS FALSE.
  2484. C
  2485.       IMPLICIT INTEGER*4(A-Z)
  2486.       LOGICAL BLKLIN
  2487. C!!!  COMMON /TXTCOM/ RTEXT,LINES
  2488.       COMMON /TXTCOM/ RTEXT
  2489.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  2490.       DIMENSION RTEXT(205),TEXT(70)
  2491. C!!!  DIMENSION LINES(9800)
  2492.       DATA BLANK/' '/
  2493. C
  2494. C
  2495.       IF(N.EQ.0)RETURN
  2496.       IF(LINES(N+1).EQ.CODE1('>$<      '))RETURN
  2497. C
  2498.       IF(BLKLIN)WRITE(TTYO,1)
  2499.     1 FORMAT(1X)
  2500. C
  2501.       K=N
  2502. C
  2503.    10 NWORDS=IABS(LINES(K))-K-1
  2504.       IF(NWORDS.EQ.0)GO TO 40
  2505. C
  2506.       NCHARS=5*NWORDS
  2507.       DO 15 I=1,NWORDS
  2508.          LIDX=K+I
  2509.          TIDX=5*(I-1)+1
  2510.          CALL DCODE1(LINES(LIDX),TEXT(TIDX))
  2511.    15 CONTINUE
  2512.       WRITE(TTYO,20)(TEXT(I),I=1,NCHARS)
  2513.    20 FORMAT(1X,70A1)
  2514. C
  2515.    30 K=IABS(LINES(K))
  2516.       IF(LINES(K).GE.0)GO TO 10
  2517.       RETURN
  2518. C
  2519.    40 WRITE(TTYO,1)
  2520.       GO TO 30
  2521.       END
  2522.       SUBROUTINE PSPEAK(MSG,SKIP)
  2523. C
  2524. C  FIND THE SKIP+1ST MESSAGE FROM MSG AND PRINT IT.  MSG SHOULD BE THE I
  2525. C  THE INVENTORY MESSAGE FOR OBJECT.  (INVEN+N+1 MESSAGE IS PROP=N MESSA
  2526. C
  2527.       IMPLICIT INTEGER*4(A-Z)
  2528. C!!!  COMMON /TXTCOM/ RTEXT,LINES
  2529.       COMMON /TXTCOM/ RTEXT
  2530.       COMMON /PTXCOM/ PTEXT
  2531.       DIMENSION RTEXT(205),PTEXT(100)
  2532. C!!!  DIMENSION LINES(9800)
  2533. C
  2534.       M=PTEXT(MSG)
  2535.       IF(SKIP.LT.0)GO TO 9
  2536.       DO 3 I=0,SKIP
  2537.     1 M=IABS(LINES(M))
  2538.       IF(LINES(M).GE.0)GO TO 1
  2539.     3 CONTINUE
  2540.     9 CALL SPEAK(M)
  2541.       RETURN
  2542.       END
  2543.       SUBROUTINE RSPEAK(I)
  2544. C
  2545. C  PRINT THE I-TH "RANDOM" MESSAGE (SECTION 6 OF DATABASE).
  2546. C
  2547.       IMPLICIT INTEGER*4(A-Z)
  2548. C!!!  COMMON /TXTCOM/ RTEXT,LINES
  2549.       COMMON /TXTCOM/ RTEXT
  2550.       DIMENSION RTEXT(205)
  2551. C!!!  DIMENSION LINES(9800)
  2552. C
  2553.       IF(I.NE.0)CALL SPEAK(RTEXT(I))
  2554.       RETURN
  2555.       END
  2556.       SUBROUTINE MSPEAK(I)
  2557. C
  2558. C  PRINT THE I-TH "MAGIC" MESSAGE (SECTION 12 OF DATABASE).
  2559. C
  2560.       IMPLICIT INTEGER*4(A-Z)
  2561.       COMMON /MTXCOM/ MTEXT
  2562.       DIMENSION MTEXT(35)
  2563. C
  2564.       IF(I.NE.0)CALL SPEAK(MTEXT(I))
  2565.       RETURN
  2566.       END
  2567.       SUBROUTINE GETIN(WORD1,WORD1X,WORD2,WORD2X,NULLOK)
  2568. C
  2569. C  GET A COMMAND FROM THE ADVENTURER.
  2570. C
  2571. C  WORD1 IS SET TO THE FIRST FIVE CHARACTERS OF THE FIRST WORD AND
  2572. C  WORD1X IS SET TO THE SECOND FIVE.  WORD2 AND WORD2X ARE USED IN
  2573. C  AN ANALAGOUS FASHION FOR THE SECOND WORD.  IF THERE IS NO SECOND
  2574. C  WORD, WORD2 IS SET TO ZERO.
  2575. C  IF NULLOK IS .TRUE. AND A BLANK LINE IS SUPPLIED, WORD1 IS SET TO ZER
  2576. C  OTHERWISE, THE USER MUST TYPE A NON-BLANK RESPONSE.
  2577. C
  2578.       IMPLICIT INTEGER*4(A-Z)
  2579.       LOGICAL NULLOK,BLKLIN,NULL,LGWORD
  2580. C
  2581.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  2582. C
  2583.       DIMENSION LINE(70),CHARS(5)
  2584.       DATA BLANK/' '/, NEWLINE/Z'0D202020'/
  2585. C
  2586. C
  2587.       WORD1=0
  2588.       WORD1X=0
  2589.       WORD2=0
  2590.       WORD2X=0
  2591. C
  2592.       IF(BLKLIN)WRITE(TTYO,1)
  2593.     1 FORMAT(1X)
  2594. C
  2595.     2 write (ttyo,'('' ? '',$)')
  2596.       READ(TTYI,3)LINE
  2597.     3 FORMAT(70A1)
  2598. C
  2599. C
  2600. C  CHECK FOR A NULL RESPONSE
  2601. C
  2602.       NULL = .TRUE.
  2603.       DO 4 I =1,70
  2604.          IF (LINE(I) .EQ. NEWLINE) LINE(I) = BLANK
  2605.          IF(LINE(I).NE.BLANK)NULL=.FALSE.
  2606.     4 CONTINUE
  2607. C
  2608.       IF(NULL.AND..NOT.NULLOK)GO TO 2
  2609.       IF(NULL.AND.NULLOK)RETURN
  2610. C
  2611.       CALL CVLTUC(LINE,70)
  2612. C
  2613. C
  2614. C  PROCESS THE FIRST WORD
  2615. C
  2616.       DO 10 WDST=1,70
  2617.          IF(LINE(WDST).NE.BLANK)GO TO 11
  2618.    10 CONTINUE
  2619.       CALL BUG(29)
  2620. C
  2621.    11 RETPNT=1
  2622.       GO TO 1000
  2623.    12 WORD1=CODE2(CHARS)
  2624. C
  2625.       IF(.NOT.LGWORD)GO TO 20
  2626.       RETPNT=2
  2627.       GO TO 1000
  2628.    15 WORD1X=CODE2(CHARS)
  2629. C
  2630.       IF(.NOT.LGWORD)GO TO 20
  2631.       DO 16 WDST=WDST,70
  2632.          IF(LINE(WDST).EQ.BLANK)GO TO 20
  2633.    16 CONTINUE
  2634.       RETURN
  2635. C
  2636. C
  2637. C  PROCESS SECOND WORD (IF ANY)
  2638. C
  2639.    20 IF(WDST.GT.70)RETURN
  2640.       DO 21 WDST=WDST,70
  2641.          IF(LINE(WDST).NE.BLANK)GO TO 25
  2642.    21 CONTINUE
  2643.       RETURN
  2644. C
  2645.    25 RETPNT=3
  2646.       GO TO 1000
  2647.    30 WORD2=CODE2(CHARS)
  2648. C
  2649.       IF(.NOT.LGWORD)RETURN
  2650.       RETPNT=4
  2651.       GO TO 1000
  2652.    35 WORD2X=CODE2(CHARS)
  2653.       RETURN
  2654. C
  2655. C
  2656. C  'INTERNAL SUBROUTINE' TO GET FIVE CHARACTERS (OR LESS) FROM CURRENT
  2657. C  WORD AND INDICATE IF WORD IS OVER FIVE CHARACTER LONG.
  2658. C
  2659.  1000 DO 1001 I=1,5
  2660.  1001 CHARS(I)=BLANK
  2661. C
  2662.       WDEND=MIN0(WDST+4,70)
  2663.       DO 1002 I=WDST,WDEND
  2664.          IF(LINE(I).EQ.BLANK)GO TO 1010
  2665.          J=I-WDST+1
  2666.          CHARS(J)=LINE(I)
  2667.  1002 CONTINUE
  2668. C
  2669.       WDST=WDST+5
  2670.       IF(LINE(WDST).NE.BLANK)LGWORD=.TRUE.
  2671.       IF(WDST.GT.70)LGWORD=.FALSE.
  2672.       GO TO 1099
  2673. C
  2674.  1010 WDST=I
  2675.       LGWORD=.FALSE.
  2676. C
  2677.  1099 GO TO(12,15,30,35),RETPNT
  2678.       END
  2679.       LOGICAL FUNCTION YESX(X,Y,Z,ISPK)
  2680. C
  2681. C  PRINT MESSAGE X, WAIT FOR YES/NO ANSWER.  IF YES, PRINT Y AND LEAVE Y
  2682. C  TRUE; IF NO, PRINT Z AND LEAVE YEA FALSE.  SPK IS EITHER RSPEAK OR MS
  2683. C
  2684.       IMPLICIT INTEGER*4(A-Z)
  2685.       LOGICAL BLKLIN
  2686.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  2687. C
  2688.     1 IF(X.NE.0.AND.ISPK.EQ.1)CALL RSPEAK(X)
  2689.       IF(X.NE.0.AND.ISPK.EQ.2)CALL MSPEAK(X)
  2690.       CALL GETIN(REPLY,JUNK1,JUNK2,JUNK3,.FALSE.)
  2691.       IF(REPLY.EQ.CODE1('YES      ').OR.REPLY.EQ.CODE1('Y        '))
  2692.      *GO TO 10
  2693.       IF(REPLY.EQ.CODE1('NO       ').OR.REPLY.EQ.CODE1('N        '))
  2694.      *GO TO 20
  2695.       WRITE(TTYO,9)
  2696.     9 FORMAT(/,' PLEASE ANSWER THE QUESTION.')
  2697.       GO TO 1
  2698.    10 YESX=.TRUE.
  2699.       IF(Y.NE.0.AND.ISPK.EQ.1)CALL RSPEAK(Y)
  2700.       IF(Y.NE.0.AND.ISPK.EQ.2)CALL MSPEAK(Y)
  2701.       RETURN
  2702.    20 YESX=.FALSE.
  2703.       IF(Z.NE.0.AND.ISPK.EQ.1)CALL RSPEAK(Z)
  2704.       IF(Z.NE.0.AND.ISPK.EQ.2)CALL MSPEAK(Z)
  2705.       RETURN
  2706.       END
  2707.       SUBROUTINE A5TOA1(A,B,C,INSBLK,CHARS,LENG)
  2708. C
  2709. C  A AND B CONTAIN A 1- TO 10-CHARACTER WORD IN SIXBIT, C CONTAINS ANOTH
  2710. C  WORD AND/OR PUNCTUATION.  THEY ARE UNPACKED TO ONE CHARACTER PER WORD
  2711. C  ARRAY CHARS, WITH EXACTLY ONE BLANK BETWEEN B AND C IF INSBLK IS .TRU
  2712. C  (OTHERWISE, NO BLANK IS INSERTED).
  2713. C  THE INDEX OF THE LAST NON-BLANK CHAR IN CHARS IS RETURNED IN LENG.
  2714. C
  2715.       IMPLICIT INTEGER*4(A-Z)
  2716.       LOGICAL INSBLK
  2717.       DIMENSION CHARS(20)
  2718.       DATA BLANK/' '/
  2719. C
  2720. C
  2721.       CALL DCODE1(A,CHARS(1))
  2722.       CALL DCODE1(B,CHARS(6))
  2723. C
  2724.       DO 1 I=1,10
  2725.          II=11-I
  2726.          IF(CHARS(II).NE.BLANK)GO TO 2
  2727.     1 CONTINUE
  2728.       II=0
  2729. C
  2730.     2 IF(.NOT.INSBLK)GO TO 3
  2731.       II=II+1
  2732.       CHARS(II)=BLANK
  2733. C
  2734.     3 II=II+1
  2735.       CALL DCODE1(C,CHARS(II))
  2736. C
  2737.       DO 4 I=1,5
  2738.          LENG=II+5-I
  2739.          IF(CHARS(LENG).NE.BLANK)RETURN
  2740.     4 CONTINUE
  2741. C
  2742.       LENG=II-1
  2743.       IF(INSBLK)LENG=LENG-1
  2744.       RETURN
  2745.       END
  2746. C
  2747. C  DATA STRUCTURE ROUTINES (VOCAB, DSTROY, JUGGLE, MOVE, PUT, CARRY, DRO
  2748. C
  2749.       INTEGER*4 FUNCTION VOCAB(ID,INIT)
  2750. C
  2751. C  LOOK UP ID IN THE VOCABULARY (ATAB) AND RETURN ITS "DEFINITION" (KTAB
  2752. C  -1 IF NOT FOUND.  IF INIT IS POSITIVE, THIS IS AN INITIALIZATION CALL
  2753. C  UP A KEYWORD VARIABLE, AND NOT FINDING IT CONSTITUTES A BUG.  IT ALSO
  2754. C  THAT ONLY KTAB VALUES WHICH TAKEN OVER 1000 EQUAL INIT MAY BE CONSIDE
  2755. C  (THUS "STEPS", WHICH IS A MOTION VERB AS WELL AS AN OBJECT, MAY BE LO
  2756. C  AS AN OBJECT.)  AND IT ALSO MEANS THE KTAB VALUE IS TAKEN MOD 1000.
  2757. C
  2758.       IMPLICIT INTEGER*4(A-Z)
  2759.       COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
  2760.       DIMENSION KTAB(300),ATAB(300)
  2761. C
  2762. C     SCRAMBLE THE CODE
  2763.       HASH=-(ID)
  2764.       DO 1 I=1,TABSIZ
  2765.       IF(KTAB(I).EQ.-1)GO TO 2
  2766.       IF(INIT.GE.0.AND.KTAB(I)/1000.NE.INIT)GO TO 1
  2767.       IF(ATAB(I).EQ.HASH)GO TO 3
  2768.     1 CONTINUE
  2769.       CALL BUG(21)
  2770. C
  2771.     2 VOCAB=-1
  2772.       IF(INIT.LT.0)RETURN
  2773.       CALL BUG(5)
  2774. C
  2775.     3 V=KTAB(I)
  2776.       VOCAB=KTAB(I)
  2777.       IF(INIT.GE.0)VOCAB=MOD(V,1000)
  2778.       RETURN
  2779.       END
  2780.       SUBROUTINE JUGGLE(OBJECT)
  2781. C
  2782. C  JUGGLE AN OBJECT BY PICKING IT UP AND PUTTING IT DOWN AGAIN, THE PURP
  2783. C  BEING TO GET THE OBJECT TO THE FRONT OF THE CHAIN OF THINGS AT ITS LO
  2784. C
  2785.       IMPLICIT INTEGER*4(A-Z)
  2786.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,COND,PROP,LOC,LAMP,HOLDNG
  2787.       DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
  2788.       DIMENSION COND(150),PROP(100)
  2789. C
  2790.       I=PLACE(OBJECT)
  2791.       J=FIXED(OBJECT)
  2792.       CALL MOVE(OBJECT,I)
  2793.       CALL MOVE(OBJECT+100,J)
  2794.       RETURN
  2795.       END
  2796.       SUBROUTINE MOVE(OBJECT,WHERE)
  2797. C
  2798. C  PLACE ANY OBJECT ANYWHERE BY PICKING IT UP AND DROPPING IT.  MAY ALRE
  2799. C  TOTING, IN WHICH CASE THE CARRY IS A NO-OP.  MUSTN'T PICK UP OBJECTS
  2800. C  ARE NOT AT ANY LOC, SINCE CARRY WANTS TO REMOVE OBJECTS FROM ATLOC CH
  2801. C
  2802.       IMPLICIT INTEGER*4(A-Z)
  2803.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,COND,PROP,LOC,LAMP,HOLDNG
  2804.       DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
  2805.       DIMENSION COND(150),PROP(100)
  2806. C
  2807.       IF(OBJECT.GT.100)GO TO 1
  2808.       FROM=PLACE(OBJECT)
  2809.       GO TO 2
  2810.     1 FROM=FIXED(OBJECT-100)
  2811.     2 IF(FROM.GT.0.AND.FROM.LE.300)CALL CARRY(OBJECT,FROM)
  2812.       CALL DROP(OBJECT,WHERE)
  2813.       RETURN
  2814.       END
  2815.       INTEGER*4 FUNCTION PUT(OBJECT,WHERE,PVAL)
  2816. C
  2817. C  PUT IS THE SAME AS MOVE, EXCEPT IT RETURNS A VALUE USED TO SET UP THE
  2818. C  NEGATED PROP VALUES FOR THE REPOSITORY OBJECTS.
  2819. C
  2820.       IMPLICIT INTEGER*4(A-Z)
  2821. C
  2822.       CALL MOVE(OBJECT,WHERE)
  2823.       PUT=(-1)-PVAL
  2824.       RETURN
  2825.       END
  2826.       SUBROUTINE CARRY(OBJECT,WHERE)
  2827. C
  2828. C  START TOTING AN OBJECT, REMOVING IT FROM THE LIST OF THINGS AT ITS FO
  2829. C  LOCATION.  INCR HOLDNG UNLESS IT WAS ALREADY BEING TOTED.  IF OBJECT>
  2830. C  (MOVING "FIXED" SECOND LOC), DON'T CHANGE PLACE OR HOLDNG.
  2831. C
  2832.       IMPLICIT INTEGER*4(A-Z)
  2833.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,COND,PROP,LOC,LAMP,HOLDNG
  2834.       DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
  2835.       DIMENSION COND(150),PROP(100)
  2836. C
  2837.       IF(OBJECT.GT.100)GO TO 5
  2838.       IF(PLACE(OBJECT).EQ.-1)RETURN
  2839.       PLACE(OBJECT)=-1
  2840.       HOLDNG=HOLDNG+1
  2841.     5 IF(ATLOC(WHERE).NE.OBJECT)GO TO 6
  2842.       ATLOC(WHERE)=LINK(OBJECT)
  2843.       RETURN
  2844.     6 TEMP=ATLOC(WHERE)
  2845.     7 IF(LINK(TEMP).EQ.OBJECT)GO TO 8
  2846.       TEMP=LINK(TEMP)
  2847.       GO TO 7
  2848.     8 LINK(TEMP)=LINK(OBJECT)
  2849.       RETURN
  2850.       END
  2851.       SUBROUTINE DROP(OBJECT,WHERE)
  2852. C
  2853. C  PLACE AN OBJECT AT A GIVEN LOC, PREFIXING IT ONTO THE ATLOC LIST.  DE
  2854. C  HOLDNG IF THE OBJECT WAS BEING TOTED.
  2855. C
  2856.       IMPLICIT INTEGER*4(A-Z)
  2857.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,COND,PROP,LOC,LAMP,HOLDNG
  2858.       DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
  2859.       DIMENSION COND(150),PROP(100)
  2860. C
  2861.       IF(OBJECT.GT.100)GO TO 1
  2862.       IF(PLACE(OBJECT).EQ.-1)HOLDNG=HOLDNG-1
  2863.       PLACE(OBJECT)=WHERE
  2864.       GO TO 2
  2865.     1 FIXED(OBJECT-100)=WHERE
  2866.     2 IF(WHERE.LE.0)RETURN
  2867.       LINK(OBJECT)=ATLOC(WHERE)
  2868.       ATLOC(WHERE)=OBJECT
  2869.       RETURN
  2870.       END
  2871. C  WIZARDRY ROUTINES (START, MAINT, WIZARD, HOURS(X), NEWHRS(X), MOTD, P
  2872. C
  2873. C
  2874.       LOGICAL FUNCTION START(DUMY)
  2875. C
  2876. C  CHECK TO SEE IF THIS IS "PRIME TIME".  IF SO, ONLY WIZARDS MAY PLAY,
  2877. C  OTHERS MAY BE ALLOWED A SHORT GAME FOR DEMONSTRATION PURPOSES.  IF SE
  2878. C  WE'RE CONTINUING FROM A SAVED GAME, SO CHECK FOR SUITABLE LATENCY.  R
  2879. C  TRUE IF THIS IS A DEMO GAME (VALUE IS IGNORED FOR RESTARTS).
  2880. C
  2881.       IMPLICIT INTEGER*4(A-Z)
  2882.       LOGICAL PTIME,SOON,WIZARD,BLKLIN,YESX
  2883.       DIMENSION HNAME(20)
  2884.       COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
  2885.      1SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
  2886.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  2887. C
  2888. C  FIRST FIND OUT WHETHER IT IS PRIME TIME (SAVE IN PTIME) AND, IF RESTA
  2889. C  WHETHER IT'S TOO SOON (SAVE IN SOON).  PRIME-TIME SPECS ARE IN WKDAY,
  2890. C  AND HOLID; SEE MAINT ROUTINE FOR DETAILS.  LATNCY IS REQUIRED DELAY B
  2891. C  RESTARTING.  WIZARDS MAY CUT THIS TO A THIRD.
  2892. C
  2893.       CALL DATIME(D,T)
  2894.       PRIMTM=WKDAY
  2895.       IF(MOD(D,7).LE.1)PRIMTM=WKEND
  2896.       IF(D.GE.HBEGIN.AND.D.LE.HEND)PRIMTM=HOLID
  2897.       PTIME=AND(PRIMTM,ISHFT(1,T/60)).NE.0
  2898.       SOON=.FALSE.
  2899.       IF(SETUP.GE.0)GO TO 20
  2900.       DELAY=(D-SAVED)*1440+(T-SAVET)
  2901.       IF(DELAY.GE.LATNCY)GO TO 20
  2902.       WRITE(TTYO,10)DELAY
  2903.    10 FORMAT(' THIS ADVENTURE WAS SUSPENDED A MERE',I3,' MINUTES AGO.')
  2904.       SOON=.TRUE.
  2905. C
  2906. C    REMOVE NEXT THREE LINES TO ALLOW WIZARD TO RESUME WITHOUT
  2907. C    WAITING
  2908. C
  2909. C     IF(DELAY.GE.LATNCY/3)GO TO 20
  2910. C     CALL MSPEAK(2)
  2911. C     STOP
  2912. C
  2913. C  IF NEITHER TOO SOON NOR PRIME TIME, NO PROBLEM.  ELSE SPECIFY WHAT'S
  2914. C
  2915.    20 START=.FALSE.
  2916.       IF(SOON)GO TO 30
  2917.       IF(PTIME)GO TO 25
  2918.    22 SAVED=-1
  2919.       RETURN
  2920. C
  2921. C  COME HERE IF NOT RESTARTING TOO SOON (MAYBE NOT RESTARTING AT ALL), B
  2922. C  PRIME TIME.  GIVE OUR HOURS AND SEE IF HE'S A WIZARD.  IF NOT, THEN C
  2923. C  RESTART, BUT IF JUST BEGINNING THEN WE CAN OFFER A SHORT GAME.
  2924. C
  2925.    25 CALL MSPEAK(3)
  2926.       CALL HOURS
  2927.       CALL MSPEAK(4)
  2928.       IF(WIZARD(0))GO TO 22
  2929.       IF(SETUP.LT.0)GO TO 33
  2930.       START=YESX(5,7,7,2)
  2931.       IF(START)GO TO 22
  2932.       STOP
  2933. C
  2934. C  COME HERE IF RESTARTING TOO SOON.  IF HE'S A WIZARD, LET HIM GO (AND
  2935. C  THAT IT THEN DOESN'T MATTER WHETHER IT'S PRIME TIME).  ELSE, TOUGH BE
  2936. C
  2937.    30 CALL MSPEAK(8)
  2938.       IF(WIZARD(0))GO TO 22
  2939.    33 CALL MSPEAK(9)
  2940.       STOP
  2941.       END
  2942.       SUBROUTINE MAINT(CMADRS,CMSZES)
  2943. C
  2944. C  SOMEONE SAID THE MAGIC WORD TO INVOKE MAINTENANCE MODE.  MAKE SURE HE
  2945. C  WIZARD.  IF SO, LET HIM TWEAK ALL SORTS OF RANDOM THINGS, THEN EXIT S
  2946. C  SAVE TWEAKED VERSION.  SINCE MAGIC WORD MUST BE FIRST COMMAND GIVEN,
  2947. C  THING WHICH NEEDS TO BE FIXED UP IS ABB(1).
  2948. C
  2949.       IMPLICIT INTEGER*4(A-Z)
  2950.       LOGICAL YESX,BLKLIN,WIZARD
  2951.       DIMENSION HNAME(20),ABB(150),CMADRS(4,11),CMSZES(11),FDUMY(10)
  2952.       COMMON /ABBCOM/ ABB
  2953.       COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
  2954.      1SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
  2955.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  2956. C
  2957. C
  2958.       IF(.NOT.WIZARD(0))RETURN
  2959. C
  2960.       IF(YESX(10,0,0,2))CALL HOURS
  2961.       IF(YESX(11,0,0,2))CALL NEWHRS
  2962.       IF(.NOT.YESX(26,0,0,2))GO TO 10
  2963. C
  2964.       CALL MSPEAK(27)
  2965.       CALL GETIN(WORD1,WORD1X,DUMY,DUMY,.FALSE.)
  2966.       HBEGIN=CVSTB(WORD1,WORD1X)
  2967.       CALL MSPEAK(28)
  2968.       CALL GETIN(WORD1,WORD1X,DUMY,DUMY,.FALSE.)
  2969.       HEND=CVSTB(WORD1,WORD1X)
  2970.       CALL DATIME(D,T)
  2971.       HBEGIN=HBEGIN+D
  2972.       HEND=HBEGIN+HEND-1
  2973.       CALL MSPEAK(29)
  2974.       READ(TTYI,2)HNAME
  2975.     2 FORMAT(20A1)
  2976. C
  2977.    10 WRITE(TTYO,12)SHORT
  2978.    12 FORMAT(/,' LENGTH OF SHORT GAME (NULL TO LEAVE AT ',I3,'):')
  2979.       CALL GETIN(WORD1,WORD1X,DUMY,DUMY,.TRUE.)
  2980.       IF(WORD1.EQ.0)GO TO 15
  2981.       X=CVSTB(WORD1,WORD1X)
  2982.       IF(X.GT.0)SHORT=X
  2983. C
  2984.    15 CALL MSPEAK(12)
  2985.       CALL GETIN(WORD1,DUMY,DUMY,DUMY,.TRUE.)
  2986.       IF(WORD1.NE.0)MAGIC=WORD1
  2987. C
  2988.       WRITE(TTYO,16)LATNCY
  2989.    16 FORMAT(/,' LATENCY FOR RESTART (NULL TO LEAVE AT ',I3,'):')
  2990.       CALL GETIN(WORD1,WORD1X,DUMY,DUMY,.TRUE.)
  2991.       IF(WORD1.EQ.0)GO TO 20
  2992.       X=CVSTB(WORD1,WORD1X)
  2993.       IF(X.GT.0.AND.X.LT.45)CALL MSPEAK(30)
  2994.       IF(X.GT.0)LATNCY=MAX0(45,X)
  2995. C
  2996.    20 IF(YESX(14,0,0,2))CALL MOTD(.TRUE.)
  2997. C
  2998.       SAVED=0
  2999.       SETUP=2
  3000.       ABB(1)=0
  3001.       BLKLIN=.TRUE.
  3002.       CALL SVCOMN(.TRUE.,FDUMY,CMADRS,CMSZES)
  3003.       CALL MSPEAK(15)
  3004.       RETURN
  3005.       END
  3006.       LOGICAL FUNCTION WIZARD(DUMY)
  3007. C
  3008. C  ASK IF HE'S A WIZARD.  IF HE SAYS YES, MAKE HIM PROVE IT.  RETURN TRU
  3009. C  REALLY IS A WIZARD.
  3010. C
  3011.       IMPLICIT INTEGER*4(A-Z)
  3012.       LOGICAL YESX,BLKLIN
  3013.       DIMENSION HNAME(20),XD(10)
  3014.       COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
  3015.      1SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
  3016.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3017. C
  3018.       WIZARD=YESX(16,0,7,2)
  3019.       IF(.NOT.WIZARD)RETURN
  3020. C
  3021. C  HE SAYS HE IS.  FIRST STEP: DOES HE KNOW ANYTHING MAGICAL?
  3022. C
  3023.       CALL MSPEAK(17)
  3024.       CALL GETIN(WORD,X,Y,Z,.FALSE.)
  3025.       IF(WORD.NE.MAGIC)GO TO 99
  3026. C
  3027. C  HE DOES.  GIVE HIM A RANDOM CHALLENGE AND CHECK HIS REPLY.
  3028. C
  3029. C     X=0
  3030. C     DO 10 I=1,10
  3031. C        XD(I)=RAN(8)
  3032. C        X=ISHFT(X,3)+XD(I)
  3033. C  10 CONTINUE
  3034. C     MWORD=IEOR(MAGIC,X)
  3035. C
  3036.       IF(YESX(18,0,0,2))GO TO 99
  3037. C
  3038. C     WRITE(TTYO,11)XD
  3039. C  11 FORMAT(/1X,10I1)
  3040. C     CALL GETIN(WORD,X,Y,Z,.FALSE.)
  3041. C     IF(WORD.NE.MWORD)GO TO 99
  3042. C
  3043. C  BY GEORGE, HE REALLY *IS* A WIZARD!
  3044. C
  3045.       CALL MSPEAK(19)
  3046.       RETURN
  3047. C
  3048. C  AHA!  AN IMPOSTOR!
  3049. C
  3050.    99 CALL MSPEAK(20)
  3051.       WIZARD=.FALSE.
  3052.       RETURN
  3053.       END
  3054.       SUBROUTINE HOURS
  3055. C
  3056. C  ANNOUNCE THE CURRENT HOURS WHEN THE CAVE IS OPEN FOR ADVENTURING.  TH
  3057. C  IS STORED IN WKDAY, WKEND, AND HOLID, WHERE BIT ISHFT(1,N) IS ON IFF
  3058. C  HOUR FROM N:00 TO N:59 IS "PRIME TIME" (CAVE CLOSED).  WKDAY IS FOR
  3059. C  WEEKDAYS, WKEND FOR WEEKENDS, HOLID FOR HOLIDAYS.  NEXT HOLIDAY IS FR
  3060. C  HBEGIN TO HEND.
  3061. C
  3062.       IMPLICIT INTEGER*4(A-Z)
  3063.       LOGICAL BLKLIN
  3064.       DIMENSION HNAME(20)
  3065.       COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
  3066.      1SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
  3067.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3068. C
  3069. C
  3070.       WRITE(TTYO,1)
  3071.     1 FORMAT(' ')
  3072. C
  3073.       CALL HOURSX(WKDAY,1)
  3074.       CALL HOURSX(WKEND,2)
  3075.       CALL HOURSX(HOLID,3)
  3076. C
  3077.       CALL DATIME(D,T)
  3078.       IF(HEND.LT.D.OR.HEND.LT.HBEGIN)RETURN
  3079.       IF(HBEGIN.GT.D)GO TO 10
  3080. C
  3081.       WRITE(TTYO,5)HNAME
  3082.     5 FORMAT(/,' TODAY IS A HOLIDAY, NAMELY ',20A1)
  3083.       RETURN
  3084. C
  3085.    10 D=HBEGIN-D
  3086.       T='S,'
  3087.       IF(D.EQ.1)T=', '
  3088.       WRITE(TTYO,15)D,T,HNAME
  3089.    15 FORMAT(/,' THE NEXT HOLIDAY WILL BE IN',I3,' DAY',A2,
  3090.      1' NAMELY ',20A1)
  3091.       RETURN
  3092.       END
  3093.       SUBROUTINE HOURSX(H,DAYTYP)
  3094. C
  3095. C  USED BY HOURS (ABOVE) TO PRINT HOURS FOR EITHER WEEKDAYS OR WEEKENDS.
  3096. C
  3097.       IMPLICIT INTEGER*4(A-Z)
  3098.       LOGICAL FIRST,BLKLIN
  3099.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3100. C
  3101.       DIMENSION TYPE(3,10)
  3102.       DATA ((TYPE(I,J),J=1,10),I=1,3)
  3103.      1     /1HM,1HO,1HN,1H ,1H-,1H ,1HF,1HR,1HI,1H:,
  3104.      2      1HS,1HA,1HT,1H ,1H&,1H ,1HS,1HU,1HN,1H:,
  3105.      3      1HH,1HO,1HL,1HI,1HD,1HA,1HY,1HS,1H:,1H /
  3106. C
  3107. C
  3108.       FIRST=.TRUE.
  3109.       FROM=-1
  3110.       IF(H.NE.0)GO TO 10
  3111. C
  3112.       WRITE(TTYO,2)(TYPE(DAYTYP,J),J=1,10)
  3113.     2 FORMAT(10X,10A1,'   OPEN ALL DAY')
  3114.       RETURN
  3115. C
  3116.    10 FROM=FROM+1
  3117.       IF(AND(H,ISHFT(1,FROM)).NE.0)GO TO 10
  3118.       IF(FROM.GE.24)GO TO 20
  3119.       TILL=FROM
  3120.    14 TILL=TILL+1
  3121.       IF(AND(H,ISHFT(1,TILL)).EQ.0.AND.TILL.NE.24)GO TO 14
  3122. C
  3123.       IF(FIRST)WRITE(TTYO,16)(TYPE(DAYTYP,J),J=1,10),FROM,TILL
  3124.       IF(.NOT.FIRST)WRITE(TTYO,18)FROM,TILL
  3125.    16 FORMAT(10X,10A1,I4,':00 TO',I3,':00')
  3126.    18 FORMAT(20X,I4,':00 TO',I3,':00')
  3127.       FIRST=.FALSE.
  3128.       FROM=TILL
  3129.       GO TO 10
  3130. C
  3131.    20 IF(FIRST)WRITE(TTYO,22)(TYPE(DAYTYP,J),J=1,10)
  3132.    22 FORMAT(10X,10A1,'   CLOSED ALL DAY')
  3133.       RETURN
  3134.       END
  3135.       SUBROUTINE NEWHRS
  3136. C
  3137. C  SET UP NEW HOURS FOR THE CAVE.  SPECIFIED AS INVERSE--I.E., WHEN IS I
  3138. C  CLOSED DUE TO PRIME TIME?  SEE HOURS (ABOVE) FOR DESC OF VARIABLES.
  3139. C
  3140.       IMPLICIT INTEGER*4(A-Z)
  3141.       DIMENSION HNAME(20)
  3142.       COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
  3143.      1SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
  3144. C
  3145.       CALL MSPEAK(21)
  3146. C
  3147.       WKDAY=NEWHRX(1)
  3148.       WKEND=NEWHRX(2)
  3149.       HOLID=NEWHRX(3)
  3150. C
  3151.       CALL MSPEAK(22)
  3152.       CALL HOURS
  3153.       RETURN
  3154.       END
  3155.       INTEGER*4 FUNCTION NEWHRX(DAYTYP)
  3156. C
  3157. C  INPUT PRIME TIME SPECS AND SET UP A WORD OF INTERNAL FORMAT.
  3158. C
  3159.       IMPLICIT INTEGER*4(A-Z)
  3160.       LOGICAL BLKLIN
  3161.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3162. C
  3163.       DIMENSION TYPE(3,10)
  3164.       DATA ((TYPE(I,J),J=1,10),I=1,3)
  3165.      1     /1HM,1HO,1HN,1H ,1H-,1H ,1HF,1HR,1HI,1H:,
  3166.      2      1HS,1HA,1HT,1H ,1H&,1H ,1HS,1HU,1HN,1H:,
  3167.      3      1HH,1HO,1HL,1HI,1HD,1HA,1HY,1HS,1H:,1H /
  3168. C
  3169.       NX=0
  3170.       BLKLIN=.FALSE.
  3171.       WRITE(TTYO,1)(TYPE(DAYTYP,J),J=1,10)
  3172.     1 FORMAT(' PRIME TIME ON ',10A1)
  3173. C
  3174.    10 WRITE(TTYO,2)
  3175.     2 FORMAT(' FROM:')
  3176.       CALL GETIN(WORD1,WORD1X,DUMY,DUMY,.TRUE.)
  3177.       FROM=CVSTB(WORD1,WORD1X)
  3178.       IF(FROM.LT.0.OR.FROM.GE.24)GO TO 20
  3179. C
  3180.       WRITE(TTYO,4)
  3181.     4 FORMAT(' TILL:')
  3182.       CALL GETIN(WORD1,WORD1X,DUMY,DUMY,.TRUE.)
  3183.       TILL=CVSTB(WORD1,WORD1X)-1
  3184.       IF(TILL.LT.FROM.OR.TILL.GE.24)GO TO 20
  3185. C
  3186.       DO 5 I=FROM,TILL
  3187.     5 NX=OR(NX,ISHFT(1,I))
  3188.       GO TO 10
  3189. C
  3190.    20 BLKLIN=.TRUE.
  3191.       NEWHRX=NX
  3192.       RETURN
  3193.       END
  3194.       SUBROUTINE MOTD(ALTER)
  3195. C
  3196. C  HANDLES MESSAGE OF THE DAY.  IF ALTER IS TRUE, READ A NEW MESSAGE FRO
  3197. C  WIZARD.  ELSE PRINT THE CURRENT ONE.  MESSAGE IS INITIALLY NULL.
  3198. C
  3199.       IMPLICIT INTEGER*4(A-Z)
  3200.       LOGICAL ALTER,BLKLIN
  3201. C
  3202.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3203.       COMMON /MTDCOM/ MTDTXT
  3204. C
  3205.       DIMENSION MTDTXT(100),TEXT(70)
  3206.       DATA BLANK/' '/,PERIOD/'.'/
  3207. C
  3208. C
  3209.       IF(ALTER)GO TO 50
  3210. C
  3211.       K=1
  3212. C
  3213.    10 IF(MTDTXT(K).LT.0)RETURN
  3214.       NWORDS=MTDTXT(K)-K-1
  3215.       IF(NWORDS.EQ.0)GO TO 40
  3216. C
  3217.       NCHARS=5*NWORDS
  3218.       DO 15 I=1,NWORDS
  3219.          MIDX=K+I
  3220.          TIDX=5*(I-1)+1
  3221.          CALL DCODE1(MTDTXT(MIDX),TEXT(TIDX))
  3222.    15 CONTINUE
  3223.       WRITE(TTYO,20)(TEXT(I),I=1,NCHARS)
  3224.    20 FORMAT(1X,70A1)
  3225. C
  3226.    30 K=MTDTXT(K)
  3227.       GO TO 10
  3228. C
  3229.    40 WRITE(TTYO,45)
  3230.    45 FORMAT(1X)
  3231.       GO TO 30
  3232. C
  3233.    50 M=1
  3234.       CALL MSPEAK(23)
  3235. C
  3236.    55 READ(TTYI,56)TEXT,K
  3237.    56 FORMAT(70A1,A1)
  3238.       IF(K.EQ.BLANK)GO TO 60
  3239.       CALL MSPEAK(24)
  3240.       GO TO 55
  3241. C
  3242.    60 DO 62 I=1,70
  3243.          K=71-I
  3244.          IF(TEXT(K).NE.BLANK)GO TO 65
  3245.    62 CONTINUE
  3246.       K=0
  3247.       GO TO 70
  3248. C
  3249.    65 IF((K.EQ.1).AND.(TEXT(1).EQ.PERIOD))GO TO 90
  3250. C
  3251.       CALL CVLTUC(TEXT,K)
  3252.       K=(K+4)/5
  3253.       DO 66 I=1,K
  3254.          K1=M+I
  3255.          K2=5*(I-1)+1
  3256.          MTDTXT(K1)=CODE2(TEXT(K2))
  3257.    66 CONTINUE
  3258. C
  3259.    70 MTDTXT(M)=M+K+1
  3260.       M=M+K+1
  3261.       IF(M+14.LT.100)GO TO 55
  3262.       CALL MSPEAK(25)
  3263. C
  3264.    90 MTDTXT(M)=-1
  3265.       RETURN
  3266.       END
  3267.       SUBROUTINE POOF
  3268. C
  3269. C  AS PART OF DATABASE INITIALIZATION, WE CALL POOF TO SET UP SOME DUMY
  3270. C  PRIME-TIME SPECS, MAGIC WORDS, ETC.
  3271. C
  3272.       IMPLICIT INTEGER*4(A-Z)
  3273.       DIMENSION HNAME(20)
  3274.       COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
  3275.      1SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
  3276. C
  3277.       WKDAY=261888
  3278. C  ABOVE CONSTANT SETS PRIME-TIME ON WEEKDAYS AS 09:00 - 18:00
  3279.       WKEND=0
  3280.       HOLID=0
  3281.       HBEGIN=0
  3282.       HEND=-1
  3283.       SHORT=30
  3284.       MAGIC=CODE1('DWARF    ')
  3285.       MAGNM=11111
  3286.       LATNCY=90
  3287.       RETURN
  3288.       END
  3289. C
  3290. C  UTILITY ROUTINES (SCRMBL, RAN, DATIME, CIAO, BUG)
  3291. C
  3292.       SUBROUTINE BUG(NUM)
  3293.       IMPLICIT INTEGER*4(A-Z)
  3294.       LOGICAL BLKLIN
  3295.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3296.       DATA CAVE/'CAVE'/
  3297. C
  3298. C  THE FOLLOWING CONDITIONS ARE CURRENTLY CONSIDERED FATAL BUGS.  NUMBER
  3299. C  ARE DETECTED WHILE READING THE DATABASE; THE OTHERS OCCUR AT "RUN TIM
  3300. C       0       MESSAGE LINE > 70 CHARACTERS
  3301. C       1       NULL LINE IN MESSAGE
  3302. C       2       TOO MANY WORDS OF MESSAGES
  3303. C       3       TOO MANY TRAVEL OPTIONS
  3304. C       4       TOO MANY VOCABULARY WORDS
  3305. C       5       REQUIRED VOCABULARY WORD NOT FOUND
  3306. C       6       TOO MANY RTEXT OR MTEXT MESSAGES
  3307. C       7       TOO MANY HINTS
  3308. C       8       LOCATION HAS COND BIT BEING SET TWICE
  3309. C       9       INVALID SECTION NUMBER IN DATABASE
  3310. C      20       SPECIAL TRAVEL (500>L>300) EXCEEDS GO TO LIST
  3311. C      21       RAN OFF END OF VOCABULARY TABLE
  3312. C      22       VOCABULARY TYPE (N/1000) NOT BETWEEN 0 AND 3
  3313. C      23       INTRANSITIVE ACTION VERB EXCEEDS GO TO LIST
  3314. C      24       TRANSITIVE ACTION VERB EXCEEDS GO TO LIST
  3315. C      25       CONDITIONAL TRAVEL ENTRY WITH NO ALTERNATIVE
  3316. C      26       LOCATION HAS NO TRAVEL ENTRIES
  3317. C      27       HINT NUMBER EXCEEDS GO TO LIST
  3318. C      28       INVALID MONTH RETURNED BY DATE FUNCTION
  3319. C      29       INTERNAL ERROR IN GETIN (POSSIBLE FORTRAN BUG)
  3320. C
  3321.       WRITE(TTYO,1)NUM
  3322.     1 FORMAT (' FATAL ERROR, SEE SOURCE CODE FOR INTERPRETATION.',/
  3323.      1' PROBABLY CAUSE: ERRONEOUS INFO IN DATABASE.',/
  3324.      2' ERROR CODE =',I2/)
  3325.       CALL ABORT(CAVE)
  3326. 9     RETURN
  3327.       END
  3328.       SUBROUTINE IOINIT(DUMY)
  3329. C
  3330.       IMPLICIT INTEGER*4(A-Z)
  3331.       LOGICAL BLKLIN
  3332.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3333.       integer getuid
  3334.       CHARACTER*16 MODE
  3335.       DATA LINE/'LINE'/, DATA/'DATA'/
  3336. C
  3337. C     TTYI='!!!'
  3338. C     TTYO='!!!'
  3339. C     DBFI='DBF'
  3340.       TTYI=5
  3341.       TTYO=6
  3342.       DBFI=1
  3343. C
  3344. C     OPEN (UNIT=TTYI)
  3345.       IF (DUMY .NE. 0) GO TO 38
  3346.       MODE = 'old'
  3347.       IF (getuid() .eq. 0) MODE='unknown'
  3348. c     WRITE(0,4321) MODE
  3349. c4321 FORMAT(' OPEN LFC = >2<, FILENAME = ',
  3350. c    1 '>/usr/local/lib/M.ADVLIN<, MODE = >',A,'<')
  3351.       OPEN (UNIT=2,ACCESS='DIRECT',ERR=37,
  3352.      * FORM='FORMATTED',RECL=768,
  3353.      * FILE='/usr/local/lib/M.ADVLIN', status=MODE)
  3354.       GO TO 38
  3355. 37    CALL ABORT(LINE)
  3356. 38    CONTINUE
  3357. C
  3358. c     WRITE(0,4322)
  3359. c4322 FORMAT(' OPEN LFC = >1<, FILENAME = ',
  3360. c    1 '>/usr/local/lib/M.ADVDAT<')
  3361.       OPEN (UNIT=1,ERR=39,
  3362.      * FILE='/usr/local/lib/M.ADVDAT',
  3363.      * status='old')
  3364.       GO TO 40
  3365. 39    CALL ABORT(DATA)
  3366. 40    CONTINUE
  3367. C
  3368.       RETURN
  3369.       END
  3370.       SUBROUTINE LDCOMN(L,FNAME,CMADDR,CMSIZE)
  3371. C
  3372.       IMPLICIT INTEGER*4(A-Z)
  3373. C
  3374.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3375. C
  3376.       LOGICAL L
  3377. C
  3378.       DIMENSION FNAME(8),CMADDR(4,11),CMSIZE(11)
  3379.       DIMENSION NEW2(8)
  3380. C
  3381.       DATA NEW2/1HM,1H.,1HA,1HD,1HV,1HG,1HA,1HM/
  3382. C
  3383.       QQQ=3
  3384. c     write (0,9997) l
  3385. c9997 format (' In LDCOMN, l = ', l1)
  3386. c     do 9998 i=1,11
  3387. c9998 write (0,9999) i, cmsize(i), cmaddr(1,i)
  3388. c9999 format (' i = ',i3,', cmsize = ',i10,', cmaddr = ',z8.8)
  3389.       IF (L) GO TO 1
  3390.       IF (ATTACH(QQQ,1,FNAME,'old').EQ.0) GO TO 5
  3391.       WRITE (TTYO,10) FNAME
  3392. 10    FORMAT (/' I CAN NOT FIND FILE NAME ',8A1,
  3393.      1 ' - I WILL START A REGULAR GAME INSTEAD')
  3394. C
  3395. 1     IF (ATTACH(QQQ,0,NEW2,'old').NE.0) GO TO 999
  3396. 5     CONTINUE
  3397.       DO 110 I=1,11
  3398.       CALL IO(CMSIZE(I),CMADDR(1,I),0)
  3399. 110   CONTINUE
  3400. c     WRITE(0,4323)
  3401. c4323 FORMAT(' CLOSE 3')
  3402.       CLOSE (UNIT=3)
  3403.       RETURN
  3404. C
  3405. 999   WRITE (TTYO,998)
  3406. 998   FORMAT (' I AM SORRY, BUT I CAN''T SEEM TO FIND YOUR FILE')
  3407.       STOP
  3408.       END
  3409.       SUBROUTINE SVCOMN(L,FNAME,CMADDR,CMSIZE)
  3410. C
  3411.       IMPLICIT INTEGER*4(A-Z)
  3412.       LOGICAL L
  3413. C
  3414.       DIMENSION FNAME(8),CMADDR(4,11),CMSIZE(11)
  3415.       DIMENSION NEW2(8)
  3416.       COMMON /IOSCOM/ TTYI,TTYO,BLKLIN,DBFI
  3417. C
  3418.       DATA NEW2/1HM,1H.,1HA,1HD,1HV,1HG,1HA,1HM/
  3419. C
  3420.       QQQ=3
  3421. c     write (0,9997) l
  3422. c9997 format (' In SVCOMN, l = ', l1)
  3423. c     do 9998 i=1,11
  3424. c9998 write (0,9999) i, cmsize(i), cmaddr(1,i)
  3425. c9999 format (' i = ',i3,', cmsize = ',i10,', cmaddr = ',z8.8)
  3426.       IF (L) GO TO 1
  3427. C     HERE TO SAVE CURRENT GAME
  3428.       CALL GENRAT(1,FNAME)
  3429.       IF (ATTACH(QQQ,1,FNAME,'unknown').EQ.0) GO TO 5
  3430.       GO TO 900
  3431. C
  3432. C     HERE TO SAVE NEW GAME (WIZARDS ONLY)
  3433. 1     CALL GENRAT(0,NEW2)
  3434.       IF (ATTACH( QQQ ,0,NEW2,'unknown').NE.0) GO TO 900
  3435.       CALL SAVLINES
  3436. 5     CONTINUE
  3437.       DO 110 I=1,11
  3438.       CALL IO(CMSIZE(I),CMADDR(1,I),1)
  3439. 110   CONTINUE
  3440. c     WRITE(0,4324)
  3441. c4324 FORMAT(' CLOSE 3')
  3442.       CLOSE (UNIT=3)
  3443.       RETURN
  3444. C
  3445. 900   WRITE(TTYO,903)
  3446. 903   FORMAT(' I AM SORRY, BUT I CAN''T CREATE OR FIND YOUR FILE')
  3447.       RETURN
  3448.       END
  3449.       INTEGER*4 FUNCTION RAN(RANGE)
  3450. C
  3451. C  RETURN RANDOM UNIFORMLY DISTRIBUTED VALUE IN CLOSED INTERVAL
  3452. C     [0,RANGE-1]
  3453. C
  3454.       IMPLICIT INTEGER*4(A-Z)
  3455.       COMMON /RANCOM/ R
  3456. C
  3457.       IF (R.NE.0) GO TO 1
  3458.       CALL DATIME(D,T)
  3459.       R = T
  3460.       IF (R .EQ. 0)  R = 1
  3461. C
  3462. C     16807 = 7**5 - LONG PERIOD FOR 32 BIT INT
  3463. 1     R = R * 16807
  3464. C     TAKE MIDDLE DIGITS
  3465.       RAN = AND (Z'0000FFFF', ISHFT(R,-8))
  3466.       RAN = MOD (RAN, RANGE)
  3467.       RETURN
  3468.       END
  3469.       INTEGER*4 FUNCTION ATTACH (LFC, QUAL, FNAME, MODE)
  3470. C ALLOCATE FNAME TO LFC
  3471.       IMPLICIT INTEGER*4 (A-Z)
  3472.       DIMENSION FNAME (8)
  3473. C FNAME IS IN 1H FORMAT; NEED TO CONVERT
  3474.       CHARACTER F8C*8, ZFILE*50, MODE*(*)
  3475. C
  3476.       DO 1 I = 1,8
  3477.          F8C(I:I) = CHAR( ISHFT (FNAME(I), -24) )
  3478. c        write (0,*) 'In ATTACH, I = ', i, ', f8c(i:i) = ', f8c(i:i)
  3479.  1    CONTINUE
  3480. c        WRITE(0,4321)LFC,F8C,QUAL,MODE
  3481. c4321    FORMAT(' OPEN FOR LFC = >',I4,'< FILENAME = >',A8,'< QUAL = >'
  3482. c    *           ,I1,'< MODE = >',A,'<')
  3483.       ZFILE = F8C//' '
  3484.       IF (QUAL .EQ. 0) ZFILE = '/usr/local/lib/'//F8C//' '
  3485.          OPEN (UNIT=LFC,FILE=ZFILE,ERR=2,
  3486.      *   FORM='UNFORMATTED',status=MODE,IOSTAT=ISTAT)
  3487. c     write (0,*) 'ATTACH successful for file ', zfile
  3488. 3     ATTACH = 0
  3489.       RETURN
  3490. C
  3491.  2    ATTACH = 1
  3492.       WRITE (0,9990) ISTAT, ZFILE
  3493.  9990 FORMAT (/' *** ATTACH OPEN STATUS =',I15/' FILE: ',A50)
  3494.       RETURN
  3495.       END
  3496.       SUBROUTINE GENRAT (QUAL, FNAME)
  3497. C CREATE A COMMON SAVE FILE
  3498.       IMPLICIT INTEGER*4 (A-Z)
  3499.       DIMENSION FNAME(8)
  3500. C AGAIN, FNAME IN 1H - CONVERT
  3501.       CHARACTER ZFILE*50, F8C*8
  3502. C
  3503.       DO 1 I=1,8
  3504.          F8C(I:I) = CHAR( ISHFT (FNAME(I), -24) )
  3505. 1     CONTINUE
  3506.       ZFILE = F8C//' '
  3507.       IF (QUAL .EQ. 0) ZFILE = '/usr/local/lib/'//F8C//' '
  3508. c     WRITE(0,123)F8C,QUAL
  3509. c123  FORMAT(' In GENRAT: >',A8,'< >',I1,'<')
  3510.       OPEN (UNIT=3, ERR=800, FILE=ZFILE,
  3511.      1 FORM='UNFORMATTED', STATUS='OLD')
  3512.       CLOSE (UNIT=3, ERR=800, STATUS='DELETE')
  3513. c800  CRSIZ = 80
  3514. 800   OPEN (UNIT=3, ERR=910, FILE=ZFILE,
  3515.      1  FORM='UNFORMATTED', STATUS='NEW',
  3516.      2 IOSTAT=ISTAT)
  3517.       CLOSE (UNIT=3, ERR=900)
  3518. 900   RETURN
  3519. C
  3520. 910   CONTINUE
  3521.       WRITE (0,9990) ISTAT, ZFILE
  3522.  9990 FORMAT (/' *** UNABLE TO CREATE SAVE FILE, OPEN STATUS =',I15/
  3523.      1 ' FILE NAME: ',A50)
  3524.       RETURN
  3525.       END
  3526.       SUBROUTINE IO (QUANT, BASE, RWFLAG)
  3527. c
  3528. C TRANSFER QUANT WORDS TO/FROM ADDRESS BASE
  3529. c Note that this routine uses "illegal" subscripts on array 'foo'
  3530. c to actually get at the elements of the array pointed to by 'base'.
  3531. c On the Apollo, 'foo' must be in common to get addresses that are
  3532. c close enough to the addresses in 'base'.
  3533. c
  3534.       IMPLICIT INTEGER*4 (A-Z)
  3535.       DIMENSION FOO(2)
  3536.       common /foocommon/ foo
  3537. C
  3538.       QQQ=3
  3539. c     write (0,9998) QUANT, BASE, RWFLAG
  3540. c9998 format (' In IO, QUANT = ',i6,', BASE = ',z8.8,', RWFLAG = ',i4)
  3541.       IF (QUANT .LE. 0) RETURN
  3542. c     Create an offset from FOO to BASE for addressing.
  3543.       subscript = (base-iaddr(foo(1))) / 4
  3544. c     write (0,9999) iaddr(foo(1)), subscript, subscript
  3545. c9999 format (' iaddr(FOO(1)) = ',z8.8,', subscript = ',i12,
  3546. c    1 ' (',z8.8,')')
  3547.       IF (RWFLAG .EQ. 0) GO TO 1
  3548.       IF (RWFLAG .EQ. 1) GO TO 2
  3549.       RETURN
  3550. c
  3551. c     Read.
  3552. c
  3553. 1     continue
  3554. c     write (0,4322) qqq, quant
  3555. c4322 FORMAT(' TRY TO READ.  QQQ = >',I4,'<, QUANT = >',I10,'<')
  3556.       read (qqq,end=900) (foo(subscript+i),i=1,quant)
  3557.       RETURN
  3558. 900   write (0,901)
  3559. 901   format (' Read failed in routine IO - if this is the',
  3560.      1 ' initialization phase, no problem.'/
  3561.      2 ' Returning a buffer of zeroes.')
  3562.       do 902 i=1,quant
  3563. 902   foo(subscript+i) = 0
  3564.       return
  3565. c
  3566. c     Write.
  3567. c
  3568. 2     continue
  3569. c     write (0,4321) qqq, quant
  3570. c4321 FORMAT(' TRY TO WRITE.  QQQ = >',I4,'<, QUANT = >',I10,'<')
  3571.       write (qqq) (foo(subscript+i),i=1,quant)
  3572.       RETURN
  3573.       END
  3574.       SUBROUTINE DATIME(D,T)
  3575. C
  3576. C  RETURN THE CURRENT DATE AND TIME.
  3577. C
  3578. C  D IS SET TO THE NUMBER OF DAYS SINCE 07/01/78 (A SATURDAY)
  3579. C  T IS SET TO THE NUMBER OF MINUTES PAST MIDNIGHT.
  3580. C
  3581. C
  3582.       IMPLICIT INTEGER*4(A-Z)
  3583.       DIMENSION MOTAB(12)
  3584.       INTEGER T1(3)
  3585.       DATA MOTAB/0,31,59,90,120,151,181,212,243,273,304,334/
  3586. C
  3587.       call itime (t1)
  3588.       T = 60 * T1(1) + T1(2)
  3589. c     write (0,*) 'time is ', t1(1), ':', t1(2)
  3590. C
  3591.       call idate (t1)
  3592.       DD = t1(1)
  3593.       MM = t1(2)
  3594.       YY = t1(3) - 1900
  3595. c     write (0,*) 'date is ', t1(1), '/', t1(2), '/', t1(3)
  3596. C
  3597.       IF (YY .LT. 78) YY = 78
  3598.       D = (YY - 78)*365 + (YY - 76)/4
  3599. C     JULY 1 ADJUST
  3600.       D = D - 182
  3601. C     WHY NOT JULY?
  3602.       IF (MM .GT. 12 .OR. MM .LT. 1) MM = 7
  3603.       D = D + MOTAB(MM)
  3604.       IF (MOD(YY,4) .EQ. 0 .AND. MM .LE. 2) D = D - 1
  3605. C     WHY NOT AUGUST 47?
  3606.       D = D + DD
  3607. C     FRI JULY 7, 1978
  3608.       IF (D .LT. 0) D = 6
  3609.       RETURN
  3610.       END
  3611.       INTEGER FUNCTION LINES (JNDEX)
  3612. c
  3613. c     Retrieve an entry from the data base.
  3614. c
  3615.       IMPLICIT INTEGER*4 (A-Z)
  3616. c
  3617.       DIMENSION BUF(0:191)
  3618. c
  3619.       DATA CURRENT/-1/, DIRTY/0/, BUF/192*0/
  3620. C
  3621. c     write (0,*) 'Call LINES: JNDEX = ', jndex
  3622.       WFLAG = 0
  3623.       INDEX=JNDEX
  3624. C     MAKE SURE CURRENT CORRECT
  3625.       GO TO 200
  3626. 10    LINES = BUF(DISP)
  3627.       RETURN
  3628. C
  3629.       ENTRY SETLINES (JNDEX, VALUE)
  3630. c
  3631. c     Add an entry to the data base.
  3632. c
  3633. c     write (0,*) 'Call SETLINES: JNDEX = ', jndex
  3634.       WFLAG = 1
  3635.       INDEX=JNDEX
  3636.       GO TO 200
  3637. 20    BUF(DISP) = VALUE
  3638.       LINES = VALUE
  3639.       DIRTY = 1
  3640.       RETURN
  3641. C
  3642.       ENTRY SAVLINES
  3643. c
  3644. c     Force the last block to be written out.
  3645. c
  3646. c     write (0,*) 'Call SAVLINES'
  3647.       WFLAG = 0
  3648.       INDEX = 1
  3649.       IF (CURRENT .EQ. 0) INDEX = 1000
  3650. C
  3651. 200   QQQ=2
  3652.       IDX = INDEX - 1
  3653.       BLK = IDX/192
  3654.       DISP = IDX - BLK*192
  3655. c     write (0,*) 'In LINES: INDEX = ', index, ', BLK = ', blk,
  3656. c    1 ', CURRENT = ', current
  3657.       IF (BLK .EQ. CURRENT) GO TO 210
  3658.       IF (DIRTY .EQ. 0) GO TO 205
  3659.       CURR=CURRENT+1
  3660. c     write (0,*) 'In LINES: writing record ', curr
  3661.       IF(CURR.GT.0)WRITE(qqq,1000,REC=CURR)BUF
  3662. 1000  FORMAT(192A4)
  3663.       DIRTY = 0
  3664. 205   CONTINUE
  3665.       CURRENT = BLK
  3666.       CURR=CURRENT+1
  3667. c     write (0,*) 'In LINES: reading record ', curr
  3668.       IF(CURR.GT.0)READ(qqq,1000,REC=CURR,err=207)BUF
  3669.       go to 210
  3670. c
  3671. c     Error on read (probably a record past EOF) - return a
  3672. c     block of zeroes, which is what is needed for the first
  3673. c     initialization of the data base.
  3674. c
  3675. 207   write (0,*) 'LINES/SETLINES/SAVLINES: error on read',
  3676.      1 ' of record ', curr, ' (OK if initializing).'
  3677.       write (0,*) 'Returning a buffer of zeroes.'
  3678.       do 208 i=0,191
  3679. 208   buf(i) = 0
  3680. c
  3681. 210   IF (WFLAG .EQ. 0) GO TO 10
  3682.       GO TO 20
  3683. C
  3684.       END
  3685. C     integer function ishft (iarg, icount)
  3686. c
  3687. c     Replace Gould ishft function by Apollo versions.
  3688. c
  3689. c     Shift iarg left by icount bits (icount > 0).
  3690. c     Shift iarg right by icount bits (icount < 0).
  3691. c
  3692. C     implicit integer*4 (a-z)
  3693. c
  3694. c     write (0,9999) iarg, icount
  3695. c9999 format (' In ishft, iarg is ',z8.8,', icount is ',i4)
  3696. C     if (icount .gt. 0) then
  3697. C        ishft = lshft (iarg, icount)
  3698. C     else if (icount .lt. 0) then
  3699. C        ishft = rshft (iarg, -icount)
  3700. C     else
  3701. C        ishft = iarg
  3702. C     end if
  3703. c     write (0,9998) ishft
  3704. c9998 format ('           ishft returned ',z8.8)
  3705. C     return
  3706. C     end
  3707.       integer function and (iarg1, iarg2)
  3708. c
  3709. c     Replace Apollo 'and' function by HP 'iand'.
  3710. c
  3711. c
  3712.       implicit integer*4 (a-z)
  3713. c
  3714. c     write (0,9999) iarg1, iarg2
  3715. c9999 format (' In and, iarg1 is ',z8.8,', iarg2 is ',z8.8)
  3716.       and = iand (iarg1, iarg2)
  3717. c     write (0,9998) and
  3718. c9998 format ('         and returned ',z8.8)
  3719.       return
  3720.       end
  3721.       integer function or (iarg1, iarg2)
  3722. c
  3723. c     Replace Apollo 'or' function by HP 'ior'.
  3724. c
  3725. c
  3726.       implicit integer*4 (a-z)
  3727. c
  3728. c     write (0,9999) iarg1, iarg2
  3729. c9999 format (' In or, iarg1 is ',z8.8,', iarg2 is ',z8.8)
  3730.       or = ior (iarg1, iarg2)
  3731. c     write (0,9998) or
  3732. c9998 format ('        or returned ',z8.8)
  3733.       return
  3734.       end
  3735.       integer function iaddr (i)
  3736. c
  3737. c     Replace Apollo 'iaddr' function by HP 'loc'.
  3738. c
  3739. c     Return the address of 'i'.
  3740. c
  3741. c
  3742.       iaddr = loc (i)
  3743.       return
  3744.       end
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!