C  Adventure Binary Data Base Generator From ASCII File--storage 2
c   Written for MS DOS PDS FORTRAN v5.10 
c    by Paul Mu¤oz-Colman, FunStuff Software
c   27 Mar 1993  
c   12 August 1985
C
$NODEBUG
$notstrict
$storage: 2
      IMPLICIT INTEGER*2 (A-Z)
      COMMON /TXTCOM/ RTEXT
      COMMON /BLKCOM/ BLKLIN
      COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
      COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
      COMMON /MTXCOM/ MTEXT
      COMMON /PTXCOM/ PTEXT
      COMMON /ABBCOM/ ABB
      COMMON /concom/ COND
      COMMON /LOCCOM/ LOC
      COMMON /PROCOM/ prop, lamp
      COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
     1          SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP

      COMMON /lincom/ LINES
      CHARACTER*2 LINES (21150),CLINES
      CHARACTER*4 WD1,WD2,IZ,BL,ATAB(295),TK(20)
      CHARACTER*12 FNAME
      INTEGER*4 TRAVEL(745),ITK(20),IZZ,IBL,ILINES,newloc,klong,llong
      integer*4 kklong,linuse,kk,linsiz,ran
      DIMENSION KTAB(295),RTEXT(205)
      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 CTEXT(12),CVAL(12)
      DIMENSION HINTLC(20),HINTED(20),HINTS(20,4)
      DIMENSION MTEXT(35)
      DIMENSION DSEEN(6),DLOC(6),ODLOC(6),HNAME(4)
      INTEGER*2 IDONDX
C
      EQUIVALENCE(IZ,IZZ),(BL,IBL),(TK,ITK),(CLINES,ILINES)
      DATA LINSIZ/21150/,TRVSIZ/745/,LOCSIZ/150/,
     1        VRBSIZ/35/,RTXSIZ/205/,CLSMAX/12/,HNTSIZ/20/,MAGSIZ/35/
      DATA BL/'    '/,IZZ/0/
C
      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
      SETUP = 0
      TABSIZ=295
      BLKLIN = 1
 
      IF(SETUP.NE.0)GOTO 1100
      WRITE (*,1000)
 1000 FORMAT(//' IBM PC Adventure Binary Data Base Writer!',//,
     .  ' Initializing..Please Wait..',//)
 
      DO 1001 I=1,300
      IF(I.LE.100)PTEXT(I)=0
      IF(I.LE.RTXSIZ)RTEXT(I)=0
      IF(I.LE.CLSMAX)CTEXT(I)=0
      IF(I.LE.MAGSIZ)MTEXT(I)=0
      IF(I.GT.LOCSIZ)GOTO 1001
      STEXT(I)=0
      LTEXT(I)=0
      COND(I)=0
 1001 CONTINUE
      FNAME='ADVEDAT.ASC'
      OPEN (1, FILE=FNAME)
      REWIND 1
      SETUP=1
      LINUSE=1
      TRVS=1
      CLSSES=1
c  start new data section.  sect is the section number.
 1002 read(1,1003)sect
 1003 format(i4)
      oldloc=-1
      if(sect.gt.11) call bug(9)
c
      if (sect .ne. 0) write (*,10031) sect
10031 format (1h ,i2/)
      goto(1100,1004,1004,1030,1040,1004,1004,1050,1060,1070,1004,
     1    1080),(sect+1)
c           (0)  (1)  (2)  (3)  (4)  (5)  (6)  (7)  (8)  (9)  (10)
c          (11)
c  sections 1, 2, 5, 6, 10.  read messages and set up pointers.
 1004 read(1,1005)loc,(lines(linuse+j),j=1,36)
 1005 format(i4,36a2)
c
      if(loc.eq.-1)goto 1002
      do 1006 k=1,36
      kk=linuse+37-k
      if(lines(kk).ne.'  ')go to 1007
 1006 continue
      call bug(1)
 1007 ilines=kk+1
      lines(linuse)=clines
      if(loc.eq.oldloc)goto 1020
      ilines=-ilines
      lines(linuse)=clines
      if(sect.eq.10)goto 1012
      if(sect.eq.6)goto 1011
      if(sect.eq.5)goto 1010
      if(sect.eq.1)goto 1008
      stext(loc)=linuse
      goto 1020
 
 1008 ltext(loc)=linuse
      goto 1020
 
 1010 if(loc.gt.0.and.loc.le.100)ptext(loc)=linuse
      goto 1020
 
 1011 if(loc.gt.rtxsiz)call bug(6)
      rtext(loc)=linuse
      goto 1020
 
 1012 ctext(clsses)=linuse
      cval(clsses)=loc
      clsses=clsses+1
      goto 1020
 
 1020 linuse=kk+1
      ilines=-1
      lines(linuse)=clines
      oldloc=loc
      if(linuse+36.gt.linsiz)call bug(2)
      goto 1004
 
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.
 
 1030 read(1,1031)loc,newloc,(itk(l),l=1,9)
 1031 format(i4,10i7)
      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,9
      if(itk(l).eq.0)goto 1039
      travel(trvs)=newloc*1000+itk(l)
      trvs=trvs+1
      if(trvs.eq.trvsiz)call bug(3)
 1037 continue
 1039 travel(trvs-1)=-travel(trvs-1)
      goto 1030
 
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
c
 
 1040 do 1042 tabndx=1,tabsiz
 1043 read(1,1041)ktab(tabndx),atab(tabndx)
 1041 format(i4,a4)
      if(ktab(tabndx).eq.-1)goto 1002
 1042 continue
      call bug(4)
 
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.
 
 1050 read(1,1031)obj,j,k
      if(obj.eq.-1)goto 1002
      plac(obj)=j
      fixd(obj)=k
      goto 1050
 
c  read default message numbers for action verbs, store in actspk.
 
 1060 read(1,1031)verb,j
      if(verb.eq.-1)goto 1002
      actspk(verb)=j
      goto 1060
 
c  read info about available liquids and other conditions, store in cond.
 
 1070 read(1,1031)k,(itk(i),i=1,10)
      if(k.eq.-1)goto 1002
      do 1071 i=1,10
      loc=itk(i)
      if(loc.eq.0)goto 1070
      if(bitset(loc,k).eq.1)call bug(8)
 1071 cond(loc)=cond(loc)+shift(1,k)
      goto 1070
 
c  read data for hints.
 
 1080 hntmax=0
 1081 read(1,1031)k,(itk(i),i=1,4)
      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)=itk(i)
      hntmax=max0(hntmax,k)
      goto 1081
