File Coverage

blib/lib/Graph/ChainBuilder.pm

Criterion	Covered	Total	%
statement	62	73	84.9
branch	22	24	91.6
condition			n/a
subroutine	14	16	87.5
pod	4	4	100.0
total	102	117	87.1

package Graph::ChainBuilder;
$VERSION = v0.0.2;

use warnings;
use strict;
use Carp;

=head1 NAME

Graph::ChainBuilder - build directed 2-regular cyclic graphs

=head1 SYNOPSIS

This object collects data into a set of ordered chains, allowing you to
organize e.g. edges AB,CD,AD,CB into the circular sequence AB,BC,CD,DA
while keeping track of the directionality of the input data.

  my $graph = Graph::ChainBuilder->new;

  while(whatever) {
    ...
    $graph->add($p0, $p1, $data);
  }

An edge is defined by the strings $p0 and $p1.  The $data is whatever
you want to associate with an edge.

  foreach my $loop ($graph->loops) {
    foreach my $edge (@$loop) {
      ...
      $edge->data;
    }
  }

=head1 Limitations

This code will identify multiple independent loops in an arbitrary set
of unordered edges, but assumes that all loops are closed and that no
stray edges exist.  The result is undefined if your input contains
duplicate or dangling edges.

=cut

use Class::Accessor::Classy;
with 'new';
lo 'loops';
no  Class::Accessor::Classy;

=head2 new

  my $graph = Graph::ChainBuilder->new;

=cut

sub new {
  my $self = shift->SUPER::new();
  $self->{ep}    = {};
  $self->{loops} = [];
  return($self);
} # end subroutine new definition
########################################################################

=head2 add

Adds an edge to the graph.  The nodes $p0 and $p1 will be connected (if
possible) to the existing loops.

  $graph->add($p0, $p1, $data);

Attempting to add an edge with a point which has already been connected
will throw an error.

=cut

sub add {
  my $self = shift;
  my ($p0, $p1, $data) = @_;

  my $edge = Graph::ChainBuilder::edge->new($p0, $p1, 0, $data);

  my $ep = $self->{ep};
  if(my $where = delete($ep->{$p0})) {
    my ($chain, $end) = @$where;
    # warn "insert $p0|$p1 on $chain $end";
    $edge->reverse unless($end);
    splice(@$chain, $end ? scalar(@$chain) : 0, 0, $edge);
    if(my $and = delete($ep->{$p1})) {
      # warn "unravelling needed at $p1";
      # {local $ep->{$p1} = $and; warn join("\n", $self->stringify, '');}
      if($and->[0] eq $chain) { # closed!
        push(@{$self->{loops}}, $chain);
      }
      else {
        $self->_unravel([$chain, $end], $and);
      }
    }
    else {
      $ep->{$p1} = [$chain, $end];
    }
  }
  elsif($where = delete($ep->{$p1})) {
    my ($chain, $end) = @$where;
    # warn "insert $p1|$p0 on $chain $end";
    $edge->reverse if($end);
    splice(@$chain, $end ? scalar(@$chain) : 0, 0, $edge);
    $ep->{$p0} = [$chain, $end];
  }
  else {
    # start a new chain
    my $chain = [$edge];
    $ep->{$p0} = [$chain, 0];
    $ep->{$p1} = [$chain, 1];
  }
} # end subroutine add definition
########################################################################

=begin nothing

=head2 open_ends

=head2 stringify

=end nothing

=cut

sub open_ends {
  my $self = shift;

  my %once = map({$_ => $_} map {$_->[0]} values %{$self->{ep}});
  return(values %once);
}
sub stringify {
  my $self = shift;

  return map({join(" ", map({join("|", $_->p0, $_->p1)} @$_))}
    $self->open_ends);
}

# recursively check/close connected subchains
sub _unravel {
  my $self = shift;
  my ($where, $and) = @_;

  my $ep = $self->{ep};

  my $chain = $where->[0];
  my $end   = $where->[1];

  my $subchain = $and->[0];

  if($end == $and->[1]) { # reverse direction
    @$subchain = reverse(@$subchain);
    $_->reverse for(@$subchain);
  }

  splice(@$chain, $end ? scalar(@$chain) : 0, 0, @$subchain);

  # the opposite end of that chain is now this end of this chain
  my $which_node = 'p' . $end;
  my $last = $subchain->[$end ? $#$subchain : 0]->$which_node;
  $ep->{$last} or die "that's unexpected";
  $ep->{$last} = $where;
} # end subroutine _unravel definition
########################################################################

{
package Graph::ChainBuilder::edge;

=head2 new

  my $e = Graph::ChainBuilder::edge->new($p0, $p1, $rev, $data);

=cut

sub new { my $class = shift; bless([@_], $class); }
sub p0       {shift->[0]};
sub p1       {shift->[1]};
sub reversed {shift->[2]};
sub data     {shift->[3]};

sub reverse { my $e = shift; $e->[2] ^= 1; @$e[0,1] = @$e[1,0]; }
}
########################################################################


=head1 AUTHOR

Eric Wilhelm @

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2009 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatsoever.  You
have been warned.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# vi:ts=2:sw=2:et:sta
1;