# # CODE WHICH REQUIRES SPECIAL SUPPORT FROM THE ICR INSTALLATION IS # COMMENTED OUT USING THE FOLLOWING DEFINES. THE SECOND DEFINE # OVERRIDES THE FIRST UNLESS IT IS COMMENTED OUT. # # NOTE THE ORDER OF THE NEXT 4 DEFINES IS SIGNIFICANT! # DEFINE(ICR,# ICR ONLY ) #DEFINE(ICR,) # COMMENT THIS OUT FOR EXPORT VERSION DEFINE(NOTICR,) ICR DEFINE(NOTICR,# NOT ICR) 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 MESSAGE OUTPUT # MAY 1980 BILL CAEL, BILL WOOD, AND BOB STODOLA # RECODED COMMAND ARG PROMPTING # INCLUDE COMMON.RAT LOGICAL*1 OK,DONE,YES,WARN,REFRES,REFTOG,REC96 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) # # NOTE, THE SEQUENCE OF THE NEXT 4 STATEMENTS IS SIGNIFICANT # BYTE BLUNK BYTE NBUFF(-9:+9,-9:+9) BYTE BLUNK2 BYTE OBUFF(-9:+9,-9:+9) INTEGER COMMND INTEGER WHO ICR INTEGER IOP(4) ICR INTEGER*4 RUNTSK ICR DATA RUNTSK/6R...RUN/ DATA BLANK/80*' '/ DATA BLUNK,BLUNK2/' ',' '/ DATA SC/9*-9999./ DATA R/9*-9999./ DATA DONE/.FALSE./ DATA OK/.FALSE./ DATA DEFDIR/0.0/,DEFSHD/0.0/ CALL ERRSET(63,.TRUE.,.FALSE.,.TRUE.,.FALSE.,) CALL ERRSET(64,.TRUE.,.FALSE.,.TRUE.,.FALSE.,) WRITE(5,('0WELCOME TO MULTI-TREK.')) REPEAT [ WRITE(5,('0THE FOLLOWING VESSELS ARE AVAILIABLE FOR USE.')) DO I=1,8 [ IF (^XSHIP(I)) [ WRITE(5,(' SHIP ',I1)) I ] ] WRITE(5,('$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,('0THIS SHIP ALREADY HAS A COMMANDER.')) WRITE(5,('$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 # # REC96 IS SET TRUE IF TERMINAL SPEED IS 9600 BAUD. # IF REC96 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(REC96) # GET REC96, INITIALIZE TERMINAL IO CALL STRMOV(BLUNK2,1,361,OBUFF,1) CALL RBUFF IF (~REC96) CALL MARK(3,60,1,IDS) # START 1 SECOND TIMER IF NOT 9600 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. # ICR IF (THRU) [ # THEN MTREKD ISN'T RUNNING ICR CALL SPWNNL(RUNTSK,IOP,'RUN MTR/TI=TT0',14,IDS) ICR ] # # PLACE LOCAL SCAN ON TERMINAL # REFTOG = (~REFTOG) | REC96 IF ((XSHIP(WHO) & REFTOG) | REFRES) [ # DON'T REFRESH IF BLOWN UP! CALL STRMOV(BLUNK,1,361,NBUFF,1) ID=SCAN(WHO) XX=XCORD(WHO) YY=YCORD(WHO) DO IX = -ID, +ID [ IX1=XX+IX DO IY = -ID, MIN(8, +ID) [ IY1=YY+IY IF ((IX1 < 100) & (IX1 > 1) & (IY1 < 100) & (IY1 > 1 )) [ ALPHA=UNIV(IX1,IY1) ] ELSE IF (((IX1 == 100) | (IX1 == 1) | (IY1 == 100) | (IY1 == 1) ) & (((IX1 < 100) & (IX1 > 1)) | ((IY1 < 100) & (IY1 > 1)))) [ ALPHA = UNIV(IX1, IY1) IF (ALPHA == EMPTY) [ IF (_ ((IX == -ID \ IX == ID \ IX == 0) & (IY1 == 100 \ IY1 == 1)) \ ((IY == -ID \ IY == MIN(8,ID) \ IY == 0) & (IX1 == 100 \ IX1 == 1))) ALPHA='-' ] ] ELSE [ ALPHA=EMPTY ] 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 (NBUFF(-ID, -ID) == EMPTY) NBUFF(-ID, -ID) = '.' IF (NBUFF(-ID, MIN(ID, 8)) == EMPTY) NBUFF(-ID, MIN(ID, 8)) = '.' IF (NBUFF(ID, MIN(ID, 8)) == EMPTY) NBUFF(ID, MIN(ID, 8)) = '.' 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 (REC96) 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 ') ; # # HELP COMMAND # ELSE IF (COMMND == '? ') [ CALL POSITN(18,1) WRITE(5,1001) 1001 FORMAT ( ' A APPEAR (CLOAKING OFF)'T30'M SEND MESSAGE'T55'T FIRE TORPEDOES'/, ' C COURSE HEADING'T30'N FREEZE ANTI-MATTER'T55'W SET WARP SPEED'/, ' F FADE (CLOAKING ON)'T30'P FIRE PHASERS'T55'X DETONATE ANTI-MATTER'/, ' H HYPERSPACE SETTING'T30'Q QUIT'T55'Z LAUNCH ANTI-MATTER'/, ' K FIRE HOMING TORPEDO'T30'R RESET DISPLAY'T55'? HELP MESSAGE'/, ' L LOCATE SHIP'T30'S SHIELD CHANGE'T55'E ENERGY NET') CALL POSITN(1,1) ] # # 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. ] ] ] # # 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 !?') ] ] ] # # QUIT COMMAND # ELSE IF (COMMND == 'Q ') [ CALL YESNO('QUIT NOW? ',DONE) ] # # 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') ] ] # # 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 ] # # 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') ] ] # # 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 POSITN(16,75) WRITE(5,(1X,I2,',',I2)) IX,IY XX = XCORD(WHO) YY = YCORD(WHO) X1=XCORD(II) IF (X1 < 50.) [ X2=X1+100. ] ELSE [ X2=X1-100. ] Y1=YCORD(II) IF (Y1 < 50.) [ 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.2952 IF (EDIR < 0.) [ EDIR=EDIR+360. ] IF (EDIR > 90.) [ EDIR=(450.-EDIR)/30. ] ELSE [ EDIR=(90.-EDIR)/30. ] DEFDIR = EDIR CALL POSITN(15,75) WRITE(5,(1X,F5.2)) EDIS CALL POSITN(14,75) WRITE (5,(1X,F5.2)) EDIR CALL POSITN(13,79) WRITE (5,(1X,I1)) DEFSHP ] ] # # 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 POSITN(23,1) WRITE(5,(80(' '))) CALL POSITN(23,1) WRITE(5,('$MESSAGE CAPTAIN? ')) READ(5,(59A1),END=1012) (MESBUF(I),I=2,60) GOTO 1013 1012 CLOSE(UNIT=5) 1013 CONTINUE CALL POSITN(1,1) MESBUF(1) = WHO+DIG0 DO I = IL, IH IF (XSHIP(I) & I ^= WHO) [ ENERGY(WHO)=ENERGY(WHO)-10. CALL STRMOV(MESBUF,1,60,MESSAG,I*60-59) ] ] ] # # 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!') ] ] # # 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!') ] ] # # FLIP ENERGY NET ON OR OFF # ELSE IF (COMMND == 'E ') [ NET(WHO) = ~NET(WHO) ] # # FLIP VERBOSE MESSAGES ON OR OFF # ELSE IF (COMMND == 'V ') [ VERBOS = ^VERBOS ] # # 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,(////////////,25X,'*** BOOM ***')) ] WRITE(5,( '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,(' 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 POSITN(17,1) WRITE (5,( ' SPOCK HERE CAPTAIN. '/ ' WE ARE BEING DRAWN INTO SOME SORT OF BLACK HOLE,'/ ' IT IS UNLIKE ANYTHING I HAVE EVER ENCOUNTERED.'/ ' FASCINATING.') ) CALL WAIT(1,2,M) NEXT 16 CONTINUE CALL POSITN(17,1) WRITE (5,( ' SCOTT HERE CAPTAIN. '/ ' OUR DYLITHIUM CRYSTALS ARE GONE. LIFE SUPPORT IS '/ ' FAILING ...!') ) 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 POSITN(23,1) WRITE(5,(' MESSAGE FROM 'A1': '60A1)) (MESSAG(I), I = WHO*60-59,WHO*60) CALL STRMOV(BLANK,1,60,MESSAG,WHO*60-59) CALL POSITN(1,1) ] 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(STRING,NC) BYTE STRING CALL INCHAR(STRING,NC,.FALSE.,0,LINE,NC,IERR) IF (NC == 0 & IERR ^= -2) STRING=' ' RETURN END SUBROUTINE RBUFF COMMON /MESS/ CLEARF LOGICAL CLEARF CALL CLEAR CLEARF = .FALSE. # # DRAW NEW SCREEN # CALL BUFFIL(1,3,'ENERGY :',10) CALL BUFFIL(2,3,'SHIELDS :',10) CALL BUFFIL(4,3,'WARP :',10) CALL BUFFIL(5,3,'COURSE :',10) CALL BUFFIL(7,3,'X CO-ORD :',10) CALL BUFFIL(8,3,'Y CO-ORD :',10) CALL BUFFIL(10,3,'TORPS :',10) CALL BUFFIL(11,3,'SEEKERS :',10) CALL BUFFIL(12,3,'HYPER :',10) CALL BUFFIL(14,3,'DEF SHIP :',10) CALL BUFFIL(15,3,'DEF DIREC:',10) CALL BUFFIL(1,70,'SCORES',6) CALL BUFFIL(3,68,'1',1) CALL BUFFIL(4,68,'2',1) CALL BUFFIL(5,68,'3',1) CALL BUFFIL(6,68,'4',1) CALL BUFFIL(7,68,'5',1) CALL BUFFIL(8,68,'6',1) CALL BUFFIL(9,68,'7',1) CALL BUFFIL(10,68,'8',1) CALL BUFFIL(13,68,'SCAN:',5) CALL BUFFIL(14,68,'DIR :',5) CALL BUFFIL(15,68,'DIST:',5) CALL BUFFIL(16,68,'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,NCHRS) IF (NCHRS == 0) [ V = DEFVAL EXIST=.TRUE. ] ELSE IF (NCHRS < 0) [ EXIST = .FALSE. ] ELSE IF (NCHRS <= 15) [ DECODE(NCHRS,(G15.0),INPUT,ERR=201) V 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 STRING(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,(F7.1),STRING) R(1) CALL BUFFIL(1,14,STRING,7) ] IF (R(2) ~= SHIELDS(I)) [ R(2)=SHIELDS(I) ENCODE(7,(F7.1),STRING) R(2) CALL BUFFIL(2,14,STRING,7) ] IF (R(3) ~= WARP(I)) [ R(3)=WARP(I) ENCODE(4,(F4.2),STRING) R(3) CALL BUFFIL(4,17,STRING,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,(F5.2),STRING) V CALL BUFFIL(5,16,STRING,5) ] IF (R(5) ~= XCORD(I)) [ R(5)=XCORD(I) ENCODE(5,(F5.1),STRING) R(5) CALL BUFFIL(7,16,STRING,5) ] IF (R(6) ~= YCORD(I)) [ R(6)=YCORD(I) ENCODE(5,(F5.1),STRING) R(6) CALL BUFFIL(8,16,STRING,5) ] IR=R(7) IF (IR ~= TORPS(I)) [ R(7)=TORPS(I) ENCODE(2,(I2),STRING) TORPS(I) CALL BUFFIL(10,19,STRING,2) ] IR=R(8) IF (IR ~= NHOM(I)) [ R(8)=NHOM(I) ENCODE(2,(I2),STRING) NHOM(I) CALL BUFFIL(11,19,STRING,2) ] IR=R(9) IF (IR ~= HYPER(I)) [ R(9)=HYPER(I) ENCODE(1,(I1),STRING) HYPER(I) CALL BUFFIL(12,20,STRING,1) ] IF (OLDSHP ~= DEFSHP) [ OLDSHP = DEFSHP ENCODE(1,(I1),STRING) OLDSHP CALL BUFFIL(14,20,STRING,1) ] IF (OLDDIR ~= DEFDIR) [ OLDDIR = DEFDIR ENCODE(5,(F5.2),STRING) DEFDIR CALL BUFFIL(15,16,STRING,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,(F8.0,1X,A1),STRING) SC(J), ACT(J) CALL BUFFIL(J+2,70,STRING,10) ] ] CALL OUTCH(0,-1) RETURN END SUBROUTINE BUFFIL(IY,IX,ST,L) BYTE ST(1) CALL TPOS(IY + 1, IX + 1) 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,NCHRS) IF (NCHRS < 0) [ FLAG=.FALSE. ] ELSE IF (NCHRS == 0) [ FLAG = .TRUE. N = DEFVAL ] ELSE [ DECODE(NCHRS,(I5),INPUT,ERR=201) N IF ((N >= LOW) & (N <= HIGH)) [ FLAG=.TRUE. ] ELSE [ 201 CONTINUE CALL MESSGE('?! RANGE ERROR !?') ] ] RETURN END SUBROUTINE REDPMT(PROMPT,INPUT,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(1), BLANKS(PRMPTL) LOGICAL ECHO DATA BLANKS/PRMPTL*' '/ NCHRS = 0 ECHO = .TRUE. IF (PROMPT(1) ~= 0) [ # IF PROMPT IS NOT NULL... CALL INCHAR(INPUT,15,.FALSE.,0,.TRUE.,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),15-NCHRS,.FALSE.,0,.TRUE.,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),15-NCHRS,ECHO,-1,.TRUE.,NC,IERR) # FINAL READ IF (PROMPT(1) ~= 0 & NCHRS == 0) [ # THEN ERASE PROMPT STRING 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 SUBROUTINE YESNO(PROMPT,FLAG) LOGICAL*1 FLAG,OK BYTE YES(4),NO(4),PROMPT(1) BYTE ANSWER(4) DATA YES/'Y','E','S',' '/ DATA NO/'N','O',' ',' '/ # OK=.FALSE. ANSWER(1) = 0 CALL REDPMT(PROMPT,ANSWER,NCHRS) REPEAT [ IF ((NCHRS > 4) | (NCHRS <= 0)) [ NCHRS=4 ] # * CHECK FOR YES I=KOMSTR(YES,1,NCHRS,ANSWER,1) IF (I == 0) [ FLAG=.TRUE. OK=.TRUE. ] ELSE [ # * CHECK FOR A NO I=KOMSTR(NO,1,NCHRS,ANSWER,1) IF (I == 0) [ FLAG=.FALSE. OK=.TRUE. ] ELSE [ # * INCORRECT RESPONSE IF (PROMPT(1) == 0) [ WRITE(5,('$ANSWER YES OR NO? ')) READ(5,(Q,4A1),END=3) NCHRS,ANSWER NEXT 3 CONTINUE CLOSE (UNIT=5) ] ELSE [ CALL REDPMT('ANSWER YES OR NO? ',ANSWER,NCHRS) ] ] ] ] UNTIL (OK) RETURN END # POSITN - POSITION CURSOR SUBROUTINE POSITN(IROW, ICOL) # WPW 9/19/80 CALL TPOS(IROW,ICOL) CALL OUTCH(0,0) RETURN END