Super Startrek

The startrek program is one of the games in the famous 101 BASIC Computer Games published in 1978. In the book it is called 'Super Startrek' and the code available in Vintage BASIC. I have rewritten it in Pascal. It relies on two external procedures to create random numbers as the standard library doesn't have that functionality.

Use of non-standard procedures and functions:

OS-9 Pascal edition

{
SUPER STARTREK - MAY 16,1978

****        **** STAR TREK ****        ****
**** SIMULATION OF A MISSION OF THE STARSHIP ENTERPRISE,
**** AS SEEN ON THE STAR TREK TV SHOW.
**** ORIGINAL PROGRAM BY MIKE MAYFIELD, MODIFIED VERSION
**** PUBLISHED IN DEC'S '101 BASIC GAMES', BY DAVE AHL.
**** MODIFICATIONS TO THE LATTER (PLUS DEBUGGING) BY BOB
*** LEEDOM - APRIL & DECEMBER 1974,
*** WITH A LITTLE HELP FROM HIS FRIENDS . . .
}

program startrek(input);

const
  ORGTORPS = 10;
  K_ENERGY = 200;
  E_ENERGY = 3000; { Enterprise initial energy }

  DMG_NAV = 1;
  DMG_SRS = 2;
  DMG_LRS = 3;
  DMG_PHA = 4;
  DMG_TOR = 5;
  DMG_DAM = 6;
  DMG_SHE = 7;
  DMG_COM = 8;

type
  klingon_t = record
      sectx,secty:integer;
      energy:real
    end;
  feature = array [1..3] of char;
  command = array [1..3] of char;
  qname = array [1..15] of char;
  roman = array [1..4] of char;

var
  randstate : integer;
  startdate,time : real;
  gameison : boolean;
  quadrant : array[1..8,1..8] of feature;
  galaxy,known : array [1..8,1..8] of integer;
  c : array [1..9,1..2] of integer;
  k : array [1..3] of klingon_t;
  dmg : array[1..8] of real;
  cmd : command;
  shield, torpedos, energy, eneed, duration,starbases : integer;
  orgklings, klingons : integer;
  k3,s3,b3 : integer;
  s1,s2,sb1,sb2 : integer;
  d4 : real;  { Extra repair time }
  q1,q2: integer;
  docked : boolean;

{ Returns a random number between 0.0 and 1.0 }
function random(var block:integer) : real; external;
procedure randomize(var block:integer); external;

{ Provide a random real 0 <= x < 1 }
function rnd1:real;
  begin
    rnd1 := random(randstate);
  end;

{ Provide a random integer 0 <= x < maxval }
function rnd(maxval:integer):integer;
  begin
    rnd := trunc(random(randstate) * maxval);
  end;

{ Return a random integer between 1 and 8 }
function rnd8i:integer;
  begin
    rnd8i := rnd(8) + 1;
  end;

{ Print N lines }
procedure lines(n: integer);
  var i: integer;
  begin
    For i:=1 to n do writeln
  end;

{ Print N spaces }
procedure tab(num:integer);
  var
    i:integer;
  begin
    for i := 1 to num do
      write(' ');
  end;

{ Insert in string array for quadrant }
procedure insertfeature(a: feature; z1,z2: integer);
  begin
    quadrant[z1,z2] := a
  end;

{ See if the sector contains this feature }
function checkfeature(a: feature; z1,z2: integer) : boolean;
  begin
    checkfeature := false;
    if quadrant[z1,z2] = a then
        checkfeature := true;
  end;

{ Find empty place in quadrant (for things) }
procedure findempty(var r1,r2:integer);
  begin
    repeat
      r1 := rnd8i;
      r2 := rnd8i;
    until checkfeature('   ', r1, r2);
  end;

procedure inputerr;
  begin
    writeln('** Input error - reenter **');
    readln(input)
  end;

{ Read up to three letters from the user followed by newline }
procedure readcommand(var cmd:command);
  label 999;
  var
    i: integer;
  begin
    cmd := '   ';
    prompt;  { flush output }
    i := 1;
    while (i <= 3) and not eoln do
      begin
        read(cmd[i]);
        if ord(cmd[i]) = 32 then goto 999;
        i := i + 1
      end;
    readln;
  999:
  end;

{ Read integer coordinate separated by a comma }
procedure readcoord(var x,y:integer);
  var
    r : integer;
    comma: char;
  begin
    prompt;  { flush output }
    repeat
      ioabort(input, false);
      readln(x, comma, y);
      r := ioresult(input);
      ioabort(input, true);
      if r <> 0 then
        inputerr;
      if comma <> ',' then
        begin
          inputerr;
          r := 20; { Comma expected }
        end;
    until r = 0;
  end;

{ Read a y/n answer. Returns lowercase }
procedure readyesno(var yesno:char);
  begin
    prompt;  { flush output }
    readln(yesno);
    if (yesno >= 'A') and (yesno <= 'Z') then
      yesno := chr(ord(yesno) - ord('A') + ord('a'));
  end;

