File Coverage

lib/Graph/Easy/Layout/Chain.pm

Criterion	Covered	Total	%
statement	176	190	92.6
branch	66	98	67.3
condition	28	47	59.5
subroutine	13	14	92.8
pod	8	8	100.0
total	291	357	81.5

#############################################################################
# One chain of nodes in a Graph::Easy - used internally for layouts.
#
# (c) by Tels 2004-2006. Part of Graph::Easy
#############################################################################

package Graph::Easy::Layout::Chain;

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

use strict;
use warnings;

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

use constant {
  _ACTION_NODE  => 0, # place node somewhere
  _ACTION_TRACE => 1, # trace path from src to dest
  _ACTION_CHAIN => 2, # place node in chain (with parent)
  _ACTION_EDGES => 3, # trace all edges (shortes connect. first)
  };

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

sub _init
  {
  # Generic init routine, to be overriden in subclasses.
  my ($self,$args) = @_;

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

  $self->{end} = $self->{start};

  # store chain at node (to lookup node => chain info)
  $self->{start}->{_chain} = $self;
  $self->{start}->{_next} = undef;

  $self->{len} = 1;

  $self;
  }

sub start
  {
  # return first node in the chain
  my $self = shift;

  $self->{start};
  }

sub end
  {
  # return last node in the chain
  my $self = shift;

  $self->{end};
  }

sub add_node
  {
  # add a node at the end of the chain
  my ($self, $node) = @_;

  # store at end
  $self->{end}->{_next} = $node;
  $self->{end} = $node;

  # store chain at node (to lookup node => chain info)
  $node->{_chain} = $self;
  $node->{_next} = undef;

  $self->{len} ++;

  $self;
  }

sub length
  {
  # Return the length of the chain in nodes. Takes optional
  # node from where to calculate length.
  my ($self, $node) = @_;

  return $self->{len} unless defined $node;

  my $len = 0;
  while (defined $node)
    {
    $len++; $node = $node->{_next};
    }

  $len;
  }

sub nodes
  {
  # return all the nodes in the chain as a list, in order.
  my $self = shift;

  my @nodes = ();
  my $n = $self->{start};
  while (defined $n)
    {
    push @nodes, $n;
    $n = $n->{_next};
    }

  @nodes;
  }

