1 C PRINCO- Print contents of object
  2 C
  3 C Declarations
  4 C
  5           SUBROUTINE PRINCO(OBJ,DESC,LDESCF)
  6           IMPLICIT INTEGER (A-Z)
  7           %include dparam
  8           LOGICAL QEMPTY,LDESCF,MOREF,QSEEIN,QUAL
  9 C
 10 C Functions and data
 11 C
 12 C old     QSEEIN(X)=((OFLAG1(X).AND.TRANBT).NE.0).OR.
 13 C old     &           ((OFLAG2(X).AND.OPENBT).NE.0)
 14           QSEEIN(X)=((AND(OFLAG1(X),TRANBT)).NE.0).OR.
 15           &           ((AND(OFLAG2(X),OPENBT)).NE.0)
 16 C old     QUAL(X,Y)=((OFLAG1(X).AND.VISIBT).NE.0).AND.
 17 C old     &            (OCAN(X).EQ.Y).AND.(X.NE.AOBJ(WINNER))
 18           QUAL(X,Y)=((AND(OFLAG1(X),VISIBT)).NE.0).AND.
 19           &            (OCAN(X).EQ.Y).AND.(X.NE.AOBJ(WINNER))
 20 C
 21           MOREF=.FALSE.                                     ! no additional printouts.
 22           ALSO=0                                            ! no untouched descriptions.
 23           IF(SUPERF.OR..NOT.LDESCF) GO TO 2000    ! skip long descriptions?
 24           DO 1000 I=1,OLNT                        ! loop thru objects.
 25             IF(.NOT.QUAL(I,OBJ)) GO TO 1000       ! inside target?
 26 C old       IF((ODESCO(I).EQ.0).OR.
 27 C old     &   ((OFLAG2(I).AND.TCHBT).NE.0)) GO TO 700
 28             IF((ODESCO(I).EQ.0).OR.
 29           &   ((AND(OFLAG2(I),TCHBT)).NE.0)) GO TO 700
 30             CALL RSPEAK(ODESCO(I))                ! print untouched descr.
 31             ALSO=1                                ! flag.
 32             IF(.NOT.QSEEIN(I).OR.QEMPTY(I)) GO TO 1000
 33             CALL RSPSUB(573,ODESC2(I))            ! object, which contains:
 34             DO 500 J=1,OLNT                       ! loop thru objects.
 35               IF(QUAL(J,I)) CALL RSPSUB(502,ODESC2(J))
 36 500         CONTINUE
 37             GO TO 1000
 38 700         MOREF=.TRUE.
 39 1000      CONTINUE
 40           IF(.NOT.MOREF) RETURN                             ! more to do?
 41 C
 42 2000      CALL RSPSUB(DESC+ALSO,ODESC2(OBJ))      ! print header.
 43           DO 3000 I=1,OLNT                        ! loop thru objects.
 44             IF(.NOT.QUAL(I,OBJ)) GO TO 3000       ! inside target?
 45 C old       IF((ALSO.NE.0).AND.(ODESCO(I).NE.0).AND.
 46 C old     &    ((OFLAG2(I).AND.TCHBT).EQ.0)) GO TO 3000
 47             IF((ALSO.NE.0).AND.(ODESCO(I).NE.0).AND.
 48           &    ((AND(OFLAG2(I),TCHBT)).EQ.0)) GO TO 3000
 49             IF(.NOT.QSEEIN(I).OR.QEMPTY(I)) GO TO 2700
 50             CALL RSPSUB(1050,ODESC2(I))           ! object, which contains:
 51             DO 2500 J=1,OLNT                      ! loop thru objects.
 52               IF(QUAL(J,I)) CALL RSPSUB(1051,ODESC2(J))
 53 2500        CONTINUE
 54             GO TO 3000
 55 2700        CALL RSPSUB(502,ODESC2(I))            ! object, nothing inside.
 56 3000      CONTINUE
 57           RETURN
 58 C
 59           END
 60 C page
 61 C MOVETO- Move player to new room
 62 C
 63 C Declarations
 64 C
 65           LOGICAL FUNCTION MOVETO(NR,WHO)
 66           IMPLICIT INTEGER (A-Z)
 67           %include dparam
 68           LOGICAL NLV,LHR,LNR
 69 C
 70           MOVETO=.FALSE.                                    ! assume fails.
 71 C old     LHR=(RFLAG(HERE).AND.RLAND).NE.0        ! land  here flag.
 72           LHR=(AND(RFLAG(HERE),RLAND)).NE.0       ! land  here flag.
 73 C old     LNR=(RFLAG(NR).AND.RLAND).NE.0                    ! land there flag.
 74           LNR=(AND(RFLAG(NR),RLAND)).NE.0                   ! land there flag.
 75           J=AVEHIC(WHO)                                     ! his vehicle
 76 C
 77           IF(J.NE.0) GO TO 100                              ! in vehicle?
 78           IF(LNR) GO TO 500                       ! no, going to land?
 79           CALL RSPEAK(427)                        ! can't go without vehicle.
 80           RETURN
 81 C
 82 100       BITS=0                                            ! assume nowhere.
 83           IF(J.EQ.RBOAT) BITS=RWATER              ! in boat?
 84           IF(J.EQ.BALLO) BITS=RAIR                ! in balloon?
 85           IF(J.EQ.BUCKE) BITS=RBUCK               ! in bucket?
 86 C old     NLV=(RFLAG(NR).AND.BITS).EQ.0           ! got wrong vehicle flag.
 87           NLV=(AND(RFLAG(NR),BITS)).EQ.0                    ! got wrong vehicle flag.
 88           IF((.NOT.LNR .AND.NLV) .OR.
 89           &         (LNR.AND.LHR.AND.NLV.AND.(BITS.NE.RLAND)))
 90           &         GO TO 800                     ! got wrong vehicle?
 91 C
 92 500       MOVETO=.TRUE.                                     ! move should succeed.
 93 C old     IF((RFLAG(NR).AND.RMUNG).EQ.0) GO TO 600 ! room munged?
 94           IF((AND(RFLAG(NR),RMUNG)).EQ.0) GO TO 600 ! room munged?
 95           CALL RSPEAK(RDESC1(NR))                           ! yes, tell how.
 96           RETURN
 97 C
 98 600       IF(WHO.NE.PLAYER) CALL NEWSTA(AOBJ(WHO),0,NR,0,0)
 99           IF(J.NE.0) CALL NEWSTA(J,0,NR,0,0)
