Boldly Go Collection/version40.iso/TS/05B/TWVIEW91.ZIP/TOUR.INC

Text File | 1992-03-11 | 11.8 KB | 434 lines

type
  SectorVisitStatus = (unreachable, visited, scanned, open);
  ScannerMap = array [1..MaxSector] of SectorVisitStatus;
  route = record
            length : sectorIndex;               { actual trip length   }
            more   : integer;                   { how many more to hit }
            path   : array [ 1..2000 ] of sector;
          end;

  nodeptr = ^node;
  node    = record next : nodeptr; s : sector; end;
  squeue  = record front, rear : nodeptr; end;

procedure ensqueue( e : sector; var q : squeue );
var
  NewGuy : nodeptr;
begin
  New( NewGuy );
  if NewGuy = nil then
    begin
      writeln('error: out of memory during ensqueue');
      readln;
      halt;
    end;
  with NewGuy^ do
    begin
      s := e;
      next := nil;
    end; {with}
  if q.rear = nil then
    q.front := newguy
  else
    q.rear^.next := newguy;
  q.rear := newguy;
end;

procedure sserve( var e : sector; var q : squeue );
var
  killer : nodeptr;
begin
  if q.front = nil then
    begin
      writeln('error: serve from empty squeue');
      readln;
      halt;
    end;
  killer := q.front;
  with killer^ do
    begin
      e := s;
      q.front := next;
    end; {with}
  if q.front = nil then
    q.rear := nil;
  dispose( killer );
end;

procedure screate( var q : squeue );
begin
  q.front := nil;
  q.rear := nil;
end;

procedure Scan( s : sector; var m : scannerMap; var LeftOpen : integer );
{ visit s; mark every sector adjacent to s as examined. }
var
  j : warpindex;
begin
  m[s] := visited;
  with space.sectors[s] do
    for j := 1 to number do
      if m[ data[j] ] = open then
        begin
          m[ data[j] ] := scanned;
          LeftOpen := LeftOpen - 1;
          write('.');
        end;
end; {scan}

procedure InitToOpen( var s : ScannerMap );
{ initialize all known or adjacent to known sectors to "open", rest to
unreachable.  Warn if there are reachable unexplored sectors. }
var
  i : sector;
  q : squeue;
  j : warpindex;
begin
  for i := 1 to MaxSector do
    s[i] := unreachable;
  screate( q );
  ensqueue( 1, q );
  while q.front <> nil do
    begin
      sserve( i, q );
      s[i] := open;
      with space.sectors[i] do
        for j := 1 to number do
          if s[ data[j] ] = unreachable then
            ensqueue( data[ j ], q );
    end; {while}
  for i := 1 to MaxSector do
    if s[i] = unreachable then
      writeln('Sector ', i, ' unreachable.');
end; {Initialize to all open}

procedure SaveMapToDisk( var s : scannermap );
var
  f : text;
  i : sector;
begin
  assign( f, GetNewFileName('File containing sector map? ',BBSName+'.map'));
  rewrite( f );
  for i := 1 to MaxSector do
    case s[i] of
      unreachable : writeln( f, i:4, ' unreachable');
      visited     : writeln( f, i:4, ' visited');
      scanned     : writeln( f, i:4, ' scanned');
      open        : ;
    end; {for case}
  close( f );
end;

procedure EditMap( var s : scannermap );
var
  dummy : integer;
  i  : SectorIndex;
begin
  writeln('First, enter those sectors you know about (i.e. from Etherprobes)');
  writeln('but where the adjacent sectors were not scanned.');
  writeln;
  writeln('Enter 0 to finish.');
  read( i );
  while i <> 0 do
    begin
      s[i] := scanned;
      read( i );
    end; {while}
  writeln('Now enter those sectors that you have performed scans in.  0 to finish.');
  read( i );
  while i <> 0 do
    begin
      Scan( i, s, dummy );
      read( i );
    end; {while}
  readln;
end;

procedure InitMapFromDisk( var s : scannermap );
var
  f : text;
  i : integer;
  SVStatus : string;
