#  Copyright (c) 1997-2006
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de
#
#  This program is free software; you can redistribute it and/or modify it
#  under the terms of the GNU General Public License as published by the
#  Free Software Foundation; either version 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#-----------------------------------------------------------------------------
#  $Project: polymake $$Id: MetapostGraph.pm 7514 2006-12-15 17:58:53Z gawrilow $

use strict;
no integer;

package Metapost::File;		# siehe Visual.pm : visualize_explicit()

use Struct (
   [ new => '$;$' ],
   [ '$workfile' => '#1' ],	# 1. argument vom Constructor
   [ '$title' => '#2' ],
   '@figures',
   [ '$unnamed' => '0' ],
);


sub new_drawing {
   my ($self, $title)=@_;
   push @{$self->figures}, new figure( scalar(@{$self->figures}), $title );
   $self;
}

sub append {
   my $self = shift;
   $self->figures->[-1]->append(@_);
}


sub header {
   my ($self) = @_;
   my $who=$ENV{USER};
   my $when=localtime();
   my $title=$self->title;
   if (!length($title) && @{$self->figures}) {
      $title=$self->figures->[0]->title || "unnamed";
   }
   return <<".";
% produced by polymake for $who
% $when
% $title

verbatimtex
%&latex
\\documentclass{article}
\\usepackage{amsmath,amssymb,amsfonts}
\\begin{document}
etex

.
}

sub trailer {
   return <<".";

end
% EOF
.
}

my $global_tuning_params=<<'.';
% general
  numeric u, normalpen, mediumpen, thickpen, dotsize;
  u         := 1cm; % global unit parameter, reduce this if mpost issues '! Value is too large'
  normalpen := .5pt;
  mediumpen := 1pt;
  thickpen  := 2pt;
  dotsize   := 5pt;
.

sub toString {
   my $self=shift;
   my $preamble=$self->header;
   my $content=join("", map { $_->toString } @{$self->figures});
   my (%macros, %tuning);
   foreach my $fig (@{$self->figures}) {
      foreach (@{$fig->elements}) {
         push %macros, %{$_->macros};
	 push %tuning, %{$_->tuning};
      }
   }
   $tuning{default} ||= $global_tuning_params;
   if (keys %tuning) {
      $preamble .= "% tuning parameters\n" . join("\n", values %tuning) . "% end of tuning parameters\n\n";
   }
   if (keys %macros) {
      $preamble .= "% macro definitions\n" . join("\n", values %macros) . "% end of macro definitions\n\n";
   }
   $preamble . $content . $self->trailer;
}

sub print_it {
   my ($self) = @_;
   open my $file, ">".$self->workfile
      or die ref($self), "::print_it: could not write file ", $self->workfile, ": $!\n";
   print $file $self->toString;
   close $file;
}

##############################################################################################
#
#  A Metapost figure
#
package Metapost::figure;

use Struct (
   [ new => '$;$' ],
   '@elements',
   [ '$id' => '#1' ],
   [ '$title' => '#2' ],
);

sub append {
   my ($self, $el)=@_;
   push @{$self->elements}, $el;
   $self->title ||= $el->name;
   $self;
}

sub header {
   my ($self)=@_;
   my $title=$self->title || "anonymous figure";
   my $id=$self->id;
   return <<".";
beginfig($id); % $title
  save p, point_thickness;
  pair p[];    % global point array
  numeric point_thickness[];
.
}

sub trailer
{
   return <<".";
endfig;

.
}

sub toString
{
   my $self=shift;
   my $text=$self->header;
   my $n_points=0;
   foreach my $el (@{$self->elements}) {
      # we suppose all elements are derived from Metapost::element
      $text .= "% point coordinates for ".$el->source->Name."\n" . $el->pointArray($n_points);
      $n_points += @{$el->source->Vertices};
   }
   $n_points=0;
   foreach my $el (@{$self->elements}) {
      $text .= "% elements for ".$el->source->Name."\n" . $el->toString($n_points);
      $n_points += @{$el->source->Vertices};
   }
   return $text . $self->trailer;
}


