Graph-Easy

 view release on metacpan or  search on metacpan

lib/Graph/Easy.pm  view on Meta::CPAN

############################################################################
# Manage, and layout graphs on a flat plane.
#
#############################################################################

package Graph::Easy;

use 5.008002;
use Graph::Easy::Base;
use Graph::Easy::Attributes;
use Graph::Easy::Edge;
use Graph::Easy::Group;
use Graph::Easy::Group::Anon;
use Graph::Easy::Layout;
use Graph::Easy::Node;
use Graph::Easy::Node::Anon;
use Graph::Easy::Node::Empty;
use Scalar::Util qw/weaken/;

$VERSION = '0.76';
@ISA = qw/Graph::Easy::Base/;

use strict;
use warnings;
my $att_aliases;

use Graph::Easy::Util qw(ord_values);

BEGIN
  {
  # a few aliases for backwards compatibility
  *get_attribute = \&attribute;
  *as_html_page = \&as_html_file;
  *as_graphviz_file = \&as_graphviz;
  *as_ascii_file = \&as_ascii;
  *as_boxart_file = \&as_boxart;
  *as_txt_file = \&as_txt;
  *as_vcg_file = \&as_vcg;
  *as_gdl_file = \&as_gdl;
  *as_graphml_file = \&as_graphml;

  # a few aliases for code re-use
  *_aligned_label = \&Graph::Easy::Node::_aligned_label;
  *quoted_comment = \&Graph::Easy::Node::quoted_comment;
  *_un_escape = \&Graph::Easy::Node::_un_escape;
  *_convert_pod = \&Graph::Easy::Node::_convert_pod;
  *_label_as_html = \&Graph::Easy::Node::_label_as_html;
  *_wrapped_label = \&Graph::Easy::Node::_wrapped_label;
  *get_color_attribute = \&color_attribute;
  *get_custom_attributes = \&Graph::Easy::Node::get_custom_attributes;
  *custom_attributes = \&Graph::Easy::Node::get_custom_attributes;
  $att_aliases = Graph::Easy::_att_aliases();

  # backwards compatibility
  *is_simple_graph = \&is_simple;

  # compatibility to Graph
  *vertices = \&nodes;
  }

#############################################################################

