1package Graph::Traversal; 2 3use strict; 4 5# $SIG{__DIE__ } = sub { use Carp; confess }; 6# $SIG{__WARN__} = sub { use Carp; confess }; 7 8sub DEBUG () { 0 } 9 10sub reset { 11 my $self = shift; 12 $self->{ unseen } = { map { $_ => $_ } $self->{ graph }->vertices }; 13 $self->{ seen } = { }; 14 $self->{ order } = [ ]; 15 $self->{ preorder } = [ ]; 16 $self->{ postorder } = [ ]; 17 $self->{ roots } = [ ]; 18 $self->{ tree } = 19 Graph->new( directed => $self->{ graph }->directed ); 20 delete $self->{ terminate }; 21} 22 23my $see = sub { 24 my $self = shift; 25 $self->see; 26}; 27 28my $see_active = sub { 29 my $self = shift; 30 delete @{ $self->{ active } }{ $self->see }; 31}; 32 33sub has_a_cycle { 34 my ($u, $v, $t, $s) = @_; 35 $s->{ has_a_cycle } = 1; 36 $t->terminate; 37} 38 39sub find_a_cycle { 40 my ($u, $v, $t, $s) = @_; 41 my @cycle = ( $u ); 42 push @cycle, $v unless $u eq $v; 43 my $path = $t->{ order }; 44 if (@$path) { 45 my $i = $#$path; 46 while ($i >= 0 && $path->[ $i ] ne $v) { $i-- } 47 if ($i >= 0) { 48 unshift @cycle, @{ $path }[ $i+1 .. $#$path ]; 49 } 50 } 51 $s->{ a_cycle } = \@cycle; 52 $t->terminate; 53} 54 55sub configure { 56 my ($self, %attr) = @_; 57 $self->{ pre } = $attr{ pre } if exists $attr{ pre }; 58 $self->{ post } = $attr{ post } if exists $attr{ post }; 59 $self->{ pre_vertex } = $attr{ pre_vertex } if exists $attr{ pre_vertex }; 60 $self->{ post_vertex } = $attr{ post_vertex } if exists $attr{ post_vertex }; 61 $self->{ pre_edge } = $attr{ pre_edge } if exists $attr{ pre_edge }; 62 $self->{ post_edge } = $attr{ post_edge } if exists $attr{ post_edge }; 63 if (exists $attr{ successor }) { # Graph 0.201 compatibility. 64 $self->{ tree_edge } = $self->{ non_tree_edge } = $attr{ successor }; 65 } 66 if (exists $attr{ unseen_successor }) { 67 if (exists $self->{ tree_edge }) { # Graph 0.201 compatibility. 68 my $old_tree_edge = $self->{ tree_edge }; 69 $self->{ tree_edge } = sub { 70 $old_tree_edge->( @_ ); 71 $attr{ unseen_successor }->( @_ ); 72 }; 73 } else { 74 $self->{ tree_edge } = $attr{ unseen_successor }; 75 } 76 } 77 if ($self->graph->multiedged || $self->graph->countedged) { 78 $self->{ seen_edge } = $attr{ seen_edge } if exists $attr{ seen_edge }; 79 if (exists $attr{ seen_successor }) { # Graph 0.201 compatibility. 80 $self->{ seen_edge } = $attr{ seen_edge }; 81 } 82 } 83 $self->{ non_tree_edge } = $attr{ non_tree_edge } if exists $attr{ non_tree_edge }; 84 $self->{ pre_edge } = $attr{ tree_edge } if exists $attr{ tree_edge }; 85 $self->{ back_edge } = $attr{ back_edge } if exists $attr{ back_edge }; 86 $self->{ down_edge } = $attr{ down_edge } if exists $attr{ down_edge }; 87 $self->{ cross_edge } = $attr{ cross_edge } if exists $attr{ cross_edge }; 88 if (exists $attr{ start }) { 89 $attr{ first_root } = $attr{ start }; 90 $attr{ next_root } = undef; 91 } 92 if (exists $attr{ get_next_root }) { 93 $attr{ next_root } = $attr{ get_next_root }; # Graph 0.201 compat. 94 } 95 $self->{ next_root } = 96 exists $attr{ next_root } ? 97 $attr{ next_root } : 98 $attr{ next_alphabetic } ? 99 \&Graph::_next_alphabetic : 100 $attr{ next_numeric } ? 101 \&Graph::_next_numeric : 102 \&Graph::_next_random; 103 $self->{ first_root } = 104 exists $attr{ first_root } ? 105 $attr{ first_root } : 106 exists $attr{ next_root } ? 107 $attr{ next_root } : 108 $attr{ next_alphabetic } ? 109 \&Graph::_next_alphabetic : 110 $attr{ next_numeric } ? 111 \&Graph::_next_numeric : 112 \&Graph::_next_random; 113 $self->{ next_successor } = 114 exists $attr{ next_successor } ? 115 $attr{ next_successor } : 116 $attr{ next_alphabetic } ? 117 \&Graph::_next_alphabetic : 118 $attr{ next_numeric } ? 119 \&Graph::_next_numeric : 120 \&Graph::_next_random; 121 if (exists $attr{ has_a_cycle }) { 122 my $has_a_cycle = 123 ref $attr{ has_a_cycle } eq 'CODE' ? 124 $attr{ has_a_cycle } : \&has_a_cycle; 125 $self->{ back_edge } = $has_a_cycle; 126 if ($self->{ graph }->is_undirected) { 127 $self->{ down_edge } = $has_a_cycle; 128 } 129 } 130 if (exists $attr{ find_a_cycle }) { 131 my $find_a_cycle = 132 ref $attr{ find_a_cycle } eq 'CODE' ? 133 $attr{ find_a_cycle } : \&find_a_cycle; 134 $self->{ back_edge } = $find_a_cycle; 135 if ($self->{ graph }->is_undirected) { 136 $self->{ down_edge } = $find_a_cycle; 137 } 138 } 139 $self->{ add } = \&add_order; 140 $self->{ see } = $see; 141 delete @attr{ qw( 142 pre post pre_edge post_edge 143 successor unseen_successor seen_successor 144 tree_edge non_tree_edge 145 back_edge down_edge cross_edge seen_edge 146 start get_next_root 147 next_root next_alphabetic next_numeric next_random next_successor 148 first_root 149 has_a_cycle find_a_cycle 150 ) }; 151 if (keys %attr) { 152 require Carp; 153 my @attr = sort keys %attr; 154 Carp::croak(sprintf "Graph::Traversal: unknown attribute%s @{[map { qq['$_'] } @attr]}\n", @attr == 1 ? '' : 's'); 155 } 156} 157 158sub new { 159 my $class = shift; 160 my $g = shift; 161 unless (ref $g && $g->isa('Graph')) { 162 require Carp; 163 Carp::croak("Graph::Traversal: first argument is not a Graph"); 164 } 165 my $self = { graph => $g, state => { } }; 166 bless $self, $class; 167 $self->reset; 168 $self->configure( @_ ); 169 return $self; 170} 171 172sub terminate { 173 my $self = shift; 174 $self->{ terminate } = 1; 175} 176 177sub add_order { 178 my ($self, @next) = @_; 179 push @{ $self->{ order } }, @next; 180} 181 182sub visit { 183 my ($self, @next) = @_; 184 delete @{ $self->{ unseen } }{ @next }; 185 print "unseen = @{[sort keys %{$self->{unseen}}]}\n" if DEBUG; 186 @{ $self->{ seen } }{ @next } = @next; 187 print "seen = @{[sort keys %{$self->{seen}}]}\n" if DEBUG; 188 $self->{ add }->( $self, @next ); 189 print "order = @{$self->{order}}\n" if DEBUG; 190 if (exists $self->{ pre }) { 191 my $p = $self->{ pre }; 192 for my $v (@next) { 193 $p->( $v, $self ); 194 } 195 } 196} 197 198sub visit_preorder { 199 my ($self, @next) = @_; 200 push @{ $self->{ preorder } }, @next; 201 for my $v (@next) { 202 $self->{ preordern }->{ $v } = $self->{ preorderi }++; 203 } 204 print "preorder = @{$self->{preorder}}\n" if DEBUG; 205 $self->visit( @next ); 206} 207 208sub visit_postorder { 209 my ($self) = @_; 210 my @post = reverse $self->{ see }->( $self ); 211 push @{ $self->{ postorder } }, @post; 212 for my $v (@post) { 213 $self->{ postordern }->{ $v } = $self->{ postorderi }++; 214 } 215 print "postorder = @{$self->{postorder}}\n" if DEBUG; 216 if (exists $self->{ post }) { 217 my $p = $self->{ post }; 218 for my $v (@post) { 219 $p->( $v, $self ) ; 220 } 221 } 222 if (exists $self->{ post_edge }) { 223 my $p = $self->{ post_edge }; 224 my $u = $self->current; 225 if (defined $u) { 226 for my $v (@post) { 227 $p->( $u, $v, $self, $self->{ state }); 228 } 229 } 230 } 231} 232 233sub _callbacks { 234 my ($self, $current, @all) = @_; 235 return unless @all; 236 my $nontree = $self->{ non_tree_edge }; 237 my $back = $self->{ back_edge }; 238 my $down = $self->{ down_edge }; 239 my $cross = $self->{ cross_edge }; 240 my $seen = $self->{ seen_edge }; 241 my $bdc = defined $back || defined $down || defined $cross; 242 if (defined $nontree || $bdc || defined $seen) { 243 my $u = $current; 244 my $preu = $self->{ preordern }->{ $u }; 245 my $postu = $self->{ postordern }->{ $u }; 246 for my $v ( @all ) { 247 my $e = $self->{ tree }->has_edge( $u, $v ); 248 if ( !$e && (defined $nontree || $bdc) ) { 249 if ( exists $self->{ seen }->{ $v }) { 250 $nontree->( $u, $v, $self, $self->{ state }) 251 if $nontree; 252 if ($bdc) { 253 my $postv = $self->{ postordern }->{ $v }; 254 if ($back && 255 (!defined $postv || $postv >= $postu)) { 256 $back ->( $u, $v, $self, $self->{ state }); 257 } else { 258 my $prev = $self->{ preordern }->{ $v }; 259 if ($down && $prev > $preu) { 260 $down ->( $u, $v, $self, $self->{ state }); 261 } elsif ($cross && $prev < $preu) { 262 $cross->( $u, $v, $self, $self->{ state }); 263 } 264 } 265 } 266 } 267 } 268 if ($seen) { 269 my $c = $self->graph->get_edge_count($u, $v); 270 while ($c-- > 1) { 271 $seen->( $u, $v, $self, $self->{ state } ); 272 } 273 } 274 } 275 } 276} 277 278sub next { 279 my $self = shift; 280 return undef if $self->{ terminate }; 281 my @next; 282 while ($self->seeing) { 283 my $current = $self->current; 284 print "current = $current\n" if DEBUG; 285 @next = $self->{ graph }->successors( $current ); 286 print "next.0 - @next\n" if DEBUG; 287 my %next; @next{ @next } = @next; 288 print "next.1 - @next\n" if DEBUG; 289 @next = keys %next; 290 my @all = @next; 291 print "all = @all\n" if DEBUG; 292 for my $s (keys %next) { 293 delete $next{$s} if exists $self->{seen}->{$s}; 294 } 295 @next = keys %next; 296 print "next.2 - @next\n" if DEBUG; 297 if (@next) { 298 @next = $self->{ next_successor }->( $self, \%next ); 299 print "next.3 - @next\n" if DEBUG; 300 for my $v (@next) { 301 $self->{ tree }->add_edge( $current, $v ); 302 } 303 if (exists $self->{ pre_edge }) { 304 my $p = $self->{ pre_edge }; 305 my $u = $self->current; 306 for my $v (@next) { 307 $p->( $u, $v, $self, $self->{ state }); 308 } 309 } 310 last; 311 } else { 312 $self->visit_postorder; 313 } 314 return undef if $self->{ terminate }; 315 $self->_callbacks($current, @all); 316 } 317 print "next.4 - @next\n" if DEBUG; 318 unless (@next) { 319 unless ( @{ $self->{ roots } } ) { 320 my $first = $self->{ first_root }; 321 if (defined $first) { 322 @next = 323 ref $first eq 'CODE' ? 324 $self->{ first_root }->( $self, $self->{ unseen } ) : 325 $first; 326 return unless @next; 327 } 328 } 329 unless (@next) { 330 return unless defined $self->{ next_root }; 331 return unless @next = 332 $self->{ next_root }->( $self, $self->{ unseen } ); 333 } 334 return if exists $self->{ seen }->{ $next[0] }; # Sanity check. 335 print "next.5 - @next\n" if DEBUG; 336 push @{ $self->{ roots } }, $next[0]; 337 } 338 print "next.6 - @next\n" if DEBUG; 339 if (@next) { 340 $self->visit_preorder( @next ); 341 } 342 return $next[0]; 343} 344 345sub _order { 346 my ($self, $order) = @_; 347 1 while defined $self->next; 348 my $wantarray = wantarray; 349 if ($wantarray) { 350 @{ $self->{ $order } }; 351 } elsif (defined $wantarray) { 352 shift @{ $self->{ $order } }; 353 } 354} 355 356sub preorder { 357 my $self = shift; 358 $self->_order( 'preorder' ); 359} 360 361sub postorder { 362 my $self = shift; 363 $self->_order( 'postorder' ); 364} 365 366sub unseen { 367 my $self = shift; 368 values %{ $self->{ unseen } }; 369} 370 371sub seen { 372 my $self = shift; 373 values %{ $self->{ seen } }; 374} 375 376sub seeing { 377 my $self = shift; 378 @{ $self->{ order } }; 379} 380 381sub roots { 382 my $self = shift; 383 @{ $self->{ roots } }; 384} 385 386sub is_root { 387 my ($self, $v) = @_; 388 for my $u (@{ $self->{ roots } }) { 389 return 1 if $u eq $v; 390 } 391 return 0; 392} 393 394sub tree { 395 my $self = shift; 396 $self->{ tree }; 397} 398 399sub graph { 400 my $self = shift; 401 $self->{ graph }; 402} 403 404sub vertex_by_postorder { 405 my ($self, $i) = @_; 406 exists $self->{ postorder } && $self->{ postorder }->[ $i ]; 407} 408 409sub postorder_by_vertex { 410 my ($self, $v) = @_; 411 exists $self->{ postordern } && $self->{ postordern }->{ $v }; 412} 413 414sub postorder_vertices { 415 my ($self, $v) = @_; 416 exists $self->{ postordern } ? %{ $self->{ postordern } } : (); 417} 418 419sub vertex_by_preorder { 420 my ($self, $i) = @_; 421 exists $self->{ preorder } && $self->{ preorder }->[ $i ]; 422} 423 424sub preorder_by_vertex { 425 my ($self, $v) = @_; 426 exists $self->{ preordern } && $self->{ preordern }->{ $v }; 427} 428 429sub preorder_vertices { 430 my ($self, $v) = @_; 431 exists $self->{ preordern } ? %{ $self->{ preordern } } : (); 432} 433 434sub has_state { 435 my ($self, $var) = @_; 436 exists $self->{ state } && exists $self->{ state }->{ $var }; 437} 438 439sub get_state { 440 my ($self, $var) = @_; 441 exists $self->{ state } ? $self->{ state }->{ $var } : undef; 442} 443 444sub set_state { 445 my ($self, $var, $val) = @_; 446 $self->{ state }->{ $var } = $val; 447 return 1; 448} 449 450sub delete_state { 451 my ($self, $var) = @_; 452 delete $self->{ state }->{ $var }; 453 delete $self->{ state } unless keys %{ $self->{ state } }; 454 return 1; 455} 456 4571; 458__END__ 459=pod 460 461=head1 NAME 462 463Graph::Traversal - traverse graphs 464 465=head1 SYNOPSIS 466 467Don't use Graph::Traversal directly, use Graph::Traversal::DFS 468or Graph::Traversal::BFS instead. 469 470 use Graph; 471 my $g = Graph->new; 472 $g->add_edge(...); 473 use Graph::Traversal::...; 474 my $t = Graph::Traversal::...->new(%opt); 475 $t->... 476 477=head1 DESCRIPTION 478 479You can control how the graph is traversed by the various callback 480parameters in the C<%opt>. In the parameters descriptions below the 481$u and $v are vertices, and the $self is the traversal object itself. 482 483=head2 Callback parameters 484 485The following callback parameters are available: 486 487=over 4 488 489=item tree_edge 490 491Called when traversing an edge that belongs to the traversal tree. 492Called with arguments ($u, $v, $self). 493 494=item non_tree_edge 495 496Called when an edge is met which either leads back to the traversal tree 497(either a C<back_edge>, a C<down_edge>, or a C<cross_edge>). 498Called with arguments ($u, $v, $self). 499 500=item pre_edge 501 502Called for edges in preorder. 503Called with arguments ($u, $v, $self). 504 505=item post_edge 506 507Called for edges in postorder. 508Called with arguments ($u, $v, $self). 509 510=item back_edge 511 512Called for back edges. 513Called with arguments ($u, $v, $self). 514 515=item down_edge 516 517Called for down edges. 518Called with arguments ($u, $v, $self). 519 520=item cross_edge 521 522Called for cross edges. 523Called with arguments ($u, $v, $self). 524 525=item pre 526 527=item pre_vertex 528 529Called for vertices in preorder. 530Called with arguments ($v, $self). 531 532=item post 533 534=item post_vertex 535 536Called for vertices in postorder. 537Called with arguments ($v, $self). 538 539=item first_root 540 541Called when choosing the first root (start) vertex for traversal. 542Called with arguments ($self, $unseen) where $unseen is a hash 543reference with the unseen vertices as keys. 544 545=item next_root 546 547Called when choosing the next root (after the first one) vertex for 548traversal (useful when the graph is not connected). Called with 549arguments ($self, $unseen) where $unseen is a hash reference with 550the unseen vertices as keys. If you want only the first reachable 551subgraph to be processed, set the next_root to C<undef>. 552 553=item start 554 555Identical to defining C<first_root> and undefining C<next_root>. 556 557=item next_alphabetic 558 559Set this to true if you want the vertices to be processed in 560alphabetic order (and leave first_root/next_root undefined). 561 562=item next_numeric 563 564Set this to true if you want the vertices to be processed in 565numeric order (and leave first_root/next_root undefined). 566 567=item next_successor 568 569Called when choosing the next vertex to visit. Called with arguments 570($self, $next) where $next is a hash reference with the possible 571next vertices as keys. Use this to provide a custom ordering for 572choosing vertices, as opposed to C<next_numeric> or C<next_alphabetic>. 573 574=back 575 576The parameters C<first_root> and C<next_successor> have a 'hierarchy' 577of how they are determined: if they have been explicitly defined, use 578that value. If not, use the value of C<next_alphabetic>, if that has 579been defined. If not, use the value of C<next_numeric>, if that has 580been defined. If not, the next vertex to be visited is chose randomly. 581 582=head2 Methods 583 584The following methods are available: 585 586=over 4 587 588=item unseen 589 590Return the unseen vertices in random order. 591 592=item seen 593 594Return the seen vertices in random order. 595 596=item seeing 597 598Return the active fringe vertices in random order. 599 600=item preorder 601 602Return the vertices in preorder traversal order. 603 604=item postorder 605 606Return the vertices in postorder traversal order. 607 608=item vertex_by_preorder 609 610 $v = $t->vertex_by_preorder($i) 611 612Return the ith (0..$V-1) vertex by preorder. 613 614=item preorder_by_vertex 615 616 $i = $t->preorder_by_vertex($v) 617 618Return the preorder index (0..$V-1) by vertex. 619 620=item vertex_by_postorder 621 622 $v = $t->vertex_by_postorder($i) 623 624Return the ith (0..$V-1) vertex by postorder. 625 626=item postorder_by_vertex 627 628 $i = $t->postorder_by_vertex($v) 629 630Return the postorder index (0..$V-1) by vertex. 631 632=item preorder_vertices 633 634Return a hash with the vertices as the keys and their preorder indices 635as the values. 636 637=item postorder_vertices 638 639Return a hash with the vertices as the keys and their postorder 640indices as the values. 641 642=item tree 643 644Return the traversal tree as a graph. 645 646=item has_state 647 648 $t->has_state('s') 649 650Test whether the traversal has state 's' attached to it. 651 652=item get_state 653 654 $t->get_state('s') 655 656Get the state 's' attached to the traversal (C<undef> if none). 657 658=item set_state 659 660 $t->set_state('s', $s) 661 662Set the state 's' attached to the traversal. 663 664=item delete_state 665 666 $t->delete_state('s') 667 668Delete the state 's' from the traversal. 669 670=back 671 672=head2 Backward compatibility 673 674The following parameters are for backward compatibility to Graph 0.2xx: 675 676=over 4 677 678=item get_next_root 679 680Like C<next_root>. 681 682=item successor 683 684Identical to having C<tree_edge> both C<non_tree_edge> defined 685to be the same. 686 687=item unseen_successor 688 689Like C<tree_edge>. 690 691=item seen_successor 692 693Like C<seed_edge>. 694 695=back 696 697=head2 Special callbacks 698 699If in a callback you call the special C<terminate> method, 700the traversal is terminated, no more vertices are traversed. 701 702=head1 SEE ALSO 703 704L<Graph::Traversal::DFS>, L<Graph::Traversal::BFS> 705 706=head1 AUTHOR AND COPYRIGHT 707 708Jarkko Hietaniemi F<jhi@iki.fi> 709 710=head1 LICENSE 711 712This module is licensed under the same terms as Perl itself. 713 714=cut 715