pfuetz@agd.fhg.de (02/26/91)
Submitted-by: pfuetz@agd.fhg.de
Posting-number: Volume 11, Issue 93
Archive-name: xstrek/part07
#!/bin/sh
# To unshare, sh or unshar this file
echo xstrek/original_code/strek_graphics_subs.f 1>&2
sed -e 's/^X//' > xstrek/original_code/strek_graphics_subs.f <<'E!O!F! xstrek/original_code/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
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 config, size(2), 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 gpr_$init (gpr_$borrow, int2(1), size, int2(0),
X & bitmap_desc, status)
X if (status.ne.0) then
X call error_$print (status)
X stop
X end if
X call gpr_$inq_config (config, status)
X if (config.eq.gpr_$color_1024x1024x4.or.
X & config.eq.gpr_$color_1024x1024x8.or.
X & config.eq.gpr_$color_1024x800x4.or.
X & config.eq.gpr_$color_1024x800x8) then
X call gpr_$set_color_map (0, int2(2), value, status)
X end if
Xc
Xc load all fonts needed
Xc
X call gpr_$load_font_file ('/sys/dm/fonts/nonie.r.8',int2(23),
X & font_1,status)
X call gpr_$load_font_file ('/sys/dm/fonts/scvc8x16.i.r',int2(26),
X & font_2,status)
X call gpr_$load_font_file ('/sys/dm/fonts/scvc5x10.r.b',int2(26),
X & font_3,status)
X call gpr_$load_font_file ('/sys/dm/fonts/f5x9',int2(18),
X & font_4,status)
X call gpr_$set_text_path (gpr_$right,status)
X call gpr_$set_text_background_value (-1,status)
Xc
Xc set values for draws and fills
Xc
X call gpr_$set_draw_value (1,status)
X call gpr_$set_fill_value (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 gpr_$rectangle (window,status)
X call gpr_$set_fill_value (0,status)
X window(1,1) = 100
X window(2,1) = 100
X window(1,2) = 700
X window(2,2) = 600
X call gpr_$rectangle (window,status)
X window(1,1) = 100
X window(2,1) = 710
X window(1,2) = 700
X window(2,2) = 80
X call gpr_$rectangle (window,status)
X call gpr_$set_fill_value (1,status)
Xc
Xc put in text on all static panels
Xc
X call gpr_$set_clipping_active (.true.,status)
X xpt = 15
X ypt = 25
X call gpr_$set_text_font (font_2,status)
X call gpr_$set_text_value (0,status)
X call gpr_$move (xpt,ypt,status)
X text = 'Star Trek Version 3.0'
X call gpr_$text (text,int2(30),status)
X call gpr_$set_text_font (font_1,status)
X xpt = 10
X ypt = 150
X call gpr_$move (xpt,ypt,status)
X text = 'Speed'
X call gpr_$text (text,int2(30),status)
X xpt = 10
X ypt = 250
X call gpr_$move (xpt,ypt,status)
X text = 'Energy'
X call gpr_$text (text,int2(30),status)
X xpt = 10
X ypt = 350
X call gpr_$move (xpt,ypt,status)
X text = 'Photons'
X call gpr_$text (text,int2(30),status)
X xpt = 10
X ypt = 450
X call gpr_$move (xpt,ypt,status)
X text = 'Phasers'
X call gpr_$text (text,int2(30),status)
X xpt = 10
X ypt = 550
X call gpr_$move (xpt,ypt,status)
X text = 'Tractor'
X call gpr_$text (text,int2(30),status)
X xpt = 17
X ypt = 755
X call gpr_$move (xpt,ypt,status)
X text = 'Com:'
X call gpr_$text (text,int2(30),status)
X xpt = 110
X ypt = 75
X call gpr_$move (xpt,ypt,status)
X text = 'X-Coor:'
X call gpr_$text (text,int2(30),status)
X xpt = 310
X ypt = 75
X call gpr_$move (xpt,ypt,status)
X text = 'Y-Coor:'
X call gpr_$text (text,int2(30),status)
X xpt = 510
X ypt = 75
X call gpr_$move (xpt,ypt,status)
X text = 'Z-Coor:'
X call gpr_$text (text,int2(30),status)
X xpt = 810
X ypt = 125
X call gpr_$move (xpt,ypt,status)
X text = 'Scanner'
X call gpr_$text (text,int2(30),status)
X xpt = 810
X ypt = 200
X call gpr_$move (xpt,ypt,status)
X text = 'X-Coor:'
X call gpr_$text (text,int2(30),status)
X xpt = 810
X ypt = 275
X call gpr_$move (xpt,ypt,status)
X text = 'Y-Coor:'
X call gpr_$text (text,int2(30),status)
X xpt = 810
X ypt = 350
X call gpr_$move (xpt,ypt,status)
X text = 'Z-Coor:'
X call gpr_$text (text,int2(30),status)
X xpt = 810
X ypt = 425
X call gpr_$move (xpt,ypt,status)
X text = 'Range:'
X call gpr_$text (text,int2(30),status)
Xc
Xc insert scanner windows
Xc
X call gpr_$set_fill_value (0,status)
X pt1(1) = 850
X pt1(2) = 540
X radius = 45
X call gpr_$circle_filled (pt1, radius, status)
X pt1(2) = 650
X call gpr_$circle_filled (pt1, radius, status)
X call gpr_$set_text_font (font_4,status)
X xpt = 708
X ypt = 33
X call gpr_$move (xpt,ypt,status)
X text = 'Enemy 1'
X call gpr_$text (text,int2(30),status)
X xpt = 708
X ypt = 73
X call gpr_$move (xpt,ypt,status)
X text = 'Enemy 2'
X call gpr_$text (text,int2(30),status)
X xpt = 819
X ypt = 33
X call gpr_$move (xpt,ypt,status)
X text = 'Low E'
X call gpr_$text (text,int2(30),status)
X xpt = 815
X ypt = 73
X call gpr_$move (xpt,ypt,status)
X text = 'Nav On'
X call gpr_$text (text,int2(30),status)
X xpt = 810
X ypt = 490
X text = 'X'
X call gpr_$move (xpt,ypt,status)
X call gpr_$text (text,int2(30),status)
X xpt = 885
X ypt = 490
X text = 'Y'
X call gpr_$move (xpt,ypt,status)
X call gpr_$text (text,int2(30),status)
X xpt = 810
X ypt = 600
X text = 'Z'
X call gpr_$move (xpt,ypt,status)
X call gpr_$text (text,int2(30),status)
X xpt = 885
X text = 'Y'
X call gpr_$move (xpt,ypt,status)
X call gpr_$text (text,int2(30),status)
X call gpr_$set_text_font (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 gpr_$rectangle (window,status)
X pt1(1) = 850
X pt1(2) = 765
X radius = 18
X call gpr_$circle (pt1,radius,status)
X pt1(1) = 850
X pt1(2) = 765
X radius = 6
X call gpr_$circle (pt1,radius,status)
X call gpr_$set_fill_value (1,status)
X window(1,1) = 832
X window(2,1) = 715
X window(1,2) = 5
X window(2,2) = 30
X call gpr_$rectangle (window,status)
X window(1,1) = 863
X call gpr_$rectangle (window,status)
X window(1,1) = 847
X window(2,1) = 730
X window(1,2) = 6
X window(2,2) = 17
X call gpr_$rectangle (window,status)
Xc
Xc load permanent font
Xc
X call gpr_$set_text_font (font_4, status)
X call gpr_$set_text_background_value (1, status)
X call gpr_$set_draw_value (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 gpr_$set_clip_window (window,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
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 x_pt(15), y_pt(15), xpt, ypt, length, wind_1(2,2)
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 gpr_$set_clipping_active (.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 gpr_$move (x_pt(1), y_pt(1), status)
X call gpr_$text (text, length, status)
X write (text,100) power
X call gpr_$move (x_pt(2), y_pt(2), status)
X call gpr_$text (text, length, status)
X write (text,100) photons
X call gpr_$move (x_pt(3), y_pt(3), status)
X call gpr_$text (text, length, status)
X if (phase) then
X text = active
X else
X text = down
X end if
X call gpr_$move (x_pt(4), y_pt(4), status)
X call gpr_$text (text, length, status)
X else if (n.eq.2) then
X if (absol) then
X write (text,100) xc
X call gpr_$move (x_pt(6), y_pt(6), status)
X call gpr_$text (text, length, status)
X write (text,100) yc
X call gpr_$move (x_pt(7), y_pt(7), status)
X call gpr_$text (text, length, status)
X write (text,100) zc
X call gpr_$move (x_pt(8), y_pt(8), status)
X call gpr_$text (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 gpr_$move (x_pt(5), y_pt(5), status)
X call gpr_$text (text, length, status)
X if (scan) then
X write (text, '(4x, i1)') scan_ob
X else
X text = down
X end if
X call gpr_$move (x_pt(9), y_pt(9), status)
X call gpr_$text (text, length, status)
X write (text,100) txc
X call gpr_$move (x_pt(10), y_pt(10), status)
X call gpr_$text (text, length, status)
X else
X n = 0
X write (text,100) tyc
X call gpr_$move (x_pt(11), y_pt(11), status)
X call gpr_$text (text, length, status)
X write (text,100) tzc
X call gpr_$move (x_pt(12), y_pt(12), status)
X call gpr_$text (text, length, status)
X write (text,100) trange
X call gpr_$move (x_pt(13), y_pt(13), status)
X call gpr_$text (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 gpr_$set_clipping_active (.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 gpr_$set_raster_op (zero, ten, status)
X call gpr_$set_clipping_active (.false.,status)
X call gpr_$bit_blt (bitmap_desc, wind_1, zero, dest_1,
X & zero, status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.true.,status)
X old(1) = .not. old(1)
X else if ((.not. object(2)) .and. old(1)) then
X call gpr_$set_raster_op (zero, ten, status)
X call gpr_$set_clipping_active (.false.,status)
X call gpr_$bit_blt (bitmap_desc, wind_1, zero, dest_1,
X & zero, status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.true.,status)
X old(1) = .not. old(1)
X end if
X if (object(3) .and. (.not. old(2))) then
X call gpr_$set_raster_op (zero, ten, status)
X call gpr_$set_clipping_active (.false.,status)
X call gpr_$bit_blt (bitmap_desc, wind_2, zero, dest_2,
X & zero, status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.true.,status)
X old(2) = .not. old(2)
X else if ((.not. object(3)) .and. old(2)) then
X call gpr_$set_raster_op (zero, ten, status)
X call gpr_$set_clipping_active (.false.,status)
X call gpr_$bit_blt (bitmap_desc, wind_2, zero, dest_2,
X & zero, status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.true.,status)
X old(2) = .not. old(2)
X end if
X if (lock_on .and. (.not. old(3))) then
X call gpr_$set_raster_op (zero, ten, status)
X call gpr_$set_clipping_active (.false.,status)
X call gpr_$bit_blt (bitmap_desc, wind_3, zero, dest_3,
X & zero, status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.true.,status)
X old(3) = .not. old(3)
X else if ((.not. lock_on) .and. old(3)) then
X call gpr_$set_raster_op (zero, ten, status)
X call gpr_$set_clipping_active (.false.,status)
X call gpr_$bit_blt (bitmap_desc, wind_3, zero, dest_3,
X & zero, status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.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 gpr_$set_raster_op (zero, ten, status)
X call gpr_$set_clipping_active (.false.,status)
X call gpr_$bit_blt (bitmap_desc, wind_4, zero, dest_4,
X & zero, status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.true.,status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.true.,status)
X old(4) = .not. old(4)
X else if ((.not. low_e) .and. old(4)) then
X call gpr_$set_raster_op (zero, ten, status)
X call gpr_$set_clipping_active (.false.,status)
X call gpr_$bit_blt (bitmap_desc, wind_4, zero, dest_4,
X & zero, status)
X call gpr_$set_raster_op (zero, three, status)
X call gpr_$set_clipping_active (.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
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 x_pts(4), y_pts(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 gpr_$multiline (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
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/gpr.ins.ftn'
Xc
X integer*2 window(2,2), x_pt, y_pt(3), 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 / 60/
Xc
Xc deactivate clipping window
Xc
X call gpr_$set_clipping_active (.false.,status)
Xc
Xc if num_lines is zero erase message block
Xc
X if (num_lines.eq.0) then
X call gpr_$set_fill_value (0,status)
X call gpr_$rectangle (window,status)
X call gpr_$set_fill_value (1,status)
X call gpr_$set_clipping_active (.true.,status)
X return
X end if
Xc
Xc set text values and write message
Xc
X call gpr_$set_text_value (1,status)
X call gpr_$set_text_background_value (0,status)
X do 10 j = 1,num_lines
X call gpr_$move (x_pt,y_pt(j),status)
X call gpr_$text (message(j),length,status)
X 10 continue
Xc
Xc reset text values and clipping window
Xc
X call gpr_$set_text_value (0,status)
X call gpr_$set_text_background_value (1,status)
X call gpr_$set_clipping_active (.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
X% include '/sys/ins/base.ins.ftn'
X% 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 gpr_$move (xpt_l, ypt, status)
X xpt_l = xpt_l + xoff_l
X ypt = ypt + yoff
X call gpr_$line (xpt_l, ypt, status)
X xpt_r = 800 + (j-1)*xoff_r
X ypt = 700 + (j-1)*yoff
X call gpr_$move (xpt_r, ypt, status)
X xpt_r = xpt_r + xoff_r
X ypt = ypt + yoff
X call gpr_$line (xpt_r, ypt, status)
X 10 continue
Xc
Xc erase lines slowly
Xc
X call gpr_$set_draw_value (0, status)
X do 20 j = 1,20
X xpt_l = 100 + (j-1)*xoff_l
X ypt = 700 + (j-1)*yoff
X call gpr_$move (xpt_l, ypt, status)
X xpt_l = xpt_l + xoff_l
X ypt = ypt + yoff
X call gpr_$line (xpt_l, ypt, status)
X xpt_r = 800 + (j-1)*xoff_r
X ypt = 700 + (j-1)*yoff
X call gpr_$move (xpt_r, ypt, status)
X xpt_r = xpt_r + xoff_r
X ypt = ypt + yoff
X call gpr_$line (xpt_r, ypt, status)
X 20 continue
Xc
Xc return to calling sub
Xc
X call gpr_$set_draw_value (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) = 'She can''t take much more of this abuse '//
X & 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
X% include '/sys/ins/base.ins.ftn'
X% 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 gpr_$set_text_value (1, status)
X call gpr_$set_text_background_value (0, status)
X else
X call gpr_$set_text_value (0, status)
X call gpr_$set_text_background_value (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 gpr_$move (x_pt, y_pt, status)
X call gpr_$text (text(j), int2(1), status)
X end if
X 10 continue
X call gpr_$set_text_value (0, status)
X call gpr_$set_text_background_value (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 gpr_$set_clipping_active (.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 gpr_$move (xpt(j), ypt(j), status)
X xt = xpt(j) + 1
X yt = ypt(j) + 1
X call gpr_$line (xt, yt, status)
X call gpr_$move (xpt2(j), ypt2(j), status)
X xt = xpt2(j) + 1
X yt = ypt2(j) + 1
X call gpr_$line (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 gpr_$move (xt, yt, status)
X call gpr_$line (xt, yt, status)
X yt = 650
X call gpr_$move (xt, yt, status)
X call gpr_$line (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 gpr_$move (xpt(j), ypt(j), status)
X xt = xpt(j) + 1
X yt = ypt(j) + 1
X call gpr_$line (xt, yt, status)
X call gpr_$move (xpt2(j), ypt2(j), status)
X xt = xpt2(j) + 1
X yt = ypt2(j) + 1
X call gpr_$line (xt, yt, status)
X end if
X 20 continue
X end if
X call gpr_$set_clipping_active (.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
X% include '/sys/ins/base.ins.ftn'
X% 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 gpr_$move (xpt1, ypt1, status)
X xpt1 = xpt1 + xoff_1
X ypt1 = ypt1 + yoff_1
X call gpr_$line (xpt1, ypt1, status)
X xpt2 = x_pt + (j-1)*xoff_2
X ypt2 = y_pt + (j-1)*yoff_2
X call gpr_$move (xpt2, ypt2, status)
X xpt2 = xpt2 + xoff_2
X ypt2 = ypt2 + yoff_2
X call gpr_$line (xpt2, ypt2, status)
X 10 continue
Xc
Xc erase lines slowly
Xc
X call gpr_$set_draw_value (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 gpr_$move (xpt1, ypt1, status)
X xpt1 = xpt1 + xoff_1
X ypt1 = ypt1 + yoff_1
X call gpr_$line (xpt1, ypt1, status)
X xpt2 = x_pt + (j-1)*xoff_2
X ypt2 = y_pt + (j-1)*yoff_2
X call gpr_$move (xpt2, ypt2, status)
X xpt2 = xpt2 + xoff_2
X ypt2 = ypt2 + yoff_2
X call gpr_$line (xpt2, ypt2, status)
X 20 continue
Xc
Xc return to calling sub
Xc
X call gpr_$set_draw_value (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
X% include '/sys/ins/base.ins.ftn'
X% 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 gpr_$move (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 gpr_$line (x_pt, y_pt, status)
X 10 continue
Xc
Xc erase lines by redrawing in black
Xc
X call gpr_$set_draw_value (0, status)
X x_pt = pro_x(2)
X y_pt = pro_y(2)
X call gpr_$move (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 gpr_$line (x_pt, y_pt, status)
X 20 continue
Xc
Xc reset color and return
Xc
X call gpr_$set_draw_value(1, status)
X return
X end
X
X
X
X
X
E!O!F! xstrek/original_code/strek_graphics_subs.f
echo xstrek/original_code/strek_keydef_subs.f 1>&2
sed -e 's/^X//' > xstrek/original_code/strek_keydef_subs.f <<'E!O!F! xstrek/original_code/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
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/kbd.ins.ftn'
Xc
X integer*4 number
X 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', kbd_$l1, kbd_$l2,
X & kbd_$l3, kbd_$l4, kbd_$l5, kbd_$l6, kbd_$l7, kbd_$l8,
X & kbd_$l9, kbd_$la, kbd_$lb, kbd_$lc, kbd_$ld, kbd_$le,
X & kbd_$lf, kbd_$l1a, kbd_$l2a, kbd_$l3a, kbd_$l1u,
X & kbd_$l2u, kbd_$l3u, kbd_$l4u, kbd_$l5u, kbd_$l6u,
X & kbd_$l7u, kbd_$l8u, kbd_$l9u, kbd_$lau, kbd_$lbu,
X & kbd_$lcu, kbd_$ldu, kbd_$leu, kbd_$lfu, kbd_$l1au,
X & kbd_$l2au, kbd_$l3au, kbd_$f1, kbd_$f2, kbd_$f3, kbd_$f4,
X & kbd_$f5, kbd_$f6, kbd_$f7, kbd_$f8, kbd_$f1u, kbd_$f2u,
X & kbd_$f3u, kbd_$f4u, kbd_$f5u, kbd_$f6u, kbd_$f7u,
X & kbd_$f8u, kbd_$r1, kbd_$r2, kbd_$r3, kbd_$r4, kbd_$r5,
X & kbd_$r6, ' ', ',', '.', '/', ';', '['/
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/original_code/strek_keydef_subs.f
echo xstrek/original_code/strek_main.f 1>&2
sed -e 's/^X//' > xstrek/original_code/strek_main.f <<'E!O!F! xstrek/original_code/strek_main.f'
X program strek_main
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_MAIN is the main calling code for the STREK system.
Xc It handles the database startup calls, graphics init call,
Xc the screen update - resolve - key request sequence.
Xc When the ship docks or dies it updates the database.
Xc
Xc version 2.0
Xc
X% include '/sys/ins/base.ins.ftn'
X% include '/sys/ins/gpr.ins.ftn'
X% include '/sys/ins/smdu.ins.ftn'
X% include '/sys/ins/time.ins.ftn'
X% include '/sys/ins/cal.ins.ftn'
Xc
Xc STREK declarations
Xc
X parameter (pi = 3.141592653)
X integer*2 font_3, font_4, clock(3), timer(3), wait(3), center(2)
X integer*2 event_type, c_pos(2), key_set(16)
X integer*4 status, last_score, cum_score, photons, waited
X integer*4 photon_c(6), r_index, bitmap_desc, scan_ob, turns_wait
X integer*4 ph_object, tr_object, pos_store(0:9,2)
X integer*4 option, phase_c, score, index(0:9), item, type, l_object
X integer*4 txc, tyc, tzc, trange, rate, cm(3), cs(3), pc(3)
X integer*4 ship_k, ship_r, ship_n, dock_n
Xc
Xc real variables (all ship position data)
Xc
X real*4 trx, try, trz, trazm, trangle, trdist, tr_cost(0:9)
X real*4 rot_azm(10), rot_ang(10), rot_cost(10), rox(0:9)
X real*4 roy(0:9), roz(0:9), pro_x(0:9), pro_y(0:9), xt(0:9)
X real*4 yt(0:9), zt(0:9), xc, yc, zc, azm, value(9)
X real*4 angle, obx(0:9), oby(0:9), obz(0:9), oazm(0:9)
X real*4 oangle(0:9), ospeed(0:9), orange(0:9), speed, energy
X real*4 distance(3,0:9), odamage(0:9), d_pct(6), seed
X real*4 damage, maxd(9), photon_tr(4:9), razm(3), rangle(3)
X real*4 brake(3), ran_store(0:9), soa(9), coa(9), sop(9), cop(9)
X real*8 elapsed, turn, duration
Xc
Xc message strings
Xc
X character capt_name*10, nick_name*10, ship_name*30
X character*1 key, t_key, dam_rating(3)*10, means(90)
X character*80 message(3), t_message(3), s_message(17)
X character*80 b_message(3), p_message(3), u_message(6)
X character*80 sc_message(6), d_message(6), k_message(3)
X character*80 ph_message(6), a_message(3), ps_message(6)
X character*80 ap_message(3), l_message(6), r_message(3)
X character*80 e_message(3), sl_message(3)
X character*256 key_file
Xc
Xc logical toggles for objects
Xc
X logical input_event, new_ship, scan, tract, phase, found
X logical tract_ob, rotate, object(0:9), kling(3), phase_d
X logical plot(0:9), two, agr(3), lock_on, reverse, unobscured
X logical refresh
Xc
Xc key interpretation common
Xc
X common /key_defs/ means
Xc
Xc data for STREK
Xc
X data index /1, 2, 3, 4, 5, 5, 5, 6, 6, 6/
X data key_set /16 * 16#ffff/
X data ship_k, ship_r, ship_n, dock_n/4*0/
X data c/0/
X data waited, turns_wait / 0, 0/
X data cm, cs, pc /3*0, 3*0, 3*3/
X data rot_azm /0.0, -2.0, 2.0, 0.0, 0.0, -1.0, 1.0, 0.0, 2*0.0/
X data rot_ang /2.0, 0.0, 0.0, -2.0, 1.0, 0.0, 0.0, -1.0, 2*0.0/
X data rot_cost, rotate /8*.25, 0.0, 0.25, .true./
X data r_index, photon_tr /9, 6*900.0/
X data xc, yc, zc, azm, angle /0.0, -50.0, 0.0, 0.0, 0.0/
X data photons, speed, energy, damage /20, 0.0, 1000.0, 0.0/
X data d_pct, odamage /6*1.0, 10*0.0/
X data tr_cost /0.0, 0.4, 2.0, 2.0, 6*1.0/
X data obx(0), oby(0), obz(0)/3*0.0/
X data ospeed, oangle, oazm /10*0.0, 10*0.0, 10*0.0/
X data score, maxd, value /0, 5.0, 2*0.0, 6*12.5, -200.0, 2*300.0,
X & 6*0.0/
X data sa, ca, sp, cp /0.0, 1.0, 0.0, 1.0/
X data rox, roy, roz / 30 * 0.0/
X data scan, tract, phase, phase_d/3*.true., .false./
X data tract_ob, scan_ob, tr_object /.false., 1, 0/
X data object, plot /.true., 9*.false., 10*.false./
X data lock_on, refresh /.false., .true./
X data dam_rating /'light', 'moderate', 'heavy'/
X data t_message /'Which should I lock onto captain?',
X & 'Input number of object to lock,'
X & ,'any other input = No lock on '/
X data p_message /'Phaser control',
X & 'Input number of object to lock phasers on,'
X & ,'any other input = No phaser lock on '/
X data e_message /'Photon Torpedo Trigger Radius Options',
X & '1 = 15 2 = 20 3 = 25 4 = 30 5 = 35 6 = 40',
X & 'Enter option.'/
X data r_message /'Statistics for ',
X & 'Klingons Romulans Nemians Nemians Docked Sco
X &re Total', ' '/
X data a_message, b_message, k_message /9*' '/
X data ap_message(1) /'Ship hit by enemy photon!'/
X data ap_message(2) /' '/
X data d_message(1) /' '/
X data d_message(2) /'Nemian freighter destroyed.'/
X data d_message(3) /'Enemy spacecraft destroyed.'/
X data d_message(4) /'Second enemy spacecraft destroyed.'/
X data d_message(5) /'Enemy photon torpedo destroyed.'/
X data d_message(6) /'Photon torpedo destroyed.'/
X data l_message(1) /'Navigation lock on star base.'/
X data l_message(2) /'Navigation lock on Nemian freighter.'/
X data l_message(3) /'Navigation lock on enemy spacecraft.'/
X data l_message(4) /'Navigation lock on second enemy spacecraft.'/
X data ph_message(2) /'Nemian freighter hit by photon torpedo.'/
X data ph_message(3) /'Enemy ship hit by photon torpedo.'/
X data ph_message(4) /'Enemy ship hit by photon torpedo.'/
X data ps_message(2) /'Nemian freighter hit by phaser fire.'/
X data ps_message(3) /'Enemy ship hit by phaser fire.'/
X data ps_message(4) /'Enemy ship hit by phaser fire.'/
X data ps_message(5) /'Enemy Photon torpedo hit by phaser fire.'/
X data ps_message(6) /'Photon torpedo hit by phaser fire.'/
X data s_message(2) /'Tractor beam on Nemian freighter dropped.'/
X data s_message(5) /'Tractor beam on enemy photon dropped.'/
X data s_message(6) /'Tractor beam on photon torpedo dropped.'/
X data s_message(7) /'Tractor beam lock on dropped.'/
X data s_message(8) /'Photon torpedo launched sir.'/
X data s_message(9) /'I''m giving it all she''s got captain.'/
X data s_message(10) /'Scanner lock on lost.'/
X data s_message(11) /'Nemian freighter docked at star base.'/
X data s_message(12) /'Score for destroying ship: '/
X data s_message(13) /'Good going '/
X data s_message(14) /'Scanners report that the damage was '/
X data s_message(15) /'Repair parties report that the damage was '/
X data s_message(16) /'Points lost '/
X data s_message(17) /'It''s your job to defend the Nemians '/
X data sc_message(1) /'Scanner locked on starbase.'/
X data sc_message(2) /'Scanner locked on Nemian freighter.'/
X data sc_message(3) /'Scanner locked on enemy ship.'/
X data sc_message(4) /'Scanner locked on second enemy ship.'/
X data sc_message(5) /'Scanner locked on enemy photon.'/
X data sc_message(6) /'Scanner locked on photon torpedo.'/
X data u_message(2) /'Nemian freighter in tractor beam.'/
X data u_message(5) /'Enemy photon in tractor beam.'/
X data u_message(6) /'Photon torpedo in tractor beam.'/
X data sl_message(1) /'Game put on hold.'/
X data sl_message(2) /'STREK will not start again until another'/
X data sl_message(3) /'key is hit.'/
Xc
Xc statement functions for converting angles to rads
Xc and vice-versa
Xc
X ra(x) = x * pi / 180.0
X de(x) = x * 180.0 / pi
Xc
Xc call STREK_STARTUP to init db and get ship info
Xc
X call strek_startup (capt_name, nick_name, ship_name,
X & last_score, cum_score, key_file, new_ship)
Xc
Xc call STREK_SCREEN_INIT
Xc
X call strek_screen_init (bitmap_desc, font_3, font_4)
Xc
Xc enable keystroke events
Xc
X call gpr_$enable_input (gpr_$keystroke, key_set, status)
Xc
Xc startup info panels (4 passes to init everything)
Xc
X do 5 j = 1,4
X call strek_update_panel (0, int(energy), photons, phase,
X & tract_ob, int(xc), int(yc), int(zc),
X & scan, 0, 0, 0, 0, int(azm), int(angle))
X 5 continue
Xc
Xc give an introductory message
Xc
X b_message(2) = 'Welcome aboard sir, the bridge is all yours!'
X call strek_message (b_message, 3)
Xc
Xc call clock to get a random number seed
Xc
X call cal_$get_local_time (clock)
X seed = abs(clock(3)/33000.0)
Xc
Xc start turn timer
Xc
X call time_$clock (timer)
X call cal_$float_clock (timer, elapsed)
Xc
Xc get a nemian
Xc
X call strek_place_nemian (xc, yc, zc, obx(1), oby(1), obz(1),
X & oazm(1), oangle(1), ospeed(1), seed)
X object(1) = .true.
X odamage(1) = 0.0
Xc
Xc begin event driver loop
Xc
X 10 continue
Xc
Xc check phaser availability
Xc
X if ((.not.phase).and.phase_d) then
X phase_c = phase_c + 1
X if (phase_c.gt.40) then
X phase_d = .false.
X phase = .true.
X end if
X end if
Xc
Xc if nemian is getting too far away then refresh him
Xc
X if (orange(1).gt.9000000.0) object(1) = .false.
Xc
Xc if there's no nemian then get one
Xc
X if (.not.object(1)) then
X call strek_place_nemian (xc, yc, zc, obx(1), oby(1), obz(1),
X & oazm(1), oangle(1), ospeed(1), seed)
X object(1) = .true.
X odamage(1) = 0.0
Xc
Xc check for nemian docking
Xc
X else if ((tr_object.eq.1).and.tract_ob) then
X if (distance(1,0).lt.900.0.and.abs(speed).le.1) then
X score = score + 500
X b_message(2) = s_message(11)
X call strek_message (b_message, 3)
X tract_ob = .false.
X object(1) = .false.
X dock_n = dock_n + 1
X end if
X end if
Xc
Xc check for photon proximity explosions
Xc
X do 20 j = 4,9
X if (object(j)) then
X photon_c(j-3) = photon_c(j-3) + 1
X if (photon_c(j-3).gt.60) object(j) = .false.
X if (j.gt.6) then
X do 30 i = 1,3
X if (object(i).and.(distance(i,j).le.photon_tr(j).and.
X & orange(j).gt.1600.0)) then
X object(j) = .false.
X call strek_photon_damage (distance(i,j), odamage(i),
X & seed, type)
X a_message(1) = ph_message(index(i))
X write (a_message(3),'(a36,a10)') s_message(14),
X & dam_rating(type)
X call strek_message (a_message, 3)
X end if
X 30 continue
X else
Xc
Xc check for nemian hits
Xc
X if (object(1).and.(distance(1,j).lt.photon_tr(j))) then
X if (.not.object(2).or.distance(2,j).gt.900.0) then
X if (.not.object(3).or.distance(3,j).gt.900.0) then
X object(j) = .false.
X call strek_photon_damage (distance(1,j), odamage(1),
X & seed, type)
X end if
X end if
X end if
Xc
Xc check for player ship hits
Xc
X if (orange(j).lt.photon_tr(j)) then
X if (.not.object(2).or.distance(2,j).gt.225.0) then
X if (.not.object(3).or.distance(3,j).gt.225.0) then
X object(j) = .false.
X call strek_photon_damage (orange(j), damage,
X & seed, type)
X write (ap_message(3),'(a42,a10)') s_message(15),
X & dam_rating(type)
X call strek_message (ap_message, 3)
X end if
X end if
X end if
X end if
X end if
X 20 continue
Xc
Xc if enemy ships are alive then move 'em
Xc
X if (object(2).or.object(3)) then
X do 50 j = 2,3
X if (object(j)) then
X call strek_move_enemy (j, obx, oby, obz, oazm, oangle,
X & ospeed, xc, yc, zc, azm, angle,
X & speed, agr(j), object, rox(j),
X & roy(j), roz(j), odamage, pc(j),
X & distance, kling(j), cm(j), cs(j),
X & orange, razm(j), rangle(j),
X & brake(j), damage, photon_c,
X & phase_c, pro_x, pro_y, seed, center)
X end if
X 50 continue
X else if (waited .gt. turns_wait) then
Xc
Xc reset damage totals, pick ship type and aggression levels
Xc
X call strek_enemy_setup (odamage, agr, kling, maxd, object, seed,
X & two, pc)
X j = 2
X k = 3
X if (two) then
X call strek_place_enemy (xc, yc, zc, obx(j), oby(j), obz(j),
X & oazm(j), oangle(j), ospeed(j), seed)
X call strek_place_enemy (xc, yc, zc, obx(k), oby(k), obz(k),
X & oazm(k), oangle(k), ospeed(k), seed)
X else
X call strek_place_enemy (xc, yc, zc, obx(j), oby(j), obz(j),
X & oazm(j), oangle(j), ospeed(j), seed)
X end if
X waited = 0
X else if (waited .eq. 0) then
X call rand (seed)
X turns_wait = seed * 150.0 + 50
X waited = 1
X else
X waited = waited + 1
X end if
Xc
Xc evaluate sum of damages (both photon and phaser) to other objects
Xc
X do 40 j= 1,9
X if (object(j).and.(odamage(j).ge.maxd(j))) then
X if (j.eq.1) then
X ship_n = ship_n + 1
X else if (kling(j)) then
X ship_k = ship_k + 1
X else
X ship_r = ship_r + 1
X end if
X object(j) = .false.
X k_message(1) = d_message(index(j))
X if (j.eq.2.or.j.eq.3) then
X write (k_message(2),'(a27,f10.2)') s_message(12), value(j)
X write (k_message(3),'(a11,a10)') s_message(13), nick_name
X else if (j.eq.1) then
X write (k_message(2),'(a13,f10.2)') s_message(16), value(j)
X write (k_message(3),'(a36,a10)') s_message(17), capt_name
X call rand (seed)
X if (seed.gt.0.5) then
X agr(2) = .false.
X end if
X call rand (seed)
X if (seed.gt.0.5) then
X agr(3) = .false.
X end if
X else
X k_message(2) = k_message(1)
X k_message(1) = ' '
X k_message(3) = ' '
X end if
X call strek_message (k_message, 3)
X score = score + value(j)
X end if
X 40 continue
Xc
Xc process lock on coordinates
Xc
X nav_c = nav_c + 1
X if (lock_on) then
X if (orange(l_object).gt.10000.0.and.nav_c.ge.10) then
X nav_c = 0
X if (speed.lt.0.0) then
X s1 = -speed
X s2 = azm + 180.0
X if (s2.gt.360.0) s2 = s2 - 360.0
X s3 = 360.0 - angle
X reverse = .true.
X else
X s1 = speed
X s2 = azm
X s3 = angle
X reverse = .false.
X end if
X if (s1.gt.1.e-2) then
X num_forward = sqrt(orange(l_object)) / s1
X else
X num_forward = 20
X end if
X j = l_object
X xt1 = -num_forward * ospeed(j) * sin(oazm(j)) *
X & cos(oangle(j)) + obx(j)
X yt1 = num_forward * ospeed(j) * cos(oazm(j)) *
X & cos(oangle(j)) + oby(j)
X zt1 = num_forward * ospeed(j) * sin(oangle(j))
X & + obz(j)
X dx = xt1 - xc
X dy = yt1 - yc
X dz = zt1 - zc
X if (abs(dy).lt.1.0) dy = sign (1.0, dy)
X if (dy.le.0.0) then
X tazm = -de(atan(dx/dy)) + 180.0
X else
X tazm = -de(atan(dx/dy))
X end if
X if (tazm.lt.0.0) tazm = tazm + 360.0
X dist = sqrt(dx**2 + dy**2)
X if (dist.lt.1.0) dist = 1.0
X tangle = de(atan(dz/dist))
Xc
Xc pick smallest angle (needed due to arctan being only in
Xc I and IV quadrants
Xc
X t1 = (tazm - s2)/10.0
X t2 = (tangle - s3)/10.0
X t3 = (tazm - (s2 + 360.0))/10.0
X t4 = (tangle - (s3 + 360.0))/10.0
X t5 = (tazm - (s2 - 360.0))/10.0
X t6 = (tangle - (s3 - 360.0))/10.0
X if (abs(t3).lt.abs(t1)) t1 = t3
X if (abs(t5).lt.abs(t1)) t1 = t5
X if (abs(t4).lt.abs(t2)) t2 = t4
X if (abs(t6).lt.abs(t2)) t2 = t6
X if (reverse) t2 = - t2
Xc
Xc limit rotation angles by max ship ability
Xc
X if (abs(t1).gt.0.6) t1 = sign(0.6, t1)
X if (abs(t2).gt.0.6) t2 = sign(0.6, t2)
Xc
Xc set rotation vars
Xc
X rot_azm(10) = t1
X rot_ang(10) = t2
X end if
X end if
Xc
Xc if rotate then rotate
Xc
X if (rot_azm(r_index).ne.0.0) then
X azm = azm + rot_azm(r_index)
X sa = sin(ra(azm))
X ca = cos(ra(azm))
X end if
X if (rot_ang(r_index).ne.0.0) then
X angle = angle + rot_ang(r_index)
X sp = sin(ra(angle))
X cp = cos(ra(angle))
X end if
X if ((.not.rotate).and.(.not.lock_on)) r_index = 9
Xc
Xc rotate tractored object back to translated galatic coords centered
Xc on ship
Xc
X if (tract_ob.and.tract) then
X if (.not.object(tr_object)) then
X tract_ob = .false.
X b_message(2) = s_message(index(tr_object))
X call strek_message (b_message, 3)
X else
X trazm = trazm + ra(rot_azm(r_index))
X t1 = cos(trazm - ra(azm))
X trangle = trangle + ra(rot_ang(r_index)) * t1
X j = tr_object
X trx = rox(j)*ca - roy(j)*sa*cp + roz(j)*sa*sp + xc
X try = rox(j)*sa + roy(j)*ca*cp - roz(j)*ca*sp + yc
X trz = roy(j)*sp + roz(j)*cp + zc
X end if
X end if
Xc
Xc check that scan object still exists
Xc
X if (.not.(object(scan_ob)).and.(scan_ob.ge.4)) then
X scan_ob = 1
X b_message (2) = s_message(10)
X call strek_message (b_message, 3)
X end if
Xc
Xc check that nav lock on object still exists
Xc
X if (lock_on.and.((.not.object(l_object).or.orange(l_object).lt.
X & 10000.0).or.(.not.scan))) then
X lock_on = .false.
X b_message(2) = 'Navigation lock on lost.'
X call strek_message (b_message, 3)
X r_index = 9
X end if
Xc
Xc apply damage to the player's ship
Xc
X call strek_assess_damage (d_pct, damage, scan, tract, phase,
X & energy, seed)
Xc
Xc get a key if one has been struck
Xc
X unobscured = gpr_$cond_event_wait (event_type, key, c_pos, status)
X if (event_type.ne.gpr_$no_event) then
X call strek_interpret_key (key)
Xc
Xc process a speed key
Xc
X if (key.eq.'a') then
X speed = speed + 0.5
X if (speed.gt.5.0) then
X speed = 5.0
X b_message(2) = s_message(9)
X call strek_message (b_message, 3)
X end if
X else if (key.eq.'s') then
X speed = speed - 0.5
X if (speed.lt.-5.0) then
X speed = -5.0
X b_message(2) = s_message(9)
X call strek_message (b_message, 3)
X end if
X end if
Xc
Xc process a rotate key
Xc
X if (.not.lock_on) then
X if (key.eq.'m') then
X r_index = 9
X else if (key.eq.'b') then
X rotate = .not.rotate
X else
X if (.not.rotate) then
X if (key.eq.'u') then
X r_index = 1
X else if (key.eq.'j') then
X r_index = 2
X else if (key.eq.'h') then
X r_index = 3
X else if (key.eq.'n') then
X r_index = 4
X end if
X else
X if (key.eq.'u') then
X r_index = 5
X else if (key.eq.'j') then
X r_index = 6
X else if (key.eq.'h') then
X r_index = 7
X else if (key.eq.'n') then
X r_index = 8
X end if
X end if
X end if
X end if
Xc
Xc process a tractor beam key
Xc
X if ((key.eq.'t'.and.tract).and.(.not.tract_ob)) then
X call strek_number_objects (pos_store, ran_store, object,
X & .true.)
X call strek_message (t_message, 3)
X i = 0
X 60 continue
X i = i + 1
X unobscured = gpr_$cond_event_wait (event_type, t_key, c_pos,
X & status)
X if (event_type.ne.gpr_$no_event.or.i.gt.3000) goto 70
X goto 60
X 70 continue
X call strek_number_objects (pos_store, ran_store, object,
X & .false.)
X if (event_type.ne.gpr_$no_event) then
X call strek_interpret_key (t_key)
X if ((t_key.eq.'1').or.((t_key.ge.'4').and.(t_key.le.'9')))
X & then
X read (t_key,'(i1)') tr_object
X if (object(tr_object).and.orange(tr_object).lt.9.0e4) then
X tract_ob = .true.
X j = tr_object
X trx = obx(j)
X try = oby(j)
X trz = obz(j)
X trazm = oazm(j)
X trangle = oangle(j)
X trdist = orange(j)
X b_message(2) = u_message(index(j))
X call strek_message (b_message, 3)
X end if
X end if
X end if
X end if
Xc
Xc process a drop tractor key
Xc
X if (key.eq.'r'.and.tract_ob) then
X tract_ob = .false.
X oazm(tr_object) = trazm
X oangle(tr_object) = trangle
X b_message(2) = s_message(7)
X call strek_message (b_message, 3)
X end if
Xc
Xc process an damage information key
Xc
X if (key.eq.'i') then
X call strek_damage_info (d_pct, capt_name, nick_name)
X end if
Xc
Xc process a photon key
Xc
X if (key.eq.'f'.and.(photons.ge.1)) then
X call strek_find_free_ob (object, 7, j, found)
X if (found) then
X object(j) = .true.
X photon_c(j-3) = 0
X photons = photons - 1
X obx(j) = xc
X oby(j) = yc
X obz(j) = zc
X oazm(j) = ra(azm)
X oangle(j) = ra(angle)
X ospeed(j) = 10
X b_message(2) = s_message(8)
X call strek_message (b_message, 3)
X end if
X end if
Xc
Xc process a phaser key
Xc
X if (((key.eq.'p').and.(phase)).and.(energy.gt.30.0)) then
X call strek_number_objects (pos_store, ran_store, object,
X & .true.)
X call strek_message (p_message, 3)
X i = 0
X 80 continue
X i = i + 1
X unobscured = gpr_$cond_event_wait (event_type, t_key, c_pos,
X & status)
X if (event_type.ne.gpr_$no_event.or.i.gt.3000) goto 90
X goto 80
X 90 continue
X call strek_number_objects (pos_store, ran_store, object,
X & .false.)
X if (event_type.ne.gpr_$no_event) then
X call strek_interpret_key (t_key)
X if ((t_key.ge.'0').and.(t_key.le.'9')) then
X read (t_key,'(i1)') ph_object
X if (object(ph_object).and.(orange(ph_object).lt.250000.0))
X & then
X if ((pro_x(ph_object).le.800.and.pro_x(ph_object).ge.
X & 100).and.(pro_y(ph_object).le.700.and.
X & pro_y(ph_object).ge.100)) then
X call strek_draw_phasers (int(pro_x(ph_object)),
X & int(pro_y(ph_object)))
X energy = energy - 30.0
X phase_d = .true.
X phase_c = 0
X phase = .false.
Xc
Xc do damage to other ship
Xc
X call strek_phaser_fire (orange(ph_object), seed,
X & odamage(ph_object), type)
X a_message(1) = ps_message(index(ph_object))
X write (a_message(3),'(a36,a10)') s_message(14),
X & dam_rating(type)
X call strek_message (a_message, 3)
X end if
X end if
X end if
X end if
X end if
Xc
Xc process a explode radius key
Xc
X if (key.eq.'e') then
X call strek_message (e_message, 3)
X i = 0
X100 continue
X i = i + 1
X unobscured = gpr_$cond_event_wait (event_type, t_key, c_pos,
X & status)
X if (event_type.ne.gpr_$no_event.or.i.gt.5000) goto 110
X goto 100
X110 continue
X if (event_type.ne.gpr_$no_event) then
X call strek_interpret_key (t_key)
X if ((t_key.gt.'0').and.(t_key.le.'6')) then
X read (t_key,'(i1)') option
X t1 = 10.0 + 5.0*option
X photon_tr(7) = t1**2
X photon_tr(8) = photon_tr(7)
X photon_tr(9) = photon_tr(7)
X end if
X end if
X end if
Xc
Xc change scanner object keys
Xc
X if (key.ge.'0'.and.key.le.'9') then
X read (key,'(i8)') item
X if (object(item)) then
X scan_ob = item
X b_message(2) = sc_message(index(item))
X call strek_message (b_message, 3)
X end if
X end if
Xc
Xc process a nav lock on key
Xc
X if (key.eq.'l'.and.scan) then
X call strek_message (t_message, 3)
X i = 0
X120 continue
X i = i + 1
X unobscured = gpr_$cond_event_wait (event_type, t_key, c_pos,
X & status)
X if (event_type.ne.gpr_$no_event.or.i.gt.5000) goto 130
X goto 120
X130 continue
X if (event_type.ne.gpr_$no_event) then
X call strek_interpret_key (t_key)
X if (t_key.ge.'0'.and.t_key.le.'3') then
X read (t_key,'(i1)') l_object
X if (object(l_object).and.orange(l_object).gt.22500.0) then
X lock_on = .true.
X b_message(2) = l_message(index(l_object))
X call strek_message (b_message, 3)
X r_index = 10
X nav_c = 10
X end if
X end if
X end if
X end if
Xc
Xc process a nav lock drop key
Xc
X if (key.eq.'o'.and.lock_on) then
X lock_on = .false.
X b_message(2) = 'Navigation lock on dropped.'
X call strek_message (b_message, 3)
X r_index = 9
X end if
Xc
Xc process a dock key
Xc
X if ((key.eq.'d'.and.orange(0).lt.900.0).and.(abs(speed).lt.1))
X & then
X call strek_dock (d_pct, score, capt_name, nick_name,
X & ship_name, cum_score, key_file, new_ship)
X stop
X end if
Xc
Xc process a current score key
Xc
X if (key.eq.'c') then
X write (r_message(1),'(a15,a30)') r_message(1), ship_name
X write (r_message(3),'(i8,i10,i9,i16,2i7)') ship_k, ship_r,
X & ship_n, dock_n, score, cum_score
X call strek_message (r_message, 3)
X end if
Xc
Xc process a clear com window key
Xc
X if (key.eq.'z') then
X b_message(2) = ' '
X call strek_message (b_message, 3)
X end if
Xc
Xc process a sleep until key
Xc
X if (key.eq.'/') then
X call strek_message (sl_message, 3)
X125 continue
X unobscured = gpr_$cond_event_wait (event_type, t_key, c_pos,
X & status)
X if (event_type.ne.gpr_$no_event) goto 135
X goto 125
X135 continue
X b_message(2) = ' '
X call strek_message (b_message, 3)
X end if
Xc
Xc end parsing routines
Xc
X end if
Xc
Xc put angles back to normal (between 0 and 360)
Xc
X if (azm.lt.0.0) azm = azm + 360.0
X if (azm.ge.360.0) azm = azm - 360.0
X if (angle.lt.0.0) angle = angle + 360.0
X if (angle.ge.360.0) angle = angle - 360.0
Xc
Xc add engine energy output
Xc
X energy = energy + .35 * (d_pct(1) + d_pct(2))
Xc
Xc subtract off energy due to speed and rotation
Xc
X energy = energy - abs(speed)/7.5 - rot_cost(r_index)
Xc
Xc subtract energy due to tractors
Xc
X if (tract_ob) then
X energy = energy - sqrt(trdist)/60.0*tr_cost(tr_object) +0.1
X end if
Xc
Xc limit energy by battery percent
Xc
X check = d_pct(4)*1000.0
X if (energy.gt.check) energy = check
Xc
Xc if out of energy start (or continue) death march
Xc
X if (energy.lt.0.0) then
X num_times = num_times + 1
X call strek_no_energy (num_times, capt_name, nick_name,
X & ship_name, key_file, score, cum_score,
X & new_ship)
X else
X num_times = 0
X end if
Xc
Xc process new coordinates
Xc
X tempx = xc
X tempy = yc
X tempz = zc
X xc = -sa * cp * speed + xc
X yc = ca * cp * speed + yc
X zc = sp * speed + zc
X do 150 j = 0,9
X if (object(j)) then
X if (j .ne. 0) then
X soa(j) = sin(oazm(j))
X coa(j) = cos(oazm(j))
X sop(j) = sin(oangle(j))
X cop(j) = cos(oangle(j))
X obx(j) = -soa(j) * cop(j) * ospeed(j) + obx(j)
X oby(j) = coa(j) * cop(j) * ospeed(j) + oby(j)
X obz(j) = sop(j) * ospeed(j) + obz(j)
X end if
X xt(j) = obx(j) - xc
X yt(j) = oby(j) - yc
X zt(j) = obz(j) - zc
X orange(j) = xt(j)**2 + yt(j)**2 + zt(j)**2
X end if
X150 continue
Xc
Xc update tractored object
Xc
X if (tract_ob.and.tract) then
X trx = trx - tempx + xc
X try = try - tempy + yc
X trz = trz - tempz + zc
X j = tr_object
X obx(j) = trx
X oby(j) = try
X obz(j) = trz
X oazm(j) = trazm
X oangle(j) = trangle
X xt(j) = obx(j) - xc
X yt(j) = oby(j) - yc
X zt(j) = obz(j) - zc
X orange(j) = xt(j)**2 + yt(j)**2 + zt(j)**2
X trdist = orange(j)
X end if
Xc
Xc get object to object distances when both exist
Xc
X do 160 j = 0,9
X if (object(j)) then
X do 170 i = 1,3
X if (object(i).and.i.ne.j) then
X distance(i,j) = (obx(i) - obx(j))**2 + (oby(i) -
X & oby(j))**2 + (obz(i) - obz(j))**2
X end if
X170 continue
X end if
X160 continue
Xc
Xc rotate objects into shipocentric coordinates
Xc
X do 180 j = 0,9
X if (object(j)) then
X rox(j) = xt(j) * ca + yt(j) * sa
X roy(j) = -xt(j) * sa * cp + yt(j) * ca * cp + zt(j) * sp
X roz(j) = xt(j) * sa * sp - yt(j) * ca * sp + zt(j) * cp
Xc
Xc project shiopcentric coordinates to screen coords
Xc
X if (roy(j).gt.1.0) then
X pro_x(j) = 450.0 + (rox(j)/roy(j)) * 350.0
X pro_y(j) = 400.0 - (roz(j)/roy(j)) * 350.0
X if (abs(pro_x(j)).gt.3000.0) pro_x(j) = 1000.0
X if (abs(pro_y(j)).gt.3000.0) pro_y(j) = 1000.0
X else
X pro_x(j) = 1000.0
X pro_y(j) = 1000.0
X if (j .eq. 2) then
X center(1) = 1000
X center(2) = 1000
X end if
X end if
Xc
Xc fill temporary array for use in scanner windows
Xc
X pos_store(j,1) = pro_x(j)
X pos_store(j,2) = pro_y(j)
X end if
X180 continue
Xc
Xc erase old objects
Xc
X call gpr_$set_draw_value (0, status)
X if (refresh) then
X call strek_scanner (rox, roy, roz, object, .false.)
X end if
X if (plot(0)) then
X call strek_starbase (xc, yc, zc, ca, cp, sa, sp, .false.)
X end if
X do 190 j = 1, 9
X if (plot(j)) then
X goto (191, 192, 193, 194, 195, 196, 197, 198, 199) j
X191 continue
X call strek_nemian (xc, yc, zc, obx(j), oby(j), obz(j), ca,
X & sa, cp, sp, .false., soa(j), coa(j),
X & sop(j), cop(j))
X goto 190
X192 continue
X if (kling(j)) then
X call strek_klingon (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .false., center,
X & soa(j), coa(j), sop(j), cop(j))
X else
X call strek_romulan_1 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .false., soa(j),
X & coa(j), sop(j), cop(j))
X end if
X goto 190
X193 continue
X call strek_romulan_2 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .false., soa(j),
X & coa(j), sop(j), cop(j))
X goto 190
X194 continue
X call strek_photon_1 (xc, yc, zc, obx(j), oby(j), obz(j), ca,
X & sa, cp, sp, .false.)
X goto 190
X195 continue
X call strek_photon_2 (xc, yc, zc, obx(j), oby(j), obz(j), ca,
X & sa, cp, sp, .false.)
X goto 190
X196 continue
X call strek_photon_3 (xc, yc, zc, obx(j), oby(j), obz(j), ca,
X & sa, cp, sp, .false.)
X goto 190
X197 continue
X call strek_photon_4 (xc, yc, zc, obx(j), oby(j), obz(j), ca,
X & sa, cp, sp, .false.)
X goto 190
X198 continue
X call strek_photon_5 (xc, yc, zc, obx(j), oby(j), obz(j), ca,
X & sa, cp, sp, .false.)
X goto 190
X199 continue
X call strek_photon_6 (xc, yc, zc, obx(j), oby(j), obz(j), ca,
X & sa, cp, sp, .false.)
X goto 190
X end if
X190 continue
Xc
Xc update screen objects
Xc
X call gpr_$set_draw_value (1, status)
X if (refresh) then
X call strek_scanner (rox, roy, roz, object, .true.)
X end if
X refresh = .not. refresh
X do 200 j = 0,9
X plot(j) = .false.
X ran_store(j) = orange(j)
X if (object(j).and.orange(j).lt.4000000.0) then
X if ((pro_x(j).lt.900.0).and.(pro_x(j).gt.0.0)) then
X if ((pro_y(j).lt.800.0).and.(pro_y(j).gt.0.0)) then
X plot(j) = .true.
X if (j.eq.0) then
X call strek_starbase (xc, yc, zc, ca, cp, sa, sp,
X & .true.)
X else
X goto (201, 202, 203, 204, 205, 206, 207, 208, 209) j
X201 continue
X call strek_nemian (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .true., soa(j),
X & coa(j), sop(j), cop(j))
X goto 200
X202 continue
X if (kling(j)) then
X call strek_klingon (xc, yc, zc, obx(j), oby(j),
X & obz(j), ca, sa, cp, sp, .true.,
X & center, soa(j), coa(j), sop(j),
X & cop(j))
X else
X call strek_romulan_1 (xc, yc, zc, obx(j), oby(j),
X & obz(j), ca, sa, cp, sp, .true.,
X & soa(j), coa(j), sop(j), cop(j))
X end if
X goto 200
X203 continue
X call strek_romulan_2 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .true., soa(j),
X & coa(j), sop(j), cop(j))
X goto 200
X204 continue
X call strek_photon_1 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .true.)
X goto 200
X205 continue
X call strek_photon_2 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .true.)
X goto 200
X206 continue
X call strek_photon_3 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .true.)
X goto 200
X207 continue
X call strek_photon_4 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .true.)
X goto 200
X208 continue
X call strek_photon_5 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .true.)
X goto 200
X209 continue
X call strek_photon_6 (xc, yc, zc, obx(j), oby(j), obz(j),
X & ca, sa, cp, sp, .true.)
X goto 200
X end if
X end if
X end if
X end if
X200 continue
Xc
Xc draw center of the screen crosshairs
Xc
X call strek_x_hairs
Xc
Xc update panels
Xc
X if (scan) then
X txc = nint(rox(scan_ob))
X tyc = nint(roy(scan_ob))
X tzc = nint(roz(scan_ob))
X trange = nint(sqrt(orange(scan_ob)))
X end if
X rate = speed * 2
X call strek_update_panel (rate, int(energy), photons, phase,
X & tract_ob, int(xc), int(yc), int(zc),
X & scan, txc, tyc, tzc, trange, scan_ob)
X call strek_flashers (object, lock_on, energy, bitmap_desc)
Xc
Xc evaluate the turn duration, if it is shorter than the
Xc minimum (which is .06 seconds) then request it again.
Xc Since this call is slow it makes an ideal timer.
Xc
X210 continue
X call time_$clock (timer)
X call cal_$float_clock (timer, turn)
X duration = turn - elapsed
X if (duration.gt.0.06) then
X elapsed = turn
X goto 10
X end if
X goto 210
X end
X
X
X
X
E!O!F! xstrek/original_code/strek_main.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