Bug #1779 for Graph: Test Program for Graph

Hello Jarkko I'm so glad to hear that you're working on this Module. Thanks very much. Attached is a test program that exercises TransitiveClosure, APSP, and SSSP methods. It's self-documented. I run it with perl v5.6.1 on RedHat 7.2. The output when I run it with default parameters is below. Lines that start with >>> are errors. Thanks, Nat test_graph Graph::Directed test_graph Graph::Undirected test_tc Graph::Directed test_tc Graph::Undirected Show quoted text
test_apsp Graph::Directed test_apsp Graph::Undirected Show quoted text
test_sssp Dijkstra Graph::Directed --- source 0/0 --- source 0/1 Show quoted text
--- source 0/2 Show quoted text
--- source 1/0 Show quoted text
--- source 1/1 Show quoted text
--- source 1/2 Show quoted text
--- source 2/0 Show quoted text
--- source 2/1 Show quoted text
--- source 2/2 Show quoted text
test_sssp Dijkstra Graph::Undirected --- source 0/0 --- source 0/1 --- source 0/2 --- source 1/0 --- source 1/1 --- source 1/2 --- source 2/0 --- source 2/1 --- source 2/2 test_sssp Bellman_Ford Graph::Directed --- source 0/0 --- source 0/1 Show quoted text
--- source 0/2 Show quoted text
--- source 1/0 Show quoted text
--- source 1/1 Show quoted text
--- source 1/2 Show quoted text
--- source 2/0 Show quoted text
--- source 2/1 Show quoted text
--- source 2/2 Show quoted text
test_sssp Bellman_Ford Graph::Undirected --- source 0/0 Show quoted text
--- source 0/1 Show quoted text
--- source 0/2 Show quoted text
--- source 1/0 Show quoted text
--- source 1/1 Show quoted text
--- source 1/2 Show quoted text
--- source 2/0 Show quoted text
--- source 2/1 Show quoted text
--- source 2/2 Show quoted text
test_sssp DAG Graph::Directed --- source 0/0 --- source 0/1 Show quoted text
--- source 0/2 Show quoted text
--- source 1/0 Show quoted text
--- source 1/1 Show quoted text
--- source 1/2 Show quoted text
--- source 2/0 Show quoted text
--- source 2/1 Show quoted text
--- source 2/2 Show quoted text
done

=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 connected to its neighbors down and to the right, eg, node 1,1 is connected to node 1,2, node 2,1, and node 1,1. 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. =cut use Graph; use Graph::Directed; use Graph::Undirected; # set up square graph $size=shift @ARGV || 3; $g=new Graph::Directed; $h =new Graph::Undirected; $g=construct($g); $h=construct($h); test_graph($g); test_graph($h); test_tc($g); test_tc($h); test_apsp($g); test_apsp($h); test_sssp($g,'Dijkstra'); test_sssp($h,'Dijkstra'); test_sssp($g,'Bellman_Ford'); test_sssp($h,'Bellman_Ford'); test_sssp($g,'DAG'); print "\ndone\n"; exit; sub construct { my($g)=@_; 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 grapsh sub test_graph { my($g)=@_; print "\ntest_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) { print(">>> missing edge $node1-$node2\n"), next unless $g->has_edge($node1,$node2); my $weight=weight($g,$node1,$node2); print ">>> wrong weight on edge $node1-$node2: $weight\n" unless $weight==1; } else { print ">>> extra edge $node1-$node2\n" if $g->has_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)=@_; print "\ntest_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) { print ">>> missing edge $node1-$node2\n" unless $gt->has_edge($node1,$node2); } else { print ">>> extra edge $node1-$node2\n" if $gt->has_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)=@_; print "\ntest_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) { print(">>> missing edge $node1-$node2\n"), next unless $gs->has_edge($node1,$node2); my $weight=weight($gs,$node1,$node2); print ">>> wrong weight on edge $node1-$node2: is $weight, should be $dist\n" unless $weight==$dist; test_path($gs,$node1,$node2,path($gs,$node1,$node2),weight($gs,$node1,$node2)); } else { print ">>> extra edge $node1-$node2\n" if $gs->has_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,$alg)=@_; print "\ntest_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) { print(">>> missing path $node1-$node2\n"), next unless $weight>0; print ">>> wrong weight on path $node1-$node2: is $weight, should be $dist\n" unless $weight==$dist; } else { print ">>> extra path $node1-$node2\n" if $weight>0; }}}}}} sub test_path { my($g,$s,$t,$path,$weight)=@_; print ">>> path $s-$t length does not equal weight\n" unless @$path-1==$weight; return if $weight==0; # path may be reversed my @path=@$path; @path=reverse @path if $path[$#path] eq $s; print ">>> path $s-$t should start at $s, not $path[0]\n" unless $path[0] eq $s; print ">>> path $s-$t should end at $t, not $path[$#path]\n" unless $path[$#path] eq $t; for (my $i=0;$i<$#path;$i++) { print ">>> adjacent nodes in path $s-$t should be distance 1 apart, not ", dist($g,$path[$i],$path[$i+1]),"\n" unless dist($g,$path->[$i],$path->[$i+1])==1; } } sub node { my($i,$j)=@_; $j=$i unless defined $j; "$i/$j"; } sub weight { my($g,$node1,$node2)=@_; return $g->get_attribute('weight',$node1,$node2); } sub path { my($g,$node1,$node2)=@_; return $g->get_attribute('path',$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; }