##############################################################################################
#
#  Basis class for all figure objects handled by Metapost
#
package Metapost::element;

use Struct (
   [ new => '$' ],
   [ '$source' => '#1' ],
   '%macros',
   '%tuning',
);

sub pointArray {
   my ($self, $start_index)=@_;
   my $text="";
   my $k=$start_index;
   my $style=$self->source->VertexStyle;
   foreach (@{$self->source->Vertices}) {
      my $point=$_; chomp $point;
      my ($x,$y)=split /\s+/, $point;
      my $set_r="";
      if (is_code($style)) {
	 my $style=$style->($k-$start_index);
	 if ($style =~ $Visual::thickness_re) {
	    $set_r="  point_thickness[$k] := $1*dotsize;"
	 } elsif ($style =~ $Visual::hidden_re) {
	    $set_r="  point_thickness[$k] := 0;"
	 }
      }
      $text .= "  p[$k] := ($x*u,$y*u);$set_r\n";
      ++$k;
   }
   return $text;
}

# => !fill, "withcolor (R,G,B)"
sub parse_color {
   if (defined $_[0]) {
      my @c=Visual::parse_color($_[0]);
      ( $c[0], "withcolor (".join(",", map {$_/255} @c[2..4]).")" );
   } else {
      ();
   }
}

my $circle_macro=<<'.';
  def point_circle(expr i) =
    begingroup
    save c; path c;
    c := fullcircle scaled(if known point_thickness[i]: point_thickness[i] else: point_thickness.dflt fi) shifted p[i];
    unfill c;
    c
    endgroup
  enddef;
.

my $arrow_tuning=<<'.';
  numeric arrow_w, arrow_l;
  arrow_w := 2pt;   % half width
  arrow_l := 8pt;   % length
.
my $graph_arrow_macro=<<'.';
  path parrow;
  parrow = origin -- (-arrow_l,-arrow_w){dir 60} .. {dir 120}(-arrow_l,arrow_w) -- cycle;
  def arrow(expr i,j) =
    parrow shifted((if known point_thickness[j]: -point_thickness[j] else: -point_thickness.dflt fi, 0)/2) rotated angle(p[j]-p[i]) shifted p[j]
  enddef;
.

sub toString {
   my ($self, $start_index)=@_;
   my $name=$self->source->Name;
   my $style=$self->source->VertexStyle;
   if (is_code($style) || $style !~ $Visual::hidden_re) {
      my $preamble="";
      my $text=<<".";
% vertices for $name
.
      my $color=$self->source->VertexColor;
      my $circle;
      my $labels=$self->source->VertexLabels;
      my $last_point=$start_index+$#{$self->source->Vertices};
      my @options;

      if (!is_code($color)) {
	 ($circle, $color)=parse_color($color);
	 push @options, $color || "withcolor black";
	 if ($circle) {
	    $self->macros->{"vertex:circle"} ||= $circle_macro;
	 }
      }
      if (!is_code($style)) {
	 $preamble .= "  point_thickness.dflt := " . ($style =~ $Visual::thickness_re && "$1*") . "dotsize;\n";
	 push @options, "withpen pencircle scaled " . ($circle ? "normalpen" : "point_thickness.dflt");
      } else {
	 $preamble .= "  point_thickness.dflt := dotsize;\n";
      }
      $text .= "  drawoptions(@options);\n" if @options;

      if (!is_code($style) && !is_code($color)) {
	 # all points share the same color and style - can generate a MetaPost loop here
	 my $draw= $circle ? "draw point_circle(i)" : "drawdot p[i]";
	 $text .= <<".";
  for i=$start_index upto $last_point:
    $draw;
  endfor;
.
	 # put the labels
	 if ($labels) {
            $text .= <<".";
% vertex labels for $name
  drawoptions(withcolor black);
.
            for (my $i=$start_index; $i<=$last_point; ++$i) {
	       $text .= "  label.lrt(\"".$labels->($i-$start_index)."\", p[$i]);\n";
	    }
         }

      } else {
	 # points have different styles and/or colors - must generate separate statements
	 my $label_text="";
	 for (my $i=$start_index; $i<=$last_point; ++$i) {
	    my $style= is_code($style) && $style->($i-$start_index);
	    if ($style !~ $Visual::hidden_re) {
	       @options=();
	       if (is_code($color)) {
 		  ($circle, @options)=parse_color($color->($i-$start_index));
	       }
	       if ($circle) {
		  $self->macros->{"vertex:circle"} ||= $circle_macro;
		  $text .= "  draw point_circle($i)@options;\n";
	       } else {
		  push @options, "withpen pencircle scaled " . ($style =~ $Visual::thickness_re ? "point_thickness[$i]" : "point_thickness.dflt");
		  $text .= "  drawdot p[$i]@options;\n";
	       }
	       if ($labels) {
		  $label_text .= "  label.lrt(\"".$labels->($i-$start_index)."\", p[$i]);\n";
	       }
	    }
	 }
	 if ($label_text) {
	    $text .= <<".";
% vertex labels for $name
  drawoptions(withcolor black);
$label_text
.
	 }
      }
      wantarray ? ($preamble, $text) : $preamble.$text;

   } else {
      "% nodes for $name are hidden\n"
   }
}

