usr/src/contrib/dungeon/dso7.F

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
          UINW(I)=ichar(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=and(xor(xor(ichar(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)=and(RFLAG(CPUZZ),not(RSEEN))
        DO 100 I=1,OLNT
C                                               !RELOCATE OBJECTS.
          IF((OROOM(I).EQ.CPUZZ).AND.
&               (and(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/
#ifdef PDP
C
C       PICT, DGM and QMK have been changed from two to
C       one character in length. Puzout prints two copies.
C
        DATA PICT/'S','S','S',' ','M'/
        DATA QMK/'?'/
#else
        DATA PICT/'SS','SS','SS','  ','MM'/
        DATA QMK/'??'/
#endif PDP
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
#ifdef PDP
        call puzout(DGM(1))
#else
        WRITE(OUTCH,10) DGM
#endif
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
#ifndef PDP
10      FORMAT('       |',A2,1X,A2,1X,A2,'|'/,
&       ' West  |',A2,' .. ',A2,'|  East',/
&       '       |',A2,1X,A2,1X,A2,'|')
#endif PDP
C
        END