{ Read a floating point number }
procedure readreal(var value:real);
  var
    r : integer;
  begin
    prompt;  { flush output }
    repeat
      ioabort(input, false);
      readln(value);
      r := ioresult(input);
      ioabort(input, true);
      if r <> 0 then
        inputerr;
    until r = 0;
  end;

{ Read an integer }
procedure readint(var value:integer);
  var
    r : integer;
  begin
    prompt;  { flush output }
    repeat
      ioabort(input, false);
      readln(value);
      r := ioresult(input);
      ioabort(input, true);
      if r <> 0 then
        inputerr;
    until r = 0;
  end;

{ Find the last letter in the string }
function lastletter(st : qname) : integer;
  label 100;
  var
    i : integer;
  begin
    lastletter := 0;
    for i := 15 downto 1 do
      if st[i] <> ' ' then
        begin
          lastletter := i;
          goto 100
        end;
    100:
  end;

{ Write a quadrant name, but without final spaces }
procedure trimwrite(st: qname);
  var
    last,i : integer;
  begin
    last := lastletter(st);
    for i := 1 to last do
      write(st[i]);
  end;

{ End of game }
procedure resign;
  begin
    gameison := false;
    if klingons > 0 then
      begin
        writeln('There were ',klingons:1,' Klingon battle cruisers left at');
        writeln('the end of your mission.');
      end;
    writeln;
    writeln;
  end;

procedure outoftime;
  begin
    writeln('It is stardate ',time:6:1,'.');
    resign;
  end;

procedure destruction;
  begin
    writeln;
    writeln('The Enterprise has been destroyed.  Then federation will be conquered.');
    outoftime;
  end;

procedure wongame;
  begin
    gameison := false;
    writeln('Congratulation, captain!  The last Klingon battle cruiser');
    writeln('menacing the federation has been destroyed.');
    writeln;
    writeln('Your efficiency rating is ', 1000*sqr(orgklings/(time-startdate)):3:2);
    resign;
  end;

procedure initquadrant;
  var
    i,j : integer;
  begin
    for i := 1 to 8 do
      for j := 1 to 8 do
        quadrant[i,j] := '   ';
  end;

function distance(dX,dY:integer):real;
  begin
    distance := sqrt(sqr(dY) + sqr(dX))
  end;

function direction(dX,dY:integer):real;

  function horiz(h:real):real;
    begin
     if abs(dX)<=abs(dY) then
        horiz := h + (abs(dX)/abs(dY))
      else
        horiz := h + (((abs(dX)-abs(dY))+abs(dX)) / abs(dX));
    end;

  function verti(h:real):real;
    begin
      if abs(dX)>=abs(dY) then
        verti := h + (abs(dY)/abs(dX))
      else
        verti := h + (((abs(dY)-abs(dX))+abs(dY)) / abs(dY));
    end;

  begin
    dY := -dY;
    if dY<0 then
      begin
        if dX>0 then
          direction := verti(3)
        else if dY<>0 then
          direction := horiz(5)
        else
          direction := verti(7)
      end
    else if dX<0 then
      direction := verti(7)
    else if dY>0 then
      direction := horiz(1)
    else if dX=0 then
      direction := horiz(5)
    else { dY = 0 and dX >= 0 }
      direction := horiz(1);
  end;

procedure dirdist(dX,dY:integer);
  begin
    writeln('Direction = ', direction(dX,dY):6:5);
    writeln('Distance = ', distance(dX,dY):6:5)
  end;

{ Return quadrant name from Q1,Q2
  Call with NAMEONLY=TRUE to get region name only }
procedure namequadrant(q1,q2: integer; nameonly: boolean; var name: qname);
  var
    tmp : qname;

  { Append Roman numeral to string }
  procedure appendnum(var name: qname; num: roman);
    var
      last,i : integer;
    begin
      last := lastletter(name);
      for i := 1 to 4 do
        name[last + i] := num[i];
    end;

  begin
    If q2 <= 4 then
      case q1 of
        1: tmp := 'ANTARES        ';
        2: tmp := 'RIGEL          ';
        3: tmp := 'PROCYON        ';
        4: tmp := 'VEGA           ';
        5: tmp := 'CANOPUS        ';
        6: tmp := 'ALTAIR         ';
        7: tmp := 'SAGITTARIUS    ';
        8: tmp := 'POLLUX         '
      end
    else
      case q1 of
        1: tmp := 'SIRIUS         ';
        2: tmp := 'DENEB          ';
        3: tmp := 'CAPELLA        ';
        4: tmp := 'BETELGEUSE     ';
        5: tmp := 'ALDEBARAN      ';
        6: tmp := 'REGULUS        ';
        7: tmp := 'ARCTURUS       ';
        8: tmp := 'SPICA          '
      end;
    if nameonly = false then
      case q2 of
        1,5: appendnum(tmp, ' I  ');
        2,6: appendnum(tmp, ' II ');
        3,7: appendnum(tmp, ' III');
        4,8: appendnum(tmp, ' IV ')
      end;
      name := tmp
  end;

