home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / games / volume2 / dungeon / part06 / speak.F < prev   
Text File  |  1987-09-01  |  4KB  |  201 lines
  1. #include "files.h"
  2.  
  3. #ifndef RTEXTFILE
  4. #define RTEXTFILE '/usr/games/lib/dunlib/rtext.dat'
  5. #endif
  6.  
  7. #ifndef TEXTFILE
  8. #define TEXTFILE '/usr/games/lib/dunlib/dtext.dat'
  9. #endif
  10.  
  11. C
  12. C    manual speak routine
  13. C    gets dungeon messages and prints them
  14. C    (only used for pdp version)
  15. C
  16.     program speak
  17.     IMPLICIT      INTEGER(A-Z)
  18. C
  19.     COMMON /CHAN/ INPCH,OUTCH,DBCH
  20. #include "mindex.h"
  21. C    
  22. C    load the lookup table
  23. C
  24.     OPEN(UNIT=9,file=RTEXTFILE,
  25. &        status='OLD',IOSTAT=IO,
  26. &        FORM='formatted',ACCESS='SEQUENTIAL',err=50)
  27. C
  28.     call load
  29. C
  30. C    open the message file
  31. C
  32.     DBCH=2
  33. C
  34.     OPEN(UNIT=DBCH,file=TEXTFILE,
  35. &        status='OLD',IOSTAT=IO,
  36. &        FORM='UNFORMATTED',ACCESS='DIRECT',recl=76,err=60)
  37. C
  38.     print 20
  39. 20    format('Sigh... '/)
  40. C
  41. C    get numbers and call speaking program
  42. C
  43. 10    continue 
  44. C
  45.     call inprd(mesage,i,j)
  46.     call RSPSB2(mesage,i,j)
  47.     goto 10
  48. C
  49. C INITIALIZATION ERROR
  50. C
  51. 50    print 960
  52.     print 980
  53.     goto 99
  54. 60    print 970
  55.     print 980
  56.     goto 99
  57. 960    FORMAT(' I can''t open ',RTEXTFILE,'.')
  58. 970    FORMAT(' I can''t open ',TEXTFILE,'.')
  59. 980    FORMAT(' Suddenly a sinister, wraithlike figure appears before '
  60. &    'you,'/' seeming to float in the air.  In a low, sorrowful voice'
  61. &    ' he says,'/' "Alas, the very nature of the world has changed, '
  62. &    'and the dungeon'/' cannot be found.  All must now pass away."'
  63. &    '  Raising his oaken staff'/' in farewell, he fades into the '
  64. &    'spreading darkness.  In his place'/' appears a tastefully '
  65. &    'lettered sign reading:'//23X,'INITIALIZATION FAILURE'//
  66. &    ' The darkness becomes all encompassing, and your vision fails.')
  67. 99    stop
  68.     end
  69. C
  70. C RSPSB2-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENTS
  71. C
  72. C CALLED BY--
  73. C
  74. C    CALL RSPSB2(MSGNUM,S1,S2)
  75. C
  76.     SUBROUTINE    RSPSB2(A,B,C)
  77.     IMPLICIT      INTEGER(A-Z)
  78.     CHARACTER*74  B1,B2,B3
  79.     INTEGER*2     OLDREC,NEWREC,JREC
  80. C
  81. C DECLARATIONS
  82. C
  83. C
  84.     COMMON /RMSG/ MLNT,RTEXT(1050)
  85.     COMMON /CHAN/ INPCH,OUTCH,DBCH
  86. C
  87. C CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE)
  88. C TO ABSOLUTE RECORD NUMBERS.
  89. C
  90.     X=A                    
  91.     Y=B
  92.     Z=C
  93.     IF(X.GT.0) X=RTEXT(X)            
  94.     IF(Y.GT.0) Y=RTEXT(Y)
  95.     IF(Z.GT.0) Z=RTEXT(Z)
  96.     X=IABS(X)                
  97.     Y=IABS(Y)
  98.     Z=IABS(Z)
  99.     IF(X.EQ.0) RETURN            
  100. C
  101.     READ(UNIT=DBCH,REC=X) OLDREC,B1
  102. C
  103. 100    DO 150 I=1,74
  104.       X1=and(X,31)+I
  105.       B1(I:I)=char(xor(ichar(B1(I:I)),X1))
  106. 150    CONTINUE
  107. C
  108. 200    IF(Y.EQ.0) GO TO 400            
  109.     DO 300 I=1,74                
  110.       IF(B1(I:I).EQ.'#') GO TO 1000
  111. 300    CONTINUE
  112. C
  113. 400    DO 500 I=74,1,-1            
  114.       IF(B1(I:I).NE.' ') GO TO 600
  115. 500    CONTINUE
  116. C
  117. C  600    WRITE(OUTCH,650) (B1(J:J),J=1,I)        
  118. 600    PRINT 650, (B1(J:J),J=1,I)        
  119. 650    FORMAT(1X,74A1)
  120.     X=X+1                    
  121.     READ(UNIT=DBCH,REC=X) NEWREC,B1
  122.     IF(OLDREC.EQ.NEWREC) GO TO 100        
  123.     RETURN                    
  124. C
  125. C SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE.
  126. C I IS INDEX OF # IN B1.
  127. C Y IS NUMBER OF RECORD TO SUBSTITUTE.
  128. C
  129. C PROCEDURE:
  130. C   1) COPY REST OF B1 TO B2
  131. C   2) READ SUBSTITUTABLE OVER B1
  132. C   3) RESTORE TAIL OF ORIGINAL B1
  133. C
  134. C THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING
  135. C IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD).
  136. C
  137. 1000    K2=1                    
  138.     DO 1100 K1=I+1,74            
  139.       B2(K2:K2)=B1(K1:K1)
  140.       K2=K2+1
  141. 1100    CONTINUE
  142. C
  143. C   READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT:
  144. C
  145.     READ(UNIT=DBCH,REC=Y) JREC,B3
  146.     DO 1150 K1=1,74
  147.       X1=and(Y,31)+K1
  148.       B3(K1:K1)=char(xor(ICHAR(B3(K1:K1)),X1))
  149. 1150    CONTINUE
  150. C
  151. C   FILL REMAINDER OF B1 WITH CHARACTERS FROM B3:
  152. C
  153.     K2=1
  154.     DO 1180 K1=I,74
  155.       B1(K1:K1)=B3(K2:K2)
  156.       K2=K2+1
  157. 1180    CONTINUE
  158. C
  159. C   FIND END OF SUBSTITUTE STRING IN B1:
  160. C
  161.     DO 1200 J=74,1,-1            
  162.       IF(B1(J:J).NE.' ') GO TO 1300
  163. 1200    CONTINUE
  164. C
  165. C   PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING:
  166. C
  167. 1300    K1=1                    
  168.     DO 1400 K2=J+1,74            
  169.       B1(K2:K2)=B2(K1:K1)
  170.       K1=K1+1
  171. 1400    CONTINUE
  172. C
  173.     Y=Z                    
  174.     Z=0                    
  175.     GO TO 200                
  176. C
  177.     END
  178.     SUBROUTINE LOAD    
  179.     IMPLICIT INTEGER (A-Z)
  180. C
  181. C    load rtext data 
  182. C
  183. C
  184. C MESSAGE INDEX
  185. C
  186.     COMMON /RMSG/ MLNT,RTEXT(1050)
  187. C
  188. C
  189.     rewind 9
  190. C
  191. C     load the data
  192. C
  193. C
  194.     READ(9,130) RTEXT
  195. 130    FORMAT(I8)
  196.     close(9)
  197. C
  198. C
  199.     return
  200.     END
  201.