C ASCII "0" PROGRAM PLAYER C C MAY 1980 BILL CAEL AND BILL WOOD RECODED IN RATFOR C MAY 1980 BILL CAEL AND BILL WOOD ADDED DEFAULT SHIP AND DIRECTION C MAY 1980 BILL WOOD ADDED ENERGY NETS C MAY 1980 BILL CAEL AND BILL WOOD RECODED OUTPUT C MAY 1980 BILL CAEL, BILL WOOD, AND BOB STODOLA C RECODED COMMAND ARG PROMPTING C NOV 1980 BILL WOOD CONVERTED TO RUN ON VAX C C COMMON PARAMETER MAXSHP = 8, MAXHOM = 4, MAXTRP = 10 COMMON/TORPE/TLOCS(MAXSHP, MAXTRP, 2), TDIR(MAXSHP, MAXTRP), IT(MA *XSHP) COMMON/TRKDAT/ENERGY(MAXSHP), SHIELD(MAXSHP), XCORD(MAXSHP), YCORD *(MAXSHP), TORPS(MAXSHP), HOLX, HOLY, HOLW, CDRAIN, NDRAIN, TDRAIN, * SCAN(MAXSHP), PHA(MAXSHP), I1, I2, HYPER(MAXSHP), ISENT(MAXSHP, 1 *0), XPOD(MAXSHP), YPOD(MAXSHP), DPOD(MAXSHP), IPODST(MAXSHP), WPOD *(MAXSHP), XHOM(MAXSHP, MAXHOM), YHOM(MAXSHP, MAXHOM), WHOM(MAXSHP, * MAXHOM), NHOM(MAXSHP), TRBEAM(MAXSHP), SCORE(MAXSHP), CREW(MAXSHP *), DIR(MAXSHP), WARP(MAXSHP), LAUNCH(MAXSHP), UNIV(100, 100), MESS *AG(480), THRU, SHPACT(MAXSHP), CLOAK(MAXSHP), NET(MAXSHP), SHPNAM( *10, MAXSHP) REAL LAUNCH, NDRAIN INTEGER*2SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM LOGICAL*1THRU, SHPACT, CLOAK, NET BYTE UNIV, MESSAG BYTE SHPNAM C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE. C END COMMON LOGICAL*1OK, DONE, YES, WARN, REFTOG LOGICAL QUIKUP INTEGER DEFSHP REAL DEFDIR COMMON/DEFLTS/DEFSHP, DEFDIR, DEFSHD LOGICAL CLEARF, VERBOS COMMON/MESS/CLEARF, VERBOS BYTE BLANK(80), ALPHA, MESBUF(60) BYTE BLUNK(2) BYTE BLUNK2(2) BYTE OBUFF( - 9: + 9, - 9: + 9), NBUFF( - 9: + 9, - 9: + 9) BYTE JUNK LOGICAL*1REFRES COMMON/BNDRY/IXX, IYY, ID, MINID8, JUNK, OBUFF, NBUFF, REFRES BYTE COMMND CMY SHIP NUMBER INTEGER ME BYTE NAME(10) LOGICAL*1LSTOUT EQUIVALENCE(BLUNK(2), NBUFF( - 9, - 9)) EQUIVALENCE(BLUNK2(2), OBUFF( - 9, - 9)) DATA BLANK/80*' '/ DATA BLUNK, BLUNK2/4*' '/ DATA DONE/.FALSE./ DATA OK/.FALSE./ DATA DEFDIR/0.0/, DEFSHD/0.0/ C---------------------------------------------------------------------- C DON'T EXIT ON I/O CONVERSION ERRORS CALL ERRSET(63, .TRUE., .FALSE., , .FALSE.) CALL ERRSET(64, .TRUE., .FALSE., , .FALSE.) C C QUIKUP IS SET TRUE IF TERMINAL SPEED EXCEEDS A THRESHOLD C DETERMINED IN GTCHAR. C IF QUIKUP IS TRUE, A FULL SCREEN UPDATE OCCURS EVERY 1/2 SECOND; C AT SLOWER SPEEDS, 1/2 THE SCREEN IS UPDATED EVERY SECOND ON THE C HALF SECOND, THE OTHER 1/2 IS UPDATED EVERY SECOND ON THE SECOND. C THIS ALLOWS ENJOYABLE GAMES ON TERMINALS AS SLOW AS 1200 BAUD. C C GET QUIKUP, INITIALIZE TERMINAL IO CALL GTCHAR(QUIKUP) WRITE(5, 1001) 1001 FORMAT('0WELCOME TO MULTI-TREK.') 2000 CONTINUE WRITE(5, 1011) 1011 FORMAT('0 CURRENT VESSEL STATUS IS:', //T11, 'Name', T24, 'Score *'/) DO 2030 I = 1, 8 IF (.NOT.(.NOT.SHPACT(I) .AND. (CREW(I) .LE. 400))) GOTO 2050 WRITE(5, 1021) I, (SHPNAM(J, I), J = 1, 10), SCORE(I), ' EMP *TY' 1021 FORMAT(' Ship ', I1, 2X, 10A1, 2X, F8.0, A) GOTO 2060 2050 CONTINUE WRITE(5, 1021) I, (SHPNAM(J, I), J = 1, 10), SCORE(I), '*IN *USE' 2060 CONTINUE 2030 CONTINUE 2040 CONTINUE WRITE(5, 1031) 1031 FORMAT(//'$ENTER THE NUMBER OF THE VESSEL YOU WISH TO COMMAND: ' *) CALL GETINT(0, IW, OK, 1, 8, 0) IF (.NOT.(OK)) GOTO 2070 IF (.NOT.(IW .EQ. 0)) GOTO 2090 OK = .FALSE. GOTO 2010 2090 CONTINUE COUR SHIP NUMBER ME = IW IF (.NOT.(SHPACT(ME) .OR. (CREW(ME) .GT. 400))) GOTO 2110 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) GOTO 2120 2110 CONTINUE WRITE(5, 1055) 1055 FORMAT(/'$WHAT DO YOU CHRISTEN YOUR SHIP? (10 CHARS MAX) > ' *) READ(5, 1056) NCH, NAME 1056 FORMAT(Q, 10A1) IF (.NOT.(NCH .GT. 0)) GOTO 2130 C RENAME SHIP & CLEAR SCORE DO 2150 I = 1, 10 SHPNAM(I, ME) = NAME(I) 2150 CONTINUE 2160 CONTINUE SCORE(ME) = 0.0 2130 CONTINUE 2120 CONTINUE GOTO 2080 2070 CONTINUE CALL EXIT 2080 CONTINUE 2010 IF (.NOT.(OK)) GOTO 2000 2020 CONTINUE REFRES = .TRUE. REFTOG = .FALSE. CREW(ME) = CREW(ME) + 1 DEFSHP = ME CALL STRMOV(BLUNK2, 1, 361, OBUFF, 1) CALL RBUFF IF (.NOT.(.NOT.QUIKUP)) GOTO 2170 C START 1 SECOND TIMER IF SLOW UPDATE CALL MARK(3, 60, 1, IDS) 2170 CONTINUE C START 1/2 SECOND TIMER CALL MARK(2, 30, 1, IDS) 2190 CONTINUE C C THE FOLLOWING CALL SPAWNS THE MTREKD UNIVERSE MANAGER TASK ON TT0:. C IF YOU CANNOT DO SOMETHING SIMILAR, YOU MUST START MTREKD YOURSELF C BEFORE PLAYING EACH GAME. C IF (.NOT.(THRU)) GOTO 2220 C THEN MTREKD ISN'T RUNNING CALL RUNMTR C C PLACE LOCAL SCAN ON TERMINAL C 2220 CONTINUE REFTOG = (.NOT.REFTOG) .OR. QUIKUP IF (.NOT.((SHPACT(ME) .AND. REFTOG) .OR. REFRES)) GOTO 2240 C DON'T REFRESH IF BLOWN UP! CALL SRSCAN(ME) C C THE FOLLOWING WAIT CONTROLS THE UPDATE RATE, WHICH IS NORMALLY C SET TO A HALF SECOND (30 CLOCK TICKS). C 2240 CONTINUE IF (.NOT.(COMMND .NE. ' ' .AND. SHPACT(ME))) GOTO 2260 IF (.NOT.(REFTOG)) GOTO 2280 CALL WAITFR(2, IDS) IF (.NOT.(QUIKUP)) GOTO 2300 C RESTART 1/2 SECOND TIMER CALL MARK(2, 30, 1, IDS) 2300 CONTINUE GOTO 2290 2280 CONTINUE CALL WAITFR(3, IDS) C RESTART 1 SECOND TIMER CALL MARK(3, 60, 1, IDS) C RESTART 1/2 SECOND TIMER CALL MARK(2, 30, 1, IDS) 2290 CONTINUE 2260 CONTINUE 2320 CONTINUE IF (.NOT.(.NOT.SHPACT(ME))) GOTO 2350 GOTO 2340 2350 CONTINUE NC = 1 CSEE IF ANY COMMANDS TYPED CALL TREAD(COMMND, NC) IF (.NOT.(NC .GT. 0)) GOTO 2370 CALL XQTCMD(COMMND, ME, DONE) 2370 CONTINUE 2330 IF (.NOT.(NC .EQ. 0)) GOTO 2320 2340 CONTINUE IF (.NOT.((SHPACT(ME) .AND. REFTOG) .OR. REFRES)) GOTO 2390 CALL REFRSH(ME) 2390 CONTINUE IF (.NOT.(REFRES)) GOTO 2410 SHPACT(ME) = .TRUE. REFRES = .FALSE. REFTOG = .FALSE. C WRITE OUT MESSAGES FROM DRIVER 2410 CONTINUE CALL DRVMSG(ME, DONE) C WRITE OUT MESSAGES FROM OTHER PLAYERS IF (.NOT.(MESSAG(ME*60-59) .NE. ' ')) GOTO 2430 CALL TPOS(24, 1) CASCII BELL CHARACTER CALL OUTCH(7, 1) CALL OUTCH('MESSAGE FROM ', 13) MIND = ME*60 - 59 CALL OUTCH(MESSAG(MIND), 1) CALL OUTCH(': ', 2) CALL OUTCH(MESSAG(MIND + 1), 59) CALL FLUSH(0) CALL STRMOV(BLANK, 1, 60, MESSAG, MIND) C DISPLAY LOW ENERGY WARNING 2430 CONTINUE IF (.NOT.((ENERGY(ME) .LT. 900.) .AND. WARN)) GOTO 2450 CALL MESSGE('ENERGY LOW!') WARN = .FALSE. GOTO 2460 2450 CONTINUE WARN = .TRUE. 2460 CONTINUE CFLUSH OUT MESSAGES CALL MESSGE(0) 2200 IF (.NOT.(DONE)) GOTO 2190 2210 CONTINUE C PILOT ABANDONED SHIP CREW(ME) = CREW(ME) - 1 IF (.NOT.(CREW(ME) .LE. 400)) GOTO 2470 SHPACT(ME) = .FALSE. GOTO 2480 2470 CONTINUE SHPACT(ME) = .TRUE. 2480 CONTINUE CALL CLEAR CALL FLUSH(0) CALL EXIT END SUBROUTINE GETREL(PROMPT, V, EXIST, LOW, HIGH, DEFVAL) LOGICAL*1EXIST, OK REAL V, LOW, HIGH, DEFVAL BYTE INPUT(15) INTEGER NCHRS EXIST = .FALSE. CALL REDPMT(PROMPT, INPUT, 15, NCHRS) IF (.NOT.(NCHRS .EQ. 0)) GOTO 2490 V = DEFVAL EXIST = .TRUE. GOTO 2500 2490 CONTINUE IF (.NOT.(NCHRS .LT. 0)) GOTO 2510 EXIST = .FALSE. GOTO 2520 2510 CONTINUE IF (.NOT.(NCHRS .LE. 15)) GOTO 2530 DECODE(NCHRS, 1001, INPUT, ERR=201) V 1001 FORMAT(G15.0) IF (.NOT.(V .GE. LOW .AND. V .LE. HIGH)) GOTO 2550 EXIST = .TRUE. GOTO 2560 2550 CONTINUE 201 CONTINUE CALL MESSGE('?! RANGE ERROR !?') 2560 CONTINUE 2530 CONTINUE 2520 CONTINUE 2500 CONTINUE 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*1OK, FLAG BYTE INPUT(15) FLAG = .FALSE. CALL REDPMT(PROMPT, INPUT, 15, NCHRS) IF (.NOT.(NCHRS .LT. 0)) GOTO 2570 FLAG = .FALSE. GOTO 2580 2570 CONTINUE IF (.NOT.(NCHRS .EQ. 0)) GOTO 2590 FLAG = .TRUE. N = DEFVAL GOTO 2600 2590 CONTINUE DECODE(NCHRS, 1011, INPUT, ERR=201) N 1011 FORMAT(I5) IF (.NOT.((N .GE. LOW) .AND. (N .LE. HIGH))) GOTO 2610 FLAG = .TRUE. GOTO 2620 2610 CONTINUE 201 CONTINUE CALL MESSGE('?! RANGE ERROR !?') 2620 CONTINUE 2600 CONTINUE 2580 CONTINUE RETURN END SUBROUTINE REDPMT(PROMPT, INPUT, NINPUT, NCHRS) C C DO A READ WITHOUT PROMPT AND WITHOUT ECHO; IF NO INPUT IS RECEIVED AFTER 1/2 C SECOND, ISSUE THE PROMPT, THEN READ WITH NO TIMEOUT AND WITH ECHO. C IF A PROMPT IS ISSUED, IT AND THE INPUT IS ERASED TO BLANKS AFTER C THE READ. C C THIS ROUTINE COULD DO A SIMPLE PROMPT AND READ AFTER POSITIONING C TO (PRMPTY, PRMPTX), FOLLOWED BY ERASING THE PROMPT AND INPUT C TO BLANKS, IF NECCESSARY ON YOUR SYSTEM. C 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 (.NOT.(PROMPT(1) .NE. 0)) GOTO 2630 C IF PROMPT IS NOT NULL... C GET TYPE AHEAD CALL INCHAR(INPUT, NINPUT, .FALSE., 0, NC, IERR) IF (.NOT.(IERR .EQ. -1)) GOTO 2650 C EOF? GO TO 999 2650 CONTINUE NCHRS = NCHRS + NC IF (.NOT.(IERR .EQ. CR)) GOTO 2670 C DONE? RETURN 2670 CONTINUE C WAIT 1/2 SEC, THEN READ AGAIN CALL WAIT(30, 0, DSW) CALL INCHAR(INPUT(NCHRS + 1), NINPUT - NCHRS, .FALSE., 0, NC, IE *RR) IF (.NOT.(IERR .EQ. -1)) GOTO 2690 C EOF? GO TO 999 2690 CONTINUE NCHRS = NCHRS + NC IF (.NOT.(IERR .EQ. CR)) GOTO 2710 C DONE? RETURN 2710 CONTINUE IF (.NOT.(NCHRS .EQ. 0)) GOTO 2730 C THEN ISSUE PROMPT LEN = 1 2750 IF (.NOT.(LEN .LE. MAXPRM .AND. PROMPT(LEN) .NE. 0)) GOTO 2770 2760 LEN = LEN + 1 GOTO 2750 2770 CONTINUE CALL TPOS(PRMPTY, PRMPTX) CALL OUTCH(PROMPT, LEN - 1) GOTO 2740 2730 CONTINUE ECHO = .FALSE. 2740 CONTINUE 2630 CONTINUE CALL INCHAR(INPUT(NCHRS + 1), NINPUT - NCHRS, ECHO, - 1, NC, IERR C FINAL READ *) IF (.NOT.(PROMPT(1) .NE. 0 .AND. NCHRS .EQ. 0)) GOTO 2780 C THEN ERASE PROMPT STRNG CALL TPOS(PRMPTY, PRMPTX) CALL OUTCH(BLANKS, PRMPTL) 2780 CONTINUE IF (.NOT.(IERR .EQ. -1)) GOTO 2800 C EOF? GO TO 999 2800 CONTINUE NCHRS = NCHRS + NC RETURN 999 CONTINUE NCHRS = - 1 RETURN END SUBROUTINE YESNO(PROMPT, FLAG) LOGICAL*1FLAG, OK BYTE PROMPT(1) BYTE ANSWER(4) C OK = .FALSE. ANSWER(1) = 0 CALL REDPMT(PROMPT, ANSWER, 4, NCHRS) 2820 CONTINUE IF (.NOT.(NCHRS .LE. 0)) GOTO 2850 NCHRS = 1 ANSWER(1) = 0 2850 CONTINUE IF (.NOT.(ANSWER(1) .GE. 'a' .AND. ANSWER(1) .LE. 'z')) GOTO 287 *0 ANSWER(1) = (ANSWER(1) - 'a') + 'A' C * CHECK FOR YES 2870 CONTINUE IF (.NOT.(ANSWER(1) .EQ. 'Y')) GOTO 2890 FLAG = .TRUE. OK = .TRUE. C * CHECK FOR A NO GOTO 2900 2890 CONTINUE IF (.NOT.(ANSWER(1) .EQ. 'N')) GOTO 2910 FLAG = .FALSE. OK = .TRUE. C * INCORRECT RESPONSE GOTO 2920 2910 CONTINUE IF (.NOT.(PROMPT(1) .EQ. 0)) GOTO 2930 CALL OUTCH(13, 1) CALL OUTSTR(.TRUE., 'ANSWER YES OR NO? ', .FALSE.) CALL INCHAR(ANSWER, 4, .TRUE., - 1, NCHRS, IER) GOTO 2940 2930 CONTINUE CALL REDPMT('ANSWER YES OR NO? ', ANSWER, 4, NCHRS) 2940 CONTINUE 2920 CONTINUE 2900 CONTINUE 2830 IF (.NOT.(OK)) GOTO 2820 2840 CONTINUE RETURN END SUBROUTINE OUTSTR(LFFLAG, STRNG, CRFLAG) LOGICAL LFFLAG, CRFLAG BYTE STRNG(1) LEN = 0 2950 IF (.NOT.(STRNG(LEN+1) .NE. 0)) GOTO 2970 2960 LEN = LEN + 1 GOTO 2950 2970 CONTINUE IF (.NOT.(LFFLAG)) GOTO 2980 CALL OUTCH(10, 1) 2980 CONTINUE CALL OUTCH(STRNG, LEN) IF (.NOT.(CRFLAG)) GOTO 3000 CALL OUTCH(0, - 1) GOTO 3010 3000 CONTINUE CALL OUTCH(0, 0) 3010 CONTINUE RETURN END C CLKDIR - CONVERT DIRECTION IN DEGREES (0-360) TO CLOCK FACE (0-12) REAL FUNCTION CLKDIR(DEGR) CLOCK = (90.0 - DEGR)*(1/30.0) IF (.NOT.(CLOCK .LT. 0.0)) GOTO 3020 CLOCK = CLOCK + 12.0 3020 CONTINUE CLKDIR = CLOCK RETURN END C DEGDIR - CONVERT CLOCK FACE DIRECTION (0-12) TO DEGREES (0-360) REAL FUNCTION DEGDIR(CLOCK) DEGR = (3.0 - CLOCK)*30.0 IF (.NOT.(DEGR .LT. 0.0)) GOTO 3040 DEGR = DEGR + 360.0 3040 CONTINUE DEGDIR = DEGR RETURN END