zork-fortran/clockr.for

C CEVAPP- CLOCK EVENT APPLICABLES
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 CEVAPP(RI)
	IMPLICIT INTEGER (A-Z)
	INTEGER CNDTCK(10),LMPTCK(12)
	LOGICAL FINDXT,LIT,RMDESC,QOPEN,MOVETO
	LOGICAL F,QLEDGE,QVAIR,QHERE,PROB
	include 'gamestat.h'
	include 'state.h'
	include 'rooms.h'
	include 'rflag.h'
	include 'rindex.h'
	include 'objects.h'
	include 'oflags.h'
	include 'oindex.h'
	include 'clock.h'
	include 'curxt.h'
	include 'xsrch.h'
	include 'villians.h'
	include 'advers.h'
	include 'flags.h'
C
C FUNCTIONS AND DATA
C
	QOPEN(R)=(IAND(OFLAG2(R),OPENBT)).NE.0
	QLEDGE(R)=(R.EQ.LEDG2).OR.(R.EQ.LEDG3).OR.(R.EQ.LEDG4).OR.
     &	(R.EQ.VLBOT)
	QVAIR(R)=(R.EQ.VAIR1).OR.(R.EQ.VAIR2).OR.(R.EQ.VAIR3).OR.
     &	 (R.EQ.VAIR4)
	DATA CNDTCK/50,20,10,5,0,156,156,156,157,0/
	DATA LMPTCK/50,30,20,10,4,0,154,154,154,154,155,0/
C CEVAPP, PAGE 2
C
	IF(RI.EQ.0) RETURN
C						!IGNORE DISABLED.
	GO TO (1000,2000,3000,4000,5000,6000,7000,8000,9000,10000,
     & 11000,12000,13000,14000,15000,16000,17000,18000,19000,
     & 20000,21000,22000,23000,24000),RI
	CALL BUG(3,RI)
C
C CEV1--	CURE CLOCK.  LET PLAYER SLOWLY RECOVER.
C
1000	ASTREN(PLAYER)=MIN0(0,ASTREN(PLAYER)+1)
C						!RECOVER.
	IF(ASTREN(PLAYER).GE.0) RETURN
C						!FULLY RECOVERED?
	CTICK(CEVCUR)=30
C						!NO, WAIT SOME MORE.
	RETURN
C
C CEV2--	MAINT-ROOM WITH LEAK.  RAISE THE WATER LEVEL.
C
2000	IF(HERE.EQ.MAINT) CALL RSPEAK(71+(RVMNT/2))
C						!DESCRIBE.
	RVMNT=RVMNT+1
C						!RAISE WATER LEVEL.
	IF(RVMNT.LE.16) RETURN
C						!IF NOT FULL, EXIT.
	CTICK(CEVMNT)=0
C						!FULL, DISABLE CLOCK.
	RFLAG(MAINT)=IOR(RFLAG(MAINT),RMUNG)
	RRAND(MAINT)=80
C						!SAY IT IS FULL OF WATER.
	IF(HERE.EQ.MAINT) CALL JIGSUP(81)
C						!DROWN HIM IF PRESENT.
	RETURN
C
C CEV3--	LANTERN.  DESCRIBE GROWING DIMNESS.
C
3000	CALL LITINT(LAMP,ORLAMP,CEVLNT,LMPTCK,12)
C						!DO LIGHT INTERRUPT.
	RETURN
C
C CEV4--	MATCH.  OUT IT GOES.
C
4000	CALL RSPEAK(153)
C						!MATCH IS OUT.
	OFLAG1(MATCH)=IAND(OFLAG1(MATCH), not(ONBT))
	RETURN
C
C CEV5--	CANDLE.  DESCRIBE GROWING DIMNESS.
C
5000	CALL LITINT(CANDL,ORCAND,CEVCND,CNDTCK,10)
C						!DO CANDLE INTERRUPT.
	RETURN