begin
  for i := 1 to MaxSector do
    s[i] := open;
  assign( f, GetOldFileName( 'Name map is saved under? ', BBSName+'.map' ));
  reset( f );
  while not eof( f ) do
    begin
      i := ReadNumber( f );
      readln( f, SVstatus );
      if i <> 0 then
        case SVStatus[1] of
          'u' : s[i] := unreachable;
          's' : s[i] := scanned;
          'v' : s[i] := visited;
        else
          writeln('Line "', i, ' ', SVstatus, '" not understood.');
        end; {if case}
    end; {while}
end;

procedure SetUpToVisit( var s : scannermap );
var
  i : sector;
  ch: char;
begin
  write('Start with <F>resh map, or <R>ead in map from disk?  ');
  readln( ch );
  if upcase( ch ) = 'R' then
    InitMapFromDisk( s )
  else
    InitToOpen( s );
  repeat
    write('<E>dit map, <S>ave map, or <C>ontinue?  ');
    readln( ch );
    if upcase( ch ) = 'E' then
      EditMap( s )
    else if upcase( ch ) = 'S' then
      SaveMapToDisk( s );
  until not (ch in ['e','E','s','S']);
end;

function PathToThing( start : sector;
                  var map : scannermap;
                      which : integer ) : sectorindex;
{ Adjusts Distances from start up to point where "which" criteria is found;
  returns sector or 0 if no appropriate sector found. }
var
  s : sector;
  breadth : queue;
  daddy, sonny : sector;
  i : warpindex;
  done : boolean;
