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