sub layout
  {
  # Return an action stack containing the nec. actions to
  # lay out the nodes in the chain, plus any connections between
  # them.
  my ($self, $edge) = @_;

  # prevent doing it twice
  return [] if $self->{_done}; $self->{_done} = 1;

  my @TODO = ();

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

  # first, layout all the nodes in the chain:

  # start with first node
  my $pre = $self->{start}; my $n = $pre->{_next};
  if (exists $pre->{_todo})
    {
    # edges with a flow attribute must be handled differently
    # XXX TODO: the test for attribute('flow') might be wrong (raw_attribute()?)
    if ($edge && ($edge->{to} == $pre) && ($edge->attribute('flow') || $edge->has_ports()))
      {
      push @TODO, $g->_action( _ACTION_CHAIN, $pre, 0, $edge->{from}, $edge);
      }
    else
      {
      push @TODO, $g->_action( _ACTION_NODE, $pre, 0, $edge );
      }
    }

  print STDERR "# Stack after first:\n" if $g->{debug};
  $g->_dump_stack(@TODO) if $g->{debug};

  while (defined $n)
    {
    if (exists $n->{_todo})
      {
      # CHAIN means if $n isn't placed yet, it will be done with
      # $pre as parent:

      # in case there are multiple edges to the target node, use the first
      # one to determine the flow:
      my @edges = $g->edge($pre,$n);

      push @TODO, $g->_action( _ACTION_CHAIN, $n, 0, $pre, $edges[0] );
      }
    $pre = $n;
    $n = $n->{_next};
    }

  print STDERR "# Stack after chaining:\n" if $g->{debug};
  $g->_dump_stack(@TODO) if $g->{debug};

  # link from each node to the next
  $pre = $self->{start}; $n = $pre->{_next};
  while (defined $n)
    {
    # first do edges going from P to N
    #for my $e (sort { $a->{to}->{name} cmp $b->{to}->{name} } values %{$pre->{edges}})
    for my $e (ord_values ( $pre->{edges}))
      {
      # skip selfloops and backward links, these will be done later
      next if $e->{to} != $n;

      next unless exists $e->{_todo};

      # skip links from/to groups
      next if $e->{to}->isa('Graph::Easy::Group') ||
              $e->{from}->isa('Graph::Easy::Group');

#      # skip edges with a flow
#      next if exists $e->{att}->{start} || exist $e->{att}->{end};

      push @TODO, [ _ACTION_TRACE, $e ];
      delete $e->{_todo};
      }

    } continue { $pre = $n; $n = $n->{_next}; }

  print STDERR "# Stack after chain-linking:\n" if $g->{debug};
  $g->_dump_stack(@TODO) if $g->{debug};

  # Do all other links inside the chain (backwards, going forward more than
  # one node etc)

  $n = $self->{start};
  while (defined $n)
    {
    my @edges;

    my @count;

    print STDERR "# inter-chain link from $n->{name}\n" if $g->{debug};

    # gather all edges starting at $n, but do the ones with a flow first
#    for my $e (sort { $a->{to}->{name} cmp $b->{to}->{name} } values %{$n->{edges}})
    for my $e (ord_values ( $n->{edges}))
      {
      # skip selfloops, these will be done later
      next if $e->{to} == $n;

      next if !ref($e->{to}->{_chain});
      next if !ref($e->{from}->{_chain});

      next if $e->has_ports();

      # skip links from/to groups
      next if $e->{to}->isa('Graph::Easy::Group') ||
              $e->{from}->isa('Graph::Easy::Group');

      print STDERR "# inter-chain link from $n->{name} to $e->{to}->{name}\n" if $g->{debug};

      # leaving the chain?
      next if $e->{to}->{_chain} != $self;

#      print STDERR "#    trying for $n->{name}:\t $e->{from}->{name} to $e->{to}->{name}\n";
      next unless exists $e->{_todo};

      # calculate for this edge, how far it goes
      my $count = 0;
      my $curr = $n;
      while (defined $curr && $curr != $e->{to})
        {
        $curr = $curr->{_next}; $count ++;
        }
      if (!defined $curr)
        {
        # edge goes backward

        # start at $to
        $curr = $e->{to};
        $count = 0;
        while (defined $curr && $curr != $e->{from})
          {
          $curr = $curr->{_next}; $count ++;
          }
        $count = 100000 if !defined $curr;	# should not happen
        }
      push @edges, [ $count, $e ];
      push @count, [ $count, $e->{from}->{name}, $e->{to}->{name} ];
      }

#    use Data::Dumper; print STDERR "count\n", Dumper(@count);

    # do edges, shortest first
    for my $e (sort { $a->[0] <=> $b->[0] } @edges)
      {
      push @TODO, [ _ACTION_TRACE, $e->[1] ];
      delete $e->[1]->{_todo};
      }

    $n = $n->{_next};
    }

  # also do all selfloops on $n
  $n = $self->{start};
  while (defined $n)
    {
#    for my $e (sort { $a->{to}->{name} cmp $b->{to}->{name} } values %{$n->{edges}})
    for my $e (ord_values $n->{edges})
      {
      next unless exists $e->{_todo};

#      print STDERR "# $e->{from}->{name} to $e->{to}->{name} on $n->{name}\n";
#      print STDERR "# ne $e->{to} $n $e->{id}\n"
#       if $e->{from} != $n || $e->{to} != $n;		# no selfloop?

      next if $e->{from} != $n || $e->{to} != $n;	# no selfloop?

      push @TODO, [ _ACTION_TRACE, $e ];
      delete $e->{_todo};
      }
    $n = $n->{_next};
    }

  print STDERR "# Stack after self-loops:\n" if $g->{debug};
  $g->_dump_stack(@TODO) if $g->{debug};

  # XXX TODO
  # now we should do any links that start or end at this chain, recursively

  $n = $self->{start};
  while (defined $n)
    {

    # all chains that start at this node
    for my $e (sort { $a->{to}->{name} cmp $b->{to}->{name} } values %{$n->{edges}})
      {
      my $to = $e->{to};

      # skip links to groups
      next if $to->isa('Graph::Easy::Group');

#      print STDERR "# chain-tracking to: $to->{name} $to->{_chain}\n";

      next unless exists $to->{_chain} && ref($to->{_chain}) =~ /Chain/;
      my $chain = $to->{_chain};
      next if $chain->{_done};

#      print STDERR "# chain-tracking to: $to->{name}\n";

      # pass the edge along, in case it has a flow
#      my @pass = ();
#      push @pass, $e if $chain->{_first} && $e->{to} == $chain->{_first};
      push @TODO, @{ $chain->layout($e) } unless $chain->{_done};

      # link the edges to $to
      next unless exists $e->{_todo};	# was already done above?

      # next if $e->has_ports();

      push @TODO, [ _ACTION_TRACE, $e ];
      delete $e->{_todo};
      }
    $n = $n->{_next};
    }

  \@TODO;
  }

sub dump
  {
  # dump the chain to STDERR
  my ($self, $indent) = @_;

  $indent = '' unless defined $indent;

  print STDERR "#$indent chain id $self->{id} (len $self->{len}):\n";
  print STDERR "#$indent is empty\n" and return if $self->{len} == 0;

  my $n = $self->{start};
  while (defined $n)
    {
    print STDERR "#$indent  $n->{name} (chain id: $n->{_chain}->{id})\n";
    $n = $n->{_next};
    }
  $self;
  }

sub merge
  {
  # take another chain, and merge it into ourselves. If $where is defined,
  # absorb only the nodes from $where onwards (instead of all of them).
  my ($self, $other, $where) = @_;

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

  print STDERR "# panik: ", join(" \n",caller()),"\n" if !defined $other;

  print STDERR
   "# Merging chain $other->{id} (len $other->{len}) into $self->{id} (len $self->{len})\n"
     if $g->{debug};

  print STDERR
   "# Merging from $where->{name} onwards\n"
     if $g->{debug} && ref($where);

  # cannot merge myself into myself (without allocating infinitely memory)
  return if $self == $other;

  # start at start as default
  $where = undef unless ref($where) && exists $where->{_chain} && $where->{_chain} == $other;

  $where = $other->{start} unless defined $where;

  # make all nodes from chain #1 belong to it (to detect loops)
  my $n = $self->{start};
  while (defined $n)
    {
    $n->{_chain} = $self;
    $n = $n->{_next};
    }

  print STDERR "# changed nodes\n" if $g->{debug};
  $self->dump() if $g->{debug};

  # terminate at $where
  $self->{end}->{_next} = $where;
  $self->{end} = $other->{end};

  # start at joiner
  $n = $where;
  while (ref($n))
    {
    $n->{_chain} = $self;
    my $pre = $n;
    $n = $n->{_next};

#    sleep(1);
#    print "# at $n->{name} $n->{_chain}\n" if ref($n);
    if (ref($n) && defined $n->{_chain} && $n->{_chain} == $self)	# already points into ourself?
      {
#      sleep(1);
#      print "# pre $pre->{name} $pre->{_chain}\n";
      $pre->{_next} = undef;	# terminate
      $self->{end} = $pre;
      last;
      }
    }

  # could speed this up
  $self->{len} = 0; $n = $self->{start};
  while (defined $n)
    {
    $self->{len}++; $n = $n->{_next};
    }

#  print "done merging, dumping result:\n";
#  $self->dump(); sleep(10);

  if (defined $other->{start} && $where == $other->{start})
    {
    # we absorbed the other chain completely, so drop it
    $other->{end} = undef;
    $other->{start} = undef;
    $other->{len} = 0;
    # caller is responsible for cleaning it up
    }

  print STDERR "# after merging\n" if $g->{debug};
  $self->dump() if $g->{debug};

  $self;
  }

1;
__END__