{ Here any time new quadrant entered }
procedure newquadrant;
  var
    i,j : integer;
    g2: qname;
    r1, r2: integer;
  begin
    k3 := 0;
    b3 := 0;
    s3 := 0;
    d4 := 0.5 * rnd1;
    known[q1,q2] := galaxy[q1,q2];
    namequadrant(q1,q2,false,g2);
    writeln;
    if startdate <> time then
      begin
        write('Now entering ');
        trimwrite(g2);
        writeln(' quadrant . . .')
      end
    else
      begin
        writeln('Your mission begins with your starship located');
        write('in the galactic quadrant, ');
        trimwrite(g2);
        writeln('.');
      end;
    writeln;
    k3 := galaxy[q1,q2] div 100;
    b3 := galaxy[q1,q2] div 10 - 10*k3;
    s3 := galaxy[q1,q2] - 100*k3 - 10*b3;
    if k3 > 0 then
      begin
        writeln('Combat area      Condition RED');
        if shield<=200 then
          writeln('   Shields dangerously low');
      end;
    for i := 1 to 3 do
      begin
        k[i].sectx := 0;
        k[i].secty := 0;
        k[i].energy := 0
      end;

    for i := 1 to 8 do
      for j := 1 to 8 do
        quadrant[i,j] := '   ';

  { Position Enterprise in quadrant, then place 'K3' klingons, &
    'B3' starbases, & 'S3' stars elsewhere. }
    insertfeature('<*>', s1, s2);
    if k3>0 then
      for i := 1 to k3 do
        begin
          findempty(r1,r2);
          insertfeature('+K+', r1, r2);
          k[i].sectx := r1;
          k[i].secty := r2;
          k[i].energy := K_ENERGY * (0.5 + rnd1)
        end;

    if b3>0 then
      begin
        findempty(sb1,sb2);
        insertfeature('>!<', sb1, sb2)
      end;
    for i := 1 to s3 do
      begin
        findempty(r1,r2);
        insertfeature(' * ', r1, r2)
      end;
  end;

{ Print device name and return length }
function writedevice(rd: integer):integer;
  begin
    case rd of
      1: begin write('Warp engines'); writedevice := 12 end;
      2: begin write('Short range sensors'); writedevice := 19 end;
      3: begin write('Long range sensors'); writedevice := 18 end;
      4: begin write('Phaser control'); writedevice := 14 end;
      5: begin write('Photon tubes'); writedevice := 12 end;
      6: begin write('Damage control'); writedevice := 14 end;
      7: begin write('Shield control'); writedevice := 14 end;
      8: begin write('Library-computer'); writedevice := 16 end;
    end
  end;

{ Maneuver energy s/r **}
procedure useenergy;
  begin
    energy := energy-eneed-10;
    if energy < 0 then
      begin
        writeln('Shield control supplies energy to complete the maneuver.');
        shield := shield+energy;
        energy := 0;
        if shield <= 0 then shield := 0;
      end;
  end;

{ Short range sensor scan & startup subroutine }
procedure shortrange;
  var
    cs : array[1..6] of char;
    i,j : integer;
    z3 : boolean;
  begin
    docked := false;
    if k3 > 0 then
      cs := '*RED* '
    else
      begin
        cs := 'GREEN ';
        if energy < E_ENERGY * 0.1 then
          cs := 'YELLOW';
      end;
    for i := s1-1 to s1+1 do
      for j := s2-1 to s2+1 do
        if (i>0) and (i<=8) and (j>0) and (j<=8) then
          begin
            z3 := checkfeature('>!<', i, j);
            if z3 = true then
              begin
                docked := true ;
                cs := 'DOCKED';
                energy := E_ENERGY;
                torpedos := ORGTORPS;
                writeln('Shields dropped for docking purposes');
                shield := 0
              end
          end;
    
    if dmg[DMG_SRS]<0 then
      begin
        writeln;
        writeln('*** SHORT RANGE SENSORS ARE OUT ***');
        writeln;
      end
    else
      begin
        writeln('---1---2---3---4---5---6---7---8---');
        for i := 1 to 8 do
          begin
            write(i:1);
              for j := 1 to 8 do
                write(' ', quadrant[i,j]);
            write(' ',i:1);
            case i of
              1: writeln('     Stardate           ',time:6:1);
              2: writeln('     Condition          ',cs);
              3: writeln('     Quadrant           ',q1:1,',',q2:1);
              4: writeln('     Sector             ',s1:1,',',s2:1);
              5: writeln('     Photon torpedoes   ',torpedos:1); 
              6: writeln('     Total energy       ',energy+shield:4);
              7: writeln('     Shields            ',shield:1);
              8: writeln('     Klingons remaining ',klingons:1);
            end
          end;
        writeln('---1---2---3---4---5---6---7---8---');
      end;
  end;


procedure placeship(w1:real);
  var
    t8:real; { Time of Travelling }
  begin
    insertfeature('<*>', s1, s2);
    useenergy;
    t8 := 1;
    if w1<1 then
      t8 := 0.1 * aint(10*w1);
    time := time+t8;
    if time > startdate + duration then outoftime;
    { See if docked, then get command }
    shortrange;
  end;

