graph.pm

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

	my $a = $g->get_edge_attributes( @_ );
	my @e = reverse @_;
	$g->delete_edge( @_ ) unless $g->has_edge( @e );
	$g->add_edge( @e ) for 1..$c;
	$g->set_edge_attributes(@e, $a) if $a;
    }
    return $g;
}

sub transpose_graph {
    my $g = shift;
    my $t = $g->copy;
    if ($t->directed) {
	for my $e ($t->edges05) {
	    $t->transpose_edge(@$e);
	}
    }
    return $t;
}

*transpose = \&transpose_graph;

sub complete_graph {
    my $g = shift;
    my $c = $g->new( directed => $g->directed );
    my @v = $g->vertices05;
    for (my $i = 0; $i <= $#v; $i++ ) {
	for (my $j = 0; $j <= $#v; $j++ ) {
	    next if $i >= $j;
	    if ($g->is_undirected) {
		$c->add_edge($v[$i], $v[$j]);
	    } else {
		$c->add_edge($v[$i], $v[$j]);
		$c->add_edge($v[$j], $v[$i]);
	    }
	}
    }
    return $c;
}

*complement = \&complement_graph;

sub complement_graph {
    my $g = shift;
    my $c = $g->new( directed => $g->directed );
    my @v = $g->vertices05;
    for (my $i = 0; $i <= $#v; $i++ ) {
	for (my $j = 0; $j <= $#v; $j++ ) {
	    next if $i >= $j;
	    if ($g->is_undirected) {
		$c->add_edge($v[$i], $v[$j])
		    unless $g->has_edge($v[$i], $v[$j]);
	    } else {
		$c->add_edge($v[$i], $v[$j])
		    unless $g->has_edge($v[$i], $v[$j]);
		$c->add_edge($v[$j], $v[$i])
		    unless $g->has_edge($v[$j], $v[$i]);
	    }
	}
    }
    return $c;
}

*complete = \&complete_graph;

###
# Transitivity.
#

sub is_transitive {
    my $g = shift;
    Graph::TransitiveClosure::is_transitive($g);
}

###
# Weighted vertices.
#

my $defattr = 'weight';

sub _defattr {
    return $defattr;
}

sub add_weighted_vertex {
    my $g = shift;
    $g->expect_non_multivertexed;
    my $w = pop;
    $g->add_vertex(@_);
    $g->set_vertex_attribute(@_, $defattr, $w);
}

sub add_weighted_vertices {
    my $g = shift;
    $g->expect_non_multivertexed;
    while (@_) {
	my ($v, $w) = splice @_, 0, 2;
	$g->add_vertex($v);
	$g->set_vertex_attribute($v, $defattr, $w);
    }
}

sub get_vertex_weight {
    my $g = shift;
    $g->expect_non_multivertexed;
    $g->get_vertex_attribute(@_, $defattr);
}

sub has_vertex_weight {
    my $g = shift;
    $g->expect_non_multivertexed;
    $g->has_vertex_attribute(@_, $defattr);
}

sub set_vertex_weight {
    my $g = shift;
    $g->expect_non_multivertexed;
    my $w = pop;
    $g->set_vertex_attribute(@_, $defattr, $w);
}

sub delete_vertex_weight {
    my $g = shift;
    $g->expect_non_multivertexed;
    $g->delete_vertex_attribute(@_, $defattr);
}

sub add_weighted_vertex_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $w = pop;
    $g->add_vertex_by_id(@_);
    $g->set_vertex_attribute_by_id(@_, $defattr, $w);
}

sub add_weighted_vertices_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $id = pop;
    while (@_) {
	my ($v, $w) = splice @_, 0, 2;
	$g->add_vertex_by_id($v, $id);
	$g->set_vertex_attribute_by_id($v, $id, $defattr, $w);
    }
}

sub get_vertex_weight_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    $g->get_vertex_attribute_by_id(@_, $defattr);
}

sub has_vertex_weight_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    $g->has_vertex_attribute_by_id(@_, $defattr);
}

sub set_vertex_weight_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $w = pop;
    $g->set_vertex_attribute_by_id(@_, $defattr, $w);
}

sub delete_vertex_weight_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    $g->delete_vertex_attribute_by_id(@_, $defattr);
}

###
# Weighted edges.
#

sub add_weighted_edge {
    my $g = shift;
    $g->expect_non_multiedged;
    if ($g->is_compat02) {
	my $w = splice @_, 1, 1;
	$g->add_edge(@_);
	$g->set_edge_attribute(@_, $defattr, $w);
    } else {
	my $w = pop;
	$g->add_edge(@_);
	$g->set_edge_attribute(@_, $defattr, $w);
    }
}

sub add_weighted_edges {
    my $g = shift;
    $g->expect_non_multiedged;
    if ($g->is_compat02) {
	while (@_) {
	    my ($u, $w, $v) = splice @_, 0, 3;
	    $g->add_edge($u, $v);
	    $g->set_edge_attribute($u, $v, $defattr, $w);
	}
    } else {
	while (@_) {
	    my ($u, $v, $w) = splice @_, 0, 3;
	    $g->add_edge($u, $v);
	    $g->set_edge_attribute($u, $v, $defattr, $w);
	}
    }
}

