home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol047 / dso2.for < prev    next >
Encoding:
Text File  |  1984-04-29  |  7.4 KB  |  250 lines
  1. C MOVETO- MOVE PLAYER TO NEW ROOM
  2. C
  3. C COPYRIGHT 1980, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA. 02142
  4. C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
  5. C WRITTEN BY R. M. SUPNIK
  6. C
  7. C DECLARATIONS
  8. C
  9.     LOGICAL FUNCTION MOVETO(NR,WHO)
  10.     IMPLICIT INTEGER (A-Z)
  11.     LOGICAL NLV,LHR,LNR
  12. C
  13. C GAME STATE
  14. C
  15.     LOGICAL TELFLG
  16.     COMMON /PLAY/ WINNER,HERE,TELFLG
  17. C
  18. C ROOMS
  19. C
  20.     COMMON /ROOMS/ RLNT,RDESC2,RDESC1(200),REXIT(200),
  21.     1    RACTIO(200),RVAL(200),RFLAG(200)
  22.     INTEGER RRAND(200)
  23.     EQUIVALENCE (RVAL,RRAND)
  24. C
  25.     COMMON /RFLAG/ RSEEN,RLIGHT,RLAND,RWATER,RAIR,
  26.     1    RSACRD,RFILL,RMUNG,RBUCK,RHOUSE,RNWALL,REND
  27. C
  28. C OBJECTS
  29. C
  30.     COMMON /OBJCTS/ OLNT,ODESC1(220),ODESC2(220),ODESCO(220),
  31.     1    OACTIO(220),OFLAG1(220),OFLAG2(220),OFVAL(220),
  32.     2    OTVAL(220),OSIZE(220),OCAPAC(220),OROOM(220),
  33.     3    OADV(220),OCAN(220),OREAD(220)
  34. C
  35.     COMMON /OINDEX/ GARLI,FOOD,GUNK,COAL,MACHI,DIAMO,TCASE,BOTTL
  36.     COMMON /OINDEX/ WATER,ROPE,KNIFE,SWORD,LAMP,BLAMP,RUG
  37.     COMMON /OINDEX/    LEAVE,TROLL,AXE
  38.     COMMON /OINDEX/ RKNIF,KEYS,ICE,BAR
  39.     COMMON /OINDEX/ COFFI,TORCH,TBASK,FBASK,IRBOX
  40.     COMMON /OINDEX/ GHOST,TRUNK,BELL,BOOK,CANDL
  41.     COMMON /OINDEX/ MATCH,TUBE,PUTTY,WRENC,SCREW,CYCLO,CHALI
  42.     COMMON /OINDEX/ THIEF,STILL,WINDO,GRATE,DOOR
  43.     COMMON /OINDEX/ HPOLE,LEAK,RBUTT,RAILI
  44.     COMMON /OINDEX/ POT,STATU,IBOAT,DBOAT,PUMP,RBOAT
  45.     COMMON /OINDEX/ STICK,BUOY,SHOVE,BALLO,RECEP,GUANO
  46.     COMMON /OINDEX/ BROPE,HOOK1,HOOK2,SAFE,SSLOT,BRICK,FUSE
  47.     COMMON /OINDEX/ GNOME,BLABE,DBALL,TOMB
  48.     COMMON /OINDEX/ LCASE,CAGE,RCAGE,SPHER,SQBUT
  49.     COMMON /OINDEX/ FLASK,POOL,SAFFR,BUCKE,ECAKE,ORICE,RDICE,BLICE
  50.     COMMON /OINDEX/ ROBOT,FTREE,BILLS,PORTR,SCOL,ZGNOM
  51.     COMMON /OINDEX/ EGG,BEGG,BAUBL,CANAR,BCANA
  52.     COMMON /OINDEX/ YLWAL,RDWAL,PINDR,RBEAM
  53.     COMMON /OINDEX/ ODOOR,QDOOR,CDOOR,NUM1,NUM8
  54.     COMMON /OINDEX/ WARNI,CSLIT,GCARD,STLDR
  55.     COMMON /OINDEX/ HANDS,WALL,LUNGS,SAILO,AVIAT,TEETH
  56.     COMMON /OINDEX/ ITOBJ,EVERY,VALUA,OPLAY,WNORT,GWATE,MASTER
  57. C
  58. C ADVENTURERS
  59. C
  60.     COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
  61.     1    AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
  62. C
  63.     COMMON /AINDEX/ PLAYER,AROBOT,AMASTR
  64. C MOVETO, PAGE 2
  65. C
  66.     MOVETO=.FALSE.                !ASSUME FAILS.
  67.     LHR=(RFLAG(HERE).AND.RLAND).NE.0    !LAND  HERE FLAG.
  68.     LNR=(RFLAG(NR).AND.RLAND).NE.0        !LAND THERE FLAG.
  69.     J=AVEHIC(WHO)            !HIS VEHICLE
  70. C
  71.     IF(J.NE.0) GO TO 100            !IN VEHICLE?
  72.     IF(LNR) GO TO 500            !NO, GOING TO LAND?
  73.     CALL RSPEAK(427)            !CAN'T GO WITHOUT VEHICLE.
  74.     RETURN
  75. C
  76. 100    BITS=0                    !ASSUME NOWHERE.
  77.     IF(J.EQ.RBOAT) BITS=RWATER        !IN BOAT?
  78.     IF(J.EQ.BALLO) BITS=RAIR        !IN BALLOON?
  79.     IF(J.EQ.BUCKE) BITS=RBUCK        !IN BUCKET?
  80.     NLV=(RFLAG(NR).AND.BITS).EQ.0    !GOT WRONG VEHICLE FLAG.
  81.     IF((.NOT.LNR .AND.NLV) .OR.
  82.     1    (LNR.AND.LHR.AND.NLV.AND.(BITS.NE.RLAND)))
  83.     2    GO TO 800            !GOT WRONG VEHICLE?
  84. C
  85. 500    MOVETO=.TRUE.                !MOVE SHOULD SUCCEED.
  86.     IF((RFLAG(NR).AND.RMUNG).EQ.0) GO TO 600 !ROOM MUNGED?
  87.     CALL RSPEAK(RRAND(NR))            !YES, TELL HOW.
  88.     RETURN
  89. C
  90. 600    IF(WHO.NE.PLAYER) CALL NEWSTA(AOBJ(WHO),0,NR,0,0)
  91.     IF(J.NE.0) CALL NEWSTA(J,0,NR,0,0)
  92.     HERE=NR
  93.     AROOM(WHO)=HERE
  94.     CALL SCRUPD(RVAL(NR))            !SCORE ROOM
  95.     RVAL(NR)=0
  96.     RETURN
  97. C
  98. 800    CALL RSPSUB(428,ODESC2(J))        !WRONG VEHICLE.
  99.     RETURN
  100.     END
  101. C SCORE-- PRINT OUT CURRENT SCORE
  102. C
  103. C DECLARATIONS
  104. C
  105.     SUBROUTINE SCORE(FLG)
  106.     IMPLICIT INTEGER (A-Z)
  107.     LOGICAL FLG
  108.     INTEGER RANK(10),ERANK(5)
  109. C
  110. C GAME STATE
  111. C
  112.     LOGICAL TELFLG
  113.     COMMON /PLAY/ WINNER,HERE,TELFLG
  114.     COMMON /STATE/ MOVES,DEATHS,RWSCOR,MXSCOR,MXLOAD,
  115.     1    LTSHFT,BLOC,MUNGRM,HS,EGSCOR,EGMXSC
  116. C
  117.     COMMON /CHAN/ INPCH,OUTCH,DBCH
  118. C
  119. C ADVENTURERS
  120. C
  121.     COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
  122.     1    AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
  123. C
  124. C FLAGS
  125. C
  126.     LOGICAL*1 TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF
  127.     LOGICAL*1 DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF
  128.     LOGICAL*1 MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF
  129.     LOGICAL*1 EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF
  130.     LOGICAL*1 GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF
  131.     LOGICAL*1 GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF
  132.     LOGICAL*1 MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF
  133.     LOGICAL*1 FOLLWF,SPELLF,CPOUTF,CPUSHF
  134.     COMMON /FINDEX/ TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF,
  135.     1    DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF,
  136.     2    MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF,
  137.     3    EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF,
  138.     4    GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF,
  139.     5    GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF,
  140.     6    MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF,
  141.     7    FOLLWF,SPELLF,CPOUTF,CPUSHF
  142.     COMMON /FINDEX/ BTIEF,BINFF
  143.     COMMON /FINDEX/ RVMNT,RVCLR,RVCYC,RVSND,RVGUA
  144.     COMMON /FINDEX/ ORRUG,ORCAND,ORMTCH,ORLAMP
  145.     COMMON /FINDEX/ MDIR,MLOC,POLEUF
  146.     COMMON /FINDEX/ QUESNO,NQATT,CORRCT
  147.     COMMON /FINDEX/ LCELL,PNUMB,ACELL,DCELL,CPHERE
  148. C
  149. C FUNCTIONS AND DATA
  150. C
  151.     DATA RANK/20,19,18,16,12,8,4,2,1,0/
  152.     DATA ERANK/20,15,10,5,0/
  153. C SCORE, PAGE 2
  154. C
  155.     AS=ASCORE(WINNER)
  156.     IF(ENDGMF) GO TO 60            !ENDGAME?
  157.     IF(FLG) WRITE(OUTCH,100)
  158.     IF(.NOT.FLG) WRITE(OUTCH,110)
  159.     IF(MOVES.NE.1) WRITE(OUTCH,120) AS,MXSCOR,MOVES
  160.     IF(MOVES.EQ.1) WRITE(OUTCH,130) AS,MXSCOR,MOVES
  161.     DO 10 I=1,10
  162.       IF((AS*20/MXSCOR).GE.RANK(I)) GO TO 50
  163. 10    CONTINUE
  164. 50    CALL RSPEAK(484+I)
  165.     RETURN
  166. C
  167. 60    IF(FLG) WRITE(OUTCH,140)
  168.     IF(.NOT.FLG) WRITE(OUTCH,150)
  169.     WRITE(OUTCH,120) EGSCOR,EGMXSC,MOVES
  170.     DO 70 I=1,5
  171.       IF((EGSCOR*20/EGMXSC).GE.ERANK(I)) GO TO 80
  172. 70    CONTINUE
  173. 80    CALL RSPEAK(786+I)
  174.     RETURN
  175. C
  176. 100    FORMAT(' Your score would be',$)
  177. 110    FORMAT(' Your score is',$)
  178. 120    FORMAT('+',I4,' [total of',I4,' points], in',I5,' moves.')
  179. 130    FORMAT('+',I4,' [total of',I4,' points], in',I5,' move.')
  180. 140    FORMAT(' Your score in the endgame would be',$)
  181. 150    FORMAT(' Your score in the endgame is',$)
  182. C
  183.     END
  184. C SCRUPD- UPDATE WINNER'S SCORE
  185. C
  186. C DECLARATIONS
  187. C
  188.     SUBROUTINE SCRUPD(N)
  189.     IMPLICIT INTEGER (A-Z)
  190. C
  191. C GAME STATE
  192. C
  193.     LOGICAL TELFLG
  194.     COMMON /PLAY/ WINNER,HERE,TELFLG
  195.     COMMON /STATE/ MOVES,DEATHS,RWSCOR,MXSCOR,MXLOAD,
  196.     1    LTSHFT,BLOC,MUNGRM,HS,EGSCOR,EGMXSC
  197. C
  198. C CLOCK INTERRUPTS
  199. C
  200.     LOGICAL*1 CFLAG
  201.     COMMON /CEVENT/ CLNT,CTICK(25),CACTIO(25),CFLAG(25)
  202. C
  203.     COMMON /CINDEX/ CEVCUR,CEVMNT,CEVLNT,CEVMAT,CEVCND,
  204.     1    CEVBAL,CEVBRN,CEVFUS,CEVLED,CEVSAF,CEVVLG,
  205.     2    CEVGNO,CEVBUC,CEVSPH,CEVEGH,
  206.     3    CEVFOR,CEVSCL,CEVZGI,CEVZGO,CEVSTE,
  207.     5    CEVMRS,CEVPIN,CEVINQ,CEVFOL
  208. C
  209. C ADVENTURERS
  210. C
  211.     COMMON /ADVS/ ALNT,AROOM(4),ASCORE(4),AVEHIC(4),
  212.     1    AOBJ(4),AACTIO(4),ASTREN(4),AFLAG(4)
  213. C
  214. C FLAGS
  215. C
  216.     LOGICAL*1 TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF
  217.     LOGICAL*1 DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF
  218.     LOGICAL*1 MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF
  219.     LOGICAL*1 EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF
  220.     LOGICAL*1 GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF
  221.     LOGICAL*1 GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF
  222.     LOGICAL*1 MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF
  223.     LOGICAL*1 FOLLWF,SPELLF,CPOUTF,CPUSHF
  224.     COMMON /FINDEX/ TROLLF,CAGESF,BUCKTF,CAROFF,CAROZF,LWTIDF,
  225.     1    DOMEF,GLACRF,ECHOF,RIDDLF,LLDF,CYCLOF,
  226.     2    MAGICF,LITLDF,SAFEF,GNOMEF,GNODRF,MIRRMF,
  227.     3    EGYPTF,ONPOLF,BLABF,BRIEFF,SUPERF,BUOYF,
  228.     4    GRUNLF,GATEF,RAINBF,CAGETF,EMPTHF,DEFLAF,
  229.     5    GLACMF,FROBZF,ENDGMF,BADLKF,THFENF,SINGSF,
  230.     6    MRPSHF,MROPNF,WDOPNF,MR1F,MR2F,INQSTF,
  231.     7    FOLLWF,SPELLF,CPOUTF,CPUSHF
  232.     COMMON /FINDEX/ BTIEF,BINFF
  233.     COMMON /FINDEX/ RVMNT,RVCLR,RVCYC,RVSND,RVGUA
  234.     COMMON /FINDEX/ ORRUG,ORCAND,ORMTCH,ORLAMP
  235.     COMMON /FINDEX/ MDIR,MLOC,POLEUF
  236.     COMMON /FINDEX/ QUESNO,NQATT,CORRCT
  237.     COMMON /FINDEX/ LCELL,PNUMB,ACELL,DCELL,CPHERE
  238. C
  239.     IF(ENDGMF) GO TO 100            !ENDGAME?
  240.     ASCORE(WINNER)=ASCORE(WINNER)+N        !UPDATE SCORE
  241.     RWSCOR=RWSCOR+N                !UPDATE RAW SCORE
  242.     IF(ASCORE(WINNER).LT.(MXSCOR-(10*DEATHS))) RETURN
  243.     CFLAG(CEVEGH)=.TRUE.            !TURN ON END GAME
  244.     CTICK(CEVEGH)=15
  245.     RETURN
  246. C
  247. 100    EGSCOR=EGSCOR+N                !UPDATE EG SCORE.
  248.     RETURN
  249.     END
  250.