# 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:
syntax highlighted by Code2HTML, v. 0.9.1