graph.pm

nasm早期的源代码,比较简单是学习汇编和编译原理的好例子

    grep { $g->is_successorless_vertex($_) } $g->vertices05;
}

sub predecessorless_vertices {
    my $g = shift;
    grep { $g->is_predecessorless_vertex($_) } $g->vertices05;
}

sub successorful_vertices {
    my $g = shift;
    grep { $g->is_successorful_vertex($_) } $g->vertices05;
}

sub predecessorful_vertices {
    my $g = shift;
    grep { $g->is_predecessorful_vertex($_) } $g->vertices05;
}

sub isolated_vertices {
    my $g = shift;
    grep { $g->is_isolated_vertex($_) } $g->vertices05;
}

sub interior_vertices {
    my $g = shift;
    grep { $g->is_interior_vertex($_) } $g->vertices05;
}

sub exterior_vertices {
    my $g = shift;
    grep { $g->is_exterior_vertex($_) } $g->vertices05;
}

sub self_loop_vertices {
    my $g = shift;
    grep { $g->is_self_loop_vertex($_) } $g->vertices05;
}

###
# Paths and cycles.
#

sub add_path {
    my $g = shift;
    my $u = shift;
    while (@_) {
	my $v = shift;
	$g->add_edge($u, $v);
	$u = $v;
    }
    return $g;
}

sub delete_path {
    my $g = shift;
    my $u = shift;
    while (@_) {
	my $v = shift;
	$g->delete_edge($u, $v);
	$u = $v;
    }
    return $g;
}

sub has_path {
    my $g = shift;
    my $u = shift;
    while (@_) {
	my $v = shift;
	return 0 unless $g->has_edge($u, $v);
	$u = $v;
    }
    return $g;
}

sub add_cycle {
    my $g = shift;
    $g->add_path(@_, $_[0]);
}

sub delete_cycle {
    my $g = shift;
    $g->delete_path(@_, $_[0]);
}

sub has_cycle {
    my $g = shift;
    @_ ? ($g->has_path(@_, $_[0]) ? 1 : 0) : 0;
}

sub has_a_cycle {
    my $g = shift;
    my @r = ( back_edge => \&Graph::Traversal::has_a_cycle );
    push @r,
      down_edge => \&Graph::Traversal::has_a_cycle
       if $g->is_undirected;
    my $t = Graph::Traversal::DFS->new($g, @r, @_);
    $t->dfs;
    return $t->get_state('has_a_cycle');
}

sub find_a_cycle {
    my $g = shift;
    my @r = ( back_edge => \&Graph::Traversal::find_a_cycle);
    push @r,
      down_edge => \&Graph::Traversal::find_a_cycle
	if $g->is_undirected;
    my $t = Graph::Traversal::DFS->new($g, @r, @_);
    $t->dfs;
    $t->has_state('a_cycle') ? @{ $t->get_state('a_cycle') } : ();
}

###
# Attributes.

# Vertex attributes.

sub set_vertex_attribute {
    my $g = shift;
    $g->expect_non_multivertexed;
    my $value = pop;
    my $attr  = pop;
    $g->add_vertex( @_ ) unless $g->has_vertex( @_ );
    $g->[ _V ]->_set_path_attr( @_, $attr, $value );
}

sub set_vertex_attribute_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $value = pop;
    my $attr  = pop;
    $g->add_vertex_by_id( @_ ) unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_set_path_attr( @_, $attr, $value );
}

sub set_vertex_attributes {
    my $g = shift;
    $g->expect_non_multivertexed;
    my $attr = pop;
    $g->add_vertex( @_ ) unless $g->has_vertex( @_ );
    $g->[ _V ]->_set_path_attrs( @_, $attr );
}

sub set_vertex_attributes_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $attr = pop;
    $g->add_vertex_by_id( @_ ) unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_set_path_attrs( @_, $attr );
}

sub has_vertex_attributes {
    my $g = shift;
    $g->expect_non_multivertexed;
    return 0 unless $g->has_vertex( @_ );
    $g->[ _V ]->_has_path_attrs( @_ );
}

sub has_vertex_attributes_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    return 0 unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_has_path_attrs( @_ );
}

sub has_vertex_attribute {
    my $g = shift;
    $g->expect_non_multivertexed;
    my $attr = pop;
    return 0 unless $g->has_vertex( @_ );
    $g->[ _V ]->_has_path_attr( @_, $attr );
}

sub has_vertex_attribute_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $attr = pop;
    return 0 unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_has_path_attr( @_, $attr );
}

sub get_vertex_attributes {
    my $g = shift;
    $g->expect_non_multivertexed;
    return unless $g->has_vertex( @_ );
    my $a = $g->[ _V ]->_get_path_attrs( @_ );
    ($g->is_compat02) ? (defined $a ? %{ $a } : ()) : $a;
}

sub get_vertex_attributes_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    return unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_get_path_attrs( @_ );
}

