#!perl -w
use strict;
#
 #
 # Yet Another PERL Script
 #
 # Name: gridps.pl
 #
 # Date: 97.11.21 (was: 96.9.24)
 #
 # Desc: reads in world profiles and prints out a PostScript map
 #
 # Dude: rje
 #
 # SYNOPSIS: grid inputFile ...
 #
#
require "Alexandria.tas";

my %option = 
(
   'show negative'    => 0,
   'show uwp'         => 1,
   'show codes'       => 1,
   'show xboat'       => 1,
   'show allegiance'  => 1,
   'show zone'        => 1,
   'show bases'       => 1,
   'show ggs'         => 1,
);

#############################################################################
#############################################################################
my $startPSfile = "

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Invariant code starts here...
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

/top rows 1.5 mul 1 sub def

%%%%%%%%%%%%%%%%%%%%%%%%%%%
% /myScale 40 def
%
%  if (rows > 2.9 * cols)
%     myScale = rows/300
%  else
%     myScale = cols/150
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%
/cols2 cols 2.9 mul def

/myScale {
   rows cols2 ge {
      350 rows div
   } {
      190 cols div
   } ifelse
}
def

%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Jon Buller's code begins...
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%

/marginX 30              def
/marginY myScale 2.0 mul def

/r3 3.0 sqrt def
/r3o2 r3 2.0 div def

/hexpart {
   1
   1
   3 -1 roll {
      pop
      r3o2 0 rlineto
      -60 rotate
   } for
} def

/hexpair {
  gsave
    5 hexpart
    120 rotate
    6 hexpart
    stroke
  grestore
} def

marginX marginY translate   % adjust margin
myScale myScale scale       % set the scale
1.15  0 moveto              % window adjust (r3o2)

0 setlinewidth

1 1 rows {
   pop
   gsave
   1 1 cols {
      pop
      hexpair
      r3o2 r3 add
      0 rmoveto
   } for
   grestore
   0 1.5 rmoveto
} for

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Jon Buller's useful code ends here...
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%NOTE: convenience functions
%
%show centered text
%
/cshow {dup stringwidth pop 2 div neg 0 rmoveto show} def
%
%show right-aligned text
%
/rshow {dup stringwidth pop neg 0 rmoveto show} def

%
% Annotation begins...
%

/Helvetica 0.20 selectfont
";

# 0     top           moveto (0101) show
# 0     top 1.5  sub  moveto (0102) show
# 0     top 3.0  sub  moveto (0103) show
# 0     top 4.5  sub  moveto (0104) show
# 0     top 6.0  sub  moveto (0105) show
# 0     top 7.5  sub  moveto (0106) show
#
# 1.3   top 0.75 sub  moveto (0201) show
# 1.3   top 2.25 sub  moveto (0202) show
# 1.3   top 3.75 sub  moveto (0203) show
# 1.3   top 5.25 sub  moveto (0204) show
# 1.3   top 6.75 sub  moveto (0205) show

#############################################################################
#############################################################################

# Set up my color wheel...

my $black  = "0.0 0.0 0.0";
my $white  = "1.0 1.0 1.0";
my $red    = "1.0 0.0 0.0";
my $green  = "0.0 0.7 0.0";
my $blue   = "0.0 0.0 1.0";
my $amber  = "1.0 0.7 0.0";
my $purple = "0.8 0.4 0.9";
my $gold   = "0.7 0.7 0.0";
my $aqua   = "0.0 0.7 0.9";
my $puce   = "1.0 0.5 0.5";

# ... and now reverse the colors

if ( $option{ 'show negative' } )
{
   $red    = "0.0 1.0 1.0";
   $green  = "1.0 0.3 1.0";
   $blue   = "1.0 1.0 0.0";
   $amber  = "0.0 0.3 1.0";
   $purple = "0.2 0.6 0.1";
   $gold   = "0.3 0.3 1.0";
   $aqua   = "1.0 0.3 0.1";
}

#################################################
#
#  Parse the argument vector.
#
#################################################

convert( @ARGV ) || webmenu();