sub add_weighted_edges_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $id = pop;
    while (@_) {
	my ($u, $v, $w) = splice @_, 0, 3;
	$g->add_edge_by_id($u, $v, $id);
	$g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w);
    }
}

sub add_weighted_path {
    my $g = shift;
    $g->expect_non_multiedged;
    my $u = shift;
    while (@_) {
	my ($w, $v) = splice @_, 0, 2;
	$g->add_edge($u, $v);
	$g->set_edge_attribute($u, $v, $defattr, $w);
	$u = $v;
    }
}

sub get_edge_weight {
    my $g = shift;
    $g->expect_non_multiedged;
    $g->get_edge_attribute(@_, $defattr);
}

sub has_edge_weight {
    my $g = shift;
    $g->expect_non_multiedged;
    $g->has_edge_attribute(@_, $defattr);
}

sub set_edge_weight {
    my $g = shift;
    $g->expect_non_multiedged;
    my $w = pop;
    $g->set_edge_attribute(@_, $defattr, $w);
}

sub delete_edge_weight {
    my $g = shift;
    $g->expect_non_multiedged;
    $g->delete_edge_attribute(@_, $defattr);
}

sub add_weighted_edge_by_id {
    my $g = shift;
    $g->expect_multiedged;
    if ($g->is_compat02) {
	my $w = splice @_, 1, 1;
	$g->add_edge_by_id(@_);
	$g->set_edge_attribute_by_id(@_, $defattr, $w);
    } else {
	my $w = pop;
	$g->add_edge_by_id(@_);
	$g->set_edge_attribute_by_id(@_, $defattr, $w);
    }
}

sub add_weighted_path_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $id = pop;
    my $u = shift;
    while (@_) {
	my ($w, $v) = splice @_, 0, 2;
	$g->add_edge_by_id($u, $v, $id);
	$g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w);
	$u = $v;
    }
}

sub get_edge_weight_by_id {
    my $g = shift;
    $g->expect_multiedged;
    $g->get_edge_attribute_by_id(@_, $defattr);
}

sub has_edge_weight_by_id {
    my $g = shift;
    $g->expect_multiedged;
    $g->has_edge_attribute_by_id(@_, $defattr);
}

sub set_edge_weight_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $w = pop;
    $g->set_edge_attribute_by_id(@_, $defattr, $w);
}

sub delete_edge_weight_by_id {
    my $g = shift;
    $g->expect_multiedged;
    $g->delete_edge_attribute_by_id(@_, $defattr);
}

###
# Error helpers.
#

my %expected;
@expected{qw(directed undirected acyclic)} = qw(undirected directed cyclic);

sub _expected {
    my $exp = shift;
    my $got = @_ ? shift : $expected{$exp};
    $got = defined $got ? ", got $got" : "";
    if (my @caller2 = caller(2)) {
	die "$caller2[3]: expected $exp graph$got, at $caller2[1] line $caller2[2].\n";
    } else {
	my @caller1 = caller(1);
	die "$caller1[3]: expected $exp graph$got, at $caller1[1] line $caller1[2].\n";
    }
}

sub expect_undirected {
    my $g = shift;
    _expected('undirected') unless $g->is_undirected;
}

sub expect_directed {
    my $g = shift;
    _expected('directed') unless $g->is_directed;
}

sub expect_acyclic {
    my $g = shift;
    _expected('acyclic') unless $g->is_acyclic;
}

sub expect_dag {
    my $g = shift;
    my @got;
    push @got, 'undirected' unless $g->is_directed;
    push @got, 'cyclic'     unless $g->is_acyclic;
    _expected('directed acyclic', "@got") if @got;
}

sub expect_multivertexed {
    my $g = shift;
    _expected('multivertexed') unless $g->is_multivertexed;
}

sub expect_non_multivertexed {
    my $g = shift;
    _expected('non-multivertexed') if $g->is_multivertexed;
}

sub expect_non_multiedged {
    my $g = shift;
    _expected('non-multiedged') if $g->is_multiedged;
}

sub expect_multiedged {
    my $g = shift;
    _expected('multiedged') unless $g->is_multiedged;
}

sub _get_options {
    my @caller = caller(1);
    unless (@_ == 1 && ref $_[0] eq 'ARRAY') {
	die "$caller[3]: internal error: should be called with only one array ref argument, at $caller[1] line $caller[2].\n";
    }
    my @opt = @{ $_[0] };
    unless (@opt  % 2 == 0) {
	die "$caller[3]: expected an options hash, got a non-even number of arguments, at $caller[1] line $caller[2].\n";
    }
    return @opt;
}

###
# Random constructors and accessors.
#

sub __fisher_yates_shuffle (@) {
    # From perlfaq4, but modified to be non-modifying.
    my @a = @_;
    my $i = @a;
    while ($i--) {
	my $j = int rand ($i+1);
	@a[$i,$j] = @a[$j,$i];
    }
    return @a;
}