function phasereffect(energy:real; num:integer):real;
  var
    dx,dy : integer;
  begin
    dx := k[num].sectx - s1;
    dy := k[num].secty - s2;
    phasereffect := (k[num].energy / distance(dx, dy)) * (rnd1 + 2);
  end;

{ KLINGONS SHOOTING }
procedure enemyfire;
  label 4,5;
  var
    i,l,rd: integer;
    h: real;
  begin
    if k3<=0 then goto 5;

    if docked=true then
      begin
        writeln('Starbase shields protect the enterprise');
        goto 5;
      end;

    for i := 1 to 3 do
      begin
        if k[i].energy <= 0 then goto 4;

        h := phasereffect(k[i].energy,i);
        shield := shield - round(h);
        k[i].energy := k[i].energy/(3 + rnd1);
        writeln(h:3:0,' unit hit on Enterprise from sector ',k[i].sectx:1,',',k[i].secty:1);
        if shield <= 0 then begin destruction; goto 5 end;
        writeln('      <SHIELDS DOWN TO ',shield:1,' UNITS>');
        if h < 20 then goto 4;
        if (rnd1 > 0.6) or (h/shield <= 0.02) then goto 4;
        rd := rnd8i;
        dmg[rd] := dmg[rd]-h/shield - 0.5*rnd1;
        write('Damage control reports:    ''');
        l := writedevice(rd);
        writeln(' damaged by the hit''');
      4:
      end;
  5:
  end;

{ Make repairs while travelling. D6 is distance }
procedure repairs(d6:real);
  var
    header : boolean;
    i,l : integer;
  begin
    header := false;
    if d6 >= 1 then d6 := 1;

    for i := 1 to 8 do
      begin
        if dmg[i] < 0 then
          begin
            dmg[i] := dmg[i] + d6;
            if (dmg[i] > -0.1) and (dmg[i] < 0) then
              dmg[i] := -0.1;
            if dmg[i] >= 0 then
              begin
                if header = false then
                  begin
                    header := true;
                    write('Damage control report:  ')
                  end;
                tab(8);
                l := writedevice(i);
                writeln(' repair completed.')
              end
          end
      end
  end;

procedure vector(course:real; var x1,x2:real);
  var
    j:integer;
  begin
    j := round(course - 0.5);
    x1 := c[j,1] + (c[j+1,1]-c[j,1]) * (course-j);
    x2 := c[j,2] + (c[j+1,2]-c[j,2]) * (course-j);
  end;

{ Course control begins here }
procedure coursecontrol;
  label 3360,3370;
  var
    i,l,rd: integer;
    sX: array [1..3] of char;
    c1,x,y,x1,x2, w1: real;
    z3 : boolean;
    q4,q5: integer;

  {Exceeded quadrant limits }
  procedure exceedquadrant(x1,x2,w1:real); 
    label 9;
    var
      x,y: real;
      x5: boolean;
    begin
      x := 8*q1 + s1 + eneed*x1;
      y := 8*q2 + s2 + eneed*x2;
      q1 := round(x/8 - 0.5);
      q2 := round(y/8 - 0.5);
      s1 := round(x-q1*8);
      s2 := round(y-q2*8);
      if s1=0 then begin q1 := q1-1 ; s1 := 8 end;
      if s2=0 then begin q2 := q2-1 ; s2 := 8 end;

      x5 := false;
      if q1<1 then begin x5 := true ; q1 := 1 ; s1 := 1 end;
      if q1>8 then begin x5 := true ; q1 := 8 ; s1 := 8 end;
      if q2<1 then begin x5 := true ; q2 := 1 ; s2 := 1 end;
      if q2>8 then begin x5 := true ; q2 := 8 ; s2 := 8 end;
      if x5=true then
        begin
          writeln('Lt. Uhura reports message from starfleet command:');
          writeln('  ''Permission to attempt crossing of galactic perimeter');
          writeln('  is hereby *DENIED*.  Shut down your engines.''');
          writeln('Chief engineer Scott reports  ''Warp engines shut down');
          writeln('  at sector ',s1:1,',',s2:1,' of quadrant ',q1:1,',',q2:1,'.''');
          if time > startdate + duration then begin outoftime; goto 9 end;
        end;

      if 8*q1+q2 = 8*q4+q5 then
        placeship(w1)
      else
        begin
          time := time + 1;
          useenergy;
          newquadrant;
          shortrange;
        end;
    9:
    end;

  procedure enemymove;
    var
      i : integer;
      r1, r2: integer;
    begin
      for i := 1 to k3 do
        if k[i].energy <> 0 then
          begin
            insertfeature('   ', k[i].sectx, k[i].secty);
            findempty(r1,r2);
            k[i].sectx := r1;
            k[i].secty := r2;
            insertfeature('+K+', r1, r2);
          end;
    end;

  begin
    write('Course (1-9)? ');
    readreal(c1);
    If c1 = 9 then c1 := 1;

    if (c1 < 1) or (c1 > 9) then
      begin
        writeln('   Lt. Sulu reports, ''Incorrect course data, sir!''');
        goto 3370
      end;

    write('Warp factor (0-');
    if dmg[DMG_NAV] < 0 then write('0.2') else write('8');
    write('):? ');
    readreal(w1);
    if (dmg[DMG_NAV] < 0) and (w1 > 0.2) then
      begin
        writeln('Warp engines are damaged.  Maxium speed = warp 0.2');
        goto 3370
      end;
    if w1 = 0 then
      goto 3370;

    if (w1 < 0) or (w1 > 8) then
      begin
        writeln('   Chief engineer scott reports ''The engines won''t take warp ', w1:1:1,'!''');
        goto 3370
      end;
    eneed := round(w1 * 8);
    if energy-eneed < 0 then
      begin
        writeln('Engineering reports   ''Insufficient energy available');
        writeln('                       for maneuvering at warp ',w1:1,'!''');
        if (shield < eneed-energy) or (dmg[DMG_SHE] < 0) then
          goto 3370;
        writeln('Deflector control room acknowledges ',shield,' units of energy');
        writeln('                         presently deployed to shields.');
        goto 3370;
      end;

    { Klingons move/fire on moving starship . . . }
    enemymove;
    enemyfire;
    repairs(w1);

    if rnd1 < 0.2 then
      begin
        rd := rnd8i;
        write('Damage control report:  ');
        l := writedevice(rd);
        if rnd1 >= 0.6 then
          begin
            dmg[rd] := dmg[rd]+rnd(3)+1;
            writeln(' state of repair improved')
          end
        else
          begin
            dmg[rd] := dmg[rd]-(rnd(5)+1);
            writeln(' damaged')
          end;
        writeln;
      end;