#################################################
#
#  Process the file.
#
#################################################
sub convert
{
   my $fileName = shift || return 0; # die "SYNOPSIS: perl gridps.pl infile\n";
   my $min      = shift;
   my $max      = shift;
      
   open(IN, $fileName) || return 1;
   my @lines = <IN>;
   close IN;

   ##################################################
   my $outfile  = getOutfileName( $fileName, $min, $max );
   my $sector   = $1 if $fileName =~ /^(\S+)\.\S+$/;

   $sector =~ s/([A-Z])/ $1/g;

   my $pos = -6.0;
   ##################################################
   
   my %system = &getBunchesOfWorlds( @lines );

   my $filtered = &filterHex( \%system, $min, $max );
   %system = %$filtered;
   
   print STDERR sprintf( "file  %-20s ", $outfile );
   open( OUT, ">$outfile" );

   my $maxRow = delete $system{ maxrow };
   my $maxCol = delete $system{ maxcol };
   my $minRow = delete $system{ minrow };
   my $minCol = delete $system{ mincol };
   
   $minCol-- if ( $minCol % 2 == 0 ); # we start on odd columns
   $minRow-- if ( $minRow % 2 == 0 ); # we start on odd rows
   $maxCol++ if ( $maxCol % 2 == 1 ); # we end on even columns
   $maxRow++ if ( $maxRow % 2 == 1 ); # we end on even rows
   
   my $rows   = $maxRow - $minRow + 1;
   my $cols   = $maxCol - $minCol + 1;

   #
   #  Now do some funny work... 
   #  If the dimensions fit into a subsector-sized
   #  area, then force it into a subsector-sized area
   #  (i.e. 8x10 is the minimum resolution)
   #
   if ( $cols < 9 && $rows < 11 )
   {
      $rows = 10;
      $cols = 8;
   }

   print STDERR sprintf( "(%2s x %2s)  ", $cols, $rows );
   print STDERR sprintf( "%02d%02d-%02d%02d  :", 
                         $minCol, $minRow,
                         $minCol + $cols - 1,
                         $minRow + $rows - 1);
   
   # (NOTE: "%!PS-Adobe-3.0" implies structured PostScript that
   # can be manipulated by a print spooler; this ain't)
   print OUT "%!\n",
             "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n",
             "%\n",
             "%  Adjust these to your requirements.\n",
             "%\n",
             "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n",
             "/rows    $rows def\n",
             "/cols    ", int($cols/2), " def  % these are in pairs!\n";

   print OUT $startPSfile;

   my $population = int( &population( %system ) / 100000000 ) / 10;
   my @worlds     = keys %system;
   my $count      = $#worlds - 4;
   my $mul        = "billion";
   
   $sector =~ s/_/ /g;
   print OUT  "$red setrgbcolor\n";
   print OUT  "/Helvetica-Oblique 1.00 selectfont\n";
   print OUT  "0 top -1.0 sub moveto ($sector) show\n";
   print OUT  "/Helvetica 0.20 selectfont\n";
   print OUT  "$black setrgbcolor\n";
   print OUT  "0 top -0.6 sub moveto ($population $mul people in $count worlds) show\n";
              
   print OUT  "$blue setrgbcolor\n";
#   print OUT  "5 top -1.0 sub moveto (World Key:) show\n";
   print OUT  "4 top -0.8 sub moveto (Green: Agricultural)  show\n";
   print OUT  "4 top -0.6 sub moveto (Purple: Rich) show\n";
   print OUT  "4 top -0.4 sub moveto (Gold: Agri & Rich) show\n";
   print OUT  "6 top -0.8 sub moveto (Blue: Water world) show\n";
   print OUT  "6 top -0.6 sub moveto (Black dot: Industrial) show\n";
   print OUT  "6 top -0.4 sub moveto (All Caps: Population 1 billion+) show\n";
   print OUT  "$black setrgbcolor\n";
   
   foreach (sort keys %system)
   {
      print OUT &mapWorld( $rows, $cols, $minRow, $minCol,
                 %{$system{ $_ }} ) if %{$system{ $_ }};
   }

   print OUT "showpage\n";
   print OUT "%%EOF\n";
   close OUT;
   print STDERR " done.\n";
}
exit 0;


         my @help =
         (
            "Universal World Profile:",
            " Port-Size-Atmo-Hydro-Population-Gov-Law - TL",
            "",
            "Atmospheres: 2,4,7,9 = tainted",
            "",
            "Governments:",
            " 0: Family",
            " 1: Corporate",
            " 2: Democracy",
            " 3: Oligarchy",
            " 4: Republic",
            " 5: Feudal technocracy",
            " 6: Vassal state",
            " 7: Balkanized",
            " 8: Civil bureaucracy",
            " 9: Impersonal bureaucracy",
            " A: Charismatic dictator",
            " B: Non-charismatic dictator",
            " C: Charismatic oligarchy",
            " D: Religious dictatorship",
            " M: Military",
            "",
            "Bases:",
            " A:Naval co-located with Scout",
            " B:Naval co-located with way station",
            " G:Military garrison",
            " M:Non-Imperial Naval",
            " Z:Zhodani Naval",
            " N:Naval",
            " S:Scout",
            " W:Scout way station",
            "",
            "Extended UWP (pbg 3-digit number):",
            " Population most significant digit",
            " # Planetoid belts",
            " # Gas giants"
         );