##############################################################################################
#
#  Graph
#

package Metapost::graph;
use Struct (
   [ '@ISA' => 'Metapost::element' ],
);

sub toString
{
   my ($self, $start_index)=@_;
   my $name=$self->source->Name;
   my $style=$self->source->EdgeStyle;
   if (is_code($style) || $style !~ $Visual::hidden_re) {
      my $preamble="";
      my $text="% edges for $name\n";

      my $scale="normalpen";
      if (!is_code($style) && $style =~ $Visual::thickness_re) {
	 $scale="(1*normalpen)";
      }
      my @options="withpen pencircle scaled $scale";

      my $color=$self->source->EdgeColor;
      if (!is_code($color)) {
	 push @options, parse_color($color) || "withcolor black";
      }
      $text .= "  drawoptions(@options);\n";

      my $arrow=$self->source->Directed;
      if ($arrow) {
	 $self->macros->{"graph:arrow"} ||= $graph_arrow_macro;
	 $self->tuning->{"graph:arrow"} ||= $arrow_tuning;
      }

      for (my $edge=$self->source->edges; $edge; ++$edge) {
	 my ($s,$t)=$edge->incident_nodes;
	 $s+=$start_index; $t+=$start_index;
	 @options=();
	 my @coloroptions=();

	 if (my $style= is_code($style) && $style->($edge)) {
	    if ($style =~ $Visual::thickness_re) {
	       push @options, "withpen pencircle scaled($1*normalpen)";
	    }
	 }
	 if (my $color= is_code($color) && parse_color($color->($edge))) {
	    push @options, $color;
	    push @coloroptions, $color;
	 }
	 $text .= <<".";
  draw p[$s]--p[$t]@options;
.
	 if ($arrow) {
	    $text .= <<".";
  fill arrow($s,$t)@coloroptions;
.
	 }
      }

      my ($p_preamble, $p_text)=$self->SUPER::toString($start_index);
      wantarray ? ($p_preamble.$preamble, $text.$p_text) : $p_preamble.$preamble.$text.$p_text;

   } else {
      "% edges for $name are hidden\n" . $self->SUPER::toString($start_index);
   }
}

##############################################################################################
#
#  Face Lattice
#

package Metapost::lattice;
use Struct (
   [ '@ISA' => 'Metapost::element' ],
);

