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 11C 12C manual speak routine 13C gets dungeon messages and prints them 14C (only used for pdp version) 15C 16 program speak 17 IMPLICIT INTEGER(A-Z) 18C 19 COMMON /CHAN/ INPCH,OUTCH,DBCH 20#include "mindex.h" 21C 22C load the lookup table 23C 24 OPEN(UNIT=9,file=RTEXTFILE, 25& status='OLD',IOSTAT=IO, 26& FORM='formatted',ACCESS='SEQUENTIAL',err=50) 27C 28 call load 29C 30C open the message file 31C 32 DBCH=2 33C 34 OPEN(UNIT=DBCH,file=TEXTFILE, 35& status='OLD',IOSTAT=IO, 36& FORM='UNFORMATTED',ACCESS='DIRECT',recl=76,err=60) 37C 38 print 20 39#ifdef NOCC 4020 format('Sigh... '/) 41#else NOCC 4220 format(' Sigh... '/) 43#endif NOCC 44C 45C get numbers and call speaking program 46C 4710 continue 48C 49 call inprd(mesage,i,j) 50 call RSPSB2(mesage,i,j) 51 goto 10 52C 53C INITIALIZATION ERROR 54C 5550 print 960 56 print 980 57 goto 99 5860 print 970 59 print 980 60 goto 99 61#ifdef NOCC 62960 FORMAT('I can''t open ',RTEXTFILE,'.') 63970 FORMAT('I can''t open ',TEXTFILE,'.') 64980 FORMAT('Suddenly a sinister, wraithlike figure appears before ' 65& 'you,'/'seeming to float in the air. In a low, sorrowful voice' 66& ' he says,'/'"Alas, the very nature of the world has changed, ' 67& 'and the dungeon'/'cannot be found. All must now pass away."' 68& ' Raising his oaken staff'/'in farewell, he fades into the ' 69& 'spreading darkness. In his place'/'appears a tastefully ' 70& 'lettered sign reading:'//23X,'INITIALIZATION FAILURE'// 71& 'The darkness becomes all encompassing, and your vision fails.') 72#else NOCC 73960 FORMAT(' I can''t open ',RTEXTFILE,'.') 74970 FORMAT(' I can''t open ',TEXTFILE,'.') 75980 FORMAT(' Suddenly a sinister, wraithlike figure appears before ' 76& 'you,'/' seeming to float in the air. In a low, sorrowful voice' 77& ' he says,'/' "Alas, the very nature of the world has changed, ' 78& 'and the dungeon'/' cannot be found. All must now pass away."' 79& ' Raising his oaken staff'/' in farewell, he fades into the ' 80& 'spreading darkness. In his place'/' appears a tastefully ' 81& 'lettered sign reading:'//23X,'INITIALIZATION FAILURE'// 82& ' The darkness becomes all encompassing, and your vision fails.') 83#endif NOCC 8499 stop 85 end 86C 87C RSPSB2-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENTS 88C 89C CALLED BY-- 90C 91C CALL RSPSB2(MSGNUM,S1,S2) 92C 93 SUBROUTINE RSPSB2(A,B,C) 94 IMPLICIT INTEGER(A-Z) 95 CHARACTER*74 B1,B2,B3 96 INTEGER*2 OLDREC,NEWREC,JREC 97C 98C DECLARATIONS 99C 100C 101 COMMON /RMSG/ MLNT,RTEXT(1050) 102 COMMON /CHAN/ INPCH,OUTCH,DBCH 103C 104C CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE) 105C TO ABSOLUTE RECORD NUMBERS. 106C 107 X=A 108 Y=B 109 Z=C 110 IF(X.GT.0) X=RTEXT(X) 111 IF(Y.GT.0) Y=RTEXT(Y) 112 IF(Z.GT.0) Z=RTEXT(Z) 113 X=IABS(X) 114 Y=IABS(Y) 115 Z=IABS(Z) 116 IF(X.EQ.0) RETURN 117C 118 READ(UNIT=DBCH,REC=X) OLDREC,B1 119C 120100 DO 150 I=1,74 121 X1=and(X,31)+I 122 B1(I:I)=char(xor(ichar(B1(I:I)),X1)) 123150 CONTINUE 124C 125200 IF(Y.EQ.0) GO TO 400 126 DO 300 I=1,74 127 IF(B1(I:I).EQ.'#') GO TO 1000 128300 CONTINUE 129C 130400 DO 500 I=74,1,-1 131 IF(B1(I:I).NE.' ') GO TO 600 132500 CONTINUE 133C 134C 600 WRITE(OUTCH,650) (B1(J:J),J=1,I) 135600 PRINT 650, (B1(J:J),J=1,I) 136#ifdef NOCC 137650 FORMAT(74A1) 138#else NOCC 139650 FORMAT(1X,74A1) 140#endif NOCC 141 X=X+1 142 READ(UNIT=DBCH,REC=X) NEWREC,B1 143 IF(OLDREC.EQ.NEWREC) GO TO 100 144 RETURN 145C 146C SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE. 147C I IS INDEX OF # IN B1. 148C Y IS NUMBER OF RECORD TO SUBSTITUTE. 149C 150C PROCEDURE: 151C 1) COPY REST OF B1 TO B2 152C 2) READ SUBSTITUTABLE OVER B1 153C 3) RESTORE TAIL OF ORIGINAL B1 154C 155C THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING 156C IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD). 157C 1581000 K2=1 159 DO 1100 K1=I+1,74 160 B2(K2:K2)=B1(K1:K1) 161 K2=K2+1 1621100 CONTINUE 163C 164C READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT: 165C 166 READ(UNIT=DBCH,REC=Y) JREC,B3 167 DO 1150 K1=1,74 168 X1=and(Y,31)+K1 169 B3(K1:K1)=char(xor(ICHAR(B3(K1:K1)),X1)) 1701150 CONTINUE 171C 172C FILL REMAINDER OF B1 WITH CHARACTERS FROM B3: 173C 174 K2=1 175 DO 1180 K1=I,74 176 B1(K1:K1)=B3(K2:K2) 177 K2=K2+1 1781180 CONTINUE 179C 180C FIND END OF SUBSTITUTE STRING IN B1: 181C 182 DO 1200 J=74,1,-1 183 IF(B1(J:J).NE.' ') GO TO 1300 1841200 CONTINUE 185C 186C PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING: 187C 1881300 K1=1 189 DO 1400 K2=J+1,74 190 B1(K2:K2)=B2(K1:K1) 191 K1=K1+1 1921400 CONTINUE 193C 194 Y=Z 195 Z=0 196 GO TO 200 197C 198 END 199 SUBROUTINE LOAD 200 IMPLICIT INTEGER (A-Z) 201C 202C load rtext data 203C 204C 205C MESSAGE INDEX 206C 207 COMMON /RMSG/ MLNT,RTEXT(1050) 208C 209C 210 rewind 9 211C 212C load the data 213C 214C 215 READ(9,130) RTEXT 216130 FORMAT(I8) 217 close(9) 218C 219C 220 return 221 END 222