| 1 |
package Graph::Traversal;
|
| 2 |
use strict;
|
| 3 |
local $^W = 1;
|
| 4 |
use Graph::Base;
|
| 5 |
use vars qw(@ISA);
|
| 6 |
@ISA = qw(Graph::Base);
|
| 7 |
|
| 8 |
sub new
|
| 9 |
{
|
| 10 |
my $class = shift;
|
| 11 |
my $G = shift;
|
| 12 |
my $S = { G => $G };
|
| 13 |
bless $S, $class;
|
| 14 |
$S->reset(@_);
|
| 15 |
return $S;
|
| 16 |
}
|
| 17 |
|
| 18 |
sub reset
|
| 19 |
{
|
| 20 |
my $S = shift;
|
| 21 |
my $G = $S->{ G };
|
| 22 |
|
| 23 |
@{ $S->{ pool } }{ $G->vertices } = ( );
|
| 24 |
$S->{ active_list } = [ ];
|
| 25 |
$S->{ root_list } = [ ];
|
| 26 |
$S->{ preorder_list } = [ ];
|
| 27 |
$S->{ postorder_list } = [ ];
|
| 28 |
$S->{ active_pool } = { };
|
| 29 |
$S->{ vertex_found } = { };
|
| 30 |
$S->{ vertex_root } = { };
|
| 31 |
$S->{ vertex_successors } = { };
|
| 32 |
$S->{ param } = { @_ };
|
| 33 |
$S->{ when } = 0;
|
| 34 |
}
|
| 35 |
|
| 36 |
sub _get_next_root_vertex
|
| 37 |
{
|
| 38 |
my $S = shift;
|
| 39 |
my %param = ( %{ $S->{ param } }, @_ ? %{ $_[0] } : ( ));
|
| 40 |
my $G = $S->{ G };
|
| 41 |
|
| 42 |
if ( exists $param{ get_next_root } )
|
| 43 |
{
|
| 44 |
if ( ref $param{ get_next_root } eq 'CODE' )
|
| 45 |
{
|
| 46 |
return $param{ get_next_root }->( $S, %param ); # Dynamic.
|
| 47 |
}
|
| 48 |
else
|
| 49 |
{
|
| 50 |
my $get_next_root = $param{ get_next_root }; # Static.
|
| 51 |
|
| 52 |
# Use only once.
|
| 53 |
delete $S->{ param }->{ get_next_root };
|
| 54 |
delete $_[0]->{ get_next_root } if @_;
|
| 55 |
|
| 56 |
return $get_next_root;
|
| 57 |
}
|
| 58 |
}
|
| 59 |
else
|
| 60 |
{
|
| 61 |
return $G->largest_out_degree( keys %{ $S->{ pool } } );
|
| 62 |
}
|
| 63 |
}
|
| 64 |
|
| 65 |
sub _mark_vertex_found
|
| 66 |
{
|
| 67 |
my ( $S, $u ) = @_;
|
| 68 |
|
| 69 |
$S->{ vertex_found }->{ $u } = $S->{ when }++;
|
| 70 |
delete $S->{ pool }->{ $u };
|
| 71 |
}
|
| 72 |
|
| 73 |
sub _next_state
|
| 74 |
{
|
| 75 |
my $S = shift; # The current state.
|
| 76 |
my $G = $S->{ G }; # The current graph.
|
| 77 |
my %param = ( %{ $S->{ param } }, @_);
|
| 78 |
my ($u, $v); # The current vertex and its successor.
|
| 79 |
my $return = 0; # Return when this becomes true.
|
| 80 |
|
| 81 |
until ( $return )
|
| 82 |
{
|
| 83 |
# Initialize our search when needed.
|
| 84 |
# (Start up a new tree.)
|
| 85 |
unless ( @{ $S->{ active_list } } )
|
| 86 |
{
|
| 87 |
do
|
| 88 |
{
|
| 89 |
$u = $S->_get_next_root_vertex(\%param);
|
| 90 |
return wantarray ? ( ) : $u unless defined $u;
|
| 91 |
} while exists $S->{ vertex_found }->{ $u };
|
| 92 |
|
| 93 |
# A new root vertex found.
|
| 94 |
push @{ $S->{ active_list } }, $u;
|
| 95 |
$S->{ active_pool }->{ $u } = 1;
|
| 96 |
push @{ $S->{ root_list } }, $u;
|
| 97 |
$S->{ vertex_root }->{ $u } = $#{ $S->{ root_list } };
|
| 98 |
}
|
| 99 |
|
| 100 |
# Get the current vertex.
|
| 101 |
$u = $param{ current }->( $S );
|
| 102 |
return wantarray ? () : $u unless defined $u;
|
| 103 |
|
| 104 |
# Record the vertex if necessary.
|
| 105 |
unless ( exists $S->{ vertex_found }->{ $u } )
|
| 106 |
{
|
| 107 |
$S->_mark_vertex_found( $u );
|
| 108 |
push @{ $S->{ preorder_list } }, $u;
|
| 109 |
# Time to return?
|
| 110 |
$return++ if $param{ return_next_preorder };
|
| 111 |
}
|
| 112 |
|
| 113 |
# Initialized the list successors if necessary.
|
| 114 |
$S->{ vertex_successors }->{ $u } = [ $G->successors( $u ) ]
|
| 115 |
unless exists $S->{ vertex_successors }->{ $u };
|
| 116 |
|
| 117 |
# Get the next successor vertex.
|
| 118 |
$v = shift @{ $S->{ vertex_successors }->{ $u } };
|
| 119 |
|
| 120 |
if ( defined $v )
|
| 121 |
{
|
| 122 |
# Something to do for each successor?
|
| 123 |
$param{ successor }->( $u, $v, $S )
|
| 124 |
if exists $param{ successor };
|
| 125 |
|
| 126 |
unless ( exists $S->{ vertex_found }->{ $v } )
|
| 127 |
{
|
| 128 |
# An unseen successor.
|
| 129 |
$S->_mark_vertex_found( $v );
|
| 130 |
push @{ $S->{ preorder_list } }, $v;
|
| 131 |
$S->{ vertex_root }->{ $v } = $S->{ vertex_root }->{ $u };
|
| 132 |
push @{ $S->{ active_list } }, $v;
|
| 133 |
$S->{ active_pool }->{ $v } = 1;
|
| 134 |
|
| 135 |
# Something to for each unseen edge?
|
| 136 |
# For multiedges, triggered only for the first edge.
|
| 137 |
$param{ unseen_successor }->( $u, $v, $S )
|
| 138 |
if exists $param{ unseen_successor };
|
| 139 |
}
|
| 140 |
else
|
| 141 |
{
|
| 142 |
# Something to do for each seen edge?
|
| 143 |
# For multiedges, triggered for the 2nd, etc, edges.
|
| 144 |
$param{ seen_successor }->( $u, $v, $S )
|
| 145 |
if exists $param{ seen_successor };
|
| 146 |
}
|
| 147 |
|
| 148 |
# Time to return?
|
| 149 |
$return++ if $param{ return_next_edge };
|
| 150 |
|
| 151 |
}
|
| 152 |
elsif ( not exists $S->{ vertex_finished }->{ $u } )
|
| 153 |
{
|
| 154 |
# Finish off with this vertex (we run out of descendants).
|
| 155 |
$param{ finish }->( $S );
|
| 156 |
$S->{ vertex_finished }->{ $u } = $S->{ when }++;
|
| 157 |
push @{ $S->{ postorder_list } }, $u;
|
| 158 |
delete $S->{ active_pool }->{ $u };
|
| 159 |
|
| 160 |
# Time to return?
|
| 161 |
$return++ if $param{ return_next_postorder };
|
| 162 |
}
|
| 163 |
}
|
| 164 |
|
| 165 |
# Return an edge if so asked.
|
| 166 |
return ( $u, $v ) if $param{ return_next_edge };
|
| 167 |
|
| 168 |
# Return a vertex.
|
| 169 |
return $u;
|
| 170 |
}
|
| 171 |
|
| 172 |
sub next_preorder
|
| 173 |
{
|
| 174 |
my $S = shift;
|
| 175 |
$S->_next_state( return_next_preorder => 1, @_ );
|
| 176 |
}
|
| 177 |
|
| 178 |
sub next_postorder
|
| 179 |
{
|
| 180 |
my $S = shift;
|
| 181 |
$S->_next_state( return_next_postorder => 1, @_ );
|
| 182 |
}
|
| 183 |
|
| 184 |
sub next_edge
|
| 185 |
{
|
| 186 |
my $S = shift;
|
| 187 |
$S->_next_state( return_next_edge => 1, @_ );
|
| 188 |
}
|
| 189 |
|
| 190 |
sub preorder
|
| 191 |
{
|
| 192 |
my $S = shift;
|
| 193 |
1 while defined $S->next_preorder; # Process entire graph.
|
| 194 |
return @{ $S->{ preorder_list } };
|
| 195 |
}
|
| 196 |
|
| 197 |
sub postorder
|
| 198 |
{
|
| 199 |
my $S = shift;
|
| 200 |
1 while defined $S->next_postorder; # Process entire graph.
|
| 201 |
return @{ $S->{ postorder_list } };
|
| 202 |
}
|
| 203 |
|
| 204 |
sub edges
|
| 205 |
{
|
| 206 |
my $S = shift;
|
| 207 |
my (@E, $u, $v);
|
| 208 |
push @E, $u, $v while ($u, $v) = $S->next_edge;
|
| 209 |
return @E;
|
| 210 |
}
|
| 211 |
|
| 212 |
sub roots
|
| 213 |
{
|
| 214 |
my $S = shift;
|
| 215 |
|
| 216 |
$S->preorder
|
| 217 |
unless exists $S->{ preorder_list } and
|
| 218 |
@{ $S->{ preorder_list } } == $S->{ G }->vertices;
|
| 219 |
return @{ $S->{ root_list } };
|
| 220 |
}
|
| 221 |
|
| 222 |
sub vertex_roots
|
| 223 |
{
|
| 224 |
my $S = shift;
|
| 225 |
my $G = $S->{ G };
|
| 226 |
|
| 227 |
$S->preorder
|
| 228 |
unless exists $S->{ preorder_list } and
|
| 229 |
@{ $S->{ preorder_list } } == $G->vertices;
|
| 230 |
return
|
| 231 |
map { ( $_, $S->{ vertex_root }->{ $_ } ) } $G->vertices;
|
| 232 |
}
|
| 233 |
|
| 234 |
sub DELETE
|
| 235 |
{
|
| 236 |
my $S = shift;
|
| 237 |
delete $S->{ G }; # Release the graph.
|
| 238 |
}
|
| 239 |
|
| 240 |
1;
|