begin
  for s := 1 to maxSector do
    Distances[s].d := -1;
  breadth.front := 0;
  enqueue( breadth, start, start );
  repeat
      serve( breadth, daddy, sonny );
      if Distances[ sonny ].d = -1 then {haven't hit him before:}
        begin
          distances[ sonny ].d := distances[ daddy ].d + 1;
          distances[ sonny ].s := daddy;
          with space.sectors[ sonny ] do if number > 0 then
            if (space.sectors[sonny].etc and avoid) = Nothing then
              for i := 1 to number do
                enqueue( breadth, sonny, data[ i ] );
          case which of
          1 : done := map[ sonny ] = open;
          2 : done := (space.sectors[ sonny ].number = 1) and (map[sonny]=open);
          end; {case}
        end; {if}
  until done or (breadth.front = 0);
  if done then
    PathToThing := sonny
  else
    PathToThing := 0;
end; {Path to Open}



function NumberOpen( var m : ScannerMap ) : integer;
{ return the number of open sectors in array }
var
  count : integer;
  i     : sector;
begin
  count := 0;
  for i := 1 to MaxSector do
    if m[i] = open then
      count := count + 1;
  NumberOpen := count;
end;

procedure AddToRoute( target : sector;
                  var Travels : route;
                  var map : scannermap );
{ assumes Distances has already been properly set up.  We travel from
  current position to target. If target is adjacent to the current location,
  great, extend path; otherwise we have to recursively move one step
  closer, and add that. }
begin
  if not IsWarp( travels.path[ travels.length ], target ) then
    AddToRoute( distances[ target ].s, travels, map );
  travels.length := travels.length + 1;
  travels.path[ travels.length ] := target;
  scan( target, map, travels.more );
end;

procedure DoSomethingRandom(var visit : route;       { travels so far      }
                            var map   : scannerMap); { map visited sectors }
{ Go adjacent to a random open sector }
var
  target : sectorindex;
  skip : sectorindex;
begin
  skip := random( visit.more ) + 1;
  target := 0;
  repeat
    target := target + 1;
    while map[ target ] <> open do
      target := target + 1;
    skip := skip - 1;
  until skip = 0;
  writeln('random jog to ', target, ' of length ',
    FixPath( visit.path[ visit.length ], target ) );
  AddToRoute( distances[ target ].s, visit, map );
end; {DoSomethingRandom}

procedure VisitNearestOpen(var visit : route;       { travels so far      }
                           var map   : scannerMap); { map visited sectors }
begin
  AddToRoute( distances[ pathToThing( visit.path[visit.length], map, 1 ) ].s,
              visit, map );
end; {VisitNearestOpen}

procedure VisitNearestDeadEnd( var visit : route;
                               var map   : scannerMap );
var
  s : sectorIndex;
begin
  s := PathToThing( visit.path[ visit.length ], map, 2);
  if s = 0 then
    begin
      writeln('Out of dead ends');
      VisitNearestOpen( visit, map );
    end
  else
    AddToRoute( distances[s].s, visit, map );
end;

procedure FindRandomRoute( var Travels : route; map : ScannerMap );
{ Find a route through the galaxy that visits or scans every sector in the
map that isn't marked unreachable. }
var
  roll  : integer;
  greed : integer;      { percentage of  doing something random }
  ToGo  : integer;      { how many open sectors remain          }
begin
  write('Starting sector? ');
  readln( travels.path[1] );
  travels.length := 1;
  Scan( travels.path[1], map, travels.more );
  travels.more := NumberOpen( map );
  write('Random percentage?  (0=greedy algorithm, 100=random path) ');
  readln( greed );
  while travels.more > 0 do
    begin
      roll := random( 100 );
      if roll < greed then
        DoSomethingRandom( travels, map )
      else if roll < greed * 10 then
        VisitNearestDeadEnd( travels, map )
      else
        VisitNearestOpen( travels, map );
    end; {while}
end; {FindRandomRoute}

procedure PrintTour( var t : route );
{print tour to screen, and optionally to disk }
var
  f : text;
  i : sectorindex;
  filename : string;
begin
  writeln('path is of length ', t.length );
  write('Name of file?  Hit return to display to screen: ');
  readln( filename );
  assign( f, filename );
  rewrite( f );
  for i := 1 to t.length do
    begin
      write( f, t.path[i] : 8 );
      if i mod 8 = 0 then
        writeln(f);
    end; {for}
  writeln( f );
  if filename <> '' then
    close( f );
end; {PrintTour}


procedure VisitEverySector;
{ Passed "SPACE" by side effect.  Goal is to find a (short) path that will be
adjacent to every observed sector in the galaxy. }
var
  KnownGalaxy : scannerMap;
  GalacticTour: route;
begin
  SetUpToVisit( KnownGalaxy );
  FindRandomRoute( GalacticTour, KnownGalaxy );
  PrintTour( GalacticTour );
end; {VisitEverySector}

procedure decPath( var home : sectorindex; sec : sector;
                   var count : integer;
                   var map   : ScannerMap );
{ subtract one for each open sector encountered }
begin
  if home <> sec then
    decPath( home, distances[ sec ].s, count, map );
  if map[sec] = open then
    dec( count );
end;


procedure FindScanResults( var EtherProbeInfo : distanceArray;
                               map            : scannermap );
{ Load EtherProbeInfo with EtherProbeInfo.d = # open sectors on path from
base point to EtherProbeInfo.s }
var
  BaseSector : sectorIndex;
  i          : sector;
begin
  write('Base sector for etherprobes? (0 to abort) ');
  readln( BaseSector );
  if BaseSector = 0 then
    EtherProbeInfo[1].d := -maxint      { code abort }
  else
    begin
      TwoWayDistances( BaseSector, distances, false, true );
      for i := 1 to MaxSector do
        begin
          EtherProbeInfo[i].d := 0;
          if distances[i].d <> maxint then
            DecPath( BaseSector, i, EtherProbeInfo[i].d, map );
{ We are going to call sort, so these are set to negatives }
          EtherProbeInfo[i].s := i;
        end; {for}
    end; {else}
end;

procedure DisplayEtherResults( ER : distanceArray );
var
  i : 1..25;
begin
 writeln('Top 25:');
 for i := 1 to 25 do
   begin
     write('Target: ', ER[i].s : 4, '   New count : ', -ER[i].d: 4, ' ':5 );
     if not odd(i) then writeln;
   end;
 writeln;
end;


procedure SuggestEtherProbes;
{Also passed "space" by side effect.  Will suggest a list of targets that
will help scan the universe. }
var
  KnownGalaxy : scannerMap;
  NewScanned  : distancearray;
begin
  SetUpToVisit( KnownGalaxy );
  FindScanResults( NewScanned, KnownGalaxy );
  if NewScanned[1].d <> -maxint then  {abort at previous step?}
    begin
      writeln('Sorting...');
      SortDistances( NewScanned, MaxSector );
      DisplayEtherResults( NewScanned );
    end; {if}
end; {SuggestEtherProbes}