-+-+-+-+-+-+-+-+ START OF PART 10 -+-+-+-+-+-+-+-+ X`09LOC=Z6+2*IARROW(I+1)`09`09`09!** X`09AB=EMAP(LOC) X`09IF (AB.EQ.' ') GOTO 400 X300`09CONTINUE X`09RETURN`09`09`09`09`09!DON'T JUMP X400`09ARMJMP=1 X`09RETURN`09`09`09`09`09!JUMP X`09END XC`20 X`09FUNCTION PRIORI(Z6,IFO,ILA,DIR,AC) XC X`09INCLUDE 'EMPIRE.INC/NOLIST' X`09BYTE GROUND,OK XC`20 X`09DO 100 I=1,7 X100`09PRIOR(I)=0 X`09EXPMAX=0 XC`20 XC NOW MAKE A GUESS AS TO WHAT THE MOVE WILL BE XC X`09MOVE1=ILA X`09IF (IFO.EQ.1.OR.IFO.EQ.2) MOVE1=MOV(Z6,ILA) X`09IF (IFO.EQ.3) MOVE1=MOV(Z6,RLMAP(ITT2+ILA)) XC`20 XC NOW SEE IF ANY PRIORITY MOVES EXIST XC X`09DO 200 I=0,7*DIR,DIR X`09MOVE=ICORR(MOVE1+I) X`09LOC=Z6+IARROW(MOVE+1)`09`09`09!** X`09IF (ORDER(LOC).NE.0) GOTO 200 X`09AB=RMAP(LOC) XC`20 XC CHECK IF ARMY CAN ATTACK SOMETHING OVER WATER XC X`09GROUND=OMAP(LOC) X`09OK='Y' X`09IF ((AC.EQ.'t').AND.(GROUND.EQ.'.')) OK='N' XC`20 X`09IF (AB.EQ.'O') PRIOR(1)=MOVE X`09IF ((AB.EQ.'T').AND.(OK.EQ.'Y')) PRIOR(3)=MOVE X`09IF (AB.EQ.'*') PRIOR(2)=MOVE X`09IF (AB.EQ.'A') PRIOR(5)=MOVE X`09IF ((AB.EQ.'S').AND.(OK.EQ.'Y')) PRIOR(6)=MOVE X`09IF ((IFO.EQ.0).AND.(AB.GE.'A').AND.(AB.LE.'T').AND.(OK.EQ.'Y')) X`091`09 PRIOR(7)=MOVE XC`20 X`09IF (GROUND.NE.'+') GOTO 200 X`09N=0 X`09IF (EMAP(LOC+IARROW(ICORR(MOVE-2)+1)).EQ.' ') N=1`09!** X`09IF (EMAP(LOC+IARROW(ICORR(MOVE-1)+1)).EQ.' ') N=N+1`09!** X`09IF (EMAP(LOC+IARROW(MOVE+1)).EQ.' ') N=N+1`09`09!** X`09IF (EMAP(LOC+IARROW(ICORR(MOVE+1)+1)).EQ.' ') N=N+1`09!** X`09IF (EMAP(LOC+IARROW(ICORR(MOVE+2)+1)).EQ.' ') N=N+1`09!** XC`09TYPE 999,N,EXPMAX XC999`09FORMAT(' N:',I2,' EXPMAX:',I2) X`09IF (N.LE.EXPMAX) GOTO 200 X`09PRIOR(4)=MOVE X`09EXPMAX=N X200`09CONTINUE XC`09TYPE 998 XC998`09FORMAT(' XXXXXXXXXXXXXXXX') XC`20 XC NOW SELECT THE HIGHEST PRIORITY MOVE XC X`09DO 300 I=1,7 X300`09IF (PRIOR(I).NE.0) GOTO 400 X`09PRIORI=0 X`09RETURN X400`09PRIORI=PRIOR(I) X`09RETURN X`09END XC`20 X`09FUNCTION MOV(I6,I7) XC XC RETURNS THE INDEX-1 INTO IARROW FOR THE DIRECTION OF THE MOVE XC FROM I6 TO I7 XC X`09INCLUDE 'EMPIRE.INC/NOLIST' X`09LOGICAL XMAJOR XC X`09IY6=(I6-1)/100 X`09IY7=(I7-1)/100 X`09IX6=I6-(100*IY6) X`09IX7=I7-(100*IY7) X`09IY=IY7-IY6 X`09IX=IX7-IX6 X XC SCREEN OUT TRIVIAL CASES X`09IF (IX.EQ.0) THEN X`09 DIR=SIGN(100,IY) X`09 GOTO 100 X`09 ENDIF X`09IF (IY.EQ.0) THEN X`09 DIR=SIGN(1,IX) X`09 GOTO 100 X`09 ENDIF X XC THIS ATTEMPTS A LINE-OF-SIGHT APPROXIMATION XC unfortunately a true LOS requires knowing where you came from! XC this routine currently tries to keep near a 3 to 1 ratio. X`09DX=ABS(IX)`09`09`09!GET DELTA X X`09DY=ABS(IY)`09`09`09!GET DELTA Y X`09XMAJOR=.TRUE.`09`09`09!ASSUME X IS MAJOR CHANGE X`09IF (DY.GT.DX) THEN`09`09! IF WRONG, SWITCH X`09 DX=DY X`09 DY=ABS(IX) X`09 XMAJOR=.FALSE. X`09 ENDIF`09 XC`09`09`09`09`09! the divisor determines the slope XC`09`09`09`09`09! perfect case would be delta y at start X`09IF (IFIX(FLOAT(DX)/3+.5).GT.DY) THEN`09!IF MAJOR IS LONG, GO STRAIGHT X`09 IF (XMAJOR) THEN X`09`09DIR=SIGN(1,IX) X`09 ELSE X`09`09DIR=SIGN(100,IY) X`09 ENDIF X`09 ELSE`09`09`09`09`09!OTHERWISE, TAKE DIAGONAL X`09`09DIR=SIGN(100,IY)+SIGN(1,IX) X`09 ENDIF X100`09DO 200 I=1,9`09`09`09`09!FIND THE INDEX X200`09IF (IARROW(I).EQ.DIR) GOTO 300 X300`09MOV=I-1`09`09`09`09`09!FOR COMPATIBILITY (?) X X XC OLD WAY: FOR HISTORIANS XC`09THIS DOES NOT DO A "TRUE" LINE OF SIGHT, FAVORS DIAGONALS XC`09IF ((IY.LT.0).AND.(IX.GT.0)) MOV=2 XC`09IF ((IY.LT.0).AND.(IX.EQ.0)) MOV=3 XC`09IF ((IY.LT.0).AND.(IX.LT.0)) MOV=4 XC`09IF ((IY.EQ.0).AND.(IX.LT.0)) MOV=5 XC`09IF ((IY.GT.0).AND.(IX.LT.0)) MOV=6 XC`09IF ((IY.GT.0).AND.(IX.EQ.0)) MOV=7 XC`09IF ((IY.GT.0).AND.(IX.GT.0)) MOV=8 XC`09IF ((IY.EQ.0).AND.(IX.GT.0)) MOV=1 XC`09IF ((IX.EQ.0).AND.(IY.EQ.0)) MOV=0 X X`09RETURN X`09END X`0C X`09SUBROUTINE BLOCK(AMAP) XC XC THIS SUBROUTINE MAKES A COPY OF MAP II INTO SUPPLIED FILE SPEC XC X`09INCLUDE 'EMPIRE.INC/NOLIST' X`09BYTE AMAP(6000) XC X`09ISEC=-1 X`09CALL ERASE_PAGE(1,1) X`09JECTOR=-1 X`09CALL STROUT(' Output file:',12) X`09ACCEPT 999,TTY X999`09FORMAT(20A1) X`09CALL ERASE_PAGE(1,1) X`09TTY(20)=0 X`09OPEN(UNIT=2,NAME=TTY,ACCESS='SEQUENTIAL',FORM='FORMATTED', X`091 STATUS='NEW',ERR=600) X`09DO 500 J=0,5900,100 X`09DO 200 K=100,1,-1 X`09AB=AMAP(K+J) X200`09IF (AB.NE.' ') GOTO 300 X`09GOTO 500 X300`09DO 400 L=1,K X400`09G2(L)=AMAP(J+L) X`09WRITE(2,998) (G2(L),L=1,K) X998`09FORMAT(1X,100A1) X500`09CONTINUE X`09CLOSE(UNIT=2) X`09RETURN X X600`09TYPE 997,TTY X997`09FORMAT (' ERROR, Unable to open output file ',20A1) X`09RETURN X`09END XC`20 XC`20 X`09SUBROUTINE IDEN(OWN) XC X`09INCLUDE 'EMPIRE.INC/NOLIST' XC X`09IF ((OWN.GE.'a').AND.(OWN.LE.'t')) CALL STROUT('Enemy',10) X`09IF ((OWN.LE.'T').AND.(OWN.GE.'A')) CALL STROUT('Your',10) X`09IF ((OWN.EQ.'A').OR.(OWN.EQ.'a')) GOTO 100 X`09IF ((OWN.EQ.'F').OR.(OWN.EQ.'f')) GOTO 200 X`09IF ((OWN.EQ.'D').OR.(OWN.EQ.'d')) GOTO 300 X`09IF ((OWN.EQ.'S').OR.(OWN.EQ.'s')) GOTO 400 X`09IF ((OWN.EQ.'T').OR.(OWN.EQ.'t')) GOTO 500 X`09IF ((OWN.EQ.'R').OR.(OWN.EQ.'r')) GOTO 600 X`09IF ((OWN.EQ.'C').OR.(OWN.EQ.'c')) GOTO 700 XC XC THEN IT IS A BATTLESHIP! XC X`09CALL STROUT('Battleship',10) X`09RETURN X100`09CALL STROUT('Army',10) X`09RETURN X200`09CALL STROUT('Fighter',10) X`09RETURN X300`09CALL STROUT('Destroyer',10) X`09RETURN X400`09CALL STROUT('Submarine',10) X`09RETURN X500`09CALL STROUT('Troop Transport',10) X`09RETURN X600`09CALL STROUT('Cruiser',10) X`09RETURN X700`09CALL STROUT('Aircraft Carrier',10) X`09RETURN X`09END XC`20 X`09SUBROUTINE HEAD(OWN1,Y,NUM,Z6,H1) XC X`09INCLUDE 'EMPIRE.INC/NOLIST' XC X`09CALL LIB$SET_CURSOR(1,1) X`09CALL IDEN(OWN1) X`09CALL DECPRT(Y) X`09CALL STROUT(' at',10) X`09CALL DECPRT(Z6) X`09CALL LIB$ERASE_LINE X`09CALL STSOUT(MYCODE(NUM)) X`09IF (OWN1 .EQ. 'F') THEN X`09 CALL LIB$SET_CURSOR(1,60) X`09 CALL STROUT('Range:',10) X`09 CALL DECPRT(RANGE(Y)) X`09 ENDIF X`09IF ((OWN1.NE.'F').AND.(OWN1.NE.'A')) THEN X`09 CALL LIB$SET_CURSOR(1,60) X`09 CALL STROUT('Hits left:',10) X`09 CALL DECPRT(H1) X`09 ENDIF X`09RETURN X`09END XC`20 X`09SUBROUTINE STSOUT(MYCOD) XC XC DISPLAY MYCOD FUNCTION IN ENGLISH XC X`09INCLUDE 'EMPIRE.INC/NOLIST' XC X`09CALL LIB$SET_CURSOR(1,40) X`09CALL STROUT('Function:',10) X`09IF (MYCOD.LT.6100) GOTO 200 X`09IF (MYCOD.EQ.9997) THEN`09`09`09!=9997, FILL FUNCTION X`09 CALL STROUT('Fill',13) X`09 GOTO 300 X`09 ENDIF X`09DO 100 I=6101,6108 X100`09IF (I.EQ.MYCOD) TYPE 999,COMM(I-6100)`09!6101<=MYCOD<=6108, DIRECTION X999`09FORMAT('+',A1,$) X`09GOTO 300 X200`09IF (MYCOD.GT.100) THEN`09`09`09!100A1,$) XC XC NOW SEPARATE PIECES OF N X`09J=MIN0(IABS(N/10),4) X`09IF (J.NE.0) TYPE 300,(BLANKS(I),I=1,J) XC X`09J=MOD(N,10) X`09IF (J.NE.0) CALL LIB$ERASE_LINE X`09IF (J.EQ.1) TYPE 400 X400`09FORMAT(1X) X`09RETURN X`09END XC X`09SUBROUTINE DECPRT(N) XC XC PRINT INTEGER N, WITH MINIMAL LEADING BLANKS XC X`09IMPLICIT INTEGER(A-Z) XC X`09IF (N.LT.0) TYPE 999 X999`09FORMAT('+-',$) X`09J=IABS(N) X`09IF (J.GE.10000) GOTO 500 X`09IF (J.GE.1000) GOTO 400 X`09IF (J.GE.100) GOTO 300 X`09IF (J.GE.10) GOTO 200 X100`09TYPE 998,J X998`09FORMAT('+',I1,$) X`09RETURN XC X200`09TYPE 997,J X997`09FORMAT('+',I2,$) X`09RETURN XC X300`09TYPE 996,J X996`09FORMAT('+',I3,$) X`09RETURN XC X400`09TYPE 995,J X995`09FORMAT('+',I4,$) X`09RETURN XC X500`09TYPE 994,J X994`09FORMAT('+',I5,$) X`09RETURN X`09END XC X`09SUBROUTINE HUH X`09IMPLICIT INTEGER(A-Z) XC X`09CALL LIB$SET_CURSOR(1,40) X`09CALL STROUT(' Huh?',2) X`09RETURN X`09END XC X`09FUNCTION GETCHX XC XC READS A CHARACTER WITH NO ECHO XC X`09IMPLICIT INTEGER (A-Z) X`09EXTERNAL IO$_READVBLK,IO$M_NOECHO X`09BYTE CHAR X`09INTEGER*2 CHAN X`09COMMON /CHAN/ CHAN X X`09IF (CHAN.EQ.0) CALL SYS$ASSIGN('TT',CHAN,,) X`09CALL SYS$QIOW(,%VAL(CHAN), X`091 %VAL(%LOC(IO$_READVBLK).OR.%LOC(IO$M_NOECHO)),,,, X`092 CHAR,%VAL(1),,,,) X`09GETCHX=CHAR X`09IF (GETCHX.GT.96) GETCHX=GETCHX-32 X X`09END X`0C X`09FUNCTION ICORR(N) X`09IMPLICIT INTEGER(A-Z) XC X`09ICORR=N X`09IF (ICORR.GT.8) ICORR=ICORR-8 X`09IF (ICORR.LT.1) ICORR=ICORR+8 X`09RETURN X`09END XC X`09FUNCTION IDIST(N1,N2) XC XC RETURN DISTANCE BETWEEN LOCATION N1 AND N2 XC X`09IMPLICIT INTEGER(A-Z) XC X`09X1=IABS(MOD(N1-1,100)-MOD(N2-1,100)) X`09Y1=IABS(((N1-1)/100)-((N2-1)/100)) X`09IDIST=MAX0(X1,Y1) X`09RETURN X`09END XC X`09SUBROUTINE STASIS(Z6,LOC) XC XC CHECK IF ARMY #LOC, AT Z6, IS NEAR THE ENEMY, IF SO WAKE HIM UP XC X`09INCLUDE 'EMPIRE.INC/NOLIST' XC X`09DO 200 I=1,8 X`09AB=RMAP(Z6+IARROW(I+1))`09`09!** X`09IF ((AB.GE.'a').AND.(AB.LE.'t')) GOTO 100 X`09IF (AB.EQ.'X') GOTO 100 X`09IF (AB.NE.'*') GOTO 200 X`09IF (RMAP(Z6).EQ.'F') GOTO 200 X100`09MYCODE(LOC)=0 X`09GOTO 300 X200`09CONTINUE X300`09RETURN X`09END XC`20 X`09SUBROUTINE DIST(Z6,ILA) XC XC THIS SUBROUTINE SETS AR2S SO THAT THE ARMY WON'T GET XC OFF THE TROOP TRANSPORT PREMATURELY XC`20 X`09INCLUDE 'EMPIRE.INC/NOLIST' XC X`09ID=2*IDIST(Z6,ILA)+1 X`09DO 100 L=1+IAR2,LIMIT(9)+IAR2 X100`09IF (RLMAP(L).EQ.Z6) AR2S(L-IAR2)=ID X`09RETURN X`09END XC`20 X`09FUNCTION ORDER(I6) XC XC RETURN =1 IF OFF THE EDGE OF THE MAP XC X`09IMPLICIT INTEGER(A-Z) XC X`09ORDER=1 X`09IF ((I6.LE.101).OR.(I6.GE.5900)) RETURN X`09IF (MOD(I6,100).LE.1) RETURN X`09ORDER=0 X`09RETURN X`09END XC X`09SUBROUTINE DIREC X`09CALL LIB$SET_CURSOR(2,40) X`09CALL STROUT(' H for Help!',2) X`09END X X`09FUNCTION EDGER(I) XC XC RETURN NUMBER OF SEA SQUARES THAT ARE ADJACENT TO LOCATION I XC X`09INCLUDE 'EMPIRE.INC/NOLIST' XC X`09EDGER=0 X`09DO 100 IA=1,8 X100`09IF (OMAP(I+IARROW(IA+1)).EQ.'.') EDGER=EDGER+1 X`09RETURN X`09END XC`20 X`09FUNCTION IPHASE(I) XC XC RETURN INTEGER OF ASCII I AS A SECTOR NUMBER XC X`09IMPLICIT INTEGER(A-Z) XC X`09IPHASE=0 X`09I=I.AND.127 X`09IF (I.GE.48 .AND. I.LE.57) IPHASE=I-48 X`09RETURN X`09END XC`20 X`09FUNCTION KLINE(KI,JECTOR) X`09IMPLICIT INTEGER(A-Z) X`09COMMON/SCREEN/GIGI,SWIDTH XC X`09KI=0 X`09JECT=JECTOR X`09IF (JECTOR.GT.4) THEN X`09 KI=100-SWIDTH X`09 JECT=JECT-5 X`09ENDIF X`09KLINE=(JECT*10)*100 X`09RETURN X`09END XC`20 X`09FUNCTION ISCAPE(I,M) X`09IMPLICIT INTEGER(A-Z) XC XC: I = NUMBER OF TIMES ONE HAS TRIED TO ESCAPE XCM: DIRECTION IN WHICH DANGER LIES XC X`09INTEGER ITAB(8) X`09BYTE PASS X`09COMMON/PASS/PASS X`09DATA ITAB/4,5,3,6,2,7,1,0/ XC X`09ISC=M X`09IF ((PASS).AND.((I.LT.1).OR.(I.GT.8))) GOTO 100 X`09IF ((PASS).AND.((ISC.LT.1).OR.(ISC.GT.8))) GOTO 100 X`09ISC=ICORR(M+ITAB(I)) X`09ISCAPE=ISC X`09RETURN X100`09TYPE 999,ISC,I,M X999`09FORMAT(' ISCAPE- ISC,M,I:',3I) X`09RETURN X`09END X X`09FUNCTION RND(IHIGH) XC X`09IMPLICIT INTEGER(A-Z) X`09INTEGER*2 TIME(4) X`09EQUIVALENCE (TIME(2),SEED) X`09REAL MTH$RANDOM X`09DATA SEED/0/ X`09IF (SEED.EQ.0) CALL SYS$GETTIM(TIME) X`09RND=IFIX(MTH$RANDOM(SEED)*IHIGH) X`09END X`0C X`09BYTE FUNCTION DECODE(Z6) XC XC UNPACK MAP DEFINITION FILE XC`09D() = MAP DEFINITION FROM MAP FILE XC`09Z6 = LOCATION XC`09DECODE = CHARACTER AT Z6 XC XC MAPS ARE ENCODED USING MOD 3 ARITHMETIC TO FIT 9 CHARACTERS INTO ONE 16-BI VT XC WORD. XC X`09IMPLICIT INTEGER(A-Z) X`09INTEGER MSKTAB(9) X`09INTEGER*2 D(667) X`09BYTE ASCII(3) X`09DATA ASCII/'.','+','*'/ X`09DATA MSKTAB/1,3,9,27,81,243,729,2187,6561/ X`09COMMON/MAP/D XC X`09IX=((Z6-1)/9)+1 X`09IY=MOD(Z6-1,9)+1 X`09DECODE=ASCII(MOD(D(IX)/MSKTAB(IY),3)+1) X`09RETURN X`09END X`0C XC XC RANDOM MAP GENERATION SUBROUTINES XC X`09SUBROUTINE GEN X`09IMPLICIT INTEGER(A-Z) X`09PARAMETER WIDTH=100,HEIGHT=60 X`09BYTE MAP(WIDTH,HEIGHT) X`09BYTE SUBMAP(39,39) X`09BYTE OWNER(WIDTH,HEIGHT) X`09INTEGER SIZES(128) X`09COMMON/CITIES/CITIES(128) X`09COMMON/SMAP/SUBMAP +-+-+-+-+-+-+-+- END OF PART 10 +-+-+-+-+-+-+-+-