edjames@ic.Berkeley.EDU (Ed James) (12/19/86)
I5=ICORR(I4)
I=Z6+IARROW(I5+1)
comment **
900 IF ((ORDER(I).EQ.0).AND.(AB9(I5).EQ.'+')) GOTO 1000
I4=0
1000 M=I1
IF (M.EQ.9) M=I3
IF (M.EQ.9) M=I2
IF (M.EQ.9) M=I5
IF (I4.EQ.0) M=9
JIGGLE=M
RETURN
END
SHAR_EOF
if test 716 -ne "`wc -c < 'jiggle.f'`"
then
echo shar: error transmitting "'jiggle.f'" '(should have been 716 characters)'
fi
fi # end of overwriting check
if test -f 'kline.c'
then
echo shar: will not over-write existing file "'kline.c'"
else
cat << \SHAR_EOF > 'kline.c'
#include <curses.h>
/*
* Changes jector (0->9) to ki (x offset) and line (returned) * 100
*/
kline_(ki, jector)
int *ki, *jector;
{
int ject;
*ki = 0;
ject = *jector;
if ( *jector > 4) {
*ki = 100 - (COLS - 10);
if (*ki < 0)
*ki = 0;
ject = ject - 5;
}
ject = ject * 10;
if (ject + LINES - 4 > 60) {
ject = 60 - (LINES - 4);
if (ject < 0)
ject = 0;
}
return (ject * 100);
}
SHAR_EOF
if test 404 -ne "`wc -c < 'kline.c'`"
then
echo shar: error transmitting "'kline.c'" '(should have been 404 characters)'
fi
fi # end of overwriting check
if test -f 'ltr.f'
then
echo shar: will not over-write existing file "'ltr.f'"
else
cat << \SHAR_EOF > 'ltr.f'
subroutine ltr(z6,iturn)
c
c Does short range scan around location z6
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
if (mode.ne.1) goto 100
call sensor(z6)
return
100 if (iturn.ne.1) goto 700
do 200 i7=1,8
i8=z6+iarrow(i7+1)
comment **
200 if ( rmap ( i8 ) .eq. pmap ( i8 )) goto 700
call cr
call strout ( 'Before sensor probe' )
l6=z6
if (l6.lt.101) l6=l6+100
if (l6.gt.5900) l6=l6-100
if (l6/100*100.eq.l6) l6=l6-1
if (l6/100*100+1.eq.l6) l6=l6+1
do 600 i=-101,99,100
do 400 i9=0,2
400 d2(i9+1)=omap(l6+i+i9)
comment **
do 500 i9=0,2
500 g2(i9+1)=pmap(l6+i+i9)
comment **
600 continue
call putc ( g2 ( 1 ))
call putc ( g2 ( 2 ))
call putc ( g2 ( 3 ))
call putc ( d2 ( 1 ))
call putc ( d2 ( 2 ))
call putc ( d2 ( 3 ))
call sensor(z6)
call cr
call strout ( 'After sensor probe' )
700 continue
l6=z6
if (l6.lt.301) l6=l6+300-(l6-1)/100*100
if (l6.gt.5700) l6=l6-(l6-1)/100*100+5600
if ((l6-1)/100*100+97.lt.l6) l6=97+(l6-1)/100*100
if ((l6-1)/100*100+4.gt.l6) l6=l6/100*100+4
do 900 i=-303,297,100
do 800 i9=0,6
g2(i9+1)=pmap(l6+i+i9)
comment **
jnkbuf ( i9 + 1 ) = char(g2( i9 + 1 ))
800 continue
call bufout ( jnkbuf, 7 )
call cr
900 continue
1000 continue
return
end
SHAR_EOF
if test 1211 -ne "`wc -c < 'ltr.f'`"
then
echo shar: error transmitting "'ltr.f'" '(should have been 1211 characters)'
fi
fi # end of overwriting check
if test -f 'makeland.f'
then
echo shar: will not over-write existing file "'makeland.f'"
else
cat << \SHAR_EOF > 'makeland.f'
SUBROUTINE MAKELAND
IMPLICIT INTEGER(A-Z)
REAL DIVER,RAD,COSANG,SINANG
include 'common.h'
DO 100 I=1,39
DO 100 J=1,39
SUBMAP(I,J)=' '
100 CONTINUE
SUBMAP(20,20)='+'
VARY=2+irand(5)
RADIUS=irand(5)+irand(5)
START=90-irand(180)
DO 400 ROT=START,START+360,3
IF (RADIUS.LE.0) GOTO 300
COSANG=COS(FLOAT(ROT)/3.14159)
SINANG=SIN(FLOAT(ROT)/3.14159)
RAD=0
DIVER=.5/(ABS(COSANG)+ABS(SINANG))
200 IF (RAD.GT.RADIUS) GOTO 300
RAD=RAD+DIVER
SUBMAP(20+int(RAD*COSANG),20+int(RAD*SINANG))='+'
GOTO 200
300 IF (MOD(ROT,10).NE.0) GOTO 400
RADIUS=RADIUS+irand(VARY)-(VARY/2)
IF (mod (VARY, 2).EQ.0) RADIUS=RADIUS+irand(2)
IF (RADIUS.GE.12) RADIUS=11
400 CONTINUE
c do 110 i =1, 39
c print 111, (submap(i,j),j=1,39)
c110 continue
c111 format(39a1)
RETURN
END
SHAR_EOF
if test 783 -ne "`wc -c < 'makeland.f'`"
then
echo shar: error transmitting "'makeland.f'" '(should have been 783 characters)'
fi
fi # end of overwriting check
if test -f 'mov.f'
then
echo shar: will not over-write existing file "'mov.f'"
else
cat << \SHAR_EOF > 'mov.f'
FUNCTION MOV(I6,I7)
C
C RETURNS THE INDEX-1 INTO IARROW FOR THE DIRECTION OF THE MOVE
C FROM I6 TO I7
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
LOGICAL XMAJOR
C
IY6=(I6-1)/100
IY7=(I7-1)/100
IX6=I6-(100*IY6)
IX7=I7-(100*IY7)
IY=IY7-IY6
IX=IX7-IX6
C SCREEN OUT TRIVIAL CASES
IF (IX.EQ.0) THEN
DIR=SIGN(100,IY)
GOTO 100
ENDIF
IF (IY.EQ.0) THEN
DIR=SIGN(1,IX)
GOTO 100
ENDIF
C THIS ATTEMPTS A LINE-OF-SIGHT APPROXIMATION
C unfortunately a true LOS requires knowing where you came from
comment
C this routine currently tries to keep near a 3 to 1 ratio.
DX=ABS(IX)
comment GET DELTA X
DY=ABS(IY)
comment GET DELTA Y
XMAJOR=.TRUE.
comment ASSUME X IS MAJOR CHANGE
IF (DY.GT.DX) THEN
comment IF WRONG, SWITCH
DX=DY
DY=ABS(IX)
XMAJOR=.FALSE.
ENDIF
C
comment the divisor determines the slope
C
comment perfect case would be delta y at start
IF (IFIX(FLOAT(DX)/3+.5).GT.DY) THEN
comment IF MAJOR IS LONG, GO STRAIGHT
IF (XMAJOR) THEN
DIR=SIGN(1,IX)
ELSE
DIR=SIGN(100,IY)
ENDIF
ELSE
comment OTHERWISE, TAKE DIAGONAL
DIR=SIGN(100,IY)+SIGN(1,IX)
ENDIF
100 DO 200 I=1,9
comment FIND THE INDEX
200 IF (IARROW(I).EQ.DIR) GOTO 300
300 MOV=I-1
comment FOR COMPATIBILITY (?)
C OLD WAY: FOR HISTORIANS
C THIS DOES NOT DO A "TRUE" LINE OF SIGHT, FAVORS DIAGONALS
C IF ((IY.LT.0).AND.(IX.GT.0)) MOV=2
C IF ((IY.LT.0).AND.(IX.EQ.0)) MOV=3
C IF ((IY.LT.0).AND.(IX.LT.0)) MOV=4
C IF ((IY.EQ.0).AND.(IX.LT.0)) MOV=5
C IF ((IY.GT.0).AND.(IX.LT.0)) MOV=6
C IF ((IY.GT.0).AND.(IX.EQ.0)) MOV=7
C IF ((IY.GT.0).AND.(IX.GT.0)) MOV=8
C IF ((IY.EQ.0).AND.(IX.GT.0)) MOV=1
C IF ((IX.EQ.0).AND.(IY.EQ.0)) MOV=0
RETURN
END
SHAR_EOF
if test 1698 -ne "`wc -c < 'mov.f'`"
then
echo shar: error transmitting "'mov.f'" '(should have been 1698 characters)'
fi
fi # end of overwriting check
if test -f 'movcor.f'
then
echo shar: will not over-write existing file "'movcor.f'"
else
cat << \SHAR_EOF > 'movcor.f'
FUNCTION MOVCOR
1 (IFO,ITURN,Z6,MOVE,IH1,IS1,AGGR,OWN1,EXPLOR,DIR,DEST,ORIG,HMAX)
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
character ab
C
C
C CHECK FOR IMPOSSIBLE CONDITION FOR MOVE
C
IF ((.NOT.PASS).OR.(IABS(MOVE).LE.8)) GOTO 100
call clear
call topini
PRINT 999,OWN1,Z6,MOVE,IFO
999 FORMAT(1X,A1,' @ ',I4,' ATTEMPTED ',I,' WITH IFO ',I4)
C
100 MOVE=IABS(MOVE)
C
IF (ITURN.EQ.1) BLAH=0
comment **
IF (BLAH.LT.0) MOVE=ICORR(I2+irand(3)-1)
comment **
C
C CHECK FOR SOMETHING TO ATTACK, OR, SOMETHING TO RUN FROM
C BLAH.LT.0: RUN
C BLAH.GE.0: ATTACK
C
DO 200 IX=1,8
I1=IX
LOC=Z6+IARROW(I1+1)
comment **
AB=RMAP(LOC)
IF (OMAP(LOC).NE.'.') GOTO 200
IF ((AB.LT.'B').OR.(AB.GT.'T')) GOTO 200
comment IF SH/PL, LOOK
BLAH=ATTACK(OWN1,AB,IH1,AGGR)
IF (BLAH.GE.0) GOTO 1200
comment ** ATTACK IT
GOTO 300
comment RUN FROM IT
200 CONTINUE
I1=0
comment NOTHING OF INTEREST HERE
GOTO 800
C
C SELECT AN APPROPRIATE ESCAPE MOVE
C
300 IS=irand(3)
DO 600 IN=1,8
I2=IN
IF ((IS.EQ.0).OR.(IN.GT.3)) GOTO 500
IF (IS.NE.1) GOTO 400
IF (IN.EQ.1) I2=2
IF (IN.EQ.2) I2=3
IF (IN.EQ.3) I2=1
GOTO 500
400 IF (IN.EQ.1) I2=3
IF (IN.EQ.2) I2=1
IF (IN.EQ.3) I2=2
500 I=IARROW(ISCAPE(I2,I1)+1)+Z6
comment **
IF ((RMAP(I).EQ.'.').AND.(ORDER(I).EQ.0)) GOTO 700
600 CONTINUE
I1=0
GOTO 800
700 I1=ISCAPE(I2,I1)
IF (OMAP(I).NE.'.') call topmsg ( 3, 'ISCAPE ERROR' )
GOTO 1200
C
800 IF (EXPLOR.EQ.0) GOTO 1000
comment **
EXPMAX=0
DO 900 IX=MOVE,MOVE+7
I1=ICORR(IX)
LOC1=Z6+IARROW(I1+1)
comment **
IF (ORDER(LOC1).NE.0) GOTO 900
IF (RMAP(LOC1).NE.'.') GOTO 900
IF (DEST.GT.0) THEN
IF (IDIST(Z6,DEST).LT.IDIST(LOC1,DEST)) GOTO 900
ENDIF
NEXP=0
IF (EMAP(LOC1+IARROW(I1+1)).EQ.' ') NEXP=1
comment **
IF (EMAP(LOC1+IARROW(ICORR(I1-1)+1)).EQ.' ') NEXP=NEXP+1
comment **
IF (EMAP(LOC1+IARROW(ICORR(I1+1)+1)).EQ.' ') NEXP=NEXP+1
comment **
IF (EMAP(LOC1+IARROW(ICORR(I1+2)+1)).EQ.' ') NEXP=NEXP+1
comment **
IF (EMAP(LOC1+IARROW(ICORR(I1-2)+1)).EQ.' ') NEXP=NEXP+1
comment **
IF (NEXP.EQ.5) GOTO 1200
IF (NEXP.LE.EXPMAX) GOTO 900
EXPMAX=NEXP
I11=I1
900 CONTINUE
I1=0
IF (EXPMAX.EQ.0) GOTO 1000
I1=I11
GOTO 1200
1000 I2=MOVE
LOC1=Z6+IARROW(MOVE+1)
comment **
AB=RMAP(LOC1)
IF (LOC1.NE.ORIG) THEN
IF (((AB.EQ.'.').OR.(AB.EQ.'X')).AND.(ORDER(LOC1).EQ.0)) GOTO 1200
ENDIF
M=MOVE
IA=ICORR(M-DIR*3)
IF (RMAP(Z6+IARROW(IA+1)).NE.'.') M=IA
comment **
DO 1100 I=0,7*DIR,DIR
I2=ICORR(M+I)
I3=Z6+IARROW(I2+1)
comment **
IF ((RMAP(I3).EQ.'.').AND.(ORDER(I3).EQ.0).AND.(I3.NE.ORIG)) GOTO 1200
1100 CONTINUE
I2=0
1200 IF (I1.NE.0) I2=I1
IF (RMAP(Z6+IARROW(MOVE+1)).NE.'X') MOVE=I2
comment **
IF ((RMAP(Z6).EQ.'X').AND.(IH1.LT.HMAX)) MOVE=0
MOVCOR=MOVE
RETURN
END
SHAR_EOF
if test 2696 -ne "`wc -c < 'movcor.f'`"
then
echo shar: error transmitting "'movcor.f'" '(should have been 2696 characters)'
fi
fi # end of overwriting check
if test -f 'mve.f'
then
echo shar: will not over-write existing file "'mve.f'"
else
cat << \SHAR_EOF > 'mve.f'
ccc mve - handle player move mode
subroutine mve(own1,xxxmdate,relnum,num,n2,z6,z7,disas,jursor)
c
c inputs:
c own1 = char of piece (ie: 'a' for army)
c xxxmdate = round number
c relnum = relative piece number to type
c num = piece index to rlmap
c n2 = piece index to hits
c z6 = location, return new location
c z7 = old location
c disas = 0:ok, -2:stasis
c jursor = current cursor
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
disas=0
c
c Get command character with no echo
c
100 call sector ( pmap ( 1 ))
ib = j1ts ( n2 )
call head ( own1, relnum, num, z6, ib )
comment display header
call cursor ( jursor )
200 e = char(getchx())
call topmsg ( 2, 0 )
comment clear line
call topmsg ( 3, 0 )
comment clear line
call cflush
c
c Look at the command
c
z7 = z6
do 300 i = 1, 9
ind = i
300 if ( e .eq. kbtbl ( ind )) goto 400
goto 500
comment command is not a direction
400 z6 = z6 + kbfudg ( ind )
goto 4200
500 end = 15
if ( pass ) end = 20
do 600 i = 1, end
600 if ( e .eq. comman ( i )) goto 700
i = 0
c
c s, r, i, k, o, l, f, g, p, h, y, t, v, j, ?, 0, 0, u, n, +
c
700 goto ( 900, 1000, 1100, 1500, 1900, 2000, 2300, 2400, 2500, 2600,
* 2700, 2800, 2900, 3200, 3300, 800, 800, 3800, 3900, 2600 ) i
800 goto 100
c
c s: put to sleep
c
900 if ( rmap ( z6 ) .eq. 'O' ) return
mycode ( num ) = 50
return
c
c r: random movement
c
1000 if ( own1 .ne. 'A' ) goto 100
comment only for armies
mycode ( num ) = 100
z6 = z6 + iarrow ( jiggle ( z6, num ) + 1 )
return
c
c i: put in directional stasis
c
1100 call cursor(jursor)
comment cuz of clear lines above
e=char(getchx())
do 1200 i=1,9
if (e .eq. kbtbl(i)) goto 1300
1200 continue
goto 1400
1300 mycode(num)=cmytbl(i)
1400 if (mycode(num).eq.0) goto 100
disas=-2
return
c
c k: kill stasis number on piece
c
1500 mycode(num)=0
comment zero function code for anything
if (own1.ne.'T') goto 1700
comment if transport, wake armies aboard
do 1600 j=1,500
1600 if (rlmap(j).eq.z6) mycode(j)=0
goto 100
1700 if (own1.ne.'C') goto 100
comment if carrier, wake fighters aboard
do 1800 j=501,700
1800 if (rlmap(j).eq.z6) mycode(j)=0
goto 100
c
c o: cancel auto move mode
c
1900 continue
if ( .not. automv ) goto 1913
automv = .false.
call topmsg ( 3, 'Auto move mode canceled' )
goto 100
1913 continue
call topmsg ( 3, 'Not in auto mode!' )
goto 100
C
C L: SET UP CITY STASIS NUMBERS
C
2000 IF (OMAP(Z6).NE.'*') GOTO 2300
comment BETTER BE A CITY
E=char(GETCHX())
DO 2100 I=1,9
IF (E .EQ. KBTBL(I)) GOTO 2200
2100 CONTINUE
GOTO 4100
2200 FIPATH(CITFND(Z6))=CMYTBL(I)
comment SET STASIS NUMBER
DISAS=-2
RETURN
C
C F:
C
2300 CALL DIREC
GOTO 4100
C
C G: PUT T/C TO SLEEP
C
2400 IF ((OWN1.NE.'T').AND.(OWN1.NE.'C')) GOTO 100
MYCODE(NUM)=9997
DISAS=-2
RETURN
C
C P: SECTOR PRINTOUT
C
2500 ISEC=-1
CALL SECTOR(PMAP(1))
GOTO 4100
c
c h: get help
c
2600 call help
e = char(getchx())
isec = -1
goto 4100
C
C Y: CHANGE PHASE OF A CITY
C
2700 CALL DIREC
GOTO 4100
C
C T: BLOCK PRINTOUT
C
C2800 CALL CLEAR
C CALL BLOCK(PMAP(1))
C ISEC=-1
C GOTO 4100
C
C V: SAVE GAME
C
C2900 CALL GAME(1,NUM)
comment NOT SURE THIS WILL WORK AS PLAYERS EXPECT
2800 CONTINUE
2900 CALL DIREC
GOTO 100
C
C J: PUT IN EDIT MODE
C
3200 CALL EDIT(Z6)
IF (MYCODE(NUM).EQ.0) GOTO 100
DISAS=-2
RETURN
c
c ?: how many hits? loaded?
c
3300 if ((own1.eq.'A').or.(own1.eq.'F')) goto 100
ib=j1ts(n2)
comment display hits left
ptr = 0
C CALL sstrout ( ' Hits left:',10)
n = 0
comment count armies
if ( own1 .ne. 'T' ) goto 3500
do 3400 i = 1, 500
3400 if ( rlmap ( i ) .eq. z6 ) n = n + 1
if ( n .eq. 0 ) goto 3700
cc if (mode.eq.1) call tpos(3,1)
call addint ( n, jnkbuf, ptr )
if ( n .eq. 1 ) call addstr ( ' army', jnkbuf, ptr )
if ( n .gt. 1 ) call addstr ( ' armies', jnkbuf, ptr )
goto 1313
3500 if ( own1 .ne. 'C' ) goto 4100
do 3600 i = 1, 200
comment count fighters
3600 if ( rlmap ( i + 500 ) .eq. z6 ) n = n + 1
if ( n .eq. 0 ) goto 3700
cc if (mode.eq.1) call tpos(3,1)
call addstr ( ' fighter', jnkbuf, ptr )
if ( n .gt. 1 ) call addstr ( 's', jnkbuf, ptr )
1313 continue
call addstr ( ' aboard', jnkbuf, ptr )
jnkbuf(ptr + 1) = '\0'
call topmsg ( 3, jnkbuf )
call cflush
goto 4100
3700 continue
comment nothing aboard
cc if (mode.eq.1) call tpos(3,1)
call topmsg ( 3, 'Nothing aboard' )
call cflush
GOTO 4100
C
C U: CALL REFERENCE MAP
C
3800 ISEC=-1
CALL SECTOR(RMAP(1))
GOTO 4100
C
C N: CALL ENEMY MAP
C
3900 ISEC=-1
CALL SECTOR(EMAP(1))
GOTO 4100
C
C +: BLOCK PRINT REF. MAP
C
4000 call clear
call topini
ISEC=-1
CALL BLOCK(RMAP(1))
E=char(GETCHX())
GOTO 4100
C
4100 call ltr(z6,2)
call cflush
goto 100
4200 if (order(z6).eq.0) goto 4300
cc if (mode.eq.1) call tpos(3,1)
call topmsg ( 3, 'You cannot move onto the edge of the world' )
z6 = z7
goto 4100
4300 return
end
SHAR_EOF
if test 4814 -ne "`wc -c < 'mve.f'`"
then
echo shar: error transmitting "'mve.f'" '(should have been 4814 characters)'
fi
fi # end of overwriting check
if test -f 'order.c'
then
echo shar: will not over-write existing file "'order.c'"
else
cat << \SHAR_EOF > 'order.c'
#include <stdio.h>
/*
* Return 1 if off the edge of the map
*/
order_(ip)
int *ip;
{
if (*ip <= 101 || *ip >= 5900 || (*ip % 100) <= 1)
return (1);
else
return (0);
}
SHAR_EOF
if test 176 -ne "`wc -c < 'order.c'`"
then
echo shar: error transmitting "'order.c'" '(should have been 176 characters)'
fi
fi # end of overwriting check
if test -f 'path.f'
then
echo shar: will not over-write existing file "'path.f'"
else
cat << \SHAR_EOF > 'path.f'
FUNCTION PATH(BEG,END,DIR,OKVECT,FLAG)
C
C PATH SUBROUTINE FOR EMPIRE
C FINDS DIRECTION TO MOVE UNIT, FROM BEG TO END, OKVECT SPECIFIES OK TERRAIN.
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
character OKVECT(5)
C
BACKUP=1
TDIR=DIR
comment GET A DIRECTION TO FIDDLE WITH
DIR3=TDIR*3
Z6=BEG
MAXMVE=(2 * IDIST(BEG,END))+1
comment COMPUTE MAX MOVES TO GET THERE
MOVNUM=MAXMVE
100 DO 200 I=1,100
comment CLEAR G2 ARRAY
G2(I)=0
200 CONTINUE
C STRGHT:
comment TRY STRAIGHT MOVE FIRST
300 MOOVE= MOV(Z6,END)
Z62=Z6+IARROW(MOOVE+1)
AB=EMAP(Z62)
IF (COMPAR(AB,Z62,OKVECT).EQ.0) GOTO 900
comment IF NO GOOD, FOLLOW SHORE
C OKSET:
comment STRAGHT MOVE WORKING
400 BAKADR=1
C OKMOVE:
500 IF (Z6 .EQ. BEG) MOVE1=MOOVE
Z6=Z62
IF (FLAG.GE.1000) CALL TEST4(Z6,FLAG,TDIR,MOVE1,MOVNUM,BEG,
1 END,G2,BAKADR)
IF (Z6 .EQ. END) GOTO 800
comment IF Z6=END, WE'RE DONE
C DOMORE:
600 MOVNUM=MOVNUM-1
IF (MOVNUM .EQ. 0) GOTO 700
comment REACHED MAX MOVES, TRY NEW DIRECTION
C STRGHT, CHKNXT
GOTO (300, 1300), BAKADR
comment CONTINUE, IN SAME MANNER
C TRYDIR::
700 DIR3=-DIR3
comment NEGATE CURRENT DIRECTION
TDIR=-TDIR
IF (TDIR .EQ. DIR) GOTO 1200
comment GIVE UP IF BACK TO START
MOVNUM=MAXMVE
comment ELSE, TRY AGAIN
BACKUP=1
Z6=BEG
GOTO 100
C SUCCES: SUCCESS, RETURN
800 PATH=MOVE1
SUCCES=SUCCES+1
FLAG=1
RETURN
C FOLSHR: FOLLOW THE SHORE
900 MOV1=ICORR(MOOVE-DIR3)
comment TRY AGAIN
Z62=Z6+IARROW(MOV1+1)
AB=EMAP(Z62)
IF (COMPAR(AB,Z62,OKVECT).EQ.1) MOV1=MOOVE
comment ???
C STFOL:
1000 DO 1100 IVAR= MOV1,MOV1+7*TDIR,TDIR
MOOVE=ICORR(IVAR)
Z62=Z6+IARROW(MOOVE+1)
IF (ORDER(Z62) .NE. 0) GOTO 1100
AB=EMAP(Z62)
IF (COMPAR(AB,Z62,OKVECT).EQ.0) GOTO 1100
C OKSET2:
BAKADR=2
GOTO 500
1100 CONTINUE
C FAILUR:
1200 PATH=MOV(BEG,END)
FAILUR=FAILUR+1
FLAG=0
RETURN
C CHKNXT:
1300 T1=MOV(Z6,END)
Z62=Z6+IARROW(T1+1)
AB=EMAP(Z62)
IF (COMPAR(AB,Z62,OKVECT).EQ.0) GOTO 900
DO 1400 IVAR=BACKUP,1,-1
IF (Z6 .EQ. G2(IVAR)) GOTO 900
1400 CONTINUE
G2(BACKUP)=Z6
BACKUP=BACKUP+1
IF (BACKUP .LE. 100) GOTO 300
GOTO 700
END
SHAR_EOF
if test 2059 -ne "`wc -c < 'path.f'`"
then
echo shar: error transmitting "'path.f'" '(should have been 2059 characters)'
fi
fi # end of overwriting check
if test -f 'phasin.f'
then
echo shar: will not over-write existing file "'phasin.f'"
else
cat << \SHAR_EOF > 'phasin.f'
subroutine phasin(num,e)
c
c Prompt for city production type, set prod accordingly
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
e = char(getchx())
do 200 i=1,8
200 if ( e .eq. phaze ( i )) goto 300
call huh
e = ' '
return
comment if he doesn't do it right, leave it
300 phase ( num) = phazee ( i )
found ( num ) = mdate + 6 * phase ( num )
return
end
SHAR_EOF
if test 365 -ne "`wc -c < 'phasin.f'`"
then
echo shar: error transmitting "'phasin.f'" '(should have been 365 characters)'
fi
fi # end of overwriting check
if test -f 'poschk.f'
then
echo shar: will not over-write existing file "'poschk.f'"
else
cat << \SHAR_EOF > 'poschk.f'
FUNCTION POSCHK(Z6,OWN)
C
C DETERMINES IF Z6 IS IN CURRENT UPDATE SECTOR SHOWING
C 0=NO, 1=YES
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
INTEGER LOWSCRS(5),HIGHSCRS(5)
DATA LOWSCRS/1,14,24,34,44/
DATA HIGHSCRS/15,25,35,45,58/
C
IF (MODE.EQ.1) GOTO 100
POSCHK=1
GOTO 400
100 JECT=JECTOR
POSCHK=0
IY=(Z6-1)/100
IX=Z6-IY*100
ADJUST=1
IF (OWN.EQ.'F') ADJUST=0
IF (JECT.GT.4) GOTO 200
IF (IX.GT.(64+ADJUST)) GOTO 400
GOTO 300
200 IF (IX.LT.(36-ADJUST)) GOTO 400
JECT=JECT-5
300 IF ((IY.LT.(LOWSCRS(JECT+1)-ADJUST)).OR.
1 (IY.GT.(HIGHSCRS(JECT+1)+ADJUST))) GOTO 400
POSCHK=1
400 RETURN
END
SHAR_EOF
if test 615 -ne "`wc -c < 'poschk.f'`"
then
echo shar: error transmitting "'poschk.f'" '(should have been 615 characters)'
fi
fi # end of overwriting check
if test -f 'priori.f'
then
echo shar: will not over-write existing file "'priori.f'"
else
cat << \SHAR_EOF > 'priori.f'
FUNCTION PRIORI(Z6,IFO,ILA,DIR,AC)
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
character GROUND,OK
C
DO 100 I=1,7
100 PRIOR(I)=0
EXPMAX=0
C
C NOW MAKE A GUESS AS TO WHAT THE MOVE WILL BE
C
MOVE1=ILA
IF (IFO.EQ.1.OR.IFO.EQ.2) MOVE1=MOV(Z6,ILA)
IF (IFO.EQ.3) MOVE1=MOV(Z6,RLMAP(ITT2+ILA))
C
C NOW SEE IF ANY PRIORITY MOVES EXIST
C
DO 200 I=0,7*DIR,DIR
MOVE=ICORR(MOVE1+I)
LOC=Z6+IARROW(MOVE+1)
comment **
IF (ORDER(LOC).NE.0) GOTO 200
AB=RMAP(LOC)
C
C CHECK IF ARMY CAN ATTACK SOMETHING OVER WATER
C
GROUND=OMAP(LOC)
OK='Y'
IF ((AC.EQ.'t').AND.(GROUND.EQ.'.')) OK='N'
C
IF (AB.EQ.'O') PRIOR(1)=MOVE
IF ((AB.EQ.'T').AND.(OK.EQ.'Y')) PRIOR(3)=MOVE
IF (AB.EQ.'*') PRIOR(2)=MOVE
IF (AB.EQ.'A') PRIOR(5)=MOVE
IF ((AB.EQ.'S').AND.(OK.EQ.'Y')) PRIOR(6)=MOVE
IF ((IFO.EQ.0).AND.(AB.GE.'A').AND.(AB.LE.'T').AND.(OK.EQ.'Y'))
1 PRIOR(7)=MOVE
C
IF (GROUND.NE.'+') GOTO 200
N=0
IF (EMAP(LOC+IARROW(ICORR(MOVE-2)+1)).EQ.' ') N=1
comment **
IF (EMAP(LOC+IARROW(ICORR(MOVE-1)+1)).EQ.' ') N=N+1
comment **
IF (EMAP(LOC+IARROW(MOVE+1)).EQ.' ') N=N+1
comment **
IF (EMAP(LOC+IARROW(ICORR(MOVE+1)+1)).EQ.' ') N=N+1
comment **
IF (EMAP(LOC+IARROW(ICORR(MOVE+2)+1)).EQ.' ') N=N+1
comment **
C PRINT 999,N,EXPMAX
C999 FORMAT(' N:',I2,' EXPMAX:',I2)
IF (N.LE.EXPMAX) GOTO 200
PRIOR(4)=MOVE
EXPMAX=N
200 CONTINUE
C PRINT 998
C998 FORMAT(' XXXXXXXXXXXXXXXX')
C
C NOW SELECT THE HIGHEST PRIORITY MOVE
C
DO 300 I=1,7
300 IF (PRIOR(I).NE.0) GOTO 400
PRIORI=0
RETURN
400 PRIORI=PRIOR(I)
RETURN
END
SHAR_EOF
if test 1519 -ne "`wc -c < 'priori.f'`"
then
echo shar: error transmitting "'priori.f'" '(should have been 1519 characters)'
fi
fi # end of overwriting check
if test -f 'prod.f'
then
echo shar: will not over-write existing file "'prod.f'"
else
cat << \SHAR_EOF > 'prod.f'
subroutine prod ( ahits, z6, alimit, acrahit, acraloc, alopmax,
* aar2s, j, arange, string, point )
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
character string ( 80 )
integer point
integer aar2s(500),arange(200)
do 1000 i = acraloc + 1, alopmax + acraloc
if ( rlmap ( i ) .ne. 0 ) goto 1000
if ( i .gt. alimit + acraloc ) alimit = i - acraloc
rlmap ( i ) = z6
if ( ahits .gt. 1 ) j1ts ( acrahit + i - acraloc ) = ahits
if ( j .gt. 1 ) mycode ( i ) = 0
if ( j .lt. 2 ) codefu ( i - 1500 ) = 0
if ( j .lt. 2 ) codela ( i - 1500 ) = 0
if ( j .eq. 1 ) aar2s ( i - 1500 ) = 0
if ( acraloc .eq. 2000 ) arange ( i - 2000 ) = 20
if ( j .eq. 3 ) arange ( i - 500 ) = 20
cc if (( j .le. 1 ) .or. ( j .ge. 10 )) return
call addrock ( j, string, point )
return
1000 continue
return
end
SHAR_EOF
if test 804 -ne "`wc -c < 'prod.f'`"
then
echo shar: error transmitting "'prod.f'" '(should have been 804 characters)'
fi
fi # end of overwriting check
if test -f 'putc.c'
then
echo shar: will not over-write existing file "'putc.c'"
else
cat << \SHAR_EOF > 'putc.c'
putc_(cp)
char *cp;
{
caddch_(cp);
}
SHAR_EOF
if test 39 -ne "`wc -c < 'putc.c'`"
then
echo shar: error transmitting "'putc.c'" '(should have been 39 characters)'
fi
fi # end of overwriting check
if test -f 'read.f'
then
echo shar: will not over-write existing file "'read.f'"
else
cat << \SHAR_EOF > 'read.f'
subroutine read(beg,lim,num)
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
do 100 j = beg + 1, beg + lim
read ( 1 ) k
rlmap ( j ) = k
if (num .lt. 9) read ( 1 ) mycode(j)
if (num .gt. 8) read ( 1 ) codefu(j-1500),codela(j-1500)
if (num .eq. 9) read ( 1 ) ar2s(j-1500)
if (num .eq. 2) read ( 1 ) range(j-500)
if (num .eq. 10) read ( 1 ) rang(j-2000)
100 continue
return
end
SHAR_EOF
if test 386 -ne "`wc -c < 'read.f'`"
then
echo shar: error transmitting "'read.f'" '(should have been 386 characters)'
fi
fi # end of overwriting check
if test -f 'round.f'
then
echo shar: will not over-write existing file "'round.f'"
else
cat << \SHAR_EOF > 'round.f'
ccc round - display the round number
subroutine round ( date )
implicit integer(A-Z)
integer date
include 'common.h'
character jbuf ( 10 )
integer i
integer tmpx
do 100 i = 1, 3
jnkbuf ( i ) = ' '
100 continue
i = 0
call addint ( date, jbuf, i )
comment date in jbuf
tmpx = cols - 2
call bufpos ( 20, tmpx, jbuf(1), 1 )
call bufpos ( 21, tmpx, jbuf(2), 1 )
call bufpos ( 22, tmpx, jbuf(3), 1 )
return
end
SHAR_EOF
if test 429 -ne "`wc -c < 'round.f'`"
then
echo shar: error transmitting "'round.f'" '(should have been 429 characters)'
fi
fi # end of overwriting check
if test -f 'scrchk.f'
then
echo shar: will not over-write existing file "'scrchk.f'"
else
cat << \SHAR_EOF > 'scrchk.f'
FUNCTION SCRCHK(Z6)
C
C DETERMINES IF Z6 IS IN CURRENT SCREEN SECTOR SHOWING
C 0=NO, 1=YES
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
C
IF (MODE.EQ.1) GOTO 100
SCRCHK=1
GOTO 400
100 JECT=JECTOR
SCRCHK=0
IY=(Z6-1)/100
IX=Z6-IY*100
IF (JECT.GT.4) GOTO 200
comment CHECK X COORD FIRST
IF (IX.GT.70) GOTO 400
GOTO 300
200 IF (IX.LT.30) GOTO 400
JECT=JECT-5
300 IF ((IY.LT.(JECT*10)).OR.(IY.GT.(JECT*10+19))) GOTO 400
SCRCHK=1
comment PASSED, IT'S GOOD
400 RETURN
END
SHAR_EOF
if test 481 -ne "`wc -c < 'scrchk.f'`"
then
echo shar: error transmitting "'scrchk.f'" '(should have been 481 characters)'
fi
fi # end of overwriting check
if test -f 'sector.f'
then
echo shar: will not over-write existing file "'sector.f'"
else
cat << \SHAR_EOF > 'sector.f'
subroutine sector ( amap )
c
c This subroutine display sector jector from map ii
c if isec=jector, map will not be displayed again
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
character amap ( 6000 )
width = cols - 10
height = lines - 4
20 if ( jector .eq. -1 ) goto 200
if ( mode .ne. 1 ) return
if ( contained(isec, jector) .eq. 1) return
if ( isec .ne. jector ) goto 100
if ( newrnd .eq. 1 ) goto 1300
return
100 isec=jector
goto 300
200 call topmsg ( 1, 'Sector? ' )
jector=iphase(getchx())
if ((jector.lt.0).or.(jector.gt.9)) goto 200
isec=jector
jector=-1
comment let main know that updating sector isn't used
300 continue
call cflush
call delay ( 45 )
comment delay before zapping old sector
call clear
call topini
line=kline(ki,isec)
linefi=line+ 100 * height
comment linefi=line after last line of sector
linec=line-100
comment get set for line 400
400 linec=linec+100
comment goto next line
if (linec.ge.linefi) goto 1000
comment check for end of sector
kstart = ki + 1
comment if line is broken, kstart will be modified
500 do 600 j=kstart,ki+width
comment ki itself is not in sector
ab = amap ( j + linec )
comment get character
600 if (ab.ne.' ') goto 700
comment find first non-blank spot
goto 400
comment no characters in this line
700 kinit = j
comment ab is already calculated
g2(j)=ab
comment avoids repitition
do 800 j=kinit+1,ki+width
comment look for blank character
ab=amap(j+linec)
comment get character
if (ab.eq.' ') goto 900
comment exit loop if blank
800 g2(j)=ab
comment put char. string in an array
900 kfinal=j-1
comment set end of char. string
call cursor(kinit-line+linec-ki+300)
comment position cursor
c encode (kfinal-kinit+2,999,jnkbuf)(g2(j),j=kinit,kfinal),0
c999 format(<kfinal-kinit+2>a1)
call encpri (g2, kinit, kfinal)
if (kfinal.ge.ki+width) goto 400
comment next line
kstart = kfinal + 1
comment look at rest of line
goto 500
1000 kursor = (lines - 1) * 100
c
c Print x coordinates
c
do 1100 i = ki, ki + width, 10
call tpos ( lines, i - ki + 1 )
ptr = 0
call addint ( i, jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call strout ( jnkbuf )
1100 continue
c
c Print y coordinates
c
xkursor = cols - 8
ykursor = 4
max = line / 100 + height - 1
1110 do 1200 i=line/100,max,2
c call cursor ( kursor )
call tpos ( ykursor + i - line / 100, xkursor + 1 )
ptr = 0
call addint ( i, jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call strout ( jnkbuf )
c kursor=kursor+200
1200 continue
call cflush
cc do 1314 ptr = 1, 3
cc jnkbuf ( ptr ) = ' '
cc1314 continue
cc ptr = 1
cc call addint ( mdate, jnkbuf, ptr )
comment date in jnkbuf
call strpos ( 5, cols - 2, 'S' )
call strpos ( 6, cols - 2, 'e' )
call strpos ( 7, cols - 2, 'c' )
call strpos ( 8, cols - 2, 't' )
call strpos ( 9, cols - 2, 'o' )
call strpos ( 10, cols - 2, 'r' )
call bufpos ( 12, cols - 2, char(isec + 48), 1 )
call strpos ( 14, cols - 2, 'R' )
call strpos ( 15, cols - 2, 'o' )
call strpos ( 16, cols - 2, 'u' )
call strpos ( 17, cols - 2, 'n' )
call strpos ( 18, cols - 2, 'd' )
cc call bufpos ( 20, cols - 2, jnkbuf ( 1 ), 1 )
cc call bufpos ( 21, cols - 2, jnkbuf ( 2 ), 1 )
cc call bufpos ( 22, cols - 2, jnkbuf ( 3 ), 1 )
call round ( mdate )
call cflush
1300 continue
newrnd = 0
return
end
SHAR_EOF
if test 3273 -ne "`wc -c < 'sector.f'`"
then
echo shar: error transmitting "'sector.f'" '(should have been 3273 characters)'
fi
fi # end of overwriting check
if test -f 'sensor.f'
then
echo shar: will not over-write existing file "'sensor.f'"
else
cat << \SHAR_EOF > 'sensor.f'
subroutine sensor(z6)
c
c Updates player's map around location z6
c and screen if current sector is displayed
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
ibefor = -100
do 100 i = 1, 9
i1 = z6 + arrow ( i )
ab = rmap ( i1 )
if ( ab .eq. pmap ( i1 )) goto 100
pmap ( i1 ) = ab
if ( jector .eq. -1 ) goto 100
if ( isec .eq. -1 ) goto 100
line = kline ( ki, isec )
iy = ( i1 - 1 ) / 100 * 100
ix = i1 - iy
if (( iy .lt. line ) .or. ( iy .gt. line + (lines - 5) * 100 ) .or.
* ( ix .le. ki ) .or. (ix .gt. ki + (cols - 10) )) goto 100
i1 = i1 - line - ki
if ( ibefor + 1 .ne. i1 ) call cursor ( i1 + 300 )
ibefor = i1
call putc ( ab )
100 continue
call cflush
return
end
SHAR_EOF
if test 698 -ne "`wc -c < 'sensor.f'`"
then
echo shar: error transmitting "'sensor.f'" '(should have been 698 characters)'
fi
fi # end of overwriting check
if test -f 'set.f'
then
echo shar: will not over-write existing file "'set.f'"
else
cat << \SHAR_EOF > 'set.f'
FUNCTION SET(XPOS,YPOS,AREA,LS,LIM)
IMPLICIT INTEGER(A-Z)
include 'common.h'
PARAMETER (WIDTH=100,HEIGHT=60)
character area
integer xx, yy
integer*2 XSTACK(12000)
integer*2 YSTACK(12000)
integer*2 CSTACK(12000)
character LS
character MAP(width, height)
character owned(width, height)
INTEGER XADDS(8),YADDS(8)
EQUIVALENCE (MAP(1,1),OMAP(1)),(OWNED(1,1),RMAP(1))
DATA XADDS/-1,0,1,-1,1,-1,0,1/
DATA YADDS/-1,-1,-1,0,0,1,1,1/
OWNED(XPOS,YPOS)=AREA
LEVEL=1
XX=XPOS
YY=YPOS
100 K=1
200 IF ((XX+XADDS(K).LT.2).OR.(XX+XADDS(K).GT.99)) GOTO 300
IF ((YY+YADDS(K).LT.2).OR.(YY+YADDS(K).GT.59)) GOTO 300
IF (MAP(XX+XADDS(K),YY+YADDS(K)).NE.LS) GOTO 300
IF (OWNED(XX+XADDS(K),YY+YADDS(K)).NE.'\0') GOTO 300
OWNED(XX+XADDS(K),YY+YADDS(K))=AREA
XSTACK(LEVEL)=XX
YSTACK(LEVEL)=YY
CSTACK(LEVEL)=K
LEVEL=LEVEL+1
IF (LEVEL.GT.LIM) THEN
SET=0
RETURN
ENDIF
XX=XX+XADDS(K)
YY=YY+YADDS(K)
GOTO 100
300 K=K+1
IF (K.LE.8) GOTO 200
LEVEL=LEVEL-1
IF (LEVEL.EQ.0) THEN
SET=1
RETURN
ENDIF
XX=XSTACK(LEVEL)
YY=YSTACK(LEVEL)
K=CSTACK(LEVEL)
GOTO 300
END
SHAR_EOF
if test 1101 -ne "`wc -c < 'set.f'`"
then
echo shar: error transmitting "'set.f'" '(should have been 1101 characters)'
fi
fi # end of overwriting check
if test -f 'shipmv.f'
then
echo shar: will not over-write existing file "'shipmv.f'"
else
cat << \SHAR_EOF > 'shipmv.f'
ccc shipmv - this subroutine handles player's ship moves
subroutine shipmv ( acraloc, acrahit, num, own1, hitmax )
c
c synopsis
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
logical fatal
do 2600 y=1,limit(num)
loc=acraloc+y
if (movedflag(loc).ne.0) goto 2600
z6=rlmap(loc)
if (z6.eq.0) goto 2600
if ((mode.eq.1).and.(poschk(z6,own1).eq.0)) goto 2600
movedflag(loc)=1
do 2500 iturn=1,2
loc=acraloc+y
z6=rlmap(loc)
if (z6.eq.0) goto 2600
jit=acrahit+y
h1=j1ts(jit)
if ((iturn.eq.2).and.(h1.le.hitmax/2)) goto 2600
z7=z6
ab=rmap(z6)
c
c Check to see if ship was destroyed becuase the city
c it was in was captured
c
if ((ab.eq.own1).or.(ab.eq.'O')) goto 100
call head ( own1, y, loc, z6, h1 )
call topmsg ( 2, 'was destroyed' )
call cflush
call delay(30)
goto 1500
100 if ((iturn.eq.1).and.(ab.eq.'O')) h1=h1+1
comment repair if in port
if (h1.gt.hitmax) h1=hitmax
call stasis(z6,loc)
200 mycod=mycode(loc)
comment get my function code
if (mycod.eq.0) goto 900
comment if zero, skip ahead
if ((mycod.ne.9997).or.((own1.ne.'T').and.(own1.ne.'C')))
1 goto 500
comment check transports and carriers
n = 0
comment for overloading
nt = 2
ia = 1
ib=limit(1)
if (own1.ne.'C') goto 300
nt=1
ia=501
ib=limit(2)+500
300 do 400 j=ia,ib
400 if (rlmap(j).eq.z6) n=n+1
if (n.lt.nt*h1) goto 500
mycode(loc)=0
goto 900
500 if ((mycod.lt.101).or.(mycod.gt.6108)) goto 1100
if (mycod.le.6000) goto 600
if (mycod.gt.6100) goto 700
goto 1100
600 z6=z6+iarrow(mov(z6,mycod)+1)
comment destination move
goto 800
700 z6=z6+iarrow(mycod-6100+1)
comment directional move
800 ad=rmap(z6)
if (((ad.eq.'.').or.(ad.eq.'O')).and.(order(z6).eq.0)) goto 1100
z6=z7
900 call sector(pmap(1))
1000 call ltr(z6,iturn)
call mve ( own1, mdate, y, loc, jit, z6, z7, disas, z6-iadjst )
if (disas.eq.-2) goto 200
c
c Move evaluation. z6 = to, z7 = from, check out new location
c
1100 if (omap(z7).ne.'*') rmap(z7)=omap(z7)
comment remove unit from map
ac = rmap ( z6 )
ao = omap ( z6 )
if (z6.eq.mycode(loc)) mycode(loc)=0
comment arrived at destination
if ( ac .ne. 'O' ) goto 1200
comment is it our city?
call topmsg ( 3, 'Ship is docked' )
comment ship is in city
call cflush
call delay(30)
goto 1800
1200 if ( ao .eq. '.' ) goto 1600
comment if sea, skip ahead
1300 if (.not. fatal(4)) goto 2700
if ((ac.ne.'+').and.(ao.ne.'*')) goto 2400
comment check for enemy to fight
1400 continue
ptr = 0
call addidt ( own1, jnkbuf, ptr )
call addstr( ' broke up on the shore', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 2, jnkbuf )
call cflush
call delay(30)
goto 1500
1600 if (ac.ne.'.') goto 2400
rmap(z6)=own1
comment normal move
1800 rlmap(loc)=z6
j1ts(jit)=h1
1900 if ((own1.ne.'T').and.(own1.ne.'C')) goto 2500
n=0
comment if we're carring something, bring it along
ia=0
comment set up for transport
ib=limit(1)
nt=2
if (own1.ne.'C') goto 2000
ia=500
comment set up for carrier
ib=limit(2)
nt=1
2000 do 2300 i=ia+1,ia+ib
comment find pieces and move them
if (rlmap(i).ne.z7) goto 2300
if (n+1.gt.nt*h1) goto 2050
rlmap(i)=z6
n=n+1
goto 2300
2050 if (rmap(z7).eq.'O') goto 2300
rlmap(i)=0
c
c Tell about peices lost when ship went down
c
ptr = 0
if (own1.eq.'C') goto 2100
call addstr ( 'Army # ', jnkbuf, ptr )
goto 2200
2100 continue
call addstr ( 'Fighter # ', jnkbuf, ptr )
2200 continue
call addint ( i - ia, jnkbuf, ptr )
call addstr ( ' was sunk', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 2, jnkbuf )
call cflush
call delay(30)
2300 continue
goto 2500
2400 if ((ac.ge.'A').and.(ac.le.'T')) then
if (.not.fatal(2)) goto 2700
endif
h2=30
comment going to fight another unit
own2=ac
call find(own2,z6,z8,h2)
call fght(z6,h1,h2,own1,own2)
call find(own2,z6,z8,h2)
if (h1.le.0) goto 1500
rmap(z6)=own1
comment put us on the map
if ((own2.ge.'a').and.(own2.le.'t')) call sonar(z6)
if (ao.eq.'.') goto 1800
rmap(z6)=ao
comment won the battle, but...
if ((own2.ge.'a').and.(own2.le.'t')) call sonar(z6)
call topmsg ( 2, 'Your ship successfully clears the
* enemy from the beach before, CRUNCH!, grounding itself' )
call cflush
call delay(30)
1500 rlmap(loc)=0
comment kill my unit
mycode(loc)=0
call sensor(z6)
h1=0
goto 1900
2500 call sensor(z6)
2600 continue
return
c
c Recover from fatal moves
c
2700 z6=z7
comment restore old location
rmap(z6)=ab
comment restore map
goto 900
comment try again
end
SHAR_EOF
if test 4428 -ne "`wc -c < 'shipmv.f'`"
then
echo shar: error transmitting "'shipmv.f'" '(should have been 4428 characters)'
fi
fi # end of overwriting check
if test -f 'sonar.f'
then
echo shar: will not over-write existing file "'sonar.f'"
else
cat << \SHAR_EOF > 'sonar.f'
SUBROUTINE SONAR(Z6)
C
C UPDATES COMPUTER'S MAP AROUND LOCATION Z6
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
C
DO 1300 I=1,8
LOCUS=Z6+IARROW(I+1)
comment **
AB=RMAP(LOCUS)
IF (AB.NE.EMAP(LOCUS)) EMAP(LOCUS)=AB
IF ((AB.NE.'*').AND.(AB.NE.'O')) GOTO 400
DO 100 I1=1,70
100 IF (TARGET(I1).EQ.LOCUS) GOTO 1300
DO 200 I1=1,70
200 IF (TARGET(I1).EQ.0) GOTO 300
300 TARGET(I1)=LOCUS
400 IF ((AB.LT.'A').OR.(AB.GT.'T')) GOTO 1300
IF (AB.NE.'A'.AND.AB.NE.'O') GOTO 1100
C
C WE MUST NOW FIGURE OUT IF THE ARMY IS A THREAT TO ANY OF THE COMPUTER'S
C CITIES, I.E. IF IT IS ON THE CONTINENT WITH ANY OF THEM. IF SO, PUT
C THE ARMY IN THE LOCI ARRAY. THE FIRST INDEX IS THE CONTINENT, THE
C SECOND IS THE NTH ARMY DISCOVERED ON THAT CONTINENT - 1. THE (N,1)
C ARGUMENT IS THE DATE OF THE LAST ARMY DISCOVERED ON THE
C NTH CONTINENT. THUS WE HAVE A MEANS OF DETERMINING THE AGE OF THE DATA
C
ARMDEF=0
DO 480 Y=1,LIMIT(9)
IF (RLMAP(IAR2+Y).EQ.0) GOTO 480
IF (IDIST(LOCUS,RLMAP(IAR2+Y)).GT.14) GOTO 480
MOVE=PATH(RLMAP(IAR2+Y),LOCUS,1,OKA,FLAG)
IF (FLAG.NE.0) ARMDEF=ARMDEF+1
480 CONTINUE
IF (ARMDEF.GE.7) GOTO 520
DO 500 K=1,70
IF ((OWNER(K).NE.2).OR.(PHASE(K).EQ.1)) GOTO 500
IF (FOUND(K)-MDATE-5.LE.0) GOTO 500
IF (IDIST(X(K),LOCUS).GT.18) GOTO 500
MOVE=PATH(X(K),LOCUS,1,OKA,FLAG)
IF (FLAG.NE.0) PHASE(K)=-1
500 CONTINUE
C
520 IF (AB.EQ.'O') GOTO 1300
DO 600 K=1,10
IF (LOCI(K,2).EQ.0) GOTO 600
DO 550 J=2,11
IF (LOCI(K,J).EQ.LOCUS) GOTO 800
550 CONTINUE
MOVE=PATH(LOCUS,LOCI(K,2),1,OKA,FLAG)
J=11
IF (FLAG.NE.0) GOTO 800
600 CONTINUE
DO 700 K=1,10
700 IF (LOCI(K,2).EQ.0) GOTO 760
OLDEST=10000
DO 750 J=1,10
IF (LOCI(J,1).LT.OLDEST) THEN
OLDEST=LOCI(J,1)
K=J
ENDIF
750 CONTINUE
760 DO 770 J=2,11
770 LOCI(K,J)=0
GOTO 1000
800 DO 900 J=J,3,-1
900 LOCI(K,J)=LOCI(K,J-1)
comment SHIFT EVERYTHING UP THE ARRAY
1000 LOCI(K,1)=MDATE
LOCI(K,2)=LOCUS
GOTO 1300
C
1100 ISHIPT=0
IF (AB.EQ.'D') ISHIPT=1
IF (AB.EQ.'S') ISHIPT=2
IF (AB.EQ.'T') ISHIPT=3
IF (AB.EQ.'R') ISHIPT=4
IF (AB.EQ.'C') ISHIPT=5
IF (AB.EQ.'B') ISHIPT=6
IF (ISHIPT.EQ.0) GOTO 1300
DO 1200 IB=1,4
1200 TROOPT(ISHIPT,IB)=TROOPT(ISHIPT,IB+1)
TROOPT(ISHIPT,5)=LOCUS
1300 CONTINUE
EMAP(Z6)=RMAP(Z6)
IF (CODER.EQ.10) CALL SENSOR(Z6)
RETURN
END
SHAR_EOF
if test 2256 -ne "`wc -c < 'sonar.f'`"
then
echo shar: error transmitting "'sonar.f'" '(should have been 2256 characters)'
fi
fi # end of overwriting check
if test -f 'stasis.f'
then
echo shar: will not over-write existing file "'stasis.f'"
else
cat << \SHAR_EOF > 'stasis.f'
SUBROUTINE STASIS(Z6,LOC)
C
C CHECK IF ARMY #LOC, AT Z6, IS NEAR THE ENEMY, IF SO WAKE HIM UP
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
C
DO 200 I=1,8
AB=RMAP(Z6+IARROW(I+1))
comment **
IF ((AB.GE.'a').AND.(AB.LE.'t')) GOTO 100
IF (AB.EQ.'X') GOTO 100
IF (AB.NE.'*') GOTO 200
IF (RMAP(Z6).EQ.'F') GOTO 200
100 MYCODE(LOC)=0
GOTO 300
200 CONTINUE
300 RETURN
END
SHAR_EOF
if test 376 -ne "`wc -c < 'stasis.f'`"
then
echo shar: error transmitting "'stasis.f'" '(should have been 376 characters)'
fi
fi # end of overwriting check
if test -f 'strlen.f'
then
echo shar: will not over-write existing file "'strlen.f'"
else
cat << \SHAR_EOF > 'strlen.f'
ccc strlen - return size of zero character terminated string
integer function strlen(string)
character string(80)
c
c synopsis
c
c status = strlen(string)
c
c status - size of string
c string - character array terminated with a zero character
c
integer i
i = 0
1000 i = i + 1
if (string(i) .ne. '\0') goto 1000
strlen = i - 1
return
end
SHAR_EOF
if test 349 -ne "`wc -c < 'strlen.f'`"
then
echo shar: error transmitting "'strlen.f'" '(should have been 349 characters)'
fi
fi # end of overwriting check
if test -f 'strout.c'
then
echo shar: will not over-write existing file "'strout.c'"
else
cat << \SHAR_EOF > 'strout.c'
#include <curses.h>
/*
* strout - output a zero character terminated string
*/
strout_(str)
char *str;
{
addstr(str);
}
SHAR_EOF
if test 125 -ne "`wc -c < 'strout.c'`"
then
echo shar: error transmitting "'strout.c'" '(should have been 125 characters)'
fi
fi # end of overwriting check
if test -f 'strpos.f'
then
echo shar: will not over-write existing file "'strpos.f'"
else
cat << \SHAR_EOF > 'strpos.f'
ccc strpos - position cursor and output string
subroutine strpos(irow, icol, string)
integer irow, icol
character string(80)
c
c synopsis
c
c call strpos(irow, icol, string)
c
c irow - line to position cursor
c icol - column to position cursor
c string - a character array with a zero character terminator
c
integer strlen
call tpos(irow, icol)
call bufout(string, strlen(string))
return
end
SHAR_EOF
if test 404 -ne "`wc -c < 'strpos.f'`"
then
echo shar: error transmitting "'strpos.f'" '(should have been 404 characters)'
fi
fi # end of overwriting check
if test -f 'test4.f'
then
echo shar: will not over-write existing file "'test4.f'"
else
cat << \SHAR_EOF > 'test4.f'
subroutine test4(z6,flag,dir,move1,movnum,beg,end,ag2,flag2)
c
c Test subroutine for path, displays current path progress
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
INTEGER AG2(100)
character getchx
C
CALL CURSOR(Z6-IADJST)
IF (FLAG.NE.1001) E=GETCHX()
comment WAIT FOR CHAR IF TRACE MODE
IX='G'
comment DISPLAY CURRENT MOVE ON MAP
IF (FLAG2.EQ.1) PRINT 999,IX
IX='H'
IF (FLAG2.EQ.2) PRINT 999,IX
IF (FLAG.EQ.1001) RETURN
C PROCESS THIS CHAR
IF (E.EQ.' ') RETURN
comment SPACE, CONTINUE
IF (E.EQ.'G') GOTO 100
comment G, DISPLAY G2 ARRAY
CALL tpos(1,1)
comment IF NOT SPACE OR "G", SHOW PATH VARIABLES
PRINT 998,Z6,MOVE1,MOVNUM
999 FORMAT('+',A1$)
998 FORMAT(' Z6:',I4,' MOVE1:',I1,' MOVNUM:',I3)
CALL tpos(2,1)
PRINT 997,BEG,END,IADJST,DIR,FLAG
997 FORMAT(' BEG:'I4' END:'I4' IADJST:'I4' TDIR:'I2' FLAG:'I4)
IF (FLAG2 .EQ. 1) PRINT 996
996 FORMAT(' FLAG2: MOVE ')
IF (FLAG2 .EQ. 2) PRINT 995
995 FORMAT(' FLAG2: SHORE')
RETURN
100 CALL tpos(1,1)
PRINT 994,AG2
994 FORMAT(1X,16I5)
RETURN
END
SHAR_EOF
if test 1032 -ne "`wc -c < 'test4.f'`"
then
echo shar: error transmitting "'test4.f'" '(should have been 1032 characters)'
fi
fi # end of overwriting check
if test -f 'tran.f'
then
echo shar: will not over-write existing file "'tran.f'"
else
cat << \SHAR_EOF > 'tran.f'
ccc tran - translate old enemy units to new characters
subroutine tran ( ab )
character ab
c
c synopsis
c
c call tran ( ab )
c
c ab - character to translate
c
character olde ( 8 ), newe ( 8 )
data olde / '1', '2', '3', '4', '5', '6', '7', '8' /
data newe / 'a', 'f', 'd', 's', 't', 'r', 'c', 'b' /
do 10 i = 1, 8
10 if ( ab .eq. olde ( i )) ab = newe ( i )
return
end
SHAR_EOF
if test 379 -ne "`wc -c < 'tran.f'`"
then
echo shar: error transmitting "'tran.f'" '(should have been 379 characters)'
fi
fi # end of overwriting check
if test -f 'troopm.f'
then
echo shar: will not over-write existing file "'troopm.f'"
else
cat << \SHAR_EOF > 'troopm.f'
subroutine troopm
c
c This subroutine handles enemy troop transport moves
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
integer tttc(-1:20,0:50)
monkey = 0
number ( 5 ) = 0
if ( coder .eq. 5 ) print 999
999 format(' Troop transport codes')
do 2300 y=1,limit(13)
z6=rlmap(itt2+y)
if (z6.eq.0) goto 2300
monkey=y
dir=mod(y,2)*2-1
comment set dir to 1 or -1 consistently
ab=rmap(z6)
h1=j1ts(itt2h+y)
if (ab.eq.'X') h1=h1+1
if (h1.gt.3) h1=3
c
c Now compute the number of armies aboard the troop transport
c
numarm=0
do 100 i=1,limit(9)
100 if (z6.eq.rlmap(iar2+i)) numarm=numarm+1
if (numarm.gt.6) numarm=6
comment max # armies = 6
orig=z6
do 2200 iturn=1,2
p=0
z7=z6
ab=rmap(z6)
if ((iturn.eq.2).and.(h1.le.1)) goto 2300
c
c Move selection
c
ifo=codefu(y+itt2-1500)
ila=codela(y+itt2-1500)
c
c 300 is the statement number where the ifo and ila are
c processed to come up with a move, which is then fed thru movcor
c to come up with a final move.
c
c take care of damaged ships or just repaired ships.
c (damaged ships will have an ifo of 8)
c
if (h1.lt.3) goto 200
if (ifo.eq.8) ifo=0
goto 300
200 ifo=8
if (ila.eq.0) goto 250
if (rmap(ila).eq.'X') goto 1300
250 ila=iport(z6)
goto 1300
c
c ifo=10 move toward unexplored territory, location specified by ila
c ifo=7 move in a constant direction specified by ila
c ifo=9 move toward an unowned city specified by ila
c ifo=0-6 ila specifies location of where to move, either
c an army producing city or an army looking for a 't'.
c it could also be a direction. ifo is the number of armies on
c board the troop transport.
c
300 if (ifo.lt.7) ifo=numarm
if (numarm.eq.0) ifo=0
if ((ifo.eq.10).and.(emap(ila).ne.' ')) goto 1000
if (ifo.eq.10) goto 1300
if (ifo.eq.7) goto 1350
if (ifo.ne.9) goto 500
c
c ifo=9
c
do 400 i=1,70
if (target(i).ne.ila) goto 400
move=0
if ((iturn.eq.2).and.(idist(z6,ila).eq.1)) goto 1600
goto 1300
400 continue
if ((idist(z6,ila).lt.10).and.(edger(ila).lt.8).and.(irand(100).gt.10))
1 goto 1300
c
c It seems that it's target is no longer on the hit list,
c meaning it was captured.
c
500 if (ifo.le.2) goto 600
if (ifo.eq.3) then
if (irand(100).lt.96) goto 600
endif
if (ifo.eq.4) then
if (irand(100).lt.90) goto 600
endif
goto 800
comment select a target
c
c Select an army producing city and move towards it.
c pick the closest one.
c
600 if (ila.eq.0.or.ila.gt.500) goto 650
if ((codefu(ila).eq.3).and.(rlmap(iar2+ila).ne.0)) goto 1200
650 aflag=0
id=35
670 do 700 i=1,70
if ((x(i).eq.0).or.(owner(i).ne.2)) goto 700
if (edger(x(i)).eq.0) goto 700
if ((aflag.eq.0).and.(phase(i).ne.1)) goto 700
if (idist(z6,x(i)).ge.id) goto 700
do 680 j=1,limit(13)
if (j.eq.y) goto 680
if (codela(j+itt2-1500).ne.x(i)) goto 680
if (idist(rlmap(j+itt2),x(i)).le.2) goto 700
680 continue
id=idist(z6,x(i))
ila=x(i)
700 continue
if (id.ne.35) goto 1300
if (aflag.eq.1) goto 1000
aflag=1
goto 670
c
c Perform troop transport to target city assignment
c
800 if (number(10).eq.0) goto 1000
tm=0
do 820 i=1,limit(13)
if (rlmap(itt2+i).eq.0) goto 820
if (i.eq.y) goto 810
if (codefu(itt2-1500+i).eq.8) goto 820
if (codefu(itt2-1500+i).le.3) goto 820
810 tm=tm+1
if (codefu(itt2-1500+i).eq.9) codefu(itt2-1500+i)=0
tttc(tm,0)=i
820 continue
cm=0
do 840 i=1,number(10)
if (target(i).eq.0) goto 840
ila=target(i)
if (edger(ila).eq.0) goto 840
cm=cm+1
tttc(0,cm)=ila
tttc(-1,cm)=-1
if (rmap(ila).eq.'O') tttc(-1,cm)=1
840 continue
do 850 i=1,tm
do 850 j=1,cm
tttc(i,j)=idist(rlmap(itt2+tttc(i,0)),tttc(0,j))
850 continue
ac='*'
860 min=1000
do 880 i=1,tm
if (tttc(i,0).eq.0) goto 880
do 880 j=1,cm
if (emap(tttc(0,j)).ne.ac) goto 880
if (tttc(i,j).ge.min) goto 880
if (tttc(-1,j).eq.0) then
do 870 k=1,cm
if (tttc(-1,k).eq.-1) goto 880
870 continue
endif
move=path(rlmap(itt2+tttc(i,0)),tttc(0,j),1,okc,flag)
if (flag.eq.0) then
tttc(i,j)=1000
goto 880
endif
min=tttc(i,j)
ir=i
ic=j
880 continue
if (min.ne.1000) then
comment don't change function if dest is <3 from old?
codefu(itt2-1500+tttc(ir,0))=9
codela(itt2-1500+tttc(ir,0))=tttc(0,ic)
call dist(rlmap(itt2+tttc(ir,0)),tttc(0,ic))
tttc(ir,0)=0
tttc(ir,ic)=1001
tttc(-1,ic)=0
goto 860
endif
ifo=codefu(itt2-1500+y)
ila=codela(itt2-1500+y)
if (number(9)+number(10).le.38) then
if (ifo.eq.9) goto 1500
goto 1000
endif
if (ac.eq.'*') then
ac='o'
goto 860
endif
if (ifo.eq.9) goto 1500
c
c Move towards unknown territory
c
1000 ifo=10
ila=expl()
if (ila.eq.0) goto 1100
call dist(z6,ila)
goto 1300
c
c Move in specified direction (ila specifies which)
c
1100 ifo=7
ila=irand(8)+1
comment **
goto 1400
c
c Now pick a move according to ifo and ila
c
1200 move=0
if (idist(z6,rlmap(iar2+ila)).eq.1) goto 1600
move=mov(z6,rlmap(iar2+ila))
goto 1500
1300 move=path(z6,ila,dir,okc,flag)
if (flag.eq.0) goto 1100
goto 1500
1350 if (number(10).eq.0) goto 1400
if (irand(100).lt.40) goto 800
1400 move=ila
1500 aggr=-numarm
if ((number(5).gt.10).and.(numarm.eq.0)) aggr=aggr+2
explor=0
if (ifo.gt.6) explor=1
move=move*dir
dest=-1
if ((ifo.eq.9).or.(ifo.eq.10)) dest=ila
move=movcor(ifo,iturn,z6,move,h1,1,aggr,'t',explor,dir,dest,orig,3)
move=iabs(move)
if (ifo.eq.7) ila=move
1600 codefu(itt2-1500+y)=ifo
codela(itt2-1500+y)=ila
z6=z6+iarrow(move+1)
comment **
if (coder.eq.5) print 997, ifo,ila
997 format(1x,i)
c
if (omap(z7).ne.'*') rmap(z7)=omap(z7)
if (rmap(z6).eq.'.') goto 1700
if (rmap(z6).eq.'X') goto 1800
if ((rmap(z6).eq.'+').or.(omap(z6).eq.'*')) goto 1900
ab=rmap(z6)
if (coder.eq.5) print 996,ab
comment fix this conditional, kludged
996 format(' attacking ',a1)
if (ab.eq.'.') goto 1700
p=1
h2=30
own1='t'
own2=rmap(z6)
call find(own2,z6,z8,h2)
call fght(z6,h1,h2,own1,own2)
call find(own2,z6,z8,h2)
if (h1.le.0) goto 1900
if (omap(z6).eq.'+') goto 1900
j1ts(itt2h+y)=h1
1700 rmap(z6)='t'
1800 rlmap(itt2+y)=z6
j1ts(itt2h+y)=h1
if (iturn.eq.1) number(5)=number(5)+1
goto 2000
1900 rlmap(itt2+y)=0
j1ts(itt2h+y)=0
2000 n=0
if (p.eq.1) call sensor(z6)
do 2100 u=iar2+1,iar2+limit(9)
if (rlmap(u).ne.z7) goto 2100
if (n+1.gt.h1*2) then
if (rmap(z7).ne.'X') rlmap(u)=0
goto 2100
endif
n=n+1
rlmap(u)=z6
2100 continue
if (numarm.gt.2*h1) numarm=2*h1
call sonar(z6)
2200 continue
2300 continue
limit(13)=monkey
return
end
SHAR_EOF
if test 6379 -ne "`wc -c < 'troopm.f'`"
then
echo shar: error transmitting "'troopm.f'" '(should have been 6379 characters)'
fi
fi # end of overwriting check
if test -f 'ver.c'
then
echo shar: will not over-write existing file "'ver.c'"
else
cat << \SHAR_EOF > 'ver.c'
/*
* 01b 27May85 cal .Fixed round number update bug. Made truename simple.
* 01a 01Sep83 cal .Taken from a Decus tape
*/
ver_()
{
strout_("EMPIRE, Version 4.1x 27-May-1985");
}
SHAR_EOF
if test 188 -ne "`wc -c < 'ver.c'`"
then
echo shar: error transmitting "'ver.c'" '(should have been 188 characters)'
fi
fi # end of overwriting check
if test -f 'write.f'
then
echo shar: will not over-write existing file "'write.f'"
else
cat << \SHAR_EOF > 'write.f'
subroutine write ( beg, lim, num )
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
do 100 j = beg + 1, beg + lim
k = rlmap ( j )
write ( 1 ) k
if ( num .lt. 9 ) write ( 1 ) mycode(j)
if ( num .gt. 8 ) write ( 1 ) codefu(j-1500),codela(j-1500)
if ( num .eq. 9 ) write ( 1 ) ar2s(j-1500)
if ( num .eq. 2 ) write ( 1 ) range(j-500)
if ( num .eq. 10 ) write ( 1 ) rang(j-2000)
100 continue
return
end
SHAR_EOF
if test 408 -ne "`wc -c < 'write.f'`"
then
echo shar: error transmitting "'write.f'" '(should have been 408 characters)'
fi
fi # end of overwriting check
cd ..
# End of shell archive
exit 0