mirror of
https://github.com/PDP-10/its.git
synced 2026-03-06 03:19:18 +00:00
Added 350-point adventure, 448-point adventure, and star trek games.
This commit is contained in:
Eric Swenson
@@ -312,6 +312,58 @@ respond "Command:" "d"
|
||||
respond "*" ":pdump sys3; ts advent\r"
|
||||
respond "*" ":kill\r"
|
||||
|
||||
# 350-point ADVENT
|
||||
respond "*" ":cwd games\r"
|
||||
respond "*" ":dec sys:f40\r"
|
||||
respond "*" "adv3sr=adv3sr\r"
|
||||
respond "*" "adv3sb=adv3sb\r"
|
||||
respond "CORE USED" "\032"
|
||||
type ":kill\r"
|
||||
respond "*" ":dec sys:loader\r"
|
||||
respond "*" "adv3sb\r"
|
||||
respond "*" "adv3sr\r"
|
||||
respond "*" "/go\r"
|
||||
respond "EXIT" ":start\r"
|
||||
respond "*" "adv3db.1"
|
||||
respond "*" "\032"
|
||||
type ":start 45\r"
|
||||
respond "Command:" "d"
|
||||
respond "*" ":pdump games; ts adv350\r"
|
||||
respond "*" ":kill\r"
|
||||
|
||||
# 448-point ADVENT
|
||||
respond "*" ":cwd games\r"
|
||||
respond "*" ":dec sys:f40\r"
|
||||
respond "*" "adv4ma=adv4ma\r"
|
||||
respond "*" "adv4su=adv4su\r"
|
||||
respond "CORE USED" "\032"
|
||||
type ":kill\r"
|
||||
respond "*" ":dec sys:loader\r"
|
||||
respond "*" "adv4ma\r"
|
||||
respond "*" "adv4su\r"
|
||||
respond "*" "/go\r"
|
||||
respond "EXIT" ":start\r"
|
||||
respond "*" "adv4db.2"
|
||||
respond "Are you a wizard?" "\032"
|
||||
type ":start 45\r"
|
||||
respond "Command:" "d"
|
||||
respond "*" ":pdump games; ts adv448\r"
|
||||
respond "*" ":kill\r"
|
||||
|
||||
# TREK
|
||||
respond "*" ":cwd games\r"
|
||||
respond "*" ":dec sys:f40\r"
|
||||
respond "*" "trek=trek\r"
|
||||
respond "CORE USED" "\032"
|
||||
type ":kill\r"
|
||||
respond "*" ":dec sys:loader\r"
|
||||
respond "*" "trek\r"
|
||||
respond "*" "/go\r"
|
||||
respond "EXIT" ":start 45\r"
|
||||
respond "Command:" "d"
|
||||
respond "*" ":pdump games; ts trek\r"
|
||||
respond "*" ":kill\r"
|
||||
|
||||
# Chess: timesharing, no TV display
|
||||
respond "*" ":midas /t games;ts chess2_rg;chess2\r"
|
||||
respond "with ^C" "TV==0\r\003"
|
||||
|
||||
@@ -4,6 +4,8 @@
|
||||
- ACCLNK, sets com-link accept bit for specified TTY.
|
||||
- ACOUNT, dummy account program used for users from safe sites.
|
||||
- ADVENT, (Colossal Cave) Adventure by Will Crowther.
|
||||
- ADV350, 350-point Adventure.
|
||||
- ADV448, 448-point Adventure.
|
||||
- ARCCPY, copies and old-format archive, converting to new format.
|
||||
- ARCDEV, transparent file system access to archive files.
|
||||
- ARCSAL, archive salvager.
|
||||
@@ -180,6 +182,7 @@
|
||||
- TIMOON, displays the time and phase of the moon.
|
||||
- TIMSRV, RFC 868 network time protocol.
|
||||
- TMPKIL, clean out old files in .TEMP.;.
|
||||
- TREK, Star Trek game.
|
||||
- TTLOC, Advertises physical location of logged in users.
|
||||
- TTY, displays TTYs with UNAME/JNAME/CORE and other info.
|
||||
- TTYSWP, swap TTYs.
|
||||
|
||||
1809
src/games/adv3db.1
Normal file
1809
src/games/adv3db.1
Normal file
File diff suppressed because it is too large
Load Diff
854
src/games/adv3sb.2
Normal file
854
src/games/adv3sb.2
Normal file
@@ -0,0 +1,854 @@
|
||||
C I/O ROUTINES (SPEAK, PSPEAK, RSPEAK, GETIN, YES, A5TOA1)
|
||||
|
||||
|
||||
SUBROUTINE SPEAK(N)
|
||||
|
||||
C PRINT THE MESSAGE WHICH STARTS AT LINES(N). PRECEDE IT WITH A BLANK LINE
|
||||
C UNLESS BLKLIN IS FALSE.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL BLKLIN
|
||||
COMMON /TXTCOM/ RTEXT,LINES
|
||||
COMMON /BLKCOM/ BLKLIN
|
||||
DIMENSION RTEXT(205),LINES(9650)
|
||||
|
||||
IF(N.EQ.0)RETURN
|
||||
IF(LINES(N+1).EQ.'>$<')RETURN
|
||||
IF(BLKLIN)TYPE 2
|
||||
K=N
|
||||
1 L=IABS(LINES(K))-1
|
||||
K=K+1
|
||||
TYPE 2,(LINES(I),I=K,L)
|
||||
2 FORMAT(' ',14A5)
|
||||
K=L+1
|
||||
IF(LINES(K).GE.0)GOTO 1
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE PSPEAK(MSG,SKIP)
|
||||
|
||||
C FIND THE SKIP+1ST MESSAGE FROM MSG AND PRINT IT. MSG SHOULD BE THE INDEX OF
|
||||
C THE INVENTORY MESSAGE FOR OBJECT. (INVEN+N+1 MESSAGE IS PROP=N MESSAGE).
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /TXTCOM/ RTEXT,LINES
|
||||
COMMON /PTXCOM/ PTEXT
|
||||
DIMENSION RTEXT(205),LINES(9650),PTEXT(100)
|
||||
|
||||
M=PTEXT(MSG)
|
||||
IF(SKIP.LT.0)GOTO 9
|
||||
DO 3 I=0,SKIP
|
||||
1 M=IABS(LINES(M))
|
||||
IF(LINES(M).GE.0)GOTO 1
|
||||
3 CONTINUE
|
||||
9 CALL SPEAK(M)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE RSPEAK(I)
|
||||
|
||||
C PRINT THE I-TH "RANDOM" MESSAGE (SECTION 6 OF DATABASE).
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /TXTCOM/ RTEXT
|
||||
DIMENSION RTEXT(205)
|
||||
|
||||
IF(I.NE.0)CALL SPEAK(RTEXT(I))
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE MSPEAK(I)
|
||||
|
||||
C PRINT THE I-TH "MAGIC" MESSAGE (SECTION 12 OF DATABASE).
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /MTXCOM/ MTEXT
|
||||
DIMENSION MTEXT(35)
|
||||
|
||||
IF(I.NE.0)CALL SPEAK(MTEXT(I))
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE GETIN(WORD1,WORD1X,WORD2,WORD2X)
|
||||
|
||||
C GET A COMMAND FROM THE ADVENTURER. SNARF OUT THE FIRST WORD, PAD IT WITH
|
||||
C BLANKS, AND RETURN IT IN WORD1. CHARS 6 THRU 10 ARE RETURNED IN WORD1X, IN
|
||||
C CASE WE NEED TO PRINT OUT THE WHOLE WORD IN AN ERROR MESSAGE. ANY NUMBER OF
|
||||
C BLANKS MAY FOLLOW THE WORD. IF A SECOND WORD APPEARS, IT IS RETURNED IN
|
||||
C WORD2 (CHARS 6 THRU 10 IN WORD2X), ELSE WORD2 IS SET TO ZERO.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL BLKLIN
|
||||
COMMON /BLKCOM/ BLKLIN
|
||||
DIMENSION A(5),MASKS(6)
|
||||
DATA MASKS/"4000000000,"20000000,"100000,"400,"2,0/
|
||||
1 ,BLANKS/' '/
|
||||
|
||||
IF(BLKLIN)TYPE 1
|
||||
1 FORMAT()
|
||||
2 ACCEPT 3,(A(I),I=1,4)
|
||||
3 FORMAT(4A5)
|
||||
J=0
|
||||
DO 9 I=1,4
|
||||
IF(A(I).NE.BLANKS)J=1
|
||||
9 A(I)=A(I).AND.(SHIFT((A(I).AND.'@@@@@'),-1).XOR.-1)
|
||||
IF(BLKLIN.AND.J.EQ.0)GOTO 2
|
||||
|
||||
SECOND=0
|
||||
WORD1=A(1)
|
||||
WORD1X=A(2)
|
||||
WORD2=0
|
||||
|
||||
DO 10 J=1,4
|
||||
DO 10 K=1,5
|
||||
MSK="774000000000
|
||||
IF(K.NE.1)MSK="177*MASKS(K)
|
||||
IF(((A(J).XOR.BLANKS).AND.MSK).EQ.0)GOTO 15
|
||||
IF(SECOND.EQ.0)GOTO 10
|
||||
MSK=-MASKS(6-K)
|
||||
WORD2=(SHIFT(A(J),7*(K-1)).AND.MSK)
|
||||
1 +(SHIFT(A(J+1),7*(K-6)).AND.(-2-MSK))
|
||||
WORD2X=(SHIFT(A(J+1),7*(K-1)).AND.MSK)
|
||||
1 +(SHIFT(A(J+2),7*(K-6)).AND.(-2-MSK))
|
||||
RETURN
|
||||
|
||||
15 IF(SECOND.EQ.1)GOTO 10
|
||||
SECOND=1
|
||||
IF(J.EQ.1)WORD1=(WORD1.AND.-MASKS(K))
|
||||
1 .OR.(BLANKS.AND.(-MASKS(K).XOR.-1))
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
LOGICAL FUNCTION YES(X,Y,Z)
|
||||
|
||||
C CALL YESX (BELOW) WITH MESSAGES FROM SECTION 6.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
EXTERNAL RSPEAK
|
||||
LOGICAL YESX
|
||||
|
||||
YES=YESX(X,Y,Z,RSPEAK)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
LOGICAL FUNCTION YESM(X,Y,Z)
|
||||
|
||||
C CALL YESX (BELOW) WITH MESSAGES FROM SECTION 12.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
EXTERNAL MSPEAK
|
||||
LOGICAL YESX
|
||||
|
||||
YESM=YESX(X,Y,Z,MSPEAK)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
LOGICAL FUNCTION YESX(X,Y,Z,SPK)
|
||||
|
||||
C PRINT MESSAGE X, WAIT FOR YES/NO ANSWER. IF YES, PRINT Y AND LEAVE YEA
|
||||
C TRUE; IF NO, PRINT Z AND LEAVE YEA FALSE. SPK IS EITHER RSPEAK OR MSPEAK.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
|
||||
1 IF(X.NE.0)CALL SPK(X)
|
||||
CALL GETIN(REPLY,JUNK1,JUNK2,JUNK3)
|
||||
IF(REPLY.EQ.'YES'.OR.REPLY.EQ.'Y')GOTO 10
|
||||
IF(REPLY.EQ.'NO'.OR.REPLY.EQ.'N')GOTO 20
|
||||
TYPE 9
|
||||
9 FORMAT(/' PLEASE ANSWER THE QUESTION.')
|
||||
GOTO 1
|
||||
10 YESX=.TRUE.
|
||||
IF(Y.NE.0)CALL SPK(Y)
|
||||
RETURN
|
||||
20 YESX=.FALSE.
|
||||
IF(Z.NE.0)CALL SPK(Z)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE A5TOA1(A,B,C,CHARS,LENG)
|
||||
|
||||
C A AND B CONTAIN A 1- TO 9-CHARACTER WORD IN A5 FORMAT, C CONTAINS ANOTHER
|
||||
C WORD AND/OR PUNCTUATION. THEY ARE UNPACKED TO ONE CHARACTER PER WORD IN THE
|
||||
C ARRAY "CHARS", WITH EXACTLY ONE BLANK BETWEEN B AND C (OR NONE, IF C >= 0).
|
||||
C THE INDEX OF THE LAST NON-BLANK CHAR IN CHARS IS RETURNED IN LENG.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION CHARS(20),WORDS(3)
|
||||
DATA MASK,BLANK/"774000000000,' '/
|
||||
|
||||
WORDS(1)=A
|
||||
WORDS(2)=B
|
||||
WORDS(3)=C
|
||||
POSN=1
|
||||
DO 1 WORD=1,3
|
||||
IF(WORD.EQ.2.AND.POSN.NE.6)GOTO 1
|
||||
IF(WORD.EQ.3.AND.C.LT.0)POSN=POSN+1
|
||||
DO 2 CH=1,5
|
||||
CHARS(POSN)=(WORDS(WORD).AND.MASK)+(BLANK-(BLANK.AND.MASK))
|
||||
IF(CHARS(POSN).EQ.BLANK)GOTO 1
|
||||
LENG=POSN
|
||||
WORDS(WORD)=SHIFT(WORDS(WORD),7)
|
||||
2 POSN=POSN+1
|
||||
1 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
C DATA STRUCTURE ROUTINES (VOCAB, DSTROY, JUGGLE, MOVE, PUT, CARRY, DROP)
|
||||
|
||||
|
||||
INTEGER FUNCTION VOCAB(ID,INIT)
|
||||
|
||||
C LOOK UP ID IN THE VOCABULARY (ATAB) AND RETURN ITS "DEFINITION" (KTAB), OR
|
||||
C -1 IF NOT FOUND. IF INIT IS POSITIVE, THIS IS AN INITIALISATION CALL SETTING
|
||||
C UP A KEYWORD VARIABLE, AND NOT FINDING IT CONSTITUTES A BUG. IT ALSO MEANS
|
||||
C THAT ONLY KTAB VALUES WHICH TAKEN OVER 1000 EQUAL INIT MAY BE CONSIDERED.
|
||||
C (THUS "STEPS", WHICH IS A MOTION VERB AS WELL AS AN OBJECT, MAY BE LOCATED
|
||||
C AS AN OBJECT.) AND IT ALSO MEANS THE KTAB VALUE IS TAKEN MOD 1000.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
|
||||
DIMENSION KTAB(300),ATAB(300)
|
||||
|
||||
HASH=ID.XOR.'PHROG'
|
||||
DO 1 I=1,TABSIZ
|
||||
IF(KTAB(I).EQ.-1)GOTO 2
|
||||
IF(INIT.GE.0.AND.KTAB(I)/1000.NE.INIT)GOTO 1
|
||||
IF(ATAB(I).EQ.HASH)GOTO 3
|
||||
1 CONTINUE
|
||||
CALL BUG(21)
|
||||
|
||||
2 VOCAB=-1
|
||||
IF(INIT.LT.0)RETURN
|
||||
CALL BUG(5)
|
||||
|
||||
3 VOCAB=KTAB(I)
|
||||
IF(INIT.GE.0)VOCAB=MOD(VOCAB,1000)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE DSTROY(OBJECT)
|
||||
|
||||
C PERMANENTLY ELIMINATE "OBJECT" BY MOVING TO A NON-EXISTENT LOCATION.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
|
||||
CALL MOVE(OBJECT,0)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE JUGGLE(OBJECT)
|
||||
|
||||
C JUGGLE AN OBJECT BY PICKING IT UP AND PUTTING IT DOWN AGAIN, THE PURPOSE
|
||||
C BEING TO GET THE OBJECT TO THE FRONT OF THE CHAIN OF THINGS AT ITS LOC.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
|
||||
|
||||
I=PLACE(OBJECT)
|
||||
J=FIXED(OBJECT)
|
||||
CALL MOVE(OBJECT,I)
|
||||
CALL MOVE(OBJECT+100,J)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE MOVE(OBJECT,WHERE)
|
||||
|
||||
C PLACE ANY OBJECT ANYWHERE BY PICKING IT UP AND DROPPING IT. MAY ALREADY BE
|
||||
C TOTING, IN WHICH CASE THE CARRY IS A NO-OP. MUSTN'T PICK UP OBJECTS WHICH
|
||||
C ARE NOT AT ANY LOC, SINCE CARRY WANTS TO REMOVE OBJECTS FROM ATLOC CHAINS.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
|
||||
|
||||
IF(OBJECT.GT.100)GOTO 1
|
||||
FROM=PLACE(OBJECT)
|
||||
GOTO 2
|
||||
1 FROM=FIXED(OBJECT-100)
|
||||
2 IF(FROM.GT.0.AND.FROM.LE.300)CALL CARRY(OBJECT,FROM)
|
||||
CALL DROP(OBJECT,WHERE)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
INTEGER FUNCTION PUT(OBJECT,WHERE,PVAL)
|
||||
|
||||
C PUT IS THE SAME AS MOVE, EXCEPT IT RETURNS A VALUE USED TO SET UP THE
|
||||
C NEGATED PROP VALUES FOR THE REPOSITORY OBJECTS.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
|
||||
CALL MOVE(OBJECT,WHERE)
|
||||
PUT=(-1)-PVAL
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE CARRY(OBJECT,WHERE)
|
||||
|
||||
C START TOTING AN OBJECT, REMOVING IT FROM THE LIST OF THINGS AT ITS FORMER
|
||||
C LOCATION. INCR HOLDNG UNLESS IT WAS ALREADY BEING TOTED. IF OBJECT>100
|
||||
C (MOVING "FIXED" SECOND LOC), DON'T CHANGE PLACE OR HOLDNG.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
|
||||
|
||||
IF(OBJECT.GT.100)GOTO 5
|
||||
IF(PLACE(OBJECT).EQ.-1)RETURN
|
||||
PLACE(OBJECT)=-1
|
||||
HOLDNG=HOLDNG+1
|
||||
5 IF(ATLOC(WHERE).NE.OBJECT)GOTO 6
|
||||
ATLOC(WHERE)=LINK(OBJECT)
|
||||
RETURN
|
||||
6 TEMP=ATLOC(WHERE)
|
||||
7 IF(LINK(TEMP).EQ.OBJECT)GOTO 8
|
||||
TEMP=LINK(TEMP)
|
||||
GOTO 7
|
||||
8 LINK(TEMP)=LINK(OBJECT)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE DROP(OBJECT,WHERE)
|
||||
|
||||
C PLACE AN OBJECT AT A GIVEN LOC, PREFIXING IT ONTO THE ATLOC LIST. DECR
|
||||
C HOLDNG IF THE OBJECT WAS BEING TOTED.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
|
||||
|
||||
IF(OBJECT.GT.100)GOTO 1
|
||||
IF(PLACE(OBJECT).EQ.-1)HOLDNG=HOLDNG-1
|
||||
PLACE(OBJECT)=WHERE
|
||||
GOTO 2
|
||||
1 FIXED(OBJECT-100)=WHERE
|
||||
2 IF(WHERE.LE.0)RETURN
|
||||
LINK(OBJECT)=ATLOC(WHERE)
|
||||
ATLOC(WHERE)=OBJECT
|
||||
RETURN
|
||||
END
|
||||
C WIZARDRY ROUTINES (START, MAINT, WIZARD, HOURS(X), NEWHRS(X), MOTD, POOF)
|
||||
|
||||
|
||||
LOGICAL FUNCTION START(DUMMY)
|
||||
|
||||
C CHECK TO SEE IF THIS IS "PRIME TIME". IF SO, ONLY WIZARDS MAY PLAY, THOUGH
|
||||
C OTHERS MAY BE ALLOWED A SHORT GAME FOR DEMONSTRATION PURPOSES. IF SETUP<0,
|
||||
C WE'RE CONTINUING FROM A SAVED GAME, SO CHECK FOR SUITABLE LATENCY. RETURN
|
||||
C TRUE IF THIS IS A DEMO GAME (VALUE IS IGNORED FOR RESTARTS).
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL PTIME,SOON,YESM
|
||||
DIMENSION HNAME(4)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
|
||||
1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
|
||||
|
||||
C FIRST FIND OUT WHETHER IT IS PRIME TIME (SAVE IN PTIME) AND, IF RESTARTING,
|
||||
C WHETHER IT'S TOO SOON (SAVE IN SOON). PRIME-TIME SPECS ARE IN WKDAY, WKEND,
|
||||
C AND HOLID; SEE MAINT ROUTINE FOR DETAILS. LATNCY IS REQUIRED DELAY BEFORE
|
||||
C RESTARTING. WIZARDS MAY CUT THIS TO A THIRD.
|
||||
|
||||
CALL DATIME(D,T)
|
||||
PRIMTM=WKDAY
|
||||
IF(MOD(D,7).LE.1)PRIMTM=WKEND
|
||||
IF(D.GE.HBEGIN.AND.D.LE.HEND)PRIMTM=HOLID
|
||||
PTIME=(PRIMTM.AND.SHIFT(1,T/60)).NE.0
|
||||
SOON=.FALSE.
|
||||
IF(SETUP.GE.0)GOTO 20
|
||||
DELAY=(D-SAVED)*1440+(T-SAVET)
|
||||
IF(DELAY.GE.LATNCY)GOTO 20
|
||||
TYPE 10,DELAY
|
||||
10 FORMAT(' THIS ADVENTURE WAS SUSPENDED A MERE',I3,' MINUTES AGO.')
|
||||
SOON=.TRUE.
|
||||
IF(DELAY.GE.LATNCY/3)GOTO 20
|
||||
CALL MSPEAK(2)
|
||||
STOP
|
||||
|
||||
C IF NEITHER TOO SOON NOR PRIME TIME, NO PROBLEM. ELSE SPECIFY WHAT'S WRONG.
|
||||
|
||||
20 START=.FALSE.
|
||||
IF(SOON)GOTO 30
|
||||
IF(PTIME)GOTO 25
|
||||
22 SAVED=-1
|
||||
RETURN
|
||||
|
||||
C COME HERE IF NOT RESTARTING TOO SOON (MAYBE NOT RESTARTING AT ALL), BUT IT'S
|
||||
C PRIME TIME. GIVE OUR HOURS AND SEE IF HE'S A WIZARD. IF NOT, THEN CAN'T
|
||||
C RESTART, BUT IF JUST BEGINNING THEN WE CAN OFFER A SHORT GAME.
|
||||
|
||||
25 CALL MSPEAK(3)
|
||||
CALL HOURS
|
||||
CALL MSPEAK(4)
|
||||
IF(WIZARD(0))GOTO 22
|
||||
IF(SETUP.LT.0)GOTO 33
|
||||
START=YESM(5,7,7)
|
||||
IF(START)GOTO 22
|
||||
STOP
|
||||
|
||||
C COME HERE IF RESTARTING TOO SOON. IF HE'S A WIZARD, LET HIM GO (AND NOTE
|
||||
C THAT IT THEN DOESN'T MATTER WHETHER IT'S PRIME TIME). ELSE, TOUGH BEANS.
|
||||
|
||||
30 CALL MSPEAK(8)
|
||||
IF(WIZARD(0))GOTO 22
|
||||
33 CALL MSPEAK(9)
|
||||
STOP
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE MAINT
|
||||
|
||||
C SOMEONE SAID THE MAGIC WORD TO INVOKE MAINTENANCE MODE. MAKE SURE HE'S A
|
||||
C WIZARD. IF SO, LET HIM TWEAK ALL SORTS OF RANDOM THINGS, THEN EXIT SO CAN
|
||||
C SAVE TWEAKED VERSION. SINCE MAGIC WORD MUST BE FIRST COMMAND GIVEN, ONLY
|
||||
C THING WHICH NEEDS TO BE FIXED UP IS ABB(1).
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL YESM,BLKLIN
|
||||
DIMENSION HNAME(4),ABB(150)
|
||||
COMMON /BLKCOM/ BLKLIN
|
||||
COMMON /ABBCOM/ ABB
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
|
||||
1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
|
||||
|
||||
IF(.NOT.WIZARD(0))RETURN
|
||||
BLKLIN=.FALSE.
|
||||
IF(YESM(10,0,0))CALL HOURS
|
||||
IF(YESM(11,0,0))CALL NEWHRS
|
||||
IF(.NOT.YESM(26,0,0))GOTO 10
|
||||
CALL MSPEAK(27)
|
||||
ACCEPT 1,HBEGIN
|
||||
1 FORMAT(G)
|
||||
CALL MSPEAK(28)
|
||||
ACCEPT 1,HEND
|
||||
CALL DATIME(D,T)
|
||||
HBEGIN=HBEGIN+D
|
||||
HEND=HBEGIN+HEND-1
|
||||
CALL MSPEAK(29)
|
||||
ACCEPT 2,HNAME
|
||||
2 FORMAT(4A5)
|
||||
10 TYPE 12,SHORT
|
||||
12 FORMAT(' LENGTH OF SHORT GAME (NULL TO LEAVE AT',I3,'):')
|
||||
ACCEPT 1,X
|
||||
IF(X.GT.0)SHORT=X
|
||||
CALL MSPEAK(12)
|
||||
CALL GETIN(X,Y,Y,Y)
|
||||
IF(X.NE.' ')MAGIC=X
|
||||
CALL MSPEAK(13)
|
||||
ACCEPT 1,X
|
||||
IF(X.GT.0)MAGNM=X
|
||||
TYPE 16,LATNCY
|
||||
16 FORMAT(' LATENCY FOR RESTART (NULL TO LEAVE AT',I3,'):')
|
||||
ACCEPT 1,X
|
||||
IF(X.GT.0.AND.X.LT.45)CALL MSPEAK(30)
|
||||
IF(X.GT.0)LATNCY=MAX0(45,X)
|
||||
IF(YESM(14,0,0))CALL MOTD(.TRUE.)
|
||||
SAVED=0
|
||||
SETUP=2
|
||||
ABB(1)=0
|
||||
CALL MSPEAK(15)
|
||||
BLKLIN=.TRUE.
|
||||
CALL CIAO
|
||||
END
|
||||
|
||||
|
||||
|
||||
LOGICAL FUNCTION WIZARD(DUMMY)
|
||||
|
||||
C ASK IF HE'S A WIZARD. IF HE SAYS YES, MAKE HIM PROVE IT. RETURN TRUE IF HE
|
||||
C REALLY IS A WIZARD.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL YESM
|
||||
DIMENSION HNAME(4),VAL(5)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
|
||||
1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
|
||||
|
||||
WIZARD=YESM(16,0,7)
|
||||
IF(.NOT.WIZARD)RETURN
|
||||
|
||||
C HE SAYS HE IS. FIRST STEP: DOES HE KNOW ANYTHING MAGICAL?
|
||||
|
||||
CALL MSPEAK(17)
|
||||
CALL GETIN(WORD,X,Y,Z)
|
||||
IF(WORD.NE.MAGIC)GOTO 99
|
||||
|
||||
C HE DOES. GIVE HIM A RANDOM CHALLENGE AND CHECK HIS REPLY.
|
||||
|
||||
CALL DATIME(D,T)
|
||||
T=T*2+1
|
||||
WORD='@@@@@'
|
||||
DO 15 Y=1,5
|
||||
X=79+MOD(D,5)
|
||||
D=D/5
|
||||
DO 12 Z=1,X
|
||||
12 T=MOD(T*1027,1048576)
|
||||
VAL(Y)=(T*26)/1048576+1
|
||||
15 WORD=WORD+SHIFT(VAL(Y),36-7*Y)
|
||||
IF(YESM(18,0,0))GOTO 99
|
||||
TYPE 18,WORD
|
||||
18 FORMAT(/1X,A5)
|
||||
CALL GETIN(WORD,X,Y,Z)
|
||||
CALL DATIME(D,T)
|
||||
T=(T/60)*40+(T/10)*10
|
||||
D=MAGNM
|
||||
DO 19 Y=1,5
|
||||
Z=MOD(Y,5)+1
|
||||
X=MOD(IABS(VAL(Y)-VAL(Z))*MOD(D,10)+MOD(T,10),26)+1
|
||||
T=T/10
|
||||
D=D/10
|
||||
19 WORD=WORD-SHIFT(X,36-7*Y)
|
||||
IF(WORD.NE.'@@@@@')GOTO 99
|
||||
|
||||
C BY GEORGE, HE REALLY *IS* A WIZARD!
|
||||
|
||||
CALL MSPEAK(19)
|
||||
RETURN
|
||||
|
||||
C AHA! AN IMPOSTOR!
|
||||
|
||||
99 CALL MSPEAK(20)
|
||||
WIZARD=.FALSE.
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE HOURS
|
||||
|
||||
C ANNOUNCE THE CURRENT HOURS WHEN THE CAVE IS OPEN FOR ADVENTURING. THIS INFO
|
||||
C IS STORED IN WKDAY, WKEND, AND HOLID, WHERE BIT SHIFT(1,N) IS ON IFF THE
|
||||
C HOUR FROM N:00 TO N:59 IS "PRIME TIME" (CAVE CLOSED). WKDAY IS FOR
|
||||
C WEEKDAYS, WKEND FOR WEEKENDS, HOLID FOR HOLIDAYS. NEXT HOLIDAY IS FROM
|
||||
C HBEGIN TO HEND.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION HNAME(4),VAL(5)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME
|
||||
|
||||
TYPE 1
|
||||
1 FORMAT()
|
||||
CALL HOURSX(WKDAY,'MON -',' FRI:')
|
||||
CALL HOURSX(WKEND,'SAT -',' SUN:')
|
||||
CALL HOURSX(HOLID,'HOLID','AYS: ')
|
||||
CALL DATIME(D,T)
|
||||
IF(HEND.LT.D.OR.HEND.LT.HBEGIN)RETURN
|
||||
IF(HBEGIN.GT.D)GOTO 10
|
||||
TYPE 5,HNAME
|
||||
5 FORMAT(/' TODAY IS A HOLIDAY, NAMELY ',4A5)
|
||||
RETURN
|
||||
|
||||
10 D=HBEGIN-D
|
||||
T='DAYS,'
|
||||
IF(D.EQ.1)T='DAY, '
|
||||
TYPE 15,D,T,HNAME
|
||||
15 FORMAT(/' THE NEXT HOLIDAY WILL BE IN',I3,' ',A5,' NAMELY ',4A5)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE HOURSX(H,DAY1,DAY2)
|
||||
|
||||
C USED BY HOURS (ABOVE) TO PRINT HOURS FOR EITHER WEEKDAYS OR WEEKENDS.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL FIRST
|
||||
|
||||
FIRST=.TRUE.
|
||||
FROM=-1
|
||||
IF(H.NE.0)GOTO 10
|
||||
TYPE 2,DAY1,DAY2
|
||||
2 FORMAT(10X,2A5,' OPEN ALL DAY')
|
||||
RETURN
|
||||
|
||||
10 FROM=FROM+1
|
||||
IF((H.AND.SHIFT(1,FROM)).NE.0)GOTO 10
|
||||
IF(FROM.GE.24)GOTO 20
|
||||
TILL=FROM
|
||||
14 TILL=TILL+1
|
||||
IF((H.AND.SHIFT(1,TILL)).EQ.0.AND.TILL.NE.24)GOTO 14
|
||||
IF(FIRST)TYPE 16,DAY1,DAY2,FROM,TILL
|
||||
IF(.NOT.FIRST)TYPE 18,FROM,TILL
|
||||
16 FORMAT(10X,2A5,I4,':00 TO',I3,':00')
|
||||
18 FORMAT(20X,I4,':00 TO',I3,':00')
|
||||
FIRST=.FALSE.
|
||||
FROM=TILL
|
||||
GOTO 10
|
||||
|
||||
20 IF(FIRST)TYPE 22,DAY1,DAY2
|
||||
22 FORMAT(10X,2A5,' CLOSED ALL DAY')
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE NEWHRS
|
||||
|
||||
C SET UP NEW HOURS FOR THE CAVE. SPECIFIED AS INVERSE--I.E., WHEN IS IT
|
||||
C CLOSED DUE TO PRIME TIME? SEE HOURS (ABOVE) FOR DESC OF VARIABLES.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION HNAME(4)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME
|
||||
|
||||
CALL MSPEAK(21)
|
||||
WKDAY=NEWHRX('WEEKD','AYS:')
|
||||
WKEND=NEWHRX('WEEKE','NDS:')
|
||||
HOLID=NEWHRX('HOLID','AYS:')
|
||||
CALL MSPEAK(22)
|
||||
CALL HOURS
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
INTEGER FUNCTION NEWHRX(DAY1,DAY2)
|
||||
|
||||
C INPUT PRIME TIME SPECS AND SET UP A WORD OF INTERNAL FORMAT.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
|
||||
NEWHRX=0
|
||||
TYPE 1,DAY1,DAY2
|
||||
1 FORMAT(' PRIME TIME ON ',2A5)
|
||||
10 TYPE 2
|
||||
2 FORMAT(' FROM:')
|
||||
ACCEPT 3,FROM
|
||||
3 FORMAT(G)
|
||||
IF(FROM.LT.0.OR.FROM.GE.24)RETURN
|
||||
TYPE 4
|
||||
4 FORMAT(' TILL:')
|
||||
ACCEPT 3,TILL
|
||||
TILL=TILL-1
|
||||
IF(TILL.LT.FROM.OR.TILL.GE.24)RETURN
|
||||
DO 5 I=FROM,TILL
|
||||
5 NEWHRX=(NEWHRX.OR.SHIFT(1,I))
|
||||
GOTO 10
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE MOTD(ALTER)
|
||||
|
||||
C HANDLES MESSAGE OF THE DAY. IF ALTER IS TRUE, READ A NEW MESSAGE FROM THE
|
||||
C WIZARD. ELSE PRINT THE CURRENT ONE. MESSAGE IS INITIALLY NULL.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL ALTER
|
||||
DIMENSION MSG(100)
|
||||
DATA MSG/100*-1/
|
||||
|
||||
IF(ALTER)GOTO 50
|
||||
|
||||
K=1
|
||||
10 IF(MSG(K).LT.0)RETURN
|
||||
TYPE 20,(MSG(I),I=K+1,MSG(K)-1)
|
||||
20 FORMAT(' ',14A5)
|
||||
K=MSG(K)
|
||||
GOTO 10
|
||||
|
||||
50 M=1
|
||||
CALL MSPEAK(23)
|
||||
55 ACCEPT 56,(MSG(I),I=M+1,M+14),K
|
||||
56 FORMAT(15A5)
|
||||
IF(K.EQ.' ')GOTO 60
|
||||
CALL MSPEAK(24)
|
||||
GOTO 55
|
||||
60 DO 62 I=1,14
|
||||
K=M+15-I
|
||||
IF(MSG(K).NE.' ')GOTO 65
|
||||
62 CONTINUE
|
||||
GOTO 90
|
||||
65 MSG(M)=K+1
|
||||
M=K+1
|
||||
IF(M+14.LT.100)GOTO 55
|
||||
CALL MSPEAK(25)
|
||||
90 MSG(M)=-1
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE POOF
|
||||
|
||||
C AS PART OF DATABASE INITIALISATION, WE CALL POOF TO SET UP SOME DUMMY
|
||||
C PRIME-TIME SPECS, MAGIC WORDS, ETC.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION HNAME(4)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
|
||||
1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
|
||||
|
||||
WKDAY="00777400
|
||||
WKEND=0
|
||||
HOLID=0
|
||||
HBEGIN=0
|
||||
HEND=-1
|
||||
SHORT=30
|
||||
MAGIC='DWARF'
|
||||
MAGNM=11111
|
||||
LATNCY=90
|
||||
RETURN
|
||||
END
|
||||
C UTILITY ROUTINES (SHIFT, RAN, DATIME, CIAO, BUG)
|
||||
|
||||
|
||||
INTEGER FUNCTION SHIFT(VAL,DIST)
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
|
||||
C RETURN VAL LEFT-SHIFTED (LOGICALLY) DIST BITS (RIGHT-SHIFT IF DIST<0).
|
||||
|
||||
SHIFT=VAL
|
||||
IF(DIST)10,20,30
|
||||
10 IDIST=-DIST
|
||||
DO 11 I=1,IDIST
|
||||
J=0
|
||||
IF(SHIFT.LT.0)J="200000000000
|
||||
11 SHIFT=((SHIFT.AND."377777777777)/2)+J
|
||||
20 RETURN
|
||||
30 DO 31 I=1,DIST
|
||||
J=0
|
||||
IF((SHIFT.AND."200000000000).NE.0)J="400000000000
|
||||
31 SHIFT=(SHIFT.AND."177777777777)*2+J
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
INTEGER FUNCTION RAN(RANGE)
|
||||
|
||||
C SINCE THE RAN FUNCTION IN LIB40 SEEMS TO BE A REAL LOSE, WE'LL USE ONE OF
|
||||
C OUR OWN. IT'S BEEN RUN THROUGH MANY OF THE TESTS IN KNUTH VOL. 2 AND
|
||||
C SEEMS TO BE QUITE RELIABLE. RAN RETURNS A VALUE UNIFORMLY SELECTED
|
||||
C BETWEEN 0 AND RANGE-1. NOTE RESEMBLANCE TO ALG USED IN WIZARD.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DATA R/0/
|
||||
|
||||
D=1
|
||||
IF(R.NE.0)GOTO 1
|
||||
CALL DATIME(D,T)
|
||||
R=18*T+5
|
||||
D=1000+MOD(D,1000)
|
||||
1 DO 2 T=1,D
|
||||
2 R=MOD(R*1021,1048576)
|
||||
RAN=(RANGE*R)/1048576
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE DATIME(D,T)
|
||||
|
||||
C RETURN THE DATE AND TIME IN D AND T. D IS NUMBER OF DAYS SINCE 01-JAN-77,
|
||||
C T IS MINUTES PAST MIDNIGHT. THIS IS HARDER THAN IT SOUNDS, BECAUSE THE
|
||||
C FINAGLED DEC FUNCTIONS RETURN THE VALUES ONLY AS ASCII STRINGS!
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION DAT(2),MONTHS(12),HATH(12)
|
||||
DATA MONTHS/'-JAN-','-FEB-','-MAR-','-APR-','-MAY-','-JUN-',
|
||||
1 '-JUL-','-AUG-','-SEP-','-OCT-','-NOV-','-DEC-'/
|
||||
DATA HATH/31,28,31,30,31,30,31,31,30,31,30,31/
|
||||
|
||||
C FUNCTION I2 TAKES 2-DIGIT ASCII AND YIELDS DECIMAL VALUE.
|
||||
|
||||
I2(X)=(SHIFT(X,-29).AND.15)*10+(SHIFT(X,-22).AND.15)
|
||||
|
||||
CALL DATE(DAT)
|
||||
CALL TIME(TIM)
|
||||
|
||||
YEAR=I2(SHIFT(DAT(2),14))-77
|
||||
D=I2(DAT(1))-1
|
||||
X=((SHIFT(DAT(1),14).OR.SHIFT(DAT(2),-21)).AND..NOT."1004020001)
|
||||
1 .OR.'-@@@-'
|
||||
C ABOVE FUNNY EXPRESSION GUARANTEES (A) UPPER-CASE, AND (B) BOTTOM BIT OKAY.
|
||||
X='-JAN-'
|
||||
DO 1 MON=1,12
|
||||
IF(X.EQ.MONTHS(MON))GOTO 2
|
||||
1 D=D+HATH(MON)
|
||||
CALL BUG(28)
|
||||
|
||||
2 D=D+YEAR*365+YEAR/4
|
||||
IF(MOD(YEAR,4).EQ.3.AND.MON.GT.2)D=D+1
|
||||
T=I2(TIM)*60+I2(SHIFT(TIM,21))
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE CIAO
|
||||
|
||||
C EXITS, AFTER ISSUING REMINDER TO SAVE NEW CORE IMAGE. USED WHEN SUSPENDING
|
||||
C AND WHEN CREATING NEW VERSION VIA MAGIC MODE. ON SOME SYSTEMS, THE CORE
|
||||
C IMAGE IS LOST ONCE THE PROGRAM EXITS. IF SO, SET K=31 INSTEAD OF 32.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DATA K/32/
|
||||
|
||||
CALL MSPEAK(K)
|
||||
IF(K.EQ.31)CALL GETIN(A,B,C,D)
|
||||
STOP
|
||||
END
|
||||
|
||||
|
||||
|
||||
SUBROUTINE BUG(NUM)
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
|
||||
C THE FOLLOWING CONDITIONS ARE CURRENTLY CONSIDERED FATAL BUGS. NUMBERS < 20
|
||||
C ARE DETECTED WHILE READING THE DATABASE; THE OTHERS OCCUR AT "RUN TIME".
|
||||
C 0 MESSAGE LINE > 70 CHARACTERS
|
||||
C 1 NULL LINE IN MESSAGE
|
||||
C 2 TOO MANY WORDS OF MESSAGES
|
||||
C 3 TOO MANY TRAVEL OPTIONS
|
||||
C 4 TOO MANY VOCABULARY WORDS
|
||||
C 5 REQUIRED VOCABULARY WORD NOT FOUND
|
||||
C 6 TOO MANY RTEXT OR MTEXT MESSAGES
|
||||
C 7 TOO MANY HINTS
|
||||
C 8 LOCATION HAS COND BIT BEING SET TWICE
|
||||
C 9 INVALID SECTION NUMBER IN DATABASE
|
||||
C 20 SPECIAL TRAVEL (500>L>300) EXCEEDS GOTO LIST
|
||||
C 21 RAN OFF END OF VOCABULARY TABLE
|
||||
C 22 VOCABULARY TYPE (N/1000) NOT BETWEEN 0 AND 3
|
||||
C 23 INTRANSITIVE ACTION VERB EXCEEDS GOTO LIST
|
||||
C 24 TRANSITIVE ACTION VERB EXCEEDS GOTO LIST
|
||||
C 25 CONDITIONAL TRAVEL ENTRY WITH NO ALTERNATIVE
|
||||
C 26 LOCATION HAS NO TRAVEL ENTRIES
|
||||
C 27 HINT NUMBER EXCEEDS GOTO LIST
|
||||
C 28 INVALID MONTH RETURNED BY DATE FUNCTION
|
||||
|
||||
TYPE 1, NUM
|
||||
1 FORMAT (' FATAL ERROR, SEE SOURCE CODE FOR INTERPRETATION.'/
|
||||
1 ' PROBABLY CAUSE: ERRONEOUS INFO IN DATABASE.'/
|
||||
2 ' ERROR CODE =',I2/)
|
||||
STOP
|
||||
END
|
||||
2086
src/games/adv3sr.1
Normal file
2086
src/games/adv3sr.1
Normal file
File diff suppressed because it is too large
Load Diff
2212
src/games/adv4db.2
Normal file
2212
src/games/adv4db.2
Normal file
File diff suppressed because it is too large
Load Diff
2576
src/games/adv4ma.3
Normal file
2576
src/games/adv4ma.3
Normal file
File diff suppressed because it is too large
Load Diff
970
src/games/adv4su.16
Normal file
970
src/games/adv4su.16
Normal file
@@ -0,0 +1,970 @@
|
||||
SUBROUTINE SPEAK(N)
|
||||
C
|
||||
C PRINT THE MESSAGE WHICH STARTS AT LINES(N). PRECEDE IT WITH A BLANK LINE
|
||||
C UNLESS BLKLIN IS FALSE.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL BLKLIN
|
||||
COMMON /TXTCOM/ RTEXT,LINES
|
||||
COMMON /BLKCOM/ BLKLIN
|
||||
DIMENSION RTEXT (250),LINES(15000),LINE(18)
|
||||
C
|
||||
IF(N.EQ.0)RETURN
|
||||
C IF(LINES(N+1).EQ.XOR('>$<','?L.0'))RETURN
|
||||
IF(LINES(N+1).EQ.('>$<'.XOR.'?L.0'))RETURN
|
||||
IF(BLKLIN)TYPE 2
|
||||
K=N
|
||||
1 L=IABS(LINES(K))-1
|
||||
J=K+1
|
||||
UPLIM=L-K
|
||||
DO 3 I=1,UPLIM
|
||||
C LINE(I)=XOR(LINES(J),'?L.0')
|
||||
LINE(I)=LINES(J).XOR.'?L.0'
|
||||
3 J=J+1
|
||||
WRITE (5,2)(LINE(I),I=1,UPLIM)
|
||||
2 FORMAT(' ',18A4)
|
||||
K=L+1
|
||||
IF(LINES(K).GE.0)GOTO 1
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE PSPEAK(MSG,SKIP)
|
||||
C
|
||||
C FIND THE SKIP+1ST MESSAGE FROM MSG AND PRINT IT. MSG SHOULD BE THE INDEX OF
|
||||
C THE INVENTORY MESSAGE FOR OBJECT. (INVEN+N+1 MESSAGE IS PROP=N MESSAGE).
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /TXTCOM/ RTEXT,LINES
|
||||
COMMON /PTXCOM/ PTEXT
|
||||
DIMENSION RTEXT(250),LINES(15000),PTEXT(100)
|
||||
C
|
||||
M=PTEXT(MSG)
|
||||
IF(SKIP.LT.0)GOTO 9
|
||||
SKIPI = SKIP + 1
|
||||
DO 3 I=1,SKIPI
|
||||
1 M=IABS(LINES(M))
|
||||
IF(LINES(M).GE.0)GOTO 1
|
||||
3 CONTINUE
|
||||
9 CALL SPEAK(M)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE RSPEAK(I)
|
||||
C
|
||||
C PRINT THE I-TH "RANDOM" MESSAGE (SECTION 6 OF DATABASE).
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /TXTCOM/ RTEXT
|
||||
DIMENSION RTEXT(250)
|
||||
C
|
||||
IF(I.NE.0)CALL SPEAK(RTEXT(I))
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE MSPEAK(I)
|
||||
C
|
||||
C PRINT THE I-TH "MAGIC" MESSAGE (SECTION 12 OF THE DATABASE).
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /MTXCOM/ MTEXT
|
||||
DIMENSION MTEXT(35)
|
||||
C
|
||||
IF(I.NE.0)CALL SPEAK(MTEXT(I))
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GETIN(WORD1,WORD1X,WORD2,WORD2X)
|
||||
|
||||
C GET A COMMAND FROM THE ADVENTURER. SNARF OUT THE FIRST WORD, PAD IT WITH
|
||||
C BLANKS, AND RETURN IT IN WORD1. CHARS 6 THRU 10 ARE RETURNED IN WORD1X, IN
|
||||
C CASE WE NEED TO PRINT OUT THE WHOLE WORD IN AN ERROR MESSAGE. ANY NUMBER OF
|
||||
C BLANKS MAY FOLLOW THE WORD. IF A SECOND WORD APPEARS, IT IS RETURNED IN
|
||||
C WORD2 (CHARS 6 THRU 10 IN WORD2X), ELSE WORD2 IS SET TO ZERO.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL BLKLIN
|
||||
COMMON /BLKCOM/ BLKLIN
|
||||
DIMENSION A(5),MASKS(6)
|
||||
DATA MASKS/"4000000000,"20000000,"100000,"400,"2,0/
|
||||
1 ,BLANKS/' '/
|
||||
IF(BLKLIN)TYPE 1
|
||||
1 FORMAT()
|
||||
2 ACCEPT 3,(A(I),I=1,4)
|
||||
3 FORMAT(4A5)
|
||||
J=0
|
||||
DO 9 I=1,4
|
||||
IF(A(I).NE.BLANKS)J=1
|
||||
9 A(I)=A(I).AND.(SHIFT((A(I).AND.'@@@@@'),-1).XOR.-1)
|
||||
IF(BLKLIN.AND.J.EQ.0)GOTO 2
|
||||
|
||||
SECOND=0
|
||||
WORD1=A(1)
|
||||
WORD1X=A(2)
|
||||
WORD2=0
|
||||
|
||||
DO 10 J=1,4
|
||||
DO 10 K=1,5
|
||||
MSK="774000000000
|
||||
IF(K.NE.1)MSK="177*MASKS(K)
|
||||
IF(((A(J).XOR.BLANKS).AND.MSK).EQ.0)GOTO 15
|
||||
IF(SECOND.EQ.0)GOTO 10
|
||||
MSK=-MASKS(6-K)
|
||||
WORD2=(SHIFT(A(J),7*(K-1)).AND.MSK)
|
||||
1 +(SHIFT(A(J+1),7*(K-6)).AND.(-2-MSK))
|
||||
WORD2X=(SHIFT(A(J+1),7*(K-1)).AND.MSK)
|
||||
1 +(SHIFT(A(J+2),7*(K-6)).AND.(-2-MSK))
|
||||
RETURN
|
||||
|
||||
15 IF(SECOND.EQ.1)GOTO 10
|
||||
SECOND=1
|
||||
IF(J.EQ.1)WORD1=(WORD1.AND.-MASKS(K))
|
||||
1 .OR.(BLANKS.AND.(-MASKS(K).XOR.-1))
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
LOGICAL FUNCTION YES(X,Y,Z)
|
||||
C
|
||||
C CALL YESX (BELOW) WITH MESSAGES FROM SECTION 6.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
EXTERNAL RSPEAK
|
||||
LOGICAL YESX
|
||||
C
|
||||
YES=YESX(X,Y,Z,RSPEAK)
|
||||
RETURN
|
||||
END
|
||||
|
||||
LOGICAL FUNCTION YESM(X,Y,Z)
|
||||
C
|
||||
C CALL YESX (BELOW) WITH MESSAGES FROM SECTION 12.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
EXTERNAL MSPEAK
|
||||
LOGICAL YESX
|
||||
C
|
||||
YESM=YESX(X,Y,Z,MSPEAK)
|
||||
RETURN
|
||||
END
|
||||
|
||||
LOGICAL FUNCTION YESX(X,Y,Z,SPK)
|
||||
C
|
||||
C PRINT MESSAGE X, WAIT FOR YES/NO ANSWER. IF YES, PRINT Y AND LEAVE YEA
|
||||
C TRUE; IF NO, PRINT Z AND LEAVE YEA FALSE. SPK IS EITHER RSPEAK OR MSPEAK.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
C
|
||||
1 IF(X.NE.0)CALL SPK(X)
|
||||
CALL GETIN(REPLY,JUNK1,JUNK2,JUNK3)
|
||||
C IF(REPLY.EQ.CODE('YES').OR.REPLY.EQ.CODE('Y'))GOTO 10
|
||||
IF(REPLY.EQ.'YES'.OR.REPLY.EQ.'Y')GOTO 10
|
||||
C IF(REPLY.EQ.CODE('NO').OR.REPLY.EQ.CODE('N'))GOTO 20
|
||||
IF(REPLY.EQ.'NO'.OR.REPLY.EQ.'N')GOTO 20
|
||||
TYPE 9
|
||||
9 FORMAT(/' PLEASE ANSWER THE QUESTION.')
|
||||
GOTO 1
|
||||
10 YESX=.TRUE.
|
||||
IF(Y.NE.0)CALL SPK(Y)
|
||||
RETURN
|
||||
20 YESX=.FALSE.
|
||||
IF(Z.NE.0)CALL SPK(Z)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE A5TOA1(A,B,C,CHARS,LENG)
|
||||
|
||||
C A AND B CONTAIN A 1- TO 9-CHARACTER WORD IN A5 FORMAT, C CONTAINS ANOTHER
|
||||
C WORD AND/OR PUNCTUATION. THEY ARE UNPACKED TO ONE CHARACTER PER WORD IN THE
|
||||
C ARRAY "CHARS", WITH EXACTLY ONE BLANK BETWEEN B AND C (OR NONE, IF C >= 0).
|
||||
C THE INDEX OF THE LAST NON-BLANK CHAR IN CHARS IS RETURNED IN LENG.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION CHARS(20),WORDS(3)
|
||||
DATA MASK,BLANK/"774000000000,' '/
|
||||
|
||||
WORDS(1)=A
|
||||
WORDS(2)=B
|
||||
WORDS(3)=C
|
||||
POSN=1
|
||||
DO 1 WORD=1,3
|
||||
IF(WORD.EQ.2.AND.POSN.NE.6)GOTO 1
|
||||
IF(WORD.EQ.3.AND.C.LT.0)POSN=POSN+1
|
||||
DO 2 CH=1,5
|
||||
CHARS(POSN)=(WORDS(WORD).AND.MASK)+(BLANK-(BLANK.AND.MASK))
|
||||
IF(CHARS(POSN).EQ.BLANK)GOTO 1
|
||||
LENG=POSN
|
||||
WORDS(WORD)=SHIFT(WORDS(WORD),7)
|
||||
2 POSN=POSN+1
|
||||
1 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
INTEGER FUNCTION VOCAB(ID,INIT)
|
||||
C
|
||||
C LOOK UP ID IN THE VOCABULARY (ATAB) AND RETURN ITS "DEFINITION" (KTAB), OR
|
||||
C -1 IF NOT FOUND. IF INIT IS POSITIVE, THIS IS AN INITIALIZATION CALL SETTING
|
||||
C UP A KEYWORD VARIABLE, AND NOT FINDING IT CONSTITUTES A BUG. IT ALSO MEANS
|
||||
C THAT ONLY KTAB VALUES WHICH TAKEN OVER 1000 EQUAL INIT MAY BE CONSIDERED.
|
||||
C (THUS "STEPS", WHICH IS A MOTION VERB AS WELL AS AN OBJECT, MAY BE LOCATED
|
||||
C AS AN OBJECT.) AND IT ALSO MEANS THE KTAB VALUE IS TAKEN MOD 1000.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
|
||||
DIMENSION KTAB(400),ATAB(400)
|
||||
C
|
||||
C HASH=XOR(ID,'PHRO')
|
||||
HASH=ID.XOR.'PHRO'
|
||||
DO 1 I=1,TABSIZ
|
||||
IF(KTAB(I).EQ.-1)GOTO 2
|
||||
IF(INIT.GE.0.AND.KTAB(I)/1000.NE.INIT)GOTO 1
|
||||
IF(ATAB(I).EQ.HASH)GOTO 3
|
||||
1 CONTINUE
|
||||
CALL BUG(21)
|
||||
C
|
||||
2 VOCAB=-1
|
||||
IF(INIT.LT.0)RETURN
|
||||
CALL BUG(5)
|
||||
C
|
||||
3 VOCAB=KTAB(I)
|
||||
IF(INIT.GE.0)VOCAB=MOD(VOCAB,1000)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE DSTROY(OBJECT)
|
||||
C
|
||||
C PERMANENTLY ELIMINATE "OBJECT" BY MOVING TO A NON-EXISTENT LOCATION.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
C
|
||||
CALL MOVE(OBJECT,0)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE JUGGLE(OBJECT)
|
||||
C JUGGLE AN OBJECT BY PICKING IT UP AND PUTTING IT DOWN AGAIN, THE PURPOSE
|
||||
C BEING TO GET THE OBJECT TO THE FRONT OF THE CHAIN OF THINGS AT ITS LOC.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
DIMENSION ATLOC(200),LINK(200),PLACE(100),FIXED(100)
|
||||
C
|
||||
I=PLACE(OBJECT)
|
||||
J=FIXED(OBJECT)
|
||||
CALL MOVE(OBJECT,I)
|
||||
CALL MOVE(OBJECT+100,J)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE MOVE(OBJECT,WHERE)
|
||||
C
|
||||
C PLACE ANY OBJECT ANYWHERE BY PICKING IT UP AND DROPPING IT. MAY ALREADY BE
|
||||
C TOTING, IN WHICH CASE THE CARRY IS A NO-OP. MUSTN'T PICK UP OBJECTS WHICH
|
||||
C ARE NOT AT ANY LOC, SINCE CARRY WANTS TO REMOVE OBJECTS FROM ATLOC CHAINS.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
DIMENSION ATLOC(200),LINK(200),PLACE(100),FIXED(100)
|
||||
C
|
||||
IF(OBJECT.GT.100)GOTO 1
|
||||
FROM=PLACE(OBJECT)
|
||||
GOTO 2
|
||||
1 FROM=FIXED(OBJECT-100)
|
||||
2 IF(FROM.GT.0.AND.FROM.LE.300)CALL CARRY(OBJECT,FROM)
|
||||
CALL DROP(OBJECT,WHERE)
|
||||
RETURN
|
||||
END
|
||||
|
||||
INTEGER FUNCTION PUT(OBJECT,WHERE,PVAL)
|
||||
C
|
||||
C PUT IS THE SAME AS MOVE, EXCEPT IT RETURNS A VALUE USED TO SET UP THE
|
||||
C NEGATED PROP VALUES FOR THE REPOSITORY OBJECTS.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
C
|
||||
CALL MOVE(OBJECT,WHERE)
|
||||
PUT=(-1)-PVAL
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE CARRY(OBJECT,WHERE)
|
||||
C
|
||||
C START TOTING AN OBJECT, REMOVING IT FROM THE LIST OF THINGS AT ITS FORMER
|
||||
C LOCATION. INCR HOLDNG UNLESS IT WAS ALREADY BEING TOTED. IF OBJECT>100
|
||||
C (MOVING "FIXED" SECOND LOC), DON'T CHANGE PLACE OR HOLDNG.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
DIMENSION ATLOC(200),LINK(200),PLACE(100),FIXED(100)
|
||||
C
|
||||
IF(OBJECT.GT.100)GOTO 5
|
||||
IF(PLACE(OBJECT).EQ.-1)RETURN
|
||||
PLACE(OBJECT)=-1
|
||||
HOLDNG=HOLDNG+1
|
||||
5 IF(ATLOC(WHERE).NE.OBJECT)GOTO 6
|
||||
ATLOC(WHERE)=LINK(OBJECT)
|
||||
RETURN
|
||||
6 TEMP=ATLOC(WHERE)
|
||||
7 IF(LINK(TEMP).EQ.OBJECT)GOTO 8
|
||||
TEMP=LINK(TEMP)
|
||||
GOTO 7
|
||||
8 LINK(TEMP)=LINK(OBJECT)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE DROP(OBJECT,WHERE)
|
||||
C
|
||||
C PLACE AN OBJECT AT A GIVEN LOC, PREFIXING IT ONTO THE ATLOC LIST. DECR
|
||||
C HOLDING IF THE OBJECT WAS BEING TOTED.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
DIMENSION ATLOC(200),LINK(200),PLACE(100),FIXED(100)
|
||||
C
|
||||
IF(OBJECT.GT.100)GOTO 1
|
||||
IF(PLACE(OBJECT).EQ.-1)HOLDNG=HOLDNG-1
|
||||
PLACE(OBJECT)=WHERE
|
||||
GOTO 2
|
||||
1 FIXED(OBJECT-100)=WHERE
|
||||
2 IF(WHERE.LE.0)RETURN
|
||||
LINK(OBJECT)=ATLOC(WHERE)
|
||||
ATLOC(WHERE)=OBJECT
|
||||
RETURN
|
||||
END
|
||||
|
||||
LOGICAL FUNCTION START(DUMMY)
|
||||
C
|
||||
C CHECK TO SEE IF THIS IS "PRIME TIME". IF SO, ONLY WIZARDS MAY PLAY, THOUGH
|
||||
C OTHERS MAY BE ALLOWED A SHORT GAME FOR DEMONSTRATION PURPOSES. IF SETUP<0,
|
||||
C WE'RE CONTINUING FROM A SAVED GAME, SO CHECK FOR SUITABLE LATENCY. RETURN
|
||||
C TRUE IF THIS IS A DEMO GAME (VALUE IS IGNORED FOR RESTARTS).
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL PTIME,SOON,YESM,WIZARD
|
||||
DIMENSION HNAME(4)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
|
||||
1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
|
||||
C
|
||||
C FIRST FIND OUT WHETHER IT IS PRIME TIME (SAVE IN PTIME) AND, IF RESTARTING,
|
||||
C WHETHER IT'S TOO SOON (SAVE IN SOON). PRIME-TIME SPECS ARE IN WKDAY, WKEND,
|
||||
C AND HOLID; SEE MAINT ROUTINE FOR DETAILS. LATNCY IS REQUIRED DELAY BEFORE
|
||||
C RESTARTING. WIZARDS MAY CUT THIS TO A THIRD.
|
||||
C
|
||||
CALL DATIME(D,T)
|
||||
PRIMTM=WKDAY
|
||||
IF(MOD(D,7).LE.1)PRIMTM=WKEND
|
||||
IF(D.GE.HBEGIN.AND.D.LE.HEND)PRIMTM=HOLID
|
||||
C PTIME=AND(PRIMTM,SHIFT(1,T/60)).NE.0
|
||||
PTIME=(PRIMTM.AND.SHIFT(1,T/60)).NE.0
|
||||
SOON=.FALSE.
|
||||
IF(SETUP.GE.0)GOTO 20
|
||||
DELAY=IABS((D-SAVED)*1440+(T-SAVET))
|
||||
IF(DELAY.GE.LATNCY)GOTO 20
|
||||
TYPE 10,DELAY
|
||||
10 FORMAT(' THIS ADVENTURE WAS SUSPENDED A MERE',I3,' MINUTES AGO.')
|
||||
SOON=.TRUE.
|
||||
IF(DELAY.GE.LATNCY/3)GOTO 20
|
||||
CALL MSPEAK(2)
|
||||
STOP
|
||||
C
|
||||
C IF NEITHER TOO SOON NOR PRIME TIME, NO PROBLEM. ELSE SPECIFY WHAT'S WRONG.
|
||||
C
|
||||
20 START=.FALSE.
|
||||
IF(SOON)GOTO 30
|
||||
IF(PTIME)GOTO 25
|
||||
22 SAVED=-1
|
||||
RETURN
|
||||
C
|
||||
C COME HERE IF NOT RESTARTING TOO SOON (MAYBE NOT RESTARTING AT ALL), BUT IT'S
|
||||
C PRIME TIME. GIVE OUR HOURS AND SEE IF HE'S A WIZARD. IF NOT, THEN CAN'T
|
||||
C RESTART, BUT IF JUST BEGINNING THEN WE CAN OFFER A SHORT GAME.
|
||||
C
|
||||
25 CALL MSPEAK(3)
|
||||
CALL HOURS
|
||||
CALL MSPEAK(4)
|
||||
IF(WIZARD(0))GOTO 22
|
||||
IF(SETUP.LT.0)GOTO 33
|
||||
START=YESM(5,7,7)
|
||||
IF(START)GOTO 22
|
||||
STOP
|
||||
C
|
||||
C COME HERE IF RESTARTING TOO SOON. IF HE'S A WIZARD, LET HIM GO (AND NOTE
|
||||
C THAT IT THEN DOESN'T MATTER WHETHER IT'S PRIME TIME). ELSE, TOUGH BEANS.
|
||||
C
|
||||
30 CALL MSPEAK(8)
|
||||
IF(WIZARD(0))GOTO 22
|
||||
33 CALL MSPEAK(9)
|
||||
STOP
|
||||
END
|
||||
|
||||
SUBROUTINE MAINT
|
||||
C
|
||||
C SOMEONE SAID THE MAGIC WORD TO INVOKE MAINTENANCE MODE. MAKE SURE HE
|
||||
C IS A
|
||||
C WIZARD. IF SO, LET HIM TWEAK ALL SORTS OF RANDOM THINGS, THEN EXIT
|
||||
C SO HE CAN
|
||||
C SAVE TWEAKED VERSION. SINCE MAGIC WORD MUST BE FIRST COMMAND GIVEN,
|
||||
C THE ONLY THING WHICH NEEDS TO BE FIXED UP IS ABB(1).
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL YESM,BLKLIN,WIZARD
|
||||
DIMENSION HNAME(4),ABB(200)
|
||||
COMMON /BLKCOM/ BLKLIN
|
||||
COMMON /ABBCOM/ ABB
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
|
||||
1SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
|
||||
COMMON /SAVCOM/ SEGOFF,ABBNUM,ATTACK,CLOCK1,CLOCK2,CLOSED,CLOSNG,
|
||||
1DETAIL,DFLAG,DKILL,DLOC,DSEEN,DTOTAL,GAVEUP,HINT,HINTED,
|
||||
2IWEST,KNFLOC,LIMIT,LMWARN,LOC,NUMDIE,PANIC,PROP,STICK,
|
||||
3TALLY,TALLY2,TURNS,WZDARK,XXD,XXT,ACCT,HINTLC,HINTS,
|
||||
4FILLER
|
||||
C
|
||||
DIMENSION HINTLC(20),HINTED(20),HINTS(20,4),PROP(100)
|
||||
DIMENSION DSEEN(12),DLOC(12),ODLOC(12)
|
||||
LOGICAL DSEEN
|
||||
DIMENSION FILLER(20)
|
||||
C
|
||||
C
|
||||
IF(.NOT.WIZARD(0))RETURN
|
||||
BLKLIN=.FALSE.
|
||||
IF(YESM(10,0,0))CALL HOURS
|
||||
IF(YESM(11,0,0))CALL NEWHRS
|
||||
IF(.NOT.YESM(26,0,0))GOTO 10
|
||||
CALL MSPEAK(27)
|
||||
READ (5,1)HBEGIN
|
||||
1 FORMAT(I7)
|
||||
CALL MSPEAK(28)
|
||||
READ (5,1)HEND
|
||||
CALL DATIME(D,T)
|
||||
HBEGIN=HBEGIN+D
|
||||
HEND=HBEGIN+HEND-1
|
||||
CALL MSPEAK(29)
|
||||
READ (5,2)HNAME
|
||||
2 FORMAT(5A4)
|
||||
10 WRITE (5,12)SHORT
|
||||
12 FORMAT(' LENGTH OF SHORT GAME (NULL TO LEAVE AT',I3,'):')
|
||||
READ(5,1) X
|
||||
IF(X.GT.0)SHORT=X
|
||||
CALL MSPEAK(12)
|
||||
CALL GETIN(X,Y,Y,Y)
|
||||
C IF(X.NE.CODE(' '))MAGIC=X
|
||||
IF(X.NE.' ')MAGIC=X
|
||||
CALL MSPEAK(13)
|
||||
READ(5,1) X
|
||||
IF(X.GT.0)MAGNM=X
|
||||
WRITE (5,16)LATNCY
|
||||
16 FORMAT(' LATENCY FOR RESTART (NULL TO LEAVE AT',I3,'):')
|
||||
READ(5,1) X
|
||||
IF(X.GT.0.AND.X.LT.45)CALL MSPEAK(30)
|
||||
C THE FOLLOWING CHANGE SHORT CIRCUITS THE MINIMUM LATENCY TIME
|
||||
IF(X.GE.0)LATNCY=X
|
||||
C GET A NEW ACCOUNT NUMBER FOR KEEPING STATISTICS (IF WANTED)
|
||||
WRITE (5,20) ACCT
|
||||
20 FORMAT (' ACCOUNT NUMBER FOR STATS (NULL TO LEAVE ',I9,') :')
|
||||
READ (5,21) X
|
||||
21 FORMAT (I9)
|
||||
IF (X.GT.0) ACCT = X
|
||||
IF(YESM(14,0,0))CALL MOTD(.TRUE.)
|
||||
SAVED=0
|
||||
SETUP=2
|
||||
ABB(1)=0
|
||||
CALL MSPEAK(15)
|
||||
BLKLIN=.TRUE.
|
||||
CALL CIAO(.FALSE.)
|
||||
RETURN
|
||||
END
|
||||
|
||||
LOGICAL FUNCTION WIZARD(DUMMY)
|
||||
C
|
||||
C ASK IF HE'S A WIZARD. IF HE SAYS YES, MAKE HIM PROVE IT. RETURN TRUE IF HE
|
||||
C REALLY IS A WIZARD.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL YESM
|
||||
DIMENSION HNAME(4),VAL(5)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
|
||||
1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
|
||||
C
|
||||
WIZARD=YESM(16,0,7)
|
||||
IF(.NOT.WIZARD)RETURN
|
||||
C
|
||||
C HE SAYS HE IS. FIRST STEP: DOES HE KNOW ANYTHING MAGICAL?
|
||||
C
|
||||
CALL MSPEAK(17)
|
||||
CALL GETIN(WORD,X,Y,Z)
|
||||
IF(WORD.NE.MAGIC)GOTO 99
|
||||
GOTO 20
|
||||
C
|
||||
C HE DOES. GIVE HIM A RANDOM CHALLENGE AND CHECK HIS REPLY.
|
||||
C
|
||||
CALL DATIME(D,T)
|
||||
T=T*2+1
|
||||
WORD='@@@@@'
|
||||
DO 15 Y=1,5
|
||||
X=79+MOD(D,5)
|
||||
D=D/5
|
||||
DO 12 Z=1,X
|
||||
12 T=MOD(T*1027,1048576)
|
||||
VAL(Y)=(T*26)/1048576+1
|
||||
15 WORD=WORD+SHIFT(VAL(Y),36-7*Y)
|
||||
IF(YESM(18,0,0))GOTO 99
|
||||
TYPE 18,WORD
|
||||
18 FORMAT(/1X,A5)
|
||||
CALL GETIN(WORD,X,Y,Z)
|
||||
CALL DATIME(D,T)
|
||||
T=(T/60)*40+(T/10)*10
|
||||
D=MAGNM
|
||||
DO 19 Y=1,5
|
||||
Z=MOD(Y,5)+1
|
||||
X=MOD(IABS(VAL(Y)-VAL(Z))*MOD(D,10)+MOD(T,10),26)+1
|
||||
T=T/10
|
||||
D=D/10
|
||||
19 WORD=WORD-SHIFT(X,36-7*Y)
|
||||
IF(WORD.NE.'@@@@@')GOTO 99
|
||||
C
|
||||
C BY GEORGE, HE REALLY *IS* A WIZARD!
|
||||
C
|
||||
20 CALL MSPEAK(19)
|
||||
RETURN
|
||||
C
|
||||
C AHA! AN IMPOSTER!
|
||||
C
|
||||
99 CALL MSPEAK(20)
|
||||
WIZARD=.FALSE.
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE HOURS
|
||||
C
|
||||
C ANNOUNCE THE CURRENT HOURS WHEN THE CAVE IS OPEN FOR ADVENTURING. THIS INFO
|
||||
C IS STORED IN WKDAY, WKEND, AND HOLID, WHERE BIT SHIFT(1,N) IS ON IFF THE
|
||||
C HOUR FROM N:00 TO N:59 IS "PRIME TIME" (CAVE CLOSED). WKDAY IS FOR
|
||||
C WEEKDAYS, WKEND FOR WEEKENDS, HOLID FOR HOLIDAYS. NEXT HOLIDAY IS FROM
|
||||
C HBEGIN TO HEND.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION HNAME(4),VAL(5)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME
|
||||
C
|
||||
WRITE (5,1)
|
||||
1 FORMAT()
|
||||
CALL HOURSX(WKDAY,'MON ','- FR','I:')
|
||||
CALL HOURSX(WKEND,'SAT ','- SU','N:')
|
||||
CALL HOURSX(HOLID,'HOLI','DAYS',':')
|
||||
CALL DATIME(D,T)
|
||||
IF(HEND.LT.D.OR.HEND.LT.HBEGIN)RETURN
|
||||
IF(HBEGIN.GT.D)GOTO 10
|
||||
WRITE (5,5)HNAME
|
||||
LEN = HEND - D
|
||||
WRITE (5,7) LEN
|
||||
5 FORMAT(/' TODAY IS A HOLIDAY, NAMELY ',4A4)
|
||||
7 FORMAT (/' IT WILL LAST ANOTHER',I3,' DAYS')
|
||||
RETURN
|
||||
C
|
||||
10 D=HBEGIN-D
|
||||
IF(D.EQ.1)GOTO 12
|
||||
WRITE(5,20)D,HNAME
|
||||
GOTO 50
|
||||
12 WRITE(5,25)D,HNAME
|
||||
20 FORMAT(/' THE NEXT HOLIDAY WILL BE IN',I3,' DAYS, NAMELY ',5A4)
|
||||
25 FORMAT(/' THE NEXT HOLIDAY WILL BE IN',I3,' DAY, NAMELY ',5A4)
|
||||
C
|
||||
50 LEN = HEND - HBEGIN + 1
|
||||
IF (LEN .LT. 1) RETURN
|
||||
IF (LEN .EQ. 1) GOTO 55
|
||||
WRITE (5,75) LEN
|
||||
RETURN
|
||||
55 WRITE (5,80) LEN
|
||||
RETURN
|
||||
75 FORMAT (' IT WILL LAST',I3,' DAYS')
|
||||
80 FORMAT (' IT WILL LAST,'I3,' DAY')
|
||||
END
|
||||
|
||||
SUBROUTINE HOURSX(H,DAY1,DAY2,DAY3)
|
||||
C
|
||||
C USED BY HOURS (ABOVE) TO PRINT HOURS FOR EITHER WEEKDAYS OR WEEKENDS.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL FIRST
|
||||
C
|
||||
FIRST=.TRUE.
|
||||
FROM=-1
|
||||
IF(H.NE.0)GOTO 10
|
||||
WRITE (5,2)DAY1,DAY2,DAY3
|
||||
2 FORMAT(10X,3A4,' OPEN ALL DAY')
|
||||
RETURN
|
||||
C
|
||||
10 FROM=FROM+1
|
||||
C IF(AND(H,SHIFT(1,FROM)).NE.0)GOTO 10
|
||||
IF((H.AND.SHIFT(1,FROM)).NE.0)GOTO 10
|
||||
IF(FROM.GE.24)GOTO 20
|
||||
TILL=FROM
|
||||
14 TILL=TILL+1
|
||||
C IF(AND(H,SHIFT(1,TILL)).EQ.0.AND.TILL.NE.24)GOTO 14
|
||||
IF((H.AND.SHIFT(1,TILL)).EQ.0.AND.TILL.NE.24)GOTO 14
|
||||
IF(FIRST)WRITE (5,16) DAY1,DAY2,DAY3,FROM,TILL
|
||||
IF(.NOT.FIRST)WRITE (5,18) FROM,TILL
|
||||
16 FORMAT(10X,3A4,I4,':00 TO',I3,':00')
|
||||
18 FORMAT(22X,I4,':00 TO',I3,':00')
|
||||
FIRST=.FALSE.
|
||||
FROM=TILL
|
||||
GOTO 10
|
||||
C
|
||||
20 IF(FIRST)WRITE (5,22) DAY1,DAY2,DAY3
|
||||
22 FORMAT(10X,3A4,' CLOSED ALL DAY')
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE NEWHRS
|
||||
C
|
||||
C SET UP NEW HOURS FOR THE CAVE. SPECIFIED AS INVERSE--I.E., WHEN IS IT
|
||||
C CLOSED DUE TO PRIME TIME? SEE HOURS (ABOVE) FOR DESC OF VARIABLES.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION HNAME(4)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME
|
||||
C
|
||||
CALL MSPEAK(21)
|
||||
WKDAY=NEWHRX('WEEK','DAYS',':')
|
||||
WKEND=NEWHRX('WEEK','ENDS',':')
|
||||
HOLID=NEWHRX('HOLI','DAYS',':')
|
||||
CALL MSPEAK(22)
|
||||
CALL HOURS
|
||||
RETURN
|
||||
END
|
||||
|
||||
INTEGER FUNCTION NEWHRX(DAY1,DAY2,DAY3)
|
||||
C
|
||||
C INPUT PRIME TIME SPECS AND SET UP A WORD OF INTERNAL FORMAT.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
C
|
||||
NEWHRX=0
|
||||
TYPE 1,DAY1,DAY2,DAY3
|
||||
1 FORMAT(' PRIME TIME ON ',3A4)
|
||||
10 TYPE 2
|
||||
2 FORMAT(' FROM:')
|
||||
READ (5,3)FROM
|
||||
3 FORMAT(I7)
|
||||
IF(FROM.LT.0.OR.FROM.GE.24)RETURN
|
||||
TYPE 4
|
||||
4 FORMAT(' TILL:')
|
||||
READ (5,3)TILL
|
||||
TILL=TILL-1
|
||||
IF(TILL.LT.FROM.OR.TILL.GE.24)RETURN
|
||||
DO 5 I=FROM,TILL
|
||||
C5 NEWHRX=OR(NEWHRX,SHIFT(1,I))
|
||||
5 NEWHRX=NEWHRX.OR.SHIFT(1,I)
|
||||
GOTO 10
|
||||
END
|
||||
|
||||
SUBROUTINE MOTD(ALTER)
|
||||
C
|
||||
C HANDLES MESSAGE OF THE DAY. IF ALTER IS TRUE, READ A NEW MESSAGE FROM THE
|
||||
C WIZARD. ELSE PRINT THE CURRENT ONE. MESSAGE IS INITIALLY NULL.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL ALTER
|
||||
DIMENSION MSG(100)
|
||||
DATA MSG/100*-1/
|
||||
C
|
||||
IF(ALTER)GOTO 50
|
||||
C
|
||||
K=1
|
||||
10 IF(MSG(K).LT.0)RETURN
|
||||
LIM1=K+1
|
||||
LIM2=MSG(K)-1
|
||||
WRITE(5,20)(MSG(I),I=LIM1,LIM2)
|
||||
20 FORMAT(' ',18A4)
|
||||
K=MSG(K)
|
||||
GOTO 10
|
||||
C
|
||||
50 M=1
|
||||
CALL MSPEAK(23)
|
||||
55 LIM1=M+1
|
||||
LIM2=M+18
|
||||
READ(5,56)(MSG(I),I=LIM1,LIM2),K
|
||||
56 FORMAT(19A4)
|
||||
C IF(XOR(K,' ').EQ.0)GOTO 60
|
||||
IF((K.XOR.' ').EQ.0)GOTO 60
|
||||
CALL MSPEAK(24)
|
||||
GOTO 55
|
||||
60 DO 62 I=1,18
|
||||
K=M+19-I
|
||||
C IF(XOR(MSG(K),' ').NE.0)GOTO 65
|
||||
IF((MSG(K).XOR.' ').NE.0)GOTO 65
|
||||
62 CONTINUE
|
||||
GOTO 90
|
||||
65 MSG(M)=K+1
|
||||
M=K+1
|
||||
IF(M+18.LT.100)GOTO 55
|
||||
CALL MSPEAK(25)
|
||||
90 MSG(M)=-1
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE POOF
|
||||
C
|
||||
C AS PART OF DATABASE INITIALISATION, WE CALL POOF TO SET UP SOME DUMMY
|
||||
C PRIME-TIME SPECS, MAGIC WORDS, ETC. NOTE THAT THE DEFAULT VALUES FOR
|
||||
C WKDAY AND LATNCY HAVE BEEN CHANGED BY DAVID NEBIKER (6/28/78)
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION HNAME(4)
|
||||
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
|
||||
1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
|
||||
C
|
||||
WKDAY=126976
|
||||
WKEND=0
|
||||
HOLID=0
|
||||
HBEGIN=0
|
||||
HEND=-1
|
||||
SHORT=30
|
||||
MAGIC='DWARF'
|
||||
MAGNM=11111
|
||||
LATNCY=60
|
||||
RETURN
|
||||
END
|
||||
|
||||
INTEGER FUNCTION RAN(RANGE)
|
||||
C
|
||||
C SINCE THE RAN FUNCTION IN LIB40 SEEMS TO BE A REAL LOSER, WE'LL USE ONE OF
|
||||
C OUR OWN. IT'S BEEN RUN THROUGH MANY OF THE TESTS IN KNUTH VOL. 2 AND
|
||||
C SEEMS TO BE QUITE RELIABLE. RAN RETURNS A VALUE UNIFORMLY SELECTED
|
||||
C BETWEEN 0 AND RANGE-1. NOTE RESEMBLANCE TO ALG USED IN WIZARD.
|
||||
C
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DATA R/0/
|
||||
C
|
||||
D=1
|
||||
IF(R.NE.0)GOTO 1
|
||||
CALL DATIME(D,T)
|
||||
R=18*T+5
|
||||
D=1000+MOD(D,1000)
|
||||
1 DO 2 T=1,D
|
||||
2 R=MOD(R*1021,1048576)
|
||||
RAN=(RANGE*R)/1048576
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE DATIME(D,T)
|
||||
|
||||
C RETURN THE DATE AND TIME IN D AND T. D IS NUMBER OF DAYS SINCE 01-JAN-77,
|
||||
C T IS MINUTES PAST MIDNIGHT. THIS IS HARDER THAN IT SOUNDS, BECAUSE THE
|
||||
C FINAGLED DEC FUNCTIONS RETURN THE VALUES ONLY AS ASCII STRINGS!
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
DIMENSION DAT(2),MONTHS(12),HATH(12)
|
||||
DATA MONTHS/'-JAN-','-FEB-','-MAR-','-APR-','-MAY-','-JUN-',
|
||||
1 '-JUL-','-AUG-','-SEP-','-OCT-','-NOV-','-DEC-'/
|
||||
DATA HATH/31,28,31,30,31,30,31,31,30,31,30,31/
|
||||
|
||||
C FUNCTION I2 TAKES 2-DIGIT ASCII AND YIELDS DECIMAL VALUE.
|
||||
|
||||
I2(X)=(SHIFT(X,-29).AND.15)*10+(SHIFT(X,-22).AND.15)
|
||||
|
||||
CALL DATE(DAT)
|
||||
CALL TIME(TIM)
|
||||
|
||||
YEAR=I2(SHIFT(DAT(2),14))-77
|
||||
D=I2(DAT(1))-1
|
||||
X=((SHIFT(DAT(1),14).OR.SHIFT(DAT(2),-21)).AND..NOT."1004020001)
|
||||
1 .OR.'-@@@-'
|
||||
C ABOVE FUNNY EXPRESSION GUARANTEES (A) UPPER-CASE, AND (B) BOTTOM BIT OKAY.
|
||||
D=20
|
||||
GOTO 2
|
||||
DO 1 MON=1,12
|
||||
IF(X.EQ.MONTHS(MON))GOTO 2
|
||||
1 D=D+HATH(MON)
|
||||
CALL BUG(28)
|
||||
|
||||
2 D=D+YEAR*365+YEAR/4
|
||||
IF(MOD(YEAR,4).EQ.3.AND.MON.GT.2)D=D+1
|
||||
T=I2(TIM)*60+I2(SHIFT(TIM,21))
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE CIAO (SUSPND)
|
||||
|
||||
C EXITS, AFTER ISSUING REMINDER TO SAVE NEW CORE IMAGE. USED WHEN SUSPENDING
|
||||
C AND WHEN CREATING NEW VERSION VIA MAGIC MODE. ON SOME SYSTEMS, THE CORE
|
||||
C IMAGE IS LOST ONCE THE PROGRAM EXITS. IF SO, SET K=31 INSTEAD OF 32.
|
||||
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
LOGICAL SUSPND
|
||||
DATA K/32/
|
||||
IF (SUSPND) GOTO 10
|
||||
CALL MSPEAK(K)
|
||||
IF(K.EQ.31)CALL GETIN(A,B,C,D)
|
||||
GOTO 50
|
||||
10 CALL MSPEAK (33)
|
||||
50 STOP
|
||||
END
|
||||
|
||||
SUBROUTINE BUG(NUM)
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
|
||||
C THE FOLLOWING CONDITIONS ARE CURRENTLY CONSIDERED FATAL BUGS. NUMBERS < 20
|
||||
C ARE DETECTED WHILE READING THE DATABASE; THE OTHERS OCCUR AT "RUN TIME".
|
||||
C 0 MESSAGE LINE > 70 CHARACTERS
|
||||
C 1 NULL LINE IN MESSAGE
|
||||
C 2 TOO MANY WORDS OF MESSAGES
|
||||
C 3 TOO MANY TRAVEL OPTIONS
|
||||
C 4 TOO MANY VOCABULARY WORDS
|
||||
C 5 REQUIRED VOCABULARY WORD NOT FOUND
|
||||
C 6 TOO MANY RTEXT OR MTEXT MESSAGES
|
||||
C 7 TOO MANY HINTS
|
||||
C 8 LOCATION HAS COND BIT BEING SET TWICE
|
||||
C 9 INVALID SECTION NUMBER IN DATABASE
|
||||
C 20 SPECIAL TRAVEL (500>L>300) EXCEEDS GOTO LIST
|
||||
C 21 RAN OFF END OF VOCABULARY TABLE
|
||||
C 22 VOCABULARY TYPE (N/1000) NOT BETWEEN 0 AND 3
|
||||
C 23 INTRANSITIVE ACTION VERB EXCEEDS GOTO LIST
|
||||
C 24 TRANSITIVE ACTION VERB EXCEEDS GOTO LIST
|
||||
C 25 CONDITIONAL TRAVEL ENTRY WITH NO ALTERNATIVE
|
||||
C 26 LOCATION HAS NO TRAVEL ENTRIES
|
||||
C 27 HINT NUMBER EXCEEDS GOTO LIST
|
||||
C 28 INVALID MONTH RETURNED BY DATE FUNCTION
|
||||
|
||||
TYPE 1, NUM
|
||||
1 FORMAT (' FATAL ERROR, SEE SOURCE CODE FOR INTERPRETATION.'/
|
||||
1 ' PROBABLY CAUSE: ERRONEOUS INFO IN DATABASE.'/
|
||||
2 ' ERROR CODE =',I2/)
|
||||
STOP
|
||||
END
|
||||
|
||||
INTEGER FUNCTION SCORES (MXSCOR,CHEST,MAXDIE,SCORNG,BONUS,HNTMAX,
|
||||
1 MAXTRS)
|
||||
IMPLICIT INTEGER (A-Z)
|
||||
LOGICAL SCORNG
|
||||
C
|
||||
C EXIT CODE. WILL EVENTUALLY INCLUDE SCORING. FOR NOW, HOWEVER, ...
|
||||
C
|
||||
C THE PRESENT SCORING ALGORITHM IS AS FOLLOWS:
|
||||
C OBJECTIVE:POINTS: PRESENT TOTAL POSSIBLE:
|
||||
C GETTING WELL INTO CAVE 2525
|
||||
C EACH TREASURE < CHEST 1284
|
||||
C TREASURE CHEST ITSELF 1414
|
||||
C EACH TREASURE > CHEST 16 208
|
||||
C SURVIVING (MAX-NUM)*10 40
|
||||
C NOT QUITTING 4 4
|
||||
C REACHING "CLOSNG" 2525
|
||||
C "CLOSED": QUIT/KILLED 10
|
||||
C KLUTZED 25
|
||||
C WRONG WAY 30
|
||||
C SUCCESS 4545
|
||||
C CAME TO WITT'S END 1 1
|
||||
C ROUND OUT THE TOTAL 2 2
|
||||
CTOTAL: 448
|
||||
C (POINTS CAN ALSO BE DEDUCTED FOR USING HINTS.)
|
||||
C
|
||||
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
|
||||
COMMON /PTXCOM/ PTEXT
|
||||
DIMENSION PLAC(100),PLACE(100),FIXD(100),FIXED(100),LINK(200),
|
||||
1ATLOC(200),PTEXT(100)
|
||||
COMMON /SAVCOM/ SEGOFF,ABBNUM,ATTACK,CLOCK1,CLOCK2,CLOSED,CLOSNG,
|
||||
1 DETAIL,DFLAG,DKILL,DLOC,DSEEN,DTOTAL,GAVEUP,HINT,HINTED,
|
||||
2 IWEST,KNFLOC,LIMIT,LMWARN,LOC,NUMDIE,PANIC,PROP,STICK,
|
||||
3 TALLY,TALLY2,TURNS,WZDARK,XXD,XXT,ACCT,HINTLC,HINTS,
|
||||
4 FILLER
|
||||
C
|
||||
LOGICAL CLOSNG,CLOSED,HINTED
|
||||
DIMENSION HINTLC(20),HINTED(20),HINTS(20,4),PROP(100)
|
||||
DIMENSION DSEEN(12),DLOC(12),ODLOC(12)
|
||||
LOGICAL DSEEN
|
||||
DIMENSION FILLER(20)
|
||||
C
|
||||
C MAGZIN = VOCAB(CODE('MAGA','Z'),1)
|
||||
MAGZIN=VOCAB('MAGAZ',1)
|
||||
20000 SCORES=0
|
||||
MXSCOR=0
|
||||
C
|
||||
C FIRST TALLY UP THE TREASURES. MUST BE IN BUILDING AND NOT BROKEN.
|
||||
C GIVE THE POOR GUY 2 POINTS JUST FOR FINDING EACH TREASURE.
|
||||
C
|
||||
DO 20010 I=50,MAXTRS
|
||||
IF(PTEXT(I).EQ.0)GOTO 20010
|
||||
K=12
|
||||
IF(I.EQ.CHEST)K=14
|
||||
IF(I.GT.CHEST)K=16
|
||||
IF(PROP(I).GE.0)SCORES=SCORES+2
|
||||
IF(PLACE(I).EQ.3.AND.PROP(I).EQ.0)SCORES=SCORES+K-2
|
||||
MXSCOR=MXSCOR+K
|
||||
20010 CONTINUE
|
||||
C
|
||||
C NOW LOOK AT HOW HE FINISHED AND HOW FAR HE GOT. MAXDIE AND NUMDIE TELL US
|
||||
C HOW WELL HE SURVIVED. GAVEUP SAYS WHETHER HE EXITED VIA QUIT. DFLAG WILL
|
||||
C TELL US IF HE EVER GOT SUITABLY DEEP INTO THE CAVE. CLOSNG STILL INDICATE
|
||||
C WHETHER HE REACHED THE ENDGAME. AND IF HE GOT AS FAR AS "CAVE CLOSED"
|
||||
C (INDICATED BY "CLOSED"), THEN BONUS IS ZERO FOR MUNDANE EXITS OR 133, 134,
|
||||
C 135 IF HE BLEW IT (SO TO SPEAK).
|
||||
C
|
||||
SCORES=SCORES+(MAXDIE-NUMDIE)*10
|
||||
MXSCOR=MXSCOR+MAXDIE*10
|
||||
IF(.NOT.SCORNG)SCORES=SCORES+4
|
||||
MXSCOR=MXSCOR+4
|
||||
IF(DFLAG.NE.0)SCORES=SCORES+25
|
||||
MXSCOR=MXSCOR+25
|
||||
IF(CLOSNG)SCORES=SCORES+25
|
||||
MXSCOR=MXSCOR+25
|
||||
IF(.NOT.CLOSED)GOTO 20020
|
||||
IF(BONUS.EQ.0)SCORES=SCORES+10
|
||||
IF(BONUS.EQ.135)SCORES=SCORES+25
|
||||
IF(BONUS.EQ.134)SCORES=SCORES+30
|
||||
IF(BONUS.EQ.133)SCORES=SCORES+45
|
||||
20020 MXSCOR=MXSCOR+45
|
||||
C
|
||||
C DID HE COME TO WITT'S END AS HE SHOULD?
|
||||
C
|
||||
IF(PLACE(MAGZIN).EQ.108)SCORES=SCORES+1
|
||||
MXSCOR=MXSCOR+1
|
||||
C
|
||||
C ROUND IT OFF.
|
||||
C
|
||||
SCORES=SCORES+2
|
||||
MXSCOR=MXSCOR+2
|
||||
C
|
||||
C DEDUCT POINTS FOR HINTS. HINTS < 4 ARE SPECIAL; SEE DATABASE DESCRIPTION
|
||||
C
|
||||
MAXHNT = HNTMAX
|
||||
DO 20030 I=1,MAXHNT
|
||||
20030 IF(HINTED(I))SCORES=SCORES-HINTS(I,2)
|
||||
C
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE LOAD(WORD)
|
||||
IMPLICIT INTEGER (A-Z)
|
||||
RETURN
|
||||
|
||||
C
|
||||
DATA XFILE/'FILE'/, XREST/'REST'/
|
||||
IF (WORD.EQ.XFILE) GOTO 50
|
||||
IF (WORD.EQ.XREST) GOTO 30
|
||||
WRITE (6,10) WORD
|
||||
10 FORMAT (' LOAD OPTION ',A4,' NOT IMPLEMENTED')
|
||||
GOTO 100
|
||||
30 CALL RESTOR
|
||||
GOTO 100
|
||||
50 CALL FILE
|
||||
100 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
INTEGER FUNCTION SHIFT(VAL,DIST)
|
||||
IMPLICIT INTEGER(A-Z)
|
||||
SHIFT=VAL
|
||||
IF(DIST)10,20,30
|
||||
10 IDIST=-DIST
|
||||
DO 11 I=1,IDIST
|
||||
J=0
|
||||
IF(SHIFT.LT.0)J="200000000000
|
||||
11 SHIFT=((SHIFT.AND."377777777777)/2).OR.J
|
||||
20 RETURN
|
||||
30 DO 31 I=1,DIST
|
||||
J=0
|
||||
IF((SHIFT.AND."200000000000).NE.0)J=-34359738367
|
||||
SHIFT=((SHIFT.AND."177777777777)*2)+J
|
||||
31 SHIFT=SHIFT.AND."777777777776
|
||||
RETURN
|
||||
END
|
||||
1760
src/games/trek.2
Normal file
1760
src/games/trek.2
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user