#!/usr/bin/perl -w
# (c) Stijn van Dongen.

use strict;

my ($ifile, @pars);
my $B_split = 0;
my $B_test  = 0;

my $psparamsGrid  =  &defaultPsparamsGrid();
my $psparamsDiag  =  &defaultPsparamsDiag();

while ($ARGV[0] =~ /^-\w/) {

   my $opt =   shift @ARGV;
   $opt    =~  s/^-//;
   if ($opt eq 'split') {
      $B_split = 1;
   }
   if ($opt eq 'test') {
      $B_test = 1;
   }
   elsif (defined($::psparamsGridHandle->{$opt})) {
      $psparamsGrid->{$::psparamsGridHandle->{$opt}->{'param'}} = shift @ARGV;
   }
   elsif (defined($::psparamsDiagHandle->{$opt})) {
      $psparamsDiag->{$::psparamsDiagHandle->{$opt}->{'param'}} = shift @ARGV;
   }
   elsif ($opt =~ /(help|h)/) {
      &help();
      exit 0;
   }
   else {
      print "Unknown option: [$opt]\n";
      exit 1;
   }
}


{  $ifile      =  shift @ARGV;
   open (IN, "<$ifile") || die "no open input file [$ifile]\n";
   $/             =  "";               # chew on paragraphs.
   @pars          =  <IN>;
   close IN;
}

$/ =  1;

if ($B_split) {

   my $ct = 0;
   for my $par (@pars) {

      $ct++;
      my $ofile = $ifile . "-$ct" . '.ps';
      open (OUT, ">$ofile") || die "no open output file [$ofile]\n";

      my ($tsumelines, $nodes);

      my $tsparams               =  &defaultTsumeParams();
      ($tsumelines, $tsparams)   =  &parseText($par, $tsparams);
      ($nodes, $tsparams)        =  &parseAsciiTsume($tsumelines, $tsparams);
      ($nodes, $tsparams)        =  &trueLocation($nodes, $tsparams);

      my $preamble               =  &makePspreamble
                                             (  $psparamsDiag
                                             )  ;

      my ($tsumecode, $box)      =  &pstsume (  $nodes
                                             ,  $tsparams
                                             ,  $psparamsDiag
                                             ,  $psparamsGrid
                                             )  ;

      $preamble                  =~    s/#bbLLx/$box->{'bbLLx'}/g;
      $preamble                  =~    s/#bbLLy/$box->{'bbLLy'}/g;
      $preamble                  =~    s/#bbURx/$box->{'bbURx'}/g;
      $preamble                  =~    s/#bbURy/$box->{'bbURy'}/g;

      print OUT $preamble, $tsumecode;
      print OUT "showpage\n";
      close OUT;
      print "[$ofile]\n";
   }
}

else  {

   my $ofile = $ifile . '.ps';
   open (OUT, ">$ofile") || die "no open output file [$ofile]\n";
   print "[$ofile ";

   my $ct                  =     0;
   my $preamble            =     &makePspreamble($psparamsDiag);
   my $tsparams            =     &defaultTsumeParams();
   
   my ($bbLLx, $bbLLy, $bbURx, $bbURy)
                           =     (10000, 10000, 0, 0);

   my $pscode              =     $preamble;

   for my $par (@pars) {

      my       ($ofsetx, $ofsety, $dx, $dy, $nx)
                                 =  (  $psparamsGrid->{'ofsetx'}
                                    ,  $psparamsGrid->{'ofsety'}
                                    ,  $psparamsGrid->{'dx'}
                                    ,  $psparamsGrid->{'dy'}
                                    ,  $psparamsGrid->{'nx'}
                                    )  ;

      my       $transx           =  $ofsetx + $dx * ($ct % $nx);
      my       $transy           =  $ofsety - $dy * div($ct, $nx);

      $psparamsGrid->{'transx'}  =  $transx;
      $psparamsGrid->{'transy'}  =  $transy;
      $ct++;

      my ($tsumelines, $nodes);

      my $tsparams               =  &defaultTsumeParams();
      ($tsumelines, $tsparams)   =  &parseText($par, $tsparams);
      ($nodes, $tsparams)        =  &parseAsciiTsume($tsumelines, $tsparams);
      ($nodes, $tsparams)        =  &trueLocation($nodes, $tsparams);

      my ($tsumecode, $box)      =  &pstsume (  $nodes
                                             ,  $tsparams
                                             ,  $psparamsDiag
                                             ,  $psparamsGrid
                                             )  ;

      $bbLLx                     =  min($bbLLx, $box->{'bbLLx'});
      $bbLLy                     =  min($bbLLy, $box->{'bbLLy'});
      $bbURx                     =  max($bbURx, $box->{'bbURx'});
      $bbURy                     =  max($bbURy, $box->{'bbURy'});

      $pscode                   .=  $tsumecode;
      print '.';
   }

   $pscode                       =~ s/#bbLLx/$bbLLx/g;
   $pscode                       =~ s/#bbLLy/$bbLLy/g;
   $pscode                       =~ s/#bbURx/$bbURx/g;
   $pscode                       =~ s/#bbURy/$bbURy/g;

   print OUT $pscode;
   print OUT "showpage\n";
   close OUT;
   print "]\n";
}


