edjames@ic.Berkeley.EDU (Ed James) (12/19/86)
}; 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 <stdio.h> /* for NULL */ #include <sys/time.h> 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 <space>: Sit' ) cc call strpos( 7, 25, '<space>: 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 <stdio.h> #include <ctype.h> #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 <math.h> #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