DataMuseum.dk

top - metrics - download

    Length: 8152 (0x1fd8)
    Types: TextFile
    Names: »edit.f«

└─⟦b20c6495f⟧ Bits:30007238 EUUGD18: Wien-båndet, efterår 1987
    └─⟦this⟧ »EUUGD18/General/Empire/edit.f« 

TextFile

	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,ix
	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