sub help {
   print $::help;
   print "\nDiagram options (all take argument separated by whitespace):\n";
   for (sort keys %$::psparamsDiagHandle) {
      printf "-%-20s%s\n", $_, $::psparamsDiagHandle->{$_}->{'descr'};
   }
   print "\nGrid options (all take argument separated by whitespace):\n";
   for (sort keys %$::psparamsGridHandle) {
      printf "-%-20s%s\n", $_, $::psparamsGridHandle->{$_}->{'descr'};
   }
}


sub parseText {

   my $par           =     $_[0];
   my $tsparams       =     $_[1];
   my $anchor        =     $tsparams->{'anchor'};

   my $tsumelines    =     [];
   my $tsumelinect   =     0;

   my @lines         =     split "\n", $par;

   while (my $line = shift @lines) {

      chomp $line;
      $line =~ s/\s*$//;

      if ($line =~ /^\s+\S/) {

         if ($line =~ s/^(\s+)\|/$1 /) {
            $anchor->{'lftsupplied'} = 1;
         }

         if ($line =~ s/\|(\s*)$/ $1/) {
            $anchor->{'rgtsupplied'} = 1;
         }

         if (($line =~ /[\-_]/) && !$tsumelinect) {
            $anchor->{'topsupplied'} = 1;
            next;
         }

         if (($line =~ /[\-_]/) && $tsumelinect) {
            $anchor->{'botsupplied'} = 1;
            last;
         }

         push @$tsumelines, $line;
         $tsumelinect++;
      }

      elsif ($line =~ /^orientation\[([lrtbc]+)\]/) {
         
         my $string = $1;

         for (split "", $string) {
            $anchor->{$::borderopts->{$_}} =  1;
         }
      }

      elsif ($line =~ /^blackchar\[(.)\]/) {
         $tsparams->{'blackchar'} = $1;
      }

      elsif ($line =~ /^whitechar\[(.)\]/) {
         $tsparams->{'whitechar'} = $1;
      }
   }

   return ($tsumelines, $tsparams);
}


sub parseAsciiTsume {

   my $tsumelines    =     $_[0];
   my $tsparams       =     $_[1];

   my $tokenchar     =     makeTokenChar($tsparams);

   my $vlines        =     [];
   my $tsumecols     =     [];
   my $nodes         =     [];

   my ($i, $x, $y);

   for ($i=0;$i<80;$i++) {
      $vlines->[$i]   =  [];
   }

   for my $line (@$tsumelines) {

      my $len     =     length $line;

      if ($len > 80) {
         $line    =     substr   $line, 0, 80;
      }
      else {
         $line    =     $line . ' ' x (80 - $len);
      }

      my @chars   =     split "", $line;
      my $k       =     0;

      for my $char (@chars) {

         push @{$vlines->[$k]}, $char;
         $k++;
      }
   }

   for my $vref (@$vlines) {

      my $vline      =     reverse join "", @$vref;

      if ($vline  =~    /\S/) {
                                          # add missing empty points.
         $vline   =~    s/ /\./g;
         push  @$tsumecols, [ split "", $vline ];
      }
   }

   my $xstones                =      scalar @$tsumecols;

   if ($xstones == 0) {
      print " Tsume problem does not meet syntax specs]\n"
   ,  "Lines specifying the problem itself should start with white space\n"
   ,  "Lines specifying layout and display should not start with white space\n"
   ,  "There should be no empty lines within a single problem\n"
   ;  exit(1)
;  }

   my $ystones                =      scalar @{$tsumecols->[0]};

   $tsparams->{'xstones'}     =      $xstones;
   $tsparams->{'ystones'}     =      $ystones;

   for ($y=0;$y<$ystones;$y++) {

      for ($x=0;$x<$xstones;$x++) {

         my $char = $tsumecols->[$x]->[$y];

         if ($tokenchar->{$char}) {
            push @$nodes, [$x, $y, $char];
         }
      }
   }
   return ($nodes, $tsparams);
}


