PROGRAM STARTRK C********************************************************************* C* * C* THE STAR TREK GAME * C* BY * C* DAVID MATUSZEK AND PAUL REYNOLDS * C* * C* WITH MODIFICATIONS AND ADDITIONS BY * C* DON SMITH * C* * C* * C* PERMISSION IS HEREBY GRANTED FOR THE COPYING, * C* DISTRIBUTION, MODIFICATION AND USE OF THIS PROGRAM AND * C* ASSOCIATED DOCUMENTATION FOR RECREATIONAL PURPOSES, * C* PROVIDED THAT ALL REFERENCES TO THE AUTHORS ARE RETAINED. * C* HOWEVER, PERMISSION IS NOT AND WILL NOT BE GRANTED FOR * C* THE SALE OR PROMOTIONAL USE OF THIS PROGRAM OR PROGRAM * C* DOCUMENTATION, OR FOR USE IN ANY SITUATION IN WHICH * C* PROFIT MAY BE CONSIDERED AN OBJECTIVE, SINCE IT IS THE * C* DESIRE OF THE AUTHORS TO RESPECT THE COPYRIGHTS OF THE * C* ORIGINATORS OF STAR TREK. * C* * C********************************************************************* C*BEGIN COMMON COMMON SNAP,SNAPSHT(226), + DATE,REMKL,REMCOM,REMBASE,REMRES,REMTIME,STARKL,BASEKL, + KILLK,KILLC,GALAXY(8,8),CX(10),CY(10),BASEQX(5),BASEQY(5), + NEWSTUF(8,8),PLNETS(10,5),ISX,ISY,NSCREM,NROMKL,NROMREM, + NSCKILL,ICRYSTL,NPLANKL, + QUAD(10,10),KX(20),KY(20),KPOWER(20),KDIST(20),KSTUF(20), + INKLING,INBASE,INRESOR,INCOM,INTIME,INSTAR,INENRG,INSHLD, + INTORPS,INLSR,INDATE,ENERGY,SHLD,SHLDUP,CONDIT,TORPS,SHIP, + QUADX,QUADY,SECTX,SECTY,WARPFAC,WFACSQ,LSUPRES,DAMAGE(20), + LENGTH,SKILL,PASSWD,DIST,DIREC,TIME,BASEX,BASEY,DOCKFAC, + KLHERE,COMHERE,CASUAL,NHELP,NKINKS,STARCH(8,8),FUTURE(10), + DEVICE(2,14),IDIDIT,GAMEWON,ALIVE,JUSTIN,RESTING,ALLDONE, + DAMFAC,SHLDCHG,THINGX,THINGY,NDEVICE,PLNETX,PLNETY,INORBIT, + LANDED,IPLANET,IMINE,INPLAN,NENHERE,ISHERE,NEUTZ,IRHERE,ICRAFT, + IENTESC,ISCRAFT,ISATB,ISCATE,CRYPROB,ICITE,IPHWHO,BATX,BATY, + CRACKS(12) INTEGER CF,CI,SHLDUP,CONDIT,QUADX,QUADY,SECTX,SECTY,TORPS, + REMKL,REMBASE,SKILL,REMCOM,GALAXY,STARCH,CX,CY, + SHIP,ALLDONE,BASEQX,BASEQY,BASEX,BASEY,GAMEWON, + ALIVE,STARKL,BASEKL,CASUAL,COMHERE,RESTING,SNAP,SHLDCHG, + THINGX,THINGY,BATX,BATY,PLNETX,PLNETY,PLNETS REAL KDIST,KPOWER,LSUPRES,INTIME,INRESOR,INDATE,INSHLD, + INENRG,INLSR BYTE QUAD REAL*8 DEVICE,PASSWD C*END COMMON LOGICAL*1 IHS,IHR,IHC,IHK,IHE,IHF,IHBLANK,IHDOT,IHP,IHB 1 ,IHSTAR,IHT,IHQUEST,IHNUM COMMON/HOLLER/IHEOL,IHREAL,IHALPHA,IHS,IHR,IHC,IHK,IHGREEN,IHRED, +IHYELLO,IHDOCKD,IHE,IHF,IHBLANK,IHDOT,IHQUEST,IHP,IHSTAR,IHB +,IHT,IHNUM COMMON /RAN/IRAN1,IRAN2 INTEGER XOR ,CROP LOGICAL FROZEN REAL*8 ITEM,HELPX,TERM,ABAN,DEST,FREE,DEATH,AITEM REAL*8 COMMAND(21) COMMON/SCANBF/KEY,AITEM EQUIVALENCE (AITEM,ITEM) EQUIVALENCE (CRACKS(6),KDIDIT) DATA COMMAND/6HSRSCAN,6HLRSCAN,7HPHASERS,7HPHOTONS,4HMOVE, + 7HSHIELDS,4HDOCK,7HDAMAGES,5HCHART,7HIMPULSE,4HREST,4HWARP, + 6HSTATUS,7HSENSORS,5HORBIT,8HTRANSPOR,4HMINE,8HCRYSTALS, + 7HSHUTTLE,7HPLANETS,7HREQUEST/ DATA IHEOL,IHREAL,IHALPHA,IHS,IHR,IHC,IHK,IHGREEN,IHRED,IHYELLO, +IHDOCKD,IHE,IHF,IHBLANK,IHDOT,IHQUEST,IHP,IHSTAR,IHB/2HEO,2HRE, +2HAL,1HS,1HR,1HC,1HK,2HGR,2HRE,2HYE,2HDO,1HE,1HF, +1H ,1H.,1H?,1HP,1H*,1HB/ DATA IHT,IHNUM/1HT,1H#/ DATA DEVICE/8HS. R. SE,5HNSORS,8HL. R. SE,5HNSORS, 1 7HPHASERS,1H ,8HPHOTON T,4HUBES,8HLIFE SUP,4HPORT, 2 8HWARP ENG,4HINES,8HIMPULSE ,7HENGINES,7HSHIELDS,1H , 3 8HSUBSPACE,6H RADIO,8HSHUTTLE ,5HCRAFT,8HCOMPUTER,1H , 4 8HTRANSPOR,3HTER,8HSHIELD C,6HONTROL,8HDEATHRAY, 5 1H / DATA HELPX,TERM,ABAN,DEST,FREE,DEATH/'HELP','TERMINAT', 1 'ABANDON','DESTRUCT','FREEZE','DEATHRAY'/ NDEVICE=14 ICITE=0 C--------PRINT OUT PRELIMINARY MESSAGES CALL PRELIM C--------INITIALIZE AND START NEW GAME 10 CALL CHOOSE(FROZEN) IF(FROZEN) GOTO 15 CALL SETUP C--------REQUEST NEW COMMAND AND BRANCH TO CODE FOR THAT COMMAND 15 MOVED=0 20 IF(ALLDONE.NE.0) GO TO 9999 JUSTIN=0 TIME=0. KDIDIT=0 CALL PROMPT(10HCOMMAND: ,10) CALL SCAN DO 30 L=1,21 IF(CROP(ITEM,COMMAND(L))) + GO TO (100,200,300,400,500,600,700,800,900,1000, + 1100,1200,1300,1400,1450,1500,1550,1600,1650,1670,1680),L 30 CONTINUE IF(ITEM .EQ. HELPX ) GO TO 1700 IF(ITEM .EQ. TERM) GO TO 9000 IF(ITEM .EQ. ABAN ) GO TO 1900 IF(ITEM .EQ. DEST ) GO TO 2000 IF(ITEM .EQ. FREE ) GO TO 2100 IF(ITEM .EQ. DEATH ) GO TO 2200 IF(KEY .NE. 3HEOL) GO TO 40 CALL PROUT(18HBLANK LINE IGNORED,18) GO TO 20 40 CALL PROUT( + 42HUNRECOGNIZED COMMAND. LEGAL COMMANDS ARE:,42) CALL PROUT( + 37H SRSCAN MOVE PHASERS HELP,37) CALL PROUT( + 41H STATUS IMPULSE PHOTONS ABANDON ,41) CALL PROUT( + 41H LRSCAN WARP SHIELDS DESTRUCT,41) CALL PROUT( + 42H CHART REST DOCK TERMINATE,42) CALL PROUT( + 38H DAMAGES FREEZE SENSORS ORBIT,38) CALL PROUT( + 41H TRANSPORT MINE CRYSTALS SHUTTLE ,41) CALL PROUT( + 31H PLANETS REQUEST DEATHRAY,31) GO TO 20 C--------SHORT RANGE SCAN 100 CALL SRSCAN GO TO 20 C--------LONG RANGE SCAN 200 CALL LRSCAN GO TO 20 C--------FIRE PHASERS 300 CALL PHASERS 305 IF(IDIDIT .EQ. 0) GO TO 20 310 CALL ATTACK 320 IF(KDIDIT.NE.0) GO TO 2500 GO TO 15 C--------FIRE PHOTON TORPEDOS 400 CALL PHOTONS 410 IF(IDIDIT .EQ. 0) GO TO 20 MOVED=0 GO TO 2500 C--------MOVE UNDER WARP DRIVE 500 IF(MOVED .EQ. 0) GO TO 510 505 MOVED=2 510 CALL WARP 520 IF((IDIDIT.EQ.0).AND.(MOVED.EQ.2)) MOVED=1 IF(IDIDIT.EQ.0) GO TO 20 IF((MOVED.EQ.2).AND.(JUSTIN.EQ.0)) CALL ATTACK MOVED=1 GO TO 2500 C--------RAISE OR LOWER DEFLECTOR SHIELDS 600 CALL SHIELDS IF(IDIDIT .EQ. 0) GO TO 20 CALL ATTACK SHLDCHG=0 GO TO 320 C--------DOCK AT STARBASE 700 CALL DOCK IF(IDIDIT.NE.0) GO TO 310 GO TO 20 C--------LOOK AT DAMAGE REPORT 800 CALL DREPORT GO TO 20 C--------LOOK AT STAR CHART 900 CALL CHART GO TO 20 C--------MOVE UNDER IMPULSE POWER 1000 IF(MOVED.NE.0) GO TO 505 CALL IMPULSE GO TO 520 C--------REST AND REPAIR 1100 CALL WAIT GO TO 410 C--------CHANGE WARP FACTOR 1200 CALL SETWARP GO TO 20 C--------ASK FOR STATUS INFORMATION 1300 CALL STATUS GO TO 20 C--------GET A SENSOR SCAN OF QUADRANT. 1400 CALL SENSOR GO TO 20 C--------ENTER STANDARD ORBIT. 1450 CALL ORBIT GO TO 410 C--------TRANSPORT SOMEBODY SOMEWHERE. 1500 CALL BEAM GO TO 20 C--------DO A LITTLE DIGGING. 1550 CALL MINE GO TO 410 C--------LOAD SOME CRYSTALS (AND HOPE FOR THE BEST.) 1600 CALL CRYSTAL GO TO 20 C--------GO FOR A SPIN IN GALILEO. 1650 CALL GALILEO GO TO 410 C--------GET A PLANET LIST 1670 CALL PLANET GO TO 20 C--------INDIVIDUAL PIECE OF INFORMATION FROM STATUS REQUESTED. 1680 CALL REQUEST GO TO 20 C--------CALL STARBASE FOR HELP 1700 CALL HELP GO TO 20 C--------ABANDON SHIP 1900 CALL ABANDON GO TO 20 C--------SELF-DESTRUCT 2000 CALL DESTRCT GO TO 20 C--------FREEZE THE CURRENT GAME 2100 CALL FREEZE IF(IDIDIT.EQ.1) GO TO 9999 GO TO 20 C--------TRY A DESPERATION MEASURE 2200 CALL DEATHRA GO TO 305 C--------AFTER COMMANDS WHICH MAY USE TIME, DO CHECKING 2500 IF(ALLDONE.NE.0) GO TO 9999 IF(TIME .NE. 0.) CALL EVENTS IF(ALLDONE.NE.0) GO TO 9999 IF(GALAXY(QUADX,QUADY) .NE. 1000) GO TO 2510 CALL AUTOVER KDIDIT=0 MOVED=0 GO TO 2500 C--------CHECK FOR MOVE AND FIRE OPTION 2510 IF(NENHERE.EQ.0) CALL MOVETHO IF(KDIDIT .EQ. 1 .OR. NENHERE .EQ. 0) GO TO 15 IF(MOVED .EQ. 0 .OR. JUSTIN .EQ. 1) GO TO 310 GO TO 20 C--------GAME HAS ENDED. START NEW GAME OR FINALIZE. 9000 CALL SCORE 9999 CALL SKIP(2) CALL STARS CALL SKIP(1) CALL PROMPT(30HDO YOU WANT TO PLAY AGAIN? ,30) IF(JA(DUMMY)) GO TO 10 CALL SKIP(1) CALL PROUT( + 48HMAY THE GREAT BIRD OF THE GALAXY ROOST UPON YOUR,48) CALL PROUT(12HHOME PLANET.,12) CALL SKIP(1) IF(ICITE .EQ. 0) GO TO 99999 CALL PROUT(52HDON'T FORGET TO TYPE TO RECEIVE YOUR CITATION. C,52) 99999 END