program advent c c For x86_64, pgf77/ifort/gfortran, S. O. Lidie, 2015.04.01 c Tested On Mac OS X Yosemite and CentOS 6.x. c c Update for NOS/VE 1.4.x, 89/11/03. SOL, LUCC. c c Convert to NOS/VE: use direct access reads instead of word addressable c NOS CRM files. S. O. Lidie, 87/05/01, LUCC. NOS/VE 1.2.2 L678 c c Program last updated from SCOPE 3.4 to NOS 1.3 by c Bill Hein and Shelley Hobson (ACCA). c c Modified by Kent Blackett c Engineering Systems Group c Digital Equipment Corp. c 15-JUL-77 c Modified by Bob Supnik c Disk Engineering c 21-OCT-77 c Original version was for DECsystem-10 c Next version was for FORTRAN IV-Plus under c the IAS operating system on the PDP-11/70 c This version is for FORTRAN IV (V01C or later) c under RT-11 on *any* PDP-11.* c c c Current limits: c 750 travel options (travel, trvsiz). c 300 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 211 random messages (rtext, rtxsiz). c 12 different player classifications (ctext, cval, clsmax). c 20 hints, less 3 (hintlc, hinted, hints, hntsiz). c 35 magic messages (mtext, magsiz). c There are also limits which cannot be exceeded due to the structure o c the database. (e.g., the vocabulary uses n/1000 to determine word ty 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 implicit integer (a-z) logical blklin,noinpt * logical wizsw logical lmwarn,closng,panic,hinted, 1 closed,gaveup,scorng,dseen c common /txtcom/ rtext,lines,ascvar common /blkcom/ blklin,noinpt common/alphas/blank,eofm common /voccom/ ktab,atab ,tabsiz common /placom/ atloc,link,place,fixed,holdng common /mtxcom/ mtext common /ptxcom/ ptext common /abbcom/ abb common /miscom/ linuse,trvs,clsses,oldloc,loc,cval,tk,newloc, 1key,plac,fixd,actspk,cond,hints,hntmax,prop,tally,tally2, 2 hintlc,chloc,chloc2,dseen,dflag,dloc,daltlc,keys,lamp,grate, 3 cage,rod,rod2,steps,bird,door,pillow,snake,fissur,tablet, 4 clam,oyster,magzin,dwarf,knife,food,bottle,water,oil,plant, 5 plant2,axe,mirror,dragon,chasm,troll,troll2,bear,messag,vend, 6 batter,nugget,coins,chest,eggs,tridnt,vase,emrald,pyram, 7 pearl,rug,chain,back,look,cave,null,entrnc,dprssn,say,lock, 8 throw,find,invent,turns,lmwarn,knfloc,detail,abbnum, 9 numdie,maxdie,dkill,foobar,bonus,clock1,clock2, 1closng,panic,closed,gaveup,scorng,odloc,stream,orb common /misc2/ i,rtxsiz,clsmax,magsiz,locsiz,ctext,stext,ltext, 1sect,travel,trvcon,trvloc,trvsiz,tabndx,obj,j,k,verb,hntsiz, 2 maxtrs,hinted,hntloc,kk * common /tiktok/ t(4), wizsw c dimension lines(18) dimension travel(800),trvcon(800),trvloc(800) dimension ktab(300),atab(300) dimension ltext(150),stext(150),key(150),cond(150),abb(150), 1 atloc(150) dimension plac(100),place(100),fixd(100),fixed(100),link(200), 1 ptext(100),prop(100) dimension actspk(35) dimension rtext(212) dimension ctext(12),cval(12) dimension hintlc(20),hinted(20),hints(20,4) dimension mtext(35) dimension tk(20),dseen(6),dloc(6),odloc(6) c * data t/"06:00:00", "11:30:00", "13:30:00", "15:30:00"/ data blank/8h /,eofm/3h>$ c (moving "fixed" second loc), don't change place or holdng. c implicit integer (a-z) common /placom/ atloc,link,place,fixed,holdng dimension atloc(150),link(200),place(100),fixed(100) c 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 c c c subroutine drop(object,where) c c place an object at a given loc, prefixing it onto the atloc list. de c holdng if the object was being toted. c implicit integer (a-z) common /placom/ atloc,link,place,fixed,holdng dimension atloc(150) dimension link(200) dimension place(100) dimension fixed(100) c 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 INTEGER FUNCTION RND(X) INTEGER X C Return random integer 0 .. X #if (! defined __GFORTRAN__) integer r r = irandm( 0 ) rnd = mod(r, x ) #else real r r = rand( 0 ) rnd = int( r * x ) #endif END c c c c subroutine bug(num) implicit integer (a-z) c c the following conditions are currently considered fatal bugs. number c are detected while reading the database; the others occur at "run tim c 0 message line > 70 characters c 1 null line in message c 2 too many words of messages c 3 too many travel options c 4 too many vocabulary words c 5 required vocabulary word not found c 6 too many rtext or mtext 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 print (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 c 29 input in 1 word exceeds 10 chars. c print 1, num 1 format (' Fatal error ',i3,', consult your local Wizard.'/) call exit end c i/o routines (speak, pspeak, rspeak, getin, yes) c c subroutine speak(n) c c print the message in record n of the random access message file. c precede it with a blank line unless blklin is false. c implicit integer (a-z) logical blklin,noinpt common /txtcom/ rtext,lines,ascvar common /blkcom/ blklin,noinpt common /alphas/ blank,eofm dimension rtext(212),lines(18) c if(n.eq.0)return read (2, '(i4, 18a4)', rec=n) loc, lines if(lines(1).eq.eofm)return if(blklin.and.noinpt) print 2 noinpt=.true. n1=n+1 1 oldloc = loc do 3 ii=1,18 i=19-ii l = i if(lines(i) .ne. blank) go to 5 3 continue 5 print 2,(lines(i),i=1,l) 2 format(18a4) read( 2, '(i4, 18a4)', rec=n1) loc, lines n1=n1+1 if(loc .eq. oldloc) go to 1 return end c c c subroutine pspeak(msg,skip) c c find the skip+1st message for object msg and print it. c msg should be the index of c the object. (inven+n+1 message is prop=n message). c implicit integer (a-z) common /txtcom/ rtext,lines,ascvar common /ptxcom/ ptext dimension rtext(212),lines(18),ptext(100) c m=ptext(msg) if(skip.lt.0)goto 9 skip1=skip+1 oldloc=msg do 3 i=1,skip1 1 read( 2, '(i4,18a4)', rec=m) loc, lines m=m+1 if(loc.eq.oldloc) go to 1 oldloc=loc 3 continue m=m-1 9 call speak(m) return end c c c subroutine rspeak(i) c c print the i-th "random" message (section 6 of database). c implicit integer (a-z) common /txtcom/ rtext dimension rtext(212) c if(i.ne.0)call speak(rtext(i)) return end c c c c subroutine mspeak(i) c c print the i-th "magic" message from section 12 of database c implicit integer (a-z) common /mtxcom/ mtext dimension mtext (35) c if(i.ne.0) call speak(mtext(i)) return end c c subroutine getin( word1, word2, wordfull ) c c Get a command from the adventurer. Snarf out at most two words and ensure c they are upper case and at most 4 characters in length for the vocabulary c comparisons. WORDFULL, all lower case, is they entire spelling of either c the first word if there is no second word, else the second word ... for c human messages. c implicit integer (a-z) logical blklin,noinpt common /blkcom/ blklin,noinpt character*81 in character*81 in0 character*81 w1 character*81 w2 character*20 wordfull 100 continue noinpt = .false. if( blklin ) print 1 in = "" w1 = "" w2 = "" wordfull = "" inc = 1 w1c = 1 w2c = 1 word1 = 0 word2 = 0 write( 6, '(A$)' ) "Adventure>" read ( 5, 2, end=600 ) in0 * upper case input do i = 1, len(in0) #if (! defined __GFORTRAN__) j = ichar(in0(i:i)) if (j>= ichar("a") .and. j<=ichar("z") ) then in(i:i) = char(ichar(in0(i:i))-32) else in(i:i) = in0(i:i) end if #else j = iachar(in0(i:i)) if (j>= iachar("a") .and. j<=iachar("z") ) then in(i:i) = achar(iachar(in0(i:i))-32) else in(i:i) = in0(i:i) end if #endif end do * skip leading spaces do 201 c = inc, 81 if( in(c:c) .ne. " " ) goto 202 inc = inc + 1 201 continue 202 continue * collect non-space characters in w1 do 301 c = inc, 81 if( in(c:c) .eq. " " ) goto 302 w1(w1c:w1c) = in(c:c) w1c = w1c + 1 inc = inc + 1 301 continue 302 continue * skip leading spaces do 401 c = inc, 81 if( in(c:c) .ne. " " ) goto 402 inc = inc +1 401 continue 402 continue * collect non-space characters in w2 do 501 c = inc, 81 if( in(c:c) .eq. " " ) goto 502 w2(w2c:w2c) = in(c:c) w2c = w2c + 1 inc = inc + 1 501 continue 502 continue if ( w1 .ne. "" ) then read( w1, 3 ) word1 wordfull = w1 endif if ( w2 .ne. "" ) then read( w2, 3 ) word2 wordfull = w2 endif * lower case wordfull do i = 1, len(wordfull) #if (! defined __GFORTRAN__) j = ichar(wordfull(i:i)) if (j>= ichar("A") .and. j<=ichar("Z") ) then wordfull(i:i) = char(ichar(wordfull(i:i))+32) else wordfull(i:i) = wordfull(i:i) end if #else j = iachar(wordfull(i:i)) if (j>= iachar("A") .and. j<=iachar("Z") ) then wordfull(i:i) = achar(iachar(wordfull(i:i))+32) else wordfull(i:i) = wordfull(i:i) end if #endif end do return 600 continue close(unit=5) open(unit=5, file='/dev/tty') goto 100 1 format( 1x ) 2 format( a81 ) 3 format( a4 ) end c logical function yes(x,y,z) c c call yesx (below) with messages from section 6. c implicit integer (a-z) external rspeak logical yesx c yes=yesx(x,y,z,rspeak) return end c c c logical function yesm(x,y,z) c c call yesx (below) with messages from section 12. c implicit integer (a-z) external mspeak logical yesx c yesm=yesx(x,y,z,mspeak) return end c c c logical function yesx(x,y,z,spk) c c print message x, wait for yes/no answer. if yes, print y and leave y c true; if no, print z and leave yea false. spk is either rspeak or ms c implicit integer (a-z) character*1 reply common /alphas/ blank,eofm c 1 if(x.ne.0)call spk(x) read (5,3,end=8) reply 3 format(bz,a1) 10000 continue c if(eof(5)) 8,7,8 7 if ((reply.eq."Y") .or. (reply.eq."y")) goto 10 if ((reply.eq."N") .or. (reply.eq."n")) goto 20 8 print 9 9 format(/'Please answer the question.') close(unit=5) open(unit=5, file='/dev/tty') goto 1 10 yesx=.true. if(y.ne.0)call spk(y) return 20 yesx=.false. if(z.ne.0)call spk(z) return end subroutine exitadv call exit end integer function ishft (var,count) implicit integer (a-z) ivar = var icount = count c c c this beast replaces adv004.for c result = ishft(variable,count) c on shifts to the right the sign bit is zeroed c c c if count=0, no shift occurs c if count>0, a left shift occurs c if count<0, a right shift occurs c c ivar= and( ivar, '177777'O ) ishft=ivar if (icount.eq.0) return if (icount.lt.0) go to 1 #if defined(__INTEL_COMPILER) || defined(__GFORTRAN__) ishft=ISHFTC(ivar,icount) #elif defined (__PGI_COMPILER) ishft=shift(ivar,icount) #else #error FORTRAN Compiler not defined #endif return c shift right one bit and clear sign bit * print *,"this shift is WRONG" c orig 1 tshft=shift(ivar,-1).and.z"8fffffffffffffff" #if defined(__INTEL_COMPILER) || defined(__GFORTRAN__) 1 tshft= and( ISHFTC(ivar,-1), '8fffffff'x ) ishft=ISHFTC(tshft,-(icount-1)) #elif defined (__PGI_COMPILER) 1 tshft=shift(ivar,-1).and.'8fffffff'x ishft=shift(tshft,-(icount-1)) #else #error FORTRAN Compiler not defined #endif return end subroutine init c implicit integer (a-z) logical blklin,noinpt logical forced, pct logical dseen,hinted logical bitset,lmwarn,closng,panic, 1 closed,gaveup,scorng c common /txtcom/ rtext,lines,ascvar common /blkcom/ blklin,noinpt common /voccom/ ktab,atab ,tabsiz common /placom/ atloc,link,place,fixed,holdng common /mtxcom/ mtext common /ptxcom/ ptext common /abbcom/ abb common /miscom/ linuse,trvs,clsses,oldloc,loc,cval,tk,newloc, 1 key,plac,fixd,actspk,cond,hints,hntmax,prop,tally,tally2, 2 hintlc,chloc,chloc2,dseen,dflag,dloc,daltlc,keys,lamp,grate, 3 cage,rod,rod2,steps,bird,door,pillow,snake,fissur,tablet, 4 clam,oyster,magzin,dwarf,knife,food,bottle,water,oil,plant, 5 plant2,axe,mirror,dragon,chasm,troll,troll2,bear,messag,vend, 6 batter,nugget,coins,chest,eggs,tridnt,vase,emrald,pyram, 7 pearl,rug,chain,back,look,cave,null,entrnc,dprssn,say,lock, 8 throw,find,invent,turns,lmwarn,knfloc,detail,abbnum, 9 numdie,maxdie,dkill,foobar,bonus,clock1,clock2, 1 closng,panic,closed,gaveup,scorng,odloc,stream,orb common /misc2/ i,rtxsiz,clsmax,magsiz,locsiz,ctext,stext,ltext, 1 sect,travel,trvcon,trvloc,trvsiz,tabndx,obj,j,k,verb,hntsiz, 2 maxtrs,hinted,hntloc,kk c dimension lines(18) dimension travel(800),trvcon(800),trvloc(800) dimension ktab(300),atab(300) dimension ltext(150),stext(150),key(150),cond(150),abb(150), 1 atloc(150) dimension plac(100),place(100),fixd(100),fixed(100),link(200), 1 ptext(100),prop(100) dimension actspk(35) dimension rtext(212) dimension ctext(12),cval(12) dimension hintlc(20),hinted(20),hints(20,4) dimension mtext(35) dimension tk(20),dseen(6),dloc(6),odloc(6) c ENV variable BUILD_Adventure determines when to rebuild the database: c 0 = use existing c 1 = build a new version character*80 envvalue c c * bitset(l,n)=(cond(l).and.ishft(1,n)).ne.0 bitset(l,n)= ( and( cond(l), ishft(1,n) ) ) .ne.0 c description of the database format c c c the data file contains several sections. each begins with a line con 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 num c a comma, and a line of text. the set of (necessarily adjacent) li c whose numbers are x form the long description of location x. c section 2: short form descriptions. same format as long form. not a c places have short descriptions. c section 3: travel table. each line contains a location number (x), a 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 300500 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$<". c section 6: arbitrary messages. same format as sections 1, 2, and 5, c the numbers bear no relation to anything (except for special verbs c in section 4). c section 7: object locations. each line contains an object number and 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 loca c (e.g. the grate) the first location is followed with the second, a c the object is assumed to be immovable. c section 8: action defaults. each line contains an "action-verb" numb c the index (in section 6) of the default message for the verb. c section 9: liquid assets, etc. each line contains a number (n) and u c location numbers. bit n (where 0 is the units bit) is set in cond 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" routin 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 force c motion. c section 10: class messages. each line contains a number (n), a tab, c message describing a classification of player. the scoring sectio c selects the appropriate message, where each message is considered c apply to players whose scores are higher than the previous n but n c higher than this n. note that these scores probably change with e c modification (and particularly expansion) of the program. c section 11: hints. each line contains a hint number (corresponding t c cond bit, see section 9), the number of turns he must be at the ri c loc(s) before triggering the hint, the points deducted for taking c hint, the message number (section 6) of the question, and the mess 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 l c points). c section 12: magic messages. identical to section 6 except put in a se c section for easier reference. magic messages are used by the star c maintenance mode, and related routines. c section 0: end of database. c read the database if we have not yet done so c open (unit=5, file='INPUT') c open (unit=6, file='OUTPUT') * call timer open(unit=5, file='/dev/tty') c Initialize random number generator. #if (! defined __GFORTRAN__ ) ijkl = irandm( time() ) #else call srand( time() ) #endif c filsiz=2100 tabsiz=300 locsiz=150 vrbsiz=35 blklin=.true. noinpt=.true. rtxsiz = 211 hntsiz = 20 magsiz = 35 trvsiz = 800 clsmax = 12 vcount = 0 c Check Build_Adventure environment variable and convert to an integer, must be 0 or 1. call getenv( "BUILD_Adventure", envvalue) read(envvalue, 71) i 71 format(i1) i = i + 1 if ( i .eq. 1 ) then open (unit=2, file='Adventure.text.db', access='DIRECT', + recl=76, form='FORMATTED') open (unit=3, file='Adventure.save', form='unformatted', + status='old') call restoregm return endif * Create initial text database and save state files. print 123 123 format("Creating new 'Adventure.text.db'") open (unit=1, file='src/Adventure.text', status='OLD') open (unit=2, file='etc/Adventure.text.db', access='DIRECT', + recl=76,form='FORMATTED', status='new') open (unit=3, file='etc/Adventure.save.init', form='unformatted') print 1000 1000 format('Wait a minute... I can''t find the keys...') * endfile 6 c c clear out the various text-pointer arrays. all text is stored in dis c file (random access on unit 2). the text-pointer arrays contain reco c numbers in the file. stext(n) is short description of location n. c ltext(n) is long description. ptext(n) points to message for prop(n) c successive prop messages are found by chasing pointers. rtext contai c section 6's stuff. ctext(n) points to a player-class message. mtext c section 12. we also clear cond. see description of section 9 for de c do 1001 i=1,tabsiz ktab(i)=0 atab(i)=0 if(i.gt.100) go to 1990 ptext(i)=0 prop(i)=0 plac(i)=0 place(i)=0 fixd(i)=0 fixed(i)=0 link(i)=0 link(i+100)=0 1990 if(i.le.rtxsiz)rtext(i)=0 if(i.le.clsmax)ctext(i)=0 if(i.le.magsiz)mtext(i)=0 if(i.le.vrbsiz)actspk(i)=0 if(i.gt.locsiz)goto 1001 key(i)=0 abb(i)=0 atloc(i)=0 stext(i)=0 ltext(i)=0 cond(i)=0 1001 continue c wrdsum=1 ascvar=1 wasiz=19 wasiz10=370 linuse=1 - 1 trvs=1 clsses=1 c c start new data section. sect is the section number. c 1002 read(1,1003,end=10000)sect 1003 format(bz,i5) c print 930,sect c930 format(' now loading section',i3) 10000 oldloc=-1 if(sect+1.le.0 .or. sect+1.gt.13) call bug(9) print 125, sect 125 format("Initializing section #",i4) goto(1100,1004,1004,1030,1040,1004,1004,1050,1060,1070,1004, 1 1080,1004) (sect+1) call gotoer c (0) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10) c (11) (12) c c sections 1, 2, 5, 6, 10, 12. read messages and set up pointers. c 1004 read(1,1005,end=10001) loc, lines 1005 format(bz,i4,18a4) 10001 continue write (2, '(i4, 18a4)', rec=linuse+1) loc, lines linuse = linuse + 1 if(loc .eq. -1) go to 1002 if(loc .eq. oldloc) go to 1020 if(sect.eq.12)goto 1013 if(sect.eq.10)goto 1012 if(sect.eq.6)goto 1011 if(sect.eq.5)goto 1010 if(sect.eq.1)goto 1008 c stext(loc)=linuse goto 1020 c 1008 ltext(loc)=linuse goto 1020 c 1010 if(loc.gt.0.and.loc.le.100)ptext(loc)=linuse goto 1020 c 1011 if(loc .gt. rtxsiz) call bug(6) rtext(loc)=linuse goto 1020 c 1012 ctext(clsses)=linuse cval(clsses)=loc clsses=clsses+1 goto 1020 c 1013 continue if(loc.gt.magsiz)call bug(6) mtext(loc)=linuse c 1020 oldloc = loc if(linuse .ge. filsiz) call bug(2) goto 1004 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 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 tra c of the first option at location n. c c special conditions on travel are encoded in the corresponding c entries of trvcon. the new location is in trvloc. c c 1030 read(1,1031,end=10002)loc,j,newloc,tk 1031 format(bz,23i5) 10002 if(loc.eq.-1)goto 1002 if(key(loc).ne.0)goto 1033 key(loc)=trvs goto 1035 1033 travel(trvs-1)=-travel(trvs-1) 1035 do 1037 l=1,20 if(tk(l).eq.0)goto 1039 travel(trvs)=tk(l) trvloc(trvs)=newloc trvcon(trvs)=j trvs=trvs+1 if(trvs.eq.trvsiz)call bug(3) 1037 continue 1039 travel(trvs-1)=-travel(trvs-1) goto 1030 c c here we read in the vocabulary. ktab(n) is the word number, atab(n) c the corresponding word. the -1 at the end of section 4 is left in kt c as an end-marker. c 1040 do 1042 tabndx=1,tabsiz 1043 read(1,1041,end=10003)ktab(tabndx),atab(tabndx) 1041 format(bz,i6,a4) 10003 if(ktab(tabndx).eq.-1)goto 1002 1042 continue call bug(4) c c read in the initial locations for each object. also the immovability 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 1050 read(1,1031,end=10004)obj,j,k 10004 if(obj.eq.-1)goto 1002 plac(obj)=j fixd(obj)=k goto 1050 c c read default message numbers for action verbs, store in actspk. c 1060 read(1,1031,end=10005)verb,j 10005 if(verb.eq.-1)goto 1002 actspk(verb)=j vcount=max0(verb,vcount) goto 1060 c c read info about available liquids and other conditions, store in cond c 1070 read(1,1031,end=10006)k,tk 10006 if(k.eq.-1)goto 1002 do 1071 i=1,20 loc=tk(i) if(loc.eq.0)goto 1070 if(bitset(loc,k))call bug(8) 1071 cond(loc)=cond(loc)+ishft(1,k) goto 1070 c c read data for hints. c 1080 hntmax=0 1081 read(1,1031,end=10007)k,tk 10007 if(k.eq.-1)goto 1002 if(k.lt.0.or.k.gt.hntsiz)call bug(7) do 1083 i=1,4 1083 hints(k,i)=tk(i) hntmax=max0(hntmax,k) goto 1081 c finish constructing internal data format c 1100 continue c c having read in the database, certain things are now constructed. pro c set to zero. we finish setting up cond by checking for forced-motion c entries. the plac and fixd arrays are used to set up atloc(n) as the c object at location n, and link(obj) as the next object at the same lo c as obj. (obj>100 indicates that fixed(obj-100)=loc; link(obj) is sti c correct link to use.) abb is zeroed; it controls whether the abbrevi c description is printed. counts mod 5 unless "look" is used. c c c if the first motion verb is 1 (illegal), then this is a forced c motion entry. c do 1102 i=1,locsiz if(ltext(i).eq.0.or.key(i).eq.0)goto 1102 k=key(i) if(iabs(travel(k)).eq.1)cond(i)=2 1102 continue c c set up the atloc and link arrays as described above. we'll use the d c subroutine, which prefaces new objects on the lists. since we want t c in the other order, we'll run the loop backwards. if the object is i c locs, we drop it twice. this also sets up "place" and "fixed" as cop c "plac" and "fixd". also, since two-placed objects are typically best c described last, we'll drop them first. c do 1106 i=1,100 k=101-i if(fixd(k).le.0)goto 1106 call drop(k+100,fixd(k)) call drop(k,plac(k)) 1106 continue c do 1107 i=1,100 k=101-i fixed(k)=fixd(k) 1107 if(plac(k).ne.0.and.fixd(k).le.0)call drop(k,plac(k)) c c treasures, as noted earlier, are objects 50 through maxtrs (currently c their props are initially -1, and are set to 0 the first time they ar c described. tally keeps track of how many are not yet found, so we kn c when to close the cave. tally2 counts how many can never be found (e c lost bird or bridge). c maxtrs=79 tally=0 tally2=0 do 1200 i=50,maxtrs if(ptext(i).ne.0)prop(i)=-1 1200 tally=tally-prop(i) c c clear the hint stuff. hintlc(i) is how long he's been at loc with co c i. hinted(i) is true iff hint i has been used. c do 1300 i=1,hntmax hinted(i)=.false. 1300 hintlc(i)=0 c print 931,tabndx,tabsiz,vcount,vrbsiz,clsses,clsmax, 1 hntmax,hntsiz,trvs,trvsiz,linuse,filsiz 931 format('Used vs max table values:'/ 1 1x,i5,' of ',i5,' vocab entries'/ 2 1x,i5,' of ',i5,' verb entries'/ 3 1x,i5,' of ',i5,' class entries'/ 4 1x,i5,' of ',i5,' hint entries'/ 5 1x,i5,' of ',i5,' travel entries'/ 6 1x,i5,' of ',i5,' file records' 9 ) c c define some handy mnemonics. these correspond to object numbers. c call vocab("KEYS",1,keys) call vocab("LAMP",1,lamp) call vocab("GRAT",1,grate) call vocab("CAGE",1,cage) call vocab("ROD ",1,rod) rod2=rod+1 call vocab("STEP",1,steps) call vocab ("BIRD",1,bird) call vocab("DOOR",1,door) call vocab("PILL",1,pillow) call vocab("SNAK",1,snake) call vocab("FISS",1,fissur) call vocab("TABL",1,tablet) call vocab("CLAM",1,clam) call vocab ("OYST",1,oyster) call vocab("MAGA",1,magzin) call vocab("DWAR",1,dwarf) call vocab("KNIF",1,knife) call vocab("FOOD",1,food) call vocab("BOTT",1,bottle) call vocab("WATE",1,water) call vocab("OIL ",1,oil) call vocab("PLAN",1,plant) plant2=plant+1 CALL VOCAB("AXE ",1,AXE) CALL VOCAB("MIRR",1,MIRROR) CALL VOCAB("DRAG",1,DRAGON) CALL VOCAB("CHAS",1,CHASM) CALL VOCAB("TROL",1,TROLL) TROLL2=TROLL+1 CALL VOCAB("BEAR",1,BEAR) CALL VOCAB("MESS",1,MESSAG) CALL VOCAB("VEND",1,VEND) CALL VOCAB("BATT",1,BATTER) C C OBJECTS FROM 50 THROUGH WHATEVER ARE TREASURES. HERE ARE A FEW. C CALL VOCAB("GOLD",1,NUGGET) CALL VOCAB("COIN",1,COINS) CALL VOCAB("CHES",1,CHEST) CALL VOCAB("EGGS",1,EGGS) CALL VOCAB("TRID",1,TRIDNT) CALL VOCAB("VASE",1,VASE) CALL VOCAB("EMER",1,EMRALD) CALL VOCAB("PYRA",1,PYRAM) CALL VOCAB("PEAR",1,PEARL) CALL VOCAB("RUG ",1,RUG) CALL VOCAB("CHAI",1,CHAIN) CALL VOCAB("ORB ",1,ORB) C C THESE ARE MOTION-VERB NUMBERS. C CALL VOCAB("BACK",0,BACK) CALL VOCAB("LOOK",0,LOOK) CALL VOCAB("CAVE",0,CAVE) CALL VOCAB("NULL",0,NULL) CALL VOCAB("ENTR",0,ENTRNC) CALL VOCAB("DEPR",0,DPRSSN) CALL VOCAB("STRE",0,STREAM) C C AND SOME ACTION VERBS. C CALL VOCAB("SAY ",2,SAY) CALL VOCAB("LOCK",2,LOCK) CALL VOCAB("THRO",2,THROW) CALL VOCAB("FIND",2,FIND) CALL VOCAB("INVE",2,INVENT) c c initialise the dwarves. dloc is loc of dwarves, hard-wired in. odlo c prior loc of each dwarf, initially garbage. daltlc is alternate init c for dwarf, in case one of them starts out on top of the adventurer. c of the 5 initial locs are adjacent.) dseen is true if dwarf has seen 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 re c the dead end in the other maze has its loc stored in chloc2. c chloc=114 chloc2=140 do 1700 i=1,6 1700 dseen(i)=.false. dflag=0 dloc(1)=19 dloc(2)=27 dloc(3)=33 dloc(4)=44 dloc(5)=64 dloc(6)=chloc daltlc=18 c 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 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 ms 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 turns=0 lmwarn=.false. knfloc=0 detail=0 abbnum=5 do 1800 itemp=1,5 i=itemp-1 if(rtext(2*i+81).ne.0)maxdie=i+1 1800 continue numdie=0 holdng=0 dkill=0 foobar=0 bonus=0 clock1=30 clock2=50 closng=.false. panic=.false. closed=.false. gaveup=.false. scorng=.false. c c c c finally, since we're clearly setting things up for the first time... c print 999 999 format('OK, I got them...oh, yes....orange smoke...',/ +'Well, here goes...') newloc=1 loc = newloc print 124 124 format("Creating new 'Adventure.save.init'") call savegm( 0 ) CALL EXIT end subroutine main c implicit integer (a-z) character * 8, time, when character*4 holl2char character*20 wdfull logical blklin,noinpt * logical wizsw logical forced, pct logical dseen,hinted,yes logical toting,here,at,bitset,dark,wzdark,lmwarn,closng,panic, 1 closed,gaveup,scorng,yea c common /txtcom/ rtext,lines,ascvar common /blkcom/ blklin,noinpt common /alphas/ blank,eofm common /voccom/ ktab,atab ,tabsiz common /placom/ atloc,link,place,fixed,holdng common /mtxcom/ mtext common /ptxcom/ ptext common /abbcom/ abb common /miscom/ linuse,trvs,clsses,oldloc,loc,cval,tk,newloc, 1 key,plac,fixd,actspk,cond,hints,hntmax,prop,tally,tally2, 2 hintlc,chloc,chloc2,dseen,dflag,dloc,daltlc,keys,lamp,grate, 3 cage,rod,rod2,steps,bird,door,pillow,snake,fissur,tablet, 4 clam,oyster,magzin,dwarf,knife,food,bottle,water,oil,plant, 5 plant2,axe,mirror,dragon,chasm,troll,troll2,bear,messag,vend, 6 batter,nugget,coins,chest,eggs,tridnt,vase,emrald,pyram, 7 pearl,rug,chain,back,look,cave,null,entrnc,dprssn,say,lock, 8 throw,find,invent,turns,lmwarn,knfloc,detail,abbnum, 9 numdie,maxdie,dkill,foobar,bonus,clock1,clock2, 1 closng,panic,closed,gaveup,scorng,odloc,stream,orb common /misc2/ i,rtxsiz,clsmax,magsiz,locsiz,ctext,stext,ltext, 1 sect,travel,trvcon,trvloc,trvsiz,tabndx,obj,j,k,verb,hntsiz, 2 maxtrs,hinted,hntloc,kk c * common /tiktok/ t(4), wizsw dimension lines(18) dimension travel(800),trvcon(800),trvloc(800) dimension ktab(300),atab(300) dimension ltext(150),stext(150),key(150),cond(150),abb(150), 1 atloc(150) dimension plac(100),place(100),fixd(100),fixed(100),link(200), 1 ptext(100),prop(100) dimension actspk(35) dimension rtext(212) dimension ctext(12),cval(12) dimension hintlc(20),hinted(20),hints(20,4) dimension mtext(35) dimension tk(20),dseen(6),dloc(6),odloc(6) c c statement functions c 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 from 0 to 100) c 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" c c demo is true if this is a prime-time demonstration game c yea is random yes/no reply c c toting(obj)=place(obj).eq.-1 here(obj)=place(obj).eq.loc.or.toting(obj) at(obj)=place(obj).eq.loc.or.fixed(obj).eq.loc liq2(pbotl)=(1-pbotl)*water+(pbotl/2)*(water+oil) liq(dummy)=liq2(max0(prop(bottle),-1-prop(bottle))) liqloc(loc)=liq2((mod(cond(loc)/2*2,8)-5)*mod(cond(loc)/4,2)+1) * bitset(l,n)=(cond(l).and.ishft(1,n)).ne.0 bitset(l,n)= ( and (cond(l), ishft(1,n) ) ) .ne.0 forced(loc)=cond(loc).eq.2 dark(dummy)=mod(cond(loc),2).eq.0.and.(prop(lamp).eq.0.or. 1 .not.here(lamp)) pct(n)=rnd(100).lt.n c description of the database format c c c the data file contains several sections. each begins with a line con 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 num c a comma, and a line of text. the set of (necessarily adjacent) li c whose numbers are x form the long description of location x. c section 2: short form descriptions. same format as long form. not a c places have short descriptions. c section 3: travel table. each line contains a location number (x), a 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 300500 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$<". c section 6: arbitrary messages. same format as sections 1, 2, and 5, c the numbers bear no relation to anything (except for special verbs c in section 4). c section 7: object locations. each line contains an object number and 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 loca c (e.g. the grate) the first location is followed with the second, a c the object is assumed to be immovable. c section 8: action defaults. each line contains an "action-verb" numb c the index (in section 6) of the default message for the verb. c section 9: liquid assets, etc. each line contains a number (n) and u c location numbers. bit n (where 0 is the units bit) is set in cond 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" routin 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 force c motion. c section 10: class messages. each line contains a number (n), a tab, c message describing a classification of player. the scoring sectio c selects the appropriate message, where each message is considered c apply to players whose scores are higher than the previous n but n c higher than this n. note that these scores probably change with e c modification (and particularly expansion) of the program. c section 11: hints. each line contains a hint number (corresponding t c cond bit, see section 9), the number of turns he must be at the ri c loc(s) before triggering the hint, the points deducted for taking c hint, the message number (section 6) of the question, and the mess 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 l c points). c section 12: magic messages. identical to section 6 except put in a se c section for easier reference. magic messages are used by the star c maintenance mode, and related routines. c section 0: end of database. c start-up, dwarf stuff c 1 i=rnd(1) if ( .not. hinted(3) ) hinted(3) = yes( 65, 1, 0 ) newloc = loc limit=340 if(hinted(3))limit=1000 c c can't leave cave once it's closing (except by main office). c 2 if(newloc.ge.9.or.newloc.eq.0.or..not.closng)goto 71 call rspeak(130) newloc=loc if(.not.panic)clock2=15 panic=.true. c c see if a dwarf has seen him and has come from where he wants to go. c the dwarf's blocking his way. if coming from place forbidden to pira c (dwarves rooted in place) let him get out (and attacked). c 71 if(newloc.eq.loc.or.forced(loc).or.bitset(loc,3))goto 74 do 73 i=1,5 if(odloc(i).ne.newloc.or..not.dseen(i))goto 73 newloc=loc call rspeak(2) goto 74 73 continue 74 loc=newloc c c dwarf stuff. see earlier comments for description of variables. rem c sixth dwarf is pirate and is thus very different except for motion ru c c first off, don't let the dwarves follow him into a pit or a wall. ac c the whole mess the first time he gets as far as the hall of mists (lo c if newloc is forbidden to pirate (in particular, if it's beyond the t c bridge), bypass dwarf stuff. that way pirate can't steal return toll c dwarves can't meet the bear. also means dwarves won't follow him int c end in maze, but c'est la vie. they'll wait for him outside the dead c if(loc.eq.0.or.forced(loc).or.bitset(newloc,3))goto 2000 if(dflag.ne.0)goto 6000 if(loc.ge.15)dflag=1 goto 2000 c c when we encounter the first dwarf, we kill 0, 1, or 2 of the 5 dwarve c any of the survivors is at loc, replace him with the alternate. c 6000 if(dflag.ne.1)goto 6010 if(loc.lt.15.or.pct(80))goto 2000 dflag=2 do 6001 i=1,2 j=1+rnd(5) 6001 if(pct(50))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 c things are in full swing. move each dwarf at random, except if he's c he sticks with us. dwarves never go to locs <15. if wandering at ra c they don't back up unless there's no alternative. if they don't have c move, they attack. and, of course, dead dwarves don't do much of any c 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=trvloc(kk) if(newloc.gt.300.or.newloc.lt.15.or.newloc.eq.odloc(i) 1 .or.(j.gt.1.and.newloc.eq.tk(j-1)).or.j.ge.20 2 .or.newloc.eq.dloc(i).or.forced(newloc) 3 .or.(i.eq.6.and.bitset(newloc,3)) 4 .or.trvcon(kk).eq.100)goto 6014 tk(j)=newloc j=j+1 6014 kk=kk+1 if(travel(kk-1).ge.0)goto 6012 6016 tk(j)=odloc(i) if(j.ge.2)j=j-1 j=1+rnd(j) odloc(i)=dloc(i) dloc(i)=tk(j) dseen(i)=(dseen(i).and.loc.ge.15) 1 .or.(dloc(i).eq.loc.or.odloc(i).eq.loc) if(.not.dseen(i))goto 6030 dloc(i)=loc if(i.ne.6)goto 6027 c 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 fo c an unseen chest, let the pirate be spotted. c 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) 1 .or.loc.eq.plac(emrald)))goto 6020 if(toting(j))goto 6022 6020 if(here(j))k=1 if(tally.eq.tally2+1.and.k.eq.0.and.place(chest).eq.0 1 .and.here(lamp).and.prop(lamp).eq.1)goto 6025 if(odloc(6).ne.dloc(6).and.pct(80))call rspeak(127) goto 6030 c 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) 1 .or.loc.eq.plac(emrald)))goto 6023 if(at(j).and.fixed(j).eq.0)call carry(j,loc) if(toting(j))call drop(j,chloc) 6023 continue 6024 dloc(6)=chloc odloc(6)=chloc dseen(6)=.false. goto 6030 c 6025 call rspeak(186) call move(chest,chloc) call move(messag,chloc2) goto 6024 c c this threatening little dwarf is in the room with him! c 6027 dtotal=dtotal+1 if(odloc(i).ne.dloc(i))goto 6030 attack=attack+1 if(knfloc.ge.0)knfloc=loc if(rnd(1000).lt.95*(dflag-2))stick=stick+1 6030 continue c c now we know what's happening. let's tell the poor sucker about it. c if(dtotal.eq.0)goto 2000 if(dtotal.eq.1)goto 75 print 67,dtotal 67 format(/'There are ',i1,' threatening little dwarves in the' 1 ,' 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 print 78,attack 78 format(/1x,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 print 68,stick 68 format(/1x,i1,' of them get you!') 84 oldlc2=loc goto 99 c 79 call rspeak(5) k=52 goto 82 c describe the current location and (maybe) get next command. c c print text for current loc. c 2000 if(loc.eq.0)goto 99 kk=stext(loc) kent=0 if (abbnum.ne.0) kent=mod(abb(loc),abbnum) if (kent.eq.0.or.kk.eq.0) kk=ltext(loc) if(forced(loc).or..not.dark(0))goto 2001 if(wzdark.and.pct(35))goto 90 kk=rtext(16) 2001 if(toting(bear))call rspeak(141) call speak(kk) k=1 if(forced(loc))goto 8 if(loc.eq.33.and.pct(25).and..not.closng)call rspeak(8) c c print out descriptions of objects at this location. if not closing a c property value is negative, tally off another treasure. rug is speci 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 hac c are because prop=0 is needed to get full score. c if(dark(0))goto 2012 abb(loc)=abb(loc)+1 i=atloc(loc) 2004 if(i.eq.0)goto 2012 obj=i if(obj.gt.100)obj=obj-100 if(obj.eq.steps.and.toting(nugget))goto 2008 if(prop(obj).ge.0)goto 2006 if(closed)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 call pspeak(obj,kk) 2008 i=link(i) goto 2004 c 2009 k=54 2010 spk=k 2011 call rspeak(spk) c 2012 verb=0 obj=0 c c check if this loc is eligible for any hints. if been here long enoug c branch to help section (on later page). hints all come back here eve c to finish the loop. ignore "hints" < 4 (special stuff, see database c 2600 do 2602 hint=4,hntmax if(hinted(hint))goto 2602 if(.not.bitset(loc,hint))hintlc(hint)=-1 hintlc(hint)=hintlc(hint)+1 if(hintlc(hint).ge.hints(hint,1))goto 40000 2602 continue c c kick the random number generator just to add variety to the chase. a c if closing time, check for any objects being toted with prop < 0 and c the prop to -1-prop. this way objects won't be described until they' c been picked up and put down separate from their respective piles. do c tick clock1 unless well into cave (and not at y2). c if(.not.closed)goto 2605 if(prop(oyster).lt.0.and.toting(oyster)) 1 call pspeak(oyster,1) do 2604 i=1,100 2604 if(toting(i).and.prop(i).lt.0)prop(i)=-1-prop(i) 2605 wzdark=dark(0) if(knfloc.gt.0.and.knfloc.ne.loc)knfloc=0 i=rnd(1) call getin(wd1,wd2,wdfull) * print 123, wd1,wd2,wdfull * 123 format("wd1='",a4,"',wd2='",a4,"',wdfull='",a20,"'") goto 2608 * if (wizsw) go to 2608 * when = time() * 2100 format(a8) * read(when,2100) now * if (now .ge. t(1) .and. now .le. t(2)) go to 2611 * if (now .ge. t(3) .and. now .le. t(4)) go to 2611 * goto 2608 * 2611 print 2110,now * 2110 format(' You look at your watch and see it is now',/ * +1x,a9,' when...') * call mspeak(1) * scorng=.false. * goto 20000 c every input, check "foobar" flag. if zero, nothing's going on. if p c make neg. if neg, he skipped a word, so make it zero. c 2608 foobar=min0(0,-foobar) turns=turns+1 if(verb.eq.say.and.wd2.ne.0)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).and.prop(batter).eq.0 1 .and.here(lamp))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 c c do preliminary analysis of sentence to find certain special c cases, viz, c c enter c enter c c call vocab(wd1,-1,i) call vocab(wd2,-1,j) write( holl2char, 124 ) wd1 if( holl2char .ne."ente")goto 2609 if(j .eq. (water+1000) 1 .or. j .eq. stream) go to 2010 if(wd2 .ne. 0) go to 2800 2609 if((i .ne. (water+1000) .and. i .ne. (oil+1000)) 1 .or. (j .ne. (plant+1000) .and. j .ne. (door+1000))) 2 go to 2610 wd2=4hpour 2610 continue 124 format( a4 ) write( holl2char, 124 ) wd1 if( holl2char .eq."west".and.pct(10)) 1 call rspeak(17) 2630 call vocab(wd1,-1,i) if(i.eq.-1)goto 3000 k=mod(i,1000) kq=i/1000+1 if(kq.le.0 .or. kq.gt.4) call bug(22) goto (8,5000,4000,2010)kq call gotoer c c get second word for analysis. c 2800 wd1=wd2 wd2=0 goto 2610 c c gee, i don't understand. c 3000 spk=60 if(pct(20))spk=61 if(pct(20))spk=13 call rspeak(spk) goto 2600 c c analyse a verb. remember what it was, go back for object if second w c unless verb is "say", which snarfs arbitrary second word. c 4000 verb=k spk=actspk(verb) if(wd2.ne.0.and.verb.ne.say)goto 2800 if(verb.eq.say)obj=wd2 if(obj.ne.0)goto 4090 c c analyse an intransitive verb (ie, no object given yet). c 4080 if(verb.le.0 .or. verb.gt.33) call bug(23) goto(8010,8000,8000,8040,2009,8040,9070,9080,8000,8000, 1 2011,9120,9130,8140,9150,8000,8000,8180,8000,8200, 2 8000,9220,9230,8240,8250,8260,8270,8000,8000,8300, 3 8310,8320,8301)verb call gotoer 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,gaze rstr c c analyse a transitive verb. c 4090 if(verb.le.0 .or. verb.gt.33) call bug(24) goto(9010,9020,9030,9040,2009,9040,9070,9080,9090,2011, 1 2011,9120,9130,9140,9150,9160,9170,2011,9190,9190, 2 9210,9220,9230,2011,2011,2011,9270,9280,9290,2011, 3 2011,8320,8301)verb call gotoer 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,gaze rstr c c analyse an object word. see if the thing is here, whether we've got c yet, and so on. object must be here unless verb is "find" or "invent c (and no new verb yet to be analysed). water and oil are also funny, c they are never actually dropped at any location, but might be here in c the bottle or as a feature of the location. c 5000 obj=k if(fixed(k).ne.loc.and..not.here(k))goto 5100 5010 if(wd2.ne.0)goto 2800 if(verb.ne.0)goto 4090 * print 5015,wdfull * 5015 format('What do you want to do with the ',a20) call trmprt( "What do you want to do with the ", wdfull, "?" ) goto 2600 c 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)).or.k.eq.liqloc(loc))goto 5010 if(obj.ne.plant.or..not.at(plant2).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..not.here(rod2))goto 5190 obj=rod2 goto 5010 5190 if((verb.eq.find.or.verb.eq.invent).and.wd2.eq.0)goto 5010 * print 5199,wdfull * 5199 format('I don''t see any ', a20) call trmprt( "I don't see any ", wdfull, "." ) goto 2012 c figure out the new location c c given the current location in "loc", and a motion verb number in "k", c the new location in "newloc". the current loc is saved in "oldloc" i c he wants to retreat. the current oldloc is saved in oldlc2, in case c dies. (if he does, newloc will be limbo, and oldloc will be what kil c him, so we need oldlc2, which is the last place he was safe.) c 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 c 9 ll=iabs(travel(kk)) if(ll.eq.1 .or. ll.eq.k)goto 10 if(travel(kk).lt.0)goto 50 kk=kk+1 goto 9 c 10 newloc=trvcon(kk) k=mod(newloc,100) if(newloc.le.300)goto 13 if(prop(k).ne.newloc/100-3)goto 16 12 if(travel(kk).lt.0)call bug(25) kk=kk+1 go to 10 c 13 if(newloc.le.100)goto 14 if(toting(k).or.(newloc.gt.200.and.at(k)))goto 16 goto 12 c 14 if(newloc.ne.0.and..not.pct(newloc))goto 12 16 newloc=trvloc(kk) if(newloc.le.300)goto 2 if(newloc.le.500)goto 30000 call rspeak(newloc-500) newloc=loc goto 2 c c special motions come here. labelling convention: statement numbers n c (xx=00-99) are used for special case number nnn (nnn=301-500). c 30000 newloc=newloc-300 if(newloc.le.0 .or. newloc.gt.3) call bug(20) goto (30100,30200,30300)newloc call gotoer c c travel 301. plover-alcove passage. can carry only emerald. note: t c table must include "useless" entries going through passage, which can c be used for actual motion, but can be spotted by "go back". c 30100 newloc=99+100-loc if(holdng.eq.0.or.(holdng.eq.1.and.toting(emrald)))goto 2 newloc=loc call rspeak(117) goto 2 c c travel 302. plover transport. drop the emerald (only use special tr c toting it), so he's forced to use the plover-passage to get it out. c dropped it, go back and pretend he wasn't carrying it after all. c 30200 call drop(emrald,loc) goto 12 c c travel 303. troll bridge. must be done only as special motion so th c dwarves won't wander across and encounter the bear. (they won't foll 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 c 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 c 30310 newloc=plac(troll)+fixd(troll)-loc if(prop(troll).eq.0)prop(troll)=1 if(.not.toting(bear))goto 2 call rspeak(162) prop(chasm)=1 prop(troll)=2 call drop(bear,newloc) fixed(bear)=-1 prop(bear)=3 if(prop(spices).lt.0)tally2=tally2+1 oldlc2=newloc goto 99 c c end of specials. c c handle "go back". look for verb which goes from loc to oldloc, or to c if oldloc has forced-motion. k2 saves entry -> forced loc -> previou c 20 k=oldloc if(forced(k))k=oldlc2 oldlc2=oldloc oldloc=loc k2=0 if(k.ne.loc)goto 21 call rspeak(91) goto 2 c 21 ll=trvloc(kk) if(ll.eq.k)goto 25 if(ll.gt.300)goto 22 j=key(ll) if(forced(ll).and.trvloc(kk).eq.k)k2=kk 22 if(travel(kk).lt.0)goto 23 kk=kk+1 goto 21 c 23 kk=k2 if(kk.ne.0)goto 25 call rspeak(140) goto 2 c 25 k=iabs(travel(kk)) kk=key(loc) goto 9 c c look. can't give more detail. pretend it wasn't dark (though it may c be dark) so he won't fall into a pit while staring into the gloom. c 30 if(detail.lt.3)call rspeak(15) detail=detail+1 wzdark=.false. abb(loc)=0 goto 2 c c cave. different messages depending on whether above ground. c 40 if(loc.lt.8)call rspeak(57) if(loc.ge.8)call rspeak(58) goto 2 c c non-applicable motion. various messages depending on word given. c 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. w c allow this maxdie times. maxdie is automatically set based on the nu c snide messages available. each death results in a message (81, 83, e c which offers reincarnation; if accepted, this results in message 82, c etc. the last time, if he wants another chance, he gets a snide rema c we exit. when reincarnated, all objects being carried get dropped at c (presumably the last place prior to being killed) without change of p c the loop runs backwards to assure that the bird is dropped before the c (this kluge could be changed once we're sure all references to bird a c are done by keywords.) the lamp is a special case (it wouldn't do to c it in the cave). it is turned off and left outside the building (onl c was carrying it, of course). he himself is left inside the building c heaven help him if he tries to xyzzy back into the cave without the l c oldloc is zapped so he can't just "retreat". c c the easiest way to get killed is to fall into a pit in pitch darkness c 90 call rspeak(23) oldlc2=loc c c okay, he's dead. let's get on with it. c 99 if(closng)goto 95 yea=yes(81+numdie*2,82+numdie*2,54) numdie=numdie+1 if(numdie.eq.maxdie.or..not.yea)goto 20000 place(water)=0 place(oil)=0 if(toting(lamp))prop(lamp)=0 do 98 j=1,100 i=101-j if(.not.toting(i))goto 98 k=oldlc2 if(i.eq.lamp)k=1 call drop(i,k) 98 continue loc=3 oldloc=loc goto 2000 c c he died during closing time. no resurrection. tally up a death and c 95 call rspeak(131) numdie=numdie+1 goto 20000 c routines for performing the various action verbs c c statement numbers in this section are 8000 for intransitive verbs, 90 c transitive, plus ten times the verb number. many intransitive verbs c transitive code, and some verbs use code for other verbs, as noted be c c random intransitive verbs come here. clear obj just in case (see "at c 8000 continue * 8000 print 8002,wdfull * 8002 format('I don''t understand ',a20) call trmprt( "I don't understand ", wdfull, "." ) obj=0 goto 2600 c c carry, no object given yet. ok if only one object present. c 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 c carry an object. special cases for bird and cage (if bird in cage, c c take one without the other. liquids also special, since they depend c status of bottle. also various side effects, etc. c 9010 if(toting(obj))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).and.liq(0).eq.obj)goto 9018 obj=bottle if(toting(bottle).and.prop(bottle).eq.1)goto 9220 if(prop(bottle).ne.1)spk=105 if(.not.toting(bottle))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(.not.toting(rod))goto 9013 call rspeak(26) goto 2012 9013 if(toting(cage))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) 1 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 c discard object. "throw" also comes here for most objects. special c c bird (might attack snake or dragon) and cage (might contain bird) and c drop coins at vending machine for extra batteries. c 9020 if(toting(rod2).and.obj.eq.rod.and..not.toting(rod))obj=rod2 if(.not.toting(obj))goto 2011 if(obj.ne.bird.or..not.here(snake))goto 9024 call rspeak(30) if(closed)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 c 9024 if(obj.ne.coins.or..not.here(vend))goto 9025 call dstroy(coins) call drop(batter,loc) call pspeak(batter,0) goto 2012 c 9025 if(obj.ne.bird.or..not.at(dragon).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 c 9026 if(obj.ne.bear.or..not.at(troll))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 c 9027 if(obj.eq.vase.and.loc.ne.plac(pillow))goto 9028 call rspeak(54) goto 9021 c 9028 prop(vase)=2 if(at(pillow))prop(vase)=0 call pspeak(vase,prop(vase)+1) if(prop(vase).ne.0)fixed(vase)=-1 goto 9021 c c say. echo wd2 (or wd1 if no wd2 (say what?, etc.).) magic words ove c 9030 if(wd2.eq.0)goto 9031 wd1=wd2 9031 call vocab (wd1,-1,i) if(i.eq.62.or.i.eq.65.or.i.eq.71.or.i.eq.2025)goto 9035 * print 9032,wdfull * 9032 format(' Okay, ',a20) call trmprt( "Okay, ", wdfull, "." ) goto 2012 c 9035 wd2=0 obj=0 goto 2630 c c lock, unlock, no object given. assume various things if present. c 8040 spk=28 if(here(clam))obj=clam if(here(oyster))obj=oyster if(at(door))obj=door if(at(grate))obj=grate if(obj.ne.0.and.here(chain))goto 8000 if(here(chain))obj=chain if(obj.eq.0)goto 2011 c c lock, unlock object. special stuff for opening clam/oyster and for c c 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..not.here(keys))goto 2011 if(obj.eq.chain)goto 9048 if(.not.closng)goto 9043 k=130 if(.not.panic)clock2=15 panic=.true. goto 2010 c 9043 k=34+prop(grate) prop(grate)=1 if(verb.eq.lock)prop(grate)=0 k=k+2*prop(grate) goto 2010 c c clam/oyster. 9046 k=0 if(obj.eq.oyster)k=1 spk=124+k if(toting(obj))spk=120+k if(.not.toting(tridnt))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 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 c 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))call drop(chain,loc) fixed(chain)=-1 goto 2011 c c light lamp c 9070 if(.not.here(lamp))goto 2011 spk=184 if(limit.lt.0)goto 2011 prop(lamp)=1 call rspeak(39) if(wzdark)goto 2000 goto 2012 c c lamp off c 9080 if(.not.here(lamp))goto 2011 prop(lamp)=0 call rspeak(40) if(dark(0))call rspeak(16) goto 2012 c c wave. no effect unless waving rod at fissure. c 9090 if((.not.toting(obj)).and.(obj.ne.rod.or..not.toting(rod2))) 1 spk=29 if(obj.ne.rod.or..not.at(fissur).or..not.toting(obj) 1 .or.closng)goto 2011 prop(fissur)=1-prop(fissur) call pspeak(fissur,2-prop(fissur)) goto 2012 c c attack. assume target if unambiguous. "throw" also links here. att c objects fall into two categories: enemies (snake, dwarf, etc.) and o c (bird, clam). ambiguous if two enemies, or if no enemies but two oth c 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))obj=obj*100+snake if(at(dragon).and.prop(dragon).eq.0)obj=obj*100+dragon if(at(troll))obj=obj*100+troll if(here(bear).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).and.verb.ne.throw)obj=bird c clam and oyster both treated as clam for intransitive case; no harm d if(here(clam).or.here(oyster))obj=100*obj+clam if(obj.gt.100)goto 8000 9124 if(obj.ne.bird)goto 9125 spk=137 if(closed)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)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 c move dragon to central loc (still fixed), move rug there (not fixed), c move him there, too. then do a null motion to get new description. verb=0 obj=0 if(.not.yes(49,0,0))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 if(place(obj).eq.plac(dragon).or.place(obj).eq.fixd(dragon)) 1 call move(obj,k) 9126 continue loc=k k=null goto 8 c 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. c 9130 if(obj.eq.bottle.or.obj.eq.0)obj=liq(0) if(obj.eq.0)goto 8000 if(.not.toting(obj))goto 2011 spk=78 if(obj.ne.oil.and.obj.ne.water)goto 2011 prop(bottle)=1 place(obj)=0 spk=77 if(.not.(at(plant).or.at(door)))goto 2011 c if(at(door))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 c 9132 prop(door)=0 if(obj.eq.oil)prop(door)=1 spk=113+prop(door) goto 2011 c c eat. intransitive: assume food if present, else ask what. transitiv c ok, some things lose appetite, rest are ridiculous. c 8140 if(.not.here(food))goto 8000 8142 call dstroy(food) spk=72 goto 2011 c 9140 if(obj.eq.food)goto 8142 if(obj.eq.bird.or.obj.eq.snake.or.obj.eq.clam.or.obj.eq.oyster 1 .or.obj.eq.dwarf.or.obj.eq.dragon.or.obj.eq.troll 2 .or.obj.eq.bear)spk=71 goto 2011 c c drink. if no object, assume water and look for it here. if water is c the bottle, drink that, else must be at a water loc, so drink stream. c 9150 if(obj.eq.0.and.liqloc(loc).ne.water.and.(liq(0).ne.water 1 .or..not.here(bottle)))goto 8000 if(obj.ne.0.and.obj.ne.water)spk=110 if(spk.eq.110.or.liq(0).ne.water.or..not.here(bottle))goto 2011 prop(bottle)=1 place(water)=0 spk=74 goto 2011 c c rub. yields various snide remarks. c 9160 if(obj.ne.lamp)spk=76 goto 2011 c c throw. same as discard unless axe. then same as attack except ignor 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 c 9170 if(toting(rod2).and.obj.eq.rod.and..not.toting(rod))obj=rod2 if(.not.toting(obj))goto 2011 if(obj.ge.50.and.obj.le.maxtrs.and.at(troll))goto 9178 if(obj.eq.food.and.here(bear))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).and.prop(dragon).eq.0)goto 9175 spk=158 if(at(troll))goto 9175 if(here(bear).and.prop(bear).eq.0)goto 9176 obj=0 goto 9120 c 9172 spk=48 if(rnd(3).eq.0)goto 9175 dseen(i)=.false. 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 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 c but throwing food is another story. 9177 obj=bear goto 9210 c 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 c quit. intransitive only. verify intent and exit if that's what he w c 8180 gaveup=yes(22,54,54) 8185 if(gaveup)goto 20000 goto 2012 c c find. might be carrying it, or it might be here. else give caveat. c 9190 if(at(obj).or.(liq(0).eq.obj.and.at(bottle)) 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)spk=138 if(toting(obj))spk=24 goto 2011 c c inventory. if object, treat same as find. else report on current bu c 8200 spk=98 do 8201 i=1,100 if(i.eq.bear.or..not.toting(i))goto 8201 if(spk.eq.98)call rspeak(99) blklin=.false. call pspeak(i,-1) blklin=.true. spk=0 8201 continue if(toting(bear))spk=141 goto 2011 c c feed. if bird, no seed. snake, dragon, troll: quip. if dwarf, make c mad. bear, special. c 9210 if(obj.ne.bird)goto 9212 spk=100 goto 2011 c 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.or..not.here(bird))goto 2011 spk=101 call dstroy(bird) prop(bird)=0 tally2=tally2+1 goto 2011 c 9213 if(obj.ne.dwarf)goto 9214 if(.not.here(food))goto 2011 spk=103 dflag=dflag+1 goto 2011 c 9214 if(obj.ne.bear)goto 9215 if(prop(bear).eq.0)spk=102 if(prop(bear).eq.3)spk=110 if(.not.here(food))goto 2011 call dstroy(food) prop(bear)=1 fixed(axe)=0 prop(axe)=0 spk=168 goto 2011 c 9215 spk=14 goto 2011 c c fill. bottle must be empty, and some liquid available. (vase is nas c 9220 if(obj.eq.vase)goto 9222 if(obj.ne.0.and.obj.ne.bottle)goto 2011 if(obj.eq.0.and..not.here(bottle))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))place(k)=-1 if(k.eq.oil)spk=108 goto 2011 c 9222 spk=29 if(liqloc(loc).eq.0)spk=144 if(liqloc(loc).eq.0.or..not.toting(vase))goto 2011 call rspeak(145) prop(vase)=2 fixed(vase)=-1 goto 9024 c c blast. no effect unless you've got dynamite, which is a neat trick! c 9230 if(prop(rod2).lt.0.or..not.closed)goto 2011 bonus=133 if(loc.eq.115)bonus=134 if(here(rod2))bonus=135 call rspeak(bonus) goto 20000 c c score. go to scoring section, which will return to 8241 if scorng is c 8240 scorng=.true. goto 20000 c 8241 scorng=.false. print 8243,score,mxscor 8243 format('If you were to quit now, you would score',i4 1 ,' out of a possible',i4,'.') gaveup=yes(143,54,54) goto 8185 c c fee fie foe foo (and fum). advance to next state if given in proper c look up wd1 in section 3 of vocab to determine which word we've got. c word zips the eggs back to the giant room (unless already there). c 8250 call vocab(wd1,3,k) spk=42 if(foobar.eq.1-k)goto 8252 if(foobar.ne.0)spk=151 goto 2011 c 8252 foobar=k if(k.ne.4)goto 2009 foobar=0 if(place(eggs).eq.plac(eggs) 1 .or.(toting(eggs).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) 1 prop(troll)=1 k=2 if(here(eggs))k=1 if(loc.eq.plac(eggs))k=0 call move(eggs,plac(eggs)) call pspeak(eggs,k) goto 2012 c c brief. intransitive only. suppress long descriptions after first ti c 8260 spk=156 abbnum=10000 detail=3 goto 2011 c c read. magazines in dwarvish, message we've seen, and . . . oyster? c 8270 if(here(magzin))obj=magzin if(here(tablet))obj=obj*100+tablet if(here(messag))obj=obj*100+messag if(closed.and.toting(oyster))obj=oyster if(obj.gt.100.or.obj.eq.0.or.dark(0))goto 8000 c 9270 if(dark(0))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).and.toting(oyster))spk=194 if(obj.ne.oyster.or.hinted(2).or..not.toting(oyster) 1 .or..not.closed)goto 2011 hinted(2)=yes(192,193,54) goto 2012 c c break. only works for mirror in repository and, of course, the vase. c 9280 if(obj.eq.mirror)spk=148 if(obj.eq.vase.and.prop(vase).eq.0)goto 9282 if(obj.ne.mirror.or..not.closed)goto 2011 call rspeak(197) goto 19000 c 9282 spk=198 if(toting(vase))call drop(vase,loc) prop(vase)=2 fixed(vase)=-1 goto 2011 c c wake. only use is to disturb the dwarves. c 9290 if(obj.ne.dwarf.or..not.closed)goto 2011 call rspeak(199) goto 19000 c c suspend. cant in this version. But Lidie made it happen now! c 8300 call savegm( 1 ) go to 2012 8301 call restoregm goto 2012 c c hours. c 8310 call mspeak(6) * print 8315,t * 8315 format(1x,a9,' to ',a9,/,1x,a9,' to ',a9) go to 2012 c gazing into palantir for hints 8320 spk=204 if(.not.here(orb))spk=203 call rspeak(spk) if(.not.here(orb)) goto 2012 spk=209 if(toting(keys))spk=205 if(toting(keys))goto 8321 if (toting(axe))spk=208 if (toting(axe))goto 8321 if(toting(lamp))spk=207 8321 call rspeak(spk) go to 2012 c c come here if he's been long enough at required loc(s) for some unused c hint number is in variable "hint". branch to quick test for addition c conditions, then come back to do neat stuff. goto 40010 if condition c met and we want to offer the hint. goto 40020 to clear hintlc back t c 40030 to take no action yet. c 40000 if(hint-3.le.0 .or. hint-3.gt.7) call bug(27) goto (40400,40500,40600,40700,40800,40900,40900)(hint-3) call gotoer c cave bird snake maze dark witt orb c 40010 hintlc(hint)=0 if(.not.yes(hints(hint,3),0,54))goto 2602 print 40012,hints(hint,2) 40012 format(/'I am prepared to give you a hint, but it will cost you', 1 i2,' points.') hinted(hint)=yes(175,hints(hint,4),54) if(hinted(hint).and.limit.gt.30)limit=limit+30*hints(hint,2) 40020 hintlc(hint)=0 40030 goto 2602 c c now for the quick tests. see database description for one-line notes c 40400 if(prop(grate).eq.0.and..not.here(keys))goto 40010 goto 40020 c 40500 if(here(bird).and.toting(rod).and.obj.eq.bird)goto 40010 goto 40030 c 40600 if(here(snake).and..not.here(bird))goto 40010 goto 40020 c 40700 if(atloc(loc).eq.0.and.atloc(oldloc).eq.0 1 .and.atloc(oldlc2).eq.0.and.holdng.gt.1)goto 40010 goto 40020 c 40800 if(prop(emrald).ne.-1.and.prop(pyram).eq.-1)goto 40010 goto 40020 c 40900 goto 40010 c cave closing and scoring c c c these sections handle the closing of the cave. the cave closes "cloc c turns after the last treasure has been located (including the pirate' c chest, which may of course never show up). note that the treasures n c have been taken yet, just located. hence clock1 must be large enough c out of the cave (it only ticks while inside the cave). when it hits c we branch to 10000 to start closing the cave, and then sit back and w c him to try to get out. if he doesn't within clock2 turns, we close t c cave; if he does try, we assume he panics, and give him a few additio c turns to get frantic before we close. when clock2 hits zero, we bran c 11000 to transport him into the final puzzle. note that the puzzle d c upon all sorts of random things. for instance, there must be no wate c oil, since there are beanstalks which we don't want to be able to wat c since the code can't handle it. also, we can have no keys, since the c grate (having moved the fixed object!) there separating him from all c treasures. most of these problems arise from the use of negative pro c numbers to suppress the object descriptions until he's actually moved c objects. c c when the first warning comes, we lock the grate, destroy the bridge, c all the dwarves (and the pirate), remove the troll and bear (unless d c and set "closng" to true. leave the dragon; too much trouble to move c from now until clock2 runs out, he cannot unlock the grate, move to a c location outside the cave (loc<9), or create the bridge. nor can he c resurrected if he dies. note that the snake is already gone, since h c to the treasure accessible only via the hall of the mt. king. also, c been in giant room (to get eggs), so we can refer to it. also also, c gotten the pearl, so we know the bivalve is an oyster. *and*, the dw c must have been activated, since we've found chest. c 10000 prop(grate)=0 prop(fissur)=0 do 10010 i=1,6 dseen(i)=.false. 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=.true. goto 19999 c c once he's panicked, and clock2 has run out, we come here to set up th c storage room. the room has two locs, hardwired as 115 (ne) and 116 ( 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. c the sw end we place grate over treasures, snake pit, covey of caged b c more rods, and pillows. a mirror stretches across one wall. many of c objects come from known locations and/or states (e.g. the snake is kn 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 c objects he might be carrying (lest he have some which could cause tro c such as the keys). we describe the flash of light and trundle back. c 11000 prop(bottle)=lput(bottle,115,1) prop(plant)=lput(plant,115,0) prop(oyster)=lput(oyster,115,0) prop(lamp)=lput(lamp,115,0) prop(rod)=lput(rod,115,0) prop(dwarf)=lput(dwarf,115,0) loc=115 oldloc=115 newloc=115 c c leave the grate with normal (non-negative property). c i=lput(grate,116,0) prop(snake)=lput(snake,116,1) prop(bird)=lput(bird,116,1) prop(cage)=lput(cage,116,0) prop(rod2)=lput(rod2,116,0) prop(pillow)=lput(pillow,116,0) c prop(mirror)=lput(mirror,115,0) fixed(mirror)=116 c do 11010 i=1,100 11010 if(toting(i))call dstroy(i) c call rspeak(132) closed=.true. goto 2 c c another way we can force an end to things is by having the lamp give c when it gets close, we come here to warn him. we go to 12000 if the c and fresh batteries are here, in which case we replace the batteries c continue. 12200 is for other cases of lamp dying. 12400 is when it c out, and 12600 is if he's wandered outside and the lamp is used up, i c case we force him to give up. c 12000 call rspeak(188) prop(batter)=1 if(toting(batter))call drop(batter,loc) limit=limit+2500 lmwarn=.false. goto 19999 c 12200 if(lmwarn.or..not.here(lamp))goto 19999 lmwarn=.true. spk=187 if(place(batter).eq.0)spk=183 if(prop(batter).eq.1)spk=189 call rspeak(spk) goto 19999 c 12400 limit=-1 prop(lamp)=0 if(here(lamp))call rspeak(184) goto 19999 c 12600 call rspeak(185) gaveup=.true. goto 20000 c c c oh dear, he's disturbed the dwarves. c 19000 call rspeak(136) c c exit code. will eventually include scoring. for now, however, ... c c the present scoring algorithm is as follows: c objective: points: present total possible c getting well into cave 25 25 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: 350 c (points can also be deducted for using hints.) c 20000 continue call computescore( score, mxscor ) c c return to score command if that's where we came from. c if(scorng)goto 8241 c c that should be good enough. let's tell him all about it. c print 20100,score,mxscor,turns 20100 format('You scored',i4,' out of a possible',i4, 1 ', using',i5,' turns.') c do 20200 i=1,clsses if(cval(i).ge.score)goto 20210 20200 continue print 20202 20202 format(/' You just went off my scale!!'/) goto 25000 c 20210 call speak(ctext(i)) if(i.eq.clsses-1)goto 20220 k=cval(i)+1-score if (k.eq.1)print 20212,k if (k.ne.1)print 20213,k 20212 format('To acheive the next higher rating, you need ', + i3,' point.') 20213 format('To achieve the next higher rating, you need ', + i3,' points.') goto 25000 c 20220 print 20222 20222 format(/' To achieve the next higher rating ', 1 'would be a neat trick!'//' Congratulations!!'/) c 25000 continue c c end subroutine computescore( score, mxscor ) c implicit integer (a-z) logical blklin,noinpt logical forced, pct logical dseen,hinted logical bitset,lmwarn,closng,panic, 1 closed,gaveup,scorng common /txtcom/ rtext,lines,ascvar common /blkcom/ blklin,noinpt common /voccom/ ktab,atab ,tabsiz common /placom/ atloc,link,place,fixed,holdng common /mtxcom/ mtext common /ptxcom/ ptext common /abbcom/ abb common /miscom/ linuse,trvs,clsses,oldloc,loc,cval,tk,newloc, 1 key,plac,fixd,actspk,cond,hints,hntmax,prop,tally,tally2, 2 hintlc,chloc,chloc2,dseen,dflag,dloc,daltlc,keys,lamp,grate, 3 cage,rod,rod2,steps,bird,door,pillow,snake,fissur,tablet, 4 clam,oyster,magzin,dwarf,knife,food,bottle,water,oil,plant, 5 plant2,axe,mirror,dragon,chasm,troll,troll2,bear,messag,vend, 6 batter,nugget,coins,chest,eggs,tridnt,vase,emrald,pyram, 7 pearl,rug,chain,back,look,cave,null,entrnc,dprssn,say,lock, 8 throw,find,invent,turns,lmwarn,knfloc,detail,abbnum, 9 numdie,maxdie,dkill,foobar,bonus,clock1,clock2, 1 closng,panic,closed,gaveup,scorng,odloc,stream,orb common /misc2/ i,rtxsiz,clsmax,magsiz,locsiz,ctext,stext,ltext, 1 sect,travel,trvcon,trvloc,trvsiz,tabndx,obj,j,k,verb,hntsiz, 2 maxtrs,hinted,hntloc,kk dimension lines(18) dimension travel(800),trvcon(800),trvloc(800) dimension ktab(300),atab(300) dimension ltext(150),stext(150),key(150),cond(150),abb(150), 1 atloc(150) dimension plac(100),place(100),fixd(100),fixed(100),link(200), 1 ptext(100),prop(100) dimension actspk(35) dimension rtext(212) dimension ctext(12),cval(12) dimension hintlc(20),hinted(20),hints(20,4) dimension mtext(35) dimension tk(20),dseen(6),dloc(6),odloc(6) score=0 mxscor=0 c 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. c 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 c now look at how he finished and how far he got. maxdie and numdie te c how well he survived. gaveup says whether he exited via quit. dflag c tell us if he ever got suitably deep into the cave. closng still ind 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, c 135 if he blew it (so to speak). c score=score+(maxdie-numdie)*10 mxscor=mxscor+maxdie*10 if(.not.(scorng.or.gaveup))score=score+4 mxscor=mxscor+4 if(dflag.ne.0)score=score+25 mxscor=mxscor+25 if(closng)score=score+25 mxscor=mxscor+25 if(.not.closed)goto 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 c did he come to witt's end as he should? c if(place(magzin).eq.108)score=score+1 mxscor=mxscor+1 c c round it off. c score=score+2 mxscor=mxscor+2 c c deduct points for hints. hints < 4 are special; see database descrip c do 20030 i=1,hntmax 20030 if(hinted(i))score=score-hints(i,2) c c return to score command if that's where we came from. c end subroutine gotoer print *, "computed gopto error" end subroutine savegm( makecopy) c implicit integer (a-z) logical blklin,noinpt logical forced, pct logical dseen,hinted logical bitset,lmwarn,closng,panic, 1 closed,gaveup,scorng c common /txtcom/ rtext,lines,ascvar common /blkcom/ blklin,noinpt common /voccom/ ktab,atab ,tabsiz common /placom/ atloc,link,place,fixed,holdng common /mtxcom/ mtext common /ptxcom/ ptext common /abbcom/ abb common /miscom/ linuse,trvs,clsses,oldloc,loc,cval,tk,newloc, 1 key,plac,fixd,actspk,cond,hints,hntmax,prop,tally,tally2, 2 hintlc,chloc,chloc2,dseen,dflag,dloc,daltlc,keys,lamp,grate, 3 cage,rod,rod2,steps,bird,door,pillow,snake,fissur,tablet, 4 clam,oyster,magzin,dwarf,knife,food,bottle,water,oil,plant, 5 plant2,axe,mirror,dragon,chasm,troll,troll2,bear,messag,vend, 6 batter,nugget,coins,chest,eggs,tridnt,vase,emrald,pyram, 7 pearl,rug,chain,back,look,cave,null,entrnc,dprssn,say,lock, 8 throw,find,invent,turns,lmwarn,knfloc,detail,abbnum, 9 numdie,maxdie,dkill,foobar,bonus,clock1,clock2, 1 closng,panic,closed,gaveup,scorng,odloc,stream,orb common /misc2/ i,rtxsiz,clsmax,magsiz,locsiz,ctext,stext,ltext, 1 sect,travel,trvcon,trvloc,trvsiz,tabndx,obj,j,k,verb,hntsiz, 2 maxtrs,hinted,hntloc,kk c dimension lines(18) dimension travel(800),trvcon(800),trvloc(800) dimension ktab(300),atab(300) dimension ltext(150),stext(150),key(150),cond(150),abb(150), 1 atloc(150) dimension plac(100),place(100),fixd(100),fixed(100),link(200), 1 ptext(100),prop(100) dimension actspk(35) dimension rtext(212) dimension ctext(12),cval(12) dimension hintlc(20),hinted(20),hints(20,4) dimension mtext(35) dimension tk(20),dseen(6),dloc(6),odloc(6) c Game save state date, score and moves. character*19 qd character*12 scoremoves logical savescorng REWIND 3 write(3) blklin,noinpt write(3) forced, pct write(3) dseen,hinted write(3) bitset,lmwarn,closng,panic, 1 closed,gaveup,scorng write(3) rtext,lines,ascvar write(3) blklin,noinpt write(3) ktab,atab ,tabsiz write(3) atloc,link,place,fixed,holdng write(3) mtext write(3) ptext write(3) abb write(3) linuse,trvs,clsses,oldloc,loc,cval,tk,newloc write(3) key,plac,fixd,actspk,cond,hints,hntmax,prop,tally,tally2 write(3) hintlc,chloc,chloc2,dseen,dflag,dloc,daltlc,keys,lamp,gra +te write(3) cage,rod,rod2,steps,bird,door,pillow,snake,fissur,tablet write(3) clam,oyster,magzin,dwarf,knife,food,bottle,water,oil,plan +t write(3) plant2,axe,mirror,dragon,chasm,troll,troll2,bear,messag,v +end write(3) batter,nugget,coins,chest,eggs,tridnt,vase,emrald,pyram write(3) pearl,rug,chain,back,look,cave,null,entrnc,dprssn,say,loc +k write(3) throw,find,invent,turns,lmwarn,knfloc,detail,abbnum write(3) numdie,maxdie,dkill,foobar,bonus,clock1,clock2 write(3) closng,panic,closed,gaveup,scorng,odloc,stream,orb write(3) i,rtxsiz,clsmax,magsiz,locsiz,ctext,stext,ltext write(3) sect,travel,trvcon,trvloc,trvsiz,tabndx,obj,j,k,verb,hnts +iz write(3) maxtrs,hinted,hntloc,kk ENDFILE 3 close(unit=3) if ( makecopy .eq. 1 ) then c Make a backup copy of the game save state. savescorng = scorng scorng = .true. call computescore( score, mxscor ) scorng = savescorng write( scoremoves, 123 ) score, turns 123 format( "-", i3.3,"-", i7.7 ) call qdate( qd ) call system( "/bin/cp Adventure.save Adventure.save-" // qd // + scoremoves ) open (unit=3, file='Adventure.save', form='unformatted') endif call mspeak(34) end subroutine restoregm c implicit integer (a-z) logical blklin,noinpt logical forced, pct logical dseen,hinted logical bitset,lmwarn,closng,panic, 1 closed,gaveup,scorng c common /txtcom/ rtext,lines,ascvar common /blkcom/ blklin,noinpt common /voccom/ ktab,atab ,tabsiz common /placom/ atloc,link,place,fixed,holdng common /mtxcom/ mtext common /ptxcom/ ptext common /abbcom/ abb common /miscom/ linuse,trvs,clsses,oldloc,loc,cval,tk,newloc, 1 key,plac,fixd,actspk,cond,hints,hntmax,prop,tally,tally2, 2 hintlc,chloc,chloc2,dseen,dflag,dloc,daltlc,keys,lamp,grate, 3 cage,rod,rod2,steps,bird,door,pillow,snake,fissur,tablet, 4 clam,oyster,magzin,dwarf,knife,food,bottle,water,oil,plant, 5 plant2,axe,mirror,dragon,chasm,troll,troll2,bear,messag,vend, 6 batter,nugget,coins,chest,eggs,tridnt,vase,emrald,pyram, 7 pearl,rug,chain,back,look,cave,null,entrnc,dprssn,say,lock, 8 throw,find,invent,turns,lmwarn,knfloc,detail,abbnum, 9 numdie,maxdie,dkill,foobar,bonus,clock1,clock2, 1 closng,panic,closed,gaveup,scorng,odloc,stream,orb common /misc2/ i,rtxsiz,clsmax,magsiz,locsiz,ctext,stext,ltext, 1 sect,travel,trvcon,trvloc,trvsiz,tabndx,obj,j,k,verb,hntsiz, 2 maxtrs,hinted,hntloc,kk c dimension lines(18) dimension travel(800),trvcon(800),trvloc(800) dimension ktab(300),atab(300) dimension ltext(150),stext(150),key(150),cond(150),abb(150), 1 atloc(150) dimension plac(100),place(100),fixd(100),fixed(100),link(200), 1 ptext(100),prop(100) dimension actspk(35) dimension rtext(212) dimension ctext(12),cval(12) dimension hintlc(20),hinted(20),hints(20,4) dimension mtext(35) dimension tk(20),dseen(6),dloc(6),odloc(6) REWIND 3 read(3) blklin,noinpt read(3) forced, pct read(3) dseen,hinted read(3) bitset,lmwarn,closng,panic, 1 closed,gaveup,scorng read(3) rtext,lines,ascvar read(3) blklin,noinpt read(3) ktab,atab ,tabsiz read(3) atloc,link,place,fixed,holdng read(3) mtext read(3) ptext read(3) abb read(3) linuse,trvs,clsses,oldloc,loc,cval,tk,newloc read(3) key,plac,fixd,actspk,cond,hints,hntmax,prop,tally,tally2 read(3) hintlc,chloc,chloc2,dseen,dflag,dloc,daltlc,keys,lamp,gra +te read(3) cage,rod,rod2,steps,bird,door,pillow,snake,fissur,tablet read(3) clam,oyster,magzin,dwarf,knife,food,bottle,water,oil,plan +t read(3) plant2,axe,mirror,dragon,chasm,troll,troll2,bear,messag,v +end read(3) batter,nugget,coins,chest,eggs,tridnt,vase,emrald,pyram read(3) pearl,rug,chain,back,look,cave,null,entrnc,dprssn,say,loc +k read(3) throw,find,invent,turns,lmwarn,knfloc,detail,abbnum read(3) numdie,maxdie,dkill,foobar,bonus,clock1,clock2 read(3) closng,panic,closed,gaveup,scorng,odloc,stream,orb read(3) i,rtxsiz,clsmax,magsiz,locsiz,ctext,stext,ltext read(3) sect,travel,trvcon,trvloc,trvsiz,tabndx,obj,j,k,verb,hnts +iz read(3) maxtrs,hinted,hntloc,kk call mspeak(33) end subroutine qdate( qd ) c Return current date/time as character*19 '2015.04.01-01:02:03' implicit integer (a-z) character*24 fd character*19 qd character*2 mm, montht(12), dd character*3 monthf(12) data monthf/'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 1 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/ data montht/'01', '02', '03', '04', '05', '06', 1 '07', '08', '09', '10', '11', '12'/ call fdate(fd) mm = '??' do 100 i = 1, 12 if( monthf(i) .eq. fd(5:7) ) mm = montht(i) 2 format(bz,i2) 100 continue dd = '??' dd = fd(9:10) if ( dd(1:1) .eq. ' ' ) then dd = '0' // dd(2:2) endif qd = fd(21:24) // '.' // mm // '.' // dd // '-' // 1 fd(12:19) end subroutine trmprt( msg, str, punc ) * Trim trailing spaces from STR and print. implicit integer( a-z ) character*(*) msg, str, punc character*20, fmt i = len(str) do while (str(i:i) .eq. ' ') i = i - 1 enddo write( fmt, 1 ), len(msg), i, len(punc) 1 format("(a",i2,",a",i2,",a",i2,")") print fmt, msg, str(1:i), punc return end