c  finish constructing internal data format
 
1100  CLOSE (1)
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.
 
      DO 1101 I=1,100
      PLACE(I)=0
      PROP(I)=0
      LINK(I)=0
 1101 LINK(I+100 )=0
 
      DO 1102 I=1,LOCSIZ
      ABB(I)=0
      IF(LTEXT(I).EQ.0.OR.KEY(I).EQ.0)GOTO 1102
      K=KEY(I)
      IF(MOD(IABS(TRAVEL(K)),1000).EQ.1)COND(I)=2
 1102 ATLOC(I)=0
 
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.
 
      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
 
      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  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).
 
      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  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.
 
      DO 1300 I=1,HNTMAX
      HINTED(I)=0
 1300 HINTLC(I)=0
 
c  define some handy mnemonics.  these correspond to object numbers.
 
      keys=vocab('keys',1)
      lamp=vocab('lamp',1)
      grate=vocab('grat',1)
      cage=vocab('cage',1)
      rod=vocab('rod ',1)
      rod2=rod+1
      steps=vocab('step',1)
      bird=vocab('bird',1)
      door=vocab('door',1)
      pillow=vocab('pill',1)
      snake=vocab('snak',1)
      fissur=vocab('fiss',1)
      tablet=vocab('tabl',1)
      clam=vocab('clam',1)
      oyster=vocab('oyst',1)
      magzin=vocab('maga',1)
      dwarf=vocab('dwar',1)
      knife=vocab('knife',1)
      food=vocab('food',1)
      bottle=vocab('bott',1)
      water=vocab('wate',1)
      oil=vocab('oil ',1)
      plant=vocab('plan',1)
      plant2=plant+1
      axe=vocab('axe ',1)
      mirror=vocab('mirr',1)
      dragon=vocab('drag',1)
      chasm=vocab('chas',1)
      troll=vocab('trol',1)
      troll2=troll+1
      bear=vocab('bear',1)
      messag=vocab('mess',1)
      vend=vocab('vend',1)
      batter=vocab('batt',1)
 
c  objects from 50 through whatever are treasures.  here are a few.
 
      nugget=vocab('gold',1)
      coins=vocab('coins',1)
      chest=vocab('chest',1)
      eggs=vocab('eggs',1)
      tridnt=vocab('trid',1)
      vase=vocab('vase',1)
      emrald=vocab('emer',1)
      pyram=vocab('pyra',1)
      pearl=vocab('pear',1)
      rug=vocab('rug ',1)
      chain=vocab('chai',1)
      spices=vocab('spic',1)
 