{ Begin moving starship }
    insertfeature('   ', s1, s2);
    x := s1;
    y := s2;
    vector(c1, x1, x2);
    q4 := q1;
    q5 := q2;

    for i := 1 to eneed do
      begin
        x := x+x1;
        y := y+x2;
        if (x<1) or (x>=9) or (y<1) or (y>=9) then
          begin
            exceedquadrant(x1,x2,w1);
            goto 3370
          end;
        z3 := checkfeature('   ', round(x - 0.5), round(y - 0.5));
        if z3=false then
          begin
            x := round(x-x1 - 0.5);
            y := round(y-x2 - 0.5);
            write('Warp engines shut down at ');
            writeln('sector ',x:1:0,',',y:1:0,' due to bad navigation');
            goto 3360
          end;
      end;
3360:
    s1 := round(x - 0.5);
    s2 := round(y - 0.5);
    placeship(w1);
3370:
  end;
 
{ Print a value with prefixed zeros }
procedure zeroprint(val : integer);
  var
    d:integer;
  begin
    d := val div 100;
    val := val mod 100;
    write(d:1);
    d := val div 10;
    val := val mod 10;
    write(d:1,val:1);
  end;

{ Long range sensor scan code }
procedure longrange;
  var
    i,j,l: integer;
    n : array [1..3] of integer; { Known quadrants }
  begin
    if dmg[DMG_LRS]<0 then
      writeln('Long range sensors are inoperable')
    else
      begin
        writeln('Long range scan for quadrant ',q1:1,',',q2:1);
        writeln('-------------------');
        for i := q1-1 to q1+1 do
          begin
            n[1] := -1;
            n[2] := -2;
            n[3] := -3;
            for j := q2-1 to q2+1 do
              if (i>0) and (i<9) and (j>0) and (j<9) then
                begin
                  n[j-q2+2] := galaxy[i,j];
                  known[i,j] := galaxy[i,j]
                end;
            for l := 1 to 3 do
              begin
                write(': ');
                if n[l] < 0 then
                  write('*** ')
                else
                  begin
                    zeroprint(n[l]);
                    write(' ')
                  end;
              end;
            writeln(':')
          end;
        writeln('-------------------')
      end;
  end;

procedure noklingons;
  begin
    writeln('Science officer Spock reports  ''Sensors show no enemy ships');
    writeln('                                in this quadrant''');
  end;

procedure updatequadrant;
  begin
    galaxy[q1,q2] := k3*100 + b3*10 + s3;
    known[q1,q2] := galaxy[q1,q2];
  end;

procedure killklingon(i:integer);
  begin
    writeln('*** KLINGON DESTROYED ***');
    k3 := k3-1;
    klingons := klingons-1;
    insertfeature('   ', k[i].sectx, k[i].secty);
    k[i].energy := 0;
    updatequadrant;
  end;