sub trueLocation {

   my $nodes      =  $_[0];
   my $tsparams    =  $_[1];
   my $anchor     =  $tsparams->{'anchor'};
   my $location   =  $tsparams->{'location'};

   my ($xstones, $ystones)
                  =  (  $tsparams->{'xstones'}
                     ,  $tsparams->{'ystones'}
                     )  ;

   my $B_high     =  1;
   my $B_wide     =  1;

   if (  $anchor->{'topsupplied'}) {

      for my $spot (@$nodes) {
         $spot->[1]  =  19 - $ystones + $spot->[1];
      }
      $location->{'goLLy'} =     19
                              -  $::dimensionMap->{$ystones};
   }

   if (  $anchor->{'rgtsupplied'}) {

      for my $spot (@$nodes) {
         $spot->[0]  =  19 - $xstones + $spot->[0];
      }
      $location->{'goLLx'} =     19
                              -  $::dimensionMap->{$xstones};
   }

   if (  $anchor->{'botsupplied'}) {
      $location->{'goURx'} =     $::dimensionMap->{$xstones};
   }

   if (  $anchor->{'lftsupplied'}) {
      $location->{'goURy'} =     $::dimensionMap->{$ystones};
   }

   if (  !$anchor->{'lftsupplied'}
      && !$anchor->{'rgtsupplied'}
      ) {
      $B_wide     =  0;
      $location->{'goLLx'} =     9
                              -  div($::dimensionMap->{$xstones}-1, 2);

      $location->{'goURx'} =     9
                              +  div($::dimensionMap->{$xstones}, 2);
      for my $spot (@$nodes) {
         $spot->[0]  =  9 + $spot->[0] - div($xstones, 2);
      }
   }

   if (  !$anchor->{'botsupplied'}
      && !$anchor->{'topsupplied'}
      ) {
      $B_high     =  0;
      $location->{'goLLy'} =     9
                                 -  div($::dimensionMap->{$ystones}-1, 2);
      $location->{'goURy'} =     9
                                 +  div($::dimensionMap->{$ystones}, 2);
      for my $spot (@$nodes) {
         $spot->[1]  =  9 + $spot->[1] - div($ystones, 2);
      }
   }

   if (  !$B_wide && !$B_high) {
      $anchor->{'ctrsupplied'}  =  1;
   }
   return ($nodes, $tsparams);
}


sub makePspreamble {

   my $psparamsDiag  =     $_[0];
   my $pspreamble    =     $::pspreamble;

   my $scalef        =     $psparamsDiag->{'scalef'};
   my $ilw           =     $psparamsDiag->{'innerlinewidth'};
   my $olw           =     $psparamsDiag->{'outerlinewidth'};
   my $wslw          =     $psparamsDiag->{'whitestonelinewidth'};
   my $radius        =     $psparamsDiag->{'radius'};
   my $hradius       =     $psparamsDiag->{'hradius'};

   $pspreamble       =~    s/#innerlinewidth/$ilw/g;
   $pspreamble       =~    s/#outerlinewidth/$olw/g;
   $pspreamble       =~    s/#whitestonelinewidth/$wslw/g;
   $pspreamble       =~    s/#scalef/$scalef/g;
   $pspreamble       =~    s/#radius/$radius/g;
   $pspreamble       =~    s/#hradius/$hradius/g;

   $pspreamble       =~    s/#test/$B_test/g;
   return $pspreamble;
}

