date and time created 88/12/14 15:30:08 by sklower

[unix-history] / usr / src / contrib / dungeon / speak.F

#include "files.h"

#ifndef RTEXTFILE
#define RTEXTFILE '/usr/games/lib/dunlib/rtext.dat'
#endif

#ifndef TEXTFILE
#define TEXTFILE '/usr/games/lib/dunlib/dtext.dat'
#endif

C
C	manual speak routine
C	gets dungeon messages and prints them
C	(only used for pdp version)
C
	program speak
	IMPLICIT      INTEGER(A-Z)
C
	COMMON /CHAN/ INPCH,OUTCH,DBCH
#include "mindex.h"
C	
C	load the lookup table
C
	OPEN(UNIT=9,file=RTEXTFILE,
&		status='OLD',IOSTAT=IO,
&		FORM='formatted',ACCESS='SEQUENTIAL',err=50)
C
	call load
C
C	open the message file
C
	DBCH=2
C
	OPEN(UNIT=DBCH,file=TEXTFILE,
&		status='OLD',IOSTAT=IO,
&		FORM='UNFORMATTED',ACCESS='DIRECT',recl=76,err=60)
C
	print 20
#ifdef NOCC
20	format('Sigh... '/)
#else NOCC
20	format(' Sigh... '/)
#endif NOCC
C
C	get numbers and call speaking program
C
10	continue 
C
	call inprd(mesage,i,j)
	call RSPSB2(mesage,i,j)
	goto 10
C
C INITIALIZATION ERROR
C
50	print 960
	print 980
	goto 99
60	print 970
	print 980
	goto 99
#ifdef NOCC
960	FORMAT('I can''t open ',RTEXTFILE,'.')
970	FORMAT('I can''t open ',TEXTFILE,'.')
980	FORMAT('Suddenly a sinister, wraithlike figure appears before '
&	'you,'/'seeming to float in the air.  In a low, sorrowful voice'
&	' he says,'/'"Alas, the very nature of the world has changed, '
&	'and the dungeon'/'cannot be found.  All must now pass away."'
&	'  Raising his oaken staff'/'in farewell, he fades into the '
&	'spreading darkness.  In his place'/'appears a tastefully '
&	'lettered sign reading:'//23X,'INITIALIZATION FAILURE'//
&	'The darkness becomes all encompassing, and your vision fails.')
#else NOCC
960	FORMAT(' I can''t open ',RTEXTFILE,'.')
970	FORMAT(' I can''t open ',TEXTFILE,'.')
980	FORMAT(' Suddenly a sinister, wraithlike figure appears before '
&	'you,'/' seeming to float in the air.  In a low, sorrowful voice'
&	' he says,'/' "Alas, the very nature of the world has changed, '
&	'and the dungeon'/' cannot be found.  All must now pass away."'
&	'  Raising his oaken staff'/' in farewell, he fades into the '
&	'spreading darkness.  In his place'/' appears a tastefully '
&	'lettered sign reading:'//23X,'INITIALIZATION FAILURE'//
&	' The darkness becomes all encompassing, and your vision fails.')
#endif NOCC
99	stop
	end
C
C RSPSB2-- OUTPUT RANDOM MESSAGE WITH SUBSTITUTABLE ARGUMENTS
C
C CALLED BY--
C
C	CALL RSPSB2(MSGNUM,S1,S2)
C
	SUBROUTINE    RSPSB2(A,B,C)
	IMPLICIT      INTEGER(A-Z)
	CHARACTER*74  B1,B2,B3
	INTEGER*2     OLDREC,NEWREC,JREC
C
C DECLARATIONS
C
C
	COMMON /RMSG/ MLNT,RTEXT(1050)
	COMMON /CHAN/ INPCH,OUTCH,DBCH
C
C CONVERT ALL ARGUMENTS FROM DICTIONARY NUMBERS (IF POSITIVE)
C TO ABSOLUTE RECORD NUMBERS.
C
	X=A					
	Y=B
	Z=C
	IF(X.GT.0) X=RTEXT(X)			
	IF(Y.GT.0) Y=RTEXT(Y)
	IF(Z.GT.0) Z=RTEXT(Z)
	X=IABS(X)				
	Y=IABS(Y)
	Z=IABS(Z)
	IF(X.EQ.0) RETURN			
C
	READ(UNIT=DBCH,REC=X) OLDREC,B1
C
100	DO 150 I=1,74
	  X1=and(X,31)+I
	  B1(I:I)=char(xor(ichar(B1(I:I)),X1))
150	CONTINUE
C
200	IF(Y.EQ.0) GO TO 400			
	DO 300 I=1,74				
	  IF(B1(I:I).EQ.'#') GO TO 1000
300	CONTINUE
C
400	DO 500 I=74,1,-1			
	  IF(B1(I:I).NE.' ') GO TO 600
500	CONTINUE
C
C  600	WRITE(OUTCH,650) (B1(J:J),J=1,I)		
600	PRINT 650, (B1(J:J),J=1,I)		
#ifdef NOCC
650	FORMAT(74A1)
#else NOCC
650	FORMAT(1X,74A1)
#endif NOCC
	X=X+1					
	READ(UNIT=DBCH,REC=X) NEWREC,B1
	IF(OLDREC.EQ.NEWREC) GO TO 100		
	RETURN					
C
C SUBSTITUTION WITH SUBSTITUTABLE AVAILABLE.
C I IS INDEX OF # IN B1.
C Y IS NUMBER OF RECORD TO SUBSTITUTE.
C
C PROCEDURE:
C   1) COPY REST OF B1 TO B2
C   2) READ SUBSTITUTABLE OVER B1
C   3) RESTORE TAIL OF ORIGINAL B1
C
C THE IMPLICIT ASSUMPTION HERE IS THAT THE SUBSTITUTABLE STRING
C IS VERY SHORT (i.e. MUCH LESS THAN ONE RECORD).
C
1000	K2=1					
	DO 1100 K1=I+1,74			
	  B2(K2:K2)=B1(K1:K1)
	  K2=K2+1
1100	CONTINUE
C
C   READ SUBSTITUTE STRING INTO B3, AND DECRYPT IT:
C
	READ(UNIT=DBCH,REC=Y) JREC,B3
	DO 1150 K1=1,74
	  X1=and(Y,31)+K1
	  B3(K1:K1)=char(xor(ICHAR(B3(K1:K1)),X1))
1150	CONTINUE
C
C   FILL REMAINDER OF B1 WITH CHARACTERS FROM B3:
C
	K2=1
	DO 1180 K1=I,74
	  B1(K1:K1)=B3(K2:K2)
	  K2=K2+1
1180	CONTINUE
C
C   FIND END OF SUBSTITUTE STRING IN B1:
C
	DO 1200 J=74,1,-1			
	  IF(B1(J:J).NE.' ') GO TO 1300
1200	CONTINUE
C
C   PUT TAIL END OF B1 (NOW IN B2) BACK INTO B1 AFTER SUBSTITUTE STRING:
C
1300	K1=1					
	DO 1400 K2=J+1,74			
	  B1(K2:K2)=B2(K1:K1)
	  K1=K1+1
1400	CONTINUE
C
	Y=Z					
	Z=0					
	GO TO 200				
C
	END
	SUBROUTINE LOAD	
	IMPLICIT INTEGER (A-Z)
C
C	load rtext data 
C
C
C MESSAGE INDEX
C
	COMMON /RMSG/ MLNT,RTEXT(1050)
C
C
	rewind 9
C
C	 load the data
C
C
	READ(9,130) RTEXT
130	FORMAT(I8)
	close(9)
C
C
	return
	END