This repository has been archived by the owner on Oct 13, 2018. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 26
/
dso7.for
131 lines (131 loc) · 2.66 KB
/
dso7.for
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
C ENCRYP-- ENCRYPT PASSWORD
C
C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
C WRITTEN BY R. M. SUPNIK
C
C DECLARATIONS
C
SUBROUTINE ENCRYP(INW,OUTW)
IMPLICIT INTEGER(A-Z)
CHARACTER INW(6),OUTW(6)
CHARACTER KEYW(6),UKEYW(6)
INTEGER UINW(6)
DATA KEYW/'E','C','O','R','M','S'/
C
UINWS=0
C !UNBIASED INW SUM.
UKEYWS=0
C !UNBIASED KEYW SUM.
J=1
C !POINTER IN KEYWORD.
DO 100 I=1,6
C !UNBIAS, COMPUTE SUMS.
UKEYW(I)=char(ichar(KEYW(I))-64)
IF(INW(J).LE.char(64)) J=1
C UINW(I)=char(ichar(INW(J))-64)
UINW(I)=ichar(INW(J))-64
UKEYWS=UKEYWS+ichar(UKEYW(I))
UINWS=UINWS+UINW(I)
J=J+1
100 CONTINUE
C
USUM=MOD(UINWS,8)+(8*MOD(UKEYWS,8))
C !COMPUTE MASK.
DO 200 I=1,6
J=IAND(IEOR(IEOR(UINW(I),ichar(UKEYW(I))),USUM),31)
USUM=MOD(USUM+1,32)
IF(J.GT.26) J=MOD(J,26)
OUTW(I)=char(MAX0(1,J)+64)
200 CONTINUE
RETURN
C
END
C CPGOTO-- MOVE TO NEXT STATE IN PUZZLE ROOM
C
C DECLARATIONS
C
SUBROUTINE CPGOTO(ST)
IMPLICIT INTEGER(A-Z)
C
COMMON /HYPER/ HFACTR
include 'rooms.h'
include 'rflag.h'
include 'rindex.h'
include 'objects.h'
include 'oflags.h'
include 'flags.h'
C CPGOTO, PAGE 2
C
RFLAG(CPUZZ)=IAND(RFLAG(CPUZZ),not(RSEEN))
DO 100 I=1,OLNT
C !RELOCATE OBJECTS.
IF((OROOM(I).EQ.CPUZZ).AND.
& (IAND(OFLAG2(I),(ACTRBT+VILLBT)).EQ.0))
& CALL NEWSTA(I,0,CPHERE*HFACTR,0,0)
IF(OROOM(I).EQ.(ST*HFACTR))
& CALL NEWSTA(I,0,CPUZZ,0,0)
100 CONTINUE
CPHERE=ST
RETURN
C
END
C CPINFO-- DESCRIBE PUZZLE ROOM
C
C DECLARATIONS
C
SUBROUTINE CPINFO(RMK,ST)
IMPLICIT INTEGER(A-Z)
INTEGER DGMOFT(8)
CHARACTER DGM(8),PICT(5),QMK
C
COMMON /CHAN/ INPCH,OUTCH,DBCH
C
C PUZZLE ROOM
C
COMMON /PUZZLE/ CPDR(16),CPWL(8),CPVEC(64)
include 'flags.h'
C
C FUNCTIONS AND LOCAL DATA
C
C
DATA DGMOFT/-9,-8,-7,-1,1,7,8,9/
DATA PICT/'SS','SS','SS',' ','MM'/
DATA QMK/'??'/
C CPINFO, PAGE 2
C
CALL RSPEAK(RMK)
DO 100 I=1,8
J=DGMOFT(I)
DGM(I)=PICT(CPVEC(ST+J)+4)
C !GET PICTURE ELEMENT.
IF((IABS(J).EQ.1).OR.(IABS(J).EQ.8)) GO TO 100
K=8
IF(J.LT.0) K=-8
C !GET ORTHO DIR.
L=J-K
IF((CPVEC(ST+K).NE.0).AND.(CPVEC(ST+L).NE.0))
& DGM(I)=QMK
100 CONTINUE
WRITE(OUTCH,10) DGM
C
IF(ST.EQ.10) CALL RSPEAK(870)
C !AT HOLE?
IF(ST.EQ.37) CALL RSPEAK(871)
C !AT NICHE?
I=872
C !DOOR OPEN?
IF(CPOUTF) I=873
IF(ST.EQ.52) CALL RSPEAK(I)
C !AT DOOR?
IF(CPVEC(ST+1).EQ.-2) CALL RSPEAK(874)
C !EAST LADDER?
IF(CPVEC(ST-1).EQ.-3) CALL RSPEAK(875)
C !WEST LADDER?
RETURN
C
10 FORMAT(' |',A2,1X,A2,1X,A2,'|'/,
&' West |',A2,' .. ',A2,'| East',/
&' |',A2,1X,A2,1X,A2,'|')
C
END