File Coverage

lib/Graph/Easy/Group.pm

Criterion	Covered	Total	%
statement	191	211	90.5
branch	74	100	74.0
condition	37	57	64.9
subroutine	29	33	87.8
pod	14	14	100.0
total	345	415	83.1

#############################################################################
# A group of nodes. Part of Graph::Easy.
#
#############################################################################

package Graph::Easy::Group;

use Graph::Easy::Group::Cell;
use Graph::Easy;
use Scalar::Util qw/weaken/;

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

use strict;
use warnings;

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

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

sub _init
  {
  # generic init, override in subclasses
  my ($self,$args) = @_;

  $self->{name} = 'Group #'. $self->{id};
  $self->{class} = 'group';
  $self->{_cells} = {};				# the Group::Cell objects
#  $self->{cx} = 1;
#  $self->{cy} = 1;

  foreach my $k (sort keys %$args)
    {
    if ($k !~ /^(graph|name)\z/)
      {
      require Carp;
      Carp::confess ("Invalid argument '$k' passed to Graph::Easy::Group->new()");
      }
    $self->{$k} = $args->{$k};
    }

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

  $self;
  }

#############################################################################
# accessor methods

sub nodes
  {
  my $self = shift;

  wantarray ? ( ord_values ( $self->{nodes} ) ) : scalar keys %{$self->{nodes}};
  }

sub edges
  {
  # edges leading from/to this group
  my $self = shift;

  wantarray ? ( ord_values ( $self->{edges} ) ) : scalar keys %{$self->{edges}};
  }

sub edges_within
  {
  # edges between nodes inside this group
  my $self = shift;

  wantarray ? ( ord_values ( $self->{edges_within} ) ) :
		scalar keys %{$self->{edges_within}};
  }

sub _groups_within
  {
  my ($self, $level, $max_level, $cur) = @_;

  no warnings 'recursion';

  push @$cur, ord_values ( $self->{groups} );

  return if $level >= $max_level;

  for my $g (ord_values ( $self->{groups} ))
    {
    $g->_groups_within($level+1,$max_level, $cur) if scalar keys %{$g->{groups}} > 0;
    }
  }

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

sub set_attribute
  {
  my ($self, $name, $val, $class) = @_;

  $self->SUPER::set_attribute($name, $val, $class);

  # if defined attribute "nodeclass", put our nodes into that class
  if ($name eq 'nodeclass')
    {
    my $class = $self->{att}->{nodeclass};
    for my $node (ord_values ( $self->{nodes} ) )
      {
      $node->sub_class($class);
      }
    }
  $self;
  }

sub shape
  {
  my ($self) = @_;

  # $self->{att}->{shape} || $self->attribute('shape');
  '';
  }

#############################################################################
# node handling

sub add_node
  {
  # add a node to this group
  my ($self,$n) = @_;

  if (!ref($n) || !$n->isa("Graph::Easy::Node"))
    {
    if (!ref($self->{graph}))
      {
      return $self->error("Cannot add non node-object $n to group '$self->{name}'");
      }
    $n = $self->{graph}->add_node($n);
    }
  $self->{nodes}->{ $n->{name} } = $n;

  # if defined attribute "nodeclass", put our nodes into that class
  $n->sub_class($self->{att}->{nodeclass}) if exists $self->{att}->{nodeclass};

  # register ourselves with the member
  $n->{group} = $self;

  # set the proper attribute (for layout)
  $n->{att}->{group} = $self->{name};

  # 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.

  # If the node does not belong to a graph yet or belongs to another
  # graph, add it to our own graph:
  weaken($n->{graph} = $self->{graph}) unless
	$n->{graph} && $self->{graph} && $n->{graph} == $self->{graph};

  $n;
  }

sub add_member
  {
  # add a node or group to this group
  my ($self,$n) = @_;

  if (!ref($n) || !$n->isa("Graph::Easy::Node"))
    {
    if (!ref($self->{graph}))
      {
      return $self->error("Cannot add non node-object $n to group '$self->{name}'");
      }
    $n = $self->{graph}->add_node($n);
    }
  return $self->_add_edge($n) if $n->isa("Graph::Easy::Edge");
  return $self->add_group($n) if $n->isa('Graph::Easy::Group');

  $self->{nodes}->{ $n->{name} } = $n;

  # if defined attribute "nodeclass", put our nodes into that class
  my $cl = $self->attribute('nodeclass');
  $n->sub_class($cl) if $cl ne '';

  # register ourselves with the member
  $n->{group} = $self;

  # set the proper attribute (for layout)
  $n->{att}->{group} = $self->{name};

  # 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.

  # If the node does not belong to a graph yet or belongs to another
  # graph, add it to our own graph:
  weaken($n->{graph} = $self->{graph}) unless
	$n->{graph} && $self->{graph} && $n->{graph} == $self->{graph};

  $n;
  }

sub del_member
  {
  # delete a node or group from this group
  my ($self,$n) = @_;

  # XXX TOOD: groups vs. nodes
  my $class = 'nodes'; my $key = 'name';
  if ($n->isa('Graph::Easy::Group'))
    {
    # XXX TOOD: groups vs. nodes
    $class = 'groups'; $key = 'id';
    }
  delete $self->{$class}->{ $n->{$key} };
  delete $n->{group};			# unregister us

  if ($n->isa('Graph::Easy::Node'))
    {
    # find all edges that mention this node and drop them from the group
    my $edges = $self->{edges_within};
    for my $e (ord_values ( $edges))
      {
      delete $edges->{ $e->{id} } if $e->{from} == $n || $e->{to} == $n;
      }
    }

  $self;
  }

sub del_node
  {
  # delete a node from this group
  my ($self,$n) = @_;

  delete $self->{nodes}->{ $n->{name} };
  delete $n->{group};			# unregister us
  delete $n->{att}->{group};		# delete the group attribute

  # find all edges that mention this node and drop them from the group
  my $edges = $self->{edges_within};
  for my $e (ord_values ( $edges))
    {
    delete $edges->{ $e->{id} } if $e->{from} == $n || $e->{to} == $n;
    }

  $self;
  }

sub add_nodes
  {
  my $self = shift;

  # make a copy in case of scalars
  my @arg = @_;
  foreach my $n (@arg)
    {
    if (!ref($n) && !ref($self->{graph}))
      {
      return $self->error("Cannot add non node-object $n to group '$self->{name}'");
      }
    return $self->error("Cannot add group-object $n to group '$self->{name}'")
      if $n->isa('Graph::Easy::Group');

    $n = $self->{graph}->add_node($n) unless ref($n);

    $self->{nodes}->{ $n->{name} } = $n;

    # set the proper attribute (for layout)
    $n->{att}->{group} = $self->{name};

#   XXX TODO TEST!
#    # if defined attribute "nodeclass", put our nodes into that class
#    $n->sub_class($self->{att}->{nodeclass}) if exists $self->{att}->{nodeclass};

    # register ourselves with the member
    $n->{group} = $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.

    # If the node does not belong to a graph yet or belongs to another
    # graph, add it to our own graph:
    weaken($n->{graph} = $self->{graph}) unless
	$n->{graph} && $self->{graph} && $n->{graph} == $self->{graph};

    }

  @arg;
  }

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

sub _del_edge
  {
  # delete an edge from this group
  my ($self,$e) = @_;

  delete $self->{edges_within}->{ $e->{id} };
  delete $e->{group};			# unregister us

  $self;
  }

sub _add_edge
  {
  # add an edge to this group (e.g. when both from/to of this edge belong
  # to this group)
  my ($self,$e) = @_;

  if (!ref($e) || !$e->isa("Graph::Easy::Edge"))
    {
    return $self->error("Cannot add non edge-object $e to group '$self->{name}'");
    }
  $self->{edges_within}->{ $e->{id} } = $e;

  # if defined attribute "edgeclass", put our edges into that class
  my $edge_class = $self->attribute('edgeclass');
  $e->sub_class($edge_class) if $edge_class ne '';

  # XXX TODO: inline
  $self->add_node($e->{from});
  $self->add_node($e->{to});

  # register us, but don't do weaken() if the ref was already set
  weaken($e->{group} = $self) unless defined $e->{group} && $e->{group} == $self;

  $e;
  }

sub add_edge
  {
  # Add an edge to the graph of this group, then register it with this group.
  my ($self,$from,$to) = @_;

  my $g = $self->{graph};
  return $self->error("Cannot add edge to group '$self->{name}' without graph")
    unless defined $g;

  my $edge = $g->add_edge($from,$to);

  $self->_add_edge($edge);
  }

sub add_edge_once
  {
  # Add an edge to the graph of this group, then register it with this group.
  my ($self,$from,$to) = @_;

  my $g = $self->{graph};
  return $self->error("Cannot non edge to group '$self->{name}' without graph")
    unless defined $g;

  my $edge = $g->add_edge_once($from,$to);
  # edge already exists => so fetch it
  $edge = $g->edge($from,$to) unless defined $edge;

  $self->_add_edge($edge);
  }

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

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

  # 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 = $self->{graph}->add_group($name) unless ref $group;

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

  # make attribute->('group') work
  $group->{att}->{group} = $self->{name};

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

  $group;
  }

# cell management - used by the layouter

sub _cells
  {
  # return all the cells this group currently occupies
  my $self = shift;

  $self->{_cells};
  }

sub _clear_cells
  {
  # remove all belonging cells
  my $self = shift;

  $self->{_cells} = {};

  $self;
  }

sub _add_cell
  {
  # add a cell to the list of cells this group covers
  my ($self,$cell) = @_;

  $cell->_update_boundaries();
  $self->{_cells}->{"$cell->{x},$cell->{y}"} = $cell;
  $cell;
  }

sub _del_cell
  {
  # delete a cell from the list of cells this group covers
  my ($self,$cell) = @_;

  delete $self->{_cells}->{"$cell->{x},$cell->{y}"};
  delete $cell->{group};

  $self;
  }

sub _find_label_cell
  {
  # go through all cells of this group and find one where to attach the label
  my $self = shift;

  my $g = $self->{graph};

  my $align = $self->attribute('align');
  my $loc = $self->attribute('labelpos');

  # depending on whether the label should be on top or bottom:
  my $match = qr/^\s*gt\s*\z/;
  $match = qr/^\s*gb\s*\z/ if $loc eq 'bottom';

  my $lc;						# the label cell

  for my $c (ord_values ( $self->{_cells} ))
    {
    # find a cell where to put the label
    next unless $c->{cell_class} =~ $match;

    if (defined $lc)
      {
      if ($align eq 'left')
	{
	# find top-most, left-most cell
	next if $lc->{x} < $c->{x} || $lc->{y} < $c->{y};
	}
      elsif ($align eq 'center')
	{
	# just find any top-most cell
	next if $lc->{y} < $c->{y};
	}
      elsif ($align eq 'right')
	{
	# find top-most, right-most cell
	next if $lc->{x} > $c->{x} || $lc->{y} < $c->{y};
	}
      }
    $lc = $c;
    }

  # find the cell mostly near the center in the found top-row
  if (ref($lc) && $align eq 'center')
    {
    my ($left, $right);
    # find left/right most coordinates
    for my $c (ord_values ( $self->{_cells} ))
      {
      next if $c->{y} != $lc->{y};
      $left = $c->{x} if !defined $left || $left > $c->{x};
      $right = $c->{x} if !defined $right || $right < $c->{x};
      }
    my $center = int(($right - $left) / 2 + $left);
    my $min_dist;
    # find the cell mostly near the center in the found top-row
    for my $c (ord_values ( $self->{_cells} ))
      {
      next if $c->{y} != $lc->{y};
      # squared to get rid of sign
      my $dist = ($center - $c->{x}); $dist *= $dist;
      next if defined $min_dist && $dist > $min_dist;
      $min_dist = $dist; $lc = $c;
      }
    }

  print STDERR "# Setting label for group '$self->{name}' at $lc->{x},$lc->{y}\n"
	if $self->{debug};

  $lc->_set_label() if ref($lc);
  }

sub layout
  {
  my $self = shift;

  $self->_croak('Cannot call layout() on a Graph::Easy::Group directly.');
  }

sub _layout
  {
  my $self = shift;

  ###########################################################################
  # set local {debug} for groups
  local $self->{debug} = $self->{graph}->{debug};

  $self->SUPER::_layout();
  }

sub _set_cell_types
  {
  my ($self, $cells) = @_;

  # Set the right cell class for all of our cells:
  for my $cell (ord_values ( $self->{_cells} ))
    {
    $cell->_set_type($cells);
    }

  $self;
  }

1;
__END__