C CEVAPP, PAGE 3
C
C CEV6--	BALLOON
C
6000	CTICK(CEVBAL)=3
C						!RESCHEDULE INTERRUPT.
	F=AVEHIC(WINNER).EQ.BALLO
C						!SEE IF IN BALLOON.
	IF(BLOC.EQ.VLBOT) GO TO 6800
C						!AT BOTTOM?
	IF(QLEDGE(BLOC)) GO TO 6700
C						!ON LEDGE?
	IF(QOPEN(RECEP).AND.(BINFF.NE.0))
     &	GO TO 6500
C
C BALLOON IS IN MIDAIR AND IS DEFLATED (OR HAS RECEPTACLE CLOSED).
C FALL TO NEXT ROOM.
C
	IF(BLOC.NE.VAIR1) GO TO 6300
C						!IN VAIR1?
	BLOC=VLBOT
C						!YES, NOW AT VLBOT.
	CALL NEWSTA(BALLO,0,BLOC,0,0)
	IF(F) GO TO 6200
C						!IN BALLOON?
	IF(QLEDGE(HERE)) CALL RSPEAK(530)
C						!ON LEDGE, DESCRIBE.
	RETURN
C
6200	F=MOVETO(BLOC,WINNER)
C						!MOVE HIM.
	IF(BINFF.EQ.0) GO TO 6250
C						!IN BALLOON.  INFLATED?
	CALL RSPEAK(531)
C						!YES, LANDED.
	F=RMDESC(0)
C						!DESCRIBE.
	RETURN
C
6250	CALL NEWSTA(BALLO,532,0,0,0)
C						!NO, BALLOON & CONTENTS DIE.
	CALL NEWSTA(DBALL,0,BLOC,0,0)
C						!INSERT DEAD BALLOON.
	AVEHIC(WINNER)=0
C						!NOT IN VEHICLE.
	CFLAG(CEVBAL)=.FALSE.
C						!DISABLE INTERRUPTS.
	CFLAG(CEVBRN)=.FALSE.
	BINFF=0
	BTIEF=0
	RETURN
C
6300	BLOC=BLOC-1
C						!NOT IN VAIR1, DESCEND.
	CALL NEWSTA(BALLO,0,BLOC,0,0)
	IF(F) GO TO 6400
C						!IS HE IN BALLOON?
	IF(QLEDGE(HERE)) CALL RSPEAK(533)
C						!IF ON LEDGE, DESCRIBE.
	RETURN
C
6400	F=MOVETO(BLOC,WINNER)
C						!IN BALLOON, MOVE HIM.
	CALL RSPEAK(534)
C						!DESCRIBE.
	F=RMDESC(0)
	RETURN
C
C BALLOON IS IN MIDAIR AND IS INFLATED, UP-UP-AND-AWAY
C						!
C
6500	IF(BLOC.NE.VAIR4) GO TO 6600
C						!AT VAIR4?
	CTICK(CEVBRN)=0
	CTICK(CEVBAL)=0
	BINFF=0
	BTIEF=0
	BLOC=VLBOT
C						!FALL TO BOTTOM.
	CALL NEWSTA(BALLO,0,0,0,0)
C						!BALLOON & CONTENTS DIE.
	CALL NEWSTA(DBALL,0,BLOC,0,0)
C						!SUBSTITUTE DEAD BALLOON.
	IF(F) GO TO 6550
C						!WAS HE IN IT?
	IF(QLEDGE(HERE)) CALL RSPEAK(535)
C						!IF HE CAN SEE, DESCRIBE.
	RETURN
C
6550	CALL JIGSUP(536)
C						!IN BALLOON AT CRASH, DIE.
	RETURN
C
6600	BLOC=BLOC+1
C						!NOT AT VAIR4, GO UP.
	CALL NEWSTA(BALLO,0,BLOC,0,0)
	IF(F) GO TO 6650
