# 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: PostscriptGraph.pm 7495 2006-12-11 11:03:05Z gawrilow $
no integer;
package Postscript::Graph;
use Struct (
[ '@ISA' => 'Postscript::PointSet' ],
'$directed',
);
sub new {
my $self=&_new;
my ($labelwidth)=$self->init;
$self->marginLeft=$self->marginRight=
($avg_char_width * $fontsize*$labelwidth + $text_spacing)/2 + $line_width;
$self->marginTop=$self->marginBottom=
($fontsize + $text_spacing)/2 + $line_width;
$self->directed=$self->source->Directed;
$self;
}
sub draw_edge {
my ($self, $edge)=@_;
my ($s, $t)=$edge->incident_nodes;
# my $label=$Graph->get_edge_label($edge);
my $rgb="0 0 0";
my $lw=$line_width;
my $style=$self->source->EdgeStyle;
$style=$style->($edge) if is_code($style);
if ($style =~ $Visual::hidden_re) {
return "";
}
if ($style =~ $Visual::thickness_re) {
$lw*=$1;
}
my $color=$self->source->EdgeColor;
$color=$color->($edge) if is_code($color);
if (my @color=Visual::parse_color($color)) {
$rgb=RGB2float(@color[2..4]);
}
return "$rgb $lw ".join(" ", @{$self->coords->[$s]})." ".join(" ", @{$self->coords->[$t]}) ." edge\n";
}
sub node_decorations {
my ($self, $node)=@_;
my $rgb="1 1 1";
my $bw=$line_width;
my $fill="true";
my $style=$self->source->NodeStyle;
$style=$style->($node) if is_code($style);
if ($style =~ $Visual::hidden_re) {
return ();
}
if ($style =~ $Visual::thickness_re) {
$bw*=$1;
}
my $color=$self->source->NodeColor;
$color=$color->($node) if is_code($color);
if (my @color=Visual::parse_color($color)) {
$rgb=RGB2float(@color[2..4]);
$fill="false" if $color[0];
}
return ("$rgb $fill $bw", "(".($self->source->NodeLabels ? $self->source->NodeLabels->($node) : " ").")");
}
sub draw_node {
my ($self, $node)=@_;
my @dec=$self->node_decorations($node);
return @dec ? join(" ", @dec, @{$self->coords->[$node]}) ." CenteredLabel\n" : "";
}
sub draw {
my ($self, $page)=@_;
foreach my $p (@{$self->coords}) {
@$p=$page->transform(@$p);
}
my $Graph=$self->source;
my $nodes=@{$self->coords};
local $"=" "; # for any case ...
$page->code .= "/edge /" . ($self->directed ? "dir_edge" : "undir_edge") . " load def\n";
for (my $edge=$Graph->edges(); $edge; ++$edge) {
$page->code .= $self->draw_edge($edge);
}
for (my $n=0; $n<$nodes; ++$n) {
$page->code .= $self->draw_node($n);
}
}
my $common_procs=<<"-----";
/text_spacing $text_spacing def
/labelheight $fontsize text_spacing add def
% create rectangular path of size width*labelheight
% centered at the current position
% width ->
/box {
dup 2 div neg labelheight 2 div neg rmoveto
0 labelheight rlineto
0 rlineto
0 labelheight neg rlineto
closepath
} bind def
% draw the colored box with black border (if fill=true) or the white box with colored border (if fill=false)
% centered at (x,y)
% r g b fill borderwidth width x y ->
/BorderedBox {
gsave
newpath moveto box setlinewidth
{ setrgbcolor gsave fill grestore 0 setgray } % fill=true
{ 1 setgray gsave fill grestore setrgbcolor } % fill=false
ifelse
stroke
grestore
} bind def
-----
my $dir_procs=<<"-----";
/arrowheadlength $arrowheadlength def
/arrowheadwidth $arrowheadwidth def
% draw edge (arrow) from (x1,y1) to (x2,y2)
% r g b linewidth x1 y1 x2 y2 ->
/dir_edge {
gsave
8 dict begin
/y2 exch def
/x2 exch def
/y1 exch def
/x1 exch def
/dx x2 x1 sub def
/dy y2 y1 sub def
/arrowlength dx dx mul dy dy mul add sqrt def
/angle dy dx atan def
setlinewidth setrgbcolor
x1 y1 translate
angle rotate
0 0 moveto arrowlength 0 lineto stroke
arrowlength arrowheadlength sub arrowheadwidth 2 div moveto
arrowlength 0 lineto
arrowlength arrowheadlength sub arrowheadwidth 2 div neg lineto
closepath fill
end
grestore
} def
-----
my $undir_procs=<<"-----";
% draw edge from (x1,y1) to (x2,y2)
% r g b linewidth x1 y1 x2 y2 ->
/undir_edge {
gsave newpath moveto lineto setlinewidth setrgbcolor stroke grestore
} bind def
-----
my $graph_procs=<<"-----";
% draw a boxed label with center (x,y) and appropriate width
% R G B fill borderwidth (label) x y ->
/CenteredLabel {
gsave
4 dict begin
/y exch def
/x exch def
dup stringwidth pop /lw exch def
/label exch def
lw text_spacing add x y BorderedBox
x lw 2 div sub y $fontsize 0.3 mul sub moveto
label show
end
grestore
} def
-----
###########################################################################
package Postscript::Lattice;
use Struct (
[ '@ISA' => 'Postscript::Graph' ],
[ '$locked' => '0' ],
'%sorted',
);
sub new {
my $self=&_new;
my $Graph=$self->source;
$self->directed = $Graph->ArrowStyle;
my @label_width=map {
($avg_char_width * $fontsize * length($Graph->NodeLabels->($_)) + $text_spacing)*(1+$face_spacing);
} 0..$Graph->get_number_nodes-1;
$label_width[0]=$Wpaper-2*$Wmargin;
my $embedding=$Graph->Coord;
if (is_object($embedding)) {
# expecting Visual::Embedding("hd_embedder", "LATTICE_SECTION", params...) here
$embedding->splice(2, [ "@label_width\n" ], $Graph->Mode, undef);
}
@{$self->coords}=map { [ split ] } @$embedding;
my $style=$Graph->NodeStyle;
foreach my $n (0..$#label_width) {
if (!is_code($style) || $style->($n) !~ $Visual::hidden_re) {
my ($x, $y)=@{$self->coords->[$n]};
assign_min($self->minX, $x-$label_width[$n]/2);
assign_max($self->maxX, $x+$label_width[$n]/2);
assign_min_max($self->minY, $self->maxY, $y);
}
}
$self->marginTop=$self->marginBottom= 0.5*$fontsize + 0.5*$text_spacing + $line_width;
$self->marginLeft=$self->marginRight= 0.5*$text_spacing + $line_width;
$self;
}
sub draw_node {
my ($self, $node)=@_;
my ($x, $y)=@{$self->coords->[$node]};
if (my @decor=$self->node_decorations($node)) {
unshift @decor, $x;
push @{$self->sorted->{$y}}, \@decor;
}
return ""; # will produce PostScript code later
}
sub draw_edge {
my ($self, $edge)=@_;
my $rgb="0 0 0";
my $lw=$line_width;
my $style=$self->source->EdgeStyle;
$style=$style->($edge) if is_code($style);
if ($style =~ $Visual::hidden_re) {
return "";
}
if ($style =~ $Visual::thickness_re) {
$lw*=$1;
}
my $color=$self->source->EdgeColor;
$color=$color->($edge) if is_code($color);
if (my @color=Visual::parse_color($color)) {
$rgb=RGB2float(@color[2..4]);
}
my $arrow_style=$self->source->ArrowStyle;
$arrow_style=$arrow_style->($edge) if is_code($arrow_style);
my ($s,$t);
if ($arrow_style>0) {
($s,$t)=$edge->incident_nodes;
} else {
($t,$s)=$edge->incident_nodes;
}
return "$rgb $lw @{$self->coords->[$s]} @{$self->coords->[$t]} edge\n";
}
sub draw {
my ($self, $page)=@_;
&Postscript::Graph::draw;
my $code="[\n";
while (my ($y, $list)=each %{$self->sorted}) {
my @sorted_by_x=sort { $list->[$a]->[0] <=> $list->[$b]->[0] } 0..$#$list;
my $min_gap=$Wpaper;
foreach my $i (1..$#sorted_by_x-1) {
assign_min($min_gap, $list->[$sorted_by_x[$i]]->[0] - $list->[$sorted_by_x[$i-1]]->[0]);
assign_min($min_gap, $list->[$sorted_by_x[$i+1]]->[0] - $list->[$sorted_by_x[$i]]->[0]);
}
$code .= " [ $y $min_gap\n" .
join("", map { my $i=$_;
" [" . join(" ", map { $list->[$_]->[$i] } @sorted_by_x) . "]\n"
} 0..$#{$list->[0]}) .
" ]\n";
}
$code .= "] draw_nodes\n";
$page->code .= $code;
$page->dict->{face_spacing}=1+$face_spacing;
}
my $lattice_procs=<<"-----";
/min { 2 copy gt { exch } if pop } bind def
/max { 2 copy lt { exch } if pop } bind def
% [ [ y gap [ x ] [ R G B fill borderwidth ] [ label ] ] ... ] ->
/draw_nodes {
7 dict begin
/label 0 def /RGB 0 def /x 0 def /gap 0 def /y 0 def
/font_scale 1 def /i 0 def
% find the minimal text scale suitable for all layers
dup
{
dup 1 get
% param_array, layer_array, gap ->
0 2 index 4 get
% param_array, layer_array, gap, 0, label_array ->
dup length 1 eq { pop pop labelheight } { { stringwidth pop text_spacing add max } forall } ifelse % find max label width
% param_array, layer_array, gap, max_width ->
2 copy face_spacing mul div dup font_scale lt { /font_scale exch store } { pop } ifelse % if does not fit in the gap, then scale the text down
exch pop 1 exch put % store the max width in the gap slot
} forall
% draw the layers
{
aload pop
/label exch store /RGB exch store /x exch store /gap exch store /y exch store
0 1 label length 1 sub {
/i exch store
RGB i 5 mul 5 getinterval aload pop gap font_scale mul x i get y BorderedBox
x i get y moveto
gsave
font_scale font_scale scale
label i get dup stringwidth pop -2 div $fontsize -0.3 mul rmoveto show
grestore
} for
} forall
end
} def
-----
###########################################################################
package Postscript::Page;
sub addGraph {
my ($self, $Graph)=@_;
$self->title ||= $Graph->Name;
return if $Graph->Hidden;
push @{$self->elements}, new Postscript::Graph($Graph);
$self->procsets->{'Graph::common'}=$common_procs;
$self->procsets->{'Graph::graph'}=$graph_procs;
if ($Graph->Directed) {
$self->procsets->{'Graph::directed'}=$dir_procs;
} else {
$self->procsets->{'Graph::undirected'}=$undir_procs;
}
$self->dict->{edge}="null";
}
sub addLattice {
my ($self, $Lattice)=@_;
$self->title ||= $Lattice->Name;
return if $Lattice->Hidden;
push @{$self->elements}, new Postscript::Lattice($Lattice);
%{$self->procsets}=( 'Graph::common'=>$common_procs, 'Graph::lattice'=>$lattice_procs);
if($Lattice->ArrowStyle) {
$self->procsets->{'Graph::directed'}=$dir_procs;
} else {
$self->procsets->{'Graph::undirected'}=$undir_procs;
}
$self->dict->{edge}="null";
}
1
# Local Variables:
# c-basic-offset:3
# End:
syntax highlighted by Code2HTML, v. 0.9.1