sub pstsume {

   my $nodes         =     $_[0];
   my $tsparams      =     $_[1];
   my $psparamsDiag  =     $_[2];
   my $psparamsGrid  =     $_[3];

   my $location      =     $tsparams->{'location'};

   my ($goLLx, $goLLy, $goURx, $goURy)
   =     (  $location->{'goLLx'}
         ,  $location->{'goLLy'}
         ,  $location->{'goURx'}
         ,  $location->{'goURy'}
         )  ;

   my ($transx, $transy, $scalef)
   =     (  $psparamsGrid->{'transx'}
         ,  $psparamsGrid->{'transy'}
         ,  $psparamsDiag->{'scalef'}
         )  ;

   my ($bbLLx, $bbLLy, $bbURx, $bbURy)
   =     (  2.845 * ($transx - ($goURx - $goLLx + 1.1) * $scalef)
         ,  2.845 * ($transy - ($goURy - $goLLy + 1.1) * $scalef)
         ,  2.845 * ($transx + 0.1 * $scalef)
         ,  2.845 * ($transy + 0.1 * $scalef)
         )  ;

   my $box
   =     {  'bbLLx', $bbLLx
         ,  'bbLLy', $bbLLy
         ,  'bbURx', $bbURx
         ,  'bbURy', $bbURy
         }  ;

   my ($whitechar, $blackchar)
   =     (  $tsparams->{'whitechar'}
         ,  $tsparams->{'blackchar'}
         )  ;

   my $tsumecode     =     $::tsumecode;


   {
      my $clipLLx    =      $goLLx - 0.5;
      my $clipLLy    =      $goLLy - 0.5;
      my $clipURx    =      $goURx + 0.5;
      my $clipURy    =      $goURy + 0.5;

      $tsumecode     =~    s/#clipLLx/$clipLLx/g;
      $tsumecode     =~    s/#clipLLy/$clipLLy/g;
      $tsumecode     =~    s/#clipURx/$clipURx/g;
      $tsumecode     =~    s/#clipURy/$clipURy/g;

      $tsumecode     =~    s/#scalef/$scalef/g;
      $tsumecode     =~    s/#transx/$transx/g;
      $tsumecode     =~    s/#transy/$transy/g;
   }

   my @gochars       =     ();

   for my $spot (@$nodes) {

      my $colourcode = $spot->[2] eq $whitechar ? 'ws' : 'bs';
      push @gochars, "$spot->[0] $spot->[1] $colourcode";
   }

   my $tokenlist     =  join "\n", @gochars;
   $tsumecode        =~ s/#tokenlist/$tokenlist/;
   return ($tsumecode, $box);
}


sub printTsumeColumns {
   
   my $cols = $_[0];

   for my $col (@$cols) {

      print join "", @$col;
      print "\n";
   }
}

sub div {
   my $N = $_[0];
   my $k = $_[1];
   return   $k <= $N
            ?  ($N - ($N % $k)) / $k
            :  0
}

sub max {
   return   $_[0] >= $_[1]
            ?  $_[0]
            :  $_[1]
}

sub min {
   return   $_[0] <= $_[1]
            ?  $_[0]
            :  $_[1]
}

sub makeTokenChar {

   my $tsparams          =  $_[0];

   my $whitechar        =  $tsparams->{'whitechar'};
   my $blackchar        =  $tsparams->{'blackchar'};

   $tsparams->{'tokenchar'}->{$whitechar} = 1;
   $tsparams->{'tokenchar'}->{$blackchar} = 1;

   return $tsparams->{'tokenchar'};
}

sub defaultPsparamsGrid {
return
   {  'ofsetx',   70,
      'ofsety',   270,
      'transx',   100,
      'transy',   200,
      'dx',       70,
      'dy',       70,
      'nx',       3,
      'ny',       4
   }  ;
}

sub defaultPsparamsDiag {
return
   {  'innerlinewidth',       0.1,
      'outerlinewidth',       0.3,
      'whitestonelinewidth',  0.15,
      'radius',               0.45,
      'hradius',              0.10,
      'scalef',               4
   }  ;
}

sub defaultTsumeParams {
   my $params              =  {};
   $params->{'anchor'}     =
                           {  'botsupplied'   =>   0,
                              'topsupplied'   =>   0,
                              'lftsupplied'   =>   0,
                              'rgtsupplied'   =>   0,
                              'ctrsupplied'   =>   0
                           }  ;

   $params->{'location'}   =
                           {  'goLLx'         =>   0,
                              'goLLy'         =>   0,
                              'goURx'         =>   18,
                              'goURy'         =>   18
                           }  ;

   $params->{'tokenchar'}  =  {};

   $params->{'whitechar'}  =  'O';
   $params->{'blackchar'}  =  '#';

   $params->{'xstones'}    =  0;
   $params->{'ystones'}    =  0;

   return $params;
}

