use Test::More tests => 1196;
# http://rt.cpan.org/NoAuth/Bug.html?id=1179
=head1 NAME
Test program for Graph.
=head2 SYNOPSIS
perl test_graph.pl [size (default 3 works well)]
=head2 DESCRIPTION
This program constructs size x size "square" directed and undirected
graphs, then tests various path-finding related methods:
TransitiveClosure_Floyd_Warshall, APSP_Floyd_Warshall, and SSSP (all
flavors).
You can think of each node as a cell in a matrix. In the directed
case, each node is has edges from its neighbors down and right (the
coordinates growing to down and right), eg, node 1,1 is has edges to
nodes 1,2, node 2,1, and node 2,2. In the undirected case, the down
left diagonal is present as well, eg, from node 1,1 to node 0,2. All
edges have unit weight.
This structure makes it easy to calculate the correct answers. For
example, the all-pairs-shortest-path in the directed case should have
an edge from every node to every other node that is further down or to
the right, and the weight should be equal to the maximun difference in
the coordinates of the nodes. Eg, the weight from node 1,1 to node
3,3 is 2 along the path 1,1 to 2,2 to 3,3.
=head1 AUTHOR
Nathan Goodman
=cut
use Graph;
use Graph::Directed;
use Graph::Undirected;
# set up square graphs
for my $size (0..3) {
print "# size = $size\n";
$g=Graph::Directed->new(compat02 => 1);
$h=Graph::Undirected->new(compat02 => 1);
$g=construct($g, $size);
$h=construct($h, $size);
test_graph($g, $size);
test_graph($h, $size);
test_tc($g, $size);
test_tc($h, $size);
test_apsp($g, $size);
test_apsp($h, $size);
#test_sssp($g,$size,'Dijkstra');
#test_sssp($h,$size,'Dijkstra');
#test_sssp($g,'Bellman_Ford');
#test_sssp($h,'Bellman_Ford');
#test_sssp($g,'DAG');
}
exit;
sub construct {
my($g, $size)=@_;
for (my $i=0;$i<$size;$i++) {
for (my $j=0;$j<$size;$j++) {
my $node=node($i,$j);
$g->add_vertex($node);
$g->add_weighted_edge(node($i-1,$j),1,$node) if $i>0;
$g->add_weighted_edge(node($i,$j-1),1,$node) if $j>0;
$g->add_weighted_edge(node($i-1,$j-1),1,$node) if $i>0 && $j>0; # down-right diagonal
$g->add_weighted_edge(node($i-1,$j+1),1,$node)
if $g->undirected && $i>0 && $j<$size; # down-left diagonal
}
}
return $g;
}
# check graph construction
# all nodes that are distance 1 apart in the rectangle
# should be connected by an edge of weight 1 in the graphs
sub test_graph {
my($g, $size)=@_;
print "# test_graph ",ref $g,"\n";
for (my $i1=0;$i1<$size;$i1++) {
for (my $j1=0;$j1<$size;$j1++) {
my $node1=node($i1,$j1);
for (my $i2=0;$i2<$size;$i2++) {
for (my $j2=0;$j2<$size;$j2++) {
my $node2=node($i2,$j2);
if (dist($g,$node1,$node2)==1) {
ok($g->has_edge($node1,$node2), "edge $node1-$node2");
my $weight=weight($g,$node1,$node2);
is($weight, 1, "edge weight on edge $node1-$node2");
} else {
ok(!$g->has_edge($node1, $node2), "extra edge $node1-$node2");
}}}}}}
# check transitive closure
# all nodes that are distance 0 or more apart in the rectangle
# should be connected by an edge in the grapsh -- weights not used
sub test_tc {
my($g, $size)=@_;
print "# test_tc ",ref $g,"\n";
my $gt=$g->TransitiveClosure_Floyd_Warshall;
for (my $i1=0;$i1<$size;$i1++) {
for (my $j1=0;$j1<$size;$j1++) {
my $node1=node($i1,$j1);
for (my $i2=0;$i2<$size;$i2++) {
for (my $j2=0;$j2<$size;$j2++) {
my $node2=node($i2,$j2);
if (dist($gt,$node1,$node2)>=0) {
ok( $gt->has_edge($node1,$node2), "edge $node1-$node2");
} else {
ok( !$gt->has_edge($node1,$node2), "extra edge $node1-$node2");
}}}}}}
# check all pairs shortest path
# all nodes that are distance 0 or more apart in the rectangle
# should be connected by an edge in the graph with weight equal to distance
sub test_apsp {
my($g, $size)=@_;
print "# test_apsp ",ref $g,"\n";
my $gs=$g->APSP_Floyd_Warshall;
for (my $i1=0;$i1<$size;$i1++) {
for (my $j1=0;$j1<$size;$j1++) {
my $node1=node($i1,$j1);
for (my $i2=0;$i2<$size;$i2++) {
for (my $j2=0;$j2<$size;$j2++) {
my $node2=node($i2,$j2);
my $dist=dist($gs,$node1,$node2);
if ($dist>=0) {
ok($gs->has_edge($node1,$node2), "edge $node1-$node2");
my $weight=weight($gs,$node1,$node2);
is( $weight, $dist, "edge weight $node1-$node2" );
test_path($gs,$node1,$node2,path($gs,$node1,$node2),weight($gs,$node1,$node2));
} else {
ok( !$gs->has_edge($node1,$node2),
"extra edge $node1-$node2" );
}}}}}}
# check single source shortest path
# all nodes that are distance 0 or more apart in the rectangle
# should be connected by an edge in the graph with weight equal to distance
sub test_sssp {
my($g,$size,$alg)=@_;
print "# test_sssp $alg ",ref $g,"\n";
my $sssp=$g->can("SSSP_$alg");
for (my $i1=0;$i1<$size;$i1++) {
for (my $j1=0;$j1<$size;$j1++) {
my $node1=node($i1,$j1);
print "# --- source $node1\n";
my $gs=$g->$sssp($node1);
for (my $i2=0;$i2<$size;$i2++) {
for (my $j2=0;$j2<$size;$j2++) {
my $node2=node($i2,$j2);
my $dist=dist($g,$node1,$node2);
my $weight=weight($gs,$node2);
my $path=path($gs,$node2);
test_path($gs,$node1,$node2,$path,$weight);
if ($dist>0) {
ok( $weight > 0, "path weight $node1-$node2" );
is( $weight, $dist, "path weight $node1-$node2" );
} else {
is( $weight, 0, "path weight $node1-$node2" );
}}}}}}
sub test_path {
my($g,$s,$t,$path,$weight)=@_;
return if $s eq $t;
is( @$path - 1, $weight, "path $s-$t length does not equal weight");
if ($weight) {
# path may be reversed
my @path=@$path;
@path=reverse @path if $path[$#path] eq $s;
is( $path[0], $s, "path $s-$t should start at $s");
for (my $i=0;$i<$#path;$i++) {
is(dist($g,$path->[$i],$path->[$i+1]), 1,
"adjacent nodes in path $s-$t should be distance 1 apart");
}
}
}
sub node {
my($i,$j)=@_;
$j=$i unless defined $j;
"$i/$j";
}
sub weight {
my($g,$node1,$node2)=@_;
return $g->path_length($node1,$node2);
}
sub path {
my($g,$node1,$node2)=@_;
return [ $g->path_vertices($node1,$node2) ];
}
#distances in rectangular graphs with diagonal edges
sub dist {
my($g)=shift @_;
_dist($g->directed,@_);
}
sub _dist {
my($directed)=shift @_;
my($i1,$j1,$i2,$j2);
if (@_==2) {
# args are nodes
my($node1,$node2)=@_;
($i1,$j1)=split('/',$node1);
($i2,$j2)=split('/',$node2);
} else {
# args are indices
($i1,$j1,$i2,$j2)=@_;
}
if ($directed) {
return -1 unless $i1<=$i2 && $j1<=$j2;
return max($i2-$i1,$j2-$j1);
} else {
return max(abs $i2-$i1,abs $j2-$j1);
}
}
sub min {
if ($#_==0) {@_=@{$_[0]} if 'ARRAY' eq ref $_[0];}
return undef unless @_;
if ($#_==1) {my($x,$y)=@_; return ($x<=$y?$x:$y);}
my $min=shift @_;
map {$min=$_ if $_<$min} @_;
$min;
}
sub max {
if ($#_==0) {@_=@{$_[0]} if 'ARRAY' eq ref $_[0];}
return undef unless @_;
if ($#_==1) {my($x,$y)=@_; return ($x>=$y?$x:$y);}
my $max=shift @_;
map {$max=$_ if $_>$max} @_;
$max;
}