sub get_vertex_attribute {
    my $g = shift;
    $g->expect_non_multivertexed;
    my $attr = pop;
    return unless $g->has_vertex( @_ );
    $g->[ _V ]->_get_path_attr( @_, $attr );
}

sub get_vertex_attribute_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $attr = pop;
    return unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_get_path_attr( @_, $attr );
}

sub get_vertex_attribute_names {
    my $g = shift;
    $g->expect_non_multivertexed;
    return unless $g->has_vertex( @_ );
    $g->[ _V ]->_get_path_attr_names( @_ );
}

sub get_vertex_attribute_names_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    return unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_get_path_attr_names( @_ );
}

sub get_vertex_attribute_values {
    my $g = shift;
    $g->expect_non_multivertexed;
    return unless $g->has_vertex( @_ );
    $g->[ _V ]->_get_path_attr_values( @_ );
}

sub get_vertex_attribute_values_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    return unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_get_path_attr_values( @_ );
}

sub delete_vertex_attributes {
    my $g = shift;
    $g->expect_non_multivertexed;
    return undef unless $g->has_vertex( @_ );
    $g->[ _V ]->_del_path_attrs( @_ );
}

sub delete_vertex_attributes_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    return undef unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_del_path_attrs( @_ );
}

sub delete_vertex_attribute {
    my $g = shift;
    $g->expect_non_multivertexed;
    my $attr = pop;
    return undef unless $g->has_vertex( @_ );
    $g->[ _V ]->_del_path_attr( @_, $attr );
}

sub delete_vertex_attribute_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $attr = pop;
    return undef unless $g->has_vertex_by_id( @_ );
    $g->[ _V ]->_del_path_attr( @_, $attr );
}

# Edge attributes.

sub _set_edge_attribute {
    my $g = shift;
    my $value = pop;
    my $attr  = pop;
    my $E = $g->[ _E ];
    my $f = $E->[ _f ];
    my @i;
    if ($E->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
	@_ = sort @_ if ($f & _UNORD);
	my $s = $E->[ _s ];
	$g->add_edge( @_ ) unless exists $s->{ $_[0] } && exists $s->{ $_[0] }->{ $_[1] };
	@i = @{ $g->[ _V ]->[ _s ] }{ @_ };
    } else {
	$g->add_edge( @_ ) unless $g->has_edge( @_ );
	@i = $g->_vertex_ids( @_ );
    }
    $g->[ _E ]->_set_path_attr( @i, $attr, $value );
}

sub set_edge_attribute {
    my $g = shift;
    $g->expect_non_multiedged;
    my $value = pop;
    my $attr  = pop;
    my $E = $g->[ _E ];
    $g->add_edge( @_ ) unless $g->has_edge( @_ );
    $E->_set_path_attr( $g->_vertex_ids( @_ ), $attr, $value );
}

sub set_edge_attribute_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $value = pop;
    my $attr  = pop;
    # $g->add_edge_by_id( @_ ) unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_set_path_attr( $g->_vertex_ids( @_ ), $id, $attr, $value );
}

sub set_edge_attributes {
    my $g = shift;
    $g->expect_non_multiedged;
    my $attr = pop;
    $g->add_edge( @_ ) unless $g->has_edge( @_ );
    $g->[ _E ]->_set_path_attrs( $g->_vertex_ids( @_ ), $attr );
}

sub set_edge_attributes_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $attr = pop;
    $g->add_edge_by_id( @_ ) unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_set_path_attrs( $g->_vertex_ids( @_ ), $id, $attr );
}

sub has_edge_attributes {
    my $g = shift;
    $g->expect_non_multiedged;
    return 0 unless $g->has_edge( @_ );
    $g->[ _E ]->_has_path_attrs( $g->_vertex_ids( @_ ) );
}

sub has_edge_attributes_by_id {
    my $g = shift;
    $g->expect_multiedged;
    return 0 unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_has_path_attrs( $g->_vertex_ids( @_ ), $id );
}

sub has_edge_attribute {
    my $g = shift;
    $g->expect_non_multiedged;
    my $attr = pop;
    return 0 unless $g->has_edge( @_ );
    $g->[ _E ]->_has_path_attr( $g->_vertex_ids( @_ ), $attr );
}

sub has_edge_attribute_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $attr = pop;
    return 0 unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_has_path_attr( $g->_vertex_ids( @_ ), $id, $attr );
}

sub get_edge_attributes {
    my $g = shift;
    $g->expect_non_multiedged;
    return unless $g->has_edge( @_ );
    my $a = $g->[ _E ]->_get_path_attrs( $g->_vertex_ids( @_ ) );
    ($g->is_compat02) ? (defined $a ? %{ $a } : ()) : $a;
}

sub get_edge_attributes_by_id {
    my $g = shift;
    $g->expect_multiedged;
    return unless $g->has_edge_by_id( @_ );
    my $id = pop;
    return $g->[ _E ]->_get_path_attrs( $g->_vertex_ids( @_ ), $id );
}