sub new
  {
  # override new() as to not set the {id}
  my $class = shift;

  # called like "new->('[A]->[B]')":
  if (@_ == 1 && !ref($_[0]))
    {
    require Graph::Easy::Parser;
    my $parser = Graph::Easy::Parser->new();
    my $self = eval { $parser->from_text($_[0]); };
    if (!defined $self)
      {
      $self = Graph::Easy->new( fatal_errors => 0 );
      $self->error( 'Error: ' . $parser->error() ||
        'Unknown error while parsing initial text' );

lib/Graph/Easy.pm  view on Meta::CPAN

#############################################################################
# as_graphml

sub as_graphml
  {
  require Graph::Easy::As_graphml;

  _as_graphml(@_);
  }

#############################################################################

sub add_edge
  {
  my ($self,$x,$y,$edge) = @_;

  my $uc = $self->{use_class};

  my $ec = $uc->{edge};
  $edge = $ec->new() unless defined $edge;
  $edge = $ec->new(label => $edge) unless ref($edge);

  $self->_croak("Adding an edge object twice is not possible")
    if (exists ($self->{edges}->{$edge->{id}}));

  $self->_croak("Cannot add edge $edge ($edge->{id}), it already belongs to another graph")
    if ref($edge->{graph}) && $edge->{graph} != $self;

  my $nodes = $self->{nodes};
  my $groups = $self->{groups};

  $self->_croak("Cannot add edge for undefined node names ($x -> $y)")
    unless defined $x && defined $y;

  my $xn = $x; my $yn = $y;
  $xn = $x->{name} if ref($x);
  $yn = $y->{name} if ref($y);

  # convert plain scalars to Node objects if nec.

  # XXX TODO: this might be a problem when adding an edge from a group with the same
  #           name as a node

  $x = $nodes->{$xn} if exists $nodes->{$xn};		# first look them up
  $y = $nodes->{$yn} if exists $nodes->{$yn};

  $x = $uc->{node}->new( $x ) unless ref $x;		# if this fails, create
  $y = $x if !ref($y) && $y eq $xn;			# make add_edge('A','A') work
  $y = $uc->{node}->new( $y ) unless ref $y;

  print STDERR "# add_edge '$x->{name}' ($x->{id}) -> '$y->{name}' ($y->{id}) (edge $edge->{id}) ($x -> $y)\n" if $self->{debug};

  for my $n ($x,$y)
    {
    $self->_croak("Cannot add node $n ($n->{name}), it already belongs to another graph")
      if ref($n->{graph}) && $n->{graph} != $self;
    }

  # Register the nodes and the edge with our graph object
  # and weaken the references. Be careful to not needlessly
  # override and weaken again an already existing reference, this
  # is an O(N) operation in most Perl versions, and thus very slow.

  weaken($x->{graph} = $self) unless ref($x->{graph});
  weaken($y->{graph} = $self) unless ref($y->{graph});
  weaken($edge->{graph} = $self) unless ref($edge->{graph});

  # Store at the edge from where to where it goes for easier reference
  $edge->{from} = $x;
  $edge->{to} = $y;

  # store the edge at the nodes/groups, too
  $x->{edges}->{$edge->{id}} = $edge;
  $y->{edges}->{$edge->{id}} = $edge;

  # index nodes by their name so that we can find $x from $x->{name} fast
  my $store = $nodes; $store = $groups if $x->isa('Graph::Easy::Group');
  $store->{$x->{name}} = $x;
  $store = $nodes; $store = $groups if $y->isa('Graph::Easy::Group');
  $store->{$y->{name}} = $y;

  # index edges by "edgeid" so we can find them fast
  $self->{edges}->{$edge->{id}} = $edge;

  $self->{score} = undef;			# invalidate last layout

  wantarray ? ($x,$y,$edge) : $edge;
  }

sub add_anon_node
  {
  my ($self) = shift;

  $self->warn('add_anon_node does not take argumens') if @_ > 0;

  my $node = Graph::Easy::Node::Anon->new();

  $self->add_node($node);

  $node;
  }

sub add_node
  {
  my ($self,$x) = @_;

  my $n = $x;
  if (ref($x))
    {
    $n = $x->{name}; $n = '0' unless defined $n;
    }

  return $self->_croak("Cannot add node with empty name to graph.") if $n eq '';

  return $self->_croak("Cannot add node $x ($n), it already belongs to another graph")
    if ref($x) && ref($x->{graph}) && $x->{graph} != $self;

  my $no = $self->{nodes};
  # already exists?
  return $no->{$n} if exists $no->{$n};

  my $uc = $self->{use_class};
  $x = $uc->{node}->new( $x ) unless ref $x;

  # store the node
  $no->{$n} = $x;

  # Register the nodes and the edge with our graph object
  # and weaken the references. Be careful to not needlessly
  # override and weaken again an already existing reference, this
  # is an O(N) operation in most Perl versions, and thus very slow.

  weaken($x->{graph} = $self) unless ref($x->{graph});

  $self->{score} = undef;			# invalidate last layout

  $x;
  }

sub add_nodes
  {
  my $self = shift;

  my @rc;
  for my $x (@_)
    {
    my $n = $x;
    if (ref($x))
      {
      $n = $x->{name}; $n = '0' unless defined $n;
      }

    return $self->_croak("Cannot add node with empty name to graph.") if $n eq '';

    return $self->_croak("Cannot add node $x ($n), it already belongs to another graph")
      if ref($x) && ref($x->{graph}) && $x->{graph} != $self;

    my $no = $self->{nodes};
    # this one already exists
    next if exists $no->{$n};

    my $uc = $self->{use_class};
    # make it work with read-only scalars:
    my $xx = $x;
    $xx = $uc->{node}->new( $x ) unless ref $x;

    # store the node
    $no->{$n} = $xx;

    # Register the nodes and the edge with our graph object
    # and weaken the references. Be careful to not needlessly
    # override and weaken again an already existing reference, this
    # is an O(N) operation in most Perl versions, and thus very slow.

    weaken($xx->{graph} = $self) unless ref($xx->{graph});

    push @rc, $xx;
    }

  $self->{score} = undef;			# invalidate last layout

  @rc;
  }

#############################################################################
#############################################################################
# Cloning/merging of graphs and objects

sub copy
  {
  # create a copy of this graph and return it as new graph
  my $self = shift;

  my $new = Graph::Easy->new();

  # clone all the settings
  for my $k (sort keys %$self)
    {
    $new->{$k} = $self->{$k} unless ref($self->{$k});
    }

  for my $g (sort keys %{$self->{groups}})
    {
    my $ng = $new->add_group($g);
    # clone the attributes
    $ng->{att} = $self->_clone( $self->{groups}->{$g}->{att} );
    }
  for my $n (ord_values ( $self->{nodes} ))
    {
    my $nn = $new->add_node($n->{name});
    # clone the attributes
    $nn->{att} = $self->_clone( $n->{att} );
    # restore group membership for the node
    $nn->add_to_group( $n->{group}->{name} ) if $n->{group};
    }
  for my $e (ord_values ( $self->{edges} ))
    {
    my $ne = $new->add_edge($e->{from}->{name}, $e->{to}->{name} );
    # clone the attributes
    $ne->{att} = $self->_clone( $e->{att} );
    }
  # clone the attributes
  $new->{att} = $self->_clone( $self->{att});

  $new;
  }

sub _clone
  {
  # recursively clone a data structure
  my ($self,$in) = @_;

  my $out = { };

  for my $k (sort keys %$in)

lib/Graph/Easy.pm  view on Meta::CPAN

  # decouple node from the graph
  $node->{graph} = undef;
  # reset cached size
  $node->{w} = undef;

  # drop all edges from the node locally
  $node->{edges} = { };

  # if the node is a child of another node, deregister it there
  delete $node->{origin}->{children}->{$node->{id}} if defined $node->{origin};

  $self->{score} = undef;			# invalidate last layout

  $self;
  }

sub del_edge
  {
  my ($self, $edge) = @_;

  $self->_croak("del_edge() needs an object") unless ref $edge;

  # if edge is part of a group, delete it there, too
  $edge->{group}->_del_edge($edge) if ref $edge->{group};

  my $to = $edge->{to}; my $from = $edge->{from};

  # delete the edge from the nodes
  delete $from->{edges}->{$edge->{id}};
  delete $to->{edges}->{$edge->{id}};

  # drop the edge from our global edge list
  delete $self->{edges}->{$edge->{id}};

  $edge->{from} = undef;
  $edge->{to} = undef;

  $self;
  }

#############################################################################
# group management

sub add_group
  {
  # add a group object
  my ($self,$group) = @_;

  my $uc = $self->{use_class};

  # group with that name already exists?
  my $name = $group;
  $group = $self->{groups}->{ $group } unless ref $group;

  # group with that name doesn't exist, so create new one
  $group = $uc->{group}->new( name => $name ) unless ref $group;

  # index under the group name for easier lookup
  $self->{groups}->{ $group->{name} } = $group;

  # register group with ourself and weaken the reference
  $group->{graph} = $self;
  {
    no warnings; # don't warn on already weak references
    weaken($group->{graph});
  }
  $self->{score} = undef;			# invalidate last layout

  $group;
  }

sub del_group
  {
  # delete group
  my ($self,$group) = @_;

  delete $self->{groups}->{ $group->{name} };

  $self->{score} = undef;			# invalidate last layout

  $self;
  }

sub group
  {
  # return group by name
  my ($self,$name) = @_;

  $self->{groups}->{ $name };
  }

sub groups
  {
  # return number of groups (or groups as object list)
  my ($self) = @_;

  return sort { $a->{name} cmp $b->{name} } values %{$self->{groups}}
    if wantarray;

  scalar keys %{$self->{groups}};
  }

sub groups_within
  {
  # Return the groups that are directly inside this graph/group. The optional
  # level is either -1 (meaning return all groups contained within), or a
  # positive number indicating how many levels down we need to go.
  my ($self, $level) = @_;

  $level = -1 if !defined $level || $level < 0;

  # inline call to $self->groups;
  if ($level == -1)
    {
    return sort { $a->{name} cmp $b->{name} } values %{$self->{groups}}
      if wantarray;

    return scalar keys %{$self->{groups}};
    }

  my $are_graph = $self->{graph} ? 0 : 1;

  # get the groups at level 0
  my $current = 0;
  my @todo;