File Coverage

lib/Gtk2/Ex/MindMapView/Graph.pm

Criterion	Covered	Total	%
statement	12	97	12.3
branch	0	16	0.0
condition	0	3	0.0
subroutine	4	20	20.0
pod	13	13	100.0
total	29	149	19.4

package Gtk2::Ex::MindMapView::Graph;

our $VERSION = '0.000001';

use warnings;
use strict;
use Carp;

use Graph::Directed;


# $graph = Gtk2::Ex::MindMapView::Graph->new();

sub new
{
    my $class = shift(@_);

    my $self = {};

    bless $self, $class;

    $self->{graph} = Graph::Directed->new(refvertexed=>1);

    $self->{root}  = undef;

    return $self;
}


# $graph->add($item);
# $graph->add($predecessor_item, $item);

sub add
{
    my ($self, $predecessor_item, $item) = @_;

    if (!defined $item)
    {
	if (defined $self->{root})
	{
	    croak "A root has already been defined. " .
		  "Use set_root to change the root.\n";
	}

	$self->{root} = $predecessor_item;

	$self->{graph}->add_vertex($predecessor_item);

	return;
    }

    $self->{graph}->add_edge($predecessor_item, $item);
}


# $root = $graph->get_root();

sub get_root
{
    my $self = shift(@_);

    return $self->{root};
}


# $boolean = $graph->has_item($item);

sub has_item
{
    my ($self, $item) = @_;

    return $self->{graph}->has_vertex($item);
}


# $num_items = $graph->num_items();

sub num_items
{
    my $self = shift(@_);

    my $num_items = $self->{graph}->vertices();

    return $num_items;
}


# @predecessors = $graph->predecessors($item);

sub predecessors
{
    my ($self, $item) = @_;

    return $self->{graph}->predecessors($item);
}


# $graph->remove($item);
# $graph->remove($predecessor_item, $item);

sub remove
{
    my ($self, $predecessor_item, $item) = @_;

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

    my @successors = $graph->successors($item);

    if (scalar @successors > 0)
    {
	croak "You must remove the successors of this item " .
	      "prior to removing this item.\n";
    }

    if (!defined $item)
    {
	if ($predecessor_item != $self->{root})
	{
	    croak "You must pass in both the predecessor and " .
		  "the item you wish to remove.\n";
	}

	$graph->delete_vertex($predecessor_item);

	$self->{root} = undef;

	return;
    }

    $graph->delete_edge($predecessor_item, $item);

    my @predecessors = $graph->predecessors($item);

    if (scalar @predecessors == 0)
    {
	$graph->delete_vertex($item);
    }
}


# @successors = $graph->successors($item);

sub successors
{
    my ($self, $item) = @_;

    return $self->{graph}->successors($item);
}


# $graph->set_root($item);

sub set_root
{
    my ($self, $item) = @_;

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

    my $new_graph = Graph::Directed->new(refvertexed=>1);

    $new_graph->add_vertex($item);

    _set_root($self, $new_graph, $item, undef);

    $self->{graph} = $new_graph;

    $self->{root} = $item;
}


# $graph->traverse_BFS($item, $callack);

sub traverse_BFS
{
    my ($self, $item, $callback) = @_;

    my @pairs = ();

    _traverse_pairs($self, \@pairs, 0, $item);

    my @sorted_pairs = sort { ($a->[0] <=> $b->[0]) ||
			      ($a->[1] <=> $b->[1]) } @pairs;

    foreach my $pair_ref (@sorted_pairs)
    {
	&$callback($pair_ref->[1]);
    }
}


# $graph->traverse_DFS($item, $callback)

sub traverse_DFS
{
    my ($self, $item, $callback) = @_;

    &$callback($item);

    my @successors = $self->{graph}->successors($item);

    foreach my $successor_item (@successors)
    {
	$self->traverse_DFS($successor_item, $callback);
    }
}


# $graph->traverse_postorder_edge($predecessor_item, $item, $callback);

sub traverse_postorder_edge
{
    my ($self, $predecessor_item, $item, $callback) = @_;

    my @successors = $self->{graph}->successors($item);

    foreach my $successor_item (@successors)
    {
	traverse_postorder_edge($self, $item, $successor_item, $callback);
    }

    &$callback($predecessor_item, $item);
}


# $graph->traverse_preorder_edge($predecessor_item, $item, $callback);

sub traverse_preorder_edge
{
    my ($self, $predecessor_item, $item, $callback) = @_;

    &$callback($predecessor_item, $item);

    my @successors = $self->{graph}->successors($item);

    foreach my $successor_item (@successors)
    {
	traverse_preorder_edge($self, $item, $successor_item, $callback);
    }
}


sub _set_root
{
    my ($self, $new_graph, $item, $verboten_item) = @_;

    my @successors = $self->{graph}->successors($item);

    foreach my $successor_item (@successors)
    {
	next if ((defined $verboten_item) && ($successor_item == $verboten_item));

	$self->traverse_preorder_edge($item, $successor_item,
			     sub { $new_graph->add_edge($_[0], $_[1]); });
    }

    my @predecessors = $self->{graph}->predecessors($item);

    foreach my $predecessor_item (@predecessors)
    {
	$new_graph->add_edge($item, $predecessor_item);

	_set_root($self, $new_graph, $predecessor_item, $item);
    }
}


sub _traverse_pairs
{
    my ($self, $pairs_ref, $level, $item) = @_;

    push @{$pairs_ref}, [$level, $item];

    my @successors = $self->{graph}->successors($item);

    foreach my $successor_item (@successors)
    {
	_traverse_pairs($self, $pairs_ref, $level + 1, $successor_item);
    }

}



1; # Magic true value required at end of module
__END__