sub _get_edge_attribute { # Fast path; less checks.
    my $g = shift;
    my $attr = pop;
    my $E = $g->[ _E ];
    my $f = $E->[ _f ];
    if ($E->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
	@_ = sort @_ if ($f & _UNORD);
	my $s = $E->[ _s ];
	return unless exists $s->{ $_[0] } && exists $s->{ $_[0] }->{ $_[1] };
    } else {
	return unless $g->has_edge( @_ );
    }
    my @i = $g->_vertex_ids( @_ );
    $E->_get_path_attr( @i, $attr );
}

sub get_edge_attribute {
    my $g = shift;
    $g->expect_non_multiedged;
    my $attr = pop;
    return undef unless $g->has_edge( @_ );
    my @i = $g->_vertex_ids( @_ );
    return undef if @i == 0 && @_;
    my $E = $g->[ _E ];
    $E->_get_path_attr( @i, $attr );
}

sub get_edge_attribute_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $attr = pop;
    return unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_get_path_attr( $g->_vertex_ids( @_ ), $id, $attr );
}

sub get_edge_attribute_names {
    my $g = shift;
    $g->expect_non_multiedged;
    return unless $g->has_edge( @_ );
    $g->[ _E ]->_get_path_attr_names( $g->_vertex_ids( @_ ) );
}

sub get_edge_attribute_names_by_id {
    my $g = shift;
    $g->expect_multiedged;
    return unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_get_path_attr_names( $g->_vertex_ids( @_ ), $id );
}

sub get_edge_attribute_values {
    my $g = shift;
    $g->expect_non_multiedged;
    return unless $g->has_edge( @_ );
    $g->[ _E ]->_get_path_attr_values( $g->_vertex_ids( @_ ) );
}

sub get_edge_attribute_values_by_id {
    my $g = shift;
    $g->expect_multiedged;
    return unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_get_path_attr_values( $g->_vertex_ids( @_ ), $id );
}

sub delete_edge_attributes {
    my $g = shift;
    $g->expect_non_multiedged;
    return unless $g->has_edge( @_ );
    $g->[ _E ]->_del_path_attrs( $g->_vertex_ids( @_ ) );
}

sub delete_edge_attributes_by_id {
    my $g = shift;
    $g->expect_multiedged;
    return unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_del_path_attrs( $g->_vertex_ids( @_ ), $id );
}

sub delete_edge_attribute {
    my $g = shift;
    $g->expect_non_multiedged;
    my $attr = pop;
    return unless $g->has_edge( @_ );
    $g->[ _E ]->_del_path_attr( $g->_vertex_ids( @_ ), $attr );
}

sub delete_edge_attribute_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $attr = pop;
    return unless $g->has_edge_by_id( @_ );
    my $id = pop;
    $g->[ _E ]->_del_path_attr( $g->_vertex_ids( @_ ), $id, $attr );
}

###
# Compat.
#

sub vertex {
    my $g = shift;
    $g->has_vertex( @_ ) ? @_ : undef;
}

sub out_edges {
    my $g = shift;
    return unless @_ && $g->has_vertex( @_ );
    my @e = $g->edges_from( @_ );
    wantarray ? map { @$_ } @e : @e;
}

sub in_edges {
    my $g = shift;
    return unless @_ && $g->has_vertex( @_ );
    my @e = $g->edges_to( @_ );
    wantarray ? map { @$_ } @e : @e;
}

sub add_vertices {
    my $g = shift;
    $g->add_vertex( $_ ) for @_;
}

sub add_edges {
    my $g = shift;
    while (@_) {
	my $u = shift @_;
	if (ref $u eq 'ARRAY') {
	    $g->add_edge( @$u );
	} else {
	    if (@_) {
		my $v = shift @_;
		$g->add_edge( $u, $v );
	    } else {
		require Carp;
		Carp::croak("Graph::add_edges: missing end vertex");
	    }
	}
    }
}

###
# More constructors.
#

sub copy {
    my $g = shift;
    my %opt = _get_options( \@_ );
    
    my $c = (ref $g)->new(directed => $g->directed ? 1 : 0,
			  compat02 => $g->compat02 ? 1 : 0);
    for my $v ($g->isolated_vertices) { $c->add_vertex($v) }
    for my $e ($g->edges05)           { $c->add_edge(@$e)  }
    return $c;
}

*copy_graph = \©

sub deep_copy {
    require Data::Dumper;
    my $g = shift;
    my $d = Data::Dumper->new([$g]);
    use vars qw($VAR1);
    $d->Purity(1)->Terse(1)->Deepcopy(1);
    $d->Deparse(1) if $] >= 5.008;
    eval $d->Dump;
}

*deep_copy_graph = \&deep_copy;

sub transpose_edge {
    my $g = shift;
    if ($g->is_directed) {
	return undef unless $g->has_edge( @_ );
	my $c = $g->get_edge_count( @_ );