2866 lines
70 KiB
Perl
2866 lines
70 KiB
Perl
#############################################################################
|
|
# Represents one node in a Graph::Easy graph.
|
|
#
|
|
# (c) by Tels 2004-2008. Part of Graph::Easy.
|
|
#############################################################################
|
|
|
|
package Graph::Easy::Node;
|
|
|
|
$VERSION = '0.76';
|
|
|
|
use Graph::Easy::Base;
|
|
use Graph::Easy::Attributes;
|
|
@ISA = qw/Graph::Easy::Base/;
|
|
|
|
use Graph::Easy::Util qw(ord_values);
|
|
|
|
# to map "arrow-shape" to "arrowshape"
|
|
my $att_aliases;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use constant isa_cell => 0;
|
|
|
|
sub _init
|
|
{
|
|
# Generic init routine, to be overridden in subclasses.
|
|
my ($self,$args) = @_;
|
|
|
|
$self->{name} = 'Node #' . $self->{id};
|
|
|
|
$self->{att} = { };
|
|
$self->{class} = 'node'; # default class
|
|
|
|
foreach my $k (sort keys %$args)
|
|
{
|
|
if ($k !~ /^(label|name)\z/)
|
|
{
|
|
require Carp;
|
|
Carp::confess ("Invalid argument '$k' passed to Graph::Easy::Node->new()");
|
|
}
|
|
$self->{$k} = $args->{$k} if $k eq 'name';
|
|
$self->{att}->{$k} = $args->{$k} if $k eq 'label';
|
|
}
|
|
|
|
# These are undef (to save memory) until needed:
|
|
# $self->{children} = {};
|
|
# $self->{dx} = 0; # relative to no other node
|
|
# $self->{dy} = 0;
|
|
# $self->{origin} = undef; # parent node (for relative placement)
|
|
# $self->{group} = undef;
|
|
# $self->{parent} = $graph or $group;
|
|
# Mark as not yet laid out:
|
|
# $self->{x} = 0;
|
|
# $self->{y} = 0;
|
|
|
|
$self;
|
|
}
|
|
|
|
my $merged_borders =
|
|
{
|
|
'dotteddashed' => 'dot-dash',
|
|
'dasheddotted' => 'dot-dash',
|
|
'double-dashdouble' => 'double',
|
|
'doubledouble-dash' => 'double',
|
|
'doublesolid' => 'double',
|
|
'soliddouble' => 'double',
|
|
'dotteddot-dash' => 'dot-dash',
|
|
'dot-dashdotted' => 'dot-dash',
|
|
};
|
|
|
|
sub _collapse_borders
|
|
{
|
|
# Given a right border from node one, and the left border of node two,
|
|
# return what border we need to draw on node two:
|
|
my ($self, $one, $two, $swapem) = @_;
|
|
|
|
($one,$two) = ($two,$one) if $swapem;
|
|
|
|
$one = 'none' unless $one;
|
|
$two = 'none' unless $two;
|
|
|
|
# If the border of the left/top node is defined, we don't draw the
|
|
# border of the right/bottom node.
|
|
return 'none' if $one ne 'none' || $two ne 'none';
|
|
|
|
# otherwise, we draw simple the right border
|
|
$two;
|
|
}
|
|
|
|
sub _merge_borders
|
|
{
|
|
my ($self, $one, $two) = @_;
|
|
|
|
$one = 'none' unless $one;
|
|
$two = 'none' unless $two;
|
|
|
|
# "nonenone" => "none" or "dotteddotted" => "dotted"
|
|
return $one if $one eq $two;
|
|
|
|
# none + solid == solid + none == solid
|
|
return $one if $two eq 'none';
|
|
return $two if $one eq 'none';
|
|
|
|
for my $b (qw/broad wide bold double solid/)
|
|
{
|
|
# the stronger one overrides the weaker one
|
|
return $b if $one eq $b || $two eq $b;
|
|
}
|
|
|
|
my $both = $one . $two;
|
|
return $merged_borders->{$both} if exists $merged_borders->{$both};
|
|
|
|
# fallback
|
|
$two;
|
|
}
|
|
|
|
sub _border_to_draw
|
|
{
|
|
# Return the border style we need to draw, taking the shape (none) into
|
|
# account
|
|
my ($self, $shape) = @_;
|
|
|
|
my $cache = $self->{cache};
|
|
|
|
return $cache->{border_style} if defined $cache->{border_style};
|
|
|
|
$shape = $self->{att}->{shape} unless defined $shape;
|
|
$shape = $self->attribute('shape') unless defined $shape;
|
|
|
|
$cache->{border_style} = $self->{att}->{borderstyle};
|
|
$cache->{border_style} = $self->attribute('borderstyle') unless defined $cache->{border_style};
|
|
$cache->{border_style} = 'none' if $shape =~ /^(none|invisible)\z/;
|
|
$cache->{border_style};
|
|
}
|
|
|
|
sub _border_styles
|
|
{
|
|
# Return the four border styles (right, bottom, left, top). This takes
|
|
# into account the neighbouring nodes and their borders, so that on
|
|
# ASCII output the borders can be properly collapsed.
|
|
my ($self, $border, $collapse) = @_;
|
|
|
|
my $cache = $self->{cache};
|
|
|
|
# already computed values?
|
|
return if defined $cache->{left_border};
|
|
|
|
$cache->{left_border} = $border;
|
|
$cache->{top_border} = $border;
|
|
$cache->{right_border} = $border;
|
|
$cache->{bottom_border} = $border;
|
|
|
|
return unless $collapse;
|
|
|
|
# print STDERR " border_styles: $self->{name} border=$border\n";
|
|
|
|
my $EM = 14;
|
|
my $border_width = Graph::Easy::_border_width_in_pixels($self,$EM);
|
|
|
|
# convert overly broad borders to the correct style
|
|
$border = 'bold' if $border_width > 2;
|
|
$border = 'broad' if $border_width > $EM * 0.2 && $border_width < $EM * 0.75;
|
|
$border = 'wide' if $border_width >= $EM * 0.75;
|
|
|
|
# XXX TODO
|
|
# handle different colors, too:
|
|
# my $color = $self->color_attribute('bordercolor');
|
|
|
|
# Draw border on A (left), and C (left):
|
|
#
|
|
# +---+
|
|
# B | A | C
|
|
# +---+
|
|
|
|
# Ditto, plus C's border:
|
|
#
|
|
# +---+---+
|
|
# B | A | C |
|
|
# +---+---+
|
|
#
|
|
|
|
# If no left neighbour, draw border normally
|
|
|
|
# XXX TODO: ->{parent} ?
|
|
my $parent = $self->{parent} || $self->{graph};
|
|
return unless ref $parent;
|
|
|
|
my $cells = $parent->{cells};
|
|
return unless ref $cells;
|
|
|
|
my $x = $self->{x}; my $y = $self->{y};
|
|
|
|
$x -= 1; my $left = $cells->{"$x,$y"};
|
|
$x += 1; $y-= 1; my $top = $cells->{"$x,$y"};
|
|
$x += 1; $y += 1; my $right = $cells->{"$x,$y"};
|
|
$x -= 1; $y += 1; my $bottom = $cells->{"$x,$y"};
|
|
|
|
# where to store the result
|
|
my @where = ('left', 'top', 'right', 'bottom');
|
|
# need to swap arguments to _collapse_borders()?
|
|
my @swapem = (0, 0, 1, 1);
|
|
|
|
for my $other ($left, $top, $right, $bottom)
|
|
{
|
|
my $side = shift @where;
|
|
my $swap = shift @swapem;
|
|
|
|
# see if we have a (visible) neighbour on the left side
|
|
if (ref($other) &&
|
|
!$other->isa('Graph::Easy::Edge') &&
|
|
!$other->isa_cell() &&
|
|
!$other->isa('Graph::Easy::Node::Empty'))
|
|
{
|
|
$other = $other->{node} if ref($other->{node});
|
|
|
|
# print STDERR "$side node $other ", $other->_border_to_draw(), " vs. $border (swap $swap)\n";
|
|
|
|
if ($other->attribute('shape') ne 'invisible')
|
|
{
|
|
# yes, so take its border style
|
|
my $result;
|
|
if ($swap)
|
|
{
|
|
$result = $self->_merge_borders($other->_border_to_draw(), $border);
|
|
}
|
|
else
|
|
{
|
|
$result = $self->_collapse_borders($border, $other->_border_to_draw());
|
|
}
|
|
$cache->{$side . '_border'} = $result;
|
|
|
|
# print STDERR "# result: $result\n";
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub _correct_size
|
|
{
|
|
# Correct {w} and {h} after parsing. This is a fallback in case
|
|
# the output specific routines (_correct_site_ascii() etc) do
|
|
# not exist.
|
|
my $self = shift;
|
|
|
|
return if defined $self->{w};
|
|
|
|
my $shape = $self->attribute('shape');
|
|
|
|
if ($shape eq 'point')
|
|
{
|
|
$self->{w} = 5;
|
|
$self->{h} = 3;
|
|
my $style = $self->attribute('pointstyle');
|
|
my $shape = $self->attribute('pointshape');
|
|
if ($style eq 'invisible' || $shape eq 'invisible')
|
|
{
|
|
$self->{w} = 0; $self->{h} = 0; return;
|
|
}
|
|
}
|
|
elsif ($shape eq 'invisible')
|
|
{
|
|
$self->{w} = 3;
|
|
$self->{h} = 3;
|
|
}
|
|
else
|
|
{
|
|
my ($w,$h) = $self->dimensions();
|
|
$self->{h} = $h;
|
|
$self->{w} = $w + 2;
|
|
}
|
|
|
|
my $border = $self->_border_to_draw($shape);
|
|
|
|
$self->_border_styles($border, 'collapse');
|
|
|
|
# print STDERR "# $self->{name} $self->{w} $self->{h} $shape\n";
|
|
# use Data::Dumper; print Dumper($self->{cache});
|
|
|
|
if ($shape !~ /^(invisible|point)/)
|
|
{
|
|
$self->{w} ++ if $self->{cache}->{right_border} ne 'none';
|
|
$self->{w} ++ if $self->{cache}->{left_border} ne 'none';
|
|
$self->{h} ++ if $self->{cache}->{top_border} ne 'none';
|
|
$self->{h} ++ if $self->{cache}->{bottom_border} ne 'none';
|
|
|
|
$self->{h} += 2 if $border eq 'none' && $shape !~ /^(invisible|point)/;
|
|
}
|
|
|
|
$self;
|
|
}
|
|
|
|
sub _unplace
|
|
{
|
|
# free the cells this node occupies from $cells
|
|
my ($self,$cells) = @_;
|
|
|
|
my $x = $self->{x}; my $y = $self->{y};
|
|
delete $cells->{"$x,$y"};
|
|
$self->{x} = undef;
|
|
$self->{y} = undef;
|
|
$self->{cache} = {};
|
|
|
|
$self->_calc_size() unless defined $self->{cx};
|
|
|
|
if ($self->{cx} + $self->{cy} > 2) # one of them > 1!
|
|
{
|
|
for my $ax (1..$self->{cx})
|
|
{
|
|
my $sx = $x + $ax - 1;
|
|
for my $ay (1..$self->{cy})
|
|
{
|
|
my $sy = $y + $ay - 1;
|
|
# free cell
|
|
delete $cells->{"$sx,$sy"};
|
|
}
|
|
}
|
|
} # end handling multi-celled node
|
|
|
|
# unplace all edges leading to/from this node, too:
|
|
for my $e (ord_values ( $self->{edges} ))
|
|
{
|
|
$e->_unplace($cells);
|
|
}
|
|
|
|
$self;
|
|
}
|
|
|
|
sub _mark_as_placed
|
|
{
|
|
# for creating an action on the action stack we also need to recursively
|
|
# mark all our children as already placed:
|
|
my ($self) = @_;
|
|
|
|
no warnings 'recursion';
|
|
|
|
delete $self->{_todo};
|
|
|
|
for my $child (ord_values ( $self->{children} ))
|
|
{
|
|
$child->_mark_as_placed();
|
|
}
|
|
$self;
|
|
}
|
|
|
|
sub _place_children
|
|
{
|
|
# recursively place node and its children
|
|
my ($self, $x, $y, $parent) = @_;
|
|
|
|
no warnings 'recursion';
|
|
|
|
return 0 unless $self->_check_place($x,$y,$parent);
|
|
|
|
print STDERR "# placing children of $self->{name} based on $x,$y\n" if $self->{debug};
|
|
|
|
for my $child (ord_values ( $self->{children} ))
|
|
{
|
|
# compute place of children (depending on whether we are multicelled or not)
|
|
|
|
my $dx = $child->{dx} > 0 ? $self->{cx} - 1 : 0;
|
|
my $dy = $child->{dy} > 0 ? $self->{cy} - 1 : 0;
|
|
|
|
my $rc = $child->_place_children($x + $dx + $child->{dx},$y + $dy + $child->{dy},$parent);
|
|
return $rc if $rc == 0;
|
|
}
|
|
$self->_place($x,$y,$parent);
|
|
}
|
|
|
|
sub _place
|
|
{
|
|
# place this node at the requested position (without checking)
|
|
my ($self, $x, $y, $parent) = @_;
|
|
|
|
my $cells = $parent->{cells};
|
|
$self->{x} = $x;
|
|
$self->{y} = $y;
|
|
$cells->{"$x,$y"} = $self;
|
|
|
|
# store our position if we are the first node in that rank
|
|
my $r = abs($self->{rank} || 0);
|
|
my $what = $parent->{_rank_coord} || 'x'; # 'x' or 'y'
|
|
$parent->{_rank_pos}->{ $r } = $self->{$what}
|
|
unless defined $parent->{_rank_pos}->{ $r };
|
|
|
|
# a multi-celled node will be stored like this:
|
|
# [ node ] [ filler ]
|
|
# [ filler ] [ filler ]
|
|
# [ filler ] [ filler ] etc.
|
|
|
|
# $self->_calc_size() unless defined $self->{cx};
|
|
|
|
if ($self->{cx} + $self->{cy} > 2) # one of them > 1!
|
|
{
|
|
for my $ax (1..$self->{cx})
|
|
{
|
|
my $sx = $x + $ax - 1;
|
|
for my $ay (1..$self->{cy})
|
|
{
|
|
next if $ax == 1 && $ay == 1; # skip left-upper most cell
|
|
my $sy = $y + $ay - 1;
|
|
|
|
# We might even get away with creating only one filler cell
|
|
# although then its "x" and "y" values would be "wrong".
|
|
|
|
my $filler =
|
|
Graph::Easy::Node::Cell->new ( node => $self, x => $sx, y => $sy );
|
|
$cells->{"$sx,$sy"} = $filler;
|
|
}
|
|
}
|
|
} # end handling of multi-celled node
|
|
|
|
$self->_update_boundaries($parent);
|
|
|
|
1; # did place us
|
|
}
|
|
|
|
sub _check_place
|
|
{
|
|
# chack that a node can be placed at $x,$y (w/o checking its children)
|
|
my ($self,$x,$y,$parent) = @_;
|
|
|
|
my $cells = $parent->{cells};
|
|
|
|
# node cannot be placed here
|
|
return 0 if exists $cells->{"$x,$y"};
|
|
|
|
$self->_calc_size() unless defined $self->{cx};
|
|
|
|
if ($self->{cx} + $self->{cy} > 2) # one of them > 1!
|
|
{
|
|
for my $ax (1..$self->{cx})
|
|
{
|
|
my $sx = $x + $ax - 1;
|
|
for my $ay (1..$self->{cy})
|
|
{
|
|
my $sy = $y + $ay - 1;
|
|
# node cannot be placed here
|
|
return 0 if exists $cells->{"$sx,$sy"};
|
|
}
|
|
}
|
|
}
|
|
1; # can place it here
|
|
}
|
|
|
|
sub _do_place
|
|
{
|
|
# Tries to place the node at position ($x,$y) by checking that
|
|
# $cells->{"$x,$y"} is still free. If the node belongs to a cluster,
|
|
# checks all nodes of the cluster (and when all of them can be
|
|
# placed simultaneously, does so).
|
|
# Returns true if the operation succeeded, otherwise false.
|
|
my ($self,$x,$y,$parent) = @_;
|
|
|
|
my $cells = $parent->{cells};
|
|
|
|
# inlined from _check() for speed reasons:
|
|
|
|
# node cannot be placed here
|
|
return 0 if exists $cells->{"$x,$y"};
|
|
|
|
$self->_calc_size() unless defined $self->{cx};
|
|
|
|
if ($self->{cx} + $self->{cy} > 2) # one of them > 1!
|
|
{
|
|
for my $ax (1..$self->{cx})
|
|
{
|
|
my $sx = $x + $ax - 1;
|
|
for my $ay (1..$self->{cy})
|
|
{
|
|
my $sy = $y + $ay - 1;
|
|
# node cannot be placed here
|
|
return 0 if exists $cells->{"$sx,$sy"};
|
|
}
|
|
}
|
|
}
|
|
|
|
my $children = 0;
|
|
$children = scalar keys %{$self->{children}} if $self->{children};
|
|
|
|
# relativ to another, or has children (relativ to us)
|
|
if (defined $self->{origin} || $children > 0)
|
|
{
|
|
# The coordinates of the origin node. Because 'dx' and 'dy' give
|
|
# our distance from the origin, we can compute the origin by doing
|
|
# "$x - $dx"
|
|
|
|
my $grandpa = $self; my $ox = 0; my $oy = 0;
|
|
# Find our grandparent (e.g. the root of origin chain), and the distance
|
|
# from $x,$y to it:
|
|
($grandpa,$ox,$oy) = $self->find_grandparent() if $self->{origin};
|
|
|
|
# Traverse all children and check their places, place them if poss.
|
|
# This will also place ourselves, because we are a grandchild of $grandpa
|
|
return $grandpa->_place_children($x + $ox,$y + $oy,$parent);
|
|
}
|
|
|
|
# finally place this node at the requested position
|
|
$self->_place($x,$y,$parent);
|
|
}
|
|
|
|
#############################################################################
|
|
|
|
sub _wrapped_label
|
|
{
|
|
# returns the label wrapped automatically to use the least space
|
|
my ($self, $label, $align, $wrap) = @_;
|
|
|
|
return (@{$self->{cache}->{label}}) if $self->{cache}->{label};
|
|
|
|
# XXX TODO: handle "paragraphs"
|
|
$label =~ s/\\(n|r|l|c)/ /g; # replace line splits by spaces
|
|
|
|
# collapse multiple spaces
|
|
$label =~ s/\s+/ /g;
|
|
|
|
# find out where to wrap
|
|
if ($wrap eq 'auto')
|
|
{
|
|
$wrap = int(sqrt(length($label)) * 1.4);
|
|
}
|
|
$wrap = 2 if $wrap < 2;
|
|
|
|
# run through the text and insert linebreaks
|
|
my $i = 0;
|
|
my $line_len = 0;
|
|
my $last_space = 0;
|
|
my $last_hyphen = 0;
|
|
my @lines;
|
|
while ($i < length($label))
|
|
{
|
|
my $c = substr($label,$i,1);
|
|
$last_space = $i if $c eq ' ';
|
|
$last_hyphen = $i if $c eq '-';
|
|
$line_len ++;
|
|
if ($line_len >= $wrap && ($last_space != 0 || $last_hyphen != 0))
|
|
{
|
|
# print STDERR "# wrap at $line_len\n";
|
|
|
|
my $w = $last_space; my $replace = '';
|
|
if ($last_hyphen > $last_space)
|
|
{
|
|
$w = $last_hyphen; $replace = '-';
|
|
}
|
|
|
|
# print STDERR "# wrap at $w\n";
|
|
|
|
# "foo bar-baz" => "foo bar" (lines[0]) and "baz" (label afterwards)
|
|
|
|
# print STDERR "# first part '". substr($label, 0, $w) . "'\n";
|
|
|
|
push @lines, substr($label, 0, $w) . $replace;
|
|
substr($label, 0, $w+1) = '';
|
|
# reset counters
|
|
$line_len = 0;
|
|
$i = 0;
|
|
$last_space = 0;
|
|
$last_hyphen = 0;
|
|
next;
|
|
}
|
|
$i++;
|
|
}
|
|
# handle what is left over
|
|
push @lines, $label if $label ne '';
|
|
|
|
# generate the align array
|
|
my @aligns;
|
|
my $al = substr($align,0,1);
|
|
for my $i (0.. scalar @lines)
|
|
{
|
|
push @aligns, $al;
|
|
}
|
|
# cache the result to avoid costly recomputation
|
|
$self->{cache}->{label} = [ \@lines, \@aligns ];
|
|
(\@lines, \@aligns);
|
|
}
|
|
|
|
sub _aligned_label
|
|
{
|
|
# returns the label lines and for each one the alignment l/r/c
|
|
my ($self, $align, $wrap) = @_;
|
|
|
|
$align = 'center' unless $align;
|
|
$wrap = $self->attribute('textwrap') unless defined $wrap;
|
|
|
|
my $name = $self->label();
|
|
|
|
return $self->_wrapped_label($name,$align,$wrap) unless $wrap eq 'none';
|
|
|
|
my (@lines,@aligns);
|
|
my $al = substr($align,0,1);
|
|
my $last_align = $al;
|
|
|
|
# split up each line from the front
|
|
while ($name ne '')
|
|
{
|
|
$name =~ s/^(.*?([^\\]|))(\z|\\(n|r|l|c))//;
|
|
my $part = $1;
|
|
my $a = $3 || '\n';
|
|
|
|
$part =~ s/\\\|/\|/g; # \| => |
|
|
$part =~ s/\\\\/\\/g; # '\\' to '\'
|
|
$part =~ s/^\s+//; # remove spaces at front
|
|
$part =~ s/\s+\z//; # remove spaces at end
|
|
$a =~ s/\\//; # \n => n
|
|
$a = $al if $a eq 'n';
|
|
|
|
push @lines, $part;
|
|
push @aligns, $last_align;
|
|
|
|
$last_align = $a;
|
|
}
|
|
|
|
# XXX TODO: should remove empty lines at start/end?
|
|
(\@lines, \@aligns);
|
|
}
|
|
|
|
#############################################################################
|
|
# as_html conversion and helper functions related to that
|
|
|
|
my $remap = {
|
|
node => {
|
|
align => undef,
|
|
background => undef,
|
|
basename => undef,
|
|
border => undef,
|
|
borderstyle => undef,
|
|
borderwidth => undef,
|
|
bordercolor => undef,
|
|
columns => undef,
|
|
fill => 'background',
|
|
origin => undef,
|
|
offset => undef,
|
|
pointstyle => undef,
|
|
pointshape => undef,
|
|
rows => undef,
|
|
size => undef,
|
|
shape => undef,
|
|
},
|
|
edge => {
|
|
fill => undef,
|
|
border => undef,
|
|
},
|
|
all => {
|
|
align => 'text-align',
|
|
autolink => undef,
|
|
autotitle => undef,
|
|
comment => undef,
|
|
fontsize => undef,
|
|
font => 'font-family',
|
|
flow => undef,
|
|
format => undef,
|
|
label => undef,
|
|
link => undef,
|
|
linkbase => undef,
|
|
style => undef,
|
|
textstyle => undef,
|
|
title => undef,
|
|
textwrap => \&Graph::Easy::_remap_text_wrap,
|
|
group => undef,
|
|
},
|
|
};
|
|
|
|
sub _extra_params
|
|
{
|
|
# return text with a leading " ", that will be appended to "td" when
|
|
# generating HTML
|
|
'';
|
|
}
|
|
|
|
# XXX TODO: <span class="o">?
|
|
my $pod = {
|
|
B => [ '<b>', '</b>' ],
|
|
O => [ '<span style="text-decoration: overline">', '</span>' ],
|
|
S => [ '<span style="text-decoration: line-through">', '</span>' ],
|
|
U => [ '<span style="text-decoration: underline">', '</span>' ],
|
|
C => [ '<code>', '</code>' ],
|
|
I => [ '<i>', '</i>' ],
|
|
};
|
|
|
|
sub _convert_pod
|
|
{
|
|
my ($self, $type, $text) = @_;
|
|
|
|
my $t = $pod->{$type} or return $text;
|
|
|
|
# "<b>" . "text" . "</b>"
|
|
$t->[0] . $text . $t->[1];
|
|
}
|
|
|
|
sub _label_as_html
|
|
{
|
|
# Build the text from the lines, by inserting <b> for each break
|
|
# Also align each line, and if nec., convert B<bold> to <b>bold</b>.
|
|
my ($self) = @_;
|
|
|
|
my $align = $self->attribute('align');
|
|
my $text_wrap = $self->attribute('textwrap');
|
|
|
|
my ($lines,$aligns);
|
|
if ($text_wrap eq 'auto')
|
|
{
|
|
# set "white-space: nowrap;" in CSS and ignore linebreaks in label
|
|
$lines = [ $self->label() ];
|
|
$aligns = [ substr($align,0,1) ];
|
|
}
|
|
else
|
|
{
|
|
($lines,$aligns) = $self->_aligned_label($align,$text_wrap);
|
|
}
|
|
|
|
# Since there is no "float: center;" in CSS, we must set the general
|
|
# text-align to center when we encounter any \c and the default is
|
|
# left or right:
|
|
|
|
my $switch_to_center = 0;
|
|
if ($align ne 'center')
|
|
{
|
|
local $_;
|
|
$switch_to_center = grep /^c/, @$aligns;
|
|
}
|
|
|
|
$align = 'center' if $switch_to_center;
|
|
my $a = substr($align,0,1); # center => c
|
|
|
|
my $format = $self->attribute('format');
|
|
|
|
my $name = '';
|
|
my $i = 0;
|
|
while ($i < @$lines)
|
|
{
|
|
my $line = $lines->[$i];
|
|
my $al = $aligns->[$i];
|
|
|
|
# This code below will not handle B<bold\n and bolder> due to the
|
|
# line break. Also, nesting does not work due to returned "<" and ">".
|
|
|
|
if ($format eq 'pod')
|
|
{
|
|
# first inner-most, then go outer until there are none left
|
|
$line =~ s/([BOSUCI])<([^<>]+)>/ $self->_convert_pod($1,$2);/eg
|
|
while ($line =~ /[BOSUCI]<[^<>]+>/)
|
|
}
|
|
else
|
|
{
|
|
$line =~ s/&/&/g; # quote &
|
|
$line =~ s/>/>/g; # quote >
|
|
$line =~ s/</</g; # quote <
|
|
$line =~ s/\\\\/\\/g; # "\\" to "\"
|
|
}
|
|
|
|
# insert a span to align the line unless the default already covers it
|
|
$line = '<span class="' . $al . '">' . $line . '</span>'
|
|
if $a ne $al;
|
|
$name .= '<br>' . $line;
|
|
|
|
$i++; # next line
|
|
}
|
|
$name =~ s/^<br>//; # remove first <br>
|
|
|
|
($name, $switch_to_center);
|
|
}
|
|
|
|
sub quoted_comment
|
|
{
|
|
# Comment of this object, quoted suitable as to be embedded into HTML/SVG
|
|
my $self = shift;
|
|
|
|
my $cmt = $self->attribute('comment');
|
|
if ($cmt ne '')
|
|
{
|
|
$cmt =~ s/&/&/g;
|
|
$cmt =~ s/</</g;
|
|
$cmt =~ s/>/>/g;
|
|
$cmt = '<!-- ' . $cmt . " -->\n";
|
|
}
|
|
|
|
$cmt;
|
|
}
|
|
|
|
sub as_html
|
|
{
|
|
# return node as HTML
|
|
my ($self) = @_;
|
|
|
|
my $shape = 'rect';
|
|
$shape = $self->attribute('shape') unless $self->isa_cell();
|
|
|
|
if ($shape eq 'edge')
|
|
{
|
|
my $edge = Graph::Easy::Edge->new();
|
|
my $cell = Graph::Easy::Edge::Cell->new( edge => $edge );
|
|
$cell->{w} = $self->{w};
|
|
$cell->{h} = $self->{h};
|
|
$cell->{att}->{label} = $self->label();
|
|
$cell->{type} =
|
|
Graph::Easy::Edge::Cell->EDGE_HOR +
|
|
Graph::Easy::Edge::Cell->EDGE_LABEL_CELL;
|
|
return $cell->as_html();
|
|
}
|
|
|
|
my $extra = $self->_extra_params();
|
|
my $taga = "td$extra";
|
|
my $tagb = 'td';
|
|
|
|
my $id = $self->{graph}->{id};
|
|
my $a = $self->{att};
|
|
my $g = $self->{graph};
|
|
|
|
my $class = $self->class();
|
|
|
|
# how many rows/columns will this node span?
|
|
my $rs = ($self->{cy} || 1) * 4;
|
|
my $cs = ($self->{cx} || 1) * 4;
|
|
|
|
# shape: invisible; must result in an empty cell
|
|
if ($shape eq 'invisible' && $class ne 'node.anon')
|
|
{
|
|
return " <$taga colspan=$cs rowspan=$rs style=\"border: none; background: inherit;\"></$tagb>\n";
|
|
}
|
|
|
|
my $c = $class; $c =~ s/\./_/g; # node.city => node_city
|
|
|
|
my $html = " <$taga colspan=$cs rowspan=$rs##class####style##";
|
|
|
|
my $title = $self->title();
|
|
$title =~ s/'//g; # replace quotation marks
|
|
|
|
$html .= " title='$title'" if $title ne '' && $shape ne 'img'; # add mouse-over title
|
|
|
|
my ($name, $switch_to_center);
|
|
|
|
if ($shape eq 'point')
|
|
{
|
|
require Graph::Easy::As_ascii; # for _u8 and point-style
|
|
|
|
local $self->{graph}->{_ascii_style} = 1; # use utf-8
|
|
$name = $self->_point_style( $self->attribute('pointshape'), $self->attribute('pointstyle') );
|
|
}
|
|
elsif ($shape eq 'img')
|
|
{
|
|
# take the label as the URL, but escape critical characters
|
|
$name = $self->label();
|
|
$name =~ s/\s/\+/g; # space
|
|
$name =~ s/'/%27/g; # replace quotation marks
|
|
$name =~ s/[\x0d\x0a]//g; # remove 0x0d0x0a and similar
|
|
my $t = $title; $t = $name if $t eq '';
|
|
$name = "<img src='$name' alt='$t' title='$t' border='0' />";
|
|
}
|
|
else
|
|
{
|
|
($name,$switch_to_center) = $self->_label_as_html();
|
|
}
|
|
|
|
# if the label is "", the link wouldn't be clickable
|
|
my $link = ''; $link = $self->link() unless $name eq '';
|
|
|
|
# the attributes in $out will be applied to either the TD, or the inner DIV,
|
|
# unless if we have a link, then most of them will be moved to the A HREF
|
|
my $att = $self->raw_attributes();
|
|
my $out = $self->{graph}->_remap_attributes( $self, $att, $remap, 'noquote', 'encode', 'remap_colors');
|
|
|
|
$out->{'text-align'} = 'center' if $switch_to_center;
|
|
|
|
# only for nodes, not for edges
|
|
if (!$self->isa('Graph::Easy::Edge'))
|
|
{
|
|
my $bc = $self->attribute('bordercolor');
|
|
my $bw = $self->attribute('borderwidth');
|
|
my $bs = $self->attribute('borderstyle');
|
|
|
|
$out->{border} = Graph::Easy::_border_attribute_as_html( $bs, $bw, $bc );
|
|
|
|
# we need to specify the border again for the inner div
|
|
if ($shape !~ /(rounded|ellipse|circle)/)
|
|
{
|
|
my $DEF = $self->default_attribute('border');
|
|
|
|
delete $out->{border} if $out->{border} =~ /^\s*\z/ || $out->{border} eq $DEF;
|
|
}
|
|
|
|
delete $out->{border} if $class eq 'node.anon' && $out->{border} && $out->{border} eq 'none';
|
|
}
|
|
|
|
# we compose the inner part as $inner_start . $label . $inner_end:
|
|
my $inner_start = '';
|
|
my $inner_end = '';
|
|
|
|
if ($shape =~ /(rounded|ellipse|circle)/)
|
|
{
|
|
# set the fill on the inner part, but the background and no border on the <td>:
|
|
my $inner_style = '';
|
|
my $fill = $self->color_attribute('fill');
|
|
$inner_style = 'background:' . $fill if $fill;
|
|
$inner_style .= ';border:' . $out->{border} if $out->{border};
|
|
$inner_style =~ s/;\s?\z$//; # remove '; ' at end
|
|
|
|
delete $out->{background};
|
|
delete $out->{border};
|
|
|
|
my $td_style = '';
|
|
$td_style = ' style="border: none;';
|
|
my $bg = $self->color_attribute('background');
|
|
$td_style .= "background: $bg\"";
|
|
|
|
$html =~ s/##style##/$td_style/;
|
|
|
|
$inner_end = '</span></div>';
|
|
my $c = substr($shape, 0, 1); $c = 'c' if $c eq 'e'; # 'r' or 'c'
|
|
|
|
my ($w,$h) = $self->dimensions();
|
|
|
|
if ($shape eq 'circle')
|
|
{
|
|
# set both to the biggest size to enforce a circle shape
|
|
my $r = $w;
|
|
$r = $h if $h > $w;
|
|
$w = $r; $h = $r;
|
|
}
|
|
|
|
$out->{top} = ($h / 2 + 0.5) . 'em'; delete $out->{top} if $out->{top} eq '1.5em';
|
|
$h = ($h + 2) . 'em';
|
|
$w = ($w + 2) . 'em';
|
|
|
|
$inner_style .= ";width: $w; height: $h";
|
|
|
|
$inner_style = " style='$inner_style'";
|
|
$inner_start = "<div class='$c'$inner_style><span class='c'##style##>";
|
|
}
|
|
|
|
if ($class =~ /^group/)
|
|
{
|
|
delete $out->{border};
|
|
delete $out->{background};
|
|
my $group_class = $class; $group_class =~ s/\s.*//; # "group gt" => "group"
|
|
my @atr = qw/bordercolor borderwidth fill/;
|
|
|
|
# transform "group_foo gr" to "group_foo" if border eq 'none' (for anon groups)
|
|
my $border_style = $self->attribute('borderstyle');
|
|
$c =~ s/\s+.*// if $border_style eq 'none';
|
|
|
|
# only need the color for the label cell
|
|
push @atr, 'color' if $self->{has_label};
|
|
$name = ' ' unless $self->{has_label};
|
|
for my $b (@atr)
|
|
{
|
|
my $def = $g->attribute($group_class,$b);
|
|
my $v = $self->attribute($b);
|
|
|
|
my $n = $b; $n = 'background' if $b eq 'fill';
|
|
$out->{$n} = $v unless $v eq '' || $v eq $def;
|
|
}
|
|
$name = ' ' unless $name ne '';
|
|
}
|
|
|
|
# "shape: none;" or point means no border, and background instead fill color
|
|
if ($shape =~ /^(point|none)\z/)
|
|
{
|
|
$out->{background} = $self->color_attribute('background');
|
|
$out->{border} = 'none';
|
|
}
|
|
|
|
my $style = '';
|
|
for my $atr (sort keys %$out)
|
|
{
|
|
if ($link ne '')
|
|
{
|
|
# put certain styles on the outer container, and not on the link
|
|
next if $atr =~ /^(background|border)\z/;
|
|
}
|
|
$style .= "$atr: $out->{$atr}; ";
|
|
}
|
|
|
|
# bold, italic, underline etc. (but not for empty cells)
|
|
$style .= $self->text_styles_as_css(1,1) if $name !~ /^(| )\z/;
|
|
|
|
$style =~ s/;\s?\z$//; # remove '; ' at end
|
|
$style =~ s/\s+/ /g; # ' ' => ' '
|
|
$style =~ s/^\s+//; # remove ' ' at front
|
|
$style = " style=\"$style\"" if $style;
|
|
|
|
my $end_tag = "</$tagb>\n";
|
|
|
|
if ($link ne '')
|
|
{
|
|
# encode critical entities
|
|
$link =~ s/\s/\+/g; # space
|
|
$link =~ s/'/%27/g; # replace quotation marks
|
|
|
|
my $outer_style = '';
|
|
# put certain styles like border and background on the table cell:
|
|
for my $s (qw/background border/)
|
|
{
|
|
$outer_style .= "$s: $out->{$s};" if exists $out->{$s};
|
|
}
|
|
$outer_style =~ s/;\s?\z$//; # remove '; ' at end
|
|
$outer_style = ' style="'.$outer_style.'"' if $outer_style;
|
|
|
|
$inner_start =~ s/##style##/$outer_style/; # remove from inner_start
|
|
|
|
$html =~ s/##style##/$outer_style/; # or HTML, depending
|
|
$inner_start .= "<a href='$link'##style##>"; # and put on link
|
|
$inner_end = '</a>'.$inner_end;
|
|
}
|
|
|
|
$c = " class='$c'" if $c ne '';
|
|
$html .= ">$inner_start$name$inner_end$end_tag";
|
|
$html =~ s/##class##/$c/;
|
|
$html =~ s/##style##/$style/;
|
|
|
|
$self->quoted_comment() . $html;
|
|
}
|
|
|
|
sub angle
|
|
{
|
|
# return the rotation of the node, dependend on the rotate attribute
|
|
# (and if relative, on the flow)
|
|
my $self = shift;
|
|
|
|
my $angle = $self->{att}->{rotate} || 0;
|
|
|
|
$angle = 180 if $angle =~ /^(south|down)\z/;
|
|
$angle = 0 if $angle =~ /^(north|up)\z/;
|
|
$angle = 270 if $angle eq 'west';
|
|
$angle = 90 if $angle eq 'east';
|
|
|
|
# convert relative angles
|
|
if ($angle =~ /^([+-]\d+|left|right|back|front|forward)\z/)
|
|
{
|
|
my $base_rot = $self->flow();
|
|
$angle = 0 if $angle =~ /^(front|forward)\z/;
|
|
$angle = 180 if $angle eq 'back';
|
|
$angle = -90 if $angle eq 'left';
|
|
$angle = 90 if $angle eq 'right';
|
|
$angle = $base_rot + $angle + 0; # 0 points up, so front points right
|
|
$angle += 360 while $angle < 0;
|
|
}
|
|
|
|
$self->_croak("Illegal node angle $angle") if $angle !~ /^\d+\z/;
|
|
|
|
$angle %= 360 if $angle > 359;
|
|
|
|
$angle;
|
|
}
|
|
|
|
# for determining the absolute parent flow
|
|
my $p_flow =
|
|
{
|
|
'east' => 90,
|
|
'west' => 270,
|
|
'north' => 0,
|
|
'south' => 180,
|
|
'up' => 0,
|
|
'down' => 180,
|
|
'back' => 270,
|
|
'left' => 270,
|
|
'right' => 90,
|
|
'front' => 90,
|
|
'forward' => 90,
|
|
};
|
|
|
|
sub _parent_flow_absolute
|
|
{
|
|
# make parent flow absolute
|
|
my ($self, $def) = @_;
|
|
|
|
return '90' if ref($self) eq 'Graph::Easy';
|
|
|
|
my $flow = $self->parent()->raw_attribute('flow') || $def;
|
|
|
|
return unless defined $flow;
|
|
|
|
# in case of relative flow at parent, convert to absolute (right: east, left: west etc)
|
|
# so that "graph { flow: left; }" results in a westward flow
|
|
my $f = $p_flow->{$flow}; $f = $flow unless defined $f;
|
|
$f;
|
|
}
|
|
|
|
sub flow
|
|
{
|
|
# Calculate the outgoing flow from the incoming flow and the flow at this
|
|
# node (either from edge(s) or general flow). Returns an absolute flow:
|
|
# See the online manual about flow for a reference and details.
|
|
my $self = shift;
|
|
|
|
no warnings 'recursion';
|
|
|
|
my $cache = $self->{cache};
|
|
return $cache->{flow} if exists $cache->{flow};
|
|
|
|
# detected cycle, so break it
|
|
return $cache->{flow} = $self->_parent_flow_absolute('90') if exists $self->{_flow};
|
|
|
|
local $self->{_flow} = undef; # endless loops really ruin our day
|
|
|
|
my $in;
|
|
my $flow = $self->{att}->{flow};
|
|
|
|
$flow = $self->_parent_flow_absolute() if !defined $flow || $flow eq 'inherit';
|
|
|
|
# if flow is absolute, return it early
|
|
return $cache->{flow} = $flow if defined $flow && $flow =~ /^(0|90|180|270)\z/;
|
|
return $cache->{flow} = Graph::Easy->_direction_as_number($flow)
|
|
if defined $flow && $flow =~ /^(south|north|east|west|up|down)\z/;
|
|
|
|
# for relative flows, compute the incoming flow as base flow
|
|
|
|
# check all edges
|
|
for my $e (ord_values ( $self->{edges} ))
|
|
{
|
|
# only count incoming edges
|
|
next unless $e->{from} != $self && $e->{to} == $self;
|
|
|
|
# if incoming edge has flow, we take this
|
|
$in = $e->flow();
|
|
# take the first match
|
|
last if defined $in;
|
|
}
|
|
|
|
if (!defined $in)
|
|
{
|
|
# check all predecessors
|
|
for my $e (ord_values ( $self->{edges} ))
|
|
{
|
|
my $pre = $e->{from};
|
|
$pre = $e->{to} if $e->{bidirectional};
|
|
if ($pre != $self)
|
|
{
|
|
$in = $pre->flow();
|
|
# take the first match
|
|
last if defined $in;
|
|
}
|
|
}
|
|
}
|
|
|
|
$in = $self->_parent_flow_absolute('90') unless defined $in;
|
|
|
|
$flow = Graph::Easy->_direction_as_number($in) unless defined $flow;
|
|
|
|
$cache->{flow} = Graph::Easy->_flow_as_direction($in,$flow);
|
|
}
|
|
|
|
#############################################################################
|
|
# multi-celled nodes
|
|
|
|
sub _calc_size
|
|
{
|
|
# Calculate the base size in cells from the attributes (before grow())
|
|
# Will return a hash that denotes in which direction the node should grow.
|
|
my $self = shift;
|
|
|
|
# If specified only one of "rows" or "columns", then grow the node
|
|
# only in the unspecified direction. Default is grow both.
|
|
my $grow_sides = { cx => 1, cy => 1 };
|
|
|
|
my $r = $self->{att}->{rows};
|
|
my $c = $self->{att}->{columns};
|
|
delete $grow_sides->{cy} if defined $r && !defined $c;
|
|
delete $grow_sides->{cx} if defined $c && !defined $r;
|
|
|
|
$r = $self->attribute('rows') unless defined $r;
|
|
$c = $self->attribute('columns') unless defined $c;
|
|
|
|
$self->{cy} = abs($r || 1);
|
|
$self->{cx} = abs($c || 1);
|
|
|
|
$grow_sides;
|
|
}
|
|
|
|
sub _grow
|
|
{
|
|
# Grows the node until it has sufficient cells for all incoming/outgoing
|
|
# edges. The initial size will be based upon the attributes 'size' (or
|
|
# 'rows' or 'columns', depending on which is set)
|
|
my $self = shift;
|
|
|
|
# XXX TODO: grow the node based on its label dimensions
|
|
# my ($w,$h) = $self->dimensions();
|
|
#
|
|
# my $cx = int(($w+2) / 5) || 1;
|
|
# my $cy = int(($h) / 3) || 1;
|
|
#
|
|
# $self->{cx} = $cx if $cx > $self->{cx};
|
|
# $self->{cy} = $cy if $cy > $self->{cy};
|
|
|
|
# satisfy the edge start/end port constraints:
|
|
|
|
# We calculate a bitmap (vector) for each side, and mark each
|
|
# used port. Edges that have an unspecified port will just be
|
|
# counted.
|
|
|
|
# bitmap for each side:
|
|
my $vec = { north => '', south => '', east => '', west => '' };
|
|
# number of edges constrained to one side, but without port number
|
|
my $cnt = { north => 0, south => 0, east => 0, west => 0 };
|
|
# number of edges constrained to one side, with port number
|
|
my $portnr = { north => 0, south => 0, east => 0, west => 0 };
|
|
# max number of ports for each side
|
|
my $max = { north => 0, south => 0, east => 0, west => 0 };
|
|
|
|
my @idx = ( [ 'start', 'from' ], [ 'end', 'to' ] );
|
|
# number of slots we need to edges without port restrictions
|
|
my $unspecified = 0;
|
|
|
|
# count of outgoing edges
|
|
my $outgoing = 0;
|
|
|
|
for my $e (ord_values ( $self->{edges} ))
|
|
{
|
|
# count outgoing edges
|
|
$outgoing++ if $e->{from} == $self;
|
|
|
|
# do always both ends, because self-loops can start AND end at this node:
|
|
for my $end (0..1)
|
|
{
|
|
# if the edge starts/ends here
|
|
if ($e->{$idx[$end]->[1]} == $self) # from/to
|
|
{
|
|
my ($side, $nr) = $e->port($idx[$end]->[0]); # start/end
|
|
|
|
if (defined $side)
|
|
{
|
|
if (!defined $nr || $nr eq '')
|
|
{
|
|
# no port number specified, so just count
|
|
$cnt->{$side}++;
|
|
}
|
|
else
|
|
{
|
|
# mark the bit in the vector
|
|
# limit to four digits
|
|
$nr = 9999 if abs($nr) > 9999;
|
|
|
|
# if slot was not used yet, count it
|
|
$portnr->{$side} ++ if vec($vec->{$side}, $nr, 1) == 0x0;
|
|
|
|
# calculate max number of ports
|
|
$nr = abs($nr) - 1 if $nr < 0; # 3 => 3, -3 => 2
|
|
$nr++; # 3 => 4, -3 => 3
|
|
|
|
# mark as used
|
|
vec($vec->{$side}, $nr - 1, 1) = 0x01;
|
|
|
|
$max->{$side} = $nr if $nr > $max->{$side};
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$unspecified ++;
|
|
}
|
|
} # end if port is constrained
|
|
} # end for start/end port
|
|
} # end for all edges
|
|
|
|
for my $e (ord_values ( $self->{edges} ))
|
|
{
|
|
# the loop above will count all self-loops twice when they are
|
|
# unrestricted. So subtract these again. Restricted self-loops
|
|
# might start at one port and end at another, and this case is
|
|
# covered correctly by the code above.
|
|
$unspecified -- if $e->{to} == $e->{from};
|
|
}
|
|
|
|
# Shortcut, if the number of edges is < 4 and we have not restrictions,
|
|
# then a 1x1 node suffices
|
|
if ($unspecified < 4 && ($unspecified == keys %{$self->{edges}}))
|
|
{
|
|
$self->_calc_size();
|
|
return $self;
|
|
}
|
|
|
|
my $need = {};
|
|
my $free = {};
|
|
for my $side (qw/north south east west/)
|
|
{
|
|
# maximum number of ports we need to reserve, minus edges constrained
|
|
# to unique ports: free ports on that side
|
|
$free->{$side} = $max->{$side} - $portnr->{$side};
|
|
$need->{$side} = $max->{$side};
|
|
if ($free->{$side} < 2 * $cnt->{$side})
|
|
{
|
|
$need->{$side} += 2 * $cnt->{$side} - $free->{$side} - 1;
|
|
}
|
|
}
|
|
# now $need contains for each side the absolute min. number of ports we need
|
|
|
|
# use Data::Dumper;
|
|
# print STDERR "# port contraints for $self->{name}:\n";
|
|
# print STDERR "# count: ", Dumper($cnt), "# max: ", Dumper($max),"\n";
|
|
# print STDERR "# ports: ", Dumper($portnr),"\n";
|
|
# print STDERR "# need : ", Dumper($need),"\n";
|
|
# print STDERR "# free : ", Dumper($free),"\n";
|
|
|
|
# calculate min. size in X and Y direction
|
|
my $min_x = $need->{north}; $min_x = $need->{south} if $need->{south} > $min_x;
|
|
my $min_y = $need->{west}; $min_y = $need->{east} if $need->{east} > $min_y;
|
|
|
|
my $grow_sides = $self->_calc_size();
|
|
|
|
# increase the size if the minimum required size is not met
|
|
$self->{cx} = $min_x if $min_x > $self->{cx};
|
|
$self->{cy} = $min_y if $min_y > $self->{cy};
|
|
|
|
my $flow = $self->flow();
|
|
|
|
# if this is a sink node, grow it more by ignoring free ports on the front side
|
|
my $front_side = 'east';
|
|
$front_side = 'west' if $flow == 270;
|
|
$front_side = 'south' if $flow == 180;
|
|
$front_side = 'north' if $flow == 0;
|
|
|
|
# now grow the node based on the general flow first VER, then HOR
|
|
my $grow = 0; # index into @grow_what
|
|
my @grow_what = sort keys %$grow_sides; # 'cx', 'cy' or 'cx' or 'cy'
|
|
|
|
if (keys %$grow_sides > 1)
|
|
{
|
|
# for left/right flow, swap the growing around
|
|
@grow_what = ( 'cy', 'cx' ) if $flow == 90 || $flow == 270;
|
|
}
|
|
|
|
# fake a non-sink node for nodes with an offset/children
|
|
$outgoing = 1 if ref($self->{origin}) || keys %{$self->{children}} > 0;
|
|
|
|
while ( 3 < 5 )
|
|
{
|
|
# calculate whether we already found a space for all edges
|
|
my $free_ports = 0;
|
|
for my $side (qw/north south/)
|
|
{
|
|
# if this is a sink node, grow it more by ignoring free ports on the front side
|
|
next if $outgoing == 0 && $front_side eq $side;
|
|
$free_ports += 1 + int(($self->{cx} - $cnt->{$side} - $portnr->{$side}) / 2);
|
|
}
|
|
for my $side (qw/east west/)
|
|
{
|
|
# if this is a sink node, grow it more by ignoring free ports on the front side
|
|
next if $outgoing == 0 && $front_side eq $side;
|
|
$free_ports += 1 + int(($self->{cy} - $cnt->{$side} - $portnr->{$side}) / 2);
|
|
}
|
|
last if $free_ports >= $unspecified;
|
|
|
|
$self->{ $grow_what[$grow] } += 2;
|
|
|
|
$grow ++; $grow = 0 if $grow >= @grow_what;
|
|
}
|
|
|
|
$self;
|
|
}
|
|
|
|
sub is_multicelled
|
|
{
|
|
# return true if node consist of more than one cell
|
|
my $self = shift;
|
|
|
|
$self->_calc_size() unless defined $self->{cx};
|
|
|
|
$self->{cx} + $self->{cy} <=> 2; # 1 + 1 == 2: no, cx + xy != 2: yes
|
|
}
|
|
|
|
sub is_anon
|
|
{
|
|
# normal nodes are not anon nodes (but "::Anon" are)
|
|
0;
|
|
}
|
|
|
|
#############################################################################
|
|
# accessor methods
|
|
|
|
sub _un_escape
|
|
{
|
|
# replace \N, \G, \T, \H and \E (depending on type)
|
|
# if $label is false, also replace \L with the label
|
|
my ($self, $txt, $do_label) = @_;
|
|
|
|
# for edges:
|
|
if (exists $self->{edge})
|
|
{
|
|
my $e = $self->{edge};
|
|
$txt =~ s/\\E/$e->{from}->{name}\->$e->{to}->{name}/g;
|
|
$txt =~ s/\\T/$e->{from}->{name}/g;
|
|
$txt =~ s/\\H/$e->{to}->{name}/g;
|
|
# \N for edges is the label of the edge
|
|
if ($txt =~ /\\N/)
|
|
{
|
|
my $l = $self->label();
|
|
$txt =~ s/\\N/$l/g;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
# \N for nodes
|
|
$txt =~ s/\\N/$self->{name}/g;
|
|
}
|
|
# \L with the label
|
|
if ($txt =~ /\\L/ && $do_label)
|
|
{
|
|
my $l = $self->label();
|
|
$txt =~ s/\\L/$l/g;
|
|
}
|
|
|
|
# \G for edges and nodes
|
|
if ($txt =~ /\\G/)
|
|
{
|
|
my $g = '';
|
|
# the graph itself
|
|
$g = $self->attribute('title') unless ref($self->{graph});
|
|
# any nodes/edges/groups in it
|
|
$g = $self->{graph}->label() if ref($self->{graph});
|
|
$txt =~ s/\\G/$g/g;
|
|
}
|
|
$txt;
|
|
}
|
|
|
|
sub title
|
|
{
|
|
# Returns a title of the node (or '', if none was set), which can be
|
|
# used for mouse-over titles
|
|
|
|
my $self = shift;
|
|
|
|
my $title = $self->attribute('title');
|
|
if ($title eq '')
|
|
{
|
|
my $autotitle = $self->attribute('autotitle');
|
|
if (defined $autotitle)
|
|
{
|
|
$title = ''; # default is none
|
|
|
|
if ($autotitle eq 'name') # use name
|
|
{
|
|
$title = $self->{name};
|
|
# edges do not have a name and fall back on their label
|
|
$title = $self->{att}->{label} unless defined $title;
|
|
}
|
|
|
|
if ($autotitle eq 'label')
|
|
{
|
|
$title = $self->{name}; # fallback to name
|
|
# defined to avoid overriding "name" with the non-existent label attribute
|
|
# do not use label() here, but the "raw" label of the edge:
|
|
my $label = $self->label(); $title = $label if defined $label;
|
|
}
|
|
|
|
$title = $self->link() if $autotitle eq 'link';
|
|
}
|
|
$title = '' unless defined $title;
|
|
}
|
|
|
|
$title = $self->_un_escape($title, 1) if !$_[0] && $title =~ /\\[EGHNTL]/;
|
|
|
|
$title;
|
|
}
|
|
|
|
sub background
|
|
{
|
|
# get the background for this group/edge cell, honouring group membership.
|
|
my $self = shift;
|
|
|
|
$self->color_attribute('background');
|
|
}
|
|
|
|
sub label
|
|
{
|
|
my $self = shift;
|
|
|
|
# shortcut to speed it up a bit:
|
|
my $label = $self->{att}->{label};
|
|
$label = $self->attribute('label') unless defined $label;
|
|
|
|
# for autosplit nodes, use their auto-label first (unless already got
|
|
# a label from the class):
|
|
$label = $self->{autosplit_label} unless defined $label;
|
|
$label = $self->{name} unless defined $label;
|
|
|
|
return '' unless defined $label;
|
|
|
|
if ($label ne '')
|
|
{
|
|
my $len = $self->attribute('autolabel');
|
|
if ($len ne '')
|
|
{
|
|
# allow the old format (pre v0.49), too: "name,12" => 12
|
|
$len =~ s/^name\s*,\s*//;
|
|
# restrict to sane values
|
|
$len = abs($len || 0); $len = 99999 if $len > 99999;
|
|
if (length($label) > $len)
|
|
{
|
|
my $g = $self->{graph} || {};
|
|
if ((($g->{_ascii_style}) || 0) == 0)
|
|
{
|
|
# ASCII output
|
|
$len = int($len / 2) - 3; $len = 0 if $len < 0;
|
|
$label = substr($label, 0, $len) . ' ... ' . substr($label, -$len, $len);
|
|
}
|
|
else
|
|
{
|
|
$len = int($len / 2) - 2; $len = 0 if $len < 0;
|
|
$label = substr($label, 0, $len) . ' … ' . substr($label, -$len, $len);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
$label = $self->_un_escape($label) if !$_[0] && $label =~ /\\[EGHNT]/;
|
|
|
|
$label;
|
|
}
|
|
|
|
sub name
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{name};
|
|
}
|
|
|
|
sub x
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{x};
|
|
}
|
|
|
|
sub y
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{y};
|
|
}
|
|
|
|
sub width
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{w};
|
|
}
|
|
|
|
sub height
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{h};
|
|
}
|
|
|
|
sub origin
|
|
{
|
|
# Returns node that this node is relative to or undef, if not.
|
|
my $self = shift;
|
|
|
|
$self->{origin};
|
|
}
|
|
|
|
sub pos
|
|
{
|
|
my $self = shift;
|
|
|
|
($self->{x} || 0, $self->{y} || 0);
|
|
}
|
|
|
|
sub offset
|
|
{
|
|
my $self = shift;
|
|
|
|
($self->{dx} || 0, $self->{dy} || 0);
|
|
}
|
|
|
|
sub columns
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->_calc_size() unless defined $self->{cx};
|
|
|
|
$self->{cx};
|
|
}
|
|
|
|
sub rows
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->_calc_size() unless defined $self->{cy};
|
|
|
|
$self->{cy};
|
|
}
|
|
|
|
sub size
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->_calc_size() unless defined $self->{cx};
|
|
|
|
($self->{cx}, $self->{cy});
|
|
}
|
|
|
|
sub shape
|
|
{
|
|
my $self = shift;
|
|
|
|
my $shape;
|
|
$shape = $self->{att}->{shape} if exists $self->{att}->{shape};
|
|
$shape = $self->attribute('shape') unless defined $shape;
|
|
$shape;
|
|
}
|
|
|
|
sub dimensions
|
|
{
|
|
# Returns the minimum dimensions of the node/cell derived from the
|
|
# label or name, in characters.
|
|
my $self = shift;
|
|
|
|
my $align = $self->attribute('align');
|
|
my ($lines,$aligns) = $self->_aligned_label($align);
|
|
|
|
my $w = 0; my $h = scalar @$lines;
|
|
foreach my $line (@$lines)
|
|
{
|
|
$w = length($line) if length($line) > $w;
|
|
}
|
|
($w,$h);
|
|
}
|
|
|
|
#############################################################################
|
|
# edges and connections
|
|
|
|
sub edges_to
|
|
{
|
|
# Return all the edge objects that start at this vertex and go to $other.
|
|
my ($self, $other) = @_;
|
|
|
|
# no graph, no dice
|
|
return unless ref $self->{graph};
|
|
|
|
my @edges;
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
push @edges, $edge if $edge->{from} == $self && $edge->{to} == $other;
|
|
}
|
|
@edges;
|
|
}
|
|
|
|
sub edges_at_port
|
|
{
|
|
# return all edges that share the same given port
|
|
my ($self, $attr, $side, $port) = @_;
|
|
|
|
# Must be "start" or "end"
|
|
return () unless $attr =~ /^(start|end)\z/;
|
|
|
|
$self->_croak('side not defined') unless defined $side;
|
|
$self->_croak('port not defined') unless defined $port;
|
|
|
|
my @edges;
|
|
for my $e (ord_values ( $self->{edges} ))
|
|
{
|
|
# skip edges ending here if we look at start
|
|
next if $e->{to} eq $self && $attr eq 'start';
|
|
# skip edges starting here if we look at end
|
|
next if $e->{from} eq $self && $attr eq 'end';
|
|
|
|
my ($s_p,@ss_p) = $e->port($attr);
|
|
next unless defined $s_p;
|
|
|
|
# same side and same port number?
|
|
push @edges, $e
|
|
if $s_p eq $side && @ss_p == 1 && $ss_p[0] eq $port;
|
|
}
|
|
|
|
@edges;
|
|
}
|
|
|
|
sub shared_edges
|
|
{
|
|
# return all edges that share one port with another edge
|
|
my ($self) = @_;
|
|
|
|
my @edges;
|
|
for my $e (ord_values ( $self->{edges} ))
|
|
{
|
|
my ($s_p,@ss_p) = $e->port('start');
|
|
push @edges, $e if defined $s_p;
|
|
my ($e_p,@ee_p) = $e->port('end');
|
|
push @edges, $e if defined $e_p;
|
|
}
|
|
@edges;
|
|
}
|
|
|
|
sub nodes_sharing_start
|
|
{
|
|
# return all nodes that share an edge start with an
|
|
# edge from that node
|
|
my ($self, $side, @port) = @_;
|
|
|
|
my @edges = $self->edges_at_port('start',$side,@port);
|
|
|
|
my $nodes;
|
|
for my $e (@edges)
|
|
{
|
|
# ignore self-loops
|
|
my $to = $e->{to};
|
|
next if $to == $self;
|
|
|
|
# remove duplicates
|
|
$nodes->{ $to->{name} } = $to;
|
|
}
|
|
|
|
return (ord_values $nodes);
|
|
}
|
|
|
|
sub nodes_sharing_end
|
|
{
|
|
# return all nodes that share an edge end with an
|
|
# edge from that node
|
|
my ($self, $side, @port) = @_;
|
|
|
|
my @edges = $self->edges_at_port('end',$side,@port);
|
|
|
|
my $nodes;
|
|
for my $e (@edges)
|
|
{
|
|
# ignore self-loops
|
|
my $from = $e->{from};
|
|
next if $from == $self;
|
|
|
|
# remove duplicates
|
|
$nodes->{ $from->{name} } = $from;
|
|
}
|
|
|
|
return (ord_values $nodes);
|
|
}
|
|
|
|
sub incoming
|
|
{
|
|
# return all edges that end at this node
|
|
my $self = shift;
|
|
|
|
# no graph, no dice
|
|
return unless ref $self->{graph};
|
|
|
|
if (!wantarray)
|
|
{
|
|
my $count = 0;
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
$count++ if $edge->{to} == $self;
|
|
}
|
|
return $count;
|
|
}
|
|
|
|
my @edges;
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
push @edges, $edge if $edge->{to} == $self;
|
|
}
|
|
@edges;
|
|
}
|
|
|
|
sub outgoing
|
|
{
|
|
# return all edges that start at this node
|
|
my $self = shift;
|
|
|
|
# no graph, no dice
|
|
return unless ref $self->{graph};
|
|
|
|
if (!wantarray)
|
|
{
|
|
my $count = 0;
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
$count++ if $edge->{from} == $self;
|
|
}
|
|
return $count;
|
|
}
|
|
|
|
my @edges;
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
push @edges, $edge if $edge->{from} == $self;
|
|
}
|
|
@edges;
|
|
}
|
|
|
|
sub connections
|
|
{
|
|
# return number of connections (incoming+outgoing)
|
|
my $self = shift;
|
|
|
|
return 0 unless defined $self->{graph};
|
|
|
|
# We need to count the connections, because "[A]->[A]" creates
|
|
# two connections on "A", but only one edge!
|
|
my $con = 0;
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
$con ++ if $edge->{to} == $self;
|
|
$con ++ if $edge->{from} == $self;
|
|
}
|
|
$con;
|
|
}
|
|
|
|
sub edges
|
|
{
|
|
# return all the edges
|
|
my $self = shift;
|
|
|
|
# no graph, no dice
|
|
return unless ref $self->{graph};
|
|
|
|
return (wantarray
|
|
? ord_values ( $self->{edges} )
|
|
: scalar keys %{$self->{edges}}
|
|
);
|
|
}
|
|
|
|
sub sorted_successors
|
|
{
|
|
# return successors of the node sorted by their chain value
|
|
# (e.g. successors with more successors first)
|
|
my $self = shift;
|
|
|
|
my @suc = sort {
|
|
scalar $b->successors() <=> scalar $a->successors() ||
|
|
scalar $a->{name} cmp scalar $b->{name}
|
|
} $self->successors();
|
|
@suc;
|
|
}
|
|
|
|
sub successors
|
|
{
|
|
# return all nodes (as objects) we are linked to
|
|
my $self = shift;
|
|
|
|
return () unless defined $self->{graph};
|
|
|
|
my %suc;
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
next unless $edge->{from} == $self;
|
|
$suc{$edge->{to}->{id}} = $edge->{to}; # weed out doubles
|
|
}
|
|
return ord_values( \%suc );
|
|
}
|
|
|
|
sub predecessors
|
|
{
|
|
# return all nodes (as objects) that link to us
|
|
my $self = shift;
|
|
|
|
return () unless defined $self->{graph};
|
|
|
|
my %pre;
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
next unless $edge->{to} == $self;
|
|
$pre{$edge->{from}->{id}} = $edge->{from}; # weed out doubles
|
|
}
|
|
return ord_values(\%pre);
|
|
}
|
|
|
|
sub has_predecessors
|
|
{
|
|
# return true if node has incoming edges (even from itself)
|
|
my $self = shift;
|
|
|
|
return undef unless defined $self->{graph};
|
|
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
return 1 if $edge->{to} == $self; # found one
|
|
}
|
|
0; # found none
|
|
}
|
|
|
|
sub has_as_predecessor
|
|
{
|
|
# return true if other is a predecessor of node
|
|
my ($self,$other) = @_;
|
|
|
|
return () unless defined $self->{graph};
|
|
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
return 1 if
|
|
$edge->{to} == $self && $edge->{from} == $other; # found one
|
|
}
|
|
0; # found none
|
|
}
|
|
|
|
sub has_as_successor
|
|
{
|
|
# return true if other is a successor of node
|
|
my ($self,$other) = @_;
|
|
|
|
return () unless defined $self->{graph};
|
|
|
|
for my $edge (ord_values ( $self->{edges} ))
|
|
{
|
|
return 1 if
|
|
$edge->{from} == $self && $edge->{to} == $other; # found one
|
|
|
|
}
|
|
0; # found none
|
|
}
|
|
|
|
#############################################################################
|
|
# relatively placed nodes
|
|
|
|
sub relative_to
|
|
{
|
|
# Sets the new origin if passed a Graph::Easy::Node object.
|
|
my ($self,$parent,$dx,$dy) = @_;
|
|
|
|
if (!ref($parent) || !$parent->isa('Graph::Easy::Node'))
|
|
{
|
|
require Carp;
|
|
Carp::confess("Can't set origin to non-node object $parent");
|
|
}
|
|
|
|
my $grandpa = $parent->find_grandparent();
|
|
if ($grandpa == $self)
|
|
{
|
|
require Carp;
|
|
Carp::confess( "Detected loop in origin-chain:"
|
|
." tried to set origin of '$self->{name}' to my own grandchild $parent->{name}");
|
|
}
|
|
|
|
# unregister us with our old parent
|
|
delete $self->{origin}->{children}->{$self->{id}} if defined $self->{origin};
|
|
|
|
$self->{origin} = $parent;
|
|
$self->{dx} = $dx if defined $dx;
|
|
$self->{dy} = $dy if defined $dy;
|
|
$self->{dx} = 0 unless defined $self->{dx};
|
|
$self->{dy} = 0 unless defined $self->{dy};
|
|
|
|
# register us as a new child
|
|
$parent->{children}->{$self->{id}} = $self;
|
|
|
|
$self;
|
|
}
|
|
|
|
sub find_grandparent
|
|
{
|
|
# For a node that has no origin (is not relative to another), returns
|
|
# $self. For all others, follows the chain of origin back until we
|
|
# hit a node without a parent. This code assumes there are no loops,
|
|
# which origin() prevents from happening.
|
|
my $cur = shift;
|
|
|
|
if (wantarray)
|
|
{
|
|
my $ox = 0;
|
|
my $oy = 0;
|
|
while (defined($cur->{origin}))
|
|
{
|
|
$ox -= $cur->{dx};
|
|
$oy -= $cur->{dy};
|
|
$cur = $cur->{origin};
|
|
}
|
|
return ($cur,$ox,$oy);
|
|
}
|
|
|
|
while (defined($cur->{origin}))
|
|
{
|
|
$cur = $cur->{origin};
|
|
}
|
|
|
|
$cur;
|
|
}
|
|
|
|
#############################################################################
|
|
# attributes
|
|
|
|
sub del_attribute
|
|
{
|
|
my ($self, $name) = @_;
|
|
|
|
# font-size => fontsize
|
|
$name = $att_aliases->{$name} if exists $att_aliases->{$name};
|
|
|
|
$self->{cache} = {};
|
|
|
|
my $a = $self->{att};
|
|
delete $a->{$name};
|
|
if ($name eq 'size')
|
|
{
|
|
delete $a->{rows};
|
|
delete $a->{columns};
|
|
}
|
|
if ($name eq 'border')
|
|
{
|
|
delete $a->{borderstyle};
|
|
delete $a->{borderwidth};
|
|
delete $a->{bordercolor};
|
|
}
|
|
$self;
|
|
}
|
|
|
|
sub set_attribute
|
|
{
|
|
my ($self, $name, $v, $class) = @_;
|
|
|
|
$self->{cache} = {};
|
|
|
|
$name = 'undef' unless defined $name;
|
|
$v = 'undef' unless defined $v;
|
|
|
|
# font-size => fontsize
|
|
$name = $att_aliases->{$name} if exists $att_aliases->{$name};
|
|
|
|
# edge.cities => edge
|
|
$class = $self->main_class() unless defined $class;
|
|
|
|
# remove quotation marks, but not for titles, labels etc
|
|
my $val = Graph::Easy->unquote_attribute($class,$name,$v);
|
|
|
|
my $g = $self->{graph};
|
|
|
|
$g->{score} = undef if $g; # invalidate layout to force a new layout
|
|
|
|
my $strict = 0; $strict = $g->{strict} if $g;
|
|
if ($strict)
|
|
{
|
|
my ($rc, $newname, $v) = $g->validate_attribute($name,$val,$class);
|
|
|
|
return if defined $rc; # error?
|
|
|
|
$val = $v;
|
|
}
|
|
|
|
if ($name eq 'class')
|
|
{
|
|
$self->sub_class($val);
|
|
return $val;
|
|
}
|
|
elsif ($name eq 'group')
|
|
{
|
|
$self->add_to_group($val);
|
|
return $val;
|
|
}
|
|
elsif ($name eq 'border')
|
|
{
|
|
my $c = $self->{att};
|
|
|
|
($c->{borderstyle}, $c->{borderwidth}, $c->{bordercolor}) =
|
|
$g->split_border_attributes( $val );
|
|
|
|
return $val;
|
|
}
|
|
|
|
if ($name =~ /^(columns|rows|size)\z/)
|
|
{
|
|
if ($name eq 'size')
|
|
{
|
|
$val =~ /^(\d+)\s*,\s*(\d+)\z/;
|
|
my ($cx, $cy) = (abs(int($1)),abs(int($2)));
|
|
($self->{att}->{columns}, $self->{att}->{rows}) = ($cx, $cy);
|
|
}
|
|
else
|
|
{
|
|
$self->{att}->{$name} = abs(int($val));
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
if ($name =~ /^(origin|offset)\z/)
|
|
{
|
|
# Only the first autosplit node get the offset/origin
|
|
return $self if exists $self->{autosplit} && !defined $self->{autosplit};
|
|
|
|
if ($name eq 'origin')
|
|
{
|
|
# if it doesn't exist, add it
|
|
my $org = $self->{graph}->add_node($val);
|
|
$self->relative_to($org);
|
|
|
|
# set the attributes, too, so get_attribute('origin') works, too:
|
|
$self->{att}->{origin} = $org->{name};
|
|
}
|
|
else
|
|
{
|
|
# offset
|
|
# if it doesn't exist, add it
|
|
my ($x,$y) = split/\s*,\s*/, $val;
|
|
$x = int($x);
|
|
$y = int($y);
|
|
if ($x == 0 && $y == 0)
|
|
{
|
|
$g->error("Error in attribute: 'offset' is 0,0 in node $self->{name} with class '$class'");
|
|
return;
|
|
}
|
|
$self->{dx} = $x;
|
|
$self->{dy} = $y;
|
|
|
|
# set the attributes, too, so get_attribute('origin') works, too:
|
|
$self->{att}->{offset} = "$self->{dx},$self->{dy}";
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
$self->{att}->{$name} = $val;
|
|
}
|
|
|
|
sub set_attributes
|
|
{
|
|
my ($self, $atr, $index) = @_;
|
|
|
|
foreach my $n (sort keys %$atr)
|
|
{
|
|
my $val = $atr->{$n};
|
|
$val = $val->[$index] if ref($val) eq 'ARRAY' && defined $index;
|
|
|
|
next if !defined $val || $val eq '';
|
|
|
|
$n eq 'class' ? $self->sub_class($val) : $self->set_attribute($n, $val);
|
|
}
|
|
$self;
|
|
}
|
|
|
|
BEGIN
|
|
{
|
|
# some handy aliases
|
|
*text_styles_as_css = \&Graph::Easy::text_styles_as_css;
|
|
*text_styles = \&Graph::Easy::text_styles;
|
|
*_font_size_in_pixels = \&Graph::Easy::_font_size_in_pixels;
|
|
*get_color_attribute = \&color_attribute;
|
|
*link = \&Graph::Easy::link;
|
|
*border_attribute = \&Graph::Easy::border_attribute;
|
|
*get_attributes = \&Graph::Easy::get_attributes;
|
|
*get_attribute = \&Graph::Easy::attribute;
|
|
*raw_attribute = \&Graph::Easy::raw_attribute;
|
|
*get_raw_attribute = \&Graph::Easy::raw_attribute;
|
|
*raw_color_attribute = \&Graph::Easy::raw_color_attribute;
|
|
*raw_attributes = \&Graph::Easy::raw_attributes;
|
|
*raw_attributes = \&Graph::Easy::raw_attributes;
|
|
*attribute = \&Graph::Easy::attribute;
|
|
*color_attribute = \&Graph::Easy::color_attribute;
|
|
*default_attribute = \&Graph::Easy::default_attribute;
|
|
$att_aliases = Graph::Easy::_att_aliases();
|
|
}
|
|
|
|
#############################################################################
|
|
|
|
sub group
|
|
{
|
|
# return the group this object belongs to
|
|
my $self = shift;
|
|
|
|
$self->{group};
|
|
}
|
|
|
|
sub add_to_group
|
|
{
|
|
my ($self,$group) = @_;
|
|
|
|
my $graph = $self->{graph}; # shortcut
|
|
|
|
# delete from old group if nec.
|
|
$self->{group}->del_member($self) if ref $self->{group};
|
|
|
|
# if passed a group name, create or find group object
|
|
$group = $graph->add_group($group) if (!ref($group) && $graph);
|
|
|
|
# To make attribute('group') work:
|
|
$self->{att}->{group} = $group->{name};
|
|
|
|
$group->add_member($self);
|
|
|
|
$self;
|
|
}
|
|
|
|
sub parent
|
|
{
|
|
# return parent object, either the group the node belongs to, or the graph
|
|
my $self = shift;
|
|
|
|
my $p = $self->{graph};
|
|
|
|
$p = $self->{group} if ref($self->{group});
|
|
|
|
$p;
|
|
}
|
|
|
|
sub _update_boundaries
|
|
{
|
|
my ($self, $parent) = @_;
|
|
|
|
# XXX TODO: use current layout parent for recursive layouter:
|
|
$parent = $self->{graph};
|
|
|
|
# cache max boundaries for A* algorithmn:
|
|
|
|
my $x = $self->{x};
|
|
my $y = $self->{y};
|
|
|
|
# create the cache if it doesn't already exist
|
|
$parent->{cache} = {} unless ref($parent->{cache});
|
|
|
|
my $cache = $parent->{cache};
|
|
|
|
$cache->{min_x} = $x if !defined $cache->{min_x} || $x < $cache->{min_x};
|
|
$cache->{min_y} = $y if !defined $cache->{min_y} || $y < $cache->{min_y};
|
|
|
|
$x = $x + ($self->{cx}||1) - 1;
|
|
$y = $y + ($self->{cy}||1) - 1;
|
|
$cache->{max_x} = $x if !defined $cache->{max_x} || $x > $cache->{max_x};
|
|
$cache->{max_y} = $y if !defined $cache->{max_y} || $y > $cache->{max_y};
|
|
|
|
if (($parent->{debug}||0) > 1)
|
|
{
|
|
my $n = $self->{name}; $n = $self unless defined $n;
|
|
print STDERR "Update boundaries for $n (parent $parent) at $x, $y\n";
|
|
|
|
print STDERR "Boundaries are now: " .
|
|
"$cache->{min_x},$cache->{min_y} => $cache->{max_x},$cache->{max_y}\n";
|
|
}
|
|
|
|
$self;
|
|
}
|
|
|
|
1;
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Graph::Easy::Node - Represents a node in a Graph::Easy graph
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Graph::Easy::Node;
|
|
|
|
my $bonn = Graph::Easy::Node->new('Bonn');
|
|
|
|
$bonn->set_attribute('border', 'solid 1px black');
|
|
|
|
my $berlin = Graph::Easy::Node->new( name => 'Berlin' );
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
A C<Graph::Easy::Node> represents a node in a simple graph. Each
|
|
node has contents (a text, an image or another graph), and dimension plus
|
|
an origin. The origin is typically determined by a graph layouter module
|
|
like L<Graph::Easy>.
|
|
|
|
=head1 METHODS
|
|
|
|
Apart from the methods of the base class L<Graph::Easy::Base>, a
|
|
C<Graph::Easy::Node> has the following methods:
|
|
|
|
=head2 new()
|
|
|
|
my $node = Graph::Easy::Node->new( name => 'node name' );
|
|
my $node = Graph::Easy::Node->new( 'node name' );
|
|
|
|
Creates a new node. If you want to add the node to a Graph::Easy object,
|
|
then please use the following to create the node object:
|
|
|
|
my $node = $graph->add_node('Node name');
|
|
|
|
You can then use C<< $node->set_attribute(); >>
|
|
or C<< $node->set_attributes(); >> to set the new Node's attributes.
|
|
|
|
=head2 as_ascii()
|
|
|
|
my $ascii = $node->as_ascii();
|
|
|
|
Return the node as a little box drawn in ASCII art as a string.
|
|
|
|
=head2 as_txt()
|
|
|
|
my $txt = $node->as_txt();
|
|
|
|
Return the node in simple txt format, including attributes.
|
|
|
|
=head2 as_svg()
|
|
|
|
my $svg = $node->as_svg();
|
|
|
|
Returns the node as Scalable Vector Graphic. The actual code for
|
|
that routine is defined L<Graph::Easy::As_svg.pm>.
|
|
|
|
=head2 as_graphviz()
|
|
|
|
B<For internal use> mostly - use at your own risk.
|
|
|
|
my $txt = $node->as_graphviz();
|
|
|
|
Returns the node as graphviz compatible text which can be fed
|
|
to dot etc to create images.
|
|
|
|
One needs to load L<Graph::Easy::As_graphviz> first before this method
|
|
can be called.
|
|
|
|
|
|
=head2 as_graphviz_txt()
|
|
|
|
B<For internal use> mostly - use at your own risk.
|
|
|
|
my $txt = $node->as_graphviz_txt();
|
|
|
|
Return only the node itself (without attributes) as a graphviz representation.
|
|
|
|
One needs to load L<Graph::Easy::As_graphviz> first before this method
|
|
can be called.
|
|
|
|
|
|
=head2 as_pure_txt()
|
|
|
|
my $txt = $node->as_pure_txt();
|
|
|
|
Return the node in simple txt format, without the attributes.
|
|
|
|
=head2 text_styles_as_css()
|
|
|
|
my $styles = $graph->text_styles_as_css(); # or $edge->...() etc.
|
|
|
|
Return the text styles as a chunk of CSS styling that can be embedded into
|
|
a C< style="" > parameter.
|
|
|
|
=head2 as_html()
|
|
|
|
my $html = $node->as_html();
|
|
|
|
Return the node as HTML code.
|
|
|
|
=head2 attribute(), get_attribute()
|
|
|
|
$node->attribute('border-style');
|
|
|
|
Returns the respective attribute of the node or undef if it
|
|
was not set. If there is a default attribute for all nodes
|
|
of the specific class the node is in, then this will be returned.
|
|
|
|
=head2 get_attributes()
|
|
|
|
my $att = $object->get_attributes();
|
|
|
|
Return all effective attributes on this object (graph/node/group/edge) as
|
|
an anonymous hash ref. This respects inheritance and default values.
|
|
|
|
Note that this does not include custom attributes.
|
|
|
|
See also L<get_custom_attributes> and L<raw_attributes()>.
|
|
|
|
=head2 get_custom_attributes()
|
|
|
|
my $att = $object->get_custom_attributes();
|
|
|
|
Return all the custom attributes on this object (graph/node/group/edge) as
|
|
an anonymous hash ref.
|
|
|
|
=head2 custom_attributes()
|
|
|
|
my $att = $object->custom_attributes();
|
|
|
|
C<< custom_attributes() >> is an alias for L<< get_custom_attributes >>.
|
|
|
|
=head2 raw_attributes()
|
|
|
|
my $att = $object->get_attributes();
|
|
|
|
Return all set attributes on this object (graph/node/group/edge) as
|
|
an anonymous hash ref. This respects inheritance, but does not include
|
|
default values for unset attributes.
|
|
|
|
See also L<get_attributes()>.
|
|
|
|
=head2 default_attribute()
|
|
|
|
my $def = $graph->default_attribute($class, 'fill');
|
|
|
|
Returns the default value for the given attribute B<in the class>
|
|
of the object.
|
|
|
|
The default attribute is the value that will be used if
|
|
the attribute on the object itself, as well as the attribute
|
|
on the class is unset.
|
|
|
|
To find out what attribute is on the class, use the three-arg form
|
|
of L<attribute> on the graph:
|
|
|
|
my $g = Graph::Easy->new();
|
|
my $node = $g->add_node('Berlin');
|
|
|
|
print $node->attribute('fill'), "\n"; # print "white"
|
|
print $node->default_attribute('fill'), "\n"; # print "white"
|
|
print $g->attribute('node','fill'), "\n"; # print "white"
|
|
|
|
$g->set_attribute('node','fill','red'); # class is "red"
|
|
$node->set_attribute('fill','green'); # this object is "green"
|
|
|
|
print $node->attribute('fill'), "\n"; # print "green"
|
|
print $node->default_attribute('fill'), "\n"; # print "white"
|
|
print $g->attribute('node','fill'), "\n"; # print "red"
|
|
|
|
See also L<raw_attribute()>.
|
|
|
|
=head2 attributes_as_txt
|
|
|
|
my $txt = $node->attributes_as_txt();
|
|
|
|
Return the attributes of this node as text description. This is used
|
|
by the C<< $graph->as_txt() >> code and there should be no reason
|
|
to use this function on your own.
|
|
|
|
=head2 set_attribute()
|
|
|
|
$node->set_attribute('border-style', 'none');
|
|
|
|
Sets the specified attribute of this (and only this!) node to the
|
|
specified value.
|
|
|
|
=head2 del_attribute()
|
|
|
|
$node->del_attribute('border-style');
|
|
|
|
Deletes the specified attribute of this (and only this!) node.
|
|
|
|
=head2 set_attributes()
|
|
|
|
$node->set_attributes( $hash );
|
|
|
|
Sets all attributes specified in C<$hash> as key => value pairs in this
|
|
(and only this!) node.
|
|
|
|
=head2 border_attribute()
|
|
|
|
my $border = $node->border_attribute();
|
|
|
|
Assembles the C<border-width>, C<border-color> and C<border-style> attributes
|
|
into a string like "solid 1px red".
|
|
|
|
=head2 color_attribute()
|
|
|
|
# returns f.i. #ff0000
|
|
my $color = $node->get_color_attribute( 'fill' );
|
|
|
|
Just like get_attribute(), but only for colors, and returns them as hex,
|
|
using the current colorscheme.
|
|
|
|
=head2 get_color_attribute()
|
|
|
|
Is an alias for L<color_attribute()>.
|
|
|
|
=head2 raw_attribute(), get_raw_attribute()
|
|
|
|
my $value = $object->raw_attribute( $name );
|
|
|
|
Return the value of attribute C<$name> from the object it this
|
|
method is called on (graph, node, edge, group etc.). If the
|
|
attribute is not set on the object itself, returns undef.
|
|
|
|
This method respects inheritance, so an attribute value of 'inherit'
|
|
on an object will make the method return the inherited value:
|
|
|
|
my $g = Graph::Easy->new();
|
|
my $n = $g->add_node('A');
|
|
|
|
$g->set_attribute('color','red');
|
|
|
|
print $n->raw_attribute('color'); # undef
|
|
$n->set_attribute('color','inherit');
|
|
print $n->raw_attribute('color'); # 'red'
|
|
|
|
See also L<attribute()>.
|
|
|
|
=head2 raw_color_attribute()
|
|
|
|
# returns f.i. #ff0000
|
|
my $color = $graph->raw_color_attribute('color' );
|
|
|
|
Just like L<raw_attribute()>, but only for colors, and returns them as hex,
|
|
using the current colorscheme.
|
|
|
|
If the attribute is not set on the object, returns C<undef>.
|
|
|
|
=head2 text_styles()
|
|
|
|
my $styles = $node->text_styles();
|
|
if ($styles->{'italic'})
|
|
{
|
|
print 'is italic\n';
|
|
}
|
|
|
|
Return a hash with the given text-style properties, aka 'underline', 'bold' etc.
|
|
|
|
=head2 find_grandparent()
|
|
|
|
my $grandpa = $node->find_grandparent();
|
|
|
|
For a node that has no origin (is not relative to another), returns
|
|
C<$node>. For all others, follows the chain of origin back until
|
|
a node without a parent is found and returns this node.
|
|
This code assumes there are no loops, which C<origin()> prevents from
|
|
happening.
|
|
|
|
=head2 name()
|
|
|
|
my $name = $node->name();
|
|
|
|
Return the name of the node. In a graph, each node has a unique name,
|
|
which, unless a node label is set, will be displayed when rendering the
|
|
graph.
|
|
|
|
=head2 label()
|
|
|
|
my $label = $node->label();
|
|
my $label = $node->label(1); # raw
|
|
|
|
Return the label of the node. If no label was set, returns the C<name>
|
|
of the node.
|
|
|
|
If the optional parameter is true, then the label will returned 'raw',
|
|
that is any potential escape of the form C<\N>, C<\E>, C<\G>, C<\T>
|
|
or C<\H> will not be left alone and not be replaced.
|
|
|
|
=head2 background()
|
|
|
|
my $bg = $node->background();
|
|
|
|
Returns the background color. This method honours group membership and
|
|
inheritance.
|
|
|
|
=head2 quoted_comment()
|
|
|
|
my $cmt = $node->comment();
|
|
|
|
Comment of this object, quoted suitable as to be embedded into HTML/SVG.
|
|
Returns the empty string if this object doesn't have a comment set.
|
|
|
|
=head2 title()
|
|
|
|
my $title = $node->title();
|
|
my $title = $node->title(1); # raw
|
|
|
|
Returns a potential title that can be used for mouse-over effects.
|
|
If no title was set (or autogenerated), will return an empty string.
|
|
|
|
If the optional parameter is true, then the title will returned 'raw',
|
|
that is any potential escape of the form C<\N>, C<\E>, C<\G>, C<\T>
|
|
or C<\H> will be left alone and not be replaced.
|
|
|
|
=head2 link()
|
|
|
|
my $link = $node->link();
|
|
my $link = $node->link(1); # raw
|
|
|
|
Returns the URL, build from the C<linkbase> and C<link> (or C<autolink>)
|
|
attributes. If the node has no link associated with it, return an empty
|
|
string.
|
|
|
|
If the optional parameter is true, then the link will returned 'raw',
|
|
that is any potential escape of the form C<\N>, C<\E>, C<\G>, C<\T>
|
|
or C<\H> will not be left alone and not be replaced.
|
|
|
|
=head2 dimensions()
|
|
|
|
my ($w,$h) = $node->dimensions();
|
|
|
|
Returns the dimensions of the node/cell derived from the label (or name) in characters.
|
|
Assumes the label/name has literal '\n' replaced by "\n".
|
|
|
|
=head2 size()
|
|
|
|
my ($cx,$cy) = $node->size();
|
|
|
|
Returns the node size in cells.
|
|
|
|
=head2 contents()
|
|
|
|
my $contents = $node->contents();
|
|
|
|
For nested nodes, returns the contents of the node.
|
|
|
|
=head2 width()
|
|
|
|
my $width = $node->width();
|
|
|
|
Returns the width of the node. This is a unitless number.
|
|
|
|
=head2 height()
|
|
|
|
my $height = $node->height();
|
|
|
|
Returns the height of the node. This is a unitless number.
|
|
|
|
=head2 columns()
|
|
|
|
my $cols = $node->columns();
|
|
|
|
Returns the number of columns (in cells) that this node occupies.
|
|
|
|
=head2 rows()
|
|
|
|
my $cols = $node->rows();
|
|
|
|
Returns the number of rows (in cells) that this node occupies.
|
|
|
|
=head2 is_multicelled()
|
|
|
|
if ($node->is_multicelled())
|
|
{
|
|
...
|
|
}
|
|
|
|
Returns true if the node consists of more than one cell. See als
|
|
L<rows()> and L<cols()>.
|
|
|
|
=head2 is_anon()
|
|
|
|
if ($node->is_anon())
|
|
{
|
|
...
|
|
}
|
|
|
|
Returns true if the node is an anonymous node. False for C<Graph::Easy::Node>
|
|
objects, and true for C<Graph::Easy::Node::Anon>.
|
|
|
|
=head2 pos()
|
|
|
|
my ($x,$y) = $node->pos();
|
|
|
|
Returns the position of the node. Initially, this is undef, and will be
|
|
set from L<Graph::Easy::layout()>. Only valid during the layout phase.
|
|
|
|
=head2 offset()
|
|
|
|
my ($dx,$dy) = $node->offset();
|
|
|
|
Returns the position of the node relativ to the origin. Returns C<(0,0)> if
|
|
the origin node was not sset.
|
|
|
|
=head2 x()
|
|
|
|
my $x = $node->x();
|
|
|
|
Returns the X position of the node. Initially, this is undef, and will be
|
|
set from L<Graph::Easy::layout()>. Only valid during the layout phase.
|
|
|
|
=head2 y()
|
|
|
|
my $y = $node->y();
|
|
|
|
Returns the Y position of the node. Initially, this is undef, and will be
|
|
set from L<Graph::Easy::layout()>. Only valid during the layout phase.
|
|
|
|
=head2 id()
|
|
|
|
my $id = $node->id();
|
|
|
|
Returns the node's unique, internal ID number.
|
|
|
|
=head2 connections()
|
|
|
|
my $cnt = $node->connections();
|
|
|
|
Returns the count of incoming and outgoing connections of this node.
|
|
Self-loops count as two connections, so in the following example, node C<N>
|
|
has B<four> connections, but only B<three> edges:
|
|
|
|
+--+
|
|
v |
|
|
+---+ +------+ +---+
|
|
| 1 | --> | N | --> | 2 |
|
|
+---+ +------+ +---+
|
|
|
|
See also L<edges()>.
|
|
|
|
=head2 edges()
|
|
|
|
my $edges = $node->edges();
|
|
|
|
Returns a list of all the edges (as L<Graph::Easy::Edge> objects) at this node,
|
|
in no particular order.
|
|
|
|
=head2 predecessors()
|
|
|
|
my @pre = $node->predecessors();
|
|
|
|
Returns all nodes (as objects) that link to us.
|
|
|
|
=head2 has_predecessors()
|
|
|
|
if ($node->has_predecessors())
|
|
{
|
|
...
|
|
}
|
|
|
|
Returns true if the node has one or more predecessors. Will return true for
|
|
nodes with selfloops.
|
|
|
|
=head2 successors()
|
|
|
|
my @suc = $node->successors();
|
|
|
|
Returns all nodes (as objects) that we are linking to.
|
|
|
|
=head2 sorted_successors()
|
|
|
|
my @suc = $node->sorted_successors();
|
|
|
|
Return successors of the node sorted by their chain value
|
|
(e.g. successors with more successors first).
|
|
|
|
=head2 has_as_successor()
|
|
|
|
if ($node->has_as_successor($other))
|
|
{
|
|
...
|
|
}
|
|
|
|
Returns true if C<$other> ( a node or group) is a successor of node, that is if
|
|
there is an edge leading from node to C<$other>.
|
|
|
|
=head2 has_as_predecessor()
|
|
|
|
if ($node->has_as_predecessor($other))
|
|
{
|
|
...
|
|
}
|
|
|
|
Returns true if the node has C<$other> (a group or node) as predecessor, that
|
|
is if there is an edge leading from C<$other> to node.
|
|
|
|
=head2 edges_to()
|
|
|
|
my @edges = $node->edges_to($other_node);
|
|
|
|
Returns all the edges (as objects) that start at C<< $node >> and go to
|
|
C<< $other_node >>.
|
|
|
|
=head2 shared_edges()
|
|
|
|
my @edges = $node->shared_edges();
|
|
|
|
Return a list of all edges starting/ending at this node, that share a port
|
|
with another edge.
|
|
|
|
=head2 nodes_sharing_start()
|
|
|
|
my @nodes = $node->nodes_sharing_start($side, $port);
|
|
|
|
Return a list of unique nodes that share a start point with an edge
|
|
from this node, on the specified side (absolute) and port number.
|
|
|
|
=head2 nodes_sharing_end()
|
|
|
|
my @nodes = $node->nodes_sharing_end($side, $port);
|
|
|
|
Return a list of unique nodes that share an end point with an edge
|
|
from this node, on the specified side (absolute) and port number.
|
|
|
|
=head2 edges_at_port()
|
|
|
|
my @edges = $node->edges_to('start', 'south', '0');
|
|
|
|
Returns all the edge objects that share the same C<start> or C<end>
|
|
port at the specified side and port number. The side must be
|
|
one of C<south>, C<north>, C<west> or C<east>. The port number
|
|
must be positive.
|
|
|
|
=head2 incoming()
|
|
|
|
my @edges = $node->incoming();
|
|
|
|
Return all edges that end at this node.
|
|
|
|
=head2 outgoing()
|
|
|
|
my @edges = $node->outgoing();
|
|
|
|
Return all edges that start at this node.
|
|
|
|
=head2 add_to_group()
|
|
|
|
$node->add_to_group( $group );
|
|
|
|
Put the node into this group.
|
|
|
|
=head2 group()
|
|
|
|
my $group = $node->group();
|
|
|
|
Return the group this node belongs to, or undef.
|
|
|
|
=head2 parent()
|
|
|
|
my $parent = $node->parent();
|
|
|
|
Returns the parent object of the node, which is either the group the node belongs
|
|
to, or the graph.
|
|
|
|
=head2 origin()
|
|
|
|
my $origin_node = $node->origin();
|
|
|
|
Returns the node this node is relativ to, or undef otherwise.
|
|
|
|
=head2 relative_to()
|
|
|
|
$node->relative_to($parent, $dx, $dy);
|
|
|
|
Sets itself relativ to C<$parent> with the offset C<$dx,$dy>.
|
|
|
|
=head2 shape()
|
|
|
|
my $shape = $node->shape();
|
|
|
|
Returns the shape of the node as string, defaulting to 'rect'.
|
|
|
|
=head2 angle()
|
|
|
|
my $angle = $self->rotation();
|
|
|
|
Return the node's rotation, based on the C<rotate> attribute, and
|
|
in case this is relative, on the node's flow.
|
|
|
|
=head2 flow()
|
|
|
|
my $flow = $node->flow();
|
|
|
|
Returns the outgoing flow for this node as absolute direction in degrees.
|
|
|
|
The value is computed from the incoming flow (or the general flow as
|
|
default) and the flow attribute of this node.
|
|
|
|
=head2 _extra_params()
|
|
|
|
my $extra_params = $node->_extra_params();
|
|
|
|
The return value of that method is added as extra params to the
|
|
HTML tag for a node when as_html() is called. Returns the empty
|
|
string by default, and can be overridden in subclasses. See also
|
|
L<use_class()>.
|
|
|
|
Overridden method should return a text with a leading space, or the
|
|
empty string.
|
|
|
|
Example:
|
|
|
|
package Graph::Easy::MyNode;
|
|
use base qw/Graph::Easy::Node/;
|
|
|
|
sub _extra_params
|
|
{
|
|
my $self = shift;
|
|
|
|
' ' . 'onmouseover="alert(\'' . $self->name() . '\');"';
|
|
}
|
|
|
|
1;
|
|
|
|
=head1 EXPORT
|
|
|
|
None by default.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Graph::Easy>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Copyright (C) 2004 - 2007 by Tels L<http://bloodgate.com>.
|
|
|
|
See the LICENSE file for more details.
|
|
|
|
=cut
|