my $lattice_node_macro=<<'.';
  numeric x_k;
  def max_k_row(expr ifirst)(text ilist) =
    begingroup
    save i, j, max_k; numeric i, k, max_k;
    i := ifirst;
    max_k := 0;
    for j=ilist:
      k := (2*label_gap+node_gap*u+xpart(urcorner node_label[i] - center node_label[i] + center node_label[j] - ulcorner node_label[j]))/xpart(p[j]-p[i]);
      max_k := max(max_k, k);
      i := j;
    endfor
    max_k
    endgroup
  enddef;
  def scale_nodes(expr b,e) =
    for i=b upto e:
      p[i] := (x_k*xpart p[i], u*y_stretch*ypart p[i]);
    endfor
  enddef;
  def lattice_node(expr i,border_c,fill_c) =
    begingroup
    save b, d; path b; pair d;
    b := (ulcorner node_label[i]+(-label_gap,label_gap)) -- (urcorner node_label[i]+(label_gap,label_gap)) --
         (lrcorner node_label[i]+(label_gap,-label_gap)) -- (llcorner node_label[i]+(-label_gap,-label_gap)) -- cycle;
    d := p[i] - center node_label[i];
    fill b shifted d withcolor fill_c;
    draw b shifted d withcolor border_c withpen pencircle scaled(if known point_thickness[i]: point_thickness[i] else: point_thickness.dflt fi);
    draw node_label[i] shifted d withcolor black;
    endgroup
  enddef;
.
my $lattice_arrow_macro=<<'.';
  def lattice_arrow(expr i,j) =
    begingroup
    save a; numeric a;
    a := angle(p[j]-p[i]);
    parrow shifted(-(0.5*ypart(urcorner node_label[j] - lrcorner node_label[j])+label_gap)/abs(sind(a)), 0) rotated a shifted p[j]
    endgroup
  enddef;
.

# => border_color, fill_color
sub parse_node_color {
   if (defined $_[0]) {
      my @c=Visual::parse_color($_[0]);
      my $c="(".join(",", map {$_/255} @c[2..4]).")";
      if ($c[0]) {
	 ($c, "white")
      } else {
	 ( "black", $c )
      }
   } else {
      ( "black", "white" )
   }
}

