pfuetz@agd.fhg.de (02/26/91)
Submitted-by: pfuetz@agd.fhg.de
Posting-number: Volume 11, Issue 92
Archive-name: xstrek/part06
#!/bin/sh
# To unshare, sh or unshar this file
echo xstrek/original_code/strek_create_form.f 1>&2
sed -e 's/^X//' > xstrek/original_code/strek_create_form.f <<'E!O!F! xstrek/original_code/strek_create_form.f'
X program strek_create_form
Xc
Xc *******************************************************************
Xc ***** *****
Xc ***** STAR TREK VERSION 3.0 *****
Xc ***** *****
Xc ***** written by *****
Xc ***** *****
Xc ***** Justin S. Revenaugh *****
Xc ***** *****
Xc ***** 7/87 *****
Xc ***** *****
Xc ***** Massachussetts Institute of Technology *****
Xc ***** Department of Earth, Atmospheric and Planetary Science *****
Xc ***** *****
Xc *******************************************************************
Xc
Xc STREK_CREATE_FORM creates a key defs form for use in STREK
Xc
Xc version 1
Xc -jsr 8/85
Xc
X character*5 key_name(90)
X character*256 key_file
Xc
Xc keynames in order
Xc
X data key_name /'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
X &'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
X &'x', 'y', 'z', 'l1', 'l2', 'l3', 'l4', 'l5', 'l6', 'l7', 'l8',
X &'l9', 'la', 'lb', 'lc', 'ld', 'le', 'lf', 'l1a', 'l2a', 'l3a',
X &'l1u', 'l2u', 'l3u', 'l4u', 'l5u', 'l6u', 'l7u', 'l8u', 'l9u',
X &'lau', 'lbu', 'lcu', 'ldu', 'leu', 'lfu', 'l1au', 'l2au', 'l3au',
X &'f1', 'f2', 'f3', 'f4', 'f5', 'f6', 'f7', 'f8','f1u', 'f2u',
X &'f3u', 'f4u', 'f5u', 'f6u', 'f7u', 'f8u', 'r1', 'r2', 'r3', 'r4',
X &'r5', 'r6', 'space', ',', '.', '/', ';', '['/
Xc
Xc request file pathname, open and write to it
Xc
X print*,' '
X print*,'This program creates a key definition form for use with'
X print*,'Strek.'
X print*,' '
X print*,'Enter the desired pathname of the form (<256 char.).'
X read (*,'(a)') key_file
X open (unit =1 , file = key_file)
X write (1, 100)
X100 format ('enter character definition in column 7')
X write (1, 110)
X110 format ('e.g. x')
X do 10 j = 1,90
X write (1,'(a5)') key_name(j)
X 10 continue
X close(1)
X stop
X end
E!O!F! xstrek/original_code/strek_create_form.f
echo xstrek/original_code/strek_db_subs.f 1>&2
sed -e 's/^X//' > xstrek/original_code/strek_db_subs.f <<'E!O!F! xstrek/original_code/strek_db_subs.f'
X subroutine strek_write (new, ship_name, capt_name, nick_name,
X & key_file, ship_avail, last_score,
X & cum_score, ship_active, top_ten)
Xc
Xc
Xc *******************************************************************
Xc ***** *****
Xc ***** STAR TREK VERSION 3.0 *****
Xc ***** *****
Xc ***** written by *****
Xc ***** *****
Xc ***** Justin S. Revenaugh *****
Xc ***** *****
Xc ***** 7/87 *****
Xc ***** *****
Xc ***** Massachussetts Institute of Technology *****
Xc ***** Department of Earth, Atmospheric and Planetary Science *****
Xc ***** *****
Xc *******************************************************************
X
Xc STREK_WRITE updates the two STREK info files (strek_info and
Xc strek_top_scores). If (new) then a name is appended, else the
Xc name is updated.
Xc
Xc
X integer*4 ship_avail(3), last_score, cum_score, ship_retired
X integer*4 num_lines, count, top_scores(10)
X logical ship_active, new, fyn, top_ten
X character ship_name*30, capt_name*10, nick_name*10, temp*30
X character ctemp(10)*10, stemp(10)*30, key_file*256
Xc
Xc if ship name is blank then return
Xc
X if (ship_name.eq.' ') then
X top_ten = .false.
X return
X end if
Xc
Xc open up strek_info file
Xc
X inquire(file='strek_info',exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=1,file='strek_info',access ='direct',form =
X & 'unformatted', status='old',recl=1000)
X inquire(file='strek_top_scores', exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=2,file='strek_top_scores' ,status='old',recl=1000)
Xc
Xc if new then update num_lines and append info
Xc
X if (ship_active) then
X ship_retired = 0
X else
X ship_retired = 1
X end if
X if (new) then
X read (1,rec=1) num_lines
X num_lines = num_lines + 1
X write (1,rec=1) num_lines
X write (1,rec=num_lines+1) ship_name, capt_name, nick_name,
X & key_file, (ship_avail(i),i=1,3), last_score,
X & cum_score, ship_retired
X close(1)
X else
Xc
Xc name is old, find it and update
Xc
X read(1,rec=1) num_lines
X count = 1
X 10 continue
X read(1,rec=count+1) temp
X if (temp.eq.ship_name) then
X write (1,rec=count+1) ship_name, capt_name, nick_name,
X & key_file, (ship_avail(i),i=1,3), last_score,
X & cum_score, ship_retired
X goto 20
X end if
X if (count.eq.num_lines) then
X close(1)
X end if
X count = count + 1
X goto 10
X 20 continue
X close(1)
X end if
Xc
Xc determine if the score is a top ten score
Xc
X do 30 j=1,10
X read (2,110) ctemp(j), stemp(j), top_scores(j)
X 30 continue
X rewind(2)
X110 format(a10,a30,i10)
X i = 1
X top_ten = .false.
X 40 continue
X if (cum_score.gt.top_scores(i)) then
X top_ten = .true.
X goto 50
X end if
X if (i.eq.10) goto 50
X i = i + 1
X goto 40
X 50 continue
X if (top_ten) then
Xc
Xc see if ship is already on the list
Xc
X do 55 j = 1,i-1
X if (stemp(j).eq.ship_name) then
X top_ten = .false.
X close(2)
X return
X end if
X 55 continue
X do 60 j = i,10
X if (stemp(j).eq.ship_name) then
Xc
Xc move everybody up one to delete the duplicate entry
Xc
X do 70 k = j,9
X stemp(k) = stemp(k+1)
X ctemp(k) = ctemp(k+1)
X top_scores(k) = top_scores(k+1)
X 70 continue
X end if
X 60 continue
Xc
Xc write out the new list, note that a ship that was previously
Xc on the list and who's score drops as a result of a mission
Xc will remain on the list.
Xc
X do 80 j = 1,i-1
X write (2,110) ctemp(j), stemp(j), top_scores(j)
X 80 continue
X write (2,110) capt_name, ship_name, cum_score
X do 90 j = i,9
X write (2,110) ctemp(j), stemp(j), top_scores(j)
X 90 continue
X end if
X close(2)
X return
X end
X
X
X
X
X
X subroutine strek_review (ship_name, capt_name, nick_name,
X & ship_avail, cum_score, last_score,
X & ship_active, key_file, status)
Xc
Xc STREK_REVIEW reviews the STREK database which includes
Xc ships, shipnames, captains, cumulative scores, ship avail-
Xc ability times and last outing scores. File is hardwired to
Xc be STREK_INFO. The file structure is as follows:
Xc
Xc line 1 number of lines (i8)
Xc
Xc lines 2 - last:
Xc
Xc shipname (char*30), captain (char*10), nickname (char*10),
Xc ship availability (3i*4), last outing score (i*10), cumu-
Xc lative score (i*10), ship active toggle (i*1).
Xc
Xc The file is direct access, and all new entries are appended
Xc to the end.
Xc
Xc A second file called STREK_TOP_SCORES is maintained. In it
Xc are the current ten best scores (ascii). The file is struct-
Xc ered:
Xc
Xc lines 1 - 10 captains name (char*10), shipname (char*30), and
Xc cumulative score (i*10).
Xc
Xc
Xc version 1
Xc -jsr 8/85
Xc
Xc
X integer*4 ship_avail(3), cum_score, ship_retired, last_score
X integer*4 status, num_lines, count
X logical ship_active, fyn
X character ship_name*30, capt_name*10, nick_name*10, temp*30
X character key_file*256
Xc
Xc open up strek_info file
Xc
X status = 0
X inquire(file='strek_info',exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=1,file='strek_info',access = 'direct',form =
X & 'unformatted', status='old',recl=1000)
Xc
Xc read number of lines
Xc
X read(1, rec=1) num_lines
X count = 1
X 10 continue
X read(1,rec=count+1) temp
X if (temp.eq.ship_name) then
X read(1,rec=count+1) temp, capt_name, nick_name, key_file,
X & (ship_avail(i),i=1,3), last_score, cum_score, ship_retired
X goto 20
X end if
X if (count.eq.num_lines) then
X close(1)
X status = 2
X return
X end if
X count = count + 1
X goto 10
X 20 continue
X close(1)
X if (ship_retired.eq.1) then
X ship_active = .false.
X else
X ship_active = .true.
X end if
X return
X end
X
X
X
X
X
X
X subroutine strek_question (capt_name, nick_name, ship_name,
X & key_file, new)
Xc
Xc STREK_QUESTION determines if the player has a ship or if he
Xc is new (or just a new ship).
Xc
Xc version 1
Xc -jsr 8/85
Xc
X logical new, found
X character capt_name*10, nick_name*10, ship_name*30
X character answer*1, key_file*256, means(256)*1
Xc
Xc key definition common
Xc
X common /key_defs/ means
X nick_name = ' '
Xc
Xc question captains
Xc
X print*,'STAR TREK v.3'
X print*,' '
X print*,'What is your name, captain?'
X read (*,'(a)') capt_name
X call strek_search_name (capt_name, ship_name, key_file, new)
X if (new) then
X print*,' '
X print*, 'What do your friends call you sir?'
X read(*,'(a)') nick_name
X 10 continue
X print*,' '
X print*,'Enter pathname of your key definition file.'
X print*,'<return> for no file.'
X read (*,'(a)') key_file
X if (key_file .ne. ' ') then
X call strek_parse_key_defs (key_file, found)
X if (.not.found) then
X print*,'The key definition file was not found, try again.'
X goto 10
X end if
X else
X do 20 j = 1, 256
X means(j) = char(j)
X 20 continue
X end if
X else
X if (key_file .ne. ' ') then
X call strek_parse_key_defs (key_file, found)
X if (.not.found) then
X print*,' '
X print*,'The key definition file was not found,'
X print*,'enter the pathname of another file.'
X print*,'<return> for no file.'
X print*,' '
X read(*,'(a)') key_file
X if (key_file .ne. ' ') then
X call strek_parse_key_defs (key_file, found)
X end if
X if (.not. found .or. key_file .eq. ' ') then
X do 30 j = 1, 256
X means(j) = char(j)
X 30 continue
X end if
X end if
X else
X do 40 j = 1, 256
X means(j) = char(j)
X 40 continue
X end if
X end if
X print*,' '
X return
X end
X
X
X
X
X
X subroutine strek_ships
Xc
Xc STREK_SHIPS outputs the current ship list including the
Xc scores of their last outings.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/cal.ins.ftn'
X% include '/sys/ins/time.ins.ftn'
Xc
X integer*2 decoded_clock(6)
X integer*4 num_lines, last_score, cum_score, ship_avail(3)
X integer*4 ship_retired
X logical fyn
X character ship_name*30, capt_name*10, nick_name*10, retired*10
X character key_file*256
X save retired
X data retired /'retired'/
Xc
Xc get local time
Xc
X call cal_$decode_local_time (decoded_clock)
Xc
Xc open database
Xc
X inquire(file='strek_info',exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=1,file='strek_info',access ='direct',form =
X & 'unformatted', status='old',recl=1000)
Xc
Xc print out header
Xc
X print*,' '
X print*,' '
X write (*,100) (decoded_clock(i),i=1,3)
X100 format ('STAR TREK Ship Registry as of ',i4,'/',i2,'/',i2)
X print*,' '
X print*,' SHIP NAME LAST SCORE AVAILABLE
X &SCORE'
X print*,' '
X read (1,rec=1) num_lines
X do 10 j=2,num_lines+1
X read (1,rec=j) ship_name, capt_name, nick_name, key_file,
X & (ship_avail(i), i=1,3), last_score,
X & cum_score, ship_retired
X if (ship_retired.eq.1) then
X write (*,120) ship_name, last_score, retired, cum_score
X else
X write (*,130) ship_name, last_score, (ship_avail(i), i=1,3),
X & cum_score
X end if
X 10 continue
X120 format (1x,a30,x,i10,5x,a7,i10)
X130 format (1x,a30,x,i10,2x,i4,'/',i2,'/',i2,i10)
X print*,' '
X print*,' '
X close(1)
X return
X end
X
X
X
X
X
X subroutine strek_scores
Xc
Xc STREK_SCORES prints out the list of top scores currently
Xc in STREK_TOP_SCORES.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/cal.ins.ftn'
X% include '/sys/ins/time.ins.ftn'
X integer*2 decoded_clock(6)
X integer*4 top_scores
X logical fyn
X character capt_name*10, ship_name*30
Xc
Xc get local time
Xc
X call cal_$decode_local_time (decoded_clock)
Xc
Xc open up top scores file and read
Xc
X inquire(file='strek_top_scores', exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=2,file='strek_top_scores' ,status='old',recl=1000)
Xc
Xc print out header
Xc
X print*,' '
X write (*,100) (decoded_clock(i),i=1,3)
X100 format (' Top 10 STAR TREK Scores as of ',i4,'/',i2,'/',i2)
X print*,' '
X print*,' CAPTAIN SHIP NAME SCORE'
X print*,' '
X do 10 j=1,10
X read (2,110) capt_name, ship_name, top_scores
X write (*,120) j, capt_name, ship_name, top_scores
X 10 continue
X print*,' '
X print*,' '
X110 format(a10,a30,i10)
X120 format(i2,'.',2x,a10,x,a30,i10)
X close(2)
X return
X end
X
X
X
X
X
X subroutine strek_damage_date (damage_days, ship_avail)
Xc
Xc STREK_DAMAGE_DATE computes the ship availability date
Xc given the damage repair time in whole days. This is
Xc used after a game but before updating STREK_INFO via
Xc STREK_WRITE. Note that damage date can't exceed 1 year
Xc and is not adjusted for leap years encountered when
Xc damage occurs in a non-leap year.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/cal.ins.ftn'
X% include '/sys/ins/time.ins.ftn'
Xc
X integer*2 decoded_clock(6)
X integer*4 ship_avail(3), damage_days, days(12)
Xc
Xc days in months data
Xc
X data days/31,28,31,30,31,30,31,31,30,31,30,31/
Xc
Xc get local time
Xc
X call cal_$decode_local_time (decoded_clock)
Xc
Xc if a leap year change days(2)
Xc
X ichk = mod(decoded_clock(1),4)
X if (ichk.eq.0) then
X days(2) = 29
X ichk1 = mod(decoded_clock(1),100)
X ichk2 = mod(decoded_clock(1),400)
X if (ichk1.eq.0) then
X if (ichk2.eq.0) then
X days(2) = 29
X else
X days(2) = 28
X end if
X end if
X end if
Xc
Xc add damage days to local time
Xc
X iday = damage_days + decoded_clock(3)
X imonth = decoded_clock(2)
X if (iday.gt.days(imonth)) then
X iday = iday - days(imonth)
X imonth = decoded_clock(2) + 1
X end if
X if (imonth.le.12) then
X iyear = decoded_clock(1)
X else
X iyear = decoded_clock(1) + 1
X imonth = imonth - 12
X end if
Xc
Xc load ship availability date
Xc
X ship_avail(1) = iyear
X ship_avail(2) = imonth
X ship_avail(3) = iday
X return
X end
X
X
X
X
X
X
X subroutine strek_startup (capt_name, nick_name, ship_name,
X & last_score, cum_score, key_file, new)
Xc
Xc STREK_STARTUP initializes the strek system. The order
Xc of calls is:
Xc
Xc STREK_QUESTION - get captain info and ship name,
Xc
Xc STREK_REVIEW - if ship is old get it's stats.
Xc
Xc options: STREK_SHIPS - review the current ship registry,
Xc and STREK_SCORES - review the top 10 scores.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X integer*4 ship_avail(3), last_score, cum_score, status
X logical ship_active, open, new, avail
X character capt_name*10, nick_name*10, ship_name*30, answer*1
X character*256 key_file
Xc
Xc STREK is open so question the captain
Xc
X call strek_question (capt_name, nick_name, ship_name,
X & key_file, new)
Xc
Xc if this is a new ship or captain set up scores
Xc
X if (new) then
X cum_score = 0
X last_score = 0
X else
Xc
Xc this is an old ship, check her status in the registry
Xc
X call strek_review (ship_name, capt_name, nick_name, ship_avail,
X & cum_score, last_score, ship_active, key_file,
X & status)
X if (status.eq.1) then
X print*,'STREK_INFO doesn''t exist, execution stops!'
X print*,'Run STREK_STARTUP_DB to initialize the database.'
X print*,' '
X stop
X end if
X end if
Xc
Xc review the registry or scores?
Xc
X 10 continue
X print*,'Enter <r> to view the ship registry,'
X print*,' <s> to view the top ten scores or'
X print*,' <return> to start.'
X print*,' '
X read (*,'(a)') answer
X if (answer.eq.'r') then
X call strek_ships
X goto 10
X else if (answer.eq.'s') then
X call strek_scores
X goto 10
X else
X print*,' '
X end if
X return
X end
X
X
X
X
X
X subroutine strek_ship_avail (ship_avail, avail)
Xc
Xc STREK_SHIP_AVAIL decodes the ship available time from
Xc STREK_INFO and decides if the ship is ready or not.
Xc Dead ships are flagged in STREK_INFO and needn't
Xc be processed herein.
Xc
Xc If (avail) then the ship is available.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/time.ins.ftn'
X% include '/sys/ins/cal.ins.ftn'
Xc
X integer*2 decoded_clock(6)
X integer*4 ship_avail(3)
X logical avail
Xc
Xc get local time
Xc
X call cal_$decode_local_time (decoded_clock)
Xc
Xc compare dates and see if ship is ready
Xc
X if (ship_avail(1).gt.decoded_clock(1)) then
X avail = .false.
X return
X else if (ship_avail(1).lt.decoded_clock(1)) then
X avail = .true.
X return
X else if (ship_avail(2).gt.decoded_clock(2)) then
X avail = .false.
X return
X else if (ship_avail(2).lt.decoded_clock(2)) then
X avail = .true.
X return
X else if (ship_avail(3).gt.decoded_clock(3)) then
X avail = .false.
X return
X else
X avail = .true.
X end if
X return
X end
X
X
X
X
X subroutine strek_dock (d_pct, score, capt_name, nick_name,
X & ship_name, cum_score, key_file, new_ship)
Xc
Xc STREK_DOCK updates the STREK database after docking
Xc
Xc version 1
Xc -jsr 8/85
Xc
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/cal.ins.ftn'
X% include '/sys/ins/gpr.ins.ftn'
X% include '/sys/ins/time.ins.ftn'
Xc
X integer*2 clock(3)
X integer*4 score, cum_score, days, ship_avail(3), status
X integer*4 seconds
X real*4 d_pct(6), time(6), damage
X character*80 message(3)
X character capt_name*10, nick_name*10, ship_name*30, key_file*256
X logical new_ship, active, top_ten
X data time /1.25, 1.25, .75, 0.5, .75, 0.5/
X data active /.true./
X data seconds /2/
Xc
Xc do house keeping
Xc
X cum_score = cum_score + score
X call cal_$sec_to_clock (seconds, clock)
Xc
Xc add up damage times
Xc
X damage = 0.5
X do 10 j = 1,6
X damage = damage + (1.00 - d_pct(j))*time(j)
X 10 continue
X days = nint(damage)
X call strek_damage_date (days, ship_avail)
Xc
Xc write update info to STREK_INFO
Xc
X call strek_write (new_ship, ship_name, capt_name, nick_name,
X & key_file, ship_avail, score, cum_score,
X & active, top_ten)
Xc
Xc write messages to screen
Xc
X message(1) = ' '
X message(2) = 'Awaiting permission to dock.'
X message(3) = ' '
X call strek_message (message, 3)
X call time_$wait (time_$relative, clock, status)
X message(2) = 'Docking completed, good going captain. '
X call strek_message (message, 3)
X call time_$wait (time_$relative, clock, status)
Xc
Xc terminate graphics
Xc
X call gpr_$terminate (.true., status)
X print*,' '
X if (ship_name.ne.' ') then
X write (*,100) (ship_avail(i), i=1,3)
X end if
X100 format(' Your ship will be ready on ',i4,'/',i2,'/',i2)
X print*,' '
X print*,'Score for this mission: ',score
X print*,'Cumulative score: ',cum_score
X print*,' '
X if (top_ten) then
X call strek_scores
X print*,' '
X print*,'Congratulations! Your score places you in the Top 10.'
X print*,' '
X end if
X return
X end
X
X
X
X
X
X subroutine strek_no_energy (num_times, capt_name, nick_name,
X & ship_name, key_file, score,
X & cum_score, new)
Xc
Xc STREK_NO_ENERGY advises the captain to cut energy use. Messages
Xc become more and more urgent as the number of turns w/o energy
Xc increases. After 150 turns the ship is retired and the database
Xc updated.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/cal.ins.ftn'
X% include '/sys/ins/gpr.ins.ftn'
X% include '/sys/ins/time.ins.ftn'
Xc
X integer*2 clock(3)
X integer*4 num_times, score, cum_score, status, ship_avail(3)
X integer*4 seconds
X character capt_name*10, nick_name*10, ship_name*30, key_file*256
X character*80 message_1(3), message_2(3), message_3(3), blank(3)
X logical top_ten, new
X save message_1, message_2, message_3, seconds, ship_avail
X data seconds, ship_avail /5, 3*0/
Xc
Xc data for message strings
Xc
X data message_1 /'Message from engineering:',
X & 'Sir, the battery reserves are critically low.',
X & 'Non-vital subsystems being dropped.'/
X data message_2 /'Message from engineering:',
X & 'Main system shutdown occuring on all decks.',
X & 'Life-support system is in danger of failure.'/
X data message_3 /'Message from engineering:',
X & 'Life-support system is down, oxygen content is dr
X &opping.',
X & 'Main system shutdown complete.'/
X if (num_times.eq.1) then
X call strek_message (message_1, 3)
X else if (num_times.eq.50) then
X call strek_message (message_2, 3)
X else if (num_times.eq.100) then
X call strek_message (message_3, 3)
X else if (num_times.eq.150) then
X blank(1) = 'Message from chief engineer Scotty:'
X blank(2) = 'Sir, aye can''t hold on much longah.'
X write (blank(3),'(a30, a10)') 'It looks like the game''s over ',
X & nick_name
X call strek_message (blank, 3)
Xc
Xc do house keeping
Xc
X cum_score = cum_score + score
X call cal_$sec_to_clock (seconds, clock)
X call strek_write (new, ship_name, capt_name, nick_name,
X & key_file, ship_avail, score, cum_score,
X & .false., top_ten)
X call time_$wait (time_$relative, clock, status)
Xc
Xc terminate graphics
Xc
X call gpr_$terminate (.true., status)
X print*,' '
X print*,'Score for this mission: ',score
X print*,'Cumulative score: ',cum_score
X print*,' '
X if (top_ten) then
X call strek_scores
X print*,' '
X print*,'Congratulations! Your score places you in the Top 10.'
X print*,'A rather hollow victory I would think.'
X print*,' '
X end if
X print*,' '
X if (ship_name.ne.' ') then
X print*,'Your ship, the ',ship_name
X print*,'was decommissioned after being found by Federation sco
X &uts.'
X print*,' '
X end if
X stop
X end if
X return
X end
X
X
X
X
X
X
X
X subroutine strek_search_name (capt_name, ship_name, key_file, new)
Xc
Xc STREK_SEARCH_NAME searches for the names of ships for a certain
Xc captain. To fly a certain ship he need only type the number
Xc associated with it.
Xc
Xc 4/86 -jsr
Xc
X integer num_lines, ship_avail(3), last_score, cum_score
X integer ship_retired, count
X logical new, avail, ready(10)
X character capt_name*10, nick_name*10, ship_name*30
X character key_file*256, temp1*30, temp2*10, practice*30
X character ships(10)*30, nick(10)*10, key(10)*256
Xc
Xc open the info file and read off all ship names
Xc
X open (unit=1,file='strek_info',access = 'direct',form =
X & 'unformatted', status='old',recl=1000)
Xc
Xc read number of lines
Xc
X read(1, rec=1) num_lines
X count = 2
X do 10 i = 2, num_lines + 1
X read(1,rec = i) temp1, temp2
X if (temp2.eq.capt_name) then
X read(1,rec=i) ships(count), temp2, nick(count), key(count),
X & (ship_avail(j),j=1,3), last_score, cum_score, ship_retired
X call strek_ship_avail (ship_avail, avail)
X if (avail) then
X ready(count) = .true.
X else
X ready(count) = .false.
X end if
X count = count + 1
X end if
X 10 continue
X close(1)
X count = count - 1
X practice = 'practice flight'
X ships(1) = 'initiate new ship'
X ready(1) = .true.
X print*,' '
X print*,'Ships available:'
X print*,' '
X write(*, 100) 0, practice
X do 20 i = 1, count
X if (ready(i)) then
X write(*, 100) i, ships(i)
X end if
X 20 continue
X 30 continue
X100 format (x, i1, '. ', a30)
X print*,' '
X print*,'Enter the number of the ship you wish to fly.'
X print*,' '
X read*,number
X if (number .eq. 1) then
X print*,' '
X print*,'What do you want to call your ship sir?'
X read(*,'(a)') ship_name
X new = .true.
X else if (number .gt. 1 .and. ready(number)) then
X new = .false.
X ship_name = ships(number)
X nick_name = nick(number)
X key_file = key(number)
X else if (number .eq. 0) then
X new = .true.
X ship_name = ' '
X else
X goto 30
X end if
X return
X end
E!O!F! xstrek/original_code/strek_db_subs.f
echo xstrek/original_code/strek_enemy_subs.f 1>&2
sed -e 's/^X//' > xstrek/original_code/strek_enemy_subs.f <<'E!O!F! xstrek/original_code/strek_enemy_subs.f'
X subroutine strek_find_free_ob (object, first, free_ob, found)
Xc
Xc
Xc *******************************************************************
Xc ***** *****
Xc ***** STAR TREK VERSION 3.0 *****
Xc ***** *****
Xc ***** written by *****
Xc ***** *****
Xc ***** Justin S. Revenaugh *****
Xc ***** *****
Xc ***** 7/87 *****
Xc ***** *****
Xc ***** Massachussetts Institute of Technology *****
Xc ***** Department of Earth, Atmospheric and Planetary Science *****
Xc ***** *****
Xc *******************************************************************
X
Xc STREK_FIND_FREE_OB finds a free (unused) object number within
Xc the range [first, first+2]. If no such object exists then
Xc found is false. Used for finding free photon objects numbers.
Xc
Xc
X integer*4 first, free_ob
X logical object(0:9), found
Xc
Xc find first free object
Xc
X found = .false.
X if (.not.object(first)) then
X found = .true.
X free_ob = first
X else if (.not.object(first+1)) then
X found = .true.
X free_ob = first + 1
X else if (.not.object(first+2)) then
X found = .true.
X free_ob = first + 2
X end if
X return
X end
X
X
X
X
X
X subroutine strek_place_nemian (xc, yc, zc, obx, oby, obz, oazm,
X & oangle, ospeed, seed)
Xc
Xc STREK_PLACE_NEMIAN places a nubian freighter ship near
Xc the players ship. It will always fall in the distance
Xc range 600 - 1000.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X real*4 xc, yc, zc, obx, oby, obz, ospeed, oazm, oangle
X real*4 seed, radius, theta, phi
X real*4 pi
X save pi
X data pi / 3.14159265/
Xc
Xc find azm and angle totally at random
Xc
X call rand (seed)
X oazm = pi * seed
X call rand (seed)
X oangle = pi * seed
Xc
Xc find displacement using spherical coordinate geometry
Xc
X call rand (seed)
X radius = 400.0 * seed + 600.0
X call rand (seed)
X theta = 2.0 * pi * seed
X call rand (seed)
X phi = pi * seed
X sp = sin(phi)
X obx = radius * cos(theta) * sp + xc
X oby = radius * sin(theta) * sp + yc
X obz = radius * cos(phi) + zc
Xc
Xc pick a speed at random
Xc
X call rand (seed)
X ospeed = 0.25 + seed * 0.15
X return
X end
X
X
X
X
X
X subroutine strek_place_enemy (xc, yc, zc, obx, oby, obz, oazm,
X & oangle, ospeed, seed)
Xc
Xc STREK_PLACE_ENEMY places a single enemy ship in the vicinity of
Xc the player ship. Initial azm and angle are random.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X real*4 xc, yc, zc, obx, oby, obz, oazm, oangle, ospeed
X real*4 seed, radius, theta, phi, pi
X save pi
X data pi / 3.14159265/
Xc
Xc find displacement
Xc
X call rand (seed)
X radius = 600.0 * seed + 1000.0
X call rand (seed)
X theta = 2.0 * pi * seed
X call rand (seed)
X phi = pi * seed
X sp = sin(phi)
X obx = radius * cos(theta) * sp + xc
X oby = radius * sin(theta) * sp + yc
X obz = radius * cos(phi) + zc
X call rand (seed)
X oazm = 2.0 * pi * seed
X call rand (seed)
X oangle = pi * seed
X call rand (seed)
X ospeed = 3.5 * seed
X return
X end
X
X
X
X
X
X
X subroutine strek_enemy_setup (damage, agr, kling, maxd, object,
X & seed, two, photons)
Xc
Xc STREK_ENEMY_SETUP initializes many of the enemy ship variables
Xc Ensures that there is only one klingon at a time.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X integer*4 photons(3)
X real*4 damage(0:9), maxd(9), seed
X logical object(0:9), kling(3), agr(3), two
Xc
Xc set 'em up
Xc
X i = 2
X j = 3
Xc
Xc set initial damage to zero
Xc
X damage(i) = 0.0
X damage(j) = 0.0
X photons(i) = 3
X photons(j) = 3
Xc
Xc pick aggression level. Aggressive enemies come after the player
Xc ship. Unaggressive enemies shoot nemians
Xc
X agr(i) = .true.
X agr(j) = .true.
X call rand (seed)
X if (seed.gt.0.90) agr(i) = .false.
X call rand (seed)
X if (seed.gt.0.90) agr(j) = .false.
X call rand (seed)
Xc
Xc check for klingons
Xc
X call rand (seed)
X if (seed.ge.0.5) then
X kling(i) = .true.
X maxd(i) = 50.0
X else
X kling(i) = .false.
X kling(j) = .false.
X maxd(i) = 40.0
X maxd(j) = 40.0
X end if
Xc
Xc determine the number of 'em
Xc
X call rand (seed)
X if (seed.gt.0.5) then
X two = .true.
X object(i) = .true.
X object(j) = .true.
X else
X two = .false.
X object(i) = .true.
X object(j) = .false.
X end if
X if (kling(i)) then
X two = .false.
X object(j) = .false.
X end if
X return
X end
X
X
X
X
X
X subroutine strek_move_enemy (j, obx, oby, obz, oazm, oangle,
X & ospeed, xc, yc, zc, azm, angle,
X & speed, agr, object, rox, roy, roz,
X & odamage, photons, distance, kling,
X & count_m, count_s, orange, razm,
X & rangle, brake, damage, photon_c,
X & phase_c, pro_x, pro_y, seed, pcen)
Xc
Xc STREK_MOVE_ENEMY contains the enemy ship movement and attack
Xc logic. When chasing nemians (which is rare) there is only a
Xc chase algorithm. When chasing player ships there are two
Xc modes: 1. similar to chasing nemians, used when not in ships
Xc firing arc or at a distance. 2. randomly choosen dodges which
Xc can be: stop fast, accelerate, turn hard or a combination.
Xc Movement is recalculated every 10 turn. Attacks are based on
Xc range and the same firing limitations as the player ship, i.e.
Xc target in firing arc, in range and phasers active. Photons
Xc follow the course of the ship when shot.
Xc
Xc version 1
Xc - jsr 8/85
Xc
X integer*2 pcen(2)
X integer*4 photons, j, count_m, count_s, free, photon_c(6)
X integer*4 phase_c
X real*4 obx(0:9), oby(0:9), obz(0:9), oangle(0:9), oazm(0:9)
X real*4 ospeed(0:9), xc, yc, zc, azm, angle, speed, rox, pi
X real*4 roy, roz, odamage(0:9), distance(3,0:9), orange(0:9)
X real*4 pro_x(0:9), pro_y(0:9)
X logical kling, agr, object(0:9), man_1, man_2, found, shoot
X logical man_3
X save pi
X data pi /3.14159265/
X ra(x) = x * pi / 180.0
Xc
Xc increment move and shoot counters
Xc
X count_m = count_m + 1
X count_s = count_s + 1
Xc
Xc if a move is indicated then do it
Xc
X if (count_m.ge.10) then
X count_m = 0
X if ((.not.agr).and.(orange(j).gt.90000.0)) then
Xc
Xc chase the nemian unless the bad guy is too close
Xc
X if (abs(ospeed(j)).gt.1.e-3) then
X num_forward = sqrt(distance(j,1))/ospeed(j)
X else
X num_forward = 20
X end if
X xt = - num_forward * ospeed(1) * sin(oazm(1)) * cos(oangle(1))
X & + obx(1)
X yt = num_forward * ospeed(1) * cos(oazm(1)) * cos(oangle(1))
X & + oby(1)
X zt = num_forward * ospeed(1) * sin(oangle(1)) + obz(1)
X dx = xt - obx(j)
X dy = yt - oby(j)
X dz = zt - obz(j)
X if (abs(dy).lt.1.e-7) dy = sign(1.e-7, dy)
X if (dy.le.0.0) then
X tazm = - atan(dx/dy) + ra(180.0)
X else
X tazm = - atan(dx/dy)
X end if
X dist = sqrt(dx**2 + dy**2)
X if (abs(dist).lt.1.e-7) dist = sign(1.e-7, dist)
X tangle = atan(dz/dist)
X t1 = (tazm - oazm(j))/10.0
X t2 = (tangle - oangle(j))/10.0
X t3 = (tazm - (oazm(j) - 360.0))/10.0
X t4 = (tangle - (oangle(j) - 360.0))/10.0
X if (abs(t3).lt.abs(t1)) t1 = t3
X if (abs(t4).lt.abs(t2)) t2 = t4
X if (abs(t1).gt.0.05) t1 = sign(.05, t1)
X if (abs(t2).gt.0.05) t2 = sign(.05, t2)
X razm = t1
X rangle = t2
Xc
Xc adjust speed
Xc
X if (distance(j,1).gt.3600.0) then
X brake = (3.5 - ospeed(j))/10.0
X else
X brake = (ospeed(1) - ospeed(j) + 0.5)/10.0
X end if
Xc
Xc adjust max acceleration
Xc
X t1 = abs(brake)
X if (t1.gt.0.5) brake = sign (0.5, brake)
X else
Xc
Xc chase the bad guy. Two options here:
Xc 1. in his front arc => get out of it!
Xc 2. in his rear arc => stay in it but approach.
Xc
X t1 = sqrt(rox**2 + roz**2)
X t2 = t1 / roy
X if ((((roy.gt.0.0).and.(roy.lt.300.0)).and.(t2.lt.0.75)).or.
X & (((roy.gt.0.0).and.(roy.lt.820.0)).and.(t2.lt.0.18))) then
X call rand (seed)
Xc
Xc if seed < .10 then brake hard, .10 < seed < .25 then swerve
Xc if .25 < seed < .50 then do both, .40 < seed < .60 then accel
Xc else actively pursue.
Xc
X if (seed.lt.0.10) then
X man_1 = .true.
X man_2 = .false.
X man_3 = .false.
X else if ((seed.lt.0.30).and.(seed.ge.0.10)) then
X man_1 = .false.
X man_2 = .true.
X man_3 = .false.
X else if ((seed.lt.0.50).and.(seed.ge.0.30)) then
X man_1 = .true.
X man_2 = .true.
X man_3 = .false.
X else if ((seed.lt.0.60).and.(seed.ge.0.50)) then
X man_1 = .false.
X man_2 = .false.
X man_3 = .true.
X else if (t2.gt.0.33) then
X goto 10
X else
X man_1 = .true.
X man_2 = .true.
X man_3 = .false.
X end if
X if (man_1.and.((speed.gt.3.5).and.(roy.lt.75.0))) then
X brake = (0.0 - ospeed(j))/10.0
X end if
X if (man_2) then
Xc
Xc get polarity of the swerve
Xc
X call rand (seed)
X razm = 0.0
X rangle = 0.0
X if (seed.lt.0.25) then
X razm = ra(-3.5)
X else if ((seed.ge.0.25).and.(seed.lt.0.5)) then
X razm = ra(3.5)
X else if ((seed.ge.0.5).and.(seed.lt.0.75)) then
X rangle = ra(-3.5)
X else
X rangle = ra(3.5)
X end if
X end if
Xc
Xc if man_3 then accelerate
Xc
X if (man_3) then
X brake = (3.5 - ospeed(j))/10.0
X end if
X else
X 10 continue
Xc
Xc in rear arc then pursue
Xc
X rootor = sqrt(orange(j))
X num_forward = sqrt(orange(j)) / 20.0
X if (num_forward .gt. 20) num_forward = 20
X xt = - num_forward * speed * sin(ra(azm)) * cos(ra(angle))
X & + xc
X yt = num_forward * speed * cos(ra(azm)) * cos(ra(angle))
X & + yc
X zt = num_forward * speed * sin(ra(angle)) + zc
X dx = xt - obx(j)
X dy = yt - oby(j)
X dz = zt - obz(j)
X if (abs(dy).lt.1.e-7) dy = sign(1.e-7, dy)
X if (dy.le.0.0) then
X tazm = - atan(dx/dy) + pi
X else
X tazm = - atan(dx/dy)
X end if
X dist = sqrt(dx**2 + dy**2)
X if (abs(dist).lt.1.e-7) dist = sign(1.e-7, dist)
X tangle = atan(dz/dist)
Xc
Xc pick smallest angle (needed due to arctan being only in quads
Xc I and IV)
Xc
X t1 = (tazm - oazm(j))/10.0
X t2 = (tangle - oangle(j))/10.0
X t3 = (tazm - (oazm(j) - 360.0))/10.0
X t4 = (tangle - (oangle(j) - 360.0))/10.0
X if (abs(t3).lt.abs(t1)) t1 = t3
X if (abs(t4).lt.abs(t2)) t2 = t4
X if (abs(t1).gt.0.1) t1 = sign(.1, t1)
X if (abs(t2).gt.0.1) t2 = sign(.1, t2)
X razm = t1
X rangle = t2
Xc
Xc adjust speed
Xc
X if (distance(j,1).gt.10000.0) then
X brake = (4.00 - ospeed(j))/10.0
X else
X brake = (speed - ospeed(j) + 0.75)/10.0
X end if
Xc
Xc adjust max acceleration
Xc
X t1 = abs(brake)
X if (t1.gt.0.5) brake = sign (0.5, brake)
X end if
X end if
X end if
Xc
Xc formulate attacks
Xc
X if (count_s.ge.20) then
X count_s = 0
Xc
Xc check for photon firing
Xc
X if (kling) then
X if ((photons.gt.0).and.orange(j).lt.102400) then
X call strek_find_free_ob (object, 4, free, found)
X if (found) then
X t1 = ra(azm)
X t2 = ra(angle)
X call strek_aim_photons (xc, yc, zc, t1, t2, speed,
X & obx(j), oby(j), obz(j), oazm(j),
X & oangle(j), shoot)
X call rand (seed)
X if (seed.lt.0.7) then
X if (shoot) then
X object(free) = .true.
X ospeed(free) = 11.0
X obx(free) = obx(j)
X oby(free) = oby(j)
X obz(free) = obz(j)
X oazm(free) = oazm(j)
X oangle(free) = oangle(j)
X odamage(free)= 0.0
X photon_c(free-3) = 0
X photons = photons - 1
X end if
X end if
X end if
X end if
Xc
Xc if ship is a klingon then consider phasers
Xc
X if (phase_c.gt.40.0.and.orange(j).lt.40000.0) then
X xt = xc - obx(j)
X yt = yc - oby(j)
X zt = zc - obz(j)
X ca = cos(oazm(j))
X sa = sin(oazm(j))
X cp = cos(oangle(j))
X sp = sin(oangle(j))
X pox = xt*ca + yt*sa
X poy = -xt*sa*cp + yt*ca*cp + zt*sp
X poz = xt*sa*sp - yt*ca*sp + zt*cp
X if (poy.gt.1.e-7) then
X t1 = pox/poy
X t2 = poz/poy
X if ((t1.lt.1.0).and.(t2.lt.1.0)) then
X call rand (seed)
X if (seed.gt.0.2) then
X call strek_phaser_damage (orange(j), damage, seed,
X & .true.)
X call strek_phaser_ship (pro_x(j), pro_y(j), pcen,
X & seed)
X phase_c = 0
X end if
X end if
X end if
X else if (.not.agr.and.(phase_c.gt.60.0.and.distance(j,1).lt.
X & 10000.0)) then
X xt = obx(1) - obx(j)
X yt = oby(1) - oby(j)
X zt = obz(1) - obz(j)
X ca = cos(oazm(j))
X sa = sin(oazm(j))
X cp = cos(oangle(j))
X sp = sin(oangle(j))
X pox = xt*ca + yt*sa
X poy = -xt*sa*cp + yt*ca*cp + zt*sp
X poz = xt*sa*sp - yt*ca*sp + zt*cp
X if (poy.gt.1.e-7) then
X t1 = pox/poy
X t2 = poz/poy
X if ((t1.lt.1.0).and.(t2.lt.1.0)) then
X call rand (seed)
X if (seed.gt.0.6) then
X call strek_phaser_damage (distance(j,1), odamage(1),
X & seed, .false.)
X call strek_phaser_nemian (pro_x, pro_y)
X phase_c = 0
X end if
X end if
X end if
X end if
X else
Xc
Xc this is a romulan, either photon player or nemian
Xc
X if ((photons.gt.0).and.orange(j).lt.90000) then
X call strek_find_free_ob (object, 4, free, found)
X if (found) then
X t1 = ra(azm)
X t2 = ra(angle)
X call strek_aim_photons (xc, yc, zc, t1, t2, speed,
X & obx(j), oby(j), obz(j), oazm(j),
X & oangle(j), shoot)
X call rand (seed)
X if (seed.lt.0.5) then
X if (shoot) then
X object(free) = .true.
X ospeed(free) = 11.0
X obx(free) = obx(j)
X oby(free) = oby(j)
X obz(free) = obz(j)
X oazm(free) = oazm(j)
X oangle(free) = oangle(j)
X odamage(free)= 0.0
X photon_c(free-3) = 0
X end if
X end if
X end if
X else if (distance(j,1).lt.40000.0) then
X call strek_find_free_ob (object, 4, free, found)
X if (found) then
X call strek_aim_photons (obx(1), oby(1), obz(1), oazm(1),
X & oangle(1), ospeed(1), obx(j),
X & oby(j), obz(j), oazm(j),
X & oangle(j), shoot)
X call rand (seed)
X if (seed.lt.0.4) then
X if (shoot) then
X object(free) = .true.
X ospeed(free) = 11.0
X obx(free) = obx(j)
X oby(free) = oby(j)
X obz(free) = obz(j)
X oazm(free) = oazm(j)
X oangle(free) = oangle(j)
X odamage(free)= 0.0
X photon_c(free-3) = 0
X end if
X end if
X end if
X end if
X end if
X end if
Xc
Xc adjust angles and stuff
Xc
X ospeed(j) = ospeed(j) + brake
X if (ospeed(j).gt.4.00) ospeed(j) = 4.00
X if (ospeed(j).lt.0.0) ospeed(j) = 0.1
X oazm(j) = oazm(j) + razm
X oangle(j) = oangle(j) + rangle
X phase_c = phase_c + 1
X return
X end
X
X
X
X
X subroutine strek_aim_photons (xc, yc, zc, azm, angle, speed, obx,
X & oby, obz, oazm, oangle, shoot)
Xc
Xc STREK_AIM_PHOTONS projects the enemy photons, shoot is true if
Xc the projection falls within 40 units of the projected player
Xc ship. Photons do not inherit the parents ship's velocity.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X real*4 xc, yc, zc, azm, angle, speed, obx, oby, obz, oazm, oangle
X real*4 pi, a, b, c, oa, ob, oc
X logical shoot
Xc
Xc figure all pertinent angles (note that ship angles are converted
Xc to radians in STREK_MOVE_ENEMY).
Xc
X sa = sin(azm)
X ca = cos(azm)
X sp = sin(angle)
X cp = cos(angle)
X a = -sa * cp * speed
X b = ca * cp * speed
X c = sp * speed
X sa = sin(oazm)
X ca = cos(oazm)
X sp = sin(oangle)
X cp = cos(oangle)
X ospeed = 11.0
X oa = -sa * cp * ospeed
X ob = ca * cp * ospeed
X oc = sp * ospeed
X da = a - oa
X db = b - ob
X dc = c - oc
X dx = xc - obx
X dy = yc - oby
X dz = zc - obz
Xc
Xc check for an intersection within tolerance (which is 40**2 in
Xc an all out attempt not to do sqrt's)
Xc
X tol = 30.0**2
X shoot = .false.
X j = 1
X 10 continue
X if (j.gt.50) return
X dist = (j*(da) + dx)**2 + (j*(db) + dy)**2 + (j*(dc) + dz)**2
X if (dist.le.tol) then
X shoot = .true.
X return
X end if
X j = j + 1
X goto 10
X end
X
X
X
X
E!O!F! xstrek/original_code/strek_enemy_subs.f
exit
=====
@work: | Matthias Pfuetzner | @home:
ZGDV, Wilhelminenstrasse 7 | 6100 Darmstadt, FRG | Lichtenbergstrasse 73
+49 6151 155-164 or -101 \ <- Tel.nr. -> / +49 6151 75717
pfuetzner@agd.fhg.de pfuetzner@zgdvda.UUCP XBR1YD3U@DDATHD21.BITNET
--
Dan Heller
------------------------------------------------
O'Reilly && Associates ZipCode Software
Senior Writer President
argv@ora.com argv@zipcode.com