use strict;
use Carp;
use Getopt::Long;
use Text::Abbrev;
use Graph::Directed;
use Test::More qw(no_plan); # random graphs
my $cmd_line="$0 @ARGV";
my %OPTIONS;
GetOptions (\%OPTIONS,
qw(help verbose echo|X seed=i
input cycle cone grid random
circumference=i
height=i width=i
nodes=i edges=i density=f
));
$OPTIONS{help} and die <<USAGE
Usage: $0 [options] [<input file>] [<output file>]
Test StrongComponents algorithm.
The test-graphs can be any of the following:
1. Provided as input in a file or STDIN
Expressed as pairs (node1 node2) one pair per line
2. Cycle.
Size is specified by --circumference
Density of cross edges specified by --density
3. Cone (layered cycles of increasing size)
--circumference is size of largest cycle
4. Grid.
Size is specified by --height and --width options. If just 1
number is specified, the grid is square. If neither is specified
defaults are used.
5. Random graph.
Size is specifed by any two of the following:
number of nodes (--nodes option)
number of edges (--edges)
density (edges/nodes, --density option)
If 0 or 1 are specified, defaults are used for rest.
The size is a target. The actual graph may be a little smaller due
to duplicate edges.
Default is --grid and --random
Options
-------
--help Print this message
--verbose (for testing)
-X or --echo Echo command line (for testing and use in scripts)
--seed Seed for random number generator
--input Graph is provided as input
--cycle Generate cycle graph
--cone Generate cone graph
--circumference Numbre of nodes in cycle graph
--grid Generate grid (implied by --height or --width)
--height Grid height
--width Grid width
--random Generate random graph (implied by --nodes, --edges)
--nodes Number of nodes in random graph
--edges Number of edges in random graph
--density Average number of cross edges per node in cycle graph
Average number of edges per node in random graph
Options and values may be abbreviated. Values are case insensitive.
USAGE
;
print OUT "$cmd_line\n" if $OPTIONS{echo};
srand $OPTIONS{seed} if defined $OPTIONS{seed};
my %DEFAULTS=
(circumference=>10,
height=>3,
width=>3,
nodes=>10,
edges=>11,
density=>1.1,
);
my $INPUT=$OPTIONS{input} || @ARGV>=2;
my $CYCLE=$OPTIONS{cycle};
my $CONE=$OPTIONS{cone};
$CYCLE || $CONE or ($OPTIONS{circumference} and $CYCLE=1);
my $GRID=$OPTIONS{grid} || $OPTIONS{height} || $OPTIONS{width};
my $RANDOM=$OPTIONS{random} || $OPTIONS{nodes} || $OPTIONS{edges};
$CYCLE=$CONE=$GRID=$RANDOM=1 unless $INPUT || $CYCLE || $CONE || $GRID || $RANDOM;
my $CIRCUMFERENCE=get_param('circumference') if $CYCLE;
my $CONE_SIZE=get_param('circumference') if $CONE;
my($HEIGHT,$WIDTH)=grid_size() if $GRID;
my($NODES,$EDGES)=random_size() if $RANDOM;
my $DENSITY=get_param('density');
if ($INPUT && @ARGV) {
my $input_file=shift @ARGV;
open(IN,$input_file) || confess "Cannot open input file $input_file: $!";
} else {
*IN=*STDIN;
}
if (@ARGV) {
my $output_file=shift @ARGV;
open(OUT,"> $output_file") || die "Cannot create output file $output_file: $!";
} else {
*OUT=*STDOUT;
}
if ($INPUT) {
print"# Test input graph\n";
my $graph=input_graph();
test_sc($graph);
}
if ($CYCLE) {
print"# Test cycle graph\n";
my $graph=cycle_graph();
my $components=test_sc($graph);
is(@$components, 1, "number of components");
}
if ($CONE) {
print"# Test cone graph\n";
my $graph=cone_graph();
my $components=test_sc($graph);
test_cone_sc($graph,$components);
print"# Test cone graph with intermediate nodes\n";
my $graph2=cone_graph('intermediate');
my $components2=test_sc($graph2);
test_coneint_sc($graph2,$components2);
}
if ($GRID) {
print"# Test grid graph (acyclic)\n";
my $graph=grid_graph();
my $nodes=$graph->vertices;
my $components=test_sc($graph);
is(@$components, $nodes);
print"# grid graph (cyclic)\n";
my $graph2=grid_graph('cyclic');
my $components2=test_sc($graph2);
is(@$components2, 1, "number of components");
}
if ($RANDOM) {
print"# Test random graph (acyclic)\n";
my $graph=random_graph();
my $components=test_sc($graph);
my $nodes=$graph->vertices;
is(@$components, $nodes);
print"# Test random graph (cyclic)\n";
my $graph2=random_graph('cyclic');
my $components2=test_sc($graph2);
}
sub input_graph {
my $graph=new Graph::Directed;
while (<IN>) {
my($node0,$node1)=split;
next unless length($node0) && length($node1);
$graph->add_weighted_edge($node0,$node1,1);
}
$graph;
}
sub cycle_graph {
my($circumference,$density)=@_;
defined $circumference or $circumference=$CIRCUMFERENCE;
defined $density or $density=$DENSITY;
my $graph=new Graph::Directed;
# make simple cycle
for (my $i=1; $i<$circumference; $i++) {
$graph->add_weighted_edge($i-1,$i,1);
}
$graph->add_weighted_edge($circumference-1,0,1);
# add random cross edges
my $cross_edges=int $density*$circumference;
for (my $i=0;$i<$cross_edges; $i++) {
my($node1,$node2)=(int rand $circumference,int rand $circumference);
$graph->add_weighted_edge($node1,$node2,1);
}
$graph;
}
sub cone_graph {
my($intermediate)=@_;
my $graph=new Graph::Directed;
print"# Constructing cone graph...\n";
# make $CONE_SIZE simple cycles of sizes 1..$CONE_SIZE
for (my $i=0; $i<$CONE_SIZE; $i++) {
my $circumference=$i+1;
# make simple cycle
for (my $j=1; $j<$circumference; $j++) {
$graph->add_weighted_edge($i.'/'.($j-1),"$i/$j",1);
}
$graph->add_weighted_edge($i.'/'.($circumference-1),"$i/0",1);
# add random cross edges
my $cross_edges=int $DENSITY*$i;
for (my $j=0;$j<$cross_edges; $j++) {
my($j1,$j2)=(int rand $circumference,int rand $circumference);
$graph->add_weighted_edge("$i/$j1","$i/$j2",1);
}
}
# add random edges between cycles
my $nodes=0+$graph->vertices;
my $edges=int $DENSITY*$nodes;
for (my $i=0;$i<$edges; $i++) {
my($i1,$i2)=(int rand $CONE_SIZE,int rand $CONE_SIZE);
($i1,$i2)=sort2($i1,$i2);
my($j1,$j2)=(int rand $i1+1,int rand $i2+1);
if ($intermediate && $i1 != $i2) {
$graph->add_weighted_edge("$i1/$j1","i$i",1);
$graph->add_weighted_edge("i$i","$i2/$j2",1);
} else {
$graph->add_weighted_edge("$i1/$j1","$i2/$j2",1);
}
}
$graph;
}
sub grid_graph {
my($cyclic)=@_;
my $graph=new Graph::Directed;
for (my $i=0; $i<$HEIGHT; $i++) {
for (my $j=0; $j<$WIDTH; $j++) {
my $node=grid_node($i,$j);
$graph->add_vertex($node);
$graph->add_weighted_edge(grid_node($i-1,$j),$node,1) if $i>0; # down
$graph->add_weighted_edge(grid_node($i,$j-1),$node,1) if $j>0; # right
$graph->add_weighted_edge(grid_node($i-1,$j-1),$node,1) # down-right diagonal
if !$cyclic && $i>0 && $j>0;
# $graph->add_weighted_edge(grid_node($i-1,$j+1),$node,1) # down-left diagonal
# if $cyclic && $i>0 && $j<$WIDTH-1;
}
}
if ($cyclic) { # add wrapround edges, making grid a torus
if ($WIDTH>1) {
for (my $i=0; $i<$HEIGHT; $i++) {
$graph->add_weighted_edge(grid_node($i,$WIDTH-1),grid_node($i,0),1);
}
}
if ($HEIGHT>1) {
for (my $j=0; $j<$WIDTH; $j++) {
$graph->add_weighted_edge(grid_node($HEIGHT-1,$j),grid_node(0,$j),1);
}
}
}
$graph;
}
sub random_graph {
my($cyclic)=@_;
my $graph=new Graph::Directed;
for (my $i=0;$i<$EDGES; $i++) {
my($node1,$node2)=(int rand $NODES,int rand $NODES);
($node1,$node2)=sort2($node1,$node2) unless $cyclic;
$graph->add_weighted_edge($node1,$node2,1) unless $node1==$node2;
}
$graph;
}
sub get_param {
my($keyword)=@_;
$keyword=lc $keyword;
my $param=$OPTIONS{$keyword};
defined $param or $param=$DEFAULTS{$keyword};
$param;
}
sub grid_size {
my $height=$OPTIONS{height};
my $width=$OPTIONS{width};
# Cases
# 1. no height && no width => use defaults
# 2. height && no width => set width=height
# 3. no height && width => set height=width
# 4. height && width => use as given
if (!defined $height && !defined $width) {
$height=$DEFAULTS{height};
$width=$DEFAULTS{width};
} elsif (defined $height && !defined $width) {
$width=$height;
} elsif (!defined $height && defined $width) {
$height=$width;
}
($height,$width);
}
sub grid_node {
my($i,$j)=@_;
$j=$i unless defined $j;
"$i/$j";
}
#distances in directed grid with either diagonal edges or wraparound edges
sub grid_dist {
my($node1,$node2,$cyclic)=@_;
my($i1,$j1)=split('/',$node1);
my($i2,$j2)=split('/',$node2);
if ($cyclic) { # wraparound edges
return ($i2-$i1)%$HEIGHT + ($j2-$j1)%$WIDTH;
} else {
return undef unless $i1<=$i2 && $j1<=$j2;
return max($i2-$i1,$j2-$j1);
}
}
sub random_size {
my $nodes=$OPTIONS{nodes};
my $edges=$OPTIONS{edges};
my $density=$OPTIONS{density};
# Cases
# nodes edges density action
# no no no use default nodes, edges
# no no yes use default nodes
# no yes no use default density
# no yes yes okay
# yes no no use default density
# yes no yes okay
# yes yes no okay
# yes yes yes overspecified -- use nodes, edges
if (!defined $nodes) {
if (!defined $edges && !defined $density) {
($nodes,$edges)=@DEFAULTS{qw(nodes edges)};
} elsif (!defined $edges && defined $density) {
$nodes=$DEFAULTS{nodes};
$edges=int $nodes*$density;
} elsif (defined $edges && !defined $density) {
$nodes=int ($edges/$DEFAULTS{density});
} else {
$nodes=int ($edges/$density);
}
} else {
if (!defined $edges && !defined $density) {
$edges=int $nodes*$DEFAULTS{density};
} elsif (!defined $edges && defined $density) {
$edges=int $nodes*$density;
}
# remaining cases have $edges set, so nothing to do
}
($nodes,$edges);
}
# check strong components
sub test_sc {
my($graph)=@_;
print OUT "+++ test_sc\n" if $OPTIONS{verbose};
my @components=$graph->strongly_connected_components;
my $tc=new Graph::TransitiveClosure($graph);
check_partition($graph,@components); # check that components partition nodes
check_reach($graph,$tc,@components); # check reachability of components
\@components;
}
sub check_partition {
my($graph,@components)=@_;
my @nodes=$graph->vertices;
my %hits;
for my $component (@components) {
map {$hits{$_}++} @$component;
}
for my $node (@nodes) {
is($hits{$node}, 1, "node $node");
}
}
sub check_reach {
my($graph,$tc,@components)=@_;
# for each (ordered) pair of nodes in each component, make sure 1st node can reach 2nd
for my $component (@components) {
for (my $i=0; $i<@$component; $i++) {
my $nodei=$component->[$i];
for (my $j=0; $j<@$component; $j++) {
my $nodej=$component->[$j];
ok($tc->is_reachable($nodei,$nodej),
"nodes $nodei, $nodej in same component and reachable");
}
}
}
# for each pair of mutually reachable nodes, make sure they're in same component
my %components;
for my $component (@components) { # put each node in its component
@components{@$component}=($component)x@$component;
}
my @nodes=$graph->vertices;
for (my $i=0; $i<@nodes; $i++) {
my $nodei=$nodes[$i];
for (my $j=$i; $j<@nodes; $j++) {
my $nodej=$nodes[$j];
next unless $tc->is_reachable($nodei,$nodej) && $tc->is_reachable($nodej,$nodei);
is($components{$nodei}, $components{$nodej},
"nodes $nodei, $nodej reachable and in same component");
}
}
}
# check strong components of cone graph
# exploits the special structure of cycle, namely, cycles are in layers
sub test_cone_sc {
my($graph,$components)=@_;
is(@$components, $CONE_SIZE);
# each component should be different size
my %size2component;
for my $component (@$components) {
my $size=@$component;
ok(!$size2component{$size}, "two components have same size ($size)");
$size2component{$size}=$component;
}
# check that each component corresponds to a layer
for (my $i=0; $i<$CONE_SIZE; $i++) {
my $size=$i+1;
my $component=$size2component{$size};
# ecah node should start with "$i/"
my @bad=grep {$_!~/^$i\//} @$component;
is(@bad, 0, "component $size does not contain wrong nodes (@bad)");
}
}
# check strong components of cone graph with intermediate nodes
# exploits the special structure of cycle, namely, cycles are in layers
sub test_coneint_sc {
my($graph,$components)=@_;
my @nodes=$graph->vertices;
my @intermediates=grep {$_=~/^i/} @nodes;
is(@$components, $CONE_SIZE+@intermediates);
# each intermediate node should be in own component
for my $component (@$components) {
my @ints=grep {$_=~/^i/} @$component;
ok(@ints <= 1, "component contains multiple intermediate nodes @ints");
ok(!(@ints==1 && @$component>1), "component contains cycle and intermediate nodes");
}
# each component should be different size unless it contains just an intermediate node
my %size2component;
my %intermediates;
for my $component (@$components) {
my $size=@$component;
next if grep {$_=~/^i/} @$component;
ok(!($size2component{$size}), "two components have same size ($size)");
$size2component{$size}=$component;
}
# check that each non-intermediate node component corresponds to a layer
for (my $i=0; $i<$CONE_SIZE; $i++) {
my $size=$i+1;
my $component=$size2component{$size};
# each node should start with "$i/"
my @bad=grep {$_!~/^$i\//} @$component;
is(@bad, 0, "component $size contains wrong nodes @bad");
}
}
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;
}
sub mindef {min(grep {defined $_} @_);}
sub maxdef {max(grep {defined $_} @_);}
sub sort2 {$_[0]<=$_[1]? ($_[0],$_[1]): ($_[1],$_[0]);}