BEGIN {

   $::dimensionMap =    {  1  =>     9,
                           2  =>     9,
                           3  =>     9,
                           4  =>     9,
                           5  =>     9,
                           6  =>     9,
                           7  =>    11,
                           8  =>    11,
                           9  =>    11,
                          10  =>    13,
                          11  =>    13,
                          12  =>    15,
                          13  =>    15,
                          14  =>    17,
                          15  =>    17,
                          16  =>    19,
                          17  =>    19,
                          18  =>    19,
                          19  =>    19
                        }  ;

   $::borderopts  =     {  'b'             =>   'botsupplied',
                           't'             =>   'topsupplied',
                           'l'             =>   'lftsupplied',
                           'r'             =>   'rgtsupplied',
                           'c'             =>   'ctrsupplied'
                        }  ;

   $::psparamsGridHandle =

   {  'ofsetx'
   ,  {  'param'  ,    'ofsetx'
      ,  'descr'  ,    'Global x ofset (defines top left reference point)',
      }
   ,  'ofsety'
   ,  {  'param'  ,    'ofsety'
      ,  'descr'  ,    'Global y ofset (defines top left reference point)',
      }
   ,  'nx'
   ,  {  'param'  ,    'nx'
      ,  'descr'  ,    'Number of tsume-go problems in x directon',
      }
   ,  'ny'
   ,  {  'param'  ,    'ny'
      ,  'descr'  ,    'Number of tsume-go problems in y directon',
      }
   ,  'dx',
   ,  {  'param'  ,    'dx'
      ,  'descr'  ,    'Distance between problems in x direction',
      }
   ,  'dy',
   ,  {  'param'  ,    'dy'
      ,  'descr'  ,    'Distance between problems in y direction'
      }
   }  ;

   $::psparamsDiagHandle =
   
   {  'ilw'
   ,  {  'param'  ,    'innerlinewidth'
      ,  'descr'  ,    'Thickness of inner lines in mm'
      }
   ,  'olw'
   ,  {  'param'  ,    'outerlinewidth'
      ,  'descr'  ,    'Thickness of border lines in mm'
      }
   ,  'wslw'
   ,  {  'param'  ,    'whitestonelinewidth'
      ,  'descr'  ,    'Thickness of white stone outline in mm'
      }
   ,  'radius'
   ,  {  'param'  ,    'radius'
      ,  'descr'  ,    'Radius of stones as fraction of line gap'
      }
   ,  'hradius'
   ,  {  'param'  ,    'hradius'
      ,  'descr'  ,    'Radius of hoshi dots as fraction of line gap'
      }
   ,  'scalef'
   ,  {  'param'  ,    'scalef'
      ,  'descr'  ,    'Scaling of diagrams (1 unit equals 1 mm)'
      }
   }  ;

   $::help = qq~Usage: $0 [options] <tsume-file>
For <tsume-file> input specifications please visit

      http://members.ams.chello.nl/svandong/ps/index.html#tsume

Options:
-split               Output multiple problems to multiple files.
                        Default: print problems in a cellular grid.
-test                Show BoundingBox.
~;

   $::pspreamble  =  q~%!PS
%%BoundingBox: #bbLLx #bbLLy #bbURx #bbURy
/TestBoundingBox #test def

/innerlinewidth         #innerlinewidth       def
/outerlinewidth         #outerlinewidth       def
/whitestonelinewidth    #whitestonelinewidth def

/bbLLx                  #bbLLx def
/bbLLy                  #bbLLy def
/bbURx                  #bbURx def
/bbURy                  #bbURy def

/xhoshi [3 9 15] def
/yhoshi [3 9 15] def

/scalef     #scalef def

/radius     #radius def
/hradius    #hradius def

TestBoundingBox 1 eq {
gsave
   0.5 setlinewidth
   bbLLx bbLLy moveto
   bbURx bbLLy lineto
   bbURx bbURy lineto
   bbLLx bbURy lineto
   closepath
   stroke
grestore
} if

2.845 2.845 scale

/ws {
gsave
   0.0 setgray
   2 copy moveto
   gsave
      1.0 setgray
      currentpoint newpath radius 0 360 arc
      fill
   grestore
   gsave
      whitestonelinewidth scalef div setlinewidth
      currentpoint newpath radius 0 360 arc
      stroke
   grestore
grestore
}  def

/bs {
gsave
   0.0 setgray moveto
   currentpoint newpath radius 0 360 arc
   fill
grestore
}  def

/hs {
gsave
   0.0 setgray moveto
   currentpoint newpath hradius 0 360 arc
   fill
grestore
}  def
~;





$::tsumecode = q~

gsave
   #transx #transy translate
   #scalef #scalef scale
   #clipURx -1 mul #clipURy -1 mul translate

   newpath
   #clipLLx #clipLLy moveto
   #clipURx #clipLLy lineto
   #clipURx #clipURy lineto
   #clipLLx #clipURy lineto
   closepath clip newpath

   xhoshi {
   /x exch def
      yhoshi {
         x exch hs
      }
      forall
   } forall

   innerlinewidth scalef div setlinewidth

   1 1 17
   {  0 moveto
      0 18 rlineto
      stroke
   } for

   1 1 17
   {  0 exch moveto
      18 0 rlineto
      stroke
   } for

   outerlinewidth scalef div setlinewidth
   newpath
   0 0 moveto 0 18 rlineto 18 0 rlineto 0 -18 rlineto
   closepath stroke

#tokenlist
grestore

~;

}