PROGRAM DRIINI C C AUTHOR: DON LEDFORD C C DECEMBER 1978 JOHN LUTCH ADDED CLOAKING C DECEMBER 1978 DON LEDFORD ADDED ANTI-MATTER C MARCH 1979 RAY FRENCH ADDED CONTINUOUS DISPLAY C OCTOBER 1979 DON LEDFORD ADDED ROBOT SHIPS C MAY 1980 BILL CAEL AND BILL WOOD RECODED IN RATFOR C MAY 1980 BILL WOOD ADDED ENERGY NETS 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, YES BYTE CHAR C WRITE(5, 11) 11 FORMAT('0Welcome to Multi-trek initialization'/) DO 2000 I = 1, 8 IF (.NOT.(SHPACT(I))) GOTO 2020 WRITE(5, 1) 1 FORMAT('$Battle in progress. Initialize anyway? ') READ(5, 2) CHAR 2 FORMAT(A1) IF (.NOT.(CHAR.EQ.'Y' .OR. CHAR.EQ.'y')) GOTO 2040 GOTO 2010 2040 CONTINUE CALL EXIT 2050 CONTINUE C 2020 CONTINUE 2000 CONTINUE 2010 CONTINUE WRITE(5, 71) 71 FORMAT('$Enter a random integer (or to keep old universe) :') CALL GETINT(ISEED, OK, - 32000, 32000) C C SEED THE RANDOM NUMBER GENERATOR C I1 = 0 I2 = 0 IF (.NOT.(OK .AND. ISEED .NE. 0)) GOTO 2060 THRU = .TRUE. DO 2080 I = 0, IABS(ISEED) RNDOM = RAN(I1, I2) C ASK FOR UNIVERSE GENERATION INFO 2080 CONTINUE 2090 CONTINUE WRITE(5, 41) 41 FORMAT('$Enter star density of universe parts per 100 (2.0): ') CALL GETREL(STARS, OK, 0., 15.) IF (.NOT.(.NOT.OK)) GOTO 2100 STARS = 2.0 2100 CONTINUE WRITE(5, 51) 51 FORMAT('$Enter approximate number of star bases (20): ') CALL GETREL(BASES, OK, 0., 50.) IF (.NOT.(.NOT.OK)) GOTO 2120 BASES = 20. 2120 CONTINUE WRITE(5, 61) 61 FORMAT('$Enter number of random jump points (6): ') CALL GETINT(N, OK, 0, 10) IF (.NOT.(.NOT.OK)) GOTO 2140 N = 6 C C * NOW GENERATE THE UNIVERSE C 2140 CONTINUE WRITE(5, 65) 65 FORMAT(/' Generating the UNIVERSE ...'/) DO 2160 I = 1, 100 DO 2180 J = 1, 100 RNDOM = RAN(I1, I2) IF (.NOT.(RNDOM .GT. (100.-STARS)/100.)) GOTO 2200 UNIV(I, J) = '*' GOTO 2210 2200 CONTINUE IF (.NOT.(RNDOM .LE. BASES/10000.)) GOTO 2220 UNIV(I, J) = 'B' GOTO 2230 2220 CONTINUE UNIV(I, J) = ' ' 2230 CONTINUE 2210 CONTINUE 2180 CONTINUE 2190 CONTINUE C C * PUT IN THE HYPERSPACE PORTS C 2160 CONTINUE 2170 CONTINUE UNIV(20, 25) = 'H' UNIV(20, 75) = 'H' UNIV(50, 30) = 'H' UNIV(50, 70) = 'H' UNIV(80, 25) = 'H' UNIV(80, 75) = 'H' C C * PUT IN THE MOBILE "BLACK HOLE" C UNIV(30, 60) = '#' HOLX = 30. HOLY = 60. C C * PUT IN THE RANDOM HYPER-SPACE PORTS C DO 2240 I = 1, N OK = .FALSE. 2260 CONTINUE IX = RAN(I1, I2)*100. + 1. IF (.NOT.(IX .GT. 100)) GOTO 2290 IX = 100 2290 CONTINUE IY = RAN(I1, I2)*100. + 1. IF (.NOT.(IY .GT. 100)) GOTO 2310 IY = 100 2310 CONTINUE IF (.NOT.(UNIV(IX, IY) .EQ. ' ')) GOTO 2330 UNIV(IX, IY) = 'R' OK = .TRUE. 2330 CONTINUE 2270 IF (.NOT.(OK)) GOTO 2260 2280 CONTINUE C C * PUT IN THE STAR SHIPS C 2240 CONTINUE 2250 CONTINUE DO 2350 I = 1, 8 OK = .FALSE. 2370 CONTINUE IX = RAN(I1, I2)*100. + 1. IF (.NOT.(IX .GT. 100)) GOTO 2400 IX = 100 2400 CONTINUE IY = RAN(I1, I2)*100. + 1. IF (.NOT.(IY .GT. 100)) GOTO 2420 IY = 100 2420 CONTINUE IF (.NOT.(UNIV(IX, IY) .EQ. ' ')) GOTO 2440 ENCODE(1, 13, CHAR) I 13 FORMAT(I1) UNIV(IX, IY) = CHAR XCORD(I) = IX YCORD(I) = IY XCORD(I) = XCORD(I) + .5 YCORD(I) = YCORD(I) + .5 OK = .TRUE. 2440 CONTINUE 2380 IF (.NOT.(OK)) GOTO 2370 2390 CONTINUE C C * INITIALIZE STARTING STATUS OF THE STAR SHIPS C 2350 CONTINUE 2360 CONTINUE DO 2460 I = 1, 8 C * INITIALIZE SHIPS AS UNOWNED AND NOT CLOAKED SHPACT(I) = .FALSE. DO 2480 II = 1, 10 SHPNAM(II, I) = ' ' 2480 CONTINUE 2490 CONTINUE CLOAK(I) = .FALSE. NET(I) = .FALSE. TRBEAM(I) = 0 SCAN(I) = 9 NHOM(I) = 4 DO 2500 II = 1, 4 WHOM(I, II) = 0 2500 CONTINUE 2510 CONTINUE LAUNCH(I) = - 1 PHA(I) = - 1 ENERGY(I) = 10000. SHIELD(I) = 0. TORPS(I) = 10. IPODST(I) = 0 CREW(I) = 400 WARP(I) = 0. DIR(I) = 0. MESSAG(I*60 - 59) = ' ' SCORE(I) = 0. IT(I) = 1 HYPER(I) = 3 DO 2520 K = 1, 10 ISENT(I, K) = 0 TDIR(I, K) = - 1. TLOCS(I, K, 1) = 1 TLOCS(I, K, 2) = 1 2520 CONTINUE 2530 CONTINUE C SET UP DEFAULTS FOR OTHER STUFF 2460 CONTINUE 2470 CONTINUE CCLOAKING DRAIN CDRAIN = 25. CENERGY NET DRAIN NDRAIN = 75. CTRACTOR BEAM DRAIN TDRAIN = 100. CBLACK HOLE WARP SPEED HOLW = 1.0 C ASK OTHER PERTINENT QUESTIONS 2060 CONTINUE WRITE(5, 81) CDRAIN 81 FORMAT('$Enter energy drain for cloaking (', F5.0, '): ') CALL GETREL(CDRAIN, OK, 0., 2000.) WRITE(5, 82) NDRAIN 82 FORMAT('$Enter energy drain for energy net (', F5.0, '): ') CALL GETREL(NDRAIN, OK, 0., 2000.) WRITE(5, 83) TDRAIN 83 FORMAT('$Enter energy drain for tractor beam (', F5.0, '): ') CALL GETREL(TDRAIN, OK, 0., 2000.) WRITE(5, 91) HOLW 91 FORMAT('$Enter warp speed of "black hole" (', F3.0, '): ') CALL GETREL(HOLW, OK, 0., 10.) WRITE(5, 101) 101 FORMAT('0... and on the seventh day He rested.'/) END SUBROUTINE GETREL(VARI, EXIST, LOW, HIGH) C LOGICAL*1EXIST, OK REAL VARI, LOW, HIGH BYTE INPUT(15), LEFTED(15) INTEGER NCHRS OK = .FALSE. 2540 CONTINUE DO 2570 I = 1, 15 LEFTED(I) = ' ' 2570 CONTINUE 2580 CONTINUE READ(5, 101, END=812) NCHRS, (INPUT(I), I = 1, 15) 101 FORMAT(Q, 15A1) GOTO 813 812 CLOSE(UNIT = 5) 813 CONTINUE IF (.NOT.(NCHRS .EQ. 0)) GOTO 2590 OK = .TRUE. EXIST = .FALSE. GOTO 2600 2590 CONTINUE IF (.NOT.(NCHRS .LE. 15)) GOTO 2610 C * LEFT ADJUST INPUT CALL STRMOV(INPUT, 1, NCHRS, LEFTED, 16 - NCHRS) DECODE(15, 23, LEFTED, ERR=202) VARI 23 FORMAT(G15.0) IF (.NOT.(VARI .GE. LOW .AND. VARI .LE. HIGH)) GOTO 2630 OK = .TRUE. EXIST = .TRUE. GOTO 2640 2630 CONTINUE WRITE(5, 111) 111 FORMAT('0Sorry, but your command''s parameter') WRITE(5, 152) LOW, HIGH 152 FORMAT(' must be between ', F15.4, ' and ', F15.4) 2640 CONTINUE GO TO 302 202 TYPE*, 'Would you please repeat that sir ?' 302 CONTINUE GOTO 2620 2610 CONTINUE WRITE(5, 121) 121 FORMAT(' Run that by me again !') 2620 CONTINUE 2600 CONTINUE 2550 IF (.NOT.(OK)) GOTO 2540 2560 CONTINUE RETURN END SUBROUTINE GETINT(NUM, FLAG, LOW, HIGH) INTEGER NUM, LOW, HIGH LOGICAL*1OK, FLAG OK = .FALSE. 2650 CONTINUE READ(5, 11, END=805, ERR=205) NCHRS, NUM 11 FORMAT(Q, I5) GOTO 806 805 CLOSE(UNIT = 5) 806 CONTINUE IF (.NOT.(NCHRS .EQ. 0)) GOTO 2680 FLAG = .FALSE. OK = .TRUE. GOTO 2690 2680 CONTINUE IF (.NOT.((NUM .GE. LOW) .AND. (NUM .LE. HIGH))) GOTO 2700 OK = .TRUE. FLAG = .TRUE. GOTO 2710 2700 CONTINUE WRITE(5, 131) 131 FORMAT('0What ? That command requires a number that is') WRITE(5, 141) LOW, HIGH 141 FORMAT(' between ', I6, ' and ', I6) WRITE(5, 151) 151 FORMAT('$Try again :') 2710 CONTINUE 2690 CONTINUE GOTO 2660 205 WRITE(5, 102) 102 FORMAT('$Try again Bozo :') 2660 IF (.NOT.(OK)) GOTO 2650 2670 CONTINUE RETURN END