home *** CD-ROM | disk | FTP | other *** search
Text File | 1993-07-29 | 80.5 KB | 2,355 lines |
- c =====================================================================
- c Adventure!
- c =====================================================================
- c Modified for MS DOS PDS FORTRAN v5.10
- c by Paul Muñoz-Colman, FunStuff Software
- c 27 Mar 1993 change date & time to getdat & gettim
- c delete DO66 and DEBUG metacommands
- c change pause prompt
- c change OPEN STATUS to UNKNOWN on overwrites
- c 15 Oct 1990 fix abort in line 653 from using the "say" verb
- c 13 Oct 1987 with suspend and resume feature--2-byte storage
- c =====================================================================
- c
- c Differences from Honeywell version to live with MS FORTRAN 77:
- c 1. Can't EQUIVALENCE anything in COMMON or storage is bad.
- c 2. LOGICAL functions can't have integer arguments--doesn't work.
- c All were rewritten to be INTEGER functions (1=true,0=false)
- c 3. Data Base is binary file written by separate program to
- c save space and time. Limited to 64K. I/O is slowww...
- c 4. SAVE feature saves data arrays instead of whole program.
- c RESUME must be given first turn, which reads file.
- c 5. Demonstration game and wizard stuff is gone...stupid anyway..
- c
- c Current limits:
- c 21150 words of message text (lines, linsiz)
- c 745 travel options (travel, trvsiz).
- c 295 vocabulary words (ktab, atab, tabsiz).
- c 150 locations (ltext, stext, key, cond, abb, atloc, locsiz).
- c 100 objects (plac, place, fixd, fixed, link (twice), ptext, prop)
- c 35 "action" verbs (actspk, vrbsiz).
- c 205 random messages (rtext, rtxsiz).
- c 12 different player classifications (ctext, cval, clsmax).
- c 20 hints, less 3 (hintlc, hinted, hints, hntsiz).
- c
- c there are also limits which cannot be exceeded due to the structure of
- c the database. (e.g., the vocabulary uses n/1000 to determine word type,
- c so there can't be more than 1000 words.) these upper limits are:
- c 1000 non-synonymous vocabulary words
- c 300 locations
- c 100 objects
- c
- c set metacommands for ms fortran
- $nodebug
- $notstrict
- $storage: 2
- c
- implicit integer*2 (a-z)
- c
- common /txtcom/ rtext
- common /blkcom/ blklin
- common /voccom/ ktab,atab,tabsiz
- common /placom/ atloc,link,place,fixed,holdng
- common /ptxcom/ ptext
- common /abbcom/ abb
- common /concom/ cond
- common /loccom/ loc
- common /procom/ prop, lamp
- common /lincom/ lines
- character*2 lines (21150)
- character*4 wd1,wd2,iz,bl,atab(295),wd1x,wd2x
- character*1 tk(20)
- c
- integer*2 ktab(295),rtext(205),atloc(150)
- integer*2 ltext(150),stext(150),key(150),cond(150),abb(150)
- integer*2 plac(100),place(100),fixd(100),fixed(100),link(200)
- integer*2 actspk(35),ptext(100),prop(100),ctext(12),cval(12)
- integer*2 hintlc(20),hinted(20),hints(20,4),dseen(6),dloc(6)
- integer*2 idondx,odloc(6)
- integer*4 travel(745),itk(20),newloc,linuse,kk,linsiz
- integer*4 ll,izz
- c
- equivalence(izz,iz)
- c
- external ran
- c
- data linsiz/21150/,trvsiz/745/,locsiz/150/,izz/0/,
- . vrbsiz/35/,rtxsiz/205/,clsmax/12/,hntsiz/20/
- data bl/' '/
- c
- c various functions--all integer in ms fortran--1 true 0 false
- c some are statement functions--others independently compiled
- bitset(l,n)=mod(shift(cond(l),-n),2)
- liq2(pbotl)=(1-pbotl)*water+(pbotl/2)*(water+oil)
- liqloc(loc)=liq2((mod(cond(loc)/2*2,8)-5)*mod(cond(loc)/4,2)+1)
- liq(dummy)=liq2(max0(prop(bottle),-1-prop(bottle)))
- c
- c toting(obj) = true if the obj is being carried
- c here(obj) = true if the obj is at "loc" (or is being carried)
- c at(obj) = true if on either side of two-placed object
- c liq(dummy) = object number of liquid in bottle
- c liqloc(loc) = object number of liquid (if any) at loc
- c bitset(l,n) = true if cond(l) has bit n set (bit 0 is units bit)
- c forced(loc) = true if loc moves without asking for input (cond=2)
- c dark(dummy) = true if location "loc" is dark
- c pct(n) = true n% of the time (n integer*2 from 0 to 100)
- c wzdark says whether the loc he's leaving was dark
- c lmwarn says whether he's been warned about lamp going dim
- c closng says whether its closing time yet
- c panic says whether he's found out he's trapped in the cave
- c closed says whether we're all the way closed
- c gaveup says whether he exited via "quit"
- c scorng indicates to the score routine whether we're doing a "score" command
- c yea is random yes/no reply
-
- c description of the database format
- c the data file contains several sections. each begins with a line containing
- c a number identifying the section, and ends with a line containing "-1".
- c
- c section 1: long form descriptions. each line contains a location number,
- c and a line of text. the set of (necessarily adjacent) lines
- c whose numbers are x form the long description of location x.
- c
- c section 2: short form descriptions. same format as long form. not all
- c places have short descriptions.
- c
- c section 3: travel table. each line contains a location number (x), a second
- c location number (y), and a list of motion numbers (see section 4).
- c each motion represents a verb which will go to y if currently at x.
- c y, in turn, is interpreted as follows. let m=y/1000, n=y mod 1000.
- c if n<=300 it is the location to go to.
- c if 300<n<=500 n-300 is used in a computed goto to
- c a section of special code.
- c if n>500 message n-500 from section 6 is printed,
- c and he stays wherever he is.
- c meanwhile, m specifies the conditions on the motion.
- c if m=0 it's unconditional.
- c if 0<m<100 it is done with m% probability.
- c if m=100 unconditional, but forbidden to dwarves.
- c if 100<m<=200 he must be carrying object m-100.
- c if 200<m<=300 must be carrying or in same room as m-200.
- c if 300<m<=400 prop(m mod 100) must *not* be 0.
- c if 400<m<=500 prop(m mod 100) must *not* be 1.
- c if 500<m<=600 prop(m mod 100) must *not* be 2, etc.
- c
- c if the condition (if any) is not met, then the next *different*
- c "destination" value is used (unless it fails to meet *its* conditions,
- c in which case the next is found, etc.). typically, the next dest will
- c be for one of the same verbs, so that its only use is as the alternate
- c destination for those verbs. for instance:
- c 15 110022 29 31 34 35 23 43
- c 15 14 29
- c this says that, from loc 15, any of the verbs 29, 31, etc1. will take
- c him to 22 if he's carrying object 10, and otherwise will go to 14.
- c 11 303008 49
- c 11 9 50
- c this says that, from 11, 49 takes him to 8 unless prop(3)=0, in which
- c case he goes to 9. verb 50 takes him to 9 regardless of prop(3).
- c
- c section 4: vocabulary. each line contains a number (n), and a
- c five-letter word. call m=n/1000. if m=0, then the word is a motion
- c verb for use in travelling (see section 3). else, if m=1, the word is
- c an object. else, if m=2, the word is an action verb (such as "carry"
- c or "attack"). else, if m=3, the word is a special case verb (such as
- c "dig") and n mod 1000 is an index into section 6. objects from 50 to
- c (currently, anyway) 79 are considered treasures (for pirate, closeout).
- c
- c section 5: object descriptions. each line contains a number (n),
- c and a message. if n is from 1 to 100, the message is the "inventory"
- c message for object n. otherwise, n should be 000, 100, 200, etc., and
- c the message should be the description of the preceding object when its
- c prop value is n/100. the n/100 is used only to distinguish multiple
- c messages from multi-line messages; the prop info actually requires all
- c messages for an object to be present and consecutive. properties which
- c produce no message should be given the message ">$<".
- c
- c section 6: arbitrary messages. same format as sections 1, 2, and 5, except
- c the numbers bear no relation to anything (except for special verbs
- c in section 4).
- c
- c section 7: object locations. each line contains an object number and its
- c initial location (zero (or omitted) if none). if the object is
- c immovable, the location is followed by a "-1". if it has two locations
- c (e.g. the grate) the first location is followed with the second, and
- c the object is assumed to be immovable.
- c
- c section 8: action defaults. each line contains an "action-verb" number and
- c the index (in section 6) of the default message for the verb.
- c
- c section 9: liquid assets, etc. each line contains a number (n) and up to 20
- c location numbers. bit n (where 0 is the units bit) is set in cond(loc)
- c for each loc given. the cond bits currently assigned are:
- c 0 light
- c 1 if bit 2 is on: on for oil, off for water
- c 2 liquid asset, see bit 1
- c 3 pirate doesn't go here unless following player
- c other bits are used to indicate areas of interest to "hint" routines:
- c 4 trying to get into cave
- c 5 trying to catch bird
- c 6 trying to deal with snake
- c 7 lost in maze
- c 8 pondering dark room
- c 9 at witt's end
- c cond(loc) is set to 2, overriding all other bits, if loc has forced
- c motion.
- c
- c section 10: class messages. each line contains a number (n), and a
- c message describing a classification of player. the scoring section
- c selects the appropriate message, where each message is considered to
- c apply to players whose scores are higher than the previous n but not
- c higher than this n. note that these scores probably change with every
- c modification (and particularly expansion) of the program.
- c
- c section 11: hints. each line contains a hint number (corresponding to a
- c cond bit, see section 9), the number of turns he must be at the right
- c loc(s) before triggering the hint, the points deducted for taking the
- c hint, the message number (section 6) of the question, and the message
- c number of the hint. these values are stashed in the "hints" array.
- c hntmax is set to the max hint number (<= hntsiz). numbers 1-3 are
- c unusable since cond bits are otherwise assigned, so 2 is used to
- c remember if he's read the clue in the repository, and 3 is used to
- c remember whether he asked for instructions (gets more turns, but loses
- c points).
- c
- c section 12: magic messages. not implemented ibm pc version. stupid.
- c
- c section 0: end of database.
- c
- c clear out the various text-pointer arrays. all text is stored in array
- c lines; each line is preceded by a word pointing to the next pointer (i.e.
- c the word following the end of the line). the pointer is negative if this is
- c first line of a message. the text-pointer arrays contain indices of
- c pointer-words in lines. stext(n) is short description of location n.
- c ltext(n) is long description. ptext(n) points to message for prop(n)=0.
- c successive prop messages are found by chasing pointers. rtext contains
- c section 6's stuff. ctext(n) points to a player-class message.
- c we also clear cond. see description of section 9 for details.
- c
- c the stuff for section 3 is encoded here. each "from-location" gets a
- c contiguous section of the "travel" array. each entry in travel is
- c newloc*1000 + keyword (from section 4, motion verbs), and is negated if
- c this is the last entry for this location. key(n) is the index in travel
- c of the first option at location n.
-
- c here we read in the vocabulary. ktab(n) is the word number, atab(n) is
- c the corresponding word. the -1 at the end of section 4 is left in ktab
- c as an end-marker.
-
- c read in the initial locations for each object. also the immovability info.
- c plac contains initial locations of objects. fixd is -1 for immovable
- c objects (including the snake), or = second loc for two-placed objects.
-
- c read default message numbers for action verbs, store in actspk.
-
- c read info about available liquids and other conditions, store in cond.
-
- c read data for hints.
-
- c having read in the database, certain things are now constructed. props are
- c set to zero. we finish setting up cond by checking for forced-motion travel
- c entries. the plac and fixd arrays are used to set up atloc(n) as the first
- c object at location n, and link(obj) as the next object at the same location
- c as obj. (obj>100 indicates that fixed(obj-100)=loc; link(obj) is still the
- c correct link to use.) abb is zeroed; it controls whether the abbreviated
- c description is printed. counts mod 5 unless "look" is used.
-
- c set up the atloc and link arrays as described above. we'll use the drop
- c suboutine, which prefaces new objects on the lists. since we want things
- c in the other order, we'll run the loop backwards. if the object is in two
- c locs, we drop it twice. this also sets up "place" and "fixed" as copies of
- c "plac" and "fixd". also, since two-placed objects are typically best
- c described last, we'll drop them first.
-
- c treasures, as noted earlier, are objects 50 through maxtrs (currently 79).
- c their props are initially -1, and are set to 0 the first time they are
- c described. tally keeps track of how many are not yet found, so we know
- c when to close the cave. tally2 counts how many can never be found (e.g. if
- c lost bird or bridge).
-
- c clear the hint stuff. hintlc(i) is how long he's been at loc with cond bit
- c i. hinted(i) is true iff hint i has been used.
-
- c define some handy mnemonics. these correspond to object numbers.
-
- c objects from 50 through whatever are treasures. here are a few.
-
- c these are motion-verb numbers.
-
- c and some action verbs.
-
- c initialize the dwarves. dloc is loc of dwarves, hard-wired in. odloc is
- c prior loc of each dwarf, initially garbage. daltlc is alternate initial loc
- c for dwarf, in case one of them starts out on top of the adventurer. (no 2
- c of the 5 initial locs are adjacent.) dseen is true if dwarf has seen him.
- c dflag controls the level of activation of all this:
- c 0 no dwarf stuff yet (wait until reaches hall of mists)
- c 1 reached hall of mists, but hasn't met first dwarf
- c 2 met first dwarf, others start moving, no knives thrown yet
- c 3 a knife has been thrown (first set always misses)
- c 3+ dwarves are mad (increases their accuracy)
- c sixth dwarf is special (the pirate). he always starts at his chest's
- c eventual location inside the maze. this loc is saved in chloc for ref.
- c the dead end in the other maze has its loc stored in chloc2.
-
- c other random flags and counters, as follows:
- c turns tallies how many commands he's given (ignores yes/no)
- c limit lifetime of lamp (not set here)
- c iwest how many times he's said "west" instead of "w"
- c knfloc 0 if no knife here, loc if knife here, -1 after caveat
- c detail how often we've said "not allowed to give more detail"
- c abbnum how often we should print non-abbreviated descriptions
- c maxdie number of reincarnation messages available (up to 5)
- c numdie number of times killed so far
- c holdng number of objects being carried
- c dkill number of dwarves killed (unused in scoring, needed for msg)
- c foobar current progress in saying "fee fie foe foo".
- c bonus used to determine amount of bonus if he reaches closing
- c clock1 number of turns from finding last treasure till closing
- c clock2 number of turns from first warning till blinding flash
- c logicals were explained earlier
-
- c read the database--resume restores variables at 8305 and proceeds
- c
- write (*,1000)
- 1000 format(//////////////,
- . ' Adventure! (The original Colossal Cave!)',
- . ///,' (Implemented for MS DOS in PDS FORTRAN v5.10',
- . /,' by Paul Muñoz-Colman, FunStuff Software.',
- . /,' Version 27 March 1993.)',
- . ////////,' Initializing, Please Wait ...')
- c
- open (1, file='ad.dat', form='unformatted')
- c
- c read the data base in array format
- c
- read (1) abbnum,axe,back,batter,bear,bird,bonus,bottle,
- . cage,cave,chain,chasm,chest,chloc,chloc2,clam,
- . clock1,clock2,closed,closng,coins,daltlc,detail,dflag,
- . dkill,dloc,door,dprssn,dragon,dseen,dwarf,eggs,
- . emrald,entrnc,find,fissur,foobar,food,gaveup,grate
- c
- read (1) invent,iwest,keys,knfloc,knife,lamp,lmwarn,
- . lock,look,magzin,maxdie,maxtrs,messag,mirror,nugget,
- . null,numdie,oil,oyster,panic,pearl,pillow,plant,
- . plant2,pyram,rod,rod2,rug,saved,say,scorng,
- . snake,spices,steps,tablet,tally,tally2,throw,tridnt,
- . troll,troll2,turns,vase,vend,water,tabsiz,blklin,oldloc,fixed
- c
- read (1) linuse,trvs,tabndx,obj,verb,clsses,hntmax,loc,newloc,
- . k,j,stext,ltext,ptext,rtext,ctext,cval,key,
- . travel,ktab,plac,fixd,actspk,cond,hints,place,prop,link,
- . abb,atloc,holdng,hinted,hintlc,kk,i,itk,atab,lines
- c
- close (1)
-
- write (*,10001)
- 10001 format('+ ')
-
- c start-up, dwarf stuff
- c
- 1 i=ran(1)
- hinted(3)=yes(65,1,0)
- newloc=1
- limit=330
- if(hinted(3).eq.1)limit=1000
-
- c can't leave cave once it's closing (except by main office).
-
- 2 if(newloc.ge.9.or.newloc.eq.0.or.closng.eq.0) go to 71
- call rspeak(130)
- newloc=loc
- if(panic.eq.0)clock2=15
- panic=1
-
- c see if a dwarf has seen him and has come from where he wants to go. if so,
- c the dwarf's blocking his way. if coming from place forbidden to pirate
- c (dwarves rooted in place) let him get out (and attacked).
-
- 71 if(newloc.eq.loc.or.forced(loc).eq.1.or.bitset(loc,3).eq.1)goto74
- do 73 i=1,5
- if(odloc(i).ne.newloc.or.dseen(i).eq.0)goto 73
- newloc=loc
- call rspeak(2)
- goto 74
- 73 continue
- 74 loc=newloc
-
- c dwarf stuff. see earlier comments for description of variables. remember
- c sixth dwarf is pirate and is thus very different except for motion rules.
-
- c first off, don't let the dwarves follow him into a pit or a wall. activate
- c the whole mess the first time he gets as far as the hall of mists (loc 15).
- c if newloc is forbidden to pirate (in particular, if it's beyond the troll
- c bridge), bypass dwarf stuff. that way pirate can't steal return toll, and
- c dwarves can't meet the bear. also means dwarves won't follow him into dead
- c end in maze, but c'est la vie. they'll wait for him outside the dead end.
-
- nl=newloc
- if(loc.eq.0.or.forced(loc).eq.1.or.bitset(nl,3).eq.1)goto2000
- if(dflag.ne.0)goto 6000
- if(loc.ge.15)dflag=1
- goto 2000
-
- c when we encounter the first dwarf, we kill 0, 1, or 2 of the 5 dwarves. if
- c any of the survivors is at loc, replace him with the alternate.
-
- 6000 if(dflag.ne.1)goto 6010
- if(loc.lt.15.or.pct(95).eq.1)goto 2000
- dflag=2
- do 6001 i=1,2
- j=1+ran(5)
- 6001 if(pct(50).eq.1) dloc(j)=0
- do 6002 i=1,5
- if(dloc(i).eq.loc)dloc(i)=daltlc
- 6002 odloc(i)=dloc(i)
- call rspeak(3)
- call drop(axe,loc)
- goto 2000
-
- c things are in full swing. move each dwarf at random, except if he's seen us
- c he sticks with us. dwarves never go to locs <15. if wandering at random,
- c they don't back up unless there's no alternative. if they don't have to
- c move, they attack. and, of course, dead dwarves don't do much of anything.
-
- 6010 dtotal=0
- attack=0
- stick=0
- do 6030 i=1,6
- if(dloc(i).eq.0)goto 6030
- j=1
- kk=dloc(i)
- kk=key(kk)
- if(kk.eq.0)goto 6016
- 6012 newloc=mod(iabs(travel(kk))/1000,1000)
- nl=newloc
- trv=iabs(travel(kk))/1000000
- itk2=itk(j-1)
- if(nl.gt.300.or.nl.lt.15.or.nl.eq.odloc(i)
- . .or.(j.gt.1.and.nl.eq.itk2) .or.j.ge.20
- . .or.nl.eq.dloc(i).or.forced(nl).eq.1
- . .or.(i.eq.6.and.bitset(nl,3).eq.1)
- . .or.trv.eq.100) go to 6014
- itk(j)=newloc
- j=j+1
- 6014 kk=kk+1
- if(travel(kk-1).ge.0)goto 6012
- 6016 itk(j)=odloc(i)
- if(j.ge.2)j=j-1
- j=1+ran(j)
- odloc(i)=dloc(i)
- dloc(i)=itk(j)
- zzz=0
- if (dseen(i).eq.1.and.loc.ge.15) zzz=1
- dseen(i)=0
- if (zzz.eq.1.or.(dloc(i).eq.loc.or.odloc(i).eq.loc))dseen(i)=1
- if(dseen(i).eq.0) go to 6030
- dloc(i)=loc
- if(i.ne.6)goto 6027
-
- c the pirate's spotted him. he leaves him alone once we've found chest.
- c k counts if a treasure is here. if not, and tally=tally2 plus one for
- c an unseen chest, let the pirate be spotted.
-
- if(loc.eq.chloc.or.prop(chest).ge.0)goto 6030
- k=0
- do 6020 j=50,maxtrs
- c pirate won't take pyramid from plover room or dark room (too easy!).
- if(j.eq.pyram.and.(loc.eq.plac(pyram)
- . .or.loc.eq.plac(emrald)))goto 6020
- idondx=j
- if(toting(idondx).eq.1)goto 6022
- 6020 if(here(idondx).eq.1)k=1
- if(tally.eq.tally2+1.and.k.eq.0.and.place(chest).eq.0
- . .and.here(lamp).eq.1.and.prop(lamp).eq.1)goto 6025
- if(odloc(6).ne.dloc(6).and.pct(20).eq.1)call rspeak(127)
- goto 6030
-
- 6022 call rspeak(128)
- c don't steal chest back from troll!
- if(place(messag).eq.0)call move(chest,chloc)
- call move(messag,chloc2)
- do 6023 j=50,maxtrs
- if(j.eq.pyram.and.(loc.eq.plac(pyram)
- . .or.loc.eq.plac(emrald)))goto 6023
- idondx=j
- if(at(idondx).eq.1.and.fixed(idondx).eq.0)
- . call carry(idondx,loc)
- if(toting(idondx).eq.1)call drop(idondx,chloc)
- 6023 continue
- 6024 dloc(6)=chloc
- odloc(6)=chloc
- dseen(6)=0
- goto 6030
-
- 6025 call rspeak(186)
- call move(chest,chloc)
- call move(messag,chloc2)
- goto 6024
-
- c this threatening little dwarf is in the room with him!
-
- 6027 dtotal=dtotal+1
- if(odloc(i).ne.dloc(i))goto 6030
- attack=attack+1
- if(knfloc.ge.0)knfloc=loc
- if(ran(1000).lt.95*(dflag-2))stick=stick+1
- 6030 continue
-
- c now we know what's happening. let's tell the poor sucker about it.
-
- if(dtotal.eq.0)goto 2000
- if(dtotal.eq.1)goto 75
- write (*,67) dtotal
- 67 format(/' There are ',i1,' THREATENING LITTLE DWARVES in the'
- .,' room with you.')
- goto 77
- 75 call rspeak(4)
- 77 if(attack.eq.0)goto 2000
- if(dflag.eq.2)dflag=3
- if(attack.eq.1)goto 79
- write (*,78) attack
- 78 format(/' ',i1,' of them THROW KNIVES at you!')
- k=6
- 82 if(stick.gt.1)goto 83
- call rspeak(k+stick)
- if(stick.eq.0)goto 2000
- goto 84
- 83 write (*,68) stick
- 68 format(/' ',i1,' of them get you!')
- 84 oldlc2=loc
- goto 99
-
- 79 call rspeak(5)
- k=52
- goto 82
- c describe the current location and (maybe) get next command.
-
- c print text for current loc.
-
- 2000 if(loc.eq.0)goto 99
- kk=stext(loc)
- if(mod(abb(loc),abbnum).eq.0.or.kk.eq.0)kk=ltext(loc)
- if(forced(loc).eq.1.or.dark(0).eq.0)goto 2001
- if(wzdark.eq.1.and.pct(35).eq.1)goto 90
- kk=rtext(16)
- 2001 if(toting(bear).eq.1)call rspeak(141)
- kk2=kk
- call speak(kk2)
- k=1
- if(forced(loc).eq.1)goto 8
- if(loc.eq.33.and.pct(25).eq.1.and.closng.eq.0)call rspeak(8)
-
- c print out descriptions of objects at this location. if not closing and
- c property value is negative, tally off another treasure. rug is special
- c case; once seen, its prop is 1 (dragon on it) till dragon is killed.
- c similarly for chain; prop is initially 1 (locked to bear). these hacks
- c are because prop=0 is needed to get full score.
-
- if(dark(0).eq.1)goto 2012
- abb(loc)=abb(loc)+1
- i=atloc(loc)
- blklin=1
- 2004 if(i.eq.0)goto 2012
- obj=i
- if(obj.gt.100)obj=obj-100
- if(obj.eq.steps.and.toting(nugget).eq.1)goto 2008
- if(prop(obj).ge.0)goto 2006
- if(closed.eq.1)goto 2008
- prop(obj)=0
- if(obj.eq.rug.or.obj.eq.chain)prop(obj)=1
- tally=tally-1
- c if remaining treasures too elusive, zap his lamp.
- if(tally.eq.tally2.and.tally.ne.0)limit=min0(35,limit)
- 2006 kk=prop(obj)
- if(obj.eq.steps.and.loc.eq.fixed(steps))kk=1
- kk2=kk
- call pspeak(obj,kk2)
- if (blklin.eq.1) blklin=0
- 2008 i=link(i)
- goto 2004
-
- 2009 k=54
- 2010 spk=k
- 2011 call rspeak(spk)
-
- 2012 verb=0
- obj=0
- blklin=1
-
- c check if this loc is eligible for any hints. if been here long enough,
- c branch to help section (on later page). hints all come back here eventually
- c to finish the loop. ignore "hints" < 4 (special stuff, see database notes).
-
- 2600 do 2602 hint=4,hntmax
- if(hinted(hint).eq.1)goto 2602
- idondx=hint
- if(bitset(loc,idondx).eq.0)hintlc(hint)=-1
- hintlc(hint)=hintlc(hint)+1
- if(hintlc(hint).ge.hints(hint,1))goto 40000
- 2602 continue
-
- c kick the random number generator just to add variety to the chase. also,
- c if closing time, check for any objects being toted with prop < 0 and set
- c the prop to -1-prop. this way objects won't be described until they've
- c been picked up and put down seperate from their seperate piles. don't
- c tick clock1 unless well into cave (and not at y2).
- c
- 26021 continue
- if(closed.eq.0)goto 2605
- if(prop(oyster).lt.0.and.toting(oyster).eq.1)
- . call pspeak(oyster,1)
- do 2604 i=1,100
- idondx=i
- 2604 if(toting(idondx).eq.1.and.prop(idondx).lt.0)
- . prop(idondx)=-1-prop(idondx)
- 2605 wzdark=dark(0)
- if(knfloc.gt.0.and.knfloc.ne.loc)knfloc=0
- i=ran(1)
- call getin(wd1,wd1x,wd2,wd2x)
-
- c every input, check "foobar" flag. if zero, nothing's going on. if pos,
- c make neg. if neg, he skipped a word, so make it zero.
-
- 2608 foobar=min0(0,-foobar)
- if (turns.eq.0.and.wd1.eq.'resu')go to 8305
- turns=turns+1
- if(verb.eq.say.and.wd2.ne.iz)verb=0
- if(verb.eq.say)goto 4090
- if(tally.eq.0.and.loc.ge.15.and.loc.ne.33)clock1=clock1-1
- if(clock1.eq.0)goto 10000
- if(clock1.lt.0)clock2=clock2-1
- if(clock2.eq.0)goto 11000
- if(prop(lamp).eq.1)limit=limit-1
- if(limit.le.30.and.here(batter).eq.1.and.prop(batter).eq.0
- . .and.here(lamp).eq.1)goto 12000
- if(limit.eq.0)goto 12400
- if(limit.lt.0.and.loc.le.8)goto 12600
- if(limit.le.30)goto 12200
- 19999 k=43
- if(liqloc(loc).eq.water)k=70
- if(wd1.eq.'ente'.and.(wd2.eq.'stre'.or.wd2.eq.'wate'))
- . goto 2010
- if(wd1.eq.'ente'.and.wd2.ne.iz)goto 2800
- if((wd1.ne.'wate'.and.wd1.ne.'oil ')
- . .or.(wd2.ne.'plan'.and.wd2.ne.'door'))goto 2610
- if(at(vocab(wd2,1)).eq.1)wd2='pour'
- 2610 if(wd1.ne.'west')goto 2630
- iwest=iwest+1
- if(iwest.eq.10)call rspeak(17)
- 2630 i=vocab(wd1,-1)
- if(i.eq.-1)goto 3000
- k=mod(i,1000)
- kq=i/1000+1
- if(kq.gt.4) call bug(22)
- goto (8,5000,4000,2010),kq
-
- c get second word for analysis.
-
- 2800 wd1=wd2
- wd1x=wd2x
- wd2=iz
- goto 2610
-
- c gee, i don't understand.
-
- 3000 spk=60
- if(pct(20).eq.1)spk=61
- if(pct(20).eq.1)spk=13
- call rspeak(spk)
- goto 2600
-
- c analyze a verb. remember what it was, go back for object if second word
- c unless verb is "say", which snarfs arbitrary second word.
-
- 4000 verb=k
- spk=actspk(verb)
- if(wd2.ne.iz.and.verb.ne.say)goto 2800
- if(verb.eq.say)obj=wd2
- if(verb.gt.31)call bug(23)
- if(obj.ne.0)goto 4090
-
- c analyze an intransitive verb (ie, no object given yet).
-
- 4080 goto(8010,8000,8000,8040,2009,8040,9070,9080,8000,8000,
- . 2011,9120,9130,8140,9150,8000,8000,8180,8000,8200,
- . 8000,9220,9230,8240,8250,8260,8270,8000,8000,8300,
- . 8310),verb
- c take drop say open noth lock on off wave calm
- c walk kill pour eat drnk rub toss quit find invn
- c feed fill blst scor foo brf read brek wake susp
- c hour
-
- c analyze a transitive verb.
-
- 4090 goto(9010,9020,9030,9040,2009,9040,9070,9080,9090,2011,
- . 2011,9120,9130,9140,9150,9160,9170,2011,9190,9190,
- . 9210,9220,9230,2011,2011,2011,9270,9280,9290,2011,
- . 2011),verb
- c take drop say open noth lock on off wave calm
- c walk kill pour eat drnk rub toss quit find invn
- c feed fill blst scor foo brf read brek wake susp
- c hour
-
- c analyze an object word. see if the thing is here, whether we've got a verb
- c yet, and so on. object must be here unless verb is "find" or "invent(ory)"
- c (and no new verb yet to be analyzed). water and oil are also funny, since
- c they are never actually dropped at any location, but might be here inside
- c the bottle or as a feature of the location.
-
- 5000 obj=k
- if(fixed(k).ne.loc.and.here(k).eq.0)goto 5100
- 5010 if(wd2.ne.iz)goto 2800
- if(verb.ne.0)goto 4090
- call a5toa1(wd1,wd1x,'? ',' ',tk,k)
- write (*,5015) (tk(i),i=1,k)
- 5015 format(/' What do you want to do with the ',20a1)
- goto 2600
-
- 5100 if(k.ne.grate)goto 5110
- if(loc.eq.1.or.loc.eq.4.or.loc.eq.7)k=dprssn
- if(loc.gt.9.and.loc.lt.15)k=entrnc
- if(k.ne.grate)goto 8
- 5110 if(k.ne.dwarf)goto 5120
- do 5112 i=1,5
- if(dloc(i).eq.loc.and.dflag.ge.2)goto 5010
- 5112 continue
- 5120 if((liq(0).eq.k.and.here(bottle).eq.1).or.k.eq.liqloc(loc))
- . go to 5010
- if(obj.ne.plant.or.at(plant2).eq.0.or.prop(plant2).eq.0)goto 5130
- obj=plant2
- goto 5010
- 5130 if(obj.ne.knife.or.knfloc.ne.loc)goto 5140
- knfloc=-1
- spk=116
- goto 2011
- 5140 if(obj.ne.rod.or.here(rod2).eq.0)go to 5190
- obj=rod2
- goto 5010
- 5190 if((verb.eq.find.or.verb.eq.invent).and.wd2.eq.iz)goto 5010
- call a5toa1(wd1,wd1x,' her','e. ',tk,k)
- write (*,5199) (tk(i),i=1,k)
- 5199 format(/' I see no ',20a1)
- goto 2012
- c figure out the new location
- c
- c given the current location in "loc", and a motion verb number in "k", put
- c the new location in "newloc". the current loc is saved in "oldloc" in case
- c he wants to retreat. the current oldloc is saved in oldlc2, in case he
- c dies. (if he does, newloc will be limbo, and oldloc will be what killed
- c him, so we need oldlc2, which is the last place he was safe.)
-
- 8 kk=key(loc)
- newloc=loc
- if(kk.eq.0)call bug(26)
- if(k.eq.null)goto 2
- if(k.eq.back)goto 20
- if(k.eq.look)goto 30
- if(k.eq.cave)goto 40
- oldlc2=oldloc
- oldloc=loc
-
- 9 ll=iabs(travel(kk))
- if(mod(ll,1000).eq.1.or.mod(ll,1000).eq.k)goto 10
- if(travel(kk).lt.0)goto 50
- kk=kk+1
- goto 9
-
- 10 ll=ll/1000
- 11 newloc=ll/1000
- k=mod(newloc,100)
- if(newloc.le.300)goto 13
- nl=newloc
- if(prop(k).ne.((nl/100)-3)) go to 16
- 12 if(travel(kk).lt.0)call bug(25)
- kk=kk+1
- newloc=iabs(travel(kk))/1000
- if(newloc.eq.ll)goto 12
- ll=newloc
- goto 11
-
- 13 if(newloc.le.100)goto 14
- nl=newloc
- if(toting(k).eq.1.or.(nl.gt.200.and.at(k).eq.1))goto 16
- goto 12
-
- 14 nl=newloc
- if(nl.ne.0.and.pct(nl).eq.0) go to 12
- 16 newloc=mod(ll,1000)
- if(newloc.le.300)goto 2
- if(newloc.le.500)goto 30000
- nl=newloc
- call rspeak(nl-500)
- newloc=loc
- goto 2
-
- c special motions come here. labelling convention: statement numbers nnnxxc (
-
- 30000 newloc=newloc-300
- if(newloc.gt.3)call bug(20)
- goto (30100,30200,30300),newloc
-
- c travel 301. plover-alcove passage. can carry only emerald. note: travel
- c table must include "useless" entries going through passage, which can never
- c be used for actual motion, but can be spotted by "go back".
-
- 30100 newloc=99+100-loc
- if(holdng.eq.0.or.(holdng.eq.1.and.toting(emrald).eq.1))goto 2
- newloc=loc
- call rspeak(117)
- goto 2
-
- c travel302. plover transport. drop the emerald (only use special travel if
- c toting it), so he's forced to use the plover-passage to get it out. having
- c dropped it, go back and pretend he wasn't carrying it after all.
-
- 30200 call drop(emrald,loc)
- goto 12
-
- c travel 303. troll bridge. must be done only as special motion so that
- c dwarves won't wander across and encounter the bear. (they won't follow the
- c player there because that region is forbidden to the pirate.) if
- c prop(troll)=1, he's crossed since paying, so step out and block him.
- c (standard travel entries check for prop(troll)=0.) special stuff for bear.
-
- 30300 if(prop(troll).ne.1)goto 30310
- call pspeak(troll,1)
- prop(troll)=0
- call move(troll2,0)
- call move(troll2+100,0)
- call move(troll,plac(troll))
- call move(troll+100,fixd(troll))
- call juggle(chasm)
- newloc=loc
- goto 2
-
- 30310 newloc=plac(troll)+fixd(troll)-loc
- if(prop(troll).eq.0)prop(troll)=1
- if(toting(bear).eq.0)goto 2
- call rspeak(162)
- prop(chasm)=1
- prop(troll)=2
- nl=newloc
- call drop(bear,nl)
- fixed(bear)=-1
- prop(bear)=3
- if(prop(spices).lt.0)tally2=tally2+1
- oldlc2=newloc
- goto 99
-
- c end of specials.
-
- c handle "go back". look for verb which goes from loc to oldloc, or to oldlc2
- c if oldloc has forced-motion. k2 saves entry -> forced loc -> previous loc.
-
- 20 k=oldloc
- if(forced(k).eq.1)k=oldlc2
- oldlc2=oldloc
- oldloc=loc
- k2=0
- if(k.ne.loc)goto 21
- call rspeak(91)
- goto 2
-
- 21 ll=mod((iabs(travel(kk))/1000),1000)
- if(ll.eq.k)goto 25
- if(ll.gt.300)goto 22
- j=key(ll)
- ls=ll
- trv=mod((iabs(travel(j))/1000),1000)
- if(forced(ls).eq.1.and.trv.eq.k)
- . k2=kk
- 22 if(travel(kk).lt.0)goto 23
- kk=kk+1
- goto 21
-
- 23 kk=k2
- if(kk.ne.0)goto 25
- call rspeak(140)
- goto 2
-
- 25 k=mod(iabs(travel(kk)),1000)
- kk=key(loc)
- goto 9
-
- c look. can't give more detail. pretend it wasn't dark (though it may "now"
- c be dark) so he won't fall into a pit while staring into the gloom.
-
- 30 if(detail.lt.3)call rspeak(15)
- detail=detail+1
- wzdark=0
- abb(loc)=0
- goto 2
-
- c cave. different messages depending on whether above ground.
-
- 40 if(loc.lt.8)call rspeak(57)
- if(loc.ge.8)call rspeak(58)
- goto 2
-
- c non-applicable motion. various messages depending on word given.
-
- 50 spk=12
- if(k.ge.43.and.k.le.50)spk=9
- if(k.eq.29.or.k.eq.30)spk=9
- if(k.eq.7.or.k.eq.36.or.k.eq.37)spk=10
- if(k.eq.11.or.k.eq.19)spk=11
- if(verb.eq.find.or.verb.eq.invent)spk=59
- if(k.eq.62.or.k.eq.65)spk=42
- if(k.eq.17)spk=80
- call rspeak(spk)
- goto 2
- c "you're dead, jim."
- c
- c if the current loc is zero, it means the clown got himself killed. we'll
- c allow this maxdie times. maxdie is automatically set based on the number of
- c snide messages available. each death results in a message (81, 83, etc.)
- c which offers reincarnation; if accepted, this results in message 82, 84,
- c etc. the last time, if he wants another chance, he gets a snide remark as
- c we exit. when reincarnated, all objects being carried get dropped at oldlc2
- c (presumably the last place prior to being killed) without change of props.
- c the loop runs backwards to assure that the bird is dropped before the cage.
- c (this kluge could be changed once we're sure all references to bird and cage
- c are done by keywords.) the lamp is a special case (it wouldn't do to leave
- c it in the cave). it is turned off and left outside the building (only if he
- c was carrying it, of course). he himself is left inside the building (and
- c heaven help him if he tries to xyzzy back into the cave without the lamp).
- c oldloc is zapped so he can't just "retreat".
-
- c the easiest way to get killed is to fall into a pit in pitch darkness.
-
- 90 call rspeak(23)
- oldlc2=loc
-
- c okay, he's dead. let's get on with it.
-
- 99 if(closng.eq.1)goto 95
- yea=yes(81+numdie*2,82+numdie*2,54)
- numdie=numdie+1
- if(numdie.eq.maxdie.or.yea.eq.0)goto 20000
- place(water)=0
- place(oil)=0
- if(toting(lamp).eq.1)prop(lamp)=0
- do 98 j=1,100
- i=101-j
- if(toting(i).eq.0)goto 98
- k=oldlc2
- if(i.eq.lamp)k=1
- call drop(i,k)
- 98 continue
- loc=3
- oldloc=loc
- goto 2000
-
- c he died during closing time. no resurrection. tally up a death and exit.
-
- 95 call rspeak(131)
- numdie=numdie+1
- goto 20000
- c routines for performing the various action verbs
-
- c statement numbers in this section are 8000 for intransitive verbs, 9000 for
- c transitive, plus ten times the verb number. many intransitive verbs use the
- c transitive code, and some verbs use code for other verbs, as noted below.
-
- c random intransitive verbs come here. clear obj just in case (see "attack").
-
- 8000 call a5toa1(wd1,wd1x,' wha','t? ',tk,k)
- write (*,8002) (tk(i),i=1,k)
- 8002 format(/' ',20a1)
- obj=0
- goto 2600
-
- c carry, no object given yet. ok if only one object present.
-
- 8010 if(atloc(loc).eq.0.or.link(atloc(loc)).ne.0)goto 8000
- do 8012 i=1,5
- if(dloc(i).eq.loc.and.dflag.ge.2)goto 8000
- 8012 continue
- obj=atloc(loc)
-
- c carry an object. special cases for bird and cage (if bird in cage, can't
- c take one without the other. liquids also special, since they depend on
- c status of bottle. also various side effects, etc.
-
- 9010 if(toting(obj).eq.1)goto 2011
- spk=25
- if(obj.eq.plant.and.prop(plant).le.0)spk=115
- if(obj.eq.bear.and.prop(bear).eq.1)spk=169
- if(obj.eq.chain.and.prop(bear).ne.0)spk=170
- if(fixed(obj).ne.0)goto 2011
- if(obj.ne.water.and.obj.ne.oil)goto 9017
- if(here(bottle).eq.1.and.liq(0).eq.obj)goto 9018
- obj=bottle
- if(toting(bottle).eq.1.and.prop(bottle).eq.1)goto 9220
- if(prop(bottle).ne.1)spk=105
- if(toting(bottle).eq.0)spk=104
- goto 2011
- 9018 obj=bottle
- 9017 if(holdng.lt.7)goto 9016
- call rspeak(92)
- goto 2012
- 9016 if(obj.ne.bird)goto 9014
- if(prop(bird).ne.0)goto 9014
- if(toting(rod).eq.0)goto 9013
- call rspeak(26)
- goto 2012
- 9013 if(toting(cage).eq.1)goto 9015
- call rspeak(27)
- goto 2012
- 9015 prop(bird)=1
- 9014 if((obj.eq.bird.or.obj.eq.cage).and.prop(bird).ne.0)
- . call carry(bird+cage-obj,loc)
- call carry(obj,loc)
- k=liq(0)
- if(obj.eq.bottle.and.k.ne.0)place(k)=-1
- goto 2009
-
- c discard object. "throw" also comes here for most objects. special cases for
- c bird (might attack snake or dragon) and cage (might contain bird) and vase.
- c drop coins at vending machine for extra batteries.
-
- 9020 if(toting(rod2).eq.1.and.obj.eq.rod.and.toting(rod).eq.0)obj=rod2
- if(toting(obj).eq.0)goto 2011
- if(obj.ne.bird.or.here(snake).eq.0)goto 9024
- call rspeak(30)
- if(closed.eq.1)goto 19000
- call dstroy(snake)
- c set prop for use by travel options
- prop(snake)=1
- 9021 k=liq(0)
- if(k.eq.obj)obj=bottle
- if(obj.eq.bottle.and.k.ne.0)place(k)=0
- if(obj.eq.cage.and.prop(bird).ne.0)call drop(bird,loc)
- if(obj.eq.bird)prop(bird)=0
- call drop(obj,loc)
- goto 2012
-
- 9024 if(obj.ne.coins.or.here(vend).eq.0)goto 9025
- call dstroy(coins)
- call drop(batter,loc)
- call pspeak(batter,0)
- goto 2012
-
- 9025 if(obj.ne.bird.or.at(dragon).eq.0.or.prop(dragon).ne.0)goto 9026
- call rspeak(154)
- call dstroy(bird)
- prop(bird)=0
- if(place(snake).eq.plac(snake))tally2=tally2+1
- goto 2012
-
- 9026 if(obj.ne.bear.or.at(troll).eq.0)goto 9027
- call rspeak(163)
- call move(troll,0)
- call move(troll+100,0)
- call move(troll2,plac(troll))
- call move(troll2+100,fixd(troll))
- call juggle(chasm)
- prop(troll)=2
- goto 9021
-
- 9027 if(obj.eq.vase.and.loc.ne.plac(pillow))goto 9028
- call rspeak(54)
- goto 9021
-
- 9028 prop(vase)=2
- if(at(pillow).eq.1)prop(vase)=0
- call pspeak(vase,prop(vase)+1)
- if(prop(vase).ne.0)fixed(vase)=-1
- goto 9021
-
- c say. echo wd2 (or wd1 if no wd2 (say what?, etc.).) magic words override.
-
- 9030 call a5toa1(wd2,wd2x,'". ',' ',tk,k)
- if(wd2.eq.iz)call a5toa1(wd1,wd1x,'". ',' ',tk,k)
- if(wd2.ne.iz)wd1=wd2
- i=vocab(wd1,-1)
- if(i.eq.62.or.i.eq.65.or.i.eq.71.or.i.eq.2025)goto 9035
- write (*,9032) (tk(i),i=1,k)
- 9032 format(/' Okay, "',20a1)
- goto 2012
-
- 9035 wd2=iz
- obj=0
- goto 2630
-
- c lock, unlock, no object given. assume various things if present.
-
- 8040 spk=28
- if(here(clam).eq.1)obj=clam
- if(here(oyster).eq.1)obj=oyster
- if(at(door).eq.1)obj=door
- if(at(grate).eq.1)obj=grate
- if(obj.ne.0.and.here(chain).eq.1)goto 8000
- if(here(chain).eq.1)obj=chain
- if(obj.eq.0)goto 2011
-
- c lock, unlock object. special stuff for opening clam/oyster and for chain.
-
- 9040 if(obj.eq.clam.or.obj.eq.oyster)goto 9046
- if(obj.eq.door)spk=111
- if(obj.eq.door.and.prop(door).eq.1)spk=54
- if(obj.eq.cage)spk=32
- if(obj.eq.keys)spk=55
- if(obj.eq.grate.or.obj.eq.chain)spk=31
- if(spk.ne.31.or.here(keys).eq.0)goto 2011
- if(obj.eq.chain)goto 9048
- if(closng.eq.0)goto 9043
- k=130
- if(panic.eq.0)clock2=15
- panic=1
- goto 2010
-
- 9043 k=34+prop(grate)
- prop(grate)=1
- if(verb.eq.lock)prop(grate)=0
- k=k+2*prop(grate)
- goto 2010
-
- c clam/oyster.
- 9046 k=0
- if(obj.eq.oyster)k=1
- spk=124+k
- if(toting(obj).eq.1)spk=120+k
- if(toting(tridnt).eq.0)spk=122+k
- if(verb.eq.lock)spk=61
- if(spk.ne.124)goto 2011
- call dstroy(clam)
- call drop(oyster,loc)
- call drop(pearl,105)
- goto 2011
-
- c chain.
- 9048 if(verb.eq.lock)goto 9049
- spk=171
- if(prop(bear).eq.0)spk=41
- if(prop(chain).eq.0)spk=37
- if(spk.ne.171)goto 2011
- prop(chain)=0
- fixed(chain)=0
- if(prop(bear).ne.3)prop(bear)=2
- fixed(bear)=2-prop(bear)
- goto 2011
-
- 9049 spk=172
- if(prop(chain).ne.0)spk=34
- if(loc.ne.plac(chain))spk=173
- if(spk.ne.172)goto 2011
- prop(chain)=2
- if(toting(chain).eq.1)call drop(chain,loc)
- fixed(chain)=-1
- goto 2011
-
- c light lamp
-
- 9070 if(here(lamp).eq.0)goto 2011
- spk=184
- if(limit.lt.0)goto 2011
- prop(lamp)=1
- call rspeak(39)
- if(wzdark.eq.1)goto 2000
- goto 2012
-
- c lamp off
-
- 9080 if(here(lamp).eq.0)goto 2011
- prop(lamp)=0
- call rspeak(40)
- if(dark(0).eq.1)call rspeak(16)
- goto 2012
-
- c wave. no effect unless waving rod at fissure.
-
- 9090 if((toting(obj)).eq.0.and.(obj.ne.rod.or.toting(rod2).eq.0))
- . spk=29
- if(obj.ne.rod.or.at(fissur).eq.0.or.toting(obj).eq.0
- . .or.closng.eq.1)go to 2011
- prop(fissur)=1-prop(fissur)
- call pspeak(fissur,2-prop(fissur))
- goto 2012
-
- c attack. assume target if unambiguous. "throw" also links here. attackable
- c objects fall into two categories: enemies (snake, dwarf, etc.) and others
- c (bird, clam). ambiguous if two enemies, or if no enemies but two others.
-
- 9120 do 9121 i=1,5
- if(dloc(i).eq.loc.and.dflag.ge.2)goto 9122
- 9121 continue
- i=0
- 9122 if(obj.ne.0)goto 9124
- if(i.ne.0)obj=dwarf
- if(here(snake).eq.1)obj=obj*100+snake
- if(at(dragon).eq.1.and.prop(dragon).eq.0)obj=obj*100+dragon
- if(at(troll).eq.1)obj=obj*100+troll
- if(here(bear).eq.1.and.prop(bear).eq.0)obj=obj*100+bear
- if(obj.gt.100)goto 8000
- if(obj.ne.0)goto 9124
- c can't attack bird by throwing axe.
- if(here(bird).eq.1.and.verb.ne.throw)obj=bird
- c clam and oyster both treated as clam for intransitive case; no harm done.
- if(here(clam).eq.1.or.here(oyster).eq.1)obj=100*obj+clam
- if(obj.gt.100)goto 8000
- 9124 if(obj.ne.bird)goto 9125
- spk=137
- if(closed.eq.1)goto 2011
- call dstroy(bird)
- prop(bird)=0
- if(place(snake).eq.plac(snake))tally2=tally2+1
- spk=45
- 9125 if(obj.eq.0)spk=44
- if(obj.eq.clam.or.obj.eq.oyster)spk=150
- if(obj.eq.snake)spk=46
- if(obj.eq.dwarf)spk=49
- if(obj.eq.dwarf.and.closed.eq.1)goto 19000
- if(obj.eq.dragon)spk=167
- if(obj.eq.troll)spk=157
- if(obj.eq.bear)spk=165+(prop(bear)+1)/2
- if(obj.ne.dragon.or.prop(dragon).ne.0)goto 2011
- c fun stuff for dragon. if he insists on attacking it, win! set prop to dead,
- c move dragon to central loc (still fixed), move rug there (not fixed), and
- c move him there, too. then do a null motion to get new description.
- call rspeak(49)
- verb=0
- obj=0
- call getin(wd1,wd1x,wd2,wd2x)
- if(wd1.ne.'y '.and.wd1.ne.'yes ')goto 2608
- call pspeak(dragon,1)
- prop(dragon)=2
- prop(rug)=0
- k=(plac(dragon)+fixd(dragon))/2
- call move(dragon+100,-1)
- call move(rug+100,0)
- call move(dragon,k)
- call move(rug,k)
- do 9126 obj=1,100
- idondx=obj
- if(place(idondx).eq.plac(dragon).or.
- . place(idondx).eq.fixd(dragon))
- . call move(idondx,k)
- 9126 continue
- loc=k
- k=null
- goto 8
-
- c pour. if no object, or object is bottle, assume contents of bottle.
- c special tests for pouring water or oil on plant or rusty door.
-
- 9130 if(obj.eq.bottle.or.obj.eq.0)obj=liq(0)
- if(obj.eq.0)goto 8000
- if(toting(obj).eq.0)goto 2011
- spk=78
- if(obj.ne.oil.and.obj.ne.water)goto 2011
- prop(bottle)=1
- place(obj)=0
- spk=77
- if(at(plant).eq.0.and.at(door).eq.0) go to 2011
-
- if(at(door).eq.1)goto 9132
- spk=112
- if(obj.ne.water)goto 2011
- call pspeak(plant,prop(plant)+1)
- prop(plant)=mod(prop(plant)+2,6)
- prop(plant2)=prop(plant)/2
- k=null
- goto 8
-
- 9132 prop(door)=0
- if(obj.eq.oil)prop(door)=1
- spk=113+prop(door)
- goto 2011
-
- c eat. intransitive: assume food if present, else ask what. transitive: food
- c ok, some things lose appetite, rest are ridiculous.
-
- 8140 if(here(food).eq.0)goto 8000
- 8142 call dstroy(food)
- spk=72
- goto 2011
- 9140 if(obj.eq.food)goto 8142
- if(obj.eq.bird.or.obj.eq.snake.or.obj.eq.clam.or.obj.eq.oyster
- . .or.obj.eq.dwarf.or.obj.eq.dragon.or.obj.eq.troll
- . .or.obj.eq.bear)spk=71
- goto 2011
-
- c drink. if no object, assume water and look for it here. if water is in
- c the bottle, drink that, else must be at a water loc, so drink stream.
-
- 9150 if(obj.eq.0.and.liqloc(loc).ne.water.and.(liq(0).ne.water
- . .or.here(bottle).eq.0))goto 8000
- if(obj.ne.0.and.obj.ne.water)spk=110
- if(spk.eq.110.or.liq(0).ne.water.or.here(bottle).eq.0)goto 2011
- prop(bottle)=1
- place(water)=0
- spk=74
- goto 2011
-
- c rub. yields various snide remarks.
-
- 9160 if(obj.ne.lamp)spk=76
- goto 2011
-
- c throw. same as discard unless axe. then same as attack except ignore bird,
- c and if dwarf is present then one might be killed. (only way to do so)
- c axe also special for dragon, bear, and troll. treasures special for troll.
-
- 9170 if(toting(rod2).eq.1.and.obj.eq.rod.and.toting(rod).eq.0)obj=rod2
- if(toting(obj).eq.0)goto 2011
- if(obj.ge.50.and.obj.le.maxtrs.and.at(troll).eq.1)goto 9178
- if(obj.eq.food.and.here(bear).eq.1)goto 9177
- if(obj.ne.axe)goto 9020
- do 9171 i=1,5
- c needn't check dflag if axe is here.
- if(dloc(i).eq.loc)goto 9172
- 9171 continue
- spk=152
- if(at(dragon).eq.1.and.prop(dragon).eq.0)goto 9175
- spk=158
- if(at(troll).eq.1)goto 9175
- if(here(bear).eq.1.and.prop(bear).eq.0)goto 9176
- obj=0
- goto 9120
-
- 9172 spk=48
- if(ran(3).eq.0) go to 9175
- dseen(i)=0
- dloc(i)=0
- spk=47
- dkill=dkill+1
- if(dkill.eq.1)spk=149
- 9175 call rspeak(spk)
- call drop(axe,loc)
- k=null
- goto 8
-
- c this'll teach him to throw the axe at the bear!
- 9176 spk=164
- call drop(axe,loc)
- fixed(axe)=-1
- prop(axe)=1
- call juggle(bear)
- goto 2011
-
- c but throwing food is another story.
- 9177 obj=bear
- goto 9210
-
- 9178 spk=159
- c snarf a treasure for the troll.
- call drop(obj,0)
- call move(troll,0)
- call move(troll+100,0)
- call drop(troll2,plac(troll))
- call drop(troll2+100,fixd(troll))
- call juggle(chasm)
- goto 2011
-
- c quit. intransitive only. verify intent and exit if that's what he wants.
-
- 8180 gaveup=yes(22,54,54)
- 8185 if(gaveup.eq.1)goto 20000
- goto 2012
-
- c find. might be carrying it, or it might be here. else give caveat.
-
- 9190 if(at(obj).eq.1.or.(liq(0).eq.obj.and.at(bottle).eq.1)
- . .or.k.eq.liqloc(loc))spk=94
- do 9192 i=1,5
- 9192 if(dloc(i).eq.loc.and.dflag.ge.2.and.obj.eq.dwarf)spk=94
- if(closed.eq.1)spk=138
- if(toting(obj).eq.1)spk=24
- goto 2011
-
- c inventory. if object, treat same as find. else report on current burden.
-
- 8200 spk=98
- blklin=1
- do 8201 i=1,100
- idondx=i
- if(idondx.eq.bear.or.toting(idondx).eq.0)goto 8201
- if(spk.eq.98)call rspeak(99)
- call pspeak(idondx,-1)
- if (blklin.eq.1) blklin=0
- spk=0
- 8201 continue
- blklin=1
- if(toting(bear).eq.1)spk=141
- goto 2011
-
- c feed. if bird, no seed. snake, dragon, troll: quip. if dwarf, make him
- c mad. bear, special.
-
- 9210 if(obj.ne.bird)goto 9212
- spk=100
- goto 2011
-
- 9212 if(obj.ne.snake.and.obj.ne.dragon.and.obj.ne.troll)goto 9213
- spk=102
- if(obj.eq.dragon.and.prop(dragon).ne.0)spk=110
- if(obj.eq.troll)spk=182
- if(obj.ne.snake.or.closed.eq.1.or.here(bird).eq.0)goto 2011
- spk=101
- call dstroy(bird)
- prop(bird)=0
- tally2=tally2+1
- goto 2011
-
- 9213 if(obj.ne.dwarf)goto 9214
- if(here(food).eq.0)goto 2011
- spk=103
- dflag=dflag+1
- goto 2011
-
- 9214 if(obj.ne.bear)goto 9215
- if(prop(bear).eq.0)spk=102
- if(prop(bear).eq.3)spk=110
- if(here(food).eq.0)goto 2011
- call dstroy(food)
- prop(bear)=1
- fixed(axe)=0
- prop(axe)=0
- spk=168
- goto 2011
-
- 9215 spk=14
- goto 2011
-
- c fill. bottle must be empty, and some liquid available. (vase is nasty.)
-
- 9220 if(obj.eq.vase)goto 9222
- if(obj.ne.0.and.obj.ne.bottle)goto 2011
- if(obj.eq.0.and.here(bottle).eq.0)goto 8000
- spk=107
- if(liqloc(loc).eq.0)spk=106
- if(liq(0).ne.0)spk=105
- if(spk.ne.107)goto 2011
- prop(bottle)=mod(cond(loc),4)/2*2
- k=liq(0)
- if(toting(bottle).eq.1)place(k)=-1
- if(k.eq.oil)spk=108
- goto 2011
-
- 9222 spk=29
- if(liqloc(loc).eq.0)spk=144
- if(liqloc(loc).eq.0.or.toting(vase).eq.0)goto 2011
- call rspeak(145)
- prop(vase)=2
- fixed(vase)=-1
- goto 9024
-
- c blast. no effect unless you've got dynamite, which is a neat trick!
-
- 9230 if(prop(rod2).lt.0.or.closed.eq.0)goto 2011
- bonus=133
- if(loc.eq.115)bonus=134
- if(here(rod2).eq.1)bonus=135
- call rspeak(bonus)
- goto 20000
-
- c score. go to scoring section, which will return to 8241 if scorng is true.
-
- 8240 scorng=1
- goto 20000
-
- 8241 scorng=0
- write(*,8243) score, mxscor, turns
- 8243 format(/' If you were to quit now,',/,' You would score',i4
- . ,' out of a possible',i4,', using ',i5,' turns.')
- c gaveup=yes(143,54,54)
- c goto 8185
- go to 2012
- c fee fie foe foo (and fum). advance to next state if given in proper order.
- c look up wd1 in section 3 of vocab to determine which word we've got. last
- c word zips the eggs back to the giant room (unless already there).
-
- 8250 k=vocab(wd1,3)
- spk=42
- if(foobar.eq.1-k)goto 8252
- if(foobar.ne.0)spk=151
- goto 2011
-
- 8252 foobar=k
- if(k.ne.4)goto 2009
- foobar=0
- if(place(eggs).eq.plac(eggs)
- . .or.(toting(eggs).eq.1.and.loc.eq.plac(eggs)))goto 2011
- c bring back troll if we steal the eggs back from him before crossing.
- if(place(eggs).eq.0.and.place(troll).eq.0.and.prop(troll).eq.0)
- . prop(troll)=1
- k=2
- if(here(eggs).eq.1)k=1
- if(loc.eq.plac(eggs))k=0
- call move(eggs,plac(eggs))
- call pspeak(eggs,k)
- goto 2012
-
- c brief. intransitive only. suppress long descriptions after first time.
-
- 8260 spk=156
- abbnum=10000
- detail=3
- goto 2011
-
- c read. magazines in dwarvish, message we've seen, and . . . oyster?
-
- 8270 if(here(magzin).eq.1)obj=magzin
- if(here(tablet).eq.1)obj=obj*100+tablet
- if(here(messag).eq.1)obj=obj*100+messag
- if(closed.eq.1.and.toting(oyster).eq.1)obj=oyster
- if(obj.gt.100.or.obj.eq.0.or.dark(0).eq.1)goto 8000
-
- 9270 if(dark(0).eq.1)goto 5190
- if(obj.eq.magzin)spk=190
- if(obj.eq.tablet)spk=196
- if(obj.eq.messag)spk=191
- if(obj.eq.oyster.and.hinted(2).eq.1.and.toting(oyster).eq.1)
- . spk=194
- if(obj.ne.oyster.or.hinted(2).eq.1.or.toting(oyster).eq.0
- . .or.closed.eq.0)goto 2011
- hinted(2)=yes(192,193,54)
- goto 2012
-
- c break. only works for mirror in repository and, of course, the vase.
-
- 9280 if(obj.eq.mirror)spk=148
- if(obj.eq.vase.and.prop(vase).eq.0)goto 9282
- if(obj.ne.mirror.or.closed.eq.0)goto 2011
- call rspeak(197)
- goto 19000
-
- 9282 spk=198
- if(toting(vase).eq.1)call drop(vase,loc)
- prop(vase)=2
- fixed(vase)=-1
- goto 2011
-
- c wake. only use is to disturb the dwarves.
-
- 9290 if(obj.ne.dwarf.or.closed.eq.0)goto 2011
- call rspeak(199)
- goto 19000
- c
- c suspend. offer to exit and give specs on restart.
- c upon restarting, "resume" on first turn only comes to 8305
- c
- 8300 write (*,8302)
- 8302 format(/' I can suspend your Adventure for you so that you can',
- . /,' restart later, but you will have to type "resume" on your',
- . /,' FIRST TURN. The save process will write a 2772 byte file',
- . /,' named ADVENTUR.SV in your current directory.')
- c
- if(yes(200,54,54).eq.0) go to 2012
- c
- c write data file with all the good stuff to resume from
- c
- open (2,file='adventur.sv',form='unformatted',status='unknown')
- write (2) place,prop,link,abb,cond,atloc,fixd,plac,hinted,
- . hintlc,dseen,dloc,odloc,fixed,hints,tally,tally2,dflag,turns,
- . limit,iwest,knfloc,detail,abbnum,maxdie,numdie,holdng,dkill,
- . foobar,bonus,lmwarn,clock1,clock2,panic,closed,obj,verb,newloc
- . ,loc,dtotal,attack,stick,itk,idondx,kk,oldlc2,oldloc,wzdark,
- . closng
- close (2)
- c
- write (*,83001)
- 83001 format(//,' Your Adventure has been saved. Type "resume"',/,
- . ' on your FIRST TURN to restart where you left off.',//)
- go to 25000
- c
- c resume saved game from data file adventur.sv. resume must be on
- c first turn. comes here to read all variables as we wrote them
- c and proceeds.
- c
- 8305 open (2,file='adventur.sv',form='unformatted')
- read (2) place,prop,link,abb,cond,atloc,fixd,plac,hinted,
- . hintlc,dseen,dloc,odloc,fixed,hints,tally,tally2,dflag,turns,
- . limit,iwest,knfloc,detail,abbnum,maxdie,numdie,holdng,dkill,
- . foobar,bonus,lmwarn,clock1,clock2,panic,closed,obj,verb,newloc
- . ,loc,dtotal,attack,stick,itk,idondx,kk,oldlc2,oldloc,wzdark,
- . closng
- close (2)
- yea=1
- k=null
- goto 8
-
- c hours. report current non-prime-time hours.
-
- 8310 write (*,83101)
- 83101 format (/,' Colossal Cave is always open.')
- goto 2012
- c
- c hints
-
- c come here if he's been long enough at required loc(s) for some unused hint.
- c hint number is in variable "hint". branch to quick test for additional
- c conditions, then come back to do neat stuff. goto 40010 if conditions are
- c met and we want to offer the hint. goto 40020 to clear hintlc back to zero,
- c 40030 to take no action yet.
-
- 40000 if(hint.lt.4.or.hint.gt.9) call bug(27)
- go to (40400,40500,40600,40700,40800,40900),(hint-3)
- c cave bird snake maze dark witt
-
- 40010 hintlc(hint)=0
- if(yes(hints(hint,3),0,54).eq.0)goto 26021
- write (*,40012) hints (hint,2)
- 40012 format(/' I am prepared to give you a hint, but it will cost you',
- . i2,' points.')
- hinted(hint)=yes(175,hints(hint,4),54)
- if(hinted(hint).eq.1.and.limit.gt.30)limit=limit+30*hints(hint,2)
- 40020 hintlc(hint)=0
- 40030 goto 26021
-
- c now for the quick tests. see database description for one-line notes.
-
- 40400 if(prop(grate).eq.0.and.here(keys).eq.0)goto 40010
- goto 40020
-
- 40500 if(here(bird).eq.1.and.toting(rod).eq.1.and.obj.eq.bird)goto40010
- goto 40030
-
- 40600 if(here(snake).eq.1.and.here(bird).eq.0)goto 40010
- goto 40020
-
- 40700 if(atloc(loc).eq.0.and.atloc(oldloc).eq.0
- . .and.atloc(oldlc2).eq.0.and.holdng.gt.1)goto 40010
- goto 40020
-
- 40800 if(prop(emrald).ne.-1.and.prop(pyram).eq.-1)goto 40010
- goto 40020
-
- 40900 goto 40010
-
- c cave closing and scoring
-
- c these sections handle the closing of the cave. the cave closes "clock1"
- c turns after the last treasure has been located (including the pirate's
- c chest, which may of course never show up). note that the treasures need not
- c have been taken yet, just located. hence clock1 must be large enough to get
- c out of the cave (it only ticks while inside the cave). when it hits zero,
- c we branch to 10000 to start closing the cave, and then sit back and wait for
- c him to try to get out. if he doesn't within clock2 turns, we close the
- c cave; if he does try, we assume he panics, and give him a few additional
- c turns to get frantic before we close. when clock2 hits zero, we branch to
- c 11000 to transport him into the final puzzle. note that the puzzle depends
- c upon all sorts of random things. for instance, there must be no water or
- c oil, since there are beanstalks which we don't want to be able to water,
- c since the code can't handle it. also, we can have no keys, since there is a
- c grate (having moved the fixed object!) there separating him from all the
- c treasures. most of these problems arise from the use of negative prop
- c numbers to suppress the object descriptions until he's actually moved the
- c objects.
-
- c when the first warning comes, we lock the grate, destroy the bridge, kill
- c all the dwarves (and the pirate), remove the troll and bear (unless dead),
- c and set "closng" to true. leave the dragon; too much trouble to move it.
- c from now until clock2 runs out, he cannot unlock the grate, move to any
- c location outside the cave (loc<9), or create the bridge. nor can he be
- c resurrected if he dies. note that the snake is already gone, since he got
- c to the treasure accessible only via the hall of the mt. king. also, he's
- c been in giant room (to get eggs), so we can refer to it. also also, he's
- c gotten the pearl, so we know the bivalve is an oyster. *and*, the dwarves
- c must have been activated, since we've found chest.
-
- 10000 prop(grate)=0
- prop(fissur)=0
- do 10010 i=1,6
- dseen(i)=0
- 10010 dloc(i)=0
- call move(troll,0)
- call move(troll+100,0)
- call move(troll2,plac(troll))
- call move(troll2+100,fixd(troll))
- call juggle(chasm)
- if(prop(bear).ne.3)call dstroy(bear)
- prop(chain)=0
- fixed(chain)=0
- prop(axe)=0
- fixed(axe)=0
- call rspeak(129)
- clock1=-1
- closng=1
- goto 19999
-
- c once he's panicked, and clock2 has run out, we come here to set up the
- c storage room. the room has two locs, hardwired as 115 (ne) and 116 (sw).
- c at the ne end, we place empty bottles, a nursery of plants, a bed of
- c oysters, a pile of lamps, rods with stars, sleeping dwarves, and him. and
- c the sw end we place grate over treasures, snake pit, covey of caged birds,
- c more rods, and pillows. a mirror stretches across one wall. many of the
- c objects come from known locations and/or states (e.g. the snake is known to
- c have been destroyed and needn't be carried away from its old "place"),
- c making the various objects be handled differently. we also drop all other
- c objects he might be carrying (lest he have some which could cause trouble,
- c such as the keys). we describe the flash of light and trundle back.
-
- 11000 prop(bottle)=put(bottle,115,1)
- prop(plant)=put(plant,115,0)
- prop(oyster)=put(oyster,115,0)
- prop(lamp)=put(lamp,115,0)
- prop(rod)=put(rod,115,0)
- prop(dwarf)=put(dwarf,115,0)
- loc=115
- oldloc=115
- newloc=115
-
- c leave the grate with normal (non-negative property).
-
- foo=put(grate,116,0)
- prop(snake)=put(snake,116,1)
- prop(bird)=put(bird,116,1)
- prop(cage)=put(cage,116,0)
- prop(rod2)=put(rod2,116,0)
- prop(pillow)=put(pillow,116,0)
-
- prop(mirror)=put(mirror,115,0)
- fixed(mirror)=116
-
- do 11010 i=1,100
- idondx=i
- 11010 if(toting(idondx).eq.1)call dstroy(idondx)
-
- call rspeak(132)
- closed=1
- goto 2
-
- c another way we can force an end to things is by having the lamp give out.
- c when it gets close, we come here to warn him. we go to 12000 if the lamp
- c and fresh batteries are here, in which case we replace the batteries and
- c continue. 12200 is for other cases of lamp dying. 12400 is when it goes
- c out, and 12600 is if he's wandered outside and the lamp is used up, in which
- c case we force him to give up.
-
- 12000 call rspeak(188)
- prop(batter)=1
- if(toting(batter).eq.1)call drop(batter,loc)
- limit=limit+2500
- lmwarn=0
- goto 19999
-
- 12200 if(lmwarn.eq.1.or.here(lamp).eq.0)goto 19999
- lmwarn=1
- spk=187
- if(place(batter).eq.0)spk=183
- if(prop(batter).eq.1)spk=189
- call rspeak(spk)
- goto 19999
-
- 12400 limit=-1
- prop(lamp)=0
- if(here(lamp).eq.1)call rspeak(184)
- goto 19999
-
- 12600 call rspeak(185)
- gaveup=1
- goto 20000
-
- c oh dear, he's disturbed the dwarves.
-
- 19000 call rspeak(136)
-
- c exit code. will eventually include scoring. for now, however, ...
-
- c the present scoring algorithm is as follows:
- c objective: points: present total possible:
- c getting well into cave 45 45
- c each treasure < chest 12 60
- c treasure chest itself 14 14
- c each treasure > chest 16 144
- c surviving (max-num)*10 30
- c not quitting 4 4
- c reaching "closng" 25 25
- c "closed": quit/killed 10
- c klutzed 25
- c wrong way 30
- c success 45 45
- c came to witt's end 1 1
- c round out the total 2 2
- c total: 370
- c (points can also be deducted for using hints.)
-
- 20000 score=0
- mxscor=0
-
- c first tally up the treasures. must be in building and not broken.
- c give the poor guy 2 points just for finding each treasure.
-
- do 20010 i=50,maxtrs
- if(ptext(i).eq.0)goto 20010
- k=12
- if(i.eq.chest)k=14
- if(i.gt.chest)k=16
- if(prop(i).ge.0)score=score+2
- if(place(i).eq.3.and.prop(i).eq.0)score=score+k-2
- mxscor=mxscor+k
- 20010 continue
-
- c now look at how he finished and how far he got. maxdie and numdie tell us
- c how well he survived. gaveup says whether he exited via quit. dflag will
- c tell us if he ever got suitably deep into the cave. closng still indicates
- c whether he reached the endgame. and if he got as far as "cave closed"
- c (indicated by "closed"), then bonus is zero for mundane exits or 133, 134,
- c 135 if he blew it (so to speak).
-
- score=score+(maxdie-numdie)*10
- mxscor=mxscor+maxdie*10
- if(scorng.eq.0.and.gaveup.eq.0)score=score+4
- mxscor=mxscor+4
- if(dflag.ne.0)score=score+45
- mxscor=mxscor+45
- if(closng.eq.1)score=score+25
- mxscor=mxscor+25
- if(closed.eq.0)go to 20020
- if(bonus.eq.0)score=score+10
- if(bonus.eq.135)score=score+25
- if(bonus.eq.134)score=score+30
- if(bonus.eq.133)score=score+45
- 20020 mxscor=mxscor+45
-
- c did he come to witt's end as he should?
-
- if(place(magzin).eq.108)score=score+1
- mxscor=mxscor+1
-
- c round it off.
-
- score=score+2
- mxscor=mxscor+2
-
- c deduct points for hints. hints < 4 are special; see database description.
-
- do 20030 i=1,hntmax
- 20030 if(hinted(i).eq.1)score=score-hints(i,2)
-
- c return to score command if that's where we came from.
-
- if(scorng.eq.1)goto 8241
-
- c that should be good enough. let's tell him all about it.
-
- write (*,20100) score, mxscor, turns
- 20100 format(///' You scored',i4,' out of a possible',i4,
- . ', using',i5,' turns.')
-
- do 20200 i=1,clsses
- if(cval(i).ge.score)goto 20210
- 20200 continue
- write (*,20202)
- 20202 format(/' You just went off my scale !! (Whoops) !!'/)
- goto 25000
-
- 20210 call speak(ctext(i))
- if(i.eq.clsses-1)goto 20220
- k=cval(i)+1-score
- iz='s. '
- if(k.eq.1)iz='. '
- write (*,20212) k, iz
- 20212 format(/' To achieve the next higher rating, you need',i3,
- . ' more point',a2/)
- goto 25000
-
- 20220 write (*,20222)
- 20222 format(/' To achieve the next higher rating ',
- . 'would be a neat trick, Oh Great One!!'//' Congratulations!!'/)
-
- 25000 write (*,25001)
- 25001 format (/////)
- pause 'Please Press the ENTER Key to Exit From Adventure.'
- end
- c
- c subroutines and functions
- subroutine speak(n)
- c print the message which starts at lines(n). precede it with a blank line
- c unless blklin is false.
- implicit integer*2 (a-z)
- common /lincom/ lines
- common /txtcom/ rtext
- common /blkcom/ blklin
- dimension rtext (205)
- character*2 lines (21150)
- character*2 np,clines
- integer*4 nnn,k,l,i
- equivalence (clines,ilines)
- data np/'>$'/
- nnn=n
- if(nnn.eq.0)return
- if(lines(nnn+1).eq.np)return
- if(blklin.eq.1) write (*,2)
- k=nnn
- 1 clines=lines(k)
- l=iabs(ilines)-1
- k=k+1
- write (*, 2) (lines(i),i=k,l)
- 2 format(' ',36a2)
- k=l+1
- clines=lines(k)
- if(ilines.ge.0) go to 1
- return
- end
-
- subroutine pspeak(msg,skip)
- c find the skip+1st message from msg and print it. msg should be the index of
- c the inventory message for object. (inven+n+1 message is prop=n message).
- implicit integer*2 (a-z)
- common /lincom/ lines
- common /txtcom/ rtext
- common /ptxcom/ ptext
- character*2 lines (21150),clines
- dimension rtext(205),ptext(100)
- integer*4 mm
- equivalence (clines,ilines)
- m=ptext(msg)
- if(skip.lt.0)goto 9
- do 3 i=1,skip+1
- 1 mm=m
- clines=lines(mm)
- m=iabs(ilines)
- mm=m
- clines=lines(mm)
- if(ilines.ge.0) go to 1
- 3 continue
- 9 call speak(m)
- return
- end
-
- subroutine rspeak(i)
- c print the i-th "random" message (section 6 of database).
- implicit integer*2 (a-z)
- common /txtcom/ rtext
- dimension rtext(205)
- if(i.ne.0)call speak(rtext(i))
- return
- end
-
- integer*2 function yes(x,y,z)
- c call yesx (below) with messages from section 6.
- implicit integer*2 (a-z)
- yes=yesx(x,y,z)
- return
- end
-
- integer*2 function yesx(x,y,z)
- c print message x, wait for yes/no answer. if yes, print y and leave yea
- c true; if no, print z and leave yea false.
- implicit integer*2 (a-z)
- character*4 reply,junk1,junk2,junk3
- 1 if(x.ne.0) call rspeak (x)
- call getin(reply,junk1,junk2,junk3)
- if(reply.eq.'yes '.or.reply.eq.'y ')goto 10
- if(reply.eq.'no '.or.reply.eq.'n ')goto 20
- write (*,9)
- 9 format(/' Please answer the question "yes" or "no".')
- goto 1
- 10 yesx=1
- if(y.ne.0) call rspeak (y)
- return
- 20 yesx=0
- if(z.ne.0) call rspeak (z)
- return
- end
-
- subroutine a5toa1 (a, b, c, d, chars, leng)
- c a & b contain a 1 to 8-character word in a4 format. c & d contain
- c another word and/or punctuation. they are unpacked to one character
- c per word in the array "chars", with exactly one blank between b & c
- c (or none, if c is zero). the index of the last non-blank character
- c in chars is returned in leng.
- implicit integer*2 (a-z)
- integer*4 ic
- character *20 aaa
- character *4 a,b,c,d,aa(5),cc
- character *1 chars(20),raw(20)
- equivalence (aaa,aa),(cc,ic)
- c do first word until a blank
- aa(1) = a
- aa(2) = b
- call unpack (aaa, raw)
- c clear output array and move, counting to first blank
- leng=0
- do 2 i=1,20
- 2 chars(i)=' '
- do 1 i=1,8
- if (raw(i).eq.' ') go to 3
- chars(i)=raw(i)
- 1 leng=i
- c leng doesn't include trailing blank
- 3 cc=c
- if(ic.eq.0) go to 99
- c second word--ignore leading blanks, stop at trailing one
- chars(leng+1)=' '
- leng=leng+1
- ll=leng
- aa(1)=c
- aa(2)=d
- call unpack (aaa,raw)
- c skip leading blank if any
- do 4 j=1,8
- 4 if (raw(j).ne.' ') go to 5
- c second word was all blank--fooey
- go to 99
- c do non-blanks
- 5 do 6 k=j,8
- if (raw(k).eq.' ') go to 99
- chars (k-j+1+ll) = raw(k)
- 6 leng=leng+1
- 99 return
- end
- c
- integer*2 function vocab(id,init)
- c look up id in the vocabulary (atab) and return its "definition" (ktab), or
- c -1 if not found. if init is positive, this is an initialization call setting
- c up a keyword variable, and not finding it constitutes a bug. it also means
- c that only ktab values which taken over 1000 equal init may be considered.
- c (thus "steps", which is a motion verb also, may be considered
- c as an object.) and it also means the ktab value is taken mod 1000.
- implicit integer*2 (a-z)
- common /voccom/ ktab,atab,tabsiz
- character*4 atab(295),id
- dimension ktab(295)
- do 1 i=1,tabsiz
- if(ktab(i).eq.-1)goto 2
- if(init.ge.0.and.ktab(i)/1000.ne.init)goto 1
- if(atab(i).eq.id)goto 3
- 1 continue
- 10 format(1x,i4,2x,a4)
- call bug(21)
- 2 vocab=-1
- if(init.lt.0)return
- write (*,10) init, id
- call bug(5)
- 3 vocab=ktab(i)
- if(init.ge.0)vocab=mod(vocab,1000)
- return
- end
-
- subroutine dstroy(object)
- c permanently eliminate "object" by moving to a non-existent location.
- implicit integer*2 (a-z)
- call move(object,0)
- return
- end
-
- subroutine juggle(object)
- c juggle an object by picking it up and putting it down again, the purpose
- c being to get the object to the front of the chain of things at its loc.
- implicit integer*2 (a-z)
- common /placom/ atloc,link,place,fixed,holdng
- dimension atloc(150),link(200),place( 100),fixed(100)
- i=place(object)
- call move(object,i)
- call move(object+100,j)
- return
- end
-
- subroutine move(object,where)
-
- c place any object anywhere by picking it up and dropping it. may already be
- c toting, in which case the carry is a no-op. mustn't pick up objects which
- c are not at any loc, since carry wants to remove objects from atloc chains.
- implicit integer*2 (a-z)
- common /placom/ atloc,link,place,fixed,holdng
- dimension atloc(150),link(200),place( 100),fixed(100)
- if(object.gt.100)goto 1
- from=place(object)
- goto 2
- 1 from=fixed(object-100)
- 2 if(from.gt.0.and.from.le.300)call carry(object,from)
- call drop(object,where)
- return
- end
-
- integer*2 function put(object,where,pval)
-
- c put is the same as move, except it returns a value used to set up the
- c negated prop values for the repository objects.
- implicit integer*2 (a-z)
- call move(object,where)
- put=(-1)-pval
- return
- end
-
- subroutine carry(object,where)
- c start toting an object, removing it from the list of things at its former
- c location. incr holdng unless it was already being toted. if object>100
- c (moving "fixed" second loc), don't change place or holdng.
- implicit integer*2 (a-z)
- common /placom/ atloc,link,place,fixed,holdng
- dimension atloc(150),link(200),place( 100),fixed(100)
- if(object.gt.100)goto 5
- if(place(object).eq.-1)return
- place(object)=-1
- holdng=holdng+1
- 5 if(atloc(where).ne.object)goto 6
- atloc(where)=link(object)
- return
- 6 temp=atloc(where)
- 7 if(link(temp).eq.object)goto 8
- temp=link(temp)
- goto 7
- 8 link(temp)=link(object)
- return
- end
-
- subroutine drop(object,where)
- c place an object at a given loc, prefixing it onto the atloc list. decr
- c holdng if the object was being toted.
- implicit integer*2 (a-z)
- common /placom/ atloc,link,place,fixed,holdng
- dimension atloc(150),link(200),place( 100),fixed(100)
- if(object.gt.100)goto 1
- if(place(object).eq.-1)holdng=holdng-1
- place(object)=where
- goto 2
- 1 fixed(object-100)=where
- 2 if(where.le.0)return
- link(object)=atloc(where)
- atloc(where)=object
- return
- end
-
- c utility routines (shift, ran, datime, bug)
- integer*2 function shift (val, dist)
- c return val shifted (left if dist>0, else right) dist bits
- implicit integer*2 (a-z)
- shift=val
- if (dist.eq.0) go to 20
- idist=iabs(dist)
- do 1 i = 1,idist
- if (dist.lt.0) shift=shift/2
- 1 if (dist.gt.0) shift=shift*2
- 20 return
- end
- subroutine bug(num)
- implicit integer*2 (a-z)
-
- c the following conditions are currently considered fatal bugs. numbers < 20
- c are detected while reading the database; the others occur at "run time".
- c 0 message line > 72 characters
- c 1 null line in message * Only ones
- c 2 too many words of messages currently
- c 3 too many travel options implemented
- c 4 too many vocabulary words
- c 5 * required vocabulary word not found
- c 6 too many rtext messages
- c 7 too many hints
- c 8 location has cond bit being set twice
- c 9 invalid section number in database
- c 20 * special travel (500>l>300) exceeds goto list
- c 21 * ran off end of vocabulary table
- c 22 * vocabulary type (n/1000) not between 0 and 3
- c 23 * intransitive action verb exceeds goto list
- c 24 transitive action verb exceeds goto list
- c 25 * conditional travel entry with no alternative
- c 26 * location has no travel entries
- c 27 * hint number exceeds goto list
- c 28 invalid month returned by date function
-
- write (*,1) num
- 1 format (' Fatal error, see source code for interpretation.'/
- . ' Probable cause: erroneous info in database.'/
- 2 ' Error code =',i2/)
- pause 'To Exit From Adventure'
- end
-
- subroutine getin (word1,word1x,word2,word2x)
- c get a command from the adventurer. snarf out the first word, pad it
- c with blanks, and return in word1--word1x used for overflow charcters
- c 5-8 in case we need to print the whole word back out in an error.
- c any number of blanks may follow the word. if a second word appears
- c it is returned in word2/word2x, else word2 is set to zero. all are
- c converted to lower case for comparison ease (ibm pc version).
- implicit integer*2 (a-z)
- common /blkcom/ blklin
- character*1 s(20), t(20)
- character*4 word1, word1x, word2, word2x, w1(5), w2(5), a(5)
- character*20 w81, w82, aa, bb
- integer*4 iw1, iw1x, iw2, iw2x
- equivalence (w1(1),iw1),(w1(2),iw1x),(a,aa)
- equivalence (w2(1),iw2),(w2(2),iw2x),(w81,w1),(w82,w2)
- if (blklin.eq.1) write (*,1)
- 1 format (1x)
- c give a prompt to make him think we want input
- write (*,9)
- 9 format (' -> ',\)
- c
- c read twenty characters into a. unpack them into s.
- read (*,3) a
- 3 format (5a4)
- bb = aa
- call unpack (bb, s)
- c translate all to lower case
- do 1001 i=1,20
- if (ichar(s(i)).lt.65.or.ichar(s(i)).gt.90) go to 1001
- s(i)=char(ichar(s(i))+32)
- 1001 continue
- c go through the characters and transfer the first word into t, up
- c to eight characters
- do 10 i=1,20
- 10 t(i)=' '
- do 11 i=1,8
- if (s(i).eq.' ') go to 20
- 11 t(i)=s(i)
- c now repack the characters into w81, equivalent to word1,word1x
- 20 call pack (w81,t)
- word1=w1(1)
- word1x=w1(2)
- c now find a second word if one exists--clear return words first
- iw2=0
- iw2x=0
- do 30 i=1,20
- 30 t(i)=' '
- do 31 i=1,20
- if (s(i).ne.' ') go to 31
- go to 32
- 31 continue
- c all characters--fooey
- go to 40
- c hit first blank after first word--now get first non-blank
- 32 do 33 j=i,20
- if (s(j).eq.' ') go to 33
- go to 34
- 33 continue
- c blanked out again
- go to 40
- c hit beginning of second word--finish it
- 34 do 35 i=j,20
- if (s(i).eq.' ') go to 36
- 35 t(i-j+1)=s(i)
- c now repack word2/2x
- 36 call pack (w82,t)
- 40 word2=w2(1)
- word2x=w2(2)
- return
- end
- c
- subroutine unpack (b, s)
- implicit integer*2 (a-z)
- c unpack general subroutine
- c b 20 character string
- c s 20 character*1 singles
- character*20 a,b
- character*4 aa(5)
- integer*4 ia(5)
- equivalence (ia,a,aa)
- character*1 s(20)
- a = b
- do 1 k = 1,5
- do 1 j = 1,4
- s(4*(k-1)+j)=aa(k)
- 1 if(j.ne.4)ia(k)=ia(k)/256
- return
- end
- c
- subroutine pack (b, t)
- implicit integer*2 (a-z)
- c general pack subroutine--20 characters
- c b return packed word--20
- c t array to pack of char*1's
- character*20 a,b
- integer*4 ia(5)
- equivalence (ia,a)
- character*1 s(20),t(20)
- do 95 i = 1,20
- 95 s(i)=t(i)
- do 1 k = 1,5
- ia(6-k)=0
- do 1 j = 1, 4
- l=4*(5-k)+5-j
- ia(6-k) = ia(6-k) + ichar (s(l))
- 1 if (j.ne.4) ia(6-k) = ia(6-k) * 256
- b=a
- return
- end
- c
- integer*2 function toting(obj)
- implicit integer*2 (a-z)
- common /placom/ atloc,link,place,fixed,holdng
- dimension atloc(150),link(200),place( 100),fixed(100)
- toting=0
- if (place(obj).eq.-1) toting=1
- return
- end
- c
- integer*2 function here(obj)
- implicit integer*2 (a-z)
- common /placom/ atloc,link,place,fixed,holdng
- common /loccom/ loc
- dimension atloc(150),link(200),place( 100),fixed(100)
- here=0
- if (place(obj).eq.loc.or.toting(obj).eq.1) here=1
- return
- end
- c
- integer*2 function at(obj)
- implicit integer*2 (a-z)
- common /placom/ atloc,link,place,fixed,holdng
- common /loccom/ loc
- dimension atloc(150),link(200),place( 100),fixed(100)
- at=0
- if (place(obj).eq.loc.or.fixed(obj).eq.loc) at=1
- return
- end
- c
- integer*2 function forced(loc)
- implicit integer*2 (a-z)
- common /concom/ cond
- dimension cond (150)
- forced=0
- if (cond(loc).eq.2) forced=1
- return
- end
- c
- integer*2 function dark(dummy)
- implicit integer*2 (a-z)
- common /concom/ cond
- common /loccom/ loc
- common /procom/ prop, lamp
- dimension cond(150),prop(100)
- external here
- dark=0
- if (mod(cond(loc),2).eq.0 .and. (prop(lamp).eq.0 .or.
- . here(lamp).eq.0)) dark=1
- return
- end
- c
- integer*2 function pct(n)
- implicit integer*2 (a-z)
- external ran
- pct=0
- if (ran(100).lt.n) pct=1
- return
- end
-
- subroutine datime (daye,t)
- c d is date as number of days (more or less) after jan 1 77
- c t is time as number of minutes past midnight
- implicit integer*4 (a-z)
- call getdat(year,month,day)
- call gettim(hour,minute,second,hndrth)
- t=minute+60*hour
- daye=(year-77)*365+((month-1)*30)+day
- return
- end
-
- integer*2 function ran(range)
-
- c since the ran function in lib40 seems to be a real lose, we'll use one of
- c our own. it's been run through many of the tests in knuth vol. 2 and
- c seems to be quite reliable. ran returns a value uniformly selected
- c between 0 and range-1. note resemblance to alg used in wizard.
-
- implicit integer*4 (a-z)
- integer*2 range
- data r/-1/
- d=1
- if(r.ne.-1)goto 1
- call datime(d,t)
- r=18*t+5
- d=1000+mod(d,1000)
- 1 do 2 t=1,d
- 2 r=mod(r*1021,1048576)
- rn=(range*r)/1048576
- ran=rn
- return
- end
-
- c ======= end =======
-