sub pointArray {
   my ($self, $start_index)=@_;
   $self->tuning->{"lattice"} ||= <<'.';
% for face lattice drawings
  numeric y_stretch, label_gap;
  y_stretch := 5;       % vertical stretch
  label_gap := 3pt;     % between label text and surrounding box
  node_gap  := 0.25;    % between two nodes (relative to u)
.
   my $text=<<".";
  save node_label;
  picture node_label[];
.
   my $styles=$self->source->VertexStyle;
   if (is_object(my $embedding=$self->source->Coord)) {
      my @label_width=map {
	 # label spacing: twice char width between the boxes, half char width between border and label
	 length($self->source->VertexLabels->($_))+3
      } 0..$self->source->get_number_nodes-1;
      $embedding->splice(2, [ "@label_width\n" ], $self->source->Mode, undef);
   }

   my $last_point=$start_index+$#{$self->source->Vertices};
   my %sorted_by_y;

   for (my $k=$start_index; $k<=$last_point; ++$k) {
      my $point=$self->source->Coord->[$k-$start_index]; chomp $point;
      my ($x,$y)=split /\s+/, $point;
      my $set_r="";
      if (is_code($styles)) {
	 my $style=$styles->($k-$start_index);
	 if ($style =~ $Visual::thickness_re) {
	    $set_r="  point_thickness[$k] := $1*normalpen;"
	 }
      }
      my $label=$self->source->VertexLabels->($k-$start_index);
      $text .= <<".";
  node_label[$k] := thelabel("$label", origin);
  p[$k] := ($x,$y);$set_r
.
      push @{$sorted_by_y{$y}}, [ $x, $k ];
   }

   $text .= "  x_k := max( "
          . join(",\n              ",
		 map {
		    "max_k_row(" . join(",", map { $_->[1] } sort { $a->[0] <=> $b->[0] } @$_) . ")"
		 } grep { $#$_>0 } values %sorted_by_y)
	  . " );\n  scale_nodes($start_index,$last_point);\n\n";

   $self->macros->{"lattice:node"} ||= $lattice_node_macro;
   return $text;
}

sub toString
{
   my ($self, $start_index)=@_;
   my $name=$self->source->Name;
   my $styles=$self->source->EdgeStyle;
   my $preamble="";
   my $text="% edges for $name\n";

   my $scale="normalpen";
   if (!is_code($styles) && $styles =~ $Visual::thickness_re) {
      $scale="($1*normalpen)";
   }
   my @options="withpen pencircle scaled $scale";

   my $colors=$self->source->EdgeColor;
   if (!is_code($colors)) {
      push @options, parse_color($colors) || "withcolor black";
   }
   $text .= "  drawoptions(@options);\n";

   my $arrows=$self->source->ArrowStyle;
   if ($arrows) {
      $self->macros->{"graph:arrow"} ||= $graph_arrow_macro;
      $self->tuning->{"graph:arrow"} ||= $arrow_tuning;
      $self->macros->{"lattice:arrow"} ||= $lattice_arrow_macro;
   }

   for (my $edge=$self->source->edges; $edge; ++$edge) {
      my ($s,$t)=$edge->incident_nodes;
      $s+=$start_index; $t+=$start_index;
      @options=();
      my @coloroptions=();

      if (my $style= is_code($styles) && $styles->($edge)) {
	 next if $style =~ $Visual::hidden_re;
	 if ($style =~ $Visual::thickness_re) {
	    push @options, "withpen pencircle scaled($1*normalpen)"
	 }
      }
      if (my $color= is_code($colors) && parse_color($colors->($edge))) {
	 push @options, $color;
	 push @coloroptions, $color;
      }
      $text .= <<".";
  draw p[$s]--p[$t]@options;
.
      if ($arrows) {
	 my $arrow= is_code($arrows) ? $arrows->($edge) : $arrows;
	 if ($arrow>0) {
	    $text .= <<".";
  fill lattice_arrow($s,$t)@coloroptions;
.
	 } elsif ($arrow<0) {
	    $text .= <<".";
  fill lattice_arrow($t,$s)@coloroptions;
.
	 }
      }
   }

   $styles=$self->source->VertexStyle;
   $colors=$self->source->VertexColor;
   $text .= <<".";
% nodes for $name
.
   my $last_point=$start_index+$#{$self->source->Vertices};
   if (!is_code($styles)) {
      $preamble .= "  point_thickness.dflt := " . ($styles =~ $Visual::thickness_re && "$1*") . "normalpen;\n";
   } else {
      $preamble .= "  point_thickness.dflt := normalpen;\n";
   }
   if (!is_code($colors)) {
      # all nodes share the same color - can generate a MetaPost loop here

      my ($border, $color)=parse_node_color($colors);
      my ($first, $last)=($start_index, $last_point);
      if (is_code($styles)) {
	 # currently only the topmost or the bottommost node are occasionally hidden
	 ++$first if $styles->($first-$start_index) =~ $Visual::hidden_re;
	 --$last if $styles->($last-$start_index) =~ $Visual::hidden_re;
      }
      $text .= <<".";
  for i=$first upto $last:
    lattice_node(i,$border,$color);
  endfor;
.

   } else {
      # points have different colors - must generate separate statements
      for (my $i=$start_index; $i<=$last_point; ++$i) {
	 next if is_code($styles) && $styles->($i-$start_index) =~ $Visual::hidden_re;
	 my ($border, $color)=parse_node_color($colors->($i-$start_index));
	 $text .= <<".";
  lattice_node($i,$border,$color);
.
      }
   }

   wantarray ? ($preamble, $text) : $preamble.$text;
}

1

# Local Variables:
# c-basic-offset:3
# End: