Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / Graph / Traversal.pm

package Graph::Traversal;

use strict;
local $^W = 1;

use Graph::Base;

use vars qw(@ISA);
@ISA = qw(Graph::Base);

=head1 NAME

Graph::Traversal - graph traversal

=head1 SYNOPSIS

    use Graph::Traversal;

=head1 DESCRIPTION

=over 4

=cut

=pod

=item new

	$s = Graph::Traversal->new($G, %param)

Returns a new graph search object for the graph $G
and the parameters %param.

Usually not used directly but instead via frontends like
Graph::DFS for depth-first searching and Graph::BFS for
breadth-first searching:

	$dfs = Graph::DFS->new($G, %param)
	$bfs = Graph::BFS->new($G, %param)

I<%param documentation to be written>

=cut

sub new {
    my $class  = shift;
    my $G      = shift;

    my $S = { G => $G };

    bless $S, $class;

    $S->reset(@_);

    return $S;
}

=pod

=item reset

	$S->reset

Resets a graph search object $S to its initial state.

=cut

sub reset {
    my $S = shift;
    my $G = $S->{ G };

    @{ $S->{ pool } }{ $G->vertices } = ( );
    $S->{ active_list       }         = [ ];
    $S->{ root_list         }         = [ ];
    $S->{ preorder_list     }         = [ ];
    $S->{ postorder_list    }         = [ ];
    $S->{ active_pool       }         = { };
    $S->{ vertex_found      }         = { };
    $S->{ vertex_root       }         = { };
    $S->{ vertex_successors }         = { };
    $S->{ param             }         = { @_ };
    $S->{ when              }         = 0;
}

# _get_next_root_vertex
#
#	$o = $S->_get_next_root_vertex(\%param)
#
#	(INTERNAL USE ONLY)
#	Returns a vertex hopefully suitable as a root vertex of a tree.
#
#	If $param->{ get_next_root } exists, it will be used the determine
#	the root.  If it is a code reference, the result of running it
#	with parameters ($S, %param) will be the next root.  Otherwise
#	it is assumed to be the next root vertex as it is.
#
#	Otherwise an unseen vertex having the maximal out-degree
#	will be selected.
#
sub _get_next_root_vertex {
    my $S      = shift;
    my %param  = ( %{ $S->{ param } }, @_ ? %{ $_[0] } : ( ));
    my $G      = $S->{ G };

    if ( exists $param{ get_next_root } ) {
	if ( ref $param{ get_next_root } eq 'CODE' ) {
	    return $param{ get_next_root }->( $S, %param ); # Dynamic.
	} else {
	    my $get_next_root = $param{ get_next_root };	# Static.

	    # Use only once.
	    delete $S->{ param }->{ get_next_root };
	    delete $_[0]->{ get_next_root } if @_;

	    return $get_next_root;
	}
    } else {
	return $G->largest_out_degree( keys %{ $S->{ pool } } );
    }
}

# _mark_vertex_found
#
#	$S->_mark_vertex_found( $u )
#
#	(INTERNAL USE ONLY)
#	Marks the vertex $u as a new vertex in the search object $S.
#
sub _mark_vertex_found {
    my ( $S, $u ) = @_;

    $S->{ vertex_found }->{ $u } = $S->{ when }++;
    delete $S->{ pool }->{ $u };
}

# _next_state
#
#	$o = $S->_next_state(%param)
#
#	(INTERNAL USE ONLY)
#	Returns a graph search object.
#
sub _next_state {
    my $S = shift;	# The current state.

    my $G = $S->{ G };	# The current graph.
    my %param = ( %{ $S->{ param } }, @_);
    my ($u, $v);	# The current vertex and its successor.
    my $return = 0;	# Return when this becomes true.

    until ( $return ) {

	# Initialize our search when needed.
	# (Start up a new tree.)
	unless ( @{ $S->{ active_list } } ) {
	    do {
		$u = $S->_get_next_root_vertex(\%param);
		return wantarray ? ( ) : $u unless defined $u;
	    } while exists $S->{ vertex_found }->{ $u };

	    # A new root vertex found.
	    push @{ $S->{ active_list } }, $u;
	    $S->{ active_pool }->{ $u } = 1;
	    push @{ $S->{ root_list   } }, $u;
	    $S->{ vertex_root }->{ $u } = $#{ $S->{ root_list } };
	}

	# Get the current vertex.
	$u = $param{ current }->( $S );
	return wantarray ? () : $u unless defined $u;

	# Record the vertex if necessary.
	unless ( exists $S->{ vertex_found }->{ $u } ) {
	    $S->_mark_vertex_found( $u );
	    push @{ $S->{ preorder_list } }, $u;
	    # Time to return?
	    $return++ if $param{ return_next_preorder };
	}

	# Initialized the list successors if necessary.
	$S->{ vertex_successors }->{ $u } = [ $G->successors( $u ) ]
	    unless exists $S->{ vertex_successors }->{ $u };

	# Get the next successor vertex.
	$v = shift @{ $S->{ vertex_successors }->{ $u } };

	if ( defined $v ) {
	    # Something to do for each successor?
	    $param{ successor }->( $u, $v, $S )
		if exists $param{ successor };

	    unless ( exists $S->{ vertex_found }->{ $v } ) {
		# An unseen successor.
		$S->_mark_vertex_found( $v );
		push @{ $S->{ preorder_list } }, $v;
		$S->{ vertex_root }->{ $v } = $S->{ vertex_root }->{ $u };
		push @{ $S->{ active_list } }, $v;
		$S->{ active_pool }->{ $v } = 1;

		# Something to for each unseen edge?
		# For multiedges, triggered only for the first edge.
		$param{ unseen_successor }->( $u, $v, $S )
		    if exists $param{ unseen_successor };
	    } else {
		# Something to do for each seen edge?
		# For multiedges, triggered for the 2nd, etc, edges.
		$param{ seen_successor }->( $u, $v, $S )
		    if exists $param{ seen_successor };
	    }

	    # Time to return?
	    $return++ if $param{ return_next_edge };

	} elsif ( not exists $S->{ vertex_finished }->{ $u } ) {
	    # Finish off with this vertex (we run out of descendants).
	    $param{ finish }->( $S );

	    $S->{ vertex_finished }->{ $u } = $S->{ when }++;
	    push @{ $S->{ postorder_list } }, $u;
	    delete $S->{ active_pool }->{ $u };

	    # Time to return?
	    $return++ if $param{ return_next_postorder };
	}
    }

    # Return an edge if so asked.
    return ( $u, $v ) if $param{ return_next_edge };

    # Return a vertex.
    return $u;
}

