# 59_dfs.t   [plain text]

```use Test::More tests => 253;

use Graph::Directed;
use Graph::Undirected;
use Graph::Traversal::DFS;

my \$g0 = Graph::Undirected->new;
my \$g1 = Graph::Directed->new;
my \$g2 = Graph::Undirected->new; # cyclic
my \$g3 = Graph::Undirected->new; # unconnected
my \$g4 = Graph::Directed->new;   # cyclic loop
my \$g5 = Graph::Directed->new;   # cyclic
my \$g6 = Graph::Directed->new;
my \$g7 = Graph::Undirected->new; # empty
my \$g8 = Graph::Undirected->new; # only vertices
my \$g9 = Graph::Directed->new;
my \$ga = Graph::Directed->new;

sub simple {
my \$g = shift;
my @v = \$g->vertices;
is(@_, @v, "vertices");
my %v; \$v{\$_} ++ for @_;
# is(...,0) is 5.00504-incompatible
ok(!scalar(grep { (\$v{\$_} || 0) != 1 } @v), "... once");
}

{
my \$t = Graph::Traversal::DFS->new(\$g0);

is(\$t->unseen, \$g0->vertices, "fresh traversal");
is(\$t->seen,   0);
is(\$t->seeing, 0);

my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

simple(\$g0, @t0);
simple(\$g0, @t1);
simple(\$g0, @t2);

is(\$t->graph, \$g0, "graph");
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g0,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
next_alphabetic => 1);
my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->postorder;

simple(\$g1, @t0);
simple(\$g1, @t1);
simple(\$g1, @t2);

is("@pre",  "a b c d e f", "pre");
is("@post", "c d b f e a", "post");
is("@t0",   "@pre",        "t0");
is("@t1",   "@post",       "t1");
is("@t2",   "@post",       "t2");

is(\$t->unseen, 0, "unseen none");
is(\$t->seen,   6, "seen all");
is(\$t->seeing, 0, "seeing none");
is("@{[sort \$t->seen]}", "a b c d e f", "seen all");
is("@{[\$t->roots]}", "a", "roots");
ok( \$t->is_root('a') );
ok(!\$t->is_root('b') );
ok(!\$t->is_root('c') );
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g1,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
next_alphabetic => 1,
first_root     => 'b');
my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

simple(\$g1, @t0);
simple(\$g1, @t1);
simple(\$g1, @t2);

is("@pre",  "b c d a e f", "pre");
is("@post", "c d b f e a", "post");
is("@t0",   "@pre",        "t0");
is("@t1",   "@post",       "t1");
is("@t2",   "@post",       "t2");

is(\$t->unseen, 0, "unseen none");
is(\$t->seen,   6, "seen all");
is(\$t->seeing, 0, "seeing none");
is("@{[sort \$t->seen]}", "a b c d e f", "seen all");
is("@{[\$t->roots]}",  "b a", "roots");
ok( \$t->is_root('a') );
ok( \$t->is_root('b') );
ok(!\$t->is_root('c') );
}

{
my \$t0 = Graph::Traversal::DFS->new(\$g0, next_alphabetic => 1);
is(\$t0->next, "a",   "scalar next");
\$t0->terminate;
is(\$t0->next, undef, "terminate");
\$t0->reset;
is(\$t0->next, "a",   "after reset scalar next");
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g2,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
next_alphabetic => 1);
my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

simple(\$g2, @t0);
simple(\$g2, @t1);
simple(\$g2, @t2);

is("@pre",  "a b c",       "pre");
is("@post", "c b a",       "post");
is("@t0",   "@pre",        "t0");
is("@t1",   "@post",       "t1");
is("@t2",   "@post",       "t2");

is(\$t->unseen, 0, "unseen none");
is(\$t->seen,   3, "seen all");
is(\$t->seeing, 0, "seeing none");
is("@{[sort \$t->seen]}", "a b c", "seen all");
is("@{[\$t->roots]}", "a", "roots");
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g3,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
next_alphabetic => 1);
my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

simple(\$g3, @t0);
simple(\$g3, @t1);
simple(\$g3, @t2);

is("@pre",  "a b c d e f", "pre");
is("@post", "c b a f e d", "post");
is("@t0",   "@pre",        "t0");
is("@t1",   "@post",       "t1");
is("@t2",   "@post",       "t2");

is(\$t->unseen, 0, "unseen none");
is(\$t->seen,   6, "seen all");
is(\$t->seeing, 0, "seeing none");
is("@{[sort \$t->seen]}", "a b c d e f", "seen all");
is("@{[\$t->roots]}", "a d", "roots");
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g4,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
next_alphabetic => 1,
find_a_cycle => 1);
my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

is("@pre",  "a",       "pre");
is("@post", "a",       "post");
is("@t0",   "a",       "t0");
is("@t1",   "a",       "t1");
is("@t2",   "a",       "t2");

is(\$t->unseen, 0, "unseen none");
is(\$t->seen,   1, "seen all");
is(\$t->seeing, 0, "seeing none");
is("@{[sort \$t->seen]}", "a", "seen all");
is("@{[\$t->roots]}", "a", "roots");
is("@{\$t->{state}->{a_cycle}}", "a", "cycle");
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g5,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
next_alphabetic => 1,
find_a_cycle => 1);
my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

is("@pre",  "a b c",   "pre");
is("@post", "c b",     "post");
is("@t0",   "a b c",   "t0");
is("@t1",   "c b",     "t1");
is("@t2",   "c b",     "t2");

is(\$t->unseen, 0, "unseen none");
is(\$t->seen,   3, "seen all");
is(\$t->seeing, 1, "seeing one");
is("@{[sort \$t->seen]}", "a b c", "seen all");
is("@{[\$t->roots]}", "a", "roots");
is("@{\$t->{state}->{a_cycle}}", "b c a", "cycle");
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g2,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
next_alphabetic => 1,
find_a_cycle => 1);
my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

is("@pre",  "a b c",   "pre");
is("@post", "c b",     "post");
is("@t0",   "a b c",   "t0");
is("@t1",   "c b",     "t1");
is("@t2",   "c b",     "t2");

is(\$t->unseen, 0, "unseen none");
is(\$t->seen,   3, "seen all");
is(\$t->seeing, 1, "seeing one");
is("@{[sort \$t->seen]}", "a b c", "seen all");
is("@{[\$t->roots]}", "a", "roots");
is("@{\$t->{state}->{a_cycle}}", "b c a", "cycle");
}

{
my \$g = Graph::Undirected->new;
my @c = \$g->find_a_cycle(next_alphabetic => 1);
is(@c, 3, "find_a_cycle");
is("@c", "h i c", "find_a_cycle");
}

{
my \$g = Graph::Directed->new;
my \$h = Graph::Undirected->new;

ok(\$g->is_dag, "is_dag true for dag");

ok(!\$h->is_dag, "is_dag false for undirected");

my @t = \$g->topological_sort(next_alphabetic => 1);

is(@t, 9, "topological_sort");
is("@t", "a b f g c h i d e", "topological_sort");

ok(\$g->is_dag, "directed acyclic is dag");

ok(!\$g->is_dag, "directed cyclic is not dag");
}

{
my \$g = Graph::Undirected->new;

ok(!\$g->is_dag, "undirected is not dag");

eval '\$g->topological_sort';
like(\$@, qr/^Graph::topological_sort: expected directed acyclic graph, got undirected, /, "topological_sort not for undirected");

my \$d = Graph::Directed->new;

eval '\$d->toposort';
like(\$@, qr/^Graph::topological_sort: expected directed acyclic graph, got cyclic, /, "topological_sort not for cyclic");
}

{
ok( \$g0->is_connected, "is_connected");
eval '\$g1->is_connected';
like(\$@,
qr/Graph::is_connected: expected undirected graph, got directed, /,
"directed cannot be tested for connectedness/");
ok( \$g1->is_weakly_connected, "... directed is weakly connected");
ok( \$g2->is_connected, "... cyclic undirected" );
ok(!\$g3->is_connected, "... undirected unconnected");
eval '\$g4->is_connected';
like(\$@,
qr/Graph::is_connected: expected undirected graph, got directed, /,
"... cyclic loop");
ok( \$g4->is_weakly_connected, "... cyclic loop weakly connected");
eval '\$g5->is_connected';
like( \$@,
qr/Graph::is_connected: expected undirected graph, got directed, /,
"... cyclic directed");
ok( \$g5->is_weakly_connected, "... cyclic directed weakly connected");
eval '\$g6->is_connected';
like(\$@,
qr/Graph::is_connected: expected undirected graph, got directed, /,
"... directed unconnected");
ok(!\$g6->is_weakly_connected, "... directed unconnected is not weakly connected");
}

{
my \$t = Graph::Traversal::DFS->new(\$g7);

is(\$t->unseen, \$g7->vertices, "empty graph");
is(\$t->seen,   0);
is(\$t->seeing, 0);

my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

simple(\$g7, @t0);
simple(\$g7, @t1);
simple(\$g7, @t2);
}

{

my \$t = Graph::Traversal::DFS->new(\$g8);

is(\$t->unseen, \$g8->vertices, "only vertices");
is(\$t->seen,   0);
is(\$t->seeing, 0);

my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

simple(\$g8, @t0);
simple(\$g8, @t1);
simple(\$g8, @t2);
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g3,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
first_root => "a",
next_root  => undef);
my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

is("@pre",  "a b c", "pre");
is("@post", "c b a", "post");
is("@t0",   "@pre",        "t0");
is("@t1",   "@post",       "t1");
is("@t2",   "@post",       "t2");

is(\$t->unseen, 3, "unseen half");
is(\$t->seen,   3, "seen half");
is(\$t->seeing, 0, "seeing none");
is("@{[sort \$t->seen]}", "a b c", "seen half");
is("@{[\$t->roots]}", "a", "roots");
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g3,
pre  => sub { push @pre,  \$_[0] },
post => sub { push @post, \$_[0] },
start => "a");

my @t0 = \$t->preorder;
my @t1 = \$t->postorder;
my @t2 = \$t->dfs;

is("@pre",  "a b c", "pre");
is("@post", "c b a", "post");
is("@t0",   "@pre",        "t0");
is("@t1",   "@post",       "t1");
is("@t2",   "@post",       "t2");

is(\$t->unseen, 3, "unseen half");
is(\$t->seen,   3, "seen half");
is(\$t->seeing, 0, "seeing none");
is("@{[sort \$t->seen]}", "a b c", "seen half");
is("@{[\$t->roots]}", "a", "roots");
}

{
my @pre;
my @post;
my \$t = Graph::Traversal::DFS->new(\$g0,
pre_edge  => sub { push @pre,  \$_[0], \$_[1] },
post_edge => sub { push @post, \$_[0], \$_[1] },
next_alphabetic => 1);

\$t->dfs;

is("@pre",  "a b b c b d a e e f", "pre");
is("@post", "b c b d a b e f a e", "post");

is(\$t->unseen, 0, "unseen none");
is(\$t->seen,   6, "seen all");
is(\$t->seeing, 0, "seeing none");
is("@{[sort \$t->seen]}", "a b c d e f", "seen all");
is("@{[\$t->roots]}", "a", "roots");
}

my \$gb = Graph->new;

my @gb;
my \$tb =
Graph::Traversal::DFS->
new(\$gb,
next_alphabetic => 1,
pre_edge      => sub { push @gb, "pre_edge @_[0,1]" },
post_edge     => sub { push @gb, "post_edge @_[0,1]" },
non_tree_edge => sub { push @gb, "non_tree_edge @_[0,1]" },
back_edge     => sub { push @gb, "back_edge @_[0,1]" },
down_edge     => sub { push @gb, "down_edge @_[0,1]" },
cross_edge    => sub { push @gb, "cross_edge @_[0,1]" }
);

\$tb->dfs;

is(\$gb[ 0], "pre_edge a b",     "pre_edge");
is(\$gb[ 1], "pre_edge b c",     "pre_edge");
is(\$gb[ 2], "post_edge b c",    "post_edge");
is(\$gb[ 3], "non_tree_edge c a", "non_tree_edge");
is(\$gb[ 4], "back_edge c a",    "back_edge");
is(\$gb[ 5], "post_edge a b",    "post_edge");
is(\$gb[ 6], "pre_edge a d",     "pre_edge");
is(\$gb[ 7], "post_edge a d",    "post_edge");
is(\$gb[ 8], "non_tree_edge d b", "non_tree_edge");
is(\$gb[ 9], "cross_edge d b",   "cross_edge");
is(\$gb[10], "non_tree_edge a c", "non_tree_edge");
is(\$gb[11], "down_edge a c",    "down_edge");
is( @gb, 12 );

ok( \$tb->tree->has_edge('a', 'b'), "tree edge");
ok( \$tb->tree->has_edge('b', 'c'), "tree edge");
ok( \$tb->tree->has_edge('a', 'd'), "tree edge");

ok(!\$tb->tree->has_edge('c', 'a'), "non_tree edge");
ok(!\$tb->tree->has_edge('d', 'b'), "non_tree edge");
ok(!\$tb->tree->has_edge('a', 'c'), "non_tree edge");

is( \$tb->tree, "a-b,a-d,b-c", "tree" );

is( \$tb->preorder_by_vertex('a'), 0, "preorder of a" );
is( \$tb->preorder_by_vertex('b'), 1, "preorder of b" );
is( \$tb->preorder_by_vertex('c'), 2, "preorder of c" );
is( \$tb->preorder_by_vertex('d'), 3, "preorder of d" );

is( \$tb->vertex_by_preorder(0), 'a', "preorder of a" );
is( \$tb->vertex_by_preorder(1), 'b', "preorder of b" );
is( \$tb->vertex_by_preorder(2), 'c', "preorder of c" );
is( \$tb->vertex_by_preorder(3), 'd', "preorder of d" );

is( \$tb->postorder_by_vertex('a'), 3, "postorder of a" );
is( \$tb->postorder_by_vertex('b'), 1, "postorder of b" );
is( \$tb->postorder_by_vertex('c'), 0, "postorder of c" );
is( \$tb->postorder_by_vertex('d'), 2, "postorder of d" );

is( \$tb->vertex_by_postorder(3), 'a', "postorder of a" );
is( \$tb->vertex_by_postorder(1), 'b', "postorder of b" );
is( \$tb->vertex_by_postorder(0), 'c', "postorder of c" );
is( \$tb->vertex_by_postorder(2), 'd', "postorder of d" );

my %pre = \$tb->preorder_vertices();

is( \$pre{'a'}, 0, "preorder of a" );
is( \$pre{'b'}, 1, "preorder of b" );
is( \$pre{'c'}, 2, "preorder of c" );
is( \$pre{'d'}, 3, "preorder of d" );
is( keys %pre, 4 );

my %post = \$tb->postorder_vertices();

is( \$post{'a'}, 3, "postorder of a" );
is( \$post{'b'}, 1, "postorder of b" );
is( \$post{'c'}, 0, "postorder of c" );
is( \$post{'d'}, 2, "postorder of d" );
is( keys %post, 4 );

my \$gc = Graph->new(multiedged => 1);

my @gc;
my \$tc =
Graph::Traversal::DFS->
new(\$gc,
next_alphabetic => 1,
pre_edge      => sub { push @gc, "pre_edge @_[0,1]" },
post_edge     => sub { push @gc, "post_edge @_[0,1]" },
non_tree_edge => sub { push @gc, "non_tree_edge @_[0,1]" },
back_edge     => sub { push @gc, "back_edge @_[0,1]" },
down_edge     => sub { push @gc, "down_edge @_[0,1]" },
cross_edge    => sub { push @gc, "cross_edge @_[0,1]" },
seen_edge     => sub { push @gc, "seen_edge @_[0,1]" }
);

\$tc->dfs;

is( \$gc[0], "pre_edge a b", "pre_edge" );
is( \$gc[1], "post_edge a b", "post_edge" );
is( \$gc[2], "seen_edge a b", "seen_edge" );
is( @gc, 3 );

my \$gd = Graph->new;
my @gd0;
my \$td0 = Graph::Traversal::DFS->new(\$gd, next_numeric => 1, pre => sub { push @gd0, \$_[0] });
\$td0->dfs;
is( "@gd0", "0 1 9 10", "next_numeric" );
my @gd1;
my \$td1 = Graph::Traversal::DFS->new(\$gd, next_alphabetic => 1, pre => sub { push @gd1, \$_[0] });
\$td1->dfs;
is( "@gd1", "0 1 10 9", "next_alphabetic" );

eval 'Graph::Traversal::DFS->new(next_alphabetic => 1)';
like(\$@, qr/Graph::Traversal: first argument is not a Graph/, "sane args");

eval 'Graph::Traversal::DFS->new(\$gd, next_alphazetic => 1)';
like(\$@, qr/Graph::Traversal: unknown attribute 'next_alphazetic'/, "zetic");

ok(!\$td1->has_state('zot'), "has_state");

is(\$td1->get_state('zot'), undef, "get_state");

ok(\$td1->set_state('zot', 42), "set_state");

ok(\$td1->has_state('zot'), "has_state");

is(\$td1->get_state('zot'), 42, "get_state");

ok(\$td1->delete_state('zot'), "delete_state");

ok(!\$td1->has_state('zot'), "has_state");

is(\$td1->get_state('zot'), undef, "get_state");

{
# http://rt.cpan.org/NoAuth/Bug.html?id=4420
use Graph::Directed;
my \$g = new Graph::Directed;
ok(\$g->has_edge('a','b'));
ok(\$g->has_edge('b','a'));
my @toposort;
eval '@toposort = \$g->toposort';
like(\$@, qr/Graph::topological_sort: expected directed acyclic graph, got cyclic/);
# http://rt.cpan.org/NoAuth/Bug.html?id=5168
@toposort = \$g->toposort(empty_if_cyclic => 1);
is(@toposort, 0, "rt.cpan.org 5168");
# http://rt.cpan.org/NoAuth/Bug.html?id=5167
ok( \$g->has_a_cycle, "rt.cpan.org 5167" );
my \$h = Graph->new;