pfuetz@agd.fhg.de (02/26/91)
Submitted-by: pfuetz@agd.fhg.de
Posting-number: Volume 11, Issue 88
Archive-name: xstrek/part02
#!/bin/sh
# To unshare, sh or unshar this file
echo xstrek/f_changed/strek_db_subs.f 1>&2
sed -e 's/^X//' > xstrek/f_changed/strek_db_subs.f <<'E!O!F! xstrek/f_changed/strek_db_subs.f'
X subroutine strek_write (new, ship_name, user_name, capt_name,
X & 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, user_name*10
X character capt_name*10, nick_name*10, temp*30
X character my_tmp(10)*10
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='/usr/lib/X11/xstrek/strek_info',exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=1,file='/usr/lib/X11/xstrek/strek_info',
X & access ='direct',form =
X & 'unformatted', status='old',recl=1000)
X inquire(file='/usr/lib/X11/xstrek/strek_top_scores', exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=2,file='/usr/lib/X11/xstrek/strek_top_scores',
X & status='old',recl=1000,
X & form='formatted')
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, user_name,
X & 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, user_name,
X & 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) my_tmp(j),ctemp(j), stemp(j), top_scores(j)
X 30 continue
X rewind(2)
X110 format(a10,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 my_tmp(k) = my_tmp(k+1)
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) my_tmp(j),ctemp(j), stemp(j), top_scores(j)
X 80 continue
X write (2,110) user_name,capt_name, ship_name, cum_score
X do 90 j = i,9
X write (2,110) my_tmp(j),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, user_name,
X & 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, user_name*10
X character 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='/usr/lib/X11/xstrek/strek_info',exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=1,file='/usr/lib/X11/xstrek/strek_info',
X & 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, user_name,
X & 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 (user_name, capt_name,
X & 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 user_name*10
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 = ' '
X call getusername(user_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 (user_name,
X & 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
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/cal.ins.ftn'
Xc % 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, user_name*10
X character 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 caldecodelocaltime (decoded_clock)
Xc
Xc open database
Xc
X inquire(file='/usr/lib/X11/xstrek/strek_info',exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=1,file='/usr/lib/X11/xstrek/strek_info',
X & 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, user_name,
X & 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
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/cal.ins.ftn'
Xc % include '/sys/ins/time.ins.ftn'
X integer*2 decoded_clock(6)
X integer*4 top_scores
X logical fyn
X character dummy1*34, dummy2*34
X character user_name*10, capt_name*10, ship_name*30
X save dummy1
X save dummy2
X data dummy1 /' User CAPTAIN SHIP NA'/
X data dummy2 /'ME SCORE'/
Xc
Xc get local time
Xc
X call caldecodelocaltime (decoded_clock)
Xc
Xc open up top scores file and read
Xc
X inquire(file='/usr/lib/X11/xstrek/strek_top_scores', exist=fyn)
X if (.not.fyn) then
X status = 1
X return
X end if
X open (unit=2,file='/usr/lib/X11/xstrek/strek_top_scores',
X & status='old',recl=1000,
X & form='formatted')
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 write (*,130) dummy1, dummy2
X print*,' '
X do 10 j=1,10
X read (2,110) user_name, capt_name, ship_name, top_scores
X write (*,120) j, user_name, capt_name, ship_name, top_scores
X 10 continue
Xc print*,' '
X write (*,'(a1)') ' '
Xc print*,' '
X write (*,'(a1)') ' '
X110 format(a10,a10,a30,i10)
X120 format(i2,'.',2x,a10,x,a10,x,a30,x,i10)
X130 format(a34,a34)
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
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/cal.ins.ftn'
Xc % 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 caldecodelocaltime (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 (user_name,
X & 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 user_name*10
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 (user_name,
X & 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, user_name,
X & 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 XSTREK_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
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/time.ins.ftn'
Xc % 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 caldecodelocaltime (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, user_name,
X & 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
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/cal.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc % 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 user_name*10
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 calsectoclock (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, user_name,
X & 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 timewait (timerelative, clock, status)
X message(2) = 'Docking completed, good going captain. '
X call strek_message (message, 3)
X call timewait (timerelative, clock, status)
Xc
Xc terminate graphics
Xc
X call gprterminate (.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, user_name,
X & 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
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/cal.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc % 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 user_name*10
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 calsectoclock (seconds, clock)
X call strek_write (new, ship_name, user_name,
X & capt_name, nick_name,
X & key_file, ship_avail, score, cum_score,
X & .false., top_ten)
X call timewait (timerelative, clock, status)
Xc
Xc terminate graphics
Xc
X call gprterminate (.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 (user_name,
X & 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 user_name*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 temp3*10
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='/usr/lib/X11/xstrek/strek_info',
X & 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, temp3, temp2
X if ((temp2.eq.capt_name).and.(temp3.eq.user_name)) then
X read(1,rec=i) ships(count), temp3,
X & 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/f_changed/strek_db_subs.f
echo xstrek/f_changed/strek_graphics_subs.f 1>&2
sed -e 's/^X//' > xstrek/f_changed/strek_graphics_subs.f <<'E!O!F! xstrek/f_changed/strek_graphics_subs.f'
X subroutine strek_screen_init (bitmap_desc, font_3, font_4)
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_SCREEN_INIT sets up the static display panels for
Xc STREK. Used prior to any other graphics calls.
Xc
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 config, size(2)
X integer*4 font_1, font_2, font_3, font_4
X integer*2 window(2,2), xpt, ypt, pt1(2), radius
X integer*4 status, bitmap_desc, value(2)
X character text*30
Xc
Xc data for screen panels
Xc
X data size /1024, 1024/
X data value /0, 16777215/
Xc
Xc init screen in borrow mode (1024x1024)
Xc
X call gprinqconfig (config, status)
Xc
X call gprinit (gprborrow, 1, size, 0,
X & bitmap_desc, status)
X if (status.ne.0) then
Xc call errorprint (status)
X stop
X end if
Xc
X if (config.eq.gprcolor1024x1024x4.or.
X & config.eq.gprcolor1024x1024x8.or.
X & config.eq.gprcolor1024x800x4.or.
X & config.eq.gprcolor1024x800x8) then
X call gprsetcolormap (0, 2, value, status)
X end if
Xc
Xc load all fonts needed
Xc
X call gprloadfontfile ('/sys/dm/fonts/nonie.r.8',23,
X & font_1,status)
X call gprloadfontfile ('/sys/dm/fonts/scvc8x16.i.r',26,
X & font_2,status)
X call gprloadfontfile ('/sys/dm/fonts/scvc5x10.r.b',26,
X & font_3,status)
X call gprloadfontfile ('/sys/dm/fonts/f5x9',18,
X & font_4,status)
X call gprsettextpath (gprright,status)
Xc call gprsettextbackgroundvalue (-1,status)
X call gprsettextbackgroundvalue (1,status)
Xc
Xc set values for draws and fills
Xc
X call gprsetdrawvalue (1,status)
X call gprsetfillvalue (1,status)
Xc
Xc fill in rectangular border
Xc
X window(1,1) = 0
X window(2,1) = 0
X window(1,2) = 900
X window(2,2) = 800
X call gprrectangle (window,status)
X call gprsetfillvalue (0,status)
X window(1,1) = 100
X window(2,1) = 100
X window(1,2) = 700
X window(2,2) = 600
X call gprrectangle (window,status)
X window(1,1) = 100
X window(2,1) = 710
X window(1,2) = 700
X window(2,2) = 80
X call gprrectangle (window,status)
X call gprsetfillvalue (1,status)
Xc
Xc put in text on all static panels
Xc
Xc call gprsetclippingactive (.true.,status)
X xpt = 15
X ypt = 25
X call gprsettextfont (font_2,status)
X call gprsettextvalue (0,status)
X call gprmove (xpt,ypt,status)
X text = 'Star Trek Version 3.0'
X call gprtext (text,21,status)
X call gprsettextfont (font_1,status)
X xpt = 10
X ypt = 150
X call gprmove (xpt,ypt,status)
X text = 'Speed'
X call gprtext (text,5,status)
X xpt = 10
X ypt = 250
X call gprmove (xpt,ypt,status)
X text = 'Energy'
X call gprtext (text,6,status)
X xpt = 10
X ypt = 350
X call gprmove (xpt,ypt,status)
X text = 'Photons'
X call gprtext (text,7,status)
X xpt = 10
X ypt = 450
X call gprmove (xpt,ypt,status)
X text = 'Phasers'
X call gprtext (text,7,status)
X xpt = 10
X ypt = 550
X call gprmove (xpt,ypt,status)
X text = 'Tractor'
X call gprtext (text,7,status)
X xpt = 17
X ypt = 755
X call gprmove (xpt,ypt,status)
X text = 'Com:'
X call gprtext (text,4,status)
X xpt = 110
X ypt = 75
X call gprmove (xpt,ypt,status)
X text = 'X-Coor:'
X call gprtext (text,7,status)
X xpt = 310
X ypt = 75
X call gprmove (xpt,ypt,status)
X text = 'Y-Coor:'
X call gprtext (text,7,status)
X xpt = 510
X ypt = 75
X call gprmove (xpt,ypt,status)
X text = 'Z-Coor:'
X call gprtext (text,7,status)
X xpt = 810
X ypt = 125
X call gprmove (xpt,ypt,status)
X text = 'Scanner'
X call gprtext (text,7,status)
X xpt = 810
X ypt = 200
X call gprmove (xpt,ypt,status)
X text = 'X-Coor:'
X call gprtext (text,7,status)
X xpt = 810
X ypt = 275
X call gprmove (xpt,ypt,status)
X text = 'Y-Coor:'
X call gprtext (text,7,status)
X xpt = 810
X ypt = 350
X call gprmove (xpt,ypt,status)
X text = 'Z-Coor:'
X call gprtext (text,7,status)
X xpt = 810
X ypt = 425
X call gprmove (xpt,ypt,status)
X text = 'Range:'
X call gprtext (text,6,status)
Xc
Xc insert scanner windows
Xc
X call gprsetfillvalue (0,status)
X pt1(1) = 850
X pt1(2) = 540
X radius = 45
X call gprcirclefilled (pt1, radius, status)
X pt1(2) = 650
X call gprcirclefilled (pt1, radius, status)
X call gprsettextfont (font_4,status)
X xpt = 708
X ypt = 33
X call gprmove (xpt,ypt,status)
X text = 'Enemy 1'
X call gprtext (text,7,status)
X xpt = 708
X ypt = 73
X call gprmove (xpt,ypt,status)
X text = 'Enemy 2'
X call gprtext (text,7,status)
X xpt = 819
X ypt = 33
X call gprmove (xpt,ypt,status)
X text = 'Low E'
X call gprtext (text,5,status)
X xpt = 815
X ypt = 73
X call gprmove (xpt,ypt,status)
X text = 'Nav On'
X call gprtext (text,6,status)
X xpt = 810
X ypt = 490
X text = 'X'
X call gprmove (xpt,ypt,status)
X call gprtext (text,1,status)
X xpt = 885
X ypt = 490
X text = 'Y'
X call gprmove (xpt,ypt,status)
X call gprtext (text,1,status)
X xpt = 810
X ypt = 600
X text = 'Z'
X call gprmove (xpt,ypt,status)
X call gprtext (text,1,status)
X xpt = 885
X text = 'Y'
X call gprmove (xpt,ypt,status)
X call gprtext (text,1,status)
X call gprsettextfont (font_2,status)
Xc
Xc put logo in lower right corner
Xc
X window(1,1) = 810
X window(2,1) = 710
X window(1,2) = 80
X window(2,2) = 80
X call gprrectangle (window,status)
X pt1(1) = 850
X pt1(2) = 765
X radius = 18
X call gprcircle (pt1,radius,status)
X pt1(1) = 850
X pt1(2) = 765
X radius = 6
X call gprcircle (pt1,radius,status)
X call gprsetfillvalue (1,status)
X window(1,1) = 832
X window(2,1) = 715
X window(1,2) = 5
X window(2,2) = 30
X call gprrectangle (window,status)
X window(1,1) = 863
X call gprrectangle (window,status)
X window(1,1) = 847
X window(2,1) = 730
X window(1,2) = 6
X window(2,2) = 17
X call gprrectangle (window,status)
Xc
Xc load permanent font
Xc
X call gprsettextfont (font_4, status)
X call gprsettextbackgroundvalue (1, status)
X call gprsetdrawvalue (1, status)
Xc
Xc set clipping window limits
Xc
X window(1,1) = 100
X window(2,1) = 100
X window(1,2) = 700
X window(2,2) = 600
X call gprsetclipwindow (window,status)
X call gprsetclippingactive (.true.,status)
Xc
Xc return to main program
Xc
X return
X end
X
X
X
X
X
X subroutine strek_update_panel (speed, power, photons, phase,
X & tract, xc, yc, zc, scan, txc, tyc,
X & tzc, trange, scan_ob)
Xc
Xc STREK_UPDATE PANEL writes the revised panel data (not com line).
Xc Assumes the proper font and text value are loaded. Font
Xc background shouldn't be transparent. Handles clipping window.
Xc Only certain portions are refreshed each pass (this routine
Xc or GPR text to be more specific is slow).
Xc
Xc version 1
Xc -jsr 8/85
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 x_pt(15), y_pt(15), xpt, ypt, wind_1(2,2)
X integer*4 length
X integer*2 dest_1(2)
X integer*4 speed, photons, xc, yc, zc, txc, tyc, tzc, trange
X integer*4 status, power, azm, angle, scan_ob
X logical phase, tract, scan, absol
X character*7 text, active, down
X save active down, x_pt, y_pt, length, n, absol
Xc
Xc data for move statements
Xc
X data x_pt /10, 10, 10, 20, 20, 200, 400, 600, 820, 810, 810,
X & 810, 810, 770, 770/
X data y_pt /190, 290, 390, 490, 590, 75, 75, 75, 155, 230, 305,
X & 380, 455, 35, 75/
Xc
Xc data for text lines
Xc
X data active, down /' active', ' down'/
X data length, n / 7, 1/
X data wind_1 / 695, 18, 72, 24/
X data dest_1 / 695, 18/
X data absol / .true./
Xc
Xc deactivate clipping window
Xc
X call gprsetclippingactive (.false.,status)
Xc
Xc panel numbers are encoded into text which is then written
Xc
X if (n .eq. 1) then
X write (text,100) speed
X call gprmove (x_pt(1), y_pt(1), status)
X call gprtext (text, length, status)
X write (text,100) power
X call gprmove (x_pt(2), y_pt(2), status)
X call gprtext (text, length, status)
X write (text,100) photons
X call gprmove (x_pt(3), y_pt(3), status)
X call gprtext (text, length, status)
X if (phase) then
X text = active
X else
X text = down
X end if
X call gprmove (x_pt(4), y_pt(4), status)
X call gprtext (text, length, status)
X else if (n.eq.2) then
X if (absol) then
X write (text,100) xc
X call gprmove (x_pt(6), y_pt(6), status)
X call gprtext (text, length, status)
X write (text,100) yc
X call gprmove (x_pt(7), y_pt(7), status)
X call gprtext (text, length, status)
X write (text,100) zc
X call gprmove (x_pt(8), y_pt(8), status)
X call gprtext (text, length, status)
X end if
X absol = .not. absol
X else if (n.eq.3) then
X if (tract) then
X text = active
X else
X text = down
X end if
X call gprmove (x_pt(5), y_pt(5), status)
X call gprtext (text, length, status)
X if (scan) then
X write (text, '(4x, i1)') scan_ob
X else
X text = down
X end if
X call gprmove (x_pt(9), y_pt(9), status)
X call gprtext (text, length, status)
X write (text,100) txc
X call gprmove (x_pt(10), y_pt(10), status)
X call gprtext (text, length, status)
X else
X n = 0
X write (text,100) tyc
X call gprmove (x_pt(11), y_pt(11), status)
X call gprtext (text, length, status)
X write (text,100) tzc
X call gprmove (x_pt(12), y_pt(12), status)
X call gprtext (text, length, status)
X write (text,100) trange
X call gprmove (x_pt(13), y_pt(13), status)
X call gprtext (text, length, status)
X end if
X n = n + 1
Xc
Xc formats
Xc
X100 format (i7)
X110 format (i4)
Xc
Xc reactivate clipping
Xc
X call gprsetclippingactive (.true.,status)
Xc
Xc return to main
Xc
X return
X end
X
X
X
X
X
X
X subroutine strek_flashers (object, lock_on, energy, bitmap_desc)
Xc
Xc STREK_FLASHERS flashes warning lights for ships and
Xc low energy.
Xc
Xc version 1
Xc -jsr
Xc
X integer*2 wind_1(2,2), wind_2(2,2), wind_3(2,2), wind_4(2,2)
X integer*2 dest_1(2), dest_2(2), dest_3(2), dest_4(2)
X integer*2 zero, three, ten
X integer*4 bitmap_desc, status, count
X real energy
X logical object(0:9), lock_on, old(4), low_e
X save old, wind_1, wind_2, wind_3, wind_4, count
X save dest_1, dest_2, dest_3, dest_4, zero, three, ten
X data old / 4 * .false./
X data count / 0/
X data wind_1 / 695, 18, 72, 24/
X data wind_2 / 695, 58, 72, 24/
X data wind_3 / 799, 58, 72, 24/
X data wind_4 / 799, 18, 72, 24/
X data dest_1 / 695, 18/
X data dest_2 / 695, 58/
X data dest_3 / 799, 58/
X data dest_4 / 799, 18/
X data zero, three, ten / 0, 3, 10/
Xc
Xc cycle through the four warning lights, if they need
Xc to be reversed then reverse them, simple huh?
Xc
X count = count + 1
X if (count .gt. 4) then
X count = 0
X if (object(2) .and. (.not. old(1))) then
X call gprsetrasterop (zero, ten, status)
X call gprsetclippingactive (.false.,status)
X call gprbitblt (bitmap_desc, wind_1, zero, dest_1,
X & zero, status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X old(1) = .not. old(1)
X else if ((.not. object(2)) .and. old(1)) then
X call gprsetrasterop (zero, ten, status)
X call gprsetclippingactive (.false.,status)
X call gprbitblt (bitmap_desc, wind_1, zero, dest_1,
X & zero, status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X old(1) = .not. old(1)
X end if
X if (object(3) .and. (.not. old(2))) then
X call gprsetrasterop (zero, ten, status)
X call gprsetclippingactive (.false.,status)
X call gprbitblt (bitmap_desc, wind_2, zero, dest_2,
X & zero, status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X old(2) = .not. old(2)
X else if ((.not. object(3)) .and. old(2)) then
X call gprsetrasterop (zero, ten, status)
X call gprsetclippingactive (.false.,status)
X call gprbitblt (bitmap_desc, wind_2, zero, dest_2,
X & zero, status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X old(2) = .not. old(2)
X end if
X if (lock_on .and. (.not. old(3))) then
X call gprsetrasterop (zero, ten, status)
X call gprsetclippingactive (.false.,status)
X call gprbitblt (bitmap_desc, wind_3, zero, dest_3,
X & zero, status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X old(3) = .not. old(3)
X else if ((.not. lock_on) .and. old(3)) then
X call gprsetrasterop (zero, ten, status)
X call gprsetclippingactive (.false.,status)
X call gprbitblt (bitmap_desc, wind_3, zero, dest_3,
X & zero, status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X old(3) = .not. old(3)
X end if
X low_e = .false.
X if (energy .lt. 50.0) low_e = .true.
X if (low_e .and. (.not. old(4))) then
X call gprsetrasterop (zero, ten, status)
X call gprsetclippingactive (.false.,status)
X call gprbitblt (bitmap_desc, wind_4, zero, dest_4,
X & zero, status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X old(4) = .not. old(4)
X else if ((.not. low_e) .and. old(4)) then
X call gprsetrasterop (zero, ten, status)
X call gprsetclippingactive (.false.,status)
X call gprbitblt (bitmap_desc, wind_4, zero, dest_4,
X & zero, status)
X call gprsetrasterop (zero, three, status)
X call gprsetclippingactive (.true.,status)
X old(4) = .not. old(4)
X end if
X end if
X return
X end
X
X
X
X
X
X
X subroutine strek_x_hairs
Xc
Xc STREK_X_HAIRS draws the cross-hairs at the screen center.
Xc Since these don't move and should superimpose upon other
Xc objects they are redrawn instead of bit blt'ed. Assumes
Xc draw value is 1.
Xc
Xc version 1
Xc -jsr 8/85
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 x_pts(4), y_pts(4)
X integer*4 num_pos
X integer*4 status, count
X save x_pts, y_pts, num_pos, yes
X data x_pts / 440, 460, 460, 440/
X data y_pts / 410, 390, 410, 390/
X data num_pos, count / 4, 1/
Xc
Xc call multiline for cross-hairs
Xc
X if (count .eq. 3) then
X call gprmultiline (x_pts, y_pts, num_pos, status)
X count = 0
X end if
X count = count + 1
X return
X end
X
X
X
X
X
X subroutine strek_message (message, num_lines)
Xc
Xc STREK_MESSAGE prints a message in the com window.
Xc Message is an array of 3 char*80 strings, num_lines is the
Xc number to print on this call (0-3). Zero lines implies
Xc clearing the message block of all current messages.
Xc Handles the clipping window and a text value commands
Xc
Xc version 1
Xc -jsr 8/85
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 window(2,2), x_pt, y_pt(3)
X integer*4 length
X integer*4 num_lines,status
X character*80 message(3)
X save window, x_pt, y_pt, length
Xc
Xc text placement data
Xc
X data window(1,1), window(2,1), window(1,2), window(2,2) /
X & 100, 710, 700, 80/
X data x_pt / 110/
X data y_pt / 730, 750, 770/
X data length / 80/
Xc
Xc deactivate clipping window
Xc
X call gprsetclippingactive (.false.,status)
Xc
Xc if num_lines is zero erase message block
Xc
X if (num_lines.eq.0) then
X call gprsetfillvalue (0,status)
X call gprrectangle (window,status)
X call gprsetfillvalue (1,status)
X call gprsetclippingactive (.true.,status)
X return
X end if
Xc
Xc set text values and write message
Xc
X call gprsettextvalue (1,status)
X call gprsettextbackgroundvalue (0,status)
X do 10 j = 1,num_lines
X call gprmove (x_pt,y_pt(j),status)
X call gprtext (message(j),length,status)
X 10 continue
Xc
Xc reset text values and clipping window
Xc
X call gprsettextvalue (0,status)
X call gprsettextbackgroundvalue (1,status)
X call gprsetclippingactive (.true.,status)
Xc
Xc return to main program
Xc
X return
X end
X
X
X
X
X subroutine strek_draw_phasers (x_pt, y_pt)
Xc
Xc STREK_DRAW_PHASERS - draws the phasers to the target point
Xc (x_pt,y_pt). This is all done in stop action (light speed
Xc and everthing like that there). Handles all gpr actions
Xc needed and returns them to normal.
Xc
Xc version 1
Xc -jsr 8/85
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 xpt_l, xpt_r, ypt
X integer*4 x_pt, y_pt, status
X real*4 xoff_l, xoff_r, yoff
Xc
Xc find the incremental offsets of rays
Xc
X xoff_l = (x_pt - 100)/20.0
X xoff_r = (x_pt - 800)/20.0
X yoff = (y_pt - 700)/20.0
Xc
Xc begin drawing lines using move and line
Xc
X
X do 10 j = 1,20
X xpt_l = 100 + (j-1)*xoff_l
X ypt = 700 + (j-1)*yoff
X call gprmove (xpt_l, ypt, status)
X xpt_l = xpt_l + xoff_l
X ypt = ypt + yoff
X call gprline (xpt_l, ypt, status)
X xpt_r = 800 + (j-1)*xoff_r
X ypt = 700 + (j-1)*yoff
X call gprmove (xpt_r, ypt, status)
X xpt_r = xpt_r + xoff_r
X ypt = ypt + yoff
X call gprline (xpt_r, ypt, status)
X 10 continue
Xc
Xc erase lines slowly
Xc
X call gprsetdrawvalue (0, status)
X do 20 j = 1,20
X xpt_l = 100 + (j-1)*xoff_l
X ypt = 700 + (j-1)*yoff
X call gprmove (xpt_l, ypt, status)
X xpt_l = xpt_l + xoff_l
X ypt = ypt + yoff
X call gprline (xpt_l, ypt, status)
X xpt_r = 800 + (j-1)*xoff_r
X ypt = 700 + (j-1)*yoff
X call gprmove (xpt_r, ypt, status)
X xpt_r = xpt_r + xoff_r
X ypt = ypt + yoff
X call gprline (xpt_r, ypt, status)
X 20 continue
Xc
Xc return to calling sub
Xc
X call gprsetdrawvalue (1, status)
X return
X end
X
X
X
X
X
X
X subroutine strek_damage_info (d_pct, capt_name, nick_name)
Xc
Xc STREK_DAMAGE_INFO documents on the com line the current
Xc ship damages including a diagnostic from Scotty.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X real*4 d_pct(6), total
X character*10 capt_name, nick_name
X character*80 message(3)
X data message(1) /' engine 1 engine 2 phaser battery scann
X &er tractor'/
Xc
Xc encode damage pecentiles
Xc
X write (message(2),'(6f10.2)') (d_pct(i), i=1,6)
Xc
Xc add percents
Xc
X total = 0.0
X do 10 j = 1,6
X total = total + d_pct(j)
X 10 continue
Xc
Xc pick Scotty's message
Xc
X if (total.gt.4.8) then
X message(3) = 'Aye, there''s no problem captain '//capt_name
X else if (total.le.4.8.and.total.gt.3.0) then
X message(3) = 'She''ll hold together '//nick_name
X else
X message(3) =
X & 'She can''t take much more of this abuse '//nick_name
X end if
X call strek_message (message, 3)
X return
X end
X
X
X
X
X
X subroutine strek_number_objects (pos_store, orange, object, dir)
Xc
Xc STREK_NUMBER_OBJECTS writes the unique STREK object number
Xc next to screen objects. Assumes proper font, raster_op and
Xc clip window status.
Xc
Xc version 1
Xc -jsr 8/85
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 x_pt, y_pt
X integer*4 pos_store(0:9,2), status
X real*4 orange(0:9)
X logical object(0:9), dir
X character*1 text(0:9)
X save text
X data text/'0','1','2','3','4','5','6','7','8','9'/
X if (dir) then
X call gprsettextvalue (1, status)
X call gprsettextbackgroundvalue (0, status)
X else
X call gprsettextvalue (0, status)
X call gprsettextbackgroundvalue (0, status)
X end if
Xc
Xc loop over objects
Xc
X do 10 j = 0,9
X if (object(j).and.orange(j).lt.640000.0) then
X x_pt = pos_store(j,1)
X y_pt = pos_store(j,2)
X call gprmove (x_pt, y_pt, status)
X call gprtext (text(j), 1, status)
X end if
X 10 continue
X call gprsettextvalue (0, status)
X call gprsettextbackgroundvalue (1, status)
X return
X end
X
X
X
X
X
X subroutine strek_scanner (rox, roy, roz, object, dir)
Xc
Xc STREK_SCANNER maintains the scanner windows.
Xc
Xc version 1
Xc -jsr 8/85
Xc
X integer*2 xpt(0:9), ypt(0:9), xpt2(0:9), ypt2(0:9)
X integer*2 xt, yt
X integer*4 status
X real*4 rox(0:9), roy(0:9), roz(0:9), max, check, scale
X logical object(0:9), dir, erase(0:9)
X save xpt, ypt, xpt2, ypt2, max, check, scale, erase
X data max, check, scale /360000.0, 600.0, 0.0666666/
X data xpt, ypt, xpt2, ypt2 /40*0/
X data erase /10*.false./
Xc
Xc turn off clipping
Xc
X call gprsetclippingactive (.false., status)
Xc
Xc if refreshing then compute projected postions
Xc
X if (dir) then
X do 10 j= 0,9
X erase(j) = .false.
X if (object(j)) then
X if ((abs(rox(j)).lt.check.and.abs(roy(j)).lt.check).and.
X & (abs(roz(j)).lt.check)) then
X check1 = rox(j)**2 + roy(j)**2
X if (check1.lt.max) then
X check1 = roz(j)**2 + roy(j)**2
X if (check1.lt.max) then
X erase(j) = .true.
X xpt(j) = rox(j) * scale + 850
X ypt(j) = - roy(j) * scale + 540
X xpt2(j) = roy(j) * scale + 850
X ypt2(j) = - roz(j) * scale + 650
X call gprmove (xpt(j), ypt(j), status)
X xt = xpt(j) + 1
X yt = ypt(j) + 1
X call gprline (xt, yt, status)
X call gprmove (xpt2(j), ypt2(j), status)
X xt = xpt2(j) + 1
X yt = ypt2(j) + 1
X call gprline (xt, yt, status)
X end if
X end if
X end if
X end if
X 10 continue
Xc
Xc plot a dot at the center of each (player ship)
Xc
X xt = 850
X yt = 540
X call gprmove (xt, yt, status)
X call gprline (xt, yt, status)
X yt = 650
X call gprmove (xt, yt, status)
X call gprline (xt, yt, status)
Xc
Xc using previous position erase the current lines by redrawing
Xc in black
Xc
X else
X do 20 j = 0,9
X if (erase(j)) then
X call gprmove (xpt(j), ypt(j), status)
X xt = xpt(j) + 1
X yt = ypt(j) + 1
X call gprline (xt, yt, status)
X call gprmove (xpt2(j), ypt2(j), status)
X xt = xpt2(j) + 1
X yt = ypt2(j) + 1
X call gprline (xt, yt, status)
X end if
X 20 continue
X end if
X call gprsetclippingactive (.true., status)
X return
X end
X
X
X
X
X subroutine strek_phaser_ship (x1, y1, pcen, seed)
Xc
Xc STREK_PHASER_SHIP draws phasers fire lines from an enemy
Xc ship to the player ship in stop time action. Lines are
Xc then erased. Handles all GPR calls needed .
Xc
Xc version 1
Xc -jsr 8/85
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 xpt1, xpt2, ypt1, ypt2, pcen(2)
X integer*4 status, px_1, px_2, py_1, py_2
X real*4 xoff_1, xoff_2, yoff_1, yoff_2, seed, x_pt, y_pt
Xc
Xc if ship is to far off the screen or behind the player ship
Xc then don't execute.
Xc
X x_pt = x1
X y_pt = y1
X if (x_pt.eq.1000.and.y_pt.eq.1000) return
X x_pt = pcen(1)
X y_pt = pcen(2)
Xc
Xc randomly find position of hit on screen
Xc
X call rand (seed)
X if (seed.lt.0.25) then
X px_1 = 800
X call rand (seed)
X py_1 = 100 + 600 * seed
X else if (seed.lt.0.5.and.seed.ge.0.25) then
X px_1 = 100
X call rand (seed)
X py_1 = 100 + 600 * seed
X else if (seed.lt.0.75.and.seed.ge.0.50) then
X py_1 = 100
X call rand (seed)
X px_1 = 100 + 700 * seed
X else
X py_1 = 700
X call rand (seed)
X px_1 = 100 + 700 * seed
X end if
X call rand (seed)
X if (seed.lt.0.25) then
X px_2 = 800
X call rand (seed)
X py_2 = 100 + 600 * seed
X else if (seed.lt.0.5.and.seed.ge.0.25) then
X px_2 = 100
X call rand (seed)
X py_2 = 100 + 600 * seed
X else if (seed.lt.0.75.and.seed.ge.0.50) then
X py_2 = 100
X call rand (seed)
X px_2 = 100 + 700 * seed
X else
X py_2 = 700
X call rand (seed)
X px_2 = 100 + 700 * seed
X end if
Xc
Xc find the incremental offsets of rays
Xc
X xoff_1 = (px_1 - x_pt)/20.0
X xoff_2 = (px_2 - x_pt)/20.0
X yoff_1 = (py_1 - y_pt)/20.0
X yoff_2 = (py_2 - y_pt)/20.0
Xc
Xc begin drawing lines using move and line
Xc
X do 10 j = 1,20
X xpt1 = x_pt + (j-1)*xoff_1
X ypt1 = y_pt + (j-1)*yoff_1
X call gprmove (xpt1, ypt1, status)
X xpt1 = xpt1 + xoff_1
X ypt1 = ypt1 + yoff_1
X call gprline (xpt1, ypt1, status)
X xpt2 = x_pt + (j-1)*xoff_2
X ypt2 = y_pt + (j-1)*yoff_2
X call gprmove (xpt2, ypt2, status)
X xpt2 = xpt2 + xoff_2
X ypt2 = ypt2 + yoff_2
X call gprline (xpt2, ypt2, status)
X 10 continue
Xc
Xc erase lines slowly
Xc
X call gprsetdrawvalue (0, status)
X do 20 j = 1,20
X xpt1 = x_pt + (j-1)*xoff_1
X ypt1 = y_pt + (j-1)*yoff_1
X call gprmove (xpt1, ypt1, status)
X xpt1 = xpt1 + xoff_1
X ypt1 = ypt1 + yoff_1
X call gprline (xpt1, ypt1, status)
X xpt2 = x_pt + (j-1)*xoff_2
X ypt2 = y_pt + (j-1)*yoff_2
X call gprmove (xpt2, ypt2, status)
X xpt2 = xpt2 + xoff_2
X ypt2 = ypt2 + yoff_2
X call gprline (xpt2, ypt2, status)
X 20 continue
Xc
Xc return to calling sub
Xc
X call gprsetdrawvalue (1, status)
X return
X end
X
X
X
X
X subroutine strek_phaser_nemian (pro_x, pro_y)
Xc
Xc STREK_PHASER_NEMIAN draws the klingon phaser fire towards
Xc Nemian freighters in stop action time.
Xc
Xc version 1
Xc -jsr 8/85
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 x_pt, y_pt
X integer*4 status
X real*4 pro_x(0:9), pro_y(0:9), xoff, yoff
Xc
Xc check that phasers need to be drawn
Xc
X if (pro_x(1).eq.1000.0.or.pro_y(1).eq.1000.0) return
Xc
Xc form offsets
Xc
X xoff = (pro_x(1) - pro_x(2))/20.0
X yoff = (pro_y(1) - pro_y(2))/20.0
Xc
Xc draw phasers (1 line only)
Xc
X x_pt = pro_x(2)
X y_pt = pro_y(2)
X call gprmove (x_pt, y_pt, status)
X do 10 j = 1,20
X x_pt = x_pt + xoff
X y_pt = y_pt + yoff
X call gprline (x_pt, y_pt, status)
X 10 continue
Xc
Xc erase lines by redrawing in black
Xc
X call gprsetdrawvalue (0, status)
X x_pt = pro_x(2)
X y_pt = pro_y(2)
X call gprmove (x_pt, y_pt, status)
X do 20 j = 1,20
X x_pt = x_pt + xoff
X y_pt = y_pt + yoff
X call gprline (x_pt, y_pt, status)
X 20 continue
Xc
Xc reset color and return
Xc
X call gprsetdrawvalue(1, status)
X return
X end
X
X
X
X
X
E!O!F! xstrek/f_changed/strek_graphics_subs.f
echo xstrek/f_changed/strek_keydef_subs.f 1>&2
sed -e 's/^X//' > xstrek/f_changed/strek_keydef_subs.f <<'E!O!F! xstrek/f_changed/strek_keydef_subs.f'
X subroutine strek_parse_key_defs (key_file, found)
Xc
Xc STREK_PARSE_KEY_DEFS interprets the user input key
Xc definitions file in terms of the actual keys and
Xc KBD.INS.FTN parameters
Xc
Xc version 2
Xc -jsr 8/85
Xc modified 11/20/85
Xc
Xc % include '/sys/ins/base.ins.ftn'
Xc % include '/sys/ins/kbd.ins.ftn'
Xc
X integer*4 number
X character*1 means(256), temp, pf(32)
Xc character*1 means(256), temp, pf(90)
X character*256 key_file
X logical fyn, found
Xc
Xc common block of key def's
Xc
X common /key_defs/ means
X data pf /'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
X & 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
X & 'u', 'v', 'w', 'x', 'y', 'z',
X & ' ', ',', '.', '/', ';', '['/
Xc data pf /'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
Xc & 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
Xc & 'u', 'v', 'w', 'x', 'y', 'z', kbdl1, kbdl2,
Xc & kbdl3, kbdl4, kbdl5, kbdl6, kbdl7, kbdl8,
Xc & kbdl9, kbdla, kbdlb, kbdlc, kbdld, kbdle,
Xc & kbdlf, kbdl1a, kbdl2a, kbdl3a, kbdl1u,
Xc & kbdl2u, kbdl3u, kbdl4u, kbdl5u, kbdl6u,
Xc & kbdl7u, kbdl8u, kbdl9u, kbdlau, kbdlbu,
Xc & kbdlcu, kbdldu, kbdleu, kbdlfu, kbdl1au,
Xc & kbdl2au, kbdl3au, kbdf1, kbdf2, kbdf3, kbdf4,
Xc & kbdf5, kbdf6, kbdf7, kbdf8, kbdf1u, kbdf2u,
Xc & kbdf3u, kbdf4u, kbdf5u, kbdf6u, kbdf7u,
Xc & kbdf8u, kbdr1, kbdr2, kbdr3, kbdr4, kbdr5,
Xc & kbdr6, ' ', ',', '.', '/', ';', '['/
Xc
Xc read in file
Xc
X inquire (file = key_file, exist=fyn)
X if (.not.fyn) then
X found = .false.
X return
X end if
X found = .true.
X do 10 j = 1, 256
X means(j) = char(j)
X 10 continue
X open (unit = 1, file = key_file)
X read (1,'(a)') temp
X read (1,'(a)') temp
X do 20 j = 1, 90
X read (1, 100) temp
X if (temp .ne. ' ') then
X means(ichar(pf(j))) = temp
X end if
X 20 continue
X100 format (6x, a)
X close(1)
X return
X end
X
X
X
X
X subroutine strek_interpret_key (t_key)
Xc
Xc STREK_INTERPRET_KEY interprets an keystroke event datum
Xc in terms of it's users defined key.
Xc
Xc version 2
Xc -jsr 8/85
Xc modified 11/20/85
Xc
X character*1 t_key, means(256)
X common /key_defs/ means
X t_key = means(ichar(t_key))
X end
X
X
E!O!F! xstrek/f_changed/strek_keydef_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