DEFINE(DIG0,48) # ASCII "0" PROGRAM PLAYER # # MAY 1980 BILL CAEL AND BILL WOOD RECODED IN RATFOR # MAY 1980 BILL CAEL AND BILL WOOD ADDED DEFAULT SHIP AND DIRECTION # MAY 1980 BILL WOOD ADDED ENERGY NETS # MAY 1980 BILL CAEL AND BILL WOOD RECODED OUTPUT # MAY 1980 BILL CAEL, BILL WOOD, AND BOB STODOLA # RECODED COMMAND ARG PROMPTING # NOV 1980 BILL WOOD CONVERTED TO RUN ON VAX # APR 1982 NAZARIO IRIZARRY, JR. CHANGED COMMAND ORDER TO RPN # MADE FADE NOT APPEAR ON "L" # SOME COMMANDS IMMEDIATE # INCLUDE COMMON.RAT LOGICAL*1 OK,DONE,YES,WARN,REFRES,REFTOG LOGICAL QUIKUP,LARG,LIMMED REAL SC(9),R(9) INTEGER DEFSHP,OLDSHP REAL DEFDIR,OLDDIR COMMON /DEFLTS/ DEFSHP,DEFDIR,OLDDIR,OLDSHP,DEFSHD LOGICAL CLEARF, VERBOS COMMON /MESS/ CLEARF,VERBOS BYTE BLANK(80),ALPHA,MESBUF(60) REAL D1(4) BYTE BLUNK(2) BYTE BLUNK2(2) BYTE OBUFF(-9:+9,-9:+9) BYTE JUNK, NBUFF COMMON /BNDRY/ IXX, IYY, ID, MINID8, JUNK, NBUFF(-9:+9, -9:+9) INTEGER COMMND INTEGER WHO EQUIVALENCE (BLUNK(2), NBUFF(-9, -9)) EQUIVALENCE (BLUNK2(2), OBUFF(-9, -9)) DATA COMMND/' '/ DATA BLANK/80*' '/ DATA BLUNK,BLUNK2/4*' '/ DATA SC/9*-9999./ DATA R/9*-9999./ DATA DONE/.FALSE./ DATA OK/.FALSE./ DATA DEFDIR/0.0/,DEFSHD/0.0/ DATA LIMMED/.FALSE./ IF (UPRATE <= 0) [ WRITE(5,('0MTREK 2 HAS NOT BEEN INITIALIZED; RUN MTREKINI.'/)) CALL EXIT ] # # QUIKUP IS SET TRUE IF TERMINAL SPEED EXCEEDS A THRESHOLD # DETERMINED IN GTCHAR. # IF QUIKUP IS TRUE, A FULL SCREEN UPDATE OCCURS EVERY "UPRATE" CLOCK TICKS; # AT SLOWER SPEEDS, 1/2 THE SCREEN IS UPDATED EVERY UPRATE*2 CLOCK TICKS # AND THE OTHER 1/2 IS UPDATED ALTERNATELY WITH THE FIRST HALF. # THIS ALLOWS ENJOYABLE GAMES ON TERMINALS AS SLOW AS 1200 BAUD. # CALL GTCHAR(QUIKUP) # GET QUIKUP, INITIALIZE TERMINAL IO WRITE(5,1001) 1001 FORMAT('0Welcome to MULTI-TREK.') REPEAT [ WRITE(5,1011) 1011 FORMAT('0The following vessels are available for use.') DO I=1,8 [ IF (!XSHIP(I)) [ WRITE(5,1021) I 1021 FORMAT(' Ship ',I1) ] ] WRITE(5,1031) 1031 FORMAT('$Enter the number of the vessel you wish to command:') ACCEPT *,IW OK = .TRUE. IF(IW>8 | IW<1) [ TYPE *,' Number out of range' OK = .FALSE. ] IF (OK) [ IF (IW == 0) [ OK = .FALSE. NEXT ] WHO=IW IF (XSHIP(WHO)) [ WRITE(5,1041) 1041 FORMAT('0This ship already has a commander.') WRITE(5,1051) 1051 FORMAT('$Do you wish to share this command? ') CALL YESNO(0,OK) ] ] ELSE CALL EXIT ] UNTIL (OK) REFRES = .TRUE. REFTOG = .FALSE. CREW(WHO)=CREW(WHO)+1 DEFSHP = WHO CALL STRMOV(BLUNK2,1,361,OBUFF,1) CALL RBUFF IF (!QUIKUP) CALL MARK(3,2*UPRATE,1,IDS) # START SLOW TIMER IF SLOW UPDATE CALL MARK(2,UPRATE,1,IDS) # START FAST TIMER REPEAT [ # # THE FOLLOWING CALL SPAWNS THE MTREKD UNIVERSE MANAGER TASK ON TT0:. # IF YOU CANNOT DO SOMETHING SIMILAR, YOU MUST START MTREKD YOURSELF # BEFORE PLAYING EACH GAME. # IF (THRU) [ # THEN MTREKD ISN'T RUNNING CALL RUNMTR ] # # PLACE LOCAL SCAN ON TERMINAL # REFTOG = (!REFTOG) | QUIKUP # IF ((XSHIP(WHO) & REFTOG & NNC<7) | REFRES) [ # DON'T REFRESH IF BLOWN UP! IF ((XSHIP(WHO) & REFTOG) | REFRES) [ # DON'T REFRESH IF BLOWN UP! CALL STRMOV(BLUNK,1,361,NBUFF,1) ID=SCAN(WHO) MINID8 = MIN(ID,8) IXX=XCORD(WHO) IYY=YCORD(WHO) IXLOW = MAX(2, IXX-ID) IXHI = MIN(99, IXX+ID) IYLOW = MAX(2, IYY-ID) IYHI = MIN(99, IYY+MINID8) DO IX1 = IXLOW, IXHI [ IX = IX1-IXX DO IY1 = IYLOW, IYHI [ IY = IY1-IYY ALPHA=UNIV(IX1,IY1) IF ((ALPHA >= DIG0+1) & (ALPHA <= DIG0+8) & (CLOAK(ALPHA-DIG0))) NBUFF(IX,IY)=EMPTY ELSE IF (ALPHA < 0) NBUFF(IX, IY) = '%' ELSE NBUFF(IX,IY)=ALPHA ] ] IF (IXX-ID <= 1) CALL BNDRY(1, 1, MAX(1, IYY-ID), MIN(100, IYY+MINID8)) ELSE IF (IXX+ID >= 100) CALL BNDRY(100, 100, MAX(1, IYY-ID), MIN(100, IYY+MINID8)) IF (IYY-ID <= 1) CALL BNDRY(MAX(1, IXX-ID), MIN(99, IXX+ID), 1, 1) ELSE IF (IYY+ID >= 100) CALL BNDRY(MAX(1, IXX-ID), MIN(99, IXX+ID), 100, 100) IF (NBUFF(-ID, -ID) == EMPTY) NBUFF(-ID, -ID) = '.' IF (NBUFF(-ID, MINID8) == EMPTY) NBUFF(-ID, MINID8) = '.' IF (NBUFF(ID, MINID8) == EMPTY) NBUFF(ID, MINID8) = '.' IF (NBUFF(ID, -ID) == EMPTY) NBUFF(ID, -ID) = '.' DO IY = -9, +8 [ ICURSX = -999 DO IX = -9, +9 [ IF (NBUFF(IX,IY) != OBUFF(IX,IY)) [ IF (ICURSX >= IX-2) [ DO III = ICURSX+1, IX [ CALL OUTCH(' ',1) CALL OUTCH(NBUFF(III, IY), 1) ] ] ELSE [ CALL TPOS(9 - IY, 2*IX + 43) CALL OUTCH(NBUFF(IX, IY), 1) ] ICURSX = IX OBUFF(IX, IY)=NBUFF(IX, IY) ] ] ] CALL OUTCH(0, -1) ] # # THE FOLLOWING WAIT CONTROLS THE UPDATE RATE, WHICH MAY BE # SLOW OR FAST, DEPENDING ON THE SPEED OF THE TERMINAL # DO NOT WAIT IF PREVIOUS COMMAND WAS AN IMMEDIATE COMMAND. # IF (COMMND != ' ' & XSHIP(WHO) & NNC < 7 & !LIMMED) [ IF (REFTOG) [ CALL WAITFR(2,IDS) IF (QUIKUP) CALL MARK(2,UPRATE,1,IDS) # RESTART FAST TIMER ] ELSE [ CALL WAITFR(3,IDS) CALL MARK(3,2*UPRATE,1,IDS) # RESTART SLOW TIMER CALL MARK(2,UPRATE,1,IDS) # RESTART FAST TIMER ] ] NC=1 LIMMED = .FALSE. IF (XSHIP(WHO)) [ CALL ARGCOM(COMMND,NNC) ] # # CHECK FOR NO INPUT # IF (COMMND == '0 ') ; # # LONG RANGE SCAN COMMAND # ELSE IF (COMMND == 'L ') [ CALL GETINT(II,OK,1,8,DEFSHP) IF (OK) [ LIMMED = .TRUE. DEFSHP = II IX=XCORD(II)/10. IY=YCORD(II)/10. CALL TPOS(17,75) ENCODE(5, 1071, MESBUF) IX, IY 1071 FORMAT(I2,',',I2) CALL OUTCH(MESBUF, 5) XX = XCORD(WHO) YY = YCORD(WHO) X1=XCORD(II) IF (X1 < 51.) [ X2=X1+100. ] ELSE [ X2=X1-100. ] Y1=YCORD(II) IF (Y1 < 51.) [ Y2=Y1+100. ] ELSE [ Y2=Y1-100. ] D1(1)=((XX-X1)**2 + (YY-Y1)**2)**.5 D1(2)=((XX-X1)**2 + (YY-Y2)**2)**.5 D1(3)=((XX-X2)**2 + (YY-Y1)**2)**.5 D1(4)=((XX-X2)**2 + (YY-Y2)**2)**.5 IIT=1 DO J=2,4 [ IF (D1(J) < D1(IIT)) [ IIT=J ] ] D=D1(IIT) IF (IIT == 1) [ YD=Y1 XD=X1 ] ELSE IF (IIT == 2) [ YD=Y2 XD=X1 ] ELSE IF (IIT == 3) [ YD=Y1 XD=X2 ] ELSE [ YD=Y2 XD=X2 ] EDIS=D EDIR=ATAN3((YD-YY),(XD-XX))*57.29577951 IF (EDIR < 0.) [ EDIR=EDIR+360. ] IF (EDIR > 90.) [ EDIR=(450.-EDIR)/30. ] ELSE [ EDIR=(90.-EDIR)/30. ] IF(!CLOAK(II)) [ CALL TPOS(16,75) DEFDIR = EDIR ENCODE(5, 1081, MESBUF) EDIS 1081 FORMAT(F5.2) CALL OUTCH(MESBUF, 5) CALL TPOS(15,75) ENCODE(5, 1091, MESBUF) EDIR 1091 FORMAT(F5.2) CALL OUTCH(MESBUF, 5) ] ELSE [ CALL TPOS(16,75) IF (EDIS<=15.) CALL OUTSTR(.FALSE.,'*WARN',.FALSE.) IF (15. ',.FALSE.) ] ELSE IF (4.5 0) [ CALL GETREL(VALUE,OK,0.,12.,DEFDIR) IF (OK) [ DEFDIR = VALUE IF (VALUE >= 3.) [ VALUE=(15.-VALUE)*30. ] ELSE [ VALUE=(3.-VALUE)*30. ] LAUNCH(WHO)=VALUE TORPS(WHO)=TORPS(WHO)-1 IF (TORPS(WHO) == 0) [ CALL MESSGE('LAST TORPEDO!') ] ] ] ELSE [ CALL MESSGE('NO TORPEDOES!') ] ] ELSE [ CALL MESSGE('TORPEDOES NOT READY') ] ] # # PHASER COMMAND # ELSE IF (COMMND == 'P ') [ IF (PHA(WHO) < 0.) [ CALL GETREL(VALUE,OK,0.,12.,DEFDIR) IF (OK) [ DEFDIR = VALUE IF (VALUE >= 3.) [ VALUE=(15.-VALUE)*30. ] ELSE [ VALUE=(3.-VALUE)*30. ] PHA(WHO)=VALUE ENERGY(WHO)=ENERGY(WHO)-50. ] ] ELSE [ CALL MESSGE('PHASERS NOT READY') ] ] # # HOMING TORPEDO LAUNCH # ELSE IF (COMMND == 'K ') [ IF (NHOM(WHO) == 4) [ TWHOM = 0. ] ELSE [ TWHOM = WHOM(WHO,NHOM(WHO)+1) ] IF (TWHOM >= 0.) [ IF (NHOM(WHO) > 0) [ CALL GETINT(II,OK,1,8,DEFSHP) IF (OK) [ DEFSHP = II IF (II == WHO) [ CALL MESSGE('TORPEDOES JAMMED!') NHOM(WHO)=0 TORPS(WHO)=0 ] ELSE IF(CLOAK(II)) [ CALL MESSGE('ENEMY CLOAKED') ] ELSE [ WHOM(WHO,NHOM(WHO))=-II NHOM(WHO)=NHOM(WHO)-1 ] ] ] ELSE [ CALL MESSGE('NO HOMERS!') ] ] ELSE [ CALL MESSGE('HOMERS NOT READY') ] ] # # WARP FACTOR COMMAND # ELSE IF (COMMND == 'W ') [ CALL GETREL(VALUE,OK,0.,8.,WARP(WHO)) IF (OK) [ LIMMED = .TRUE. WARP(WHO)=VALUE ] ] # # COURSE COMMAND # ELSE IF (COMMND == 'C ') [ CALL GETREL(VALUE,OK,0.,12.,DEFDIR) IF (OK) [ LIMMED = .TRUE. IF (VALUE >= 3.) [ DIR(WHO)=(15.-VALUE)*30. ] ELSE [ DIR(WHO)=(3.-VALUE)*30. ] ] ] # # EXPLODE ANTI-MATTER DEVICE # ELSE IF (COMMND == 'X ') [ IF (IPOD(WHO) == 2) [ IPOD(WHO)=3 CALL MESSGE('DETONATION SIGNALED') ] ELSE [ CALL MESSGE('NO POD!') ] ] # # CONVERT MOVING ANTI-MATTER POD TO A STATIC MINE # ELSE IF (COMMND == 'N ') [ IF (IPOD(WHO) == 2) [ WPOD(WHO)=0. CALL MESSGE('POD POSITIONED') ] ELSE [ CALL MESSGE('NO POD!') ] ] # # LAUNCH ANTI-MATTER DEVICE # ELSE IF (COMMND == 'Z ') [ IF (IPOD(WHO) == 0) [ CALL GETREL(VALUE,OK,0.,12.,DEFDIR) IF (OK) [ DEFDIR = VALUE IF (VALUE >= 3.) [ DPOD(WHO)=(15.-VALUE)*30. ] ELSE [ DPOD(WHO)=(3.-VALUE)*30. ] IPOD(WHO)=1 ] ] ELSE [ CALL MESSGE('NO POD!') ] ] # # HYPERSPACE COMMAND # ELSE IF (COMMND == 'H ') [ IUNIQ = HYPER(WHO) CALL GETINT(II,OK,1,6,IUNIQ) IF (OK) [ HYPER(WHO)=II ] ] # # SHIELD COMMAND # ELSE IF (COMMND == 'S ') [ CALL GETREL(VALUE,OK,-1.E36,1.E36,DEFSHD) IF (OK) [ LIMMED = .TRUE. IF (ENERGY(WHO)-VALUE >= 0. & SHIELD(WHO)+VALUE >= 0.) [ ENERGY(WHO)=ENERGY(WHO)-VALUE SHIELD(WHO)=SHIELD(WHO)+VALUE IF (VALUE.GE.0.0) DEFSHD = VALUE ] ELSE [ CALL MESSGE('?! IMPOSSIBLE !?') ] ] ] # # FLIP ENERGY NET ON OR OFF # ELSE IF (COMMND == 'E ') [ LIMMED = .TRUE. NET(WHO) = !NET(WHO) ] # # TRACTOR BEAM # ELSE IF (COMMND == 'B ') [ CALL GETINT(II,OK,0,8,DEFSHP) IF (OK) [ IF (II != 0) DEFSHP = II IF (II == WHO) CALL MESSGE('? HUH ?') ELSE TRBEAM(WHO) = II ] ] # # CLOAKING COMMAND # ELSE IF (COMMND == 'F ') [ IF (! CLOAK(WHO)) [ CLOAK(WHO)=.TRUE. ] ELSE [ CLOAK(WHO)=.FALSE. ] ] # # APPEAR COMMAND - LEFT IN FOR COMPATIBILITY # ELSE IF (COMMND == 'A ') [ IF (CLOAK(WHO)) [ CLOAK(WHO)=.FALSE. ] ELSE [ CALL MESSGE('NOT CLOAKED!') ] ] # # FLIP VERBOSE MESSAGES ON OR OFF # ELSE IF (COMMND == 'V ') [ VERBOS = !VERBOS ] # # REFRESH COMMAND # ELSE IF (COMMND == 'R ') [ CALL STRMOV(BLUNK2,1,361,OBUFF,1) CALL RBUFF DO I=1,9 [ SC(I)=-9999. R(I)=-9999. ] OLDSHP = 0 OLDDIR = -1.0 ] # # MESSAGE COMMAND # ELSE IF (COMMND == 'M ') [ CALL GETINT(IVAL,OK,0,8,DEFSHP) IF (OK) [ IF (IVAL != 0) [ IL = IVAL IH = IVAL ] ELSE [ IL = 1 IH = 8 ] CALL TPOS(24,1) CALL OUTCH(BLANK, 79) CALL TPOS(24,1) CALL OUTSTR(.FALSE., 'MESSAGE CAPTAIN? ', .FALSE.) CALL INCHAR(MESBUF(2), 59, .TRUE., -1, NC, IERR) CALL TPOS(1, 1) CALL OUTCH(0, 0) IF (IERR >= 0 & NC > 0) [ MESBUF(1) = WHO+DIG0 DO I = IL, IH IF (XSHIP(I)) [ IF (I != WHO) ENERGY(WHO)=ENERGY(WHO)-10. CALL STRMOV(MESBUF,1,NC+1,MESSAG,I*60-59) ] ] ] ] # # QUIT COMMAND # ELSE IF (COMMND == 'Q ') [ CALL YESNO('QUIT NOW? ',DONE) ] # # HELP COMMAND # ELSE IF (COMMND == '? ') [ CALL TPOS(19,1) CALL OUTSTR(.FALSE., 'B BEAMS M SEND MESSAGE T FIRE TORPEDOES', .TRUE.) CALL OUTSTR(.TRUE., 'C COURSE HEADING N FREEZE ANTI-MATTER W SET WARP SPEED', .TRUE.) CALL OUTSTR(.TRUE., 'F FADE/APPEAR (CLOAKING) P FIRE PHASERS X DETONATE ANTI-MATTER', .TRUE.) CALL OUTSTR(.TRUE., 'H HYPERSPACE SETTING Q QUIT Z LAUNCH ANTI-MATTER', .TRUE.) CALL OUTSTR(.TRUE., 'K FIRE HOMING TORPEDO R RESET DISPLAY V VERBOSE ON/OFF', .TRUE.) CALL OUTSTR(.TRUE., 'L LOCATE SHIP S SHIELD CHANGE E ENERGY NETS ON/OFF', .TRUE.) CALL TPOS(1,1) CALL OUTCH(0,0) ] # # ERROR # ELSE IF (COMMND != ' ') [ CALL MESSGE('?! WHAT !?') ] IF ((XSHIP(WHO) & REFTOG) | REFRES) [ CALL REFRSH(SC,R,WHO) ] IF (REFRES) [ XSHIP(WHO) = .TRUE. REFRES = .FALSE. REFTOG = .FALSE. ] # # WRITE OUT MESSAGES FROM DRIVER # DO I=1,10 [ IF (ISENT(WHO,I) != 0) [ J = ISENT(WHO,I) ISENT(WHO,I)=0 GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, 21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36), J 1 CONTINUE CALL MESSGE('DOCKED.') NEXT 2 CONTINUE CALL MESSGE('- HIT A STAR!') NEXT 3 CONTINUE DO IK=1,3 [ CALL CLEAR CALL OUTCH(0,0) WRITE(5,1131) 1131 FORMAT(////////////,25X,'*** BOOM ***') ] NNC = 0 WRITE(5,1141) 1141 FORMAT('0YOUR SHIP HAS BEEN DESTROYED'/, ' FORTUNATELY YOU ESCAPED WITH YOUR LIFE.'/, ' UNFORTUNATELY, YOU HAVE BEEN GIVEN A NEW COMMAND.'//, '$ARE YOU READY TO ACCEPT THIS ASSIGNMENT? ') CALL YESNO(0,YES) IF (YES) [ WRITE (5,1142) 1142 FORMAT(' GOOD!') CALL STRMOV(BLUNK2,1,361,OBUFF,1) CALL RBUFF DO K=1,9 [ SC(K)=-9999. R(K)=-9999. ] OLDDIR = -1.0 OLDSHP = 0 REFRES = .TRUE. ] ELSE [ DONE = .TRUE. ] NEXT 4 CONTINUE CALL MESSGE('- TORPEDO HIT US!') NEXT 5 CONTINUE CALL MESSGE('+ TORPEDO HIT ALIEN!') NEXT 6 CONTINUE CALL MESSGE('+ PHASER HIT ALIEN!') NEXT 7 CONTINUE CALL MESSGE('PHASER HIT TORPEDO') NEXT 8 CONTINUE CALL MESSGE('PHASERS MISSED') NEXT 9 CONTINUE CALL MESSGE('- RAMMED ALIEN!') NEXT 10 CONTINUE CALL MESSGE('- COLLISION!') NEXT 11 CONTINUE CALL MESSGE('PHASER HIT STAR') NEXT 12 CONTINUE CALL MESSGE('- BASE UNDER ATTACK') NEXT 13 CONTINUE CALL MESSGE('TORPEDO HIT STAR') NEXT 14 CONTINUE CALL MESSGE('- PHASER ATTACK!') NEXT 15 CONTINUE CALL TPOS(18,1) CALL OUTSTR(.FALSE., 'SPOCK HERE CAPTAIN. ', .TRUE.) CALL OUTSTR(.TRUE., 'WE ARE BEING DRAWN INTO SOME SORT OF BLACK HOLE,', .TRUE.) CALL OUTSTR(.TRUE., 'IT IS UNLIKE ANYTHING I HAVE EVER ENCOUNTERED.', .TRUE.) CALL OUTSTR(.TRUE., 'FASCINATING.', .TRUE.) CALL WAIT(1,2,M) NEXT 16 CONTINUE CALL TPOS(18,1) CALL OUTSTR(.FALSE., 'SCOTT HERE CAPTAIN. ', .TRUE.) CALL OUTSTR(.TRUE., 'OUR DYLITHIUM CRYSTALS ARE GONE. LIFE SUPPORT IS', .TRUE.) CALL OUTSTR(.TRUE., 'FAILING ...!', .TRUE.) CALL WAIT(1,2,M) NEXT 17 CONTINUE CALL MESSGE('HYPERSPACE!') NEXT 18 CONTINUE CALL MESSGE('HYPERSPACE BLOCKED!') NEXT 19 CONTINUE CALL MESSGE('RANDOM HYPERSPACE!') NEXT 20 CONTINUE CALL MESSGE('TORPEDO HIT TORPEDO') NEXT 21 CONTINUE CALL MESSGE('HIT GHOST SHIP') NEXT 22 CONTINUE CALL MESSGE('*** ALIEN DESTROYED!') CALL MESSGE('********************') NEXT 23 CONTINUE CALL MESSGE('POD BLOCKED!') NEXT 24 CONTINUE CALL MESSGE('POD DESTROYED!') NEXT 25 CONTINUE CALL MESSGE('PHASER HIT POD') NEXT 26 CONTINUE CALL MESSGE('TORPEDO HIT POD') NEXT 27 CONTINUE CALL MESSGE('- METAL OBJECT NEAR') NEXT 28 CONTINUE CALL MESSGE('POD LAUNCHED') NEXT 29 CONTINUE CALL MESSGE('POD DETONATED!') NEXT 30 CONTINUE CALL MESSGE('- POD EXPLOSION!') NEXT 31 CONTINUE CALL MESSGE('IIEEEEEE!') NEXT 32 CONTINUE CALL MESSGE('+ POD HIT ALIEN!') NEXT 33 CONTINUE CALL MESSGE('- HIT NET!') NEXT 34 CONTINUE CALL MESSGE('TORPEDO HIT NET') NEXT 35 CONTINUE CALL MESSGE('PHASER HIT NET') NEXT 36 CONTINUE CALL MESSGE('NET BLOCKED!') NEXT ] ] IF (MESSAG(WHO*60-59) != ' ') [ CALL TPOS(24,1) CALL OUTCH('MESSAGE FROM ', 13) MIND = WHO*60-59 CALL OUTCH(MESSAG(MIND), 1) CALL OUTCH(': ', 2) CALL OUTCH(MESSAG(MIND+1), 59) CALL TPOS(1, 1) CALL OUTCH(0, 0) CALL STRMOV(BLANK,1,60,MESSAG,MIND) ] IF ((ENERGY(WHO) < 900.) & WARN) [ CALL MESSGE('ENERGY LOW!') WARN=.FALSE. ] ELSE [ WARN=.TRUE. ] CALL MESSGE(0) ] UNTIL (DONE) CREW(WHO)=CREW(WHO)-1 IF (CREW(WHO) <= 400) [ XSHIP(WHO) = .FALSE. ] ELSE [ XSHIP(WHO) = .TRUE. ] CALL CLEAR CALL OUTCH(0,0) CALL EXIT END SUBROUTINE RBUFF COMMON /MESS/ CLEARF LOGICAL CLEARF CALL CLEAR CLEARF = .FALSE. # # DRAW NEW SCREEN # CALL BUFFIL(2,4,'Energy :',10) CALL BUFFIL(3,4,'Shields :',10) CALL BUFFIL(5,4,'Warp :',10) CALL BUFFIL(6,4,'Course :',10) CALL BUFFIL(8,4,'X co-ord :',10) CALL BUFFIL(9,4,'Y co-ord :',10) CALL BUFFIL(11,4,'Torps :',10) CALL BUFFIL(12,4,'Seekers :',10) CALL BUFFIL(13,4,'Hyper :',10) CALL BUFFIL(15,4,'Def Ship :',10) CALL BUFFIL(16,4,'Def Direc:',10) CALL BUFFIL(2,71,'Scores',6) CALL BUFFIL(4,69,'1',1) CALL BUFFIL(5,69,'2',1) CALL BUFFIL(6,69,'3',1) CALL BUFFIL(7,69,'4',1) CALL BUFFIL(8,69,'5',1) CALL BUFFIL(9,69,'6',1) CALL BUFFIL(10,69,'7',1) CALL BUFFIL(11,69,'8',1) CALL BUFFIL(14,69,'Scan:',5) CALL BUFFIL(15,69,'Dir :',5) CALL BUFFIL(16,69,'Dist:',5) CALL BUFFIL(17,69,'Sect:',5) CALL OUTCH(0,0) RETURN END SUBROUTINE REFRSH(SC,R,I) INCLUDE COMMON.RAT REAL SC(8),R(9) BYTE STRNG(10) BYTE ACT(8) INTEGER DEFSHP,OLDSHP REAL DEFDIR,OLDDIR COMMON /DEFLTS/ DEFSHP,DEFDIR,OLDDIR,OLDSHP DATA ACT/8*' '/, OLDSHP/0/, OLDDIR/-1.0/ IF (R(1) != ENERGY(I)) [ R(1)=ENERGY(I) ENCODE(7,1001,STRNG) R(1) 1001 FORMAT(F7.1) CALL BUFFIL(2,15,STRNG,7) ] IF (R(2) != SHIELD(I)) [ R(2)=SHIELD(I) ENCODE(7,1011,STRNG) R(2) 1011 FORMAT(F7.1) CALL BUFFIL(3,15,STRNG,7) ] IF (R(3) != WARP(I)) [ R(3)=WARP(I) ENCODE(4,1021,STRNG) R(3) 1021 FORMAT(F4.2) CALL BUFFIL(5,18,STRNG,4) ] IF (R(4) != DIR(I)) [ R(4)=DIR(I) IF (R(4) > 90.) [ V=(450.-R(4))/30. ] ELSE [ V=(90.-R(4))/30. ] ENCODE(5,1031,STRNG) V 1031 FORMAT(F5.2) CALL BUFFIL(6,17,STRNG,5) ] IF (R(5) != XCORD(I)) [ R(5)=XCORD(I) ENCODE(5,1041,STRNG) R(5) 1041 FORMAT(F5.1) CALL BUFFIL(8,17,STRNG,5) ] IF (R(6) != YCORD(I)) [ R(6)=YCORD(I) ENCODE(5,1051,STRNG) R(6) 1051 FORMAT(F5.1) CALL BUFFIL(9,17,STRNG,5) ] IR=R(7) IF (IR != TORPS(I)) [ R(7)=TORPS(I) ENCODE(2,1061,STRNG) TORPS(I) 1061 FORMAT(I2) CALL BUFFIL(11,20,STRNG,2) ] IR=R(8) IF (IR != NHOM(I)) [ R(8)=NHOM(I) ENCODE(2,1071,STRNG) NHOM(I) 1071 FORMAT(I2) CALL BUFFIL(12,20,STRNG,2) ] IR=R(9) IF (IR != HYPER(I)) [ R(9)=HYPER(I) ENCODE(1,1081,STRNG) HYPER(I) 1081 FORMAT(I1) CALL BUFFIL(13,21,STRNG,1) ] IF (OLDSHP != DEFSHP) [ OLDSHP = DEFSHP ENCODE(1,1091,STRNG) OLDSHP 1091 FORMAT(I1) CALL BUFFIL(15,21,STRNG,1) ] IF (OLDDIR != DEFDIR) [ OLDDIR = DEFDIR ENCODE(5,1101,STRNG) DEFDIR 1101 FORMAT(F5.2) CALL BUFFIL(16,17,STRNG,5) ] DO J=1,8 [ IF ((SC(J) != SCORE(J)) | (XSHIP(J) .XOR. (ACT(J) == '*'))) [ IF (XSHIP(J)) ACT(J) = '*' ELSE ACT(J) = ' ' SC(J)=SCORE(J) ENCODE(10,1111,STRNG) SC(J), ACT(J) 1111 FORMAT(F8.0,1X,A1) CALL BUFFIL(J+3,71,STRNG,10) ] ] CALL OUTCH(0,-1) RETURN END SUBROUTINE BUFFIL(IY,IX,ST,L) BYTE ST(1) CALL TPOS(IY, IX) CALL OUTCH(ST,L) RETURN END SUBROUTINE REDPMT(PROMPT,INPUT,NINPUT,NCHRS) # # DO A READ WITHOUT PROMPT AND WITHOUT ECHO; IF NO INPUT IS RECEIVED AFTER 1/2 # SECOND, ISSUE THE PROMPT, THEN READ WITH NO TIMEOUT AND WITH ECHO. # IF A PROMPT IS ISSUED, IT AND THE INPUT IS ERASED TO BLANKS AFTER # THE READ. # # THIS ROUTINE COULD DO A SIMPLE PROMPT AND READ AFTER POSITIONING # TO (PRMPTY, PRMPTX), FOLLOWED BY ERASING THE PROMPT AND INPUT # TO BLANKS, IF NECCESSARY ON YOUR SYSTEM. # IMPLICIT INTEGER (A - Z) PARAMETER MAXPRM = 20 PARAMETER PRMPTY = 18, PRMPTX = 1, PRMPTL = 24, CR = 13 BYTE PROMPT(1), INPUT(NINPUT), BLANKS(PRMPTL) LOGICAL ECHO DATA BLANKS/PRMPTL*' '/ NCHRS = 0 ECHO = .TRUE. IF (PROMPT(1) != 0) [ # IF PROMPT IS NOT NULL... CALL INCHAR(INPUT,NINPUT,.FALSE.,0,NC,IERR) # GET TYPE AHEAD IF (IERR == -1) # EOF? GO TO 999 NCHRS = NCHRS+NC IF (IERR == CR) RETURN # DONE? CALL WAIT(30,0,DSW) # WAIT 1/2 SEC, THEN READ AGAIN CALL INCHAR(INPUT(NCHRS+1),NINPUT-NCHRS,.FALSE.,0,NC,IERR) IF (IERR == -1) # EOF? GO TO 999 NCHRS = NCHRS+NC IF (IERR == CR) RETURN # DONE? IF (NCHRS == 0) [ # THEN ISSUE PROMPT FOR (LEN = 1; LEN <= MAXPRM & PROMPT(LEN) != 0; LEN = LEN+1) ; CALL TPOS(PRMPTY, PRMPTX) CALL OUTCH(PROMPT,LEN-1) ] ELSE ECHO = .FALSE. ] CALL INCHAR(INPUT(NCHRS+1),NINPUT-NCHRS,ECHO,-1,NC,IERR) IF (PROMPT(1) != 0 & NCHRS == 0) [ # THEN ERASE PROMPT STRNG CALL TPOS(PRMPTY, PRMPTX) CALL OUTCH(BLANKS,PRMPTL) ] IF (IERR == -1) # EOF? GO TO 999 NCHRS = NCHRS+NC RETURN 999 CONTINUE NCHRS = -1 RETURN END DEFINE(CR,13) SUBROUTINE YESNO(PROMPT,FLAG) LOGICAL*1 FLAG,OK BYTE PROMPT(1) BYTE ANSWER(4) # OK=.FALSE. ANSWER(1) = 0 CALL REDPMT(PROMPT,ANSWER,4,NCHRS) REPEAT [ IF (NCHRS <= 0) [ NCHRS = 1 ANSWER(1) = 0 ] IF (ANSWER(1) >= 'a' & ANSWER(1) <= 'z') ANSWER(1) = (ANSWER(1) - 'a') + 'A' # * CHECK FOR YES IF (ANSWER(1) == 'Y') [ FLAG=.TRUE. OK=.TRUE. ] # * CHECK FOR A NO ELSE IF (ANSWER(1) == 'N') [ FLAG=.FALSE. OK=.TRUE. ] # * INCORRECT RESPONSE ELSE [ IF (PROMPT(1) == 0) [ CALL OUTCH(CR, 1) CALL OUTSTR(.TRUE., 'ANSWER YES OR NO? ', .FALSE.) CALL INCHAR(ANSWER, 4, .TRUE., -1, NCHRS, IER) ] ELSE [ CALL REDPMT('ANSWER YES OR NO? ',ANSWER,4,NCHRS) ] ] ] UNTIL (OK) RETURN END DEFINE(LF,10) SUBROUTINE OUTSTR(LFFLAG, STRNG, CRFLAG) LOGICAL LFFLAG, CRFLAG BYTE STRNG(1) FOR (LEN = 0; STRNG(LEN+1) != 0; LEN = LEN+1) ; IF (LFFLAG) CALL OUTCH(LF, 1) CALL OUTCH(STRNG, LEN) IF (CRFLAG) CALL OUTCH(0, -1) ELSE CALL OUTCH(0, 0) RETURN END SUBROUTINE BNDRY(IXLOW, IXHI, IYLOW, IYHI) INCLUDE COMMON.RAT BYTE ALPHA BYTE JUNK, NBUFF COMMON /BNDRY/ IXX, IYY, ID, MINID8, JUNK, NBUFF(-9:+9, -9:+9) DO IX1 = IXLOW, IXHI [ IX = IX1-IXX DO IY1 = IYLOW, IYHI [ IY = IY1-IYY ALPHA = UNIV(IX1, IY1) IF (ALPHA == EMPTY) [ IF (((IX == -ID | IX == ID | IX == 0) & (IY1 == 100 | IY1 == 1)) | ((IY == -ID | IY == MINID8 | IY == 0) & (IX1 == 100 | IX1 == 1))) NBUFF(IX,IY)='-' ] ELSE IF ((ALPHA >= DIG0+1) & (ALPHA <= DIG0+8) & (CLOAK(ALPHA-DIG0))) NBUFF(IX,IY)=EMPTY ELSE IF (ALPHA < 0) NBUFF(IX, IY) = '%' ELSE NBUFF(IX,IY)=ALPHA ] ] RETURN END SUBROUTINE ARGCOM(COM,NUMPOS) BYTE STR(20),INBUF(40),COM,IA LOGICAL OK REAL ARG COMMON/NFNF/ARG,OK # # ACCEPTS COMMANDS IN THE FORMAT [] # NO CARRIAGE RETURN IS NEEDED TO TERMINATE THE LINE # OK = .FALSE. COM = '0' CALL INCHAR(STR,20,.FALSE.,0,NC,IERR) IF(NC != 0)[ DO I = 1,NC [ IF (NUMPOS < 14)[ NUMPOS = NUMPOS + 1 IA = STR(I) IF(IA>='a' & IA<='z')IA = (IA-'a') + 'A' INBUF(NUMPOS) = IA IF(IA == ' ')NUMPOS = 0 ] ] ] IF(NUMPOS != 0) [ DO I =1,NUMPOS [ IA = INBUF(I) IF(!(('0'<=IA & IA<='9')|IA=='.'|IA=='-'))[ IF(I == 1) [ ARG = 1. COM = INBUF(I) OK = .FALSE. IF(NUMPOS > 1) DO J =2, NUMPOS [ INBUF(J-1) = INBUF(J) ] NUMPOS = NUMPOS - 1 RETURN ] ELSE [ DECODE(I-1,500,INBUF,ERR=990)ARG 500 FORMAT(G15.0) COM = INBUF(I) OK = .TRUE. IF(NUMPOS > I) DO J=I+1,NUMPOS [ INBUF(J-I) = INBUF(J) ] NUMPOS = NUMPOS - I RETURN ] ] ] ] RETURN # # ERR # 990 DO J =I, NUMPOS [ INBUF(J-I+1) = INBUF(J) ] NUMPOS = NUMPOS - I COM = '0' RETURN # END SUBROUTINE GETREL(V,EXIST,LOW,HIGH,DEFVAL) LOGICAL*1 EXIST,OK REAL V,LOW,HIGH,DEFVAL BYTE INPUT(15) INTEGER NCHRS LOGICAL LGOOD REAL VALUE COMMON/NFNF/VALUE,LGOOD # # V = DEFVAL IF(LGOOD) V = VALUE # # CHECK RANGE # V = AMAX1(V,LOW) V = AMIN1(V,HIGH) EXIST = .TRUE. RETURN END SUBROUTINE GETINT(N,FLAG,LOW,HIGH,DEFVAL) INTEGER N,LOW,HIGH,DEFVAL LOGICAL*1 OK,FLAG BYTE INPUT(15) LOGICAL LGOOD REAL VALUE COMMON/NFNF/VALUE,LGOOD # # N = DEFVAL IF(LGOOD) N = VALUE # # CHECK RANGE # N = MAX0(N,LOW) N = MIN0(N,HIGH) FLAG = .TRUE. RETURN END