C						!IN BALLOON?
	IF(QLEDGE(HERE)) CALL RSPEAK(537)
C						!CAN HE SEE IT?
	RETURN
C
6650	F=MOVETO(BLOC,WINNER)
C						!MOVE PLAYER.
	CALL RSPEAK(538)
C						!DESCRIBE.
	F=RMDESC(0)
	RETURN
C
C ON LEDGE, GOES TO MIDAIR ROOM WHETHER INFLATED OR NOT.
C
6700	BLOC=BLOC+(VAIR2-LEDG2)
C						!MOVE TO MIDAIR.
	CALL NEWSTA(BALLO,0,BLOC,0,0)
	IF(F) GO TO 6750
C						!IN BALLOON?
	IF(QLEDGE(HERE)) CALL RSPEAK(539)
C						!NO, STRANDED.
	CTICK(CEVVLG)=10
C						!MATERIALIZE GNOME.
	RETURN
C
6750	F=MOVETO(BLOC,WINNER)
C						!MOVE TO NEW ROOM.
	CALL RSPEAK(540)
C						!DESCRIBE.
	F=RMDESC(0)
	RETURN
C
C AT BOTTOM, GO UP IF INFLATED, DO NOTHING IF DEFLATED.
C
6800	IF((BINFF.EQ.0).OR..NOT.QOPEN(RECEP)) RETURN
	BLOC=VAIR1
C						!INFLATED AND OPEN,
	CALL NEWSTA(BALLO,0,BLOC,0,0)
C						!GO UP TO VAIR1.
	IF(F) GO TO 6850
C						!IN BALLOON?
	IF(QLEDGE(HERE)) CALL RSPEAK(541)
C						!IF CAN SEE, DESCRIBE.
	RETURN
C
6850	F=MOVETO(BLOC,WINNER)
C						!MOVE PLAYER.
	CALL RSPEAK(542)
	F=RMDESC(0)
	RETURN
C CEVAPP, PAGE 4
C
C CEV7--	BALLOON BURNUP
C
7000	DO 7100 I=1,OLNT
C						!FIND BURNING OBJECT
	  IF((RECEP.EQ.OCAN(I)).AND.((IAND(OFLAG1(I),FLAMBT)).NE.0))
     &	GO TO 7200
7100	CONTINUE
	CALL BUG(4,0)
C
7200	CALL NEWSTA(I,0,0,0,0)
C						!VANISH OBJECT.
	BINFF=0
C						!UNINFLATED.
	IF(HERE.EQ.BLOC) CALL RSPSUB(292,ODESC2(I))
C						!DESCRIBE.
	RETURN
C
C CEV8--	FUSE FUNCTION
C
8000	IF(OCAN(FUSE).NE.BRICK) GO TO 8500
C						!IGNITED BRICK?
	BR=OROOM(BRICK)
C						!GET BRICK ROOM.
	BC=OCAN(BRICK)
C						!GET CONTAINER.
	IF((BR.EQ.0).AND.(BC.NE.0)) BR=OROOM(BC)
	CALL NEWSTA(FUSE,0,0,0,0)
C						!KILL FUSE.
	CALL NEWSTA(BRICK,0,0,0,0)
C						!KILL BRICK.
	IF((BR.NE.0).AND.(BR.NE.HERE)) GO TO 8100
C						!BRICK ELSEWHERE?
C
	RFLAG(HERE)=IOR(RFLAG(HERE),RMUNG)
	RRAND(HERE)=114
C						!MUNG ROOM.
	CALL JIGSUP(150)
C						!DEAD.
	RETURN
C
8100	CALL RSPEAK(151)
C						!BOOM.
	MUNGRM=BR
C						!SAVE ROOM THAT BLEW.
	CTICK(CEVSAF)=5
C						!SET SAFE INTERRUPT.
	IF(BR.NE.MSAFE) GO TO 8200
C						!BLEW SAFE ROOM?
	IF(BC.NE.SSLOT) RETURN