100           HERE=NR
101           AROOM(WHO)=HERE
102           CALL SCRUPD(RVAL(NR))                             ! score room
103           RVAL(NR)=0
104           RETURN
105 C
106 800       CALL RSPSUB(428,ODESC2(J))              ! wrong vehicle.
107           RETURN
108 C
109           END
110 C page
111 C SCORE-- Print out current score
112 C
113 C Declarations
114 C
115           SUBROUTINE SCORE(FLG)
116           IMPLICIT INTEGER (A-Z)
117           %include dparam
118           LOGICAL FLG
119           INTEGER RANK(10),ERANK(5)
120 C
121 C Functions and data
122 C
123           DATA RANK/20,19,18,16,12,8,4,2,1,0/
124           DATA ERANK/20,15,10,5,0/
125 C
126           AS=ASCORE(WINNER)
127           IF(ENDGMF) GO TO 60                     ! endgame?
128           IF(FLG) WRITE(OUTCH,100)
129           IF(.NOT.FLG) WRITE(OUTCH,110)
130           IF(MOVES.NE.1) WRITE(OUTCH,120) AS,MXSCOR,MOVES
131           IF(MOVES.EQ.1) WRITE(OUTCH,130) AS,MXSCOR,MOVES
132           IF(AS.LT.0) GO TO 50                              ! negative score?
133           DO 10 I=1,10                                      ! find rank.
134             IF((AS*20/MXSCOR).GE.RANK(I)) GO TO 20
135 10        CONTINUE
136           I=10                                              ! beginner.
137 20        CALL RSPEAK(484+I)                      ! print rank.
138           RETURN
139 C
140 50        CALL RSPEAK(886)                        ! negative score.
141           RETURN
142 C
143 60        IF(FLG) WRITE(OUTCH,140)
144           IF(.NOT.FLG) WRITE(OUTCH,150)
145           WRITE(OUTCH,120) EGSCOR,EGMXSC,MOVES
146           DO 70 I=1,5
147             IF((EGSCOR*20/EGMXSC).GE.ERANK(I)) GO TO 80
148 70        CONTINUE
149           I=5                                               ! beginner.
150 80        CALL RSPEAK(786+I)
151           RETURN
152 C
153 100       FORMAT(' Your score would be',$)
154 110       FORMAT(' Your score is',$)
155 120       FORMAT('+',I4,' [total of',I4,' points], in',I5,' moves.')
156 130       FORMAT('+',I4,' [total of',I4,' points], in',I5,' move.')
157 140       FORMAT(' Your score in the endgame would be',$)
158 150       FORMAT(' Your score in the endgame is',$)
159 C
160           END
161 C page
162 C SCRUPD- Update winner's score
163 C
164 C Declarations
165 C
166           SUBROUTINE SCRUPD(N)
167           IMPLICIT INTEGER (A-Z)
168           %include dparam
169 C
170           IF(ENDGMF) GO TO 100                              ! endgame?
171           ASCORE(WINNER)=ASCORE(WINNER)+N                   ! update score
172           RWSCOR=RWSCOR+N                                   ! update raw score
173           IF(ASCORE(WINNER).LT.(MXSCOR-(10*MIN0(1,DEATHS)))) RETURN
174           CFLAG(CEVEGH)=.TRUE.                              ! turn on end game
175           CTICK(CEVEGH)=15
176           RETURN
177 C
178 100       EGSCOR=EGSCOR+N                                   ! update eg score.
179           RETURN
180 C
181           END
182 C page
183 C FINDXT- Find exit from room
184 C
185 C Declarations
186 C
187           LOGICAL FUNCTION FINDXT(DIR,RM)
188           IMPLICIT INTEGER (A-Z)
189           %include dparam
190 C
191           FINDXT=.TRUE.                                     ! assume wins.
192           XI=REXIT(RM)                                      ! find first entry.
193           IF(XI.EQ.0) GO TO 1000                            ! no exits?
194 C
195 100       I=TRAVEL(XI)                                      ! get entry.
196 C old     XROOM1=I.AND.XRMASK                     ! isolate room.
197           XROOM1=AND(I,XRMASK)                              ! isolate room.
198 C old     XTYPE=(((I.AND..NOT.XLFLAG)/XFSHFT).AND.XFMASK)+1
199           XTYPE=AND(((AND(I,COMPL(XLFLAG)))/XFSHFT),XFMASK)+1
200           GO TO (110,120,130,130),XTYPE           ! branch on entry.
201           CALL BUG(10,XTYPE)
202 C
203 C old 130 XOBJ=TRAVEL(XI+2).AND.XRMASK            ! door/cexit- get obj/flag.
204 130       XOBJ=AND(TRAVEL(XI+2),XRMASK)           ! door/cexit- get obj/flag.
205           XACTIO=TRAVEL(XI+2)/XASHFT
206 120       XSTRNG=TRAVEL(XI+1)                     ! door/cexit/nexit - string.
207 110       XI=XI+XELNT(XTYPE)                      ! advance to next entry.
208 C old     IF((I.AND.XDMASK).EQ.DIR) RETURN        ! match?
209           IF(AND(I,XDMASK).EQ.DIR) RETURN         ! match?
210 C old     IF((I.AND.XLFLAG).EQ.0) GO TO 100       ! last entry?
211           IF(AND(I,XLFLAG).EQ.0) GO TO 100        ! last entry?
212 1000      FINDXT=.FALSE.                                    ! yes, lose.
213           RETURN
214 C
215           END