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 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# delete $next{ $current }; 289 print "next.1 - @next\n" if DEBUG; 290 @next = keys %next; 291 my @all = @next; 292 print "all = @all\n" if DEBUG; 293 delete @next{ $self->seen }; 294 @next = keys %next; 295 print "next.2 - @next\n" if DEBUG; 296 if (@next) { 297 @next = $self->{ next_successor }->( $self, \%next ); 298 print "next.3 - @next\n" if DEBUG; 299 for my $v (@next) { 300 $self->{ tree }->add_edge( $current, $v ); 301 } 302 if (exists $self->{ pre_edge }) { 303 my $p = $self->{ pre_edge }; 304 my $u = $self->current; 305 for my $v (@next) { 306 $p->( $u, $v, $self, $self->{ state }); 307 } 308 } 309 last; 310 } else { 311 $self->visit_postorder; 312 } 313 return undef if $self->{ terminate }; 314 $self->_callbacks($current, @all); 315# delete $next{ $current }; 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 keys %{ $self->{ unseen } }; 369} 370 371sub seen { 372 my $self = shift; 373 keys %{ $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=back 568 569The parameters C<first_root> and C<next_successor> have a 'hierarchy' 570of how they are determined: if they have been explicitly defined, use 571that value. If not, use the value of C<next_alphabetic>, if that has 572been defined. If not, use the value of C<next_numeric>, if that has 573been defined. If not, the next vertex to be visited is chose randomly. 574 575=head2 Methods 576 577The following methods are available: 578 579=over 4 580 581=item unseen 582 583Return the unseen vertices in random order. 584 585=item seen 586 587Return the seen vertices in random order. 588 589=item seeing 590 591Return the active fringe vertices in random order. 592 593=item preorder 594 595Return the vertices in preorder traversal order. 596 597=item postorder 598 599Return the vertices in postorder traversal order. 600 601=item vertex_by_preorder 602 603 $v = $t->vertex_by_preorder($i) 604 605Return the ith (0..$V-1) vertex by preorder. 606 607=item preorder_by_vertex 608 609 $i = $t->preorder_by_vertex($v) 610 611Return the preorder index (0..$V-1) by vertex. 612 613=item vertex_by_postorder 614 615 $v = $t->vertex_by_postorder($i) 616 617Return the ith (0..$V-1) vertex by postorder. 618 619=item postorder_by_vertex 620 621 $i = $t->postorder_by_vertex($v) 622 623Return the postorder index (0..$V-1) by vertex. 624 625=item preorder_vertices 626 627Return a hash with the vertices as the keys and their preorder indices 628as the values. 629 630=item postorder_vertices 631 632Return a hash with the vertices as the keys and their postorder 633indices as the values. 634 635=item tree 636 637Return the traversal tree as a graph. 638 639=item has_state 640 641 $t->has_state('s') 642 643Test whether the traversal has state 's' attached to it. 644 645=item get_state 646 647 $t->get_state('s') 648 649Get the state 's' attached to the traversal (C<undef> if none). 650 651=item set_state 652 653 $t->set_state('s', $s) 654 655Set the state 's' attached to the traversal. 656 657=item delete_state 658 659 $t->delete_state('s') 660 661Delete the state 's' from the traversal. 662 663=back 664 665=head2 Backward compatibility 666 667The following parameters are for backward compatibility to Graph 0.2xx: 668 669=over 4 670 671=item get_next_root 672 673Like C<next_root>. 674 675=item successor 676 677Identical to having C<tree_edge> both C<non_tree_edge> defined 678to be the same. 679 680=item unseen_successor 681 682Like C<tree_edge>. 683 684=item seen_successor 685 686Like C<seed_edge>. 687 688=back 689 690=head2 Special callbacks 691 692If in a callback you call the special C<terminate> method, 693the traversal is terminated, no more vertices are traversed. 694 695=head1 SEE ALSO 696 697L<Graph::Traversal::DFS>, L<Graph::Traversal::BFS> 698 699=head1 AUTHOR AND COPYRIGHT 700 701Jarkko Hietaniemi F<jhi@iki.fi> 702 703=head1 LICENSE 704 705This module is licensed under the same terms as Perl itself. 706 707=cut 708