C						!WAS BRICK IN SAFE?
	CALL NEWSTA(SSLOT,0,0,0,0)
C						!KILL SLOT.
	OFLAG2(SAFE)=IOR(OFLAG2(SAFE),OPENBT)
	SAFEF=.TRUE.
C						!INDICATE SAFE BLOWN.
	RETURN
C
8200	DO 8250 I=1,OLNT
C						!BLEW WRONG ROOM.
	  IF(QHERE(I,BR) .AND. ((IAND(OFLAG1(I),TAKEBT)).NE.0))
     &	CALL NEWSTA(I,0,0,0,0)
8250	CONTINUE
	IF(BR.NE.LROOM) RETURN
C						!BLEW LIVING ROOM?
	DO 8300 I=1,OLNT
	  IF(OCAN(I).EQ.TCASE) CALL NEWSTA(I,0,0,0,0)
C						!KILL TROPHY CASE.
8300	CONTINUE
	RETURN
C
8500	IF(QHERE(FUSE,HERE).OR.(OADV(FUSE).EQ.WINNER))
     &	CALL RSPEAK(152)
	CALL NEWSTA(FUSE,0,0,0,0)
C						!KILL FUSE.
	RETURN
C CEVAPP, PAGE 5
C
C CEV9--	LEDGE MUNGE.
C
9000	RFLAG(LEDG4)=IOR(RFLAG(LEDG4),RMUNG)
	RRAND(LEDG4)=109
	IF(HERE.EQ.LEDG4) GO TO 9100
C						!WAS HE THERE?
	CALL RSPEAK(110)
C						!NO, NARROW ESCAPE.
	RETURN
C
9100	IF(AVEHIC(WINNER).NE.0) GO TO 9200
C						!IN VEHICLE?
	CALL JIGSUP(111)
C						!NO, DEAD.
	RETURN
C
9200	IF(BTIEF.NE.0) GO TO 9300
C						!TIED TO LEDGE?
	CALL RSPEAK(112)
C						!NO, NO PLACE TO LAND.
	RETURN
C
9300	BLOC=VLBOT
C						!YES, CRASH BALLOON.
	CALL NEWSTA(BALLO,0,0,0,0)
C						!BALLOON & CONTENTS DIE.
	CALL NEWSTA(DBALL,0,BLOC,0,0)
C						!INSERT DEAD BALLOON.
	BTIEF=0
	BINFF=0
	CFLAG(CEVBAL)=.FALSE.
	CFLAG(CEVBRN)=.FALSE.
	CALL JIGSUP(113)
C						!DEAD
	RETURN
C
C CEV10--	SAFE MUNG.
C
10000	RFLAG(MUNGRM)=IOR(RFLAG(MUNGRM),RMUNG)
	RRAND(MUNGRM)=114
	IF(HERE.EQ.MUNGRM) GO TO 10100
C						!IS HE PRESENT?
	CALL RSPEAK(115)
C						!LET HIM KNOW.
	IF(MUNGRM.EQ.MSAFE) CTICK(CEVLED)=8
C						!START LEDGE CLOCK.
	RETURN
C
10100	I=116
C						!HE'S DEAD,
	IF((IAND(RFLAG(HERE),RHOUSE)).NE.0) I=117
	CALL JIGSUP(I)
C						!LET HIM KNOW.
	RETURN
C CEVAPP, PAGE 6
C
C CEV11--	VOLCANO GNOME
C
11000	IF(QLEDGE(HERE)) GO TO 11100
C						!IS HE ON LEDGE?
	CTICK(CEVVLG)=1
C						!NO, WAIT A WHILE.
	RETURN
C
11100	CALL NEWSTA(GNOME,118,HERE,0,0)
C						!YES, MATERIALIZE GNOME.
	RETURN
C
C CEV12--	VOLCANO GNOME DISAPPEARS
C
12000	CALL NEWSTA(GNOME,149,0,0,0)
C						!DISAPPEAR THE GNOME.
	RETURN