c  these are motion-verb numbers.
 
      back=vocab('back',0)
      look=vocab('look',0)
      cave=vocab('cave',0)
      null=vocab('null',0)
      entrnc=vocab('entr',0)
      dprssn=vocab('depr',0)
 
c  and some action verbs.
 
      say=vocab('say ',2)
      lock=vocab('lock',2)
      throw=vocab('thro',2)
      find=vocab('find',2)
      invent=vocab('inve',2)
 
      CHLOC=114
      CHLOC2=140
      DO 1700 I=1,6
1700    DSEEN(I)=0
      DFLAG=0
      DLOC(1)=19
      DLOC(2)=27
      DLOC(3)=33
      DLOC(4)=44
      DLOC(5)=64
      DLOC(6)=CHLOC
      DALTLC=18
 
      TURNS=0
      LMWARN=0
      IWEST=0
      KNFLOC=0
      DETAIL=0
      ABBNUM=5
      DO 1800 I=1,5
 1800 IF(RTEXT(2*I+79).NE.0)MAXDIE=I
      NUMDIE=0
      HOLDNG=0
      DKILL=0
      FOOBAR=0
      BONUS=0
      CLOCK1=30
      CLOCK2=50
      SAVED=0
      CLOSNG=0
      PANIC=0
      CLOSED=0
      GAVEUP=0
      SCORNG=0
 
      DO 1998 K=1,LOCSIZ
      KK=LOCSIZ+1-K
      IF(LTEXT(KK).NE.0)GOTO 1997
 1998 CONTINUE
 
      OBJ=0
 1997 DO 1996 K=1,100
 1996 IF(PTEXT(K).NE.0)OBJ=OBJ+1
 
      DO 1995 K=1,TABNDX
 1995 IF(KTAB(K)/1000.EQ.2)VERB=KTAB(K)-2000
 
      DO 1994 K=1,RTXSIZ
      J=RTXSIZ+1-K
      IF(RTEXT(J).NE.0)GOTO 1993
 1994 CONTINUE
 
 1993 DO 1992 K=1,MAGSIZ
      I=MAGSIZ+1-K
      IF(MTEXT(I).NE.0)GOTO 1991
 1992 CONTINUE
 
 1991 K=100
      WRITE (*,1999) LINUSE,LINSIZ,TRVS,TRVSIZ,TABNDX,TABSIZ
      WRITE (*,19992)KK,LOCSIZ,OBJ,K,VERB,VRBSIZ,J,RTXSIZ,CLSSES,CLSMAX
      WRITE (*,19993) HNTMAX,HNTSIZ,I,MAGSIZ
 1999 FORMAT (' TABLE SPACE USED:'/
     1 ' ',I6,' OF ',I6,' WORDS OF MESSAGES'/
     2 ' ',I6,' OF ',I6,' TRAVEL OPTIONS'/
     3 ' ',I6,' OF ',I6,' VOCABULARY WORDS'/)
19992 FORMAT ( ' ',I6,' OF ',I6,' LOCATIONS'/
     5 ' ',I6,' OF ',I6,' OBJECTS'/
     6 ' ',I6,' OF ',I6,' ACTION VERBS'/
     7 ' ',I6,' OF ',I6,' RTEXT MESSAGES'/
     8 ' ',I6,' OF ',I6,' CLASS MESSAGES'/)
19993 FORMAT ( ' ',I6,' OF ',I6,' HINTS'/
     9 ' ',I6,' OF ',I6,' MAGIC MESSAGES'/)
c
c  save the data base in array format
c
      open (2,file='ad.dat',status='unknown',form='unformatted')
c
      write (2) 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
      write (2) 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
      write (2) 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
      endfile 2
      close (2)
 
 1    CONTINUE
C1    DEMO=START(0)
C     CALL MOTD(0)
      write (*,*) 'Finished'
 
      END
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
      equivalence (clines,ilines)
      data np/'>$'/
      if(n.eq.0)return
      if(lines(n+1).eq.np)return
      if(blklin.eq.1) write (*,2)
      k=n
 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)
      equivalence (clines,ilines)
      m=ptext(msg)
      if(skip.lt.0)goto 9
      do 3 i=1,skip+1
 1    clines=lines(m)
      m=iabs(ilines)
      clines=lines(m)
      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 as well as an object, may be located
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, 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
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 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


