home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol002 / advensub.for < prev    next >
Encoding:
Text File  |  1984-04-29  |  12.7 KB  |  458 lines
  1. C REV. 23
  2.       INTEGER FUNCTION LTEXT(N)
  3.       LTEXT=IDISK(4,1,1,N)
  4.       RETURN
  5.       END
  6. C
  7.       INTEGER FUNCTION STEXT(N)
  8.       STEXT=IDISK(5,1,1,N)
  9.       RETURN
  10.       END
  11. C
  12.       INTEGER FUNCTION TRAVEL(M,N)
  13.       TRAVEL=IDISK(8,3,M,N)
  14.       RETURN
  15.       END
  16. C
  17.       INTEGER FUNCTION IDISK(ILUN,IDIM,ISUB1,ISUB2)
  18.       INTEGER BUF(64)
  19.       DATA ILAST,NLAST/2*0/
  20.       K=64/IDIM
  21.       J=ISUB2-1
  22.       NREC=1+J/K
  23.       IF (ILAST .EQ. ILUN .AND. NLAST .EQ. NREC) GO TO 1
  24.       ILAST=ILUN
  25.       NLAST=NREC
  26.       READ(ILUN,REC=NREC) BUF
  27.    1  IT=MOD(J,K)*IDIM+ISUB1
  28.       IDISK=BUF(IT)
  29.       RETURN
  30.       END
  31. C
  32.       INTEGER FUNCTION RTEXT(N)
  33.       RTEXT=IDISK(10,1,1,N)
  34.       RETURN
  35.       END
  36. C
  37.       INTEGER FUNCTION VOCAB2(ID,INIT)
  38.       INTEGER TABSIZ
  39.       REAL ID,ATAB
  40.       COMMON /VOCCOM/ TABSIZ
  41. C
  42. C      WRITE(3,100)ID,INIT
  43. C 100  FORMAT(1X,'VOCAB(',A4,',',I3,')')
  44.       DO 1 I=1,TABSIZ
  45.       IK=KTAB(I)
  46.       IF (IK .EQ. -1) GO TO 2
  47.       IF (INIT .GE. 0 .AND. IK/1000 .NE. INIT) GO TO 1
  48.       IF (ATAB(I) .EQ. ID) GO TO 3
  49.    1  CONTINUE
  50.       CALL BUG(21)
  51. C
  52.    2  VOCAB2=-1
  53.       IF (INIT .LT. 0) RETURN
  54.       WRITE(3,100) ID
  55.  100  FORMAT(1X,'KEYWORD = ',A4)
  56.       CALL BUG(5)
  57. C
  58.    3  VOCAB2=IK
  59.       IF (INIT .GE. 0) VOCAB2=MOD(VOCAB2,1000)
  60.       RETURN
  61.       END
  62.       SUBROUTINE CARRY(OBJECT,WHERE)
  63.       INTEGER ATLOC,LINK,PLACE,FIXED,HOLDNG,OBJECT,WHERE,TEMP
  64.       DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
  65.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
  66. C
  67.       IF (OBJECT .GT. 100) GO TO 5
  68.       IF (PLACE(OBJECT) .EQ. -1) RETURN
  69.       PLACE(OBJECT)=-1
  70.       HOLDNG=HOLDNG+1
  71.    5  IF (ATLOC(WHERE) .NE. OBJECT) GO TO 6
  72.       ATLOC(WHERE)=LINK(OBJECT)
  73.       RETURN
  74.    6  TEMP=ATLOC(WHERE)
  75.    7  IF (LINK(TEMP) .EQ. OBJECT) GO TO 8
  76.       TEMP=LINK(TEMP)
  77.       GO TO 7
  78.    8  LINK(TEMP)=LINK(OBJECT)
  79.       RETURN
  80.       END
  81. C
  82.       SUBROUTINE DROP(OBJECT,WHERE)
  83.       INTEGER ATLOC,LINK,PLACE,FIXED,HOLDNG,OBJECT,WHERE
  84.       DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
  85.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
  86. C
  87.       IF (OBJECT .GT. 100) GO TO 1
  88.       IF (PLACE(OBJECT) .EQ. -1) HOLDNG=HOLDNG-1
  89.       PLACE(OBJECT)=WHERE
  90.       GO TO 2
  91.    1  FIXED(OBJECT-100)=WHERE
  92.    2  IF (WHERE .LE. 0) RETURN
  93.       LINK(OBJECT)=ATLOC(WHERE)
  94.       ATLOC(WHERE)=OBJECT
  95.       RETURN
  96.       END
  97. C
  98.       INTEGER FUNCTION PUT(OBJECT,WHERE,PVAL)
  99.       INTEGER OBJECT,WHERE,PVAL
  100.       CALL MOVE(OBJECT,WHERE)
  101.       PUT=-1-PVAL
  102.       RETURN
  103.       END
  104. C
  105.       SUBROUTINE MOVE(OBJECT,WHERE)
  106.       INTEGER ATLOC,LINK,PLACE,FIXED,OBJECT,WHERE,FROM,HOLDNG
  107.       DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
  108.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
  109. C
  110.       IF (OBJECT .GT. 100) GO TO 1
  111.       FROM=PLACE(OBJECT)
  112.       GO TO 2
  113.    1  FROM=FIXED(OBJECT-100)
  114.    2  IF (FROM .GT. 0 .AND. FROM .LE. 300) CALL CARRY(OBJECT,FROM)
  115.       CALL DROP(OBJECT,WHERE)
  116.       RETURN
  117.       END
  118. C
  119.       SUBROUTINE JUGGLE(OBJECT)
  120.       INTEGER ATLOC,LINK,PLACE,FIXED,HOLDNG,OBJECT
  121.       DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
  122.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED
  123. C
  124.       I=PLACE(OBJECT)
  125.       J=FIXED(OBJECT)
  126.       CALL MOVE(OBJECT,I)
  127.       CALL MOVE(OBJECT+100,J)
  128.       RETURN
  129.       END
  130. C
  131.       SUBROUTINE DSTROY(OBJECT)
  132.       INTEGER OBJECT
  133.       CALL MOVE(OBJECT,0)
  134.       RETURN
  135.       END
  136. C
  137.       INTEGER FUNCTION VOCAB(ID,INIT)
  138.       INTEGER KTAB,TABSIZ
  139.       REAL ID,ATAB
  140.       DIMENSION KTAB(300),ATAB(300)
  141.       COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
  142. C
  143.       DO 1 I=1,TABSIZ
  144.       IF (KTAB(I) .EQ. -1) GO TO 2
  145.       IF (INIT .GE. 0 .AND. KTAB(I)/1000 .NE. INIT) GO TO 1
  146.       IF (ATAB(I) .EQ. ID) GO TO 3
  147.    1  CONTINUE
  148.       CALL BUG(21)
  149. C
  150.    2  VOCAB=-1
  151.       IF (INIT .LT. 0) RETURN
  152.       WRITE(3,100) ID
  153.  100  FORMAT(1X,'KEYWORD = ',A4)
  154.       CALL BUG(5)
  155. C
  156.    3  VOCAB=KTAB(I)
  157.       IF (INIT .GE. 0) VOCAB=MOD(VOCAB,1000)
  158.       RETURN
  159.       END
  160. C
  161.       SUBROUTINE A5TOA1(A,B,C,CHARS,LENG)
  162.       LOGICAL FLG
  163.       REAL A,B,C,D
  164.       LOGICAL I,J,K,M
  165.       LOGICAL CHARS(20),TEST(4),BLANK
  166.       EQUIVALENCE (D,TEST(1))
  167.       DATA BLANK/' '/
  168. C
  169.       DO 9 I=1,20
  170.    9  CHARS(I)=BLANK
  171. C
  172.       D=A
  173.       DO 1 I=1,4
  174.    1  CHARS(I)=TEST(I)
  175. C
  176.       D=B
  177.       DO 2 I=1,4
  178.    2  CHARS(I+4)=TEST(I)
  179. C
  180.       D=C
  181.       J=9
  182.       IF (TEST(1) .GE. 65) J=10
  183.       M=1
  184.       K=J+3
  185.       DO 3 I=J,K
  186.       CHARS(I)=TEST(M)
  187.    3  M=M+1
  188. C
  189.       DO 10 I=1,19
  190.   12  IF (CHARS(I) .NE. BLANK .OR. CHARS(I+1) .NE. BLANK)GOTO 10
  191.       FLG=.FALSE.
  192.       J=I+1
  193.       DO 11 K=J,20
  194.       IF (CHARS(K) .NE. BLANK) FLG=.TRUE.
  195.   11  CHARS(K-1)=CHARS(K)
  196.       CHARS(20)=BLANK
  197.       IF (FLG) GO TO 12
  198.   10  CONTINUE
  199. C
  200.       DO 4 I=1,20
  201.       LENG=21-I
  202.       IF (CHARS(LENG) .EQ. BLANK) GO TO 4
  203.       RETURN
  204.    4  CONTINUE
  205.       CALL BUG(99)
  206.       END
  207.         INTEGER FUNCTION RAN(RANGE)
  208. C  SINCE THE RAN FUNCTION IN LIB40 SEEMS TO BE A REAL LOSE, WE'LL USE ONE OF
  209. C  OUR OWN.  IT'S BEEN RUN THROUGH MANY OF THE TESTS IN KNUTH VOL. 2 AND
  210. C  SEEMS TO BE QUITE RELIABLE.  RAN RETURNS A VALUE UNIFORMLY SELECTED
  211. C  BETWEEN 0 AND RANGE-1.  NOTE RESEMBLANCE TO ALG USED IN WIZARD.
  212.       INTEGER RANGE,D,R,T
  213.         DATA R/0/
  214.         D=1
  215.         IF(R.NE.0)GOTO 1
  216.       WRITE(3,3)
  217.    3  FORMAT(1X,'Type 3 digits, please.  ')
  218.       READ(3,4) D
  219.    4  FORMAT(I3)
  220.       R=3
  221.         D=1000+D
  222. 1       DO 2 T=1,D
  223. 2       R=R * 81
  224.         RAN=RANGE * (FLOAT(IABS(R))/32768.)
  225.         RETURN
  226.         END
  227.         SUBROUTINE BUG(NUM)
  228. C  THE FOLLOWING CONDITIONS ARE CURRENTLY CONSIDERED FATAL BUGS.  NUMBERS < 20
  229. C  ARE DETECTED WHILE READING THE DATABASE; THE OTHERS OCCUR AT "RUN TIME".
  230. C       0       MESSAGE LINE > 70 CHARACTERS
  231. C       1       NULL LINE IN MESSAGE
  232. C       2       TOO MANY WORDS OF MESSAGES
  233. C       3       TOO MANY TRAVEL OPTIONS
  234. C       4       TOO MANY VOCABULARY WORDS
  235. C       5       REQUIRED VOCABULARY WORD NOT FOUND
  236. C       6       TOO MANY RTEXT OR MTEXT MESSAGES
  237. C       7       TOO MANY HINTS
  238. C       8       LOCATION HAS COND BIT BEING SET TWICE
  239. C       9       INVALID SECTION NUMBER IN DATABASE
  240. C       20      SPECIAL TRAVEL (500>L>300) EXCEEDS GOTO LIST
  241. C       21      RAN OFF END OF VOCABULARY TABLE
  242. C       22      VOCABULARY TYPE (N/1000) NOT BETWEEN 0 AND 3
  243. C       23      INTRANSITIVE ACTION VERB EXCEEDS GOTO LIST
  244. C       24      TRANSITIVE ACTION VERB EXCEEDS GOTO LIST
  245. C       25      CONDITIONAL TRAVEL ENTRY WITH NO ALTERNATIVE
  246. C       26      LOCATION HAS NO TRAVEL ENTRIES
  247. C       27      HINT NUMBER EXCEEDS GOTO LIST
  248. C       28      INVALID MONTH RETURNED BY DATE FUNCTION
  249.         WRITE(3,1) NUM
  250. 1       FORMAT (' FATAL ERROR, SEE SOURCE CODE FOR INTERPRETATION.'/
  251.      1       ' PROBABLY CAUSE: ERRONEOUS INFO IN DATABASE.'/
  252.      2       ' ERROR CODE =',I2/)
  253.         STOP
  254.         END
  255. C  I/O ROUTINES (SPEAK, PSPEAK, RSPEAK, GETIN, YES, A5TOA1)
  256.         SUBROUTINE SPEAK(N)
  257. C  PRINT THE MESSAGE IN RECORD N OF THE RANDOM ACCESS MESSAGE FILE.
  258. C  PRECEDE IT WITH A BLANK LINE UNLESS BLKLIN IS FALSE.
  259.       INTEGER*2 RTEXT,ASCVAR,N,OLDLOC,LOC2(2),ASC2,ASC3,OLDASC
  260.         LOGICAL BLKLIN
  261.       REAL LINES(15),HNULL,HBLANK,LINES2(15,2)
  262.         COMMON /TXTCOM/ LINES,ASCVAR
  263.         COMMON /BLKCOM/ BLKLIN
  264.       DATA HNULL/'>$< '/,HBLANK/'    '/,OLDASC/0/
  265. C
  266.       ASCVAR=N
  267.         IF(N.EQ.0)RETURN
  268.     ASC3=(ASCVAR-1)/2+1
  269.     ASC2=MOD((ASCVAR-1),2)+1
  270.         IF (OLDASC.NE.ASC3) READ(6,REC=ASC3) LOC2,LINES2
  271.     LOC=LOC2(ASC2)
  272.     DO 10 IJ=1,15
  273. 10    LINES(IJ)=LINES2(IJ,ASC2)
  274.     OLDASC=ASC3
  275.       ASCVAR=ASCVAR+1
  276.         IF(LINES(1).EQ.HNULL)RETURN
  277.         IF(BLKLIN) WRITE(3,2)
  278. 1       OLDLOC = LOC
  279.         DO 3 I2=1,15
  280.       I=16-I2
  281.         L = I
  282.         IF(LINES(I) .NE. HBLANK) GO TO 5
  283. 3       CONTINUE
  284. 5       WRITE(3,2) (LINES(I),I=1,L)
  285. 2       FORMAT(1X,15A4)
  286.     ASC3=(ASCVAR-1)/2+1
  287.     ASC2=MOD((ASCVAR-1),2)+1
  288.         IF (OLDASC.NE.ASC3) READ(6,REC=ASC3) LOC2,LINES2
  289.     LOC=LOC2(ASC2)
  290.     DO 11 IJ=1,15
  291. 11    LINES(IJ)=LINES2(IJ,ASC2)
  292.     OLDASC=ASC3
  293.       ASCVAR=ASCVAR+1
  294.         IF(LOC .EQ. OLDLOC) GO TO 1
  295.       RETURN
  296.         END
  297.         SUBROUTINE PSPEAK(MSG,SKIP)
  298. C  FIND THE SKIP+1ST MESSAGE FROM MSG AND PRINT IT.  MSG SHOULD BE THE INDEX OF
  299. C  THE INVENTORY MESSAGE FOR OBJECT.  (INVEN+N+1 MESSAGE IS PROP=N MESSAGE).
  300.        INTEGER*2 RTEXT,PTEXT,ASCVAR
  301.       INTEGER SKIP,OLDLOC,ASC2,ASC3,OLDASC,LOC2(2)
  302.       LOGICAL I,IS1
  303.       REAL LINES,LINES2(15,2)
  304.         DIMENSION LINES(15),PTEXT(100)
  305.         COMMON /TXTCOM/ LINES,ASCVAR
  306.         COMMON /PTXCOM/ PTEXT
  307.     DATA OLDASC/0/
  308.         M=PTEXT(MSG)
  309.         IF(SKIP.LT.0)GOTO 9
  310.       IS1=SKIP+2
  311.       OLDLOC=-1
  312.       DO 3 I=1,IS1
  313. 1    ASC3=(M-1)/2+1
  314.     ASC2=MOD((M-1),2)+1
  315.         IF (OLDASC.NE.ASC3) READ(6,REC=ASC3) LOC2,LINES2
  316.     LOC=LOC2(ASC2)
  317.     DO 11 IJ=1,15
  318. 11    LINES(IJ)=LINES2(IJ,ASC2)
  319.     OLDASC=ASC3
  320.       M=M+1
  321.       IF (OLDLOC .EQ. LOC) GO TO 1
  322.       OLDLOC=LOC
  323.    3  CONTINUE
  324.       M=M-1
  325. 9       CALL SPEAK(M)
  326.         RETURN
  327.         END
  328.         SUBROUTINE RSPEAK(I)
  329. C  PRINT THE I-TH "RANDOM" MESSAGE (SECTION 6 OF DATABASE).
  330.        INTEGER*2 RTEXT,ASCVAR
  331.         IF(I.NE.0)CALL SPEAK(RTEXT(I))
  332.         RETURN
  333.         END
  334.         SUBROUTINE MSPEAK(I)
  335. C  PRINT THE I-TH "MAGIC" MESSAGE (SECTION 12 OF DATABASE).
  336.        INTEGER*2 MTEXT,ASCVAR
  337.         DIMENSION MTEXT(35)
  338.         COMMON /MTXCOM/ MTEXT
  339.         IF(I.NE.0)CALL SPEAK(MTEXT(I))
  340.         RETURN
  341.         END
  342.         SUBROUTINE GETIN(WORD1,WORD1X,WORD2,WORD2X)
  343. C  GET A COMMAND FROM THE ADVENTURER.  SNARF OUT THE FIRST WORD, PAD IT WITH
  344. C  BLANKS, AND RETURN IT IN WORD1.  CHARS 5 THRU 8 ARE RETURNED IN WORD1X, IN
  345. C  CASE WE NEED TO PRINT OUT THE WHOLE WORD IN AN ERROR MESSAGE.  ANY NUMBER OF
  346. C  BLANKS MAY FOLLOW THE WORD.  IF A SECOND WORD APPEARS, IT IS RETURNED IN
  347. C  WORD2 (CHARS 5 THRU 8 IN WORD2X), ELSE WORD2 IS SET TO ZERO.
  348.       INTEGER ST2
  349.       REAL WORD1,WORD1X,WORD2,WORD2X,A1(2),A2(2)
  350.       LOGICAL W1(8),W2(8),CR,BL
  351.       INTEGER IBL(8)
  352.         LOGICAL BLKLIN
  353.       LOGICAL IL,LA,LZ
  354.         LOGICAL*1 FRST(20)
  355.         COMMON /BLKCOM/ BLKLIN
  356.       EQUIVALENCE (A1(1),W1(1)), (A2(1),W2(1))
  357.       EQUIVALENCE (W1(1),IBL(1)),(W2(1),IBL(5))
  358.       EQUIVALENCE (IL,FRST(1))
  359.       DATA LA,LZ/'A','Z'/
  360.       DATA CR,BL/X'0D',' '/
  361.       DO 99 IL=1,8
  362.   99  IBL(IL)='  '
  363.         IF(BLKLIN) WRITE(3,1)
  364. 1       FORMAT(1X)
  365.       WRITE(3,103)
  366.  103  FORMAT(1X,'->')
  367. 2       READ(3,3) FRST
  368. 3       FORMAT(20A1)
  369.       DO 2000 I=1,20
  370.       IF (FRST(I) .EQ. CR) FRST(I)=BL
  371.       IF(LA .LE. FRST(I) .AND. FRST(I) .LE. LZ) FRST(I) =
  372.      2  FRST(I)+BL
  373. 2000  CONTINUE
  374.         ST2 = 1
  375.         IX1 = 0
  376.         IX2 = 0
  377.         I = 0
  378. 10      I = I + 1
  379.         IF(I .GT. 20) GO TO 2
  380.         IF(FRST(I) .EQ. BL) GO TO 10
  381. 15      IX1 = IX1 + 1
  382.       IF (IX1 .LE. 8) W1(IX1)=FRST(I)
  383.         I = I + 1
  384.         IF(I .GT. 20) GO TO 500
  385.         IF(FRST(I) .NE. BL) GO TO 15
  386. 20      I = I + 1
  387.         IF(I .GT. 20) GO TO 500
  388.         IF(FRST(I) .EQ. BL) GO TO 20
  389.         ST2 = I
  390. 25      IX2 = IX2 + 1
  391.       IF (IX2 .LE. 8) W2(IX2)=FRST(I)
  392.         I = I + 1
  393.         IF(I .GT. 20) GO TO 500
  394.         IF(FRST(I) .NE. BL) GO TO 25
  395.  500  WORD1=A1(1)
  396.       WORD1X=A1(2)
  397.         WORD2 = 0.
  398.         IF(IX2 .EQ. 0) RETURN
  399.       WORD2=A2(1)
  400.       WORD2X=A2(2)
  401.         RETURN
  402.         END
  403.         LOGICAL FUNCTION YES(X,Y,Z)
  404. C  CALL YESX (BELOW) WITH MESSAGES FROM SECTION 6.
  405.       INTEGER X,Y,Z
  406.         EXTERNAL RSPEAK
  407.         LOGICAL YESX
  408.         YES=YESX(X,Y,Z,RSPEAK)
  409.         RETURN
  410.         END
  411.         LOGICAL FUNCTION YESM(X,Y,Z)
  412. C  CALL YESX (BELOW) WITH MESSAGES FROM SECTION 12.
  413.       INTEGER X,Y,Z
  414.         EXTERNAL MSPEAK
  415.         LOGICAL YESX
  416.         YESM=YESX(X,Y,Z,MSPEAK)
  417.         RETURN
  418.         END
  419.         LOGICAL FUNCTION YESX(X,Y,Z,SPK)
  420. C  PRINT MESSAGE X, WAIT FOR YES/NO ANSWER.  IF YES, PRINT Y AND LEAVE YEA
  421. C  TRUE; IF NO, PRINT Z AND LEAVE YEA FALSE.  SPK IS EITHER RSPEAK OR MSPEAK.
  422.       INTEGER X,Y,Z
  423.       REAL REPLY,JUNK1,JUNK2,JUNK3,HY1,HY2,HN1,HN2
  424.       DATA HY1,HY2,HN1,HN2/'y   ','yes ','n   ','no  '/
  425. 1       IF(X.NE.0)CALL SPK(X)
  426.         CALL GETIN(REPLY,JUNK1,JUNK2,JUNK3)
  427.         IF(REPLY.EQ.HY1.OR.REPLY.EQ.HY2)GOTO 10
  428.         IF(REPLY.EQ.HN1.OR.REPLY.EQ.HN2)GOTO 20
  429.       WRITE(3,9)
  430. 9       FORMAT(/' Please answer the question.')
  431.         GOTO 1
  432. 10      YESX=.TRUE.
  433.         IF(Y.NE.0)CALL SPK(Y)
  434.         RETURN
  435. 20      YESX=.FALSE.
  436.         IF(Z.NE.0)CALL SPK(Z)
  437.         RETURN
  438.         END
  439.       REAL FUNCTION ATAB(I)
  440.       REAL BUF(32)
  441.       DATA N/0/
  442.       J=1+(I-1)/32
  443.       K=MOD(I,32)
  444.       IF (K .EQ. 0) K=32
  445.       IF (J .EQ. N) GO TO 1
  446.       N=J
  447.       READ(7,REC=N)BUF
  448.    1  ATAB=BUF(K)
  449.       RETURN
  450.       END
  451. C
  452.       INTEGER FUNCTION KTAB(N)
  453.       KTAB=IDISK(9,1,1,N)
  454. C      WRITE(3,100)N,KTAB
  455. C 100  FORMAT(1X,'KTAB(',I3,')=',I4)
  456.       RETURN
  457.       END
  458.