############################################################################
 #
   sub getCoord
 #
 # desc: given a row-col number, find the cartesian coordinate
 #
 # in  : location string: column . row or column, row
 #
 # out : (x,y)
 #
############################################################################
{
   my ($col, $row) = @_;
   
   unless( $row )
   {
      ($col, $row) = ($1, $2) if $col =~ /(..)(..)/;
   }

   my $x = $col * 1.3;
   my $y = $row * 1.5;
      
   $y  += 0.75 if ($col % 2);

   return ( $x, $y );
}


############################################################################
 #
   sub mapWorld
 #
 # desc:
 #
 # in  :
 #
 # out :
 #
############################################################################
{
      my ($rows, $cols, $beginRow, $beginCol, %world) = @_;

   return '' if $world{ location }->{ row } < $beginRow
             || $world{ location }->{ col } < $beginCol
             || $world{ location }->{ row } > $beginRow + $rows - 1
             || $world{ location }->{ col } > $beginCol + $cols - 1;

      my $r = $world{ location }->{ row };
      my $c = $world{ location }->{ col };

      my $loc = "$c$r";

      $r -= $beginRow;
      $c -= $beginCol;

      my ($x, $y) = getCoord( $c, $r );

      my $out;
      
      my $tx;
      my $ty;

   #####################################################################
   #
   #  Parsec location
   #
#NOTE: now centered
   $out = "$x 0.27 add top $y sub moveto  ($loc) cshow\n";
   #
   #
   #####################################################################

   #####################################################################
   #
   #  DRAW the X-Boat route
   #
   $tx  = $x + 0.25;
   $ty  = $y + 0.50;
   
   if ( $world{ xboat } && $option{ 'show xboat' } )
   {
      my @route = split( ',', $world{ xboat } );
      
      foreach ( @route )
      {
         my ($dx, $dy) = ($1, $2) if /(..)(..)/;
         
         $dx -= $beginCol;
         $dy -= $beginRow;
         
         ($dx, $dy) = &getCoord( $dx, $dy );
             
         $dx += 0.25;
         $dy += 0.50;
                       
         
         $out .= "$green setrgbcolor\n"
              .  "0.04 setlinewidth\n"
              .  "$tx top $ty sub moveto $dx top $dy sub lineto\n"
              .  "stroke\n"
              .  "0 setlinewidth\n"
              .  "$black setrgbcolor\n";
      }
   }
   
   if ( $world{ route } ) # non-xboat route
   {
      my @route = split( ',', $world{ route } );
      
      foreach( @route )
      {
         my ($dx, $dy) = ($1,$2) if /(..)(..)/;
         
         $dx -= $beginCol;
         $dy -= $beginRow;
         
         ($dx,$dy) = getCoord( $dx, $dy );
         
         $dx += 0.25;
         $dy += 0.50;
         
    #     $out .= "$amber setrgbcolor\n"
    #          .  "0.02 setlinewidth\n"
    #          .  "$tx top $ty sub moveto $dx top $dy sub lineto\n"
    #          .  "stroke\n"
    #          .  "0 setlinewidth\n"
    #          .  "$black setrgbcolor\n";
      }      
   }
   #
   #####################################################################


   #####################################################################
   #
   #  Bases, Starport class, Gas giant, Asteroid belts, Allegiance
   #
   $x   -= 0.3;
   $y   += 0.3;
   $out .= "$x top $y sub moveto (".$world{ BASES }.") show\n"
           if $world{ BASES } && $option{ 'show bases' };

   $x   += 0.5;
   $out .= "$x top $y sub moveto  (".$world{ uwp }->{ starport }.") show\n";
   
   $x   += 0.5;
   $out .= "$x top $y sub moveto (o$world{pbg}->{ gasGiants}) show\n"
           if $world{ pbg }->{ gasGiants } 
           && $option{ 'show ggs' };
		   
   $ty = $y + 0.2;
   $out .= "$x top $ty sub moveto (:$world{pbg}->{ belts }) show\n"
           if $world{ pbg }-> {belts}
           && $option{ 'show ggs' };

   $ty += 0.2;
   $out .= #"$blue setrgbcolor\n".
           "$x top $ty sub moveto (".$world{ allegiance }.") show\n"
           if $option{ 'show allegiance' };
           #"$black setrgbcolor\n";
		   
   #
   #
   #####################################################################




   #####################################################################
   #
   #  World disc
   #
   $x   -= 0.45;
   $y   += 0.2;
   
   #
   #  Print the three-dot asteroid telltale...
   #
   if ( $world{ uwp }->{ size } eq '0' )
   {
      $tx = $x;
      $ty = $y - 0.14;
      $out .= "newpath $tx top $ty sub 0.02 0 360 arc closepath stroke\n";
      
      $tx = $x - 0.1;
      $ty = $y + 0.1;
      $out .= "newpath $tx top $ty sub 0.02 0 360 arc closepath stroke\n";

      $tx = $x + 0.1;      
      $out .= "newpath $tx top $ty sub 0.02 0 360 arc closepath stroke\n";

      $tx = $x - 0.1;
      $ty = $y + 0.05;   
      $out .= "$tx top $ty sub moveto ($1) show\n" if $world{ codes } =~ /(In)/;
   }
   else
   {
      #
      #  Print and color a planet disc according to trade codes
      #      
      $out .= "newpath $x top $y sub 0.15 0 360 arc closepath\n";
      
      %world = &trade( %world ) unless $world{ codes };
   
      if ( $world{ codes } =~ /(Ag|Ri)/ && $option{ 'show codes' } ) 
      {
         $out .= "gsave $green setrgbcolor fill grestore\n" if $world{ codes } =~ /Ag/;
#      $out .= "gsave .0 setgray fill grestore\n"              if $world{ codes } =~ /In/;
         $out .= "gsave $purple setrgbcolor fill grestore\n" if $world{ codes } =~ /Ri/;
         $out .= "gsave $gold setrgbcolor fill grestore\n" 
            if $world{ codes } =~ /Ri/
            && $world{ codes } =~ /Ag/;
      }
      elsif ( $world{ uwp }->{ atmosphere } > 10 )
      {
         $out .= "gsave $puce setrgbcolor fill grestore\n";
      }
      elsif ( $world{ uwp }->{ hydrosphere } eq '10' )
      {
         $out .= "gsave $aqua setrgbcolor fill grestore\n";         
      }
      elsif ( $world{ uwp }->{ hydrosphere } ne '0' )
      {
         $out .= "gsave .8 setgray fill grestore\n";
      }
      
    
      $out .= "newpath $x top $y sub 0.06 0 360 arc closepath fill\n"
         if $world{ codes } =~ /In/
         && $option{ 'show codes' };
   }

   $tx = $x - 0.1;
   $ty = $y + 0.05;   
   $out .= "$tx top $ty sub moveto ($1) show\n" if $world{ codes } =~ /(Ni)/;
   
   $out .= "stroke\n";
   #
   #
   #####################################################################


   #####################################################################
   #
   #  Amber Zone?  Red Zone?
   #
   $out .= "$amber setrgbcolor\n".
           "0.02 setlinewidth\n".
           "newpath $x top $y sub 0.45  315 225 arc\n".
           "stroke\n".
           "0 setlinewidth\n".
           "$black setrgbcolor\n"
           if ($world{ zone } =~ /[AY]/)
           && $option{ 'show zone' };
           
   $out .= "$red setrgbcolor\n".
           "0.04 setlinewidth\n".
           "newpath $x top $y sub 0.45 315 225 arc\n".
           "stroke\n".
           "0 setlinewidth\n".
           "$black setrgbcolor\n"
           if ($world{ zone } =~ /[RZ]/)
           && $option{ 'show zone' };
   #
   #
   #####################################################################

   #####################################################################
   #
   #  X-Boat Route(s)
   #   
   $tx = $x - 0.4;
   $ty = $y + 0.05;
   #$out .= "$blue setrgbcolor\n".
   #        "$tx top $ty sub moveto (xb) show\n".
   #        "$black setrgbcolor\n"
   #        if $world{ zone } =~ /[XYZ]/;
   
   #
   #
   #####################################################################

   #####################################################################
   #
   #  World Stats, on the hex
   #
   #  Due to current print quality, sector maps do not have hex
   #  data on them.  Subsector maps will; even regional maps will.
   #
   $tx  = $c * 1.3 + 0.27;
   $ty  = $y + 0.45;
#NOTE: now centered in hex
   $out .= "$tx top $ty sub moveto ($world{UWP}) cshow\n"
       if $option{ 'show uwp' };
      #if  $cols < 21 
      #&&  $rows < 17;
   #
   #
   #####################################################################
   
   #####################################################################
   #
   #  World Name
   #
   $tx = $c * 1.3 + 0.27;
   $ty = $y + 0.65;
   
   $out .= "$red setrgbcolor\n" if $world{ codes } =~ /Cp|Cx/
                                && $option{ 'show codes' };
                                
   
   $world{name} =~ s/\s*$//;
#   NOTE: now centered in hex
   $out .= "$tx top $ty sub moveto ($world{name}) cshow\n"
      if length($world{name}) > 0;
   
   $out .= "$black setrgbcolor\n" if $world{ codes } =~ /Cp|Cx/
                                  && $option{ 'show codes' };
   #
   #
   #####################################################################

   #####################################################################
   #
   #  World Stats, on the side
   #
   #$tx = $x;
   #$ty = $y - 0.15;
   #$out .= "$tx top $ty sub moveto (".$world{ UWP }.") show\n";
   #$pos += 0.35;
   #my   $cw = &putCompressedWorld( %world );
   #chomp ( $cw );
   #$out .= ($cols*1.3)." top $pos sub moveto  ($cw) show\n";
   #
   #
   #####################################################################

   return $out;
}