BEGIN {
    sub _shuffle(@);
    # Workaround for the Perl bug [perl #32383] where -d:Dprof and
    # List::Util::shuffle do not like each other: if any debugging
    # (-d) flags are on, fall back to our own Fisher-Yates shuffle.
    # The bug was fixed by perl changes #26054 and #26062, which
    # went to Perl 5.9.3.  If someone tests this with a pre-5.9.3
    # bleadperl that calls itself 5.9.3 but doesn't yet have the
    # patches, oh, well.
    *_shuffle = $^P && $] < 5.009003 ?
	\&__fisher_yates_shuffle : \&List::Util::shuffle;
}

sub random_graph {
    my $class = (@_ % 2) == 0 ? 'Graph' : shift;
    my %opt = _get_options( \@_ );
    my $random_edge;
    unless (exists $opt{vertices} && defined $opt{vertices}) {
	require Carp;
	Carp::croak("Graph::random_graph: argument 'vertices' missing or undef");
    }
    if (exists $opt{random_seed}) {
	srand($opt{random_seed});
	delete $opt{random_seed};
    }
    if (exists $opt{random_edge}) {
	$random_edge = $opt{random_edge};
	delete $opt{random_edge};
    }
    my @V;
    if (my $ref = ref $opt{vertices}) {
	if ($ref eq 'ARRAY') {
	    @V = @{ $opt{vertices} };
	} else {
	    Carp::croak("Graph::random_graph: argument 'vertices' illegal");
	}
    } else {
	@V = 0..($opt{vertices} - 1);
    }
    delete $opt{vertices};
    my $V = @V;
    my $C = $V * ($V - 1) / 2;
    my $E;
    if (exists $opt{edges} && exists $opt{edges_fill}) {
	Carp::croak("Graph::random_graph: both arguments 'edges' and 'edges_fill' specified");
    }
    $E = exists $opt{edges_fill} ? $opt{edges_fill} * $C : $opt{edges};
    delete $opt{edges};
    delete $opt{edges_fill};
    my $g = $class->new(%opt);
    $g->add_vertices(@V);
    return $g if $V < 2;
    $C *= 2 if $g->directed;
    $E = $C / 2 unless defined $E;
    $E = int($E + 0.5);
    my $p = $E / $C;
    $random_edge = sub { $p } unless defined $random_edge;
    # print "V = $V, E = $E, C = $C, p = $p\n";
    if ($p > 1.0 && !($g->countedged || $g->multiedged)) {
	require Carp;
	Carp::croak("Graph::random_graph: needs to be countedged or multiedged ($E > $C)");
    }
    my @V1 = @V;
    my @V2 = @V;
    # Shuffle the vertex lists so that the pairs at
    # the beginning of the lists are not more likely.
    @V1 = _shuffle @V1;
    @V2 = _shuffle @V2;
 LOOP:
    while ($E) {
	for my $v1 (@V1) {
	    for my $v2 (@V2) {
		next if $v1 eq $v2; # TODO: allow self-loops?
		my $q = $random_edge->($g, $v1, $v2, $p);
		if ($q && ($q == 1 || rand() <= $q) &&
		    !$g->has_edge($v1, $v2)) {
		    $g->add_edge($v1, $v2);
		    $E--;
		    last LOOP unless $E;
		}
	    }
	}
    }
    return $g;
}

sub random_vertex {
    my $g = shift;
    my @V = $g->vertices05;
    @V[rand @V];
}

sub random_edge {
    my $g = shift;
    my @E = $g->edges05;
    @E[rand @E];
}

sub random_successor {
    my ($g, $v) = @_;
    my @S = $g->successors($v);
    @S[rand @S];
}

sub random_predecessor {
    my ($g, $v) = @_;
    my @P = $g->predecessors($v);
    @P[rand @P];
}

###
# Algorithms.
#

my $MST_comparator = sub { ($_[0] || 0) <=> ($_[1] || 0) };

sub _MST_attr {
    my $attr = shift;
    my $attribute =
	exists $attr->{attribute}  ?
	    $attr->{attribute}  : $defattr;
    my $comparator =
	exists $attr->{comparator} ?
	    $attr->{comparator} : $MST_comparator;
    return ($attribute, $comparator);
}

sub _MST_edges {
    my ($g, $attr) = @_;
    my ($attribute, $comparator) = _MST_attr($attr);
    map { $_->[1] }
        sort { $comparator->($a->[0], $b->[0], $a->[1], $b->[1]) }
             map { [ $g->get_edge_attribute(@$_, $attribute), $_ ] }
                 $g->edges05;
}

sub MST_Kruskal {
    my ($g, %attr) = @_;

    $g->expect_undirected;

    my $MST = Graph::Undirected->new;

    my $UF  = Graph::UnionFind->new;
    for my $v ($g->vertices05) { $UF->add($v) }

    for my $e ($g->_MST_edges(\%attr)) {
	my ($u, $v) = @$e; # TODO: hyperedges
	my $t0 = $UF->find( $u );
	my $t1 = $UF->find( $v );
	unless ($t0 eq $t1) {
	    $UF->union($u, $v);
	    $MST->add_edge($u, $v);
	}
    }

    return $MST;
}