C
C CEV13--	BUCKET.
C
13000	IF(OCAN(WATER).EQ.BUCKE)
     &	CALL NEWSTA(WATER,0,0,0,0)
	RETURN
C
C CEV14--	SPHERE.  IF EXPIRES, HE'S TRAPPED.
C
14000	RFLAG(CAGER)=IOR(RFLAG(CAGER),RMUNG)
	RRAND(CAGER)=147
	CALL JIGSUP(148)
C						!MUNG PLAYER.
	RETURN
C
C CEV15--	END GAME HERALD.
C
15000	ENDGMF=.TRUE.
C						!WE'RE IN ENDGAME.
	CALL RSPEAK(119)
C						!INFORM OF ENDGAME.
	RETURN
C CEVAPP, PAGE 7
C
C CEV16--	FOREST MURMURS
C
16000	CFLAG(CEVFOR)=(HERE.EQ.MTREE).OR.
     &	((HERE.GE.FORE1).AND.(HERE.LT.CLEAR))
	IF(CFLAG(CEVFOR).AND.PROB(10,10)) CALL RSPEAK(635)
	RETURN
C
C CEV17--	SCOL ALARM
C
17000	IF(HERE.EQ.BKTWI) CFLAG(CEVZGI)=.TRUE.
C						!IF IN TWI, GNOME.
	IF(HERE.EQ.BKVAU) CALL JIGSUP(636)
C						!IF IN VAU, DEAD.
	RETURN
C
C CEV18--	ENTER GNOME OF ZURICH
C
18000	CFLAG(CEVZGO)=.TRUE.
C						!EXITS, TOO.
	CALL NEWSTA(ZGNOM,0,BKTWI,0,0)
C						!PLACE IN TWI.
	IF(HERE.EQ.BKTWI) CALL RSPEAK(637)
C						!ANNOUNCE.
	RETURN
C
C CEV19--	EXIT GNOME
C
19000	CALL NEWSTA(ZGNOM,0,0,0,0)
C						!VANISH.
	IF(HERE.EQ.BKTWI) CALL RSPEAK(638)
C						!ANNOUNCE.
	RETURN
C CEVAPP, PAGE 8
C
C CEV20--	START OF ENDGAME
C
20000	IF(SPELLF) GO TO 20200
C						!SPELL HIS WAY IN?
	IF(HERE.NE.CRYPT) RETURN
C						!NO, STILL IN TOMB?
	IF(.NOT.LIT(HERE)) GO TO 20100
C						!LIGHTS OFF?
	CTICK(CEVSTE)=3
C						!RESCHEDULE.
	RETURN
C
20100	CALL RSPEAK(727)
C						!ANNOUNCE.
20200	DO 20300 I=1,OLNT
C						!STRIP HIM OF OBJS.
	  CALL NEWSTA(I,0,OROOM(I),OCAN(I),0)
20300	CONTINUE
	CALL NEWSTA(LAMP,0,0,0,PLAYER)
C						!GIVE HIM LAMP.
	CALL NEWSTA(SWORD,0,0,0,PLAYER)
C						!GIVE HIM SWORD.
C
	OFLAG1(LAMP)=IAND((IOR(OFLAG1(LAMP),LITEBT)), not(ONBT))
	OFLAG2(LAMP)=IOR(OFLAG2(LAMP),TCHBT)
	CFLAG(CEVLNT)=.FALSE.
C						!LAMP IS GOOD AS NEW.
	CTICK(CEVLNT)=350
	ORLAMP=0
	OFLAG2(SWORD)=IOR(OFLAG2(SWORD),TCHBT)
	SWDACT=.TRUE.
	SWDSTA=0
C
	THFACT=.FALSE.
C						!THIEF GONE.
	ENDGMF=.TRUE.
C						!ENDGAME RUNNING.
	CFLAG(CEVMAT)=.FALSE.