{ Phaser control code begins here }
procedure phaser;
  label 4670,4680;
  var
    i,h,tofire: integer;
    h1: real;
  begin
    if dmg[DMG_PHA]<0 then
      begin
        writeln('Phasers inoperative');
        goto 4680
      end;

    if k3<=0 then
      begin
        noklingons;
        goto 4680
      end;

    if dmg[DMG_COM]<0 then
      writeln('Computer failure hampers accuracy');
    write('Phasers locked on target;  ');

    repeat
      writeln('Energy available = ',energy:4,' units');
      write('Number of units to fire? ');
      readint(tofire);
      if tofire<=0 then
        begin
          writeln('Phaser fire cancelled');
          goto 4680;
        end;
    until energy >= tofire;
    energy := energy - tofire;
    if dmg[DMG_COM]<0 then tofire := round(tofire * rnd1);

    h1 := tofire / k3;
    for i := 1 to 3 do
      begin
        if k[i].energy <= 0 then goto 4670;
        h := round(phasereffect(h1, i));
        if h <= 0.15 * k[i].energy then
          writeln('Sensors show no damage to enemy at ',k[i].sectx:1,',',k[i].secty:1)
        else
          begin
            k[i].energy := k[i].energy - h;
            writeln(h:1,' Unit hit on klingon at sector ',k[i].sectx:1,',',k[i].secty:1);
            if k[i].energy <= 0 then
              begin
                killklingon(i);
                if klingons<=0 then wongame;
              end
            else
              writeln('   (Sensors show ',round(k[i].energy):1,' units remaining)');
          end;
      4670:
      end;
      enemyfire;
    4680:
  end;

