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 # INCLUDE COMMON.RAT LOGICAL*1 OK,DONE,YES,WARN,REFRES,REFTOG LOGICAL QUIKUP 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 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/ # # QUIKUP IS SET TRUE IF TERMINAL SPEED EXCEEDS A THRESHOLD # DETERMINED IN GTCHAR. # IF QUIKUP IS TRUE, A FULL SCREEN UPDATE OCCURS EVERY 1/2 SECOND; # AT SLOWER SPEEDS, 1/2 THE SCREEN IS UPDATED EVERY SECOND ON THE # HALF SECOND, THE OTHER 1/2 IS UPDATED EVERY SECOND ON THE SECOND. # 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 AVAILIABLE 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: ') CALL GETINT(0,IW,OK,1,8,0) 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,60,1,IDS) # START 1 SECOND TIMER IF SLOW UPDATE CALL MARK(2,30,1,IDS) # START 1/2 SECOND 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) | 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 IS NORMALLY # SET TO A HALF SECOND (30 CLOCK TICKS). # IF (COMMND != ' ' & XSHIP(WHO)) [ IF (REFTOG) [ CALL WAITFR(2,IDS) IF (QUIKUP) CALL MARK(2,30,1,IDS) # RESTART 1/2 SECOND TIMER ] ELSE [ CALL WAITFR(3,IDS) CALL MARK(3,60,1,IDS) # RESTART 1 SECOND TIMER CALL MARK(2,30,1,IDS) # RESTART 1/2 SECOND TIMER ] ] NC=1 COMMND='0 ' IF (XSHIP(WHO)) [ CALL TREAD(COMMND,NC) ] # # CHECK FOR NO INPUT # IF (COMMND == '0 ') ; # # LONG RANGE SCAN COMMAND # ELSE IF (COMMND == 'L ') [ CALL GETINT('FREQUENCY? ',II,OK,1,8,DEFSHP) IF (OK) [ 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. ] DEFDIR = EDIR CALL TPOS(16,75) 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) CALL TPOS(14,79) ENCODE(1, 1101, MESBUF) DEFSHP 1101 FORMAT(I1) CALL OUTCH(MESBUF, 1) CALL OUTCH(0, -1) ] ] # # TORPEDO COMMAND # ELSE IF (COMMND == 'T ') [ IF (LAUNCH(WHO) < 0.) [ IF (TORPS(WHO) > 0) [ CALL GETREL('TORPEDO COURSE? ',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('PHASER COURSE? ',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('HOMING FREQUENCY? ',II,OK,1,8,DEFSHP) IF (OK) [ DEFSHP = II IF (II == WHO) [ CALL MESSGE('TORPEDOES JAMMED!') NHOM(WHO)=0 TORPS(WHO)=0 ] 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('WARP SIR? ',VALUE,OK,0.,8.,WARP(WHO)) IF (OK) [ WARP(WHO)=VALUE ] ] # # COURSE COMMAND # ELSE IF (COMMND == 'C ') [ CALL GETREL('COURSE SIR? ',VALUE,OK,0.,12.,DEFDIR) IF (OK) [ 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('POD COURSE? ',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('HYPER PORT? ',II,OK,1,6,IUNIQ) IF (OK) [ HYPER(WHO)=II ] ] # # SHIELD COMMAND # ELSE IF (COMMND == 'S ') [ CALL GETREL('ENERGY CHANGE? ',VALUE,OK,-1.E36,1.E36,DEFSHD) IF (OK) [ 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 ') [ NET(WHO) = !NET(WHO) ] # # TRACTOR BEAM # ELSE IF (COMMND == 'B ') [ CALL GETINT('BEAM FREQUENCY? ',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 [ CALL MESSGE('ALREADY CLOAKED!') ] ] # # APPEAR COMMAND # 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('UHURA HERE, TO WHOM? ',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., 'A APPEAR (CLOAKING OFF) 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 (CLOAKING ON) 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 ***') ] 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 TREAD(STR,NC) BYTE STR CALL INCHAR(STR,NC,.FALSE.,0,NC,IERR) IF (NC == 0 & IERR != -2) STR=' ' ELSE IF (STR >= 'a' & STR <= 'z') STR = (STR - 'a') + 'A' RETURN 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 GETREL(PROMPT,V,EXIST,LOW,HIGH,DEFVAL) LOGICAL*1 EXIST,OK REAL V,LOW,HIGH,DEFVAL BYTE INPUT(15) INTEGER NCHRS EXIST=.FALSE. CALL REDPMT(PROMPT,INPUT,15,NCHRS) IF (NCHRS == 0) [ V = DEFVAL EXIST=.TRUE. ] ELSE IF (NCHRS < 0) [ EXIST = .FALSE. ] ELSE IF (NCHRS <= 15) [ DECODE(NCHRS,1001,INPUT,ERR=201) V 1001 FORMAT(G15.0) IF (V >= LOW & V <= HIGH) [ EXIST=.TRUE. ] ELSE [ 201 CONTINUE CALL MESSGE('?! RANGE ERROR !?') ] ] 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 GETINT(PROMPT,N,FLAG,LOW,HIGH,DEFVAL) INTEGER N,LOW,HIGH,DEFVAL LOGICAL*1 OK,FLAG BYTE INPUT(15) FLAG=.FALSE. CALL REDPMT(PROMPT,INPUT,15,NCHRS) IF (NCHRS < 0) [ FLAG=.FALSE. ] ELSE IF (NCHRS == 0) [ FLAG = .TRUE. N = DEFVAL ] ELSE [ DECODE(NCHRS,1011,INPUT,ERR=201) N 1011 FORMAT(I5) IF ((N >= LOW) & (N <= HIGH)) [ FLAG=.TRUE. ] ELSE [ 201 CONTINUE CALL MESSGE('?! RANGE ERROR !?') ] ] 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) # FINAL READ 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