Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!seismo!lll-crg!ames!ucbcad!ic.Berkeley.EDU!edjames
From: edjames@ic.Berkeley.EDU (Ed James)
Newsgroups: net.sources.games
Subject: VMS Empire Part 2 of 3 (splice together)
Message-ID: <1175@ucbcad.BERKELEY.EDU>
Date: Thu, 18-Dec-86 16:00:43 EST
Article-I.D.: ucbcad.1175
Posted: Thu Dec 18 16:00:43 1986
Date-Received: Fri, 19-Dec-86 01:44:37 EST
Sender: news@ucbcad.BERKELEY.EDU
Reply-To: edjames@ic.berkeley.edu (Ed James)
Organization: University of California, Berkeley
Lines: 3000
};
char oka_[5] = {
'+',' ','*','X','O'
};
char okb_[5] = {
'+',' ','O','t','*'
};
char okc_[5] = {
'.',' ','O','*','X'
};
int ph_[8] = {
1,2,4,5,6,10,12,15
};
char phaze_[8] = {
'A','F','D','S','T','R','C','B'
};
int phazee_[8] = {
1,2,4,5,6,10,12,15
};
int step_ = 37, posit_ = 65, start_ = 102;
int tipe_[15] = {
1,2,0,3,4,5,0,0,0,6,0,7,0,0,8
};
int lines_, cols_;
int x_[70];
int g2_[100];
int nshprf_[4][6];
int prior_[7];
int range_[200], ar2s_[500];
int armtot_[20], codefu_[1500], codela_[1500], target_[70],
limit_[16];
int d2_[3];
int mycode_[1500];
int rang_[200];
int ptr_;
int rlmap_[3000];
int cities[128];
int movedflag_[1500];
int j1ts_[1600];
int d_[667];
int owner_[70];
int found_[70];
int phase_[70];
int fipath_[70];
int loci_[11][10];
int number_[18];
int troopt_[5][6];
char submap_[39][39];
char ab_, ac_, ad_, ao_, e_, own1_, own2_, own_;
char ab9_[9];
char ifile_[11], kill_;
char tty_[20];
char emap_[6000], rmap_[6000], pmap_[6000], omap_[6000];
char pamela_[8], reeed_[9];
char jnkbuf_[80];
LOGICAL specal_, pass_, automv_;
SHAR_EOF
if test 2417 -ne "`wc -c < 'data.c'`"
then
echo shar: error transmitting "'data.c'" '(should have been 2417 characters)'
fi
fi # end of overwriting check
if test -f 'decode.f'
then
echo shar: will not over-write existing file "'decode.f'"
else
cat << \SHAR_EOF > 'decode.f'
character FUNCTION DECODE(Z6)
C
C UNPACK MAP DEFINITION FILE
C D() = MAP DEFINITION FROM MAP FILE
C Z6 = LOCATION
C DECODE = CHARACTER AT Z6
C
C MAPS ARE ENCODED USING MOD 3 ARITHMETIC TO FIT 9 CHARACTERS INTO ONE 16-BIT
C WORD.
C
IMPLICIT INTEGER(A-Z)
INTEGER MSKTAB(9)
INTEGER*2 D(667)
character ASCII(3)
COMMON/MAP/D
DATA ASCII/'.','+','*'/
DATA MSKTAB/1,3,9,27,81,243,729,2187,6561/
C
IX=((Z6-1)/9)+1
IY=MOD(Z6-1,9)+1
DECODE=ASCII(MOD(D(IX)/MSKTAB(IY),3)+1)
RETURN
END
SHAR_EOF
if test 487 -ne "`wc -c < 'decode.f'`"
then
echo shar: error transmitting "'decode.f'" '(should have been 487 characters)'
fi
fi # end of overwriting check
if test -f 'delay.c'
then
echo shar: will not over-write existing file "'delay.c'"
else
cat << \SHAR_EOF > 'delay.c'
#include /* for NULL */
#include
delay_(ticks)
int *ticks;
{
struct timeval tv;
tv.tv_sec = *ticks / 60;
tv.tv_usec = (*ticks % 60) * 1000000 / 60;
select(0, NULL, NULL, NULL, &tv);
}
SHAR_EOF
if test 214 -ne "`wc -c < 'delay.c'`"
then
echo shar: error transmitting "'delay.c'" '(should have been 214 characters)'
fi
fi # end of overwriting check
if test -f 'direc.c'
then
echo shar: will not over-write existing file "'direc.c'"
else
cat << \SHAR_EOF > 'direc.c'
direc_()
{
int two = 2;
topmsg_(&two, "H for Help!");
}
SHAR_EOF
if test 59 -ne "`wc -c < 'direc.c'`"
then
echo shar: error transmitting "'direc.c'" '(should have been 59 characters)'
fi
fi # end of overwriting check
if test -f 'dist.c'
then
echo shar: will not over-write existing file "'dist.c'"
else
cat << \SHAR_EOF > 'dist.c'
#include "c_common.h"
/*
* This subroutine sets ar2s so that the army won't get
* off the troop transport prematurely
*/
dist_(z6, ila)
int *z6, *ila;
{
int id, l;
id = 2 * idist_(z6, ila) + 1;
for (l = IAR2; l < limit_[9] + IAR2; l++)
if (rlmap_[l] == *z6)
ar2s_[l - IAR2] = id;
}
SHAR_EOF
if test 297 -ne "`wc -c < 'dist.c'`"
then
echo shar: error transmitting "'dist.c'" '(should have been 297 characters)'
fi
fi # end of overwriting check
if test -f 'edger.c'
then
echo shar: will not over-write existing file "'edger.c'"
else
cat << \SHAR_EOF > 'edger.c'
#include "c_common.h"
edger_(ip)
int *ip;
{
int i, seacount = 0;
for (i = 1; i <= 8; i++)
if (omap_[*ip + iarrow_[i + 1]] == '.')
seacount++;
return (seacount);
}
SHAR_EOF
if test 174 -ne "`wc -c < 'edger.c'`"
then
echo shar: error transmitting "'edger.c'" '(should have been 174 characters)'
fi
fi # end of overwriting check
if test -f 'edit.f'
then
echo shar: will not over-write existing file "'edit.f'"
else
cat << \SHAR_EOF > 'edit.f'
subroutine edit(z5)
c
c Edit mode command subroutine
c test routines for path
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
character ch
character whtflg
z6=z5
whtflg='\0'
movflg=0
oldj=jector
call sector(pmap(1))
100 line=kline(ki,jector)
iadjst=line+ki-300
if (z6.eq.0) z6=iadjst+1240
dir=1
200 call cursor(z6-iadjst)
e=char(getchx())
z7 = z6
do 300 i=1,8
300 if (e.eq.comm(i)) z6=z6+iarrow(i+1)
comment if cursor move, change location
c if ((scrchk(z6).eq.1).and.(order(z6).eq.0)) goto 400
if ((contained(jector,jector).eq.1).and.(order(z6).eq.0)) goto 400
z6=z7
comment if not on screen, get back
goto 4500
400 if (z6.eq.z7) goto 500
goto 200
500 do 600 i=10,30
j=i
600 if (e.eq.comm(i)) goto 700
goto 4500
c
c l, b, f, t, g, v, j, u,-1,-1 priv cmds
c
700 if (pass) goto (800,900,1000,1100,1200,1400,1500,1600,1700,1800) j-9
c
c o, p, r, i, m, k, n, s, ?, y, h normal cmds
c
goto (1300,1900,4300,2100,2500,2700,2900,3100,3200,4200,4400) j-19
goto 4500
800 isec=-1
comment n - display enemy sector
call sector(emap(1))
goto 200
900 beg=z6
comment b - set beg
ix='B'
print 999,ix
999 format('+',a1,$)
goto 200
1000 end=z6
comment f - set end
ix='E'
print 999,ix
goto 200
1100 flag=1000
comment t - single step & trace path
call path(beg,end,dir,okc,flag)
goto 200
1200 flag=1001
comment g - show path chosen
call path(beg,end,dir,okc,flag)
goto 200
1300 continue
comment o - return to caller
jector=oldj
comment restore sector number
line=kline(ki,jector)
iadjst=line+ki-300
call sector(pmap(1))
comment refresh our map
return
1400 dir=-dir
comment v - reverse direction
goto 200
1500 h2=30
comment j - display code values for
own2=rmap(z6)
comment enemy units
if (own2.lt.'a' .or. own2.gt.'9') goto 4500
call find(own2,z6,z8,h2)
ptr = 0
call addstr ( 'Code: ', jnkbuf, ptr )
call addint ( codefu ( z8 - 1500 ), jnkbuf, ptr )
call addstr ( ' ', jnkbuf, ptr )
call addint ( codela ( z8 - 1500 ), jnkbuf, ptr )
call bufpos ( 1, 50, jnkbuf, ptr )
call cflush
goto 200
1600 isec=-1
comment u - display reference sector
call sector(rmap(1))
goto 200
1700 continue
comment shouldn't happen
1800 continue
stop
c
c p: print out new sector
c
1900 isec=-1
call topmsg ( 3, 0 )
call topmsg ( 2, 0 )
call topmsg ( 1, 'New Sector: ')
call cflush
jector = iphase(getchx())
call addcnt ( 1, 1 )
if ( jector .lt. 0 .or. jector .gt. 9 ) goto 1900
call sector ( pmap ( 1 ))
isec = -1
z6 = 0
goto 100
c
c r: print out the round number
c
c2000 call TPOS(2,50)
c call SSTROUT ( ' Round #',12)
c call decprt(mdate)
c call eol
c goto 200
c
c i: directional stasis
c
2100 ab=rmap(z6)
if ((ab.lt.'A').or.(ab.gt.'T')) goto 4500
e=char(getchx())
do 2200 i=1,8
j=i
2200 if (comm(i).eq.e) goto 2300
goto 4500
2300 if (ab.ne.'O') goto 2400
fipath(citfnd(z6))=j+6100
goto 200
2400 h2=30
call find(ab,z6,movflg,h2)
mycode(movflg)=j+6100
goto 200
c
c m: say we want to move to a location
c
2500 ab=rmap(z6)
if ((ab.lt.'A').or.(ab.gt.'T')) goto 4500
if (ab.ne.'O') goto 2600
whtflg='C'
movflg=citfnd(z6)
goto 200
2600 h2=30
call find(ab,z6,movflg,h2)
whtflg='U'
goto 200
c
c k: wake up anything and everything
c
2700 ab=rmap(z6)
if ((ab.lt.'A').or.(ab.gt.'T')) goto 4500
if (ab.ne.'O') goto 2800
fipath(citfnd(z6))=0
comment if city, kill flight path
do 2750 i=501,1500
comment wake any fighters or ships
if (rlmap(i).eq.z6) mycode(i)=0
2750 continue
goto 200
2800 h2=30
comment not a city, find the unit
call find(ab,z6,movflg,h2)
mycode(movflg)=0
comment zero any function code
if (ab.ne.'T') goto 2817
comment if transport, wake armies aboard
do 2816 j=1,500
2816 if (rlmap(j).eq.z6) mycode(j)=0
goto 200
2817 if (ab.ne.'C') goto 200
comment if carrier, wake fighters aboard
do 2818 j=501,700
2818 if (rlmap(j).eq.z6) mycode(j)=0
goto 200
c
c n: go here
c
2900 if (whtflg.ne.'C') goto 3000
fipath(movflg)=z6
goto 200
3000 if (whtflg.ne.'U') goto 4500
mycode(movflg)=z6
goto 200
c
c s: goto sleep
c
3100 ab=rmap(z6)
if ((ab.lt.'A').or.(ab.gt.'T')) goto 4500
if (ab.eq.'O') goto 4500
h2=30
call find(ab,z6,movflg,h2)
mycode(movflg)=50
goto 200
c
c ?: request info
c
3200 ab = rmap ( z6 )
if (ab.eq.'O') goto 3800
if ((ab.eq.'X').and.(pass)) goto 3800
if ((ab.ge.'A').and.(ab.le.'T')) goto 3250
if ((ab.ge.'a').and.(ab.le.'t').and.(pass)) goto 3250
goto 4500
3250 h2=30
call find(ab,z6,movflg,h2)
if (movflg.le.1500) then
do 3300 i=1,8
3300 if (ab.eq. phaze(i)) relnum=movflg-craloc(phazee(i))
call topmsg ( 3, 0 )
call topmsg ( 2, 0 )
comment clear line
call head (ab, relnum, movflg, z6, h2 )
comment display standard header
else
call tpos ( 1, 1 )
print 989,movflg,codefu(movflg-1500),codela(movflg-1500),h2
989 format ( '+ unit=',i5,' function=',i5,' sub func=',i5,
1 ' hits=',i2,$)
endif
if ((ab.eq.'A').or.(ab.eq.'F').or.(ab.eq.'a').or.(ab.eq.'f')) goto 200
n=0
base=0
if (movflg.gt.1500) base=1500
if ((ab.ne.'T').and.(ab.ne.'t')) goto 3500
do 3400 i=1,500
comment count armies
3400 if (rlmap(i+base).eq.z6) n=n+1
if (n.eq.0) goto 3700
ptr = 0
call addint ( n, jnkbuf, ptr )
if ( n .eq. 1 ) call addstr ( ' army', jnkbuf, ptr )
if ( n .gt. 1 ) call addstr ( ' armies', jnkbuf, ptr )
call addstr ( ' aboard', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 3, jnkbuf )
call cflush
goto 200
3500 if ((ab.ne.'C').and.(ab.ne.'c')) goto 200
do 3600 i=1,200
comment count fighters
3600 if (rlmap(i+500+base).eq.z6) n=n+1
if (n.eq.0) goto 3700
cc if (mode.eq.1) call TPOS(3,1)
ptr = 0
call addint ( n, jnkbuf, ptr )
call addstr ( ' fighter', jnkbuf, ptr )
if ( n .gt. 1 ) call addstr ( 's', jnkbuf, ptr )
call addstr ( ' aboard', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 3, jnkbuf )
call cflush
goto 200
3700 continue
comment nothing there
cc if (mode.eq.1) call TPOS(3,1)
call topmsg ( 3, 'Nothing aboard' )
call cflush
goto 200
c
c Display info on city
c
3800 continue
call topmsg ( 2, 0 )
comment clear line
j=citfnd(z6)
comment find city
base=0
if (owner(j).eq.2) base=1500
n=0
do 3900 i=base+501,base+700
comment count fighters
3900 if (rlmap(i).eq.z6) n=n+1
cc call tpos(2,1)
ptr = 0
call addint ( n, jnkbuf, ptr )
call addstr ( ' fighter', jnkbuf, ptr )
if ( n .ne. 1 ) call addstr ( 's', jnkbuf, ptr )
call addstr ( ' landed, ', jnkbuf, ptr )
n=0
do 4000 i=base+701,base+1500
comment count ships
4000 if (rlmap(i).eq.z6) n=n+1
call addint ( n, jnkbuf, ptr )
call addstr ( ' ship', jnkbuf, ptr )
if ( n .ne. 1 ) call addstr ( 's', jnkbuf, ptr )
call addstr ( ' docked', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 3, jnkbuf )
4150 continue
comment explain production
ptr = 0
call addstr ( 'City at location ', jnkbuf, ptr )
call addint ( z6, jnkbuf, ptr )
call addstr ( ', will complete a', jnkbuf, ptr )
do 4100 i=1,8
if (phase(j) .eq. phazee(i)) ch = phaze ( i )
4100 continue
if (( ch .eq. 'A') .or. ( ch .eq. 'a' ))
* call addstr ( 'n', jnkbuf, ptr )
call addstr ( ' ', jnkbuf, ptr )
call addpei ( ch, jnkbuf, ptr )
call addstr ( ' on ', jnkbuf, ptr )
call addint ( found ( j ), jnkbuf, ptr )
call addstr ( ', fpath: ', jnkbuf, ptr )
if (fipath(j).lt.100) call addstr ( 'sit', jnkbuf, ptr )
if ((fipath(j).gt.100).and.(fipath(j).lt.6000))
* call addint ( fipath ( j ), jnkbuf, ptr )
if ( fipath ( j ) .le. 6100 ) goto 4126
ptr = ptr + 1
jnkbuf ( ptr ) = comm ( fipath ( j ) - 6100 )
4126 continue
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 1, jnkbuf )
call cflush
goto 200
c
c y: enter new city production
c
4200 ab = rmap ( z6 )
if ( ab .ne. 'O' ) goto 4500
j = citfnd ( z6 )
call topmsg ( 3, 0 )
call topmsg ( 2, 0 )
call topmsg ( 1, 'New Production: ' )
call cflush
call phasin ( j, e )
call addcnt ( 1, 1 )
call putc ( e )
call cflush
goto 4150
c
c r: set army to move at random
c
4300 ab = rmap ( z6 )
if ( ab .ne. 'A' ) goto 4500
h2 = 30
call find ( ab, z6, movflg, h2 )
mycode ( movflg ) = 100
goto 200
c
c h: get help
c
4400 call help
e = char(getchx())
isec = -1
call sector(pmap(1))
isec = -1
goto 100
c
c Default mistake message
c
4500 call huh
goto 200
end
SHAR_EOF
if test 8149 -ne "`wc -c < 'edit.f'`"
then
echo shar: error transmitting "'edit.f'" '(should have been 8149 characters)'
fi
fi # end of overwriting check
if test -f 'empend.c'
then
echo shar: will not over-write existing file "'empend.c'"
else
cat << \SHAR_EOF > 'empend.c'
empend_()
{
/* gamend_(); */
/* endst_(); */
close_disp();
exit(0);
}
SHAR_EOF
if test 74 -ne "`wc -c < 'empend.c'`"
then
echo shar: error transmitting "'empend.c'" '(should have been 74 characters)'
fi
fi # end of overwriting check
if test -f 'empire.f'
then
echo shar: will not over-write existing file "'empire.f'"
else
cat << \SHAR_EOF > 'empire.f'
program empire
c
c This program is a war game simulation for video terminals.
c The game was originally written outside of Digital, probably a university.
c This version of the game was made runnable on Digital Equipment VAX/VMS
c FORTRAN by conversion from the TOPS-10/20 sources available around fall 1979.
c After debugging it, numerous changes have been made.
c
c Now that you are the proud owner of the source and you are all gung ho
c to do things right, there are a few things you should be aware of.
c Unfortunately, there are many magic numbers controlling how many different
c kinds of units can exist and how many of each, so think well before you
c attempt to add another unit type. Also, "slight changes" to the way the units
c work will typically have a fairly devastating affect on the computers
c strategy. If you are interested in really hacking this, there is a plenty
c of room for enhanced computer strategy. As you'll see, there are some
c very good debugging tools tucked inside, and you will soon discover weak
c points and bugs, that up until you, have remained problems (all the previous
c programmers got lazy or lost interest). Finally, please be careful with
c the version number and identification at start up to avoid confusion of
c ongoing versions with private copies. If you make a change don't remove
c the major version id, but rather add something like (V4.0 site.1 20-JUL-80).
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
character orders
character odor ( 2 )
equivalence ( odor ( 1 ), orders )
integer i, count, status
call ttinit
CC call initst
CC call gaminit ( 'empire' )
call rndini
win = 0
ncycle = 1
pass = .false.
automv = .false.
call clear
call topini
call tpos ( 7, 1 )
call ver
comment Special message
cc call strpos ( 8, 1, 'Detailed directions are in EMPIRE.DOC' )
cc call cr
call cflush
c
c -1/0/1 = restore/start/save game
c
call game ( -1, num )
comment Try to restore a previous game
c
c Command loop starts here
c
100 continue
call round ( mdate )
if ( automv ) goto 4200
comment Don't ask if in auto move
call bell
comment Wake up sleepy commanders
call topmsg ( 1, 'Your orders? ' )
call cflush
call getstr ( jnkbuf, 80, count )
call addcnt ( 1, count )
if ( count .gt. 2 ) goto 100
orders = ' '
call tupper ( jnkbuf, count )
odor ( 1 ) = jnkbuf ( 1 )
if ( odor ( 1 ) .eq. '\26' ) goto 1900
comment Quit command?
if ( count .eq. 2 ) odor ( 2 ) = jnkbuf ( 2 )
c
c Special hack for je command
c
if ((specal) .and. (orders .eq. 'JE')) goto 3900
c
c Lookup command
c
do 200 i = 1,20
200 if ( orders .eq. char(comscn ( i ))) goto 300
if ( pass ) goto 2200
call bell
goto 100
c
c m, n, o, s, t, v, p, y, c, l, h, j, 1, r, @, q , +, a
c
300 goto ( 400, 500, 600, 700, 800, 900, 1000, 1100, 1200, 1300,
* 1400, 1500, 1600, 1700, 1800, 1900, 2000, 2100 ) i
goto 100
400 goto 4200
comment m - move mode
500 continue
comment n - free enemy moves
call topmsg ( 2, 'Number of free enemy moves: ' )
call addcnt ( 2, 5 )
call cflush
call readi(ncycle)
goto 5300
600 goto 4200
comment o - move mode (synomn for m)
700 call clear
comment s - clear the screen
call topini
isec = -1
goto 100
800 call block ( pmap ( 1 ))
comment t - print out map
goto 100
900 call game ( +1, 0 )
comment v - save game
call topmsg ( 3, 'Game Saved.' )
goto 100
1000 call sector ( pmap ( 1 ))
comment p - print out a sector
goto 100
1100 call direc
comment y - error msg
goto 100
1200 goto 5200
comment c - give one free enemy move
1300 call direc
comment l - error msg
goto 100
1400 call help
comment h - help
isec = -1
goto 100
1500 mode = 1
comment j - edit mode
z6 = 0
call edit ( z6 )
goto 100
1600 mode = 0
comment 1 - set mode=0
jector = -1
goto 100
1700 continue
comment r - display round number
ptr = 0
call addstr ( 'Round # ', jnkbuf, ptr )
call addint ( mdate, jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 2, jnkbuf )
call cflush
goto 100
1800 continue
comment @ - restore game
jector = -1
call clear
call topini
call game ( -1, num )
if ( num .ne. 0 ) goto 5200
comment **
goto 100
1900 continue
comment q - quit
call topmsg ( 3, 0 )
comment clear line
call topmsg ( 2, 'QUIT - Are you sure? ' )
call cflush
e = char(getchx())
call putc ( e )
call cflush
call addcnt ( 2, 1 )
if ( e .ne. 'y' .and. e .ne. 'Y' ) goto 100
call clear
call topini
call cflush
call empend
2000 e = char(getchx())
comment + - turn on pass
if ( e .eq. '+' ) pass = .true.
if ( e .eq. '-' ) pass = .false.
comment or off
goto 100
2100 automv = .true.
c call topmsg(2, 'Now in Auto-Mode')
comment a - turn on auto move mode
goto 4200
2200 do 2300 i=21,40
comment debugging commands
2300 if (orders.eq.char(comscn(i))) goto 2400
goto 100
c
c lo,nu,li,tr,ar,ta,pa,a1,t3,a0,co,ch,q0, q1,je,cy,ex
c
2400 goto (2500,2600,2700,2800,2900,3000,3100,3200,3300,
1 3400,3500,3600,3700,3800,3900,4000,4100) i-20
goto 100
2500 print 986, ((loci(i,j),j=1,11),i=1,10)
comment lo -
goto 100
2600 print 989, number
comment nu -
goto 100
2700 print 991, limit
comment li -
goto 100
2800 print 990, troopt
comment tr -
goto 100
2900 print 989, armtot
comment ar -
goto 100
3000 print 989, target
comment ta -
goto 100
3100 print 988, succes,failur
comment pa -
goto 100
3200 call block(rmap(1))
comment a1 - print reference map
goto 100
3300 goto 100
comment t3 - ignored
3400 call block(emap(1))
comment a0 - print computer's map
goto 100
3500 call readi(i1)
comment co -
call readi(i2)
993 format(i)
print 987, (codefu(j),codela(j),j=i1,i1+i2)
goto 100
3600 call readi(coder)
comment ch - set coder variable
goto 100
3700 isec = -1
comment q0 - display enemy map sector
call topmsg ( 2, 'Sector? ' )
call cflush
call addcnt ( 2, 1 )
jector = iphase ( getchx())
call sector ( emap ( 1 ))
goto 100
3800 isec=-1
comment q1 - display reference map sector
call topmsg ( 2, 'Sector? ' )
call cflush
call addcnt ( 2, 1 )
jector = iphase ( getchx())
call sector(rmap(1))
goto 100
3900 isec=-1
call topmsg ( 2, 'Sector? ' )
call cflush
jector=iphase(getchx())
comment je - display enemy sector of choice
if (jector.lt.0.or.jector.gt.9) goto 3900
call sector(emap(1))
isec=-1
goto 100
4000 goto 100
comment cy - ignored
4100 ex=expl()
comment ex - disply explore function value
print 992,ex
goto 100
992 FORMAT('+EXP VALUE:',I5$)
991 FORMAT(1X,8I4)
990 FORMAT(1X,5I6)
989 FORMAT(1X,10I5)
988 FORMAT(' SUCCESS:',I6,' FAILURE:',I6)
987 FORMAT(1X,10I7)
986 FORMAT(11I5)
985 format(i)
c
c Begin movement
c
c User move
c
4200 if ( mode .eq. 0 ) goto 4400
if ( jector .ne. -1 ) goto 4300
call clear
call topini
jector = 0
isec = -1
4300 istart = isec
if ( isec .lt. 0 ) istart = 0
4400 do 4500 i = 1, 1500
4500 movedflag ( i ) = 0
do 4700 ject = istart, istart + 9
if ( mode .eq. 0 ) goto 4600
jector = ject
if ( ject .gt. 9 ) jector = ject - 10
line = kline ( ki, jector )
iadjst = line + ki - 300
4600 call shipmv ( itt, itth, 5, 'T', 3 )
call shipmv ( ica, icah, 7, 'C', 8 )
call shipmv ( iba, ibah, 8, 'B', 12 )
call shipmv ( icr, icrh, 6, 'R', 8 )
call shipmv ( isu, isuh, 4, 'S', 2 )
call shipmv ( ide, ideh, 3, 'D', 3 )
call armymv
call fighmv
if ( mode .eq. 0 ) goto 4800
4700 continue
4800 continue
c
c Hardware production
c
do 5100 y = 1, 70
if ( owner ( y ) .ne. 1 ) goto 5100
if ( phase ( y ) .eq. 14 ) goto 5100
call sensor ( x ( y ))
if ( phase(y).eq.8) goto 4900
if (( phase(y) .lt. 1 ) .or. ( phase(y) .gt. 15 )) goto 4900
if ( mod ( phase ( y ), 2 ) .eq. 0 ) goto 5000
if ( mod ( phase ( y ), 5 ) .eq. 0 ) goto 5000
if ( phase ( y ) .eq. 1 ) goto 5000
c
c City phase incorrect or we just took it
c
4900 continue
call clear
call topini
isec = -1
ptr = 0
call addstr ( 'Readout around city at ', jnkbuf, ptr )
call addint ( x ( y ), jnkbuf, ptr )
call bufpos ( 4, 1, jnkbuf, ptr )
call cr
call cr
i1 = mode
mode = 0
call ltr ( x ( y ), 0 )
mode = i1
call cr
call strout ( 'What are your production demands for this city? ' )
call cflush
call phasin ( y, e )
call putc ( e )
call cflush
call delay ( 45 )
call clear
call topini
call cflush
goto 5100
5000 if ( mdate .lt. found ( y )) goto 5100
found ( y ) = mdate + phase ( y ) * 5
c
c A city has built something; build up a line
c
ptr = 0
call addstr ( 'City # ', jnkbuf, ptr )
call addint ( y, jnkbuf, ptr )
call addstr ( ' at ', jnkbuf, ptr )
call addint ( x(y), jnkbuf, ptr )
call addstr ( ' has completed a', jnkbuf, ptr )
k = phase ( y )
c print 983, hits ( k ), x ( y ), tipe ( k ), crahit ( k ), craloc ( k ),
c 1 lopmax ( k ), k
c983 format(' hits:',i5,' x(y):',i5,' tipe(k):',i5,' crahit(k):',i5,/
c 1 ,' craloc(k):',i5,' lopmax(k):',i5,' k:',i)
call prod ( hits ( k ), x ( y ), limit ( tipe ( k )),
* crahit ( k ), craloc ( k ), lopmax ( k ), ar2s,
* tipe ( k ) + 1, range, jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 3, jnkbuf )
call cflush
call delay(30)
5100 continue
5200 continue
c
c Computer move
c
5300 continue
c d call pme_init
do 5500 i=1,ncycle
call armcnt
call troopm
call topmsg ( 1, 'My turn, thinking..' )
call cflush
call armyen
call topmsg ( 1, 0 )
comment Blank the thinking
call cflush
call carier
call enemym ( 'b', 12 ,iba2h, iba2, 8 )
call enemym ( 'r', 8 ,icr2h, icr2, 6 )
call enemym ( 's', 2 ,isu2h, isu2, 4 )
call enemym ( 'd', 3 ,ide2h, ide2, 3 )
call topmsg ( 1, 'My turn, thinking...' )
call cflush
call fightr
c
c Age known enemy army locations
c
do 5350 k = 1, 10
if ( loci ( k, 1 ) + 21 .gt. mdate ) goto 5350
comment If data is not old
do 5340 j = 1, 11
5340 loci ( k, j ) = 0
comment Zero that line
5350 continue
c
c Production of enemy hardware
c
call cityct
do 5400 y = 1, 70
if ((x(y) .eq. 0) .or. (owner(y) .ne. 2)) goto 5400
call sonar ( x ( y ))
if ((phase(y) .le. 0) .or. (mdate .lt. found(y))) goto 5380
k = phase ( y )
j = 0
if ( k .eq. 1 ) j = 1
ptr = 0
comment To fake out prod
call prod(hits(k),x(y),limit(tipe(k)+8),crahit(k)+ide2h,
* craloc(k)+1500,lopmax(k),ar2s,j,rang, jnkbuf, ptr )
5380 if ((phase(y).le.0).or.(mdate.ge.found(y))) call cityph(y)
5400 continue
mdate = mdate + 1
newrnd = 1
if (mod(mdate,4).eq.0.or.(mdate.gt.160)) call game (+1,0)
5500 continue
c d call pme_exit
ncycle = 1
c
if ( win .eq. 1 ) goto 100
if ( win .eq. 2 ) goto 5700
n = 0
do 5600 j = 1, 70
5600 if (owner(j) .eq. 1) n = n + 1
if (n.lt.30) goto 5700
if (number(9).gt.n/2) goto 5700
call topmsg ( 1, 'The computer acknowledges defeat. Do' )
call topmsg ( 2, 'you wish to smash the rest of the enemy? ')
call cflush
call addcnt ( 2, 1 )
if ( char(getchx()) .ne. 'Y' ) call empend
call cr
call strout ( 'The enemy inadvertantly revealed its code used for' )
call cr
call strout ( 'receiving battle information. You can display what' )
call cr
call strout ( 'they''ve learned through the command ''JE''(cr)(lf),' )
call cr
call strout ( 'followed by the sector number.' )
call cflush
specal = .true.
win = 2
automv = .false.
goto 100
5700 if ((number(9).gt.0).or.(limit(9).gt.0)) goto 5800
call clear
call topini
call strout ( 'The enemy is incapable of defeating you.' )
call cr
call strout ( 'You are free to rape the empire as you wish.' )
call cr
call strout ( 'There may be, however, remnants of the enemy fleet' )
call cr
call strout ( 'to be routed out and destroyed.' )
win = 1
automv = .false.
goto 100
5800 do 5900 i=1,70
5900 if (owner(i).eq.1) goto 100
do 6000 i=1,limit(1)
6000 if (rlmap(i).ne.0) goto 100
call clear
call topini
win = 1
call strout ( 'You have been rendered incapable of' )
call cr
call strout ( 'defeating the rampaging enemy fascists! The' )
call cr
call strout ( 'empire is lost. If you have any ships left, you may' )
call cr
call strout ( 'attempt to harass enemy shipping.' )
automv = .false.
goto 100
end
SHAR_EOF
if test 11913 -ne "`wc -c < 'empire.f'`"
then
echo shar: error transmitting "'empire.f'" '(should have been 11913 characters)'
fi
fi # end of overwriting check
if test -f 'enemym.f'
then
echo shar: will not over-write existing file "'enemym.f'"
else
cat << \SHAR_EOF > 'enemym.f'
SUBROUTINE ENEMYM(OWN1,HITMAX,ACRAHIT,ACRALOC,NUM)
C
C THIS SUBROUTINE HANDLES ENEMY SHIP MOVES OTHER THAN T'S AND C'S
C
IMPLICIT INTEGER(A-Z)
character p
include 'common.h'
C
C
C NSHPRF IS AN ARRAY WHICH IS REFERENCED TO DETERMINE
C WHETHER A CERTAIN SHIP (D=1,S=2,R=3,B=4) WANTS TO ATTACK
C ANOTHER CERTAIN TYPE OF SHIP. 1 MEANS YES, 0 MEANS NO.
C SECOND VARIABLE: 1=D,2=S,3=T,4=R,5=C,6=B
C
DATA NSHPRF/1,1,1,0,0,0,1,1,1,0,0,0,1,1,1,1,1,0,1,1,1,1,1,1/
C
CTHE FOLLOWING NUMBERS ARE IFO VARIABLES RELATING TO
C CERTAIN TYPES OF MOVEMENT (CODES)
C 7: RANDOM DIRECTION
C 3: CITY TARGET LOC.
C 4: TT NUMBER ESCORT
C 5: TARGET
C 8: DAMAGED
C 10: LOOK AT UNEXPLORED TERRITORY
C
IF (NUM.EQ.3) NUMSHP=1
IF (NUM.EQ.4) NUMSHP=2
IF (NUM.EQ.6) NUMSHP=3
IF (NUM.EQ.8) NUMSHP=4
C
NUMBER(NUM)=0
IF (CODER.EQ.NUM) PRINT 999,OWN1
999 FORMAT(1X,A1,' CODES')
MONKEY=0
C
DO 2400 Y=1,LIMIT(NUM+8)
Z6=RLMAP(Y+ACRALOC)
IF (Z6.EQ.0) GOTO 2400
DIR=MOD(Y,2)*2-1
H1=J1TS(Y+ACRAHIT)
AB=RMAP(Z6)
IF (AB.EQ.'X') H1=H1+1
IF (H1.GT.HITMAX) H1=HITMAX
C
ORIG=Z6
DO 2300 ITURN=1,2
P='N'
IF ((ITURN.EQ.2).AND.(H1.LE.HITMAX/2)) GOTO 2400
Z7=Z6
C
C MOVE SELECTION
C
IFO=CODEFU(Y+ACRALOC-1500)
ILA=CODELA(Y+ACRALOC-1500)
C
C DOES A NEW CODE NEED TO BE SELECTED? 800:YES, 1600:NO
C
IF ((IFO.EQ.8).AND.(H1.EQ.HITMAX)) IFO=0
IF (IFO.EQ.8) GOTO 1600
IF (H1.EQ.HITMAX) GOTO 100
IFO=8
ILA=IPORT(Z6)
GOTO 1600
100 GOTO (800,200,300,400,500,800,800,800,800,700) IFO
GOTO 800
C
200 GOTO 800
C
300 IF (RMAP(ILA).EQ.'X') GOTO 800
IF (IDIST(Z6,ILA).EQ.1) GOTO 800
GOTO 1600
C
400 IF (RLMAP(2600+ILA).EQ.0) GOTO 800
IF (CODEFU(1100+ILA).LT.7) GOTO 800
GOTO 1600
C
500 IF (ILA.NE.Z6) GOTO 1600
DO 600 I1=1,6
DO 600 I2=1,5
IF (TROOPT(I1,I2).NE.ILA) GOTO 600
TROOPT(I1,I2)=0
600 CONTINUE
GOTO 800
C
700 IF (EMAP(ILA).NE.' ') GOTO 800
GOTO 1600
C
C NEW CODE SELECTION
C 5:TARGET
C
800 ID=500
DO 900 N=1,6
IF (NSHPRF(NUMSHP,N).EQ.0) GOTO 900
DO 900 N2=1,5
IF (TROOPT(N,N2).EQ.0) GOTO 900
IF (IDIST(Z6,TROOPT(N,N2)).GE.ID) GOTO 900
ID=IDIST(Z6,TROOPT(N,N2))
ILA=TROOPT(N,N2)
IFO=5
900 CONTINUE
IF (ID.NE.500) GOTO 1600
IF (irand(100).GT.40) GOTO 1200
comment **
C
C 3:CITY TARGET LOC.
C
IA=irand(20)+1
comment **
IB=IA+70
DO 1100 IC=IA,IB
I=IC
IF (I.GT.70) I=IC-70
IF (TARGET(I).EQ.0) GOTO 1100
IF (RMAP(TARGET(I)).NE.'O') GOTO 1100
IF (EDGER(TARGET(I)).EQ.0) GOTO 1100
IFO=3
ILA=TARGET(I)
GOTO 1600
1100 CONTINUE
C
C 4:TT NUMBER ESCORT
C
1200 IA=irand(LIMIT(13))+1
comment **
IB=IA+LIMIT(13)
DO 1300 IC=IA,IB
I=IC
IF (I.GT.LIMIT(13)) I=IC-LIMIT(13)
IF (RLMAP(2600+I).EQ.0) GOTO 1300
IF (CODEFU(1100+I).LT.9) GOTO 1300
IFO=4
ILA=I
GOTO 1600
1300 CONTINUE
C
C 10: EXPLORE
C
1400 I1=EXPL()
IF (I1.EQ.0) GOTO 1500
ILA=I1
IFO=10
GOTO 1600
C
C 1: RANDOM DIRECTION
C
1500 IF (IFO.EQ.7) GOTO 1600
ILA=irand(8)+1
comment **
IFO=7
C
C MOVE CORRECTION
C
1600 IF (IFO.EQ.7) MOOV=ILA
FLAG=1
IF ((IFO.EQ.8).OR.(IFO.EQ.3).OR.(IFO.EQ.5))
1 MOOV=PATH(Z6,ILA,DIR,OKC,FLAG)
IF (IFO.EQ.4) MOOV=PATH(Z6,RLMAP(ITT2+ILA),DIR,OKC,FLAG)
IF (FLAG.EQ.0) GOTO 1400
IF (IFO.EQ.10) MOOV=PATH(Z6,ILA,DIR,OKC,FLAG)
IF (FLAG.EQ.0) GOTO 1500
IF (IFO.NE.2) GOTO 1700
MOOV=0
IF (IDIST(Z6,ILA).GT.4) MOOV=MOV(Z6,ILA)
IF (IDIST(Z6,ILA).LT.4) MOOV=ICORR(MOV(Z6,ILA)-4)
1700 AGGR=0
IS1=1
IF (OWN1.EQ.'s') IS1=2
MOOV=MOOV*DIR
MOOV=MOVCOR(IFO,ITURN,Z6,MOOV,H1,IS1,AGGR,OWN1,1,DIR,-1,ORIG,HITMAX)
IF (IFO.EQ.7) ILA=IABS(MOOV)
CODEFU(Y+ACRALOC-1500)=IFO
CODELA(Y+ACRALOC-1500)=ILA
MOOV=IABS(MOOV)
IF (CODER.EQ.NUM) PRINT 998,IFO,ILA
998 FORMAT(I)
C
C MOVE EVALUATION
C
Z6=Z6+IARROW(MOOV+1)
comment **
IF (OMAP(Z7).NE.'*') RMAP(Z7)=OMAP(Z7)
AD=RMAP(Z6)
IF (AD.EQ.'.') GOTO 1900
IF (AD.EQ.'X') GOTO 2000
IF ((AD.GE.'A').AND.(AD.LE.'T')) GOTO 1800
PRINT 997,OWN1,Z6,AD
997 FORMAT(' ENEMY ',A1,' AT ',I4,' RAN AGROUND ON ',A1)
GOTO 2100
1800 H2=30
P='S'
OWN2=AD
CALL FIND(OWN2,Z6,Z8,H2)
CALL FGHT(Z6,H1,H2,OWN1,OWN2)
CALL FIND(OWN2,Z6,Z8,H2)
IF (H1.LE.0) GOTO 2100
1900 RMAP(Z6)=OWN1
2000 RLMAP(Y+ACRALOC)=Z6
J1TS(Y+ACRAHIT)=H1
IF (ITURN.EQ.1) NUMBER(NUM)=NUMBER(NUM)+1
MONKEY=Y
GOTO 2200
2100 RLMAP(Y+ACRALOC)=0
CODEFU(Y+ACRALOC-1500)=0
CODELA(Y+ACRALOC-1500)=0
J1TS(Y+ACRAHIT)=0
2200 CALL SONAR(Z6)
IF (P.EQ.'S') CALL SENSOR(Z6)
2300 CONTINUE
2400 CONTINUE
LIMIT(NUM+8)=MONKEY
RETURN
END
SHAR_EOF
if test 4333 -ne "`wc -c < 'enemym.f'`"
then
echo shar: error transmitting "'enemym.f'" '(should have been 4333 characters)'
fi
fi # end of overwriting check
if test -f 'expl.f'
then
echo shar: will not over-write existing file "'expl.f'"
else
cat << \SHAR_EOF > 'expl.f'
FUNCTION EXPL
C
C THIS SUBROUTINE SEARCHES FOR UNKNOWN TERRITORY AND RETURNS A VALUE
C IN EXPL.
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
C
IF (FULL.EQ.2) GOTO 300
BEGPOS=START
GOTO 200
100 IF ((EMAP(POSIT).EQ.' ').AND.(ORDER(POSIT).EQ.0)) GOTO 400
200 POSIT=POSIT+STEP
IF (POSIT.LT.5900) GOTO 100
START=START+1
POSIT=START
IF (START.EQ.BEGPOS+37) GOTO 300
GOTO 100
300 EXPL=0
FULL=2
C CALL tpos(1,1)
C PRINT 999,POSIT,STEP,START,BEGPOS,KNOWN
C999 FORMAT('+POSIT,STEP,START,BEGPOS,KNOWN:',5I5$)
RETURN
400 EXPL=POSIT
RETURN
END
SHAR_EOF
if test 551 -ne "`wc -c < 'expl.f'`"
then
echo shar: error transmitting "'expl.f'" '(should have been 551 characters)'
fi
fi # end of overwriting check
if test -f 'fatal.f'
then
echo shar: will not over-write existing file "'fatal.f'"
else
cat << \SHAR_EOF > 'fatal.f'
logical function fatal ( dummy )
c
c Ask player if wants to reconsider
c
implicit integer(a-z)
logical fat
character ch
goto ( 100, 200, 300, 400, 500, 600 ) dummy
100 call topmsg ( 2, 'The troops cannot swim too well, Sir!
* Are you sure you want to GOTO sea? ' )
goto 700
200 call topmsg ( 2, 'SIR! Those are OUR men!
* Do you really want to attack them? ' )
goto 700
300 call topmsg ( 2, 'That''s NEVER worked before, Sir!
* Are sure you want to try? ' )
goto 700
400 call topmsg ( 2, 'Ships need SEA to float, Sir!
* Do you really want go on shore? ' )
goto 700
500 call topmsg ( 2, 'That''s OUR city, Sir!
* Do you really want to attack the garrison? ' )
goto 700
600 call topmsg ( 2, 'Sorry Sir, there is no room
* left on the transport. Do you insist? ' )
700 continue
call cflush
ch = char(getchx())
call topmsg ( 2, 0 )
comment clear the line
fat = .false.
if (( ch .eq. 'Y') .or. ( ch .eq. 'y' )) fat = .true.
fatal = fat
return
end
SHAR_EOF
if test 993 -ne "`wc -c < 'fatal.f'`"
then
echo shar: error transmitting "'fatal.f'" '(should have been 993 characters)'
fi
fi # end of overwriting check
if test -f 'fght.f'
then
echo shar: will not over-write existing file "'fght.f'"
else
cat << \SHAR_EOF > 'fght.f'
subroutine fght(z6,h1,h2,own1,own2)
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
if ((own2.lt.'A').or.(own2.gt.'T')) goto 100
cc if (mode.eq.1) call TPOS(2,1)
ptr = 0
call addidt ( own2, jnkbuf, ptr )
call addstr ( ' is under attack at ', jnkbuf, ptr )
call addint ( z6, jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 2, jnkbuf )
call cflush
100 continue
s1=1
s2=1
if ((own1.eq.'S').or.(own1.eq.'s')) s1=3
if ((own2.eq.'S').or.(own2.eq.'s')) s2=3
ptr = 0
if (h2.eq.0) goto 300
200 if (irand(100).le.50) goto 300
comment **
h1=h1-s2
h=h2
if (h1.gt.0) goto 200
own=own1
call addidt ( own, jnkbuf, ptr )
own=own2
call addstr ( ' destroyed, ', jnkbuf, ptr )
goto 400
300 h2=h2-s1
h=h1
if (h2.gt.0) goto 200
own=own2
call addidt ( own, jnkbuf, ptr )
own=own1
call addstr ( ' destroyed, ', jnkbuf, ptr )
400 continue
call addidt ( own, jnkbuf, ptr )
call addstr ( ' has ', jnkbuf, ptr )
call addint ( h, jnkbuf, ptr )
call addstr ( ' hit', jnkbuf, ptr )
if ( h .gt. 1 ) call addstr ( 's', jnkbuf, ptr )
call addstr ( ' left', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 3, jnkbuf )
call cflush
call delay(30)
return
end
SHAR_EOF
if test 1178 -ne "`wc -c < 'fght.f'`"
then
echo shar: error transmitting "'fght.f'" '(should have been 1178 characters)'
fi
fi # end of overwriting check
if test -f 'fighmv.f'
then
echo shar: will not over-write existing file "'fighmv.f'"
else
cat << \SHAR_EOF > 'fighmv.f'
subroutine fighmv
c
c This subroutine handles player's fighter moves
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
logical fatal
do 2100 y = 1, limit ( 2 )
loc = 500 + y
if (movedflag(loc).ne.0) goto 2100
z6=rlmap(loc)
if (z6.eq.0) goto 2100
if ((mode.eq.1).and.(poschk(z6,'F').eq.0)) goto 2100
movedflag(loc)=1
z3=min(range(y),4)
if (z3.eq.0) z3=4
do 1900 iturn=1,z3
loc=500+y
z6=rlmap(loc)
if (z6.eq.0) goto 2100
ab=rmap(z6)
c
c Now check to see if fighter is in a city, if it is change the
c stasis number of the fighter to that specified by fipath(i)
c
if ( ab .ne. 'O' ) goto 300
comment if fighter not in city
do 100 i = 1, 70
100 if ( x ( i ) .eq. z6 ) goto 200
comment find city at z6
200 mycode(loc)=fipath(i)
comment change statis of fighter
c
c Check for fighters destroyed along with carrier or city
c
300 if ((ab.eq.'C').or.(ab.eq.'F').or.(ab.eq.'O')) goto 400
ptr = 0
call addstr ( 'Fighter # ', jnkbuf, ptr )
call addint ( y, jnkbuf, ptr )
call addstr ( ' destroyed', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 3, jnkbuf )
call cflush
call delay(30)
goto 1700
400 z7 = z6
call stasis ( z6, loc )
500 if ( range ( y ) .ne. 0 ) goto 600
comment check for fuel
call head ( 'F', y, loc, z6, 1 )
call topmsg ( 3, 'Ran out of fuel and crashed' )
call cflush
call delay(30)
if (( ab .ne. 'C').and.(omap(z6).ne.'*')) rmap(z6)=omap(z6)
goto 1700
600 mycod=mycode(loc)
comment get my function code
if (mycod.eq.0) goto 1100
comment none, skip ahead
if ((mycod.lt.101).or.(mycod.gt.6108)) goto 1300
if (mycod.le.6000) goto 700
if (mycod.gt.6100) goto 800
goto 1300
700 z6=z6+iarrow(mov(z6,mycod)+1)
comment destination function
if ((range(y).eq.10).and.(idist(z6,mycod).le.10)) goto 902
goto 900
800 z6=z6+iarrow(mycod-6100+1)
comment directional functions
900 if (range(y).eq.10) goto 1000
902 if (order(z6).ne.0) goto 1000
ad=rmap(z6)
comment check new location
if ((ad.eq.'C').or.(ad.eq.'O')) goto 1300
if ((ad.eq.'+').or.(ad.eq.'.')) goto 1300
1000 z6=z7
1100 call sector(pmap(1))
call ltr(z6,iturn)
1200 call mve('F',mdate,y,loc,1,z6,z7,disas,z6-iadjst)
if (disas.eq.-2) goto 500
c
c Move evaluation
c
1300 ac=rmap(z6)
ao=omap(z6)
if (z6.eq.mycode(loc)) mycode(loc)=0
comment arrived at destination
if ((ac.ne.'O').and.(ac.ne.'C')) range(y)=range(y)-1
if (z7.eq.z6) goto 2000
comment didnt go anywhere, end move
if ((ab.ne.'C').and.(omap(z7).ne.'*')) rmap(z7)=omap(z7)
comment change prev loc
if (ao.eq.'*') goto 1400
comment check on cities
if (ac.eq.'C') goto 1500
comment landing on a carrier
if ((ac .ne. '.') .and. (ac .ne. '+')) goto 1800
comment attack any other units
rmap ( z6 ) = 'F'
comment normal move
rlmap ( loc ) = z6
goto 1900
1400 if (ac.ne.'O') goto 1600
comment is it my city?
1500 continue
comment landed in a city or carrier
if (mycode(loc) .ne. 0) goto 1313
call topmsg ( 3, 'Landing confirmed' )
call cflush
call delay(30)
1313 continue
mycode ( loc ) = 0
comment zero my function
rlmap(loc)=z6
range(y)=20
goto 2000
1600 if (.not.fatal(3)) goto 2200
comment ask about flying over enemy city
call topmsg ( 3, 'Fighter shot down' )
call cflush
call delay(30)
1700 rlmap ( loc ) = 0
goto 2000
c
c Attacking a unit
c
1800 if ((ac .lt. 'A') .or. (ac .gt. 'T')) goto 1314
if (.not.fatal(2)) goto 2200
1314 continue
h1=1
own1='F'
own2=ac
h2=30
call find(own2,z6,z8,h2)
call fght(z6,h1,h2,own1,own2)
call find(own2,z6,z8,h2)
if (h1.le.0) goto 1700
rmap(z6)='F'
rlmap(loc)=z6
if ((own2.ge.'a').and.(own2.le.'t')) call sonar(z6)
1900 call sensor(z6)
comment bottom of per turn loop
2000 call sensor(z6)
comment bottom of per unit loop
2100 continue
return
c
c Recover from fatal move
c
2200 z6 = z7
comment go back to old location
rmap(z6) = ab
comment restore map to previous
range(y) = range(y)+1
comment get your fuel back
goto 1200
end
SHAR_EOF
if test 3878 -ne "`wc -c < 'fighmv.f'`"
then
echo shar: error transmitting "'fighmv.f'" '(should have been 3878 characters)'
fi
fi # end of overwriting check
if test -f 'fightr.f'
then
echo shar: will not over-write existing file "'fightr.f'"
else
cat << \SHAR_EOF > 'fightr.f'
SUBROUTINE FIGHTR
C
C THIS SUBROUTINE HANDLES ENEMY FIGHTER MOVES
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
C
C IFO=7: CITY LOCATION
C IFO=6: CARRIER NUMBER
C IFO=5: TARGET LOCATION
C IFO=4: TARGET LOCATION, KAMIKAZE MISSION
C IFO=3: DIRECTIONAL
C IFO=2: DIRECTIONAL, KAMIKAZE MISSION
C
MONKEY=0
NUMBER(2)=0
IF (CODER.EQ.2) PRINT 999
999 FORMAT(' FIGHTER CODES')
DO 3600 Y=1,LIMIT(10)
DO 3500 I1=1,4
Z6=RLMAP(2000+Y)
IF (Z6.EQ.0) GOTO 3600
C DIR=MOD(Y,2)*2-1
comment UNUSED
MONKEY=Y
STOPF=1
P=0
Z7=Z6
AB=RMAP(Z6)
DO 100 IA=1,6
DO 100 IB=1,5
100 IF (TROOPT(IA,IB).EQ.Z6) TROOPT(IA,IB)=0
IF ((AB.NE.'f').AND.(AB.NE.'X').AND.(AB.NE.'c')) GOTO 3400
IF ((AB.EQ.'X').OR.(AB.EQ.'c')) RANG(Y)=20
IF (RANG(Y).NE.0) GOTO 200
RMAP(Z6)=OMAP(Z6)
GOTO 3400
C
C MOVE SELECTION
C
200 IF (CODELA(Y+IFI2-1500).EQ.Z6) GOTO 1100
IFO=CODEFU(Y+IFI2-1500)
ILA=CODELA(Y+IFI2-1500)
C
C DOES A NEW CODE NEED TO BE SELECTED? 1100:YES, 2600:NO
C
GOTO (1100,300,600,700,800,900,1000) IFO
GOTO 1100
C
300 IF (irand(100).LT.5) ILA=ICORR(ILA+1)
comment **
IF (RANG(Y).GT.10) GOTO 2600
DO 400 I=1,70
IF (X(I).EQ.0.OR.OWNER(I).NE.2) GOTO 400
IF (IDIST(Z6,X(I)).GT.RANG(Y)) GOTO 400
IFO=7
ILA=X(I)
GOTO 2600
400 CONTINUE
C
600 IF (irand(100).LT.10) ILA=ICORR(ILA+1)
comment **
IF (RANG(Y).LE.11) GOTO 1100
GOTO 2600
C
700 IF (ILA.EQ.Z6) GOTO 1100
GOTO 2600
C
800 IF ((ILA.EQ.Z6).OR.(RANG(Y).LE.11)) GOTO 1100
GOTO 2600
C
900 IF (Z6.EQ.RLMAP(ILA+2800)) GOTO 1100
comment IF LANDED
IF (RLMAP(ILA+2800).EQ.0) GOTO 1100
comment IF CARRIER DOESN'T EXIST
IF (IDIST(Z6,RLMAP(ILA+2800)).GT.RANG(Y)) GOTO 1100
comment IF OUT OF RANG
GOTO 2600
C
1000 IF (Z6.EQ.ILA) GOTO 1100
comment IF LANDED
IF (IDIST(Z6,ILA).GT.RANG(Y)) GOTO 1100
comment IF OUT OF RANG
GOTO 2600
C
C NEW CODE SELECTION
C
1200 FUEL=RANG(Y)
comment NO CHOICE BUT BE KAMIKAZE
GOTO 1400
comment START LOOKING FOR ENEMY TROOP TRANS.
1100 IF (AB.EQ.'f') GOTO 2100
comment IF FIGHTER IS AIRBORNE
ID=0
1300 FUEL=RANG(Y)/2
comment DO THIS SO CRAFT CAN RETURN TO REFUEL
IF (irand(100).LT.5) FUEL=RANG(Y)
comment ** 1 IN 20 IS KAMIKAZE
1400 ISHIPT=3
comment ENEMY TROOP TRANSPORTS
C
C LOOK FOR ENEMY TROOP TRANSPORTS, THEN SUBMARINES
C
1500 DO 1600 I=1,5
IF (TROOPT(ISHIPT,I).EQ.0) GOTO 1600
IF (IDIST(Z6,TROOPT(ISHIPT,I)).GT.FUEL) GOTO 1600
comment OUT OF RANG
IFO=5
IF (FUEL.EQ.RANG(Y)) IFO=4
ILA=TROOPT(ISHIPT,I)
GOTO 2600
comment PROCEED TO MOVE CORRECTION
1600 CONTINUE
IF (ISHIPT.EQ.2) GOTO 1700
comment IF ALREADY LOOKED FOR SUBS
ISHIPT=2
GOTO 1500
comment NOW LOOK FOR SUBS
1700 IF (ID.EQ.1000) GOTO 1900
comment IF NO REFUELING SPOT WITHIN RANG
IF (irand(100).LT.33) GOTO 1900
comment ** LOOK FOR ENEMY CONCENTRATIONS
IF (irand(100).LT.50) GOTO 2100
comment ** MOVE TOWARDS CITY OR CARRIER
C
C MOVE IN A RANDOM DIRECTION
C
1800 IFO=3
ILA=irand(8)+1
IF (irand(100).LT.5) IFO=2
comment ** ONE OUT OF 20 WILL BE KAMIKAZE
IF (NUMBER(2).LE.2) IFO=3
GOTO 2600
comment PROCEED TO MOVE CORRECTION
C
C MOVE TOWARD AN ENEMY CONCENTRATION WITHIN RANG
C
1900 DO 2000 I=1,10
DO 2000 J=2,11
IF (LOCI(I,J).EQ.0) GOTO 2000
IF (IDIST(Z6,LOCI(I,J)).GT.FUEL) GOTO 2000
comment IF OUT OF RANG
IFO=5
IF (FUEL.EQ.RANG(Y)) IFO=4
comment KAMIKAZE
ILA=LOCI(I,J)
GOTO 2600
comment PROCEED TO MOVE CORRECTION
2000 CONTINUE
IF (ID.EQ.1000) GOTO 1800
comment IF NO CITY OR CARRIER IS WITHIN RANG
C
C NOW MOVE TOWARDS A CITY CLOSEST TO ENEMY CONCENTRATION
C
2100 IA=MOD(Y,10)+1
DO 2200 IB=IA,IA+9
I=IB
IF (I.GT.10) I=I-10
IF (LOCI(I,2).EQ.0) GOTO 2200
LOC=LOCI(I,2)
ID=IDIST(Z6,LOCI(I,2))
GOTO 2300
2200 CONTINUE
LOC=EXPL()
2300 ID=1000
IGARBG=irand(70+LIMIT(15))+1
comment **
DO 2500 ILOOP=IGARBG,IGARBG+70+LIMIT(15)
IA=ILOOP
IF (IA.GT.70+LIMIT(15)) IA=IA-70-LIMIT(15)
IF (IA.GT.70) GOTO 2400
IF (OWNER(IA).NE.2) GOTO 2500
IF (IDIST(Z6,X(IA)).GT.RANG(Y)) GOTO 2500
IF (IDIST(X(IA),LOC).GE.ID) GOTO 2500
IFO=7
ILA=X(IA)
ID=IDIST(X(IA),LOC)
GOTO 2500
2400 IB=IA-70
IF (RLMAP(2800+IB).EQ.0) GOTO 2500
IF (IDIST(Z6,RLMAP(2800+IB)).GT.RANG(Y)) GOTO 2500
IF (IDIST(RLMAP(2800+IB),LOC).GE.ID) GOTO 2500
IF ((RANG(Y).EQ.20).AND.(IDIST(Z6,RLMAP(2800+IB)).GT.12)
1 .AND.(CODEFU(1300+IB).NE.9)) GOTO 2500
IFO=6
ILA=IB
ID=IDIST(RLMAP(2800+IB),LOC)
2500 CONTINUE
IF (ID.EQ.1000) GOTO 1200
GOTO 2600
C
C MOVE CORRECTION
C
2600 IZOT=0
MOOV=0
IF (ILA.GT.100) IZOT=MOV(Z6,ILA)
IF (ILA.LT.10) IZOT=ILA
IF (IFO.EQ.6) IZOT=MOV(Z6,RLMAP(2800+ILA))
IF ((IFO.LT.4).AND.(irand(100).LT.5)) IZOT=ICORR(IZOT+1)
comment **
DO 2700 I=1,8
AC=RMAP(Z6+IARROW(I+1))
comment **
IF ((AC.NE.'D').AND.(AC.NE.'S').AND.(AC.NE.'T')
1 .AND.(AC.NE.'F').AND.(AC.NE.'A')) GOTO 2700
MOOV=I
GOTO 3100
2700 CONTINUE
C
C LOOK FOR TERRITORY TO EXPLOR IN FRONT
C
IF (RANG(Y).LE.10) GOTO 2900
comment IF LOW ON FUEL
IZOT2=IZOT
comment STORE IZOT A MOMENT
Z62=Z6+IARROW(ICORR(IZOT2+1)+1)
comment **
IF (ORDER(Z62).NE.0) GOTO 2800
comment IF ON THE EDGE OF THE MAP
IF (EMAP(Z62).EQ.' ') IZOT=ICORR(IZOT2+1)
comment IF Z62 IS UNEXPLORED
2800 Z62=Z6+IARROW(ICORR(IZOT2-1)+1)
comment **TRY OTHER SIDE
IF (ORDER(Z62).NE.0) GOTO 2900
comment IF ON THE EDGE OF THE MAP
IF (EMAP(Z62).EQ.' ') IZOT=ICORR(IZOT2-1)
comment IF Z62 IS UNEXPLORED
C
2900 DESTIN=ILA
IF (IFO.EQ.6) DESTIN=RLMAP(2800+ILA)
ID=IZOT
DO 3000 I=0,7
IZOT=ICORR(ID+I)
NEWLOC=Z6+IARROW(IZOT+1)
comment **
IF (IFO.GT.3) THEN
IF (IDIST(Z6,DESTIN).LE.IDIST(NEWLOC,DESTIN)) GOTO 3000
ENDIF
AC=RMAP(NEWLOC)
IF ((((AC.GE.'A').AND.(AC.LE.'T')).OR.
1 (AC.EQ.'X').OR.(AC.EQ.'.').OR.
1 (AC.EQ.'c').OR.(AC.EQ.'+')).AND.(ORDER(NEWLOC).EQ.0))
1 GOTO 3100
3000 CONTINUE
IZOT=0
3100 CODEFU(IFI2-1500+Y)=IFO
CODELA(IFI2-1500+Y)=ILA
IF (IFO.LT.4) CODELA(IFI2-1500+Y)=IZOT
IF (CODER.EQ.2) PRINT 998,IFO,CODELA(IFI2-1500+Y)
998 FORMAT(I)
IF (MOOV.NE.0) IZOT=MOOV
Z6=Z6+IARROW(IZOT+1)
comment **
C
C MOVE EVALUATION
C
IF (AB.EQ.'f') RMAP(Z7)=OMAP(Z7)
AB=RMAP(Z6)
IF ((AB.EQ.'.').OR.(AB.EQ.'+')) GOTO 3200
IF ((AB.EQ.'X').OR.(AB.EQ.'c')) GOTO 3300
IF (OMAP(Z6).EQ.'*') GOTO 3400
H2=30
P=1
H1=1
OWN1='f'
OWN2=AB
CALL FIND(OWN2,Z6,Z8,H2)
CALL FGHT(Z6,H1,H2,OWN1,OWN2)
CALL FIND(OWN2,Z6,Z8,H2)
IF (H1.LE.0) GOTO 3400
3200 RMAP(Z6)='f'
STOPF=0
3300 RANG(Y)=RANG(Y)-1
IF (I1.EQ.1) NUMBER(2)=NUMBER(2)+1
RLMAP(2000+Y)=Z6
CALL SONAR(Z6)
IF (P.EQ.1) CALL SENSOR(Z6)
IF (STOPF.EQ.1) GOTO 3600
3500 CONTINUE
GOTO 3600
3400 RLMAP(2000+Y)=0
CALL SONAR(Z6)
IF (P.EQ.1) CALL SENSOR(Z6)
3600 CONTINUE
RETURN
END
SHAR_EOF
if test 6476 -ne "`wc -c < 'fightr.f'`"
then
echo shar: error transmitting "'fightr.f'" '(should have been 6476 characters)'
fi
fi # end of overwriting check
if test -f 'find.f'
then
echo shar: will not over-write existing file "'find.f'"
else
cat << \SHAR_EOF > 'find.f'
subroutine find(own, z6, z8, h2)
c
c Cross-reference subroutine, it finds data on whatever
c craft is at point z6.
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
if (h2 .gt. 0) goto 1100
c
c Now we must destroy own
c first of all, update troopt
c
ishp = 0
if (own .eq. 'D') ishp = 1
if (own .eq. 'S') ishp = 2
if (own .eq. 'T') ishp = 3
if (own .eq. 'R') ishp = 4
if (own .eq. 'C') ishp = 5
if (own .eq. 'B') ishp = 6
if (ishp .eq. 0) goto 200
do 100 z = 1, 5
100 if (troopt(ishp, z) .eq. z6) troopt(ishp, z) = 0
c
c Now destroy the craft, set rlmap(n)=0
c
200 if (own .ne. 'C') goto 400
do 300 z = 1, 200
if (rlmap(500 + z) .ne. z6) goto 300
rlmap(500 + z) = 0
if (mode .eq. 1) call tpos(2, 60)
print 999, z
999 format('+Fighter #'I3' sunk'$)
300 continue
400 if (own .ne. 'T') goto 600
do 500 z = 1, 500
if (rlmap(z) .ne. z6) goto 500
rlmap(z) = 0
if (mode .eq. 1) call tpos(2, 60)
print 998, z
998 format('+Army #'I3' sunk'$)
500 continue
600 if (own .ne. 't') goto 800
do 700 z = 1501, 2000
700 if (rlmap(z) .eq. z6) rlmap(z) = 0
800 if (own .ne. 'c') goto 1000
do 900 z = 2001, 2200
900 if (rlmap(z) .eq. z6) rlmap(z) = 0
1000 rlmap(z8) = 0
if ((own .ge. 'a') .and. (own .le. 't')) call sonar(z6)
if ((own .ge. 'A') .and. (own .le. 'T')) call sensor(z6)
return
1100 if (h2 .eq. 30) goto 1200
if ((own .eq. 'A') .or. (own .eq. 'F') .or. (own .eq. 'a') .or.
$ (own .eq. 'f')) return
if ((own .ge. 'A') .and. (own .le. 'T')) j1ts(z8 - 700) = h2
if ((own .ge. 'a') .and. (own .le. 't')) j1ts(z8 - 1400) = h2
return
1200 h2 = 0
ia = 1
if (own .eq. 'T') ia = 1101
if (own .eq. 'O') ia = 1101
comment special hack for docking
if (own .eq. 'C') ia = 1301
if (own .eq. 'a') ia = 1501
if (own .eq. 'f') ia = 2001
if (own .eq. 't') ia = 2601
if (own .eq. 'c') ia = 2801
do 1300 z8 = ia, 3000
if (rlmap(z8) .eq. z6) goto 1400
1300 continue
pause ' Error in subroutine find, "CONTINUE" to continue'
997 format(' ERROR IN SUB. FIND')
return
1400 if ((own .eq. 'A') .or. (own .eq. 'F') .or. (own .eq. 'a') .or.
$ (own .eq. 'f')) h2 = 1
if (h2 .eq. 1) return
if ((own .ge. 'A') .and. (own .le. 'T')) h2 = j1ts(z8 - 700)
if ((own .ge. 'a') .and. (own .le. 't')) h2 = j1ts(z8 - 1400)
return
end
SHAR_EOF
if test 2250 -ne "`wc -c < 'find.f'`"
then
echo shar: error transmitting "'find.f'" '(should have been 2250 characters)'
fi
fi # end of overwriting check
if test -f 'game.f'
then
echo shar: will not over-write existing file "'game.f'"
else
cat << \SHAR_EOF > 'game.f'
subroutine game ( icode, num )
c
c This subroutine reads in the game map and initializes the
c map arrays it also saves and restores the game from the
c save file using the codes: -1 = restore, 0 = init, 1 = save
c
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
data ifile /'G','A','M','E','S',':','E','M','R','A','\0'/
if ( icode ) 1800, 100, 1500
comment -1/0/+1 = restore/init/save
c
c Here to initialize the game
c
100 do 200 i = 1, 70
comment clear arrays
x ( i ) = 0
found ( i ) = 0
owner ( i ) = 0
phase ( i ) = 0
target ( i ) = 0
fipath ( i ) = 0
200 continue
do 300 i=1,1500
codefu ( i ) = 0
codela ( i ) = 0
mycode ( i ) = 0
300 continue
do 400 i = 1, 200
range ( i ) = 0
rang ( i ) = 0
400 continue
do 500 i = 1, 500
500 ar2s ( i ) = 0
do 600 i = 1, 3000
rlmap ( i ) = 0
600 continue
do 700 i = 1, 6000
emap ( i ) = ' '
pmap ( i ) = ' '
700 continue
mode = 1
isec = -1
call time ( pamela )
c call date ( reeed )
c reeed ( 5 ) = reeed ( 5 ) + o'40'
comment make lower case
c reeed ( 6 ) = reeed ( 6 ) + o'40'
version = 6
comment version of data within emsave.dat
ib=1
c
c Map selection. Pick one of the maps randomly. Maps are in files a-f
C
C We don't have the maps anyway.
C
c try = 0
comment try again
c900 try = try + 1
c ifile ( 10 ) = 'a'
c ifile ( 10 ) = ifile ( 10 ) + irand ( 10 )
c
ccomment currently six maps, allow 4 extra
c if ( try .le. 8 ) goto 1000
ccomment try again if you don't have them all
call cr
call strout ( 'Generating new map...')
call cflush
call gen
try = 0
goto 1100
c1000 open ( unit=1, file=ifile, access = 'SEQUENTIAL',
c * form = 'UNFORMATTED', type = 'OLD', readonly, err=900 )
c read ( 1 ) ( d ( I ), i = 1, 223 )
c read ( 1 ) ( d ( I ), i = 224, 446 )
c read ( 1 ) ( d ( I ), i = 447, 667 )
c close ( unit = 1 )
c
c City and a-map initialization
c
1100 call initia ( try )
comment transfer map from d() into mapbuf
1200 c = irand ( 70 ) + 1
comment ** pick our city
id = irand ( 70 ) + 1
comment pick enemy city
if (x(c) .eq. 0 .or. x(id) .eq. 0) goto 1200
if (x(c) .eq. x(id)) goto 1200
if ((edger(x(c)) .eq. 8) .or. (edger(x(id)) .eq. 8)) goto 1200
if ( try .ne. 0 ) goto 1300
1250 pcon = cities(int(rmap(x(id))))
econ = cities(int(rmap(x(c))))
if (pcon.le.100) goto 1200
comment note rmap is really owner
if (econ.le.100) goto 1200
comment from map generator
ptot=pcon/100+mod(pcon,100)
etot=econ/100+mod(econ,100)
if (ptot.le.etot) goto 1275
i = c
c = id
id = i
goto 1250
1275 diff=min(11,((etot*2*100+45)/ptot)/100)-1
if ( pcon .eq. econ ) diff = 3
call cr
ptr = 0
call addstr ( 'Difficulty estimate: ', jnkbuf, ptr )
call addint ( diff, jnkbuf, ptr )
call addstr ( ' where 1 is easy and 10 is most challenging.',
* jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call cr
call strout ( jnkbuf )
1300 z6 = x ( id )
ptr = 0
call addstr ( 'Your city is at ', jnkbuf, ptr )
call addint ( x ( id ), jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = '\0'
call cr
call cr
call strout ( jnkbuf )
call cr
do 1400 i=1,6000
1400 rmap ( i ) = omap ( i )
rmap(z6) = 'O'
comment mark it on map
rmap(x(c)) = 'X'
call sonar(x(c))
comment do sensor scans
call sensor(z6)
mode = 0
call ltr ( z6, 0 )
comment show the city
mode=1
call strout ( 'What do you demand that this city produce? ' )
call cflush
owner(id)=1
mdate = 0
call phasin(id,e)
call putc ( e )
call cflush
owner ( c ) = 2
phase ( c ) = 1
found ( c ) = 5
z6 = x ( id )
return
comment return to orders mode
c
c Here to save a game
c
1500 if (mode .ne. 0) goto 1600
call cr
call strout ( 'A few moments please...' )
call cr
call cflush
1600 continue
call time ( pamela )
c call date ( reeed )
c reeed ( 5 ) = reeed ( 5 ) + ' '
comment make lower case
c reeed ( 6 ) = reeed ( 6 ) + ' '
open ( unit=1, file='EMSAVE', access='SEQUENTIAL',
* form='UNFORMATTED', status='UNKNOWN' )
write ( 1 ) limit, mdate, version, pamela, reeed
write ( 1 ) emap, rmap, pmap, omap
write ( 1 ) rlmap
write ( 1 ) troopt
write ( 1 ) number
write ( 1 ) x, target, found
write ( 1 ) owner, phase
do 1700 i = 1, 16
1700 call write ( iotab ( I ), limit ( I ), i )
write ( 1 ) j1ts
write ( 1 ) num
write ( 1 ) loci
write ( 1 ) nshift, fipath
close ( unit=1 )
return
c
c Here to restore a game
c
1800 continue
call cr
call strout ( 'A few moments please...' )
call cflush
open ( unit=1, file='EMSAVE', access='SEQUENTIAL',
* form='UNFORMATTED', status='OLD',err=2200)
read(1) limit,mdate,version,pamela,reeed
read(1) emap,rmap,pmap,omap
if(version.ge.6) goto 1850
version=6
comment translate to new version
do 1850 i=1,6000
if((emap ( I ).ge.'1').and.(emap ( I ).le.'8')) call tran(emap ( I ))
if((rmap ( I ).ge.'1').and.(rmap ( I ).le.'8')) call tran(rmap ( I ))
if((pmap ( I ).ge.'1').and.(pmap ( I ).le.'8')) call tran(pmap ( I ))
1850 continue
read(1) rlmap
read(1) troopt
read(1) number
read(1) x,target,found
read(1) owner,phase
do 1900 i=1,16
1900 call read ( iotab ( i ), limit ( i ), i )
if (version.le.4) read(1) (j1ts ( I ),i=1,1500)
if (version.ge.5) read(1) j1ts
read(1) num
read(1) loci
read(1) nshift,fipath
2000 close(unit=1)
ptr = 59
c encode ( ptr, 996, jnkbuf ) pamela, reeed
c996 FORMAT('Ready to resume game terminated at ', 8A1,
c * ' on ', 7a1, '19', 2a1 )
print 996
996 FORMAT('Ready to resume game terminated at ???')
call cr
call bufout ( jnkbuf, ptr )
mode=1
isec=-1
return
2200 continue
call cr
call strout ( 'Unable to open save file, EMSAVE.DAT,
* Starting new game.' )
call cflush
goto 100
end
SHAR_EOF
if test 5547 -ne "`wc -c < 'game.f'`"
then
echo shar: error transmitting "'game.f'" '(should have been 5547 characters)'
fi
fi # end of overwriting check
if test -f 'gen.f'
then
echo shar: will not over-write existing file "'gen.f'"
else
cat << \SHAR_EOF > 'gen.f'
C
C RANDOM MAP GENERATION SUBROUTINES
C
SUBROUTINE GEN
IMPLICIT INTEGER(A-Z)
PARAMETER (WIDTH=100,HEIGHT=60)
character MAP(WIDTH,HEIGHT)
character OWNED(WIDTH,HEIGHT)
INTEGER SIZES(128)
include 'common.h'
EQUIVALENCE (MAP(1,1),OMAP(1)),(OWNED(1,1),RMAP(1))
100 DO 200 I=1,WIDTH
DO 200 J=1,HEIGHT
200 MAP(I,J)='.'
HSECTS=3+irand(4)
VSECTS=3+irand(3)
HSPACE=WIDTH/HSECTS
VSPACE=HEIGHT/VSECTS
DO 400 I=1,HSECTS
DO 400 J=1,VSECTS
DO 400 K=1,irand(2)+irand(3)
CALL MAKELAND
YPOS=(J-1)*VSPACE+irand(VSPACE)
XPOS=(I-1)*HSPACE+irand(HSPACE)
DO 300 L=1,39
DO 300 M=1,39
IF (SUBMAP(L,M).EQ.' ') GOTO 300
IF (((XPOS+L-20).LE.0).OR.((XPOS+L-20).GT.100)) GOTO 300
IF (((YPOS+M-20).LE.0).OR.((YPOS+M-20).GT.60)) GOTO 300
MAP(XPOS+L-20,YPOS+M-20)=SUBMAP(L,M)
300 CONTINUE
400 CONTINUE
COUNT=0
DO 500 I=1,100
DO 500 J=1,60
IF (MAP(I,J).EQ.'.') COUNT=COUNT+1
500 CONTINUE
IF (COUNT.LT.4000.AND.COUNT.GT.2500) GOTO 600
c PRINT 999,COUNT
C WRITE (1,999) COUNT
999 FORMAT(' FAILED SEA CHECK, COUNT=',I5)
GOTO 100
c600 PRINT 998,COUNT
C WRITE (1,998) COUNT
998 FORMAT(' COUNT=',I5)
600 continue
DO 800 I=1,100
DO 800 J=1,60
OWNED(I,J)='\0'
800 CONTINUE
LAREA=1
WAREA=33
DO 1000 I=2,99
DO 1000 J=2,59
IF (OWNED(I,J).NE.'\0') GOTO 1000
IF (MAP(I,J).EQ.'.') THEN
IF (SET(I,J,WAREA,'.',12000).EQ.0) GOTO 100
WAREA=WAREA+1
GOTO 1000
ELSE
IF (SET(I,J,LAREA,'+',1200).EQ.1) GOTO 900
c PRINT 997
C WRITE (1,997)
997 FORMAT(' FAILED SINGLE LAND MASS TEST')
C GOTO 100
goto 1000
ENDIF
900 LAREA=LAREA+1
1000 CONTINUE
IF (LAREA.GE.10.AND.LAREA.LE.30) GOTO 1100
c PRINT 996, LAREA
C WRITE(1,996)
996 FORMAT('FAILED SEPARATION TEST -- land areas = ', i4)
c PRINT 103,((MAP(I,J),I=1,100),J=1,60)
C WRITE(1,103) ((MAP(I,J),I=1,100),J=1,60)
103 FORMAT(1X,100A1)
GOTO 100
c1100 PRINT 995,((int('@')+int(OWNED(I,J)),I=1,100),J=1,60)
C WRITE(1,995) (('@'+OWNED(I,J),I=1,100),J=1,60)
995 FORMAT(1X,100A1)
1100 DO 1300 I=1,128
1300 SIZES(I)=0
DO 1400 I=2,99
DO 1400 J=2,59
SIZES(int(OWNED(I,J)))=SIZES(int(OWNED(I,J)))+1
1400 CONTINUE
SCOUNT=COUNT*40/50
DO 1500 SEA=33,WAREA
1500 IF (SIZES(SEA).GE.SCOUNT) GOTO 1600
c PRINT 994
C WRITE (1,994)
994 FORMAT(' FAILURE- OCEANS ARE SEPARATED')
GOTO 100
1600 CITS=(6000-COUNT)/50+1
CITS=MAX(52,CITS)
CITS=MIN(70,CITS)
SEACITS=CITS*60/100+irand(12)
LANDCITS=CITS-SEACITS
DO 2100 K=1,SEACITS
1700 I=irand(98)+2
J=irand(58)+2
IF (MAP(I,J).NE.'+') GOTO 1700
DO 1800 L=MAX(2,I-1),MIN(99,I+1)
DO 1800 M=MAX(2,J-1),MIN(59,J+1)
IF (int(OWNED(L,M)).EQ.SEA) GOTO 1900
1800 CONTINUE
GOTO 1700
1900 DO 2000 L=MAX(2,I-3),MIN(99,I+3)
DO 2000 M=MAX(2,J-3),MIN(59,J+3)
IF (OWNED(L,M).NE.OWNED(I,J)) GOTO 2000
IF (MAP(L,M).EQ.'*') GOTO 1700
2000 CONTINUE
MAP(I,J)='*'
CITIES(int(OWNED(I,J)))=CITIES(int(OWNED(I,J)))+100
2100 CONTINUE
DO 2500 K=1,LANDCITS
2200 I=irand(98)+2
J=irand(58)+2
IF (MAP(I,J).NE.'+') GOTO 2200
DO 2300 L=MAX(2,I-1),MIN(99,I+1)
DO 2300 M=MAX(2,J-1),MIN(59,J+1)
IF (MAP(L,M).EQ.'.') GOTO 2200
2300 CONTINUE
DO 2400 L=MAX(2,I-2),MIN(99,I+2)
DO 2400 M=MAX(2,J-2),MIN(59,J+2)
IF (OWNED(L,M).NE.OWNED(I,J)) GOTO 2400
IF (MAP(L,M).EQ.'*') GOTO 2200
2400 CONTINUE
MAP(I,J)='*'
CITIES(int(OWNED(I,J)))=CITIES(int(OWNED(I,J)))+1
2500 CONTINUE
c PRINT 993,((MAP(I,J),I=1,100),J=1,60)
C WRITE(1,993) ((MAP(I,J),I=1,100),J=1,60)
993 FORMAT(1X,100A1)
END
SHAR_EOF
if test 3438 -ne "`wc -c < 'gen.f'`"
then
echo shar: error transmitting "'gen.f'" '(should have been 3438 characters)'
fi
fi # end of overwriting check
if test -f 'getc.c'
then
echo shar: will not over-write existing file "'getc.c'"
else
cat << \SHAR_EOF > 'getc.c'
getc_(cp)
char *cp;
{
int count, one = 1;
cflush_();
getstr_(cp, &one, &count);
}
SHAR_EOF
if test 87 -ne "`wc -c < 'getc.c'`"
then
echo shar: error transmitting "'getc.c'" '(should have been 87 characters)'
fi
fi # end of overwriting check
if test -f 'getcq.c'
then
echo shar: will not over-write existing file "'getcq.c'"
else
cat << \SHAR_EOF > 'getcq.c'
getcq_(cp)
char *cp;
{
int count, one = 1;
cflush_();
getstrq_(cp, &one, &count);
}
SHAR_EOF
if test 89 -ne "`wc -c < 'getcq.c'`"
then
echo shar: error transmitting "'getcq.c'" '(should have been 89 characters)'
fi
fi # end of overwriting check
if test -f 'head.f'
then
echo shar: will not over-write existing file "'head.f'"
else
cat << \SHAR_EOF > 'head.f'
subroutine head ( own1, y, num, z6, h1 )
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
integer i
ptr = 0
call addidt ( own1, jnkbuf, ptr )
call addstr ( ' ', jnkbuf, ptr )
call addint ( y, jnkbuf, ptr )
call addstr ( ' at ', jnkbuf, ptr )
call addint ( z6, jnkbuf, ptr )
do 100, i = ptr + 1, 40
jnkbuf (i) = ' '
100 continue
ptr = 39
call addsts ( mycode ( num ), jnkbuf, ptr )
if ( own1 .eq. 'A' ) goto 500
do 200, i = ptr + 1, 60
jnkbuf (i) = ' '
200 continue
ptr = 59
if ( own1 .ne. 'F' ) goto 250
call addstr ( 'Range: ', jnkbuf, ptr )
call addint ( range ( y ), jnkbuf, ptr )
goto 500
250 continue
call addstr ( 'Hits left: ', jnkbuf, ptr )
call addint ( h1, jnkbuf, ptr )
500 continue
jnkbuf ( ptr + 1 ) = '\0'
call topmsg ( 1, jnkbuf )
call cflush
return
end
SHAR_EOF
if test 801 -ne "`wc -c < 'head.f'`"
then
echo shar: error transmitting "'head.f'" '(should have been 801 characters)'
fi
fi # end of overwriting check
if test -f 'help.f'
then
echo shar: will not over-write existing file "'help.f'"
else
cat << \SHAR_EOF > 'help.f'
ccc help - give help
subroutine help
call clear
call topini
cc call topmsg ( 'EMPIRE.HLP (see EMPIRE.DOC for more detail)' )
call topmsg ( 2, 'ORDERS MODE-----------
* MOVE MODE------------- EDIT MODE-------------' )
call strpos ( 7, 1, 'A: Stay in Move mode' )
call strpos ( 8, 1, 'C: Give 1 free move' )
call strpos ( 9, 1, 'H: This text' )
call strpos ( 10, 1, 'J: Enter edit mode' )
call strpos ( 11, 1, 'M: Enter move mode' )
call strpos ( 12, 1, 'N: Give n free moves' )
call strpos ( 13, 1, 'P: Refresh sector' )
call strpos ( 14, 1, 'Q: Quit game' )
call strpos ( 15, 1, 'R: Display round #' )
call strpos ( 16, 1, 'S: Clear screen' )
call strpos ( 17, 1, 'T: Print out map' )
call strpos ( 18, 1, 'V: Save game' )
call cflush
call strpos( 4, 25, 'QWE: Movement' )
call strpos( 5, 25, 'A D direction' )
call strpos( 6, 25, 'ZXC : Sit' )
cc call strpos( 7, 25, ': Sit' )
call strpos( 8, 25, 'G: Sleep till full T,C' )
call strpos( 9, 25, 'H: This text' )
call strpos( 10, 25, 'I: Set direction' )
call strpos( 11, 25, 'J: Enter edit mode' )
call strpos( 12, 25, 'K: Wake piece' )
call strpos( 13, 25, 'L: Set city direction' )
call strpos( 14, 25, 'O: Cancel auto moves' )
call strpos( 15, 25, 'P: Refresh screen' )
call strpos( 16, 25, 'R: Random for armies' )
call strpos( 17, 25, 'S: Sentry' )
call strpos( 18, 25, '?: Display function' )
call cflush
cc call strpos( 4, 49, 'QWE: Cursor' )
cc call strpos( 5, 49, 'A D direction' )
cc call strpos( 6, 49, 'ZXC' )
cc call strpos( 8, 49, 'G: Sleep til full T,C' )
call strpos( 8, 49, 'H: This text' )
call strpos( 9, 49, 'I: Set direction' )
call strpos( 10, 49, 'K: Wake anything' )
call strpos( 11, 49, 'M: Set path start' )
call strpos( 12, 49, 'N: Set path end' )
call strpos( 13, 49, 'O: Exit edit mode' )
call strpos( 14, 49, 'P: Change sector' )
call strpos( 15, 49, 'R: Random for armies' )
call strpos( 16, 49, 'S: Sentry ' )
call strpos( 17, 49, 'Y: Set city production' )
call strpos( 18, 49, '?: Display function' )
call cflush
call strpos ( 20, 1, 'Piece---Yours-Enemy-Moves-Hits-Cost
* Piece---Yours-Enemy-Moves-Hits-Cost' )
call strpos ( 21, 1, 'army A a 1 1 5
* transport T t 2 3 30' )
call strpos ( 22, 1, 'fighter F f 4 1 10
* cruiser R r 2 8 50' )
call strpos ( 23, 1, 'destroyer D d 2 3 20
* carrier C c 2 8 60' )
call strpos ( 24, 1, 'submarine S s 2 2 25
* battleship B b 2 12 75' )
call cflush
return
end
SHAR_EOF
if test 2632 -ne "`wc -c < 'help.f'`"
then
echo shar: error transmitting "'help.f'" '(should have been 2632 characters)'
fi
fi # end of overwriting check
if test -f 'hits.c'
then
echo shar: will not over-write existing file "'hits.c'"
else
cat << \SHAR_EOF > 'hits.c'
#include
#include
#include "c_common.h"
extern int debug;
extern FILE *fileerr;
static int b[8] = { 1 , 1, 3, 2, 3, 8, 8, 12 };
hits_(own)
int *own;
{
int i;
for (i = 0; i < 8; i++)
if (*own == phazee_[i])
return (b[i]);
if (debug) {
fprintf(fileerr, "DEBUG: returning 0 for %d\n", *own);
fflush(fileerr);
}
return (0);
}
static char atyp[8] = { 'A','F','D','S','T','R','C','B' };
chits_(own)
char *own;
{
int i;
char ch;
ch = (islower(*own)) ? toupper(*own) : *own;
for (i = 0; i < 8; i++)
if (ch == atyp[i])
return (b[i]);
if (debug) {
fprintf(fileerr, "DEBUG: returning 0 for %c\n", *own);
fflush(fileerr);
}
return (0);
}
SHAR_EOF
if test 694 -ne "`wc -c < 'hits.c'`"
then
echo shar: error transmitting "'hits.c'" '(should have been 694 characters)'
fi
fi # end of overwriting check
if test -f 'huh.c'
then
echo shar: will not over-write existing file "'huh.c'"
else
cat << \SHAR_EOF > 'huh.c'
huh_()
{
int two = 2;
topmsg_(&two, "Huh?" );
cflush_();
}
SHAR_EOF
if test 62 -ne "`wc -c < 'huh.c'`"
then
echo shar: error transmitting "'huh.c'" '(should have been 62 characters)'
fi
fi # end of overwriting check
if test -f 'icorr.c'
then
echo shar: will not over-write existing file "'icorr.c'"
else
cat << \SHAR_EOF > 'icorr.c'
icorr_(np)
int *np;
{
if (*np > 8)
return (*np - 8);
else if (*np < 1)
return (*np + 8);
else
return (*np);
}
SHAR_EOF
if test 121 -ne "`wc -c < 'icorr.c'`"
then
echo shar: error transmitting "'icorr.c'" '(should have been 121 characters)'
fi
fi # end of overwriting check
if test -f 'idist.c'
then
echo shar: will not over-write existing file "'idist.c'"
else
cat << \SHAR_EOF > 'idist.c'
#include
#define MAX(a,b) ((a > b) ? (a) : (b))
#define ABS(a) (((a) < 0) ? -(a) : (a))
/*
* Return distance between location n1 and n2
*/
idist_(n1p, n2p)
int *n1p, *n2p;
{
int x, y;
x = ABS(((*n1p - 1) % 100) - ((*n2p - 1) % 100));
y = ABS(((*n1p - 1) / 100) - ((*n2p - 1) / 100));
return (MAX(x, y));
}
SHAR_EOF
if test 327 -ne "`wc -c < 'idist.c'`"
then
echo shar: error transmitting "'idist.c'" '(should have been 327 characters)'
fi
fi # end of overwriting check
if test -f 'initia.f'
then
echo shar: will not over-write existing file "'initia.f'"
else
cat << \SHAR_EOF > 'initia.f'
subroutine initia(flag)
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
character decode
external decode
do 300 i=1,6000
if (flag.ne.0) omap(i)=decode(i)
if (omap(i).ne.'*') goto 300
n1=irand(70)+1
comment **
do 100 n3=n1,n1+70
n=n3
if (n.gt.70) n=n-70
100 if (x(n).eq.0) goto 200
200 x(n)=i
300 continue
return
end
SHAR_EOF
if test 328 -ne "`wc -c < 'initia.f'`"
then
echo shar: error transmitting "'initia.f'" '(should have been 328 characters)'
fi
fi # end of overwriting check
if test -f 'iport.f'
then
echo shar: will not over-write existing file "'iport.f'"
else
cat << \SHAR_EOF > 'iport.f'
FUNCTION IPORT(Z6)
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
IPORT=0
ID=500
DO 100 I=1,70
IF (X(I).EQ.0) GOTO 100
IF (RMAP(X(I)).NE.'X') GOTO 100
IF (EDGER(Z6).EQ.0) GOTO 100
IF (IDIST(X(I),Z6).GE.ID) GOTO 100
IPORT=X(I)
ID=IDIST(X(I),Z6)
100 CONTINUE
IF (IPORT.NE.0) RETURN
IPORT=irand(5798)+102
RETURN
END
SHAR_EOF
if test 328 -ne "`wc -c < 'iport.f'`"
then
echo shar: error transmitting "'iport.f'" '(should have been 328 characters)'
fi
fi # end of overwriting check
if test -f 'iphase.c'
then
echo shar: will not over-write existing file "'iphase.c'"
else
cat << \SHAR_EOF > 'iphase.c'
/*
* iphase - return integer of ascii i as a sector number
*/
iphase_(cp)
char *cp;
{
if (*cp >= '0' && *cp <= '9')
return (*cp - '0');
else
return (*cp);
}
SHAR_EOF
if test 166 -ne "`wc -c < 'iphase.c'`"
then
echo shar: error transmitting "'iphase.c'" '(should have been 166 characters)'
fi
fi # end of overwriting check
if test -f 'iscape.f'
then
echo shar: will not over-write existing file "'iscape.f'"
else
cat << \SHAR_EOF > 'iscape.f'
FUNCTION ISCAPE(I,M)
IMPLICIT INTEGER(A-Z)
C
C: I = NUMBER OF TIMES ONE HAS TRIED TO ESCAPE
CM: DIRECTION IN WHICH DANGER LIES
C
INTEGER ITAB(8)
LOGICAL PASS
COMMON/PASS/PASS
DATA ITAB/4,5,3,6,2,7,1,0/
C
ISC=M
IF ((PASS).AND.((I.LT.1).OR.(I.GT.8))) GOTO 100
IF ((PASS).AND.((ISC.LT.1).OR.(ISC.GT.8))) GOTO 100
ISC=ICORR(M+ITAB(I))
ISCAPE=ISC
RETURN
100 PRINT 999,ISC,I,M
999 FORMAT(' ISCAPE- ISC,M,I:',3I)
RETURN
END
SHAR_EOF
if test 431 -ne "`wc -c < 'iscape.f'`"
then
echo shar: error transmitting "'iscape.f'" '(should have been 431 characters)'
fi
fi # end of overwriting check
if test -f 'ittype.f'
then
echo shar: will not over-write existing file "'ittype.f'"
else
cat << \SHAR_EOF > 'ittype.f'
ccc ittype - return terminal type
subroutine ittype(term)
integer term
c
c synopsis
c
c call ittype(term)
c
c term - integer containing terminal type
c
c
c Common terminal
c
integer ttbufsiz
parameter (ttbufsiz = 750)
comment size of buffer in characters
common /ioempire/ TTVT52, TTVT100,
$ TTANN, TTHP, TTADM, TTHZ15,
$ inchan, outchan, ttnbuf, tttype, ttflag, ttbuf
integer TTVT52, TTVT100
integer TTANN, TTHP, TTADM, TTHZ15
integer inchan
comment input channel
integer outchan
comment output channel
integer ttnbuf
comment number of characters to output
integer tttype
comment terminal type
logical ttflag
comment flag for non-buffered i/o
character ttbuf(ttbufsiz)
comment the buffer
term = tttype
return
end
SHAR_EOF
if test 746 -ne "`wc -c < 'ittype.f'`"
then
echo shar: error transmitting "'ittype.f'" '(should have been 746 characters)'
fi
fi # end of overwriting check
if test -f 'jiggle.f'
then
echo shar: will not over-write existing file "'jiggle.f'"
else
cat << \SHAR_EOF > 'jiggle.f'
FUNCTION JIGGLE(Z6,NUM)
C
C DO RANDOM MOVE FOR PLAYER'S ARMY
C
IMPLICIT INTEGER(A-Z)
include 'common.h'
C
C
DO 100 I=1,9
100 AB9(I)=RMAP(Z6+IARROW(I+1))
comment **
IF (AB9(9).NE.'T') GOTO 200
JIGGLE=0
MYCODE(NUM)=0
RETURN
C
200 DO 300 I1=1,9
300 IF ((AB9(I1).EQ.'*').OR.(AB9(I1).EQ.'X')) GOTO 400
I1=9
400 DO 500 I2=1,9
500 IF ((AB9(I2).GE.'a').AND.(AB9(I2).LE.'t')) GOTO 600
I2=9
600 DO 700 I3=1,9
700 IF (AB9(I3).EQ.'T') GOTO 800
I3=9
800 M1=irand(8)+1
comment **
M2=M1+7
DO 900 I4=M1,M2