{ Photon torpedo code begins here }
procedure firetorpedo;
  label 4760,5190,5430,5500;
  var
    i,x3,y3:integer;
    c1,x,y,x1,x2:real;
    z3 : boolean;
  begin
    if torpedos<=0 then
      begin
        writeln('All photon torpedoes expended');
        goto 5500
      end;

    if dmg[DMG_TOR]<0 then
      begin
        writeln('Photon tubes are not operational');
        goto 5500
      end;
    4760:
    write('Photon torpedo course (1-9) ');
    readreal(c1);
    if c1 = 9 then c1 := 1;
    if (c1<1) or (c1>9) then
      begin
        writeln('Ensign Chekov reports,  ''Incorrect course data, sir!''');
        goto 5500
      end;
    energy := energy-2;
    torpedos := torpedos-1;
    vector(c1, x1, x2);
    x := s1;
    y := s2;
    writeln('Torpedo track:');

    repeat
      x := x + x1;
      y := y + x2;
      x3 := round(x);
      y3 := round(y);
      if (x3<1) or (x3>8) or (y3<1) or (y3>8) then
        begin
          writeln('Torpedo missed');
          enemyfire;
          goto 5500
        end;
      writeln('               ',x3:1,',',y3:1);
      z3 := checkfeature('   ', x3, y3);
    until z3=false;
  { We have now hit something }
    z3 := checkfeature('+K+', x3, y3);
    if z3=true then
      begin
        for i := 1 to 3 do
          if (x3=k[i].sectx) and (y3=k[i].secty) then goto 5190;
        i := 3; { Couldn't find the klingon }
        5190:
        killklingon(i);
        if klingons<=0 then wongame;
        goto 5430
      end;
    z3 := checkfeature(' * ', x3, y3);
    if z3=true then
      begin
        writeln('Star at ',x3:1,',',y3:1,' absorbed torpedo energy.');
        goto 5430
      end;

    z3 := checkfeature('>!<', x3, y3);
    if z3=true then
    begin
      writeln('*** STARBASE DESTROYED ***');
      b3 := b3-1;
      starbases := starbases-1;
      insertfeature('   ', x3, y3);
      updatequadrant;
      if (starbases > 0) or (klingons > time - startdate - duration) then
        begin
          writeln('Starfleet command reviewing your record to consider');
          writeln('court martial!');
          docked := false
        end
      else
        begin
          writeln('That does it, captain!!  You are hereby relieved of command');
          writeln('and sentenced to 99 stardates at hard labor on cygnus 12!!');
          resign;
          goto 5500
        end;
    end;
    5430:
    enemyfire;
  5500:
  end;

{ Shield control }
procedure shieldcontrol;
  label 2;
  var
    newval : integer;
  begin
    if dmg[DMG_SHE]<0 then
      begin
        writeln('Shield control inoperable');
        goto 2
      end;
    write('Energy available = ',energy+shield:4);
    write(' Number of units to shields? ');
    readint(newval);
    if (newval<0) or (shield=newval) then
      begin
        writeln('<SHIELDS UNCHANGED>');
        goto 2
      end;

    if newval > energy+shield then
      begin
        writeln('Shield control reports  ''This is not the federation treasury.''');
        writeln('<SHIELDS UNCHANGED>');
      end
    else
      begin
        energy := energy+shield-newval;
        shield := newval;
        writeln('Deflector control room report:');
        writeln('  ''Shields now at ',shield:1,' units per your command.''');
      end;
  2:
  end;

{ DAMAGE CONTROL }
procedure damagecontrol;
  label 5720,5910,5980;
  var
    repairyn : char;
    l, i,rd : integer;
    estimate : real;
  begin
    if dmg[DMG_DAM]>=0 then goto 5910;
    writeln('Damage control report not available');
    if docked=false then goto 5980;

5720:
    estimate := 0;
    for i := 1 to 8 do
      if dmg[i]<0 then estimate := estimate + 0.1;

    if estimate=0 then
      goto 5980;

    writeln;
    estimate := estimate + d4; { Add random extra repair time }
    if estimate >= 1 then estimate := 0.9;

    writeln('Technicians standing by to effect repairs to your ship;');
    writeln('Estimated time to repair: ',estimate:1:2,' stardates.');
    write('Will you authorize the repair order (y/n)? ');
    readyesno(repairyn);
    if repairyn <>'y' then
      goto 5980;

    for i := 1 to 8 do
      if dmg[i]<0 then dmg[i] := 0;

    time := time + estimate + 0.1;
5910:
    writeln;
    writeln('Device             State of repair');
    for rd := 1 to 8 do
      begin
        l := writedevice(rd);
        tab(25-l);
        writeln(dmg[rd]:6:2)
      end;
    writeln;
    if docked=true then goto 5720;
5980:
  end;

procedure map(h8:boolean);
  var
    i,j,j0 : integer;
    g2: qname;
  begin
    writeln('     1     2     3     4     5     6     7     8');
    writeln('   ----- ----- ----- ----- ----- ----- ----- -----');
    for i := 1 to 8 do
      begin
        write(i:1);
        if h8 then
          for j := 1 to 8 do
            begin
              write('   ');
              if known[i,j] = 0 then
                write('***')
              else
                zeroprint(known[i,j]);
            end
        else
          begin
            namequadrant(i, 1, true, g2);
            j0 := 10 - (lastletter(g2) div 2);
            tab(j0);
            trimwrite(g2);
            tab(j0);
            write('     ');
            namequadrant(i, 5, true, g2);
            j0 := 10 - (lastletter(g2) div 2);
            tab(j0);
            trimwrite(g2);
            tab(j0)
          end;
        writeln;
        writeln('   ----- ----- ----- ----- ----- ----- ----- -----');
      end;
    writeln;
  end;

{ Show map of star systems }
procedure galaxymap;
  begin
    writeln('                        The galaxy');
    map(false);
  end;

{ Show visited quadrants }
procedure galacticrecord;
  begin
    writeln;
    writeln('     Computer record of galaxy for quadrant ',q1:1,',',q2:1);
    writeln;
    map(true);
  end;

{ Status report }
procedure statusreport;
  begin
    writeln('   Status report:');
    if klingons > 1 then
      writeln('Klingons left: ',klingons:1)
    else
      writeln('Klingon left: ',klingons:1);

    writeln('Mission must be completed in ',
       (startdate + duration - time):3:1,' stardates');
    if starbases < 1 then
      begin
        writeln('Your stupidity has left you on your own in');
        writeln('  the galaxy -- You have no starbases left!');
      end
    else
      if starbases < 2 then
        writeln('The federation is maintaining ',starbases:1,' starbase in the galaxy')
      else
        writeln('The federation is maintaining ',starbases:1,' starbases in the galaxy');
  end;

{ Torpedo, base nav, d/d calculator }
procedure torpedodata;
  var
    i:integer;
  begin
    if k3<=0 then
      noklingons
    else
      begin
        write('From enterprise to Klingon battle cruiser');
        if k3 > 1 then writeln('s')
        else writeln;

        for i := 1 to 3 do
          if k[i].energy > 0 then
            dirdist(s1-k[i].sectx, s2-k[i].secty);
      end
  end;

procedure dircalc;
  var
    ix,iy,fx,fy: integer;
  begin
    writeln('Direction/distance calculator:');
    writeln('You are at quadrant ',q1:1,',',q2:1,' sector ',s1:1,',',s2:1);
    writeln('Please enter');
    write('  Initial coordinates (x,y) ');
    readcoord(ix, iy);
    write('  Final coordinates (x,y) ');
    readcoord(fx, fy);
    dirdist(ix-fx, iy-fy)
  end;

procedure navdata;
  begin
    if b3<>0 then
      begin
        writeln('From enterprise to starbase:');
        dirdist(s1-sb1, s2-sb2)
      end
    else
      writeln('Mr. Spock reports,  ''Sensors show no starbases in this quadrant.''');
  end;


procedure librarycomputer;
  label 1;
  var
    a : integer;
    redo : boolean;
  begin
    if dmg[DMG_COM]<0 then
      begin
        writeln('Computer disabled');
        goto 1
      end;
    repeat
      redo := false;
      write('Computer active and awaiting command? ');
      readint(a);
      if a < 0 then
        goto 1;

      writeln;
      case a of
        0: galacticrecord;
        1: statusreport;
        2: torpedodata;
        3: navdata;
        4: dircalc;
        5: galaxymap;
        otherwise:
          begin
            redo := true;
            writeln('Functions available from library-computer:');
            writeln('   0 = Cumulative galactic record');
            writeln('   1 = Status report');
            writeln('   2 = Photon torpedo data');
            writeln('   3 = Starbase nav data');
            writeln('   4 = Direction/distance calculator');
            writeln('   5 = Galaxy ''region name'' map');
            writeln
          end;
      end;
    until redo = false;
  1:
  end;

procedure initialize;
  var
    i,j : integer;
    t1 : real;
  begin
    lines(11);
    writeln('                                    ,------*------,');
    writeln('                    ,-------------   ''---  ------''');
    writeln('                     ''-------- --''      / /');
    writeln('                         ,---'' ''-------/ /--,');
    writeln('                          ''----------------''');
    writeln;
    writeln('                    THE USS ENTERPRISE --- NCC-1701');
    lines(5);

    time := 0.0 + (rnd(20)+20)*100;
    startdate := time;
    duration := 25 + rnd(10);
    docked := false;
    energy := E_ENERGY;
    torpedos := ORGTORPS;
    shield := 0;
    starbases := 0;
    klingons := 0;

    { Position ship in the galaxy }
    q1 := rnd8i;
    q2 := rnd8i;
    s1 := rnd8i;
    s2 := rnd8i;

    for i := 1 to 9 do
      begin
        c[i,1]:=0;  c[i,2]:=0
      end;
    c[3,1]:=-1;  c[2,1]:=-1;  c[4,1]:=-1;  c[4,2]:=-1;  c[5,2]:=-1;  c[6,2]:=-1;
    c[1,2]:=1; c[2,2]:=1; c[6,1]:=1; c[7,1]:=1; c[8,1]:=1; c[8,2]:=1; c[9,2]:=1;

    for i := 1 to 8 do dmg[i] := 0;

    { Setup what exists in galaxy . . .
      K3= # Klingons  B3= # Starbases  S3 = # Stars }
    for i := 1 to 8 do
      for j := 1 to 8 do
        begin
          k3 := 0;
          known[i,j] := 0;
          t1 := rnd1;
          if t1 > 0.98 then
            begin
              k3 := k3 + 1;
              klingons := klingons+1
            end;
          if t1 > 0.95 then
            begin
              k3 := k3 + 1;
              klingons := klingons+1
            end;
          if t1 > 0.80 then
            begin
              k3 := k3 + 1;
              klingons := klingons+1
            end;
          
          b3 := 0;
          if rnd1 > 0.96 then
            begin
              b3 := 1;
              starbases := starbases+1;
            end;
          s3 := rnd8i;
          galaxy[i,j] := k3*100 + b3*10 + s3
        end; { for j,i }

    if klingons > duration then
      duration := klingons+1;

    if starbases = 0 then
      begin
        { Add a Klingon to the sector with the only starbase }
        if galaxy[q1,q2]<200 then
          begin
            galaxy[q1,q2] := galaxy[q1,q2]+100;
            klingons := klingons+1
          end;
        starbases := 1;
        galaxy[q1,q2] := galaxy[q1,q2]+10;
        q1 := rnd8i;
        q2 := rnd8i
      end;

    orgklings := klingons;
    writeln('Your orders are as follows:');
    writeln('''Destroy the ',klingons:1,' Klingon warships which have invaded');
    writeln('the galaxy before they can attack federation');
    writeln('headquarters on stardate ',startdate+duration:4:0,'. This gives you ',duration:2);
    if starbases <> 1 then
      writeln('days. There are ',starbases:1,' starbases in the galaxy for')
    else
      writeln('days. There is ',starbases:1,' starbase in the galaxy for');
    writeln('resupplying your ship.''');
    writeln;
    newquadrant;
    shortrange;
  end;


{ MAIN }
begin
  randstate := 0;
  randomize(randstate);

  repeat
    gameison := true;
    initialize;

    repeat
      write('Command? ');
      readcommand(cmd);
      if cmd = 'nav' then coursecontrol
      else if cmd = 'srs' then shortrange
      else if cmd = 'lrs' then longrange
      else if cmd = 'pha' then phaser
      else if cmd = 'tor' then firetorpedo
      else if cmd = 'she' then shieldcontrol
      else if cmd = 'dam' then damagecontrol
      else if cmd = 'com' then librarycomputer
      else if cmd = 'xxx' then resign
      else
        begin
          writeln('Enter one of the following:');
          writeln('  nav  (To set course)');
          writeln('  srs  (For short range sensor scan)');
          writeln('  lrs  (For long range sensor scan)');
          writeln('  pha  (To fire phasers)');
          writeln('  tor  (To fire photon torpedoes)');
          writeln('  she  (To raise or lower shields)');
          writeln('  dam  (For damage control reports)');
          writeln('  com  (To call on library-computer)');
          writeln('  xxx  (To resign your command)');
          writeln
        end;
      if (shield+energy <= 10) or ((energy <= 10) and (dmg[DMG_SHE]<0)) then
        begin
          writeln;
          writeln('** FATAL ERROR **  You''ve just stranded your ship in space.');
          writeln('You have insufficient maneuvering energy, and shield control');
          writeln('is presently incapable of cross-circuiting to engine room!!');
          outoftime;
        end;
    until not gameison;
  
    if starbases > 0 then
      begin
        writeln('The federation is in need of a new starship commander');
        writeln('for a similar mission -- If there is a volunteer,');
        write('let him step forward and enter ''aye''? ');
        readcommand(cmd);
      end;
  until cmd <> 'aye'
end.


Sidst opdateret: 2018/10/11
Website vedligeholdt af Søren Roug