C						!MATCHES GONE,
	CFLAG(CEVCND)=.FALSE.
C						!CANDLES GONE.
C
	CALL SCRUPD(RVAL(CRYPT))
C						!SCORE CRYPT,
	RVAL(CRYPT)=0
C						!BUT ONLY ONCE.
	F=MOVETO(TSTRS,WINNER)
C						!TO TOP OF STAIRS,
	F=RMDESC(3)
C						!AND DESCRIBE.
	RETURN
C						!BAM
C						!
C
C CEV21--	MIRROR CLOSES.
C
21000	MRPSHF=.FALSE.
C						!BUTTON IS OUT.
	MROPNF=.FALSE.
C						!MIRROR IS CLOSED.
	IF(HERE.EQ.MRANT) CALL RSPEAK(728)
C						!DESCRIBE BUTTON.
	IF((HERE.EQ.INMIR).OR.(MRHERE(HERE).EQ.1))
     &	CALL RSPEAK(729)
	RETURN
C CEVAPP, PAGE 9
C
C CEV22--	DOOR CLOSES.
C
22000	IF(WDOPNF) CALL RSPEAK(730)
C						!DESCRIBE.
	WDOPNF=.FALSE.
C						!CLOSED.
	RETURN
C
C CEV23--	INQUISITOR'S QUESTION
C
23000	IF(AROOM(PLAYER).NE.FDOOR) RETURN
C						!IF PLAYER LEFT, DIE.
	CALL RSPEAK(769)
	CALL RSPEAK(770+QUESNO)
	CTICK(CEVINQ)=2
	RETURN
C
C CEV24--	MASTER FOLLOWS
C
24000	IF(AROOM(AMASTR).EQ.HERE) RETURN
C						!NO MOVEMENT, DONE.
	IF((HERE.NE.CELL).AND.(HERE.NE.PCELL)) GO TO 24100
	IF(FOLLWF) CALL RSPEAK(811)
C						!WONT GO TO CELLS.
	FOLLWF=.FALSE.
	RETURN
C
24100	FOLLWF=.TRUE.
C						!FOLLOWING.
	I=812
C						!ASSUME CATCHES UP.
	DO 24200 J=XMIN,XMAX,XMIN
	  IF(FINDXT(J,AROOM(AMASTR)).AND.(XROOM1.EQ.HERE))
     &	I=813
24200	CONTINUE
	CALL RSPEAK(I)
	CALL NEWSTA(MASTER,0,HERE,0,0)
C						!MOVE MASTER OBJECT.
	AROOM(AMASTR)=HERE
C						!MOVE MASTER PLAYER.
	RETURN
C
	END
C LITINT-	LIGHT INTERRUPT PROCESSOR
C
C DECLARATIONS
C
	SUBROUTINE LITINT(OBJ,CTR,CEV,TICKS,TICKLN)
	IMPLICIT INTEGER (A-Z)
	INTEGER TICKS(TICKLN)
	include 'gamestat.h'
	include 'objects.h'
	include 'oflags.h'
	include 'clock.h'
C
	CTR=CTR+1
C						!ADVANCE STATE CNTR.
	CTICK(CEV)=TICKS(CTR)
C						!RESET INTERRUPT.
	IF(CTICK(CEV).NE.0) GO TO 100
C						!EXPIRED?
	OFLAG1(OBJ)=IAND(OFLAG1(OBJ), not(LITEBT+FLAMBT+ONBT))
	IF((OROOM(OBJ).EQ.HERE).OR.(OADV(OBJ).EQ.WINNER))
     &	CALL RSPSUB(293,ODESC2(OBJ))
	RETURN
C
100	IF((OROOM(OBJ).EQ.HERE).OR.(OADV(OBJ).EQ.WINNER))
     &	CALL RSPEAK(TICKS(CTR+(TICKLN/2)))
	RETURN
C
	END