sub webmenu
{
   my $query = $ENV{ QUERY_STRING } || '';
   my %env;
   
   foreach my $item ( split( /&/, $query ) )
   {
      my @pair = split '=', $item;
      $env{$pair[0]} = $pair[1];
   }
   
   if ( $env{sector} )
   {  
      my $file = getOutfileName( $env{sector}, $env{min}, $env{max} );
      convert( $env{sector}, $env{min}, $env{max} )
         unless -f $file;
        
#      open IN, $psfile;
#      my $data = join( '', <IN> );
#      close IN;
      
      print<<EOOUTPUT;
Content-type: text/html

Your PostScript output file: <a href=$file>$file</a>
EOOUTPUT
   }
   else
   {
      my @avail = <*.ps>;
      my $count = 0;
      
      foreach (sort @avail)
      {
         my $name = sprintf( "%-30s", $_ );
         $_ = "<a href=$_>$name</a>";
         $count++;
         $_ .= "\n" unless $count % 2;
      }
      
      my @files = <*.sec>;
      
      $_ = "<option name=$_>$_" for @files;
      
      print<<EOHTML;
Content-type: text/html

   <html>
   <body>
   
   Seriik Gerum Nashalek - Sector Mapping Interface
   <hr>
   
   <form method=get>
   
   Sector data:
   <select name=sector>
      @files
   </select>
   <!--input type=submit value="Load Sector Data"-->
   <br>
   
   <!--textarea cols=80 rows=10 name=data>data</textarea-->
   
   <br><br>
   
   Upper-left hex: <input name=min size=4 value=0101>
   Lower-right hex:</td><td><input name=max size=4 value=3240>
   
   <hr>
   
   <br>
   <input type=submit value="Create PostScript">
   <br><hr>
   Already converted and available:<br>
<pre>
 @avail
</pre>
   </form>
   </body>
   </html>
EOHTML
   }
   
   
}

sub getOutfileName
{
   my ($sec, $min, $max) = @_;
   my $name = $sec;
   $name =~ s/\.sec$/.ps/;
   
   if ( $min && $max )
   {
      $name =~ s/.ps$/.$min.$max.ps/
         unless $min eq '0101' && $max eq '3240';
   }
   return $name;
}