=pod

=item next_preorder

	$v = $s->next_preorder

Returns the next vertex in preorder of the graph
encapsulated within the search object $s.

=cut

sub next_preorder {
    my $S = shift;

    $S->_next_state( return_next_preorder => 1, @_ );
}

=cut

=item next_postorder

	$v = $S->next_postorder

Returns the next vertex in postorder of the graph
encapsulated within the search object $S.

=cut

sub next_postorder {
    my $S = shift;

    $S->_next_state( return_next_postorder => 1, @_ );
}

=pod

=item next_edge

	($u, $v) = $s->next_edge

Returns the vertices of the next edge of the graph
encapsulated within the search object $s.

=cut

sub next_edge {
    my $S = shift;

    $S->_next_state( return_next_edge => 1, @_ );
}

=pod

=item preorder

	@V = $S->preorder

Returns all the vertices in preorder of the graph
encapsulated within the search object $S.

=cut

sub preorder {
    my $S = shift;

    1 while defined $S->next_preorder;  # Process entire graph.

    return @{ $S->{ preorder_list } };
}

=pod

=item postorder

	@V = $S->postorder

Returns all the vertices in postorder of the graph
encapsulated within the search object $S.

=cut

sub postorder {
    my $S = shift;

    1 while defined $S->next_postorder; # Process entire graph.

    return @{ $S->{ postorder_list } };
}

=pod

=item edges

	@V = $S->edges

Returns all the edges of the graph
encapsulated within the search object $S.

=cut

sub edges {
    my $S = shift;
    my (@E, $u, $v);

    push @E, $u, $v while ($u, $v) = $S->next_edge;

    return @E;
}

=pod

=item roots

	@R = $S->roots

Returns all the root vertices of the trees of
the graph encapsulated within the search object $S.
"The root vertices" is ambiguous: what really happens
is that either the roots from the previous search made
on the $s are returned; or a preorder search is done
and the roots of this search are returned.

=cut

sub roots {
    my $S = shift;

    $S->preorder
	unless exists $S->{ preorder_list } and
	       @{ $S->{ preorder_list } } == $S->{ G }->vertices;

    return @{ $S->{ root_list } };
}

=pod

=item _vertex_roots

	%R = $S->_vertex_roots

Returns as a hash of ($vertex, index) pairs where index is an index
into the vertex_root list of the traversal.

"The root vertices" is ambiguous; see the documentation of the roots()
method for more details.

(This is the old vertex_roots().)

=cut

sub _vertex_roots {
    my $S = shift;
    my $G = $S->{ G };

    $S->preorder
        unless exists $S->{ preorder_list } and
	       @{ $S->{ preorder_list } } == $G->vertices;

    return 
	map { ( $_, $S->{ vertex_root }->{ $_ } ) } $G->vertices;
}

=pod

=item vertex_roots

	%R = $S->vertex_roots

Returns as a hash of ($vertex, $root) pairs all the vertices
and the root vertices of their search trees of the graph
encapsulated within the search object $S.

"The root vertices" is ambiguous; see the documentation of
the roots() method for more details.

(See also _vertex_roots()).

=cut

sub vertex_roots {
    my $S = shift;
    my $G = $S->{ G };

    $S->preorder
        unless exists $S->{ preorder_list } and
	       @{ $S->{ preorder_list } } == $G->vertices;

    return 
        map { ( $_, $S->{root_list}[$S->{ vertex_root }->{ $_ }] ) }
            $G->vertices;
}

# DELETE
#
#	(INTERNAL USE ONLY)
#	The Destructor.
#
sub DELETE {
    my $S = shift;

    delete $S->{ G }; # Release the graph.
}

=pod

=back

=head1 COPYRIGHT

Copyright 1999, O'Reilly & Associates.

This code is distributed under the same copyright terms as Perl itself.

=cut

1;