graph.pm

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

sub _MST_add {
    my ($g, $h, $HF, $r, $attr, $unseen) = @_;
    for my $s ( grep { exists $unseen->{ $_ } } $g->successors( $r ) ) {
	$HF->add( Graph::MSTHeapElem->new( $r, $s, $g->get_edge_attribute( $r, $s, $attr ) ) );
    }
}

sub _next_alphabetic { shift; (sort               keys %{ $_[0] })[0] }
sub _next_numeric    { shift; (sort { $a <=> $b } keys %{ $_[0] })[0] }
sub _next_random     { shift; (values %{ $_[0] })[ rand keys %{ $_[0] } ] }

sub _root_opt {
    my $g = shift;
    my %opt = @_ == 1 ? ( first_root => $_[0] ) : _get_options( \@_ );
    my %unseen;
    my @unseen = $g->vertices05;
    @unseen{ @unseen } = @unseen;
    @unseen = _shuffle @unseen;
    my $r;
    if (exists $opt{ start }) {
	$opt{ first_root } = $opt{ start };
	$opt{ next_root  } = undef;
    }
    if (exists $opt{ get_next_root }) {
	$opt{ next_root  } = $opt{ get_next_root }; # Graph 0.201 compat.
    }
    if (exists $opt{ first_root }) {
	if (ref $opt{ first_root } eq 'CODE') {
	    $r = $opt{ first_root }->( $g, \%unseen );
	} else {
	    $r = $opt{ first_root };
	}
    } else {
	$r = shift @unseen;
    }
    my $next =
	exists $opt{ next_root } ?
	    $opt{ next_root } :
		$opt{ next_alphabetic } ?
		    \&_next_alphabetic :
			$opt{ next_numeric } ? \&_next_numeric :
			    \&_next_random;
    my $code = ref $next eq 'CODE';
    my $attr = exists $opt{ attribute } ? $opt{ attribute } : $defattr;
    return ( \%opt, \%unseen, \@unseen, $r, $next, $code, $attr );
}

sub _heap_walk {
    my ($g, $h, $add, $etc) = splice @_, 0, 4; # Leave %opt in @_.

    my ($opt, $unseenh, $unseena, $r, $next, $code, $attr) = $g->_root_opt(@_);
    my $HF = Heap071::Fibonacci->new;

    while (defined $r) {
	# print "r = $r\n";
	$add->($g, $h, $HF, $r, $attr, $unseenh, $etc);
	delete $unseenh->{ $r };
	while (defined $HF->top) {
	    my $t = $HF->extract_top;
	    # use Data::Dumper; print "t = ", Dumper($t);
	    if (defined $t) {
		my ($u, $v, $w) = $t->val;
		# print "extracted top: $u $v $w\n";
		if (exists $unseenh->{ $v }) {
		    $h->set_edge_attribute($u, $v, $attr, $w);
		    delete $unseenh->{ $v };
		    $add->($g, $h, $HF, $v, $attr, $unseenh, $etc);
		}
	    }
	}
	return $h unless defined $next;
	$r = $code ? $next->( $g, $unseenh ) : shift @$unseena;
    }

    return $h;
}

sub MST_Prim {
    my $g = shift;
    $g->expect_undirected;
    $g->_heap_walk(Graph::Undirected->new(), \&_MST_add, undef, @_);
}

*MST_Dijkstra = \&MST_Prim;

*minimum_spanning_tree = \&MST_Prim;

###
# Cycle detection.
#

*is_cyclic = \&has_a_cycle;

sub is_acyclic {
    my $g = shift;
    return !$g->is_cyclic;
}

sub is_dag {
    my $g = shift;
    return $g->is_directed && $g->is_acyclic ? 1 : 0;
}

*is_directed_acyclic_graph = \&is_dag;

###
# Backward compat.
#

sub average_degree {
    my $g = shift;
    my $V = $g->vertices05;

    return $V ? $g->degree / $V : 0;
}

sub density_limits {
    my $g = shift;

    my $V = $g->vertices05;
    my $M = $V * ($V - 1);

    $M /= 2 if $g->is_undirected;

    return ( 0.25 * $M, 0.75 * $M, $M );
}

sub density {
    my $g = shift;
    my ($sparse, $dense, $complete) = $g->density_limits;

    return $complete ? $g->edges / $complete : 0;
}

###
# Attribute backward compat
#

sub _attr02_012 {
    my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5;
    if ($g->is_compat02) {
	if    (@_ == 0) { return $ga->( $g ) }
	elsif (@_ == 1) { return $va->( $g, @_ ) }
	elsif (@_ == 2) { return $ea->( $g, @_ ) }
	else {
	    die sprintf "$op: wrong number of arguments (%d)", scalar @_;
	}
    } else {
	die "$op: not a compat02 graph"
    }
}

sub _attr02_123 {
    my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5;
    if ($g->is_compat02) {
	if    (@_ == 1) { return $ga->( $g, @_ ) }
	elsif (@_ == 2) { return $va->( $g, @_[1, 0] ) }
	elsif (@_ == 3) { return $ea->( $g, @_[1, 2, 0] ) }
	else {
	    die sprintf "$op: wrong number of arguments (%d)", scalar @_;
	}
    } else {
	die "$op: not a compat02 graph"
    }
}

sub _attr02_234 {
    my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5;
    if ($g->is_compat02) {
	if    (@_ == 2) { return $ga->( $g, @_ ) }
	elsif (@_ == 3) { return $va->( $g, @_[1, 0, 2] ) }
	elsif (@_ == 4) { return $ea->( $g, @_[1, 2, 0, 3] ) }
	else {
	    die sprintf "$op: wrong number of arguments (%d)", scalar @_;
	}
    } else {
	die "$op: not a compat02 graph";
    }
}

sub set_attribute {
    my $g = shift;
    $g->_attr02_234('set_attribute',
		    \&Graph::set_graph_attribute,
		    \&Graph::set_vertex_attribute,
		    \&Graph::set_edge_attribute,
		    @_);

}

sub set_attributes {
    my $g = shift;
    my $a = pop;
    $g->_attr02_123('set_attributes',
		    \&Graph::set_graph_attributes,
		    \&Graph::set_vertex_attributes,
		    \&Graph::set_edge_attributes,
		    $a, @_);

}

sub get_attribute {
    my $g = shift;
    $g->_attr02_123('get_attribute',
		    \&Graph::get_graph_attribute,
		    \&Graph::get_vertex_attribute,
		    \&Graph::get_edge_attribute,
		    @_);

}

sub get_attributes {
    my $g = shift;
    $g->_attr02_012('get_attributes',
		    \&Graph::get_graph_attributes,
		    \&Graph::get_vertex_attributes,
		    \&Graph::get_edge_attributes,
		    @_);

}

sub has_attribute {
    my $g = shift;
    return 0 unless @_;
    $g->_attr02_123('has_attribute',
		    \&Graph::has_graph_attribute,
		    \&Graph::has_vertex_attribute,
		    \&Graph::get_edge_attribute,
		    @_);

}

sub has_attributes {
    my $g = shift;
    $g->_attr02_012('has_attributes',
		    \&Graph::has_graph_attributes,
		    \&Graph::has_vertex_attributes,
		    \&Graph::has_edge_attributes,
		    @_);

}

sub delete_attribute {
    my $g = shift;
    $g->_attr02_123('delete_attribute',
		    \&Graph::delete_graph_attribute,
		    \&Graph::delete_vertex_attribute,
		    \&Graph::delete_edge_attribute,
		    @_);

}

sub delete_attributes {
    my $g = shift;
    $g->_attr02_012('delete_attributes',
		    \&Graph::delete_graph_attributes,
		    \&Graph::delete_vertex_attributes,
		    \&Graph::delete_edge_attributes,
		    @_);

}

###
# Simple DFS uses.
#

sub topological_sort {
    my $g = shift;
    my %opt = _get_options( \@_ );
    my $eic = $opt{ empty_if_cyclic };
    my $hac;
    if ($eic) {
	$hac = $g->has_a_cycle;
    } else {
	$g->expect_dag;
    }
    delete $opt{ empty_if_cyclic };
    my $t = Graph::Traversal::DFS->new($g, %opt);
    my @s = $t->dfs;
    $hac ? () : reverse @s;
}

*toposort = \&topological_sort;

sub undirected_copy {
    my $g = shift;

    $g->expect_directed;

    my $c = Graph::Undirected->new;
    for my $v ($g->isolated_vertices) { # TODO: if iv ...
	$c->add_vertex($v);
    }
    for my $e ($g->edges05) {
	$c->add_edge(@$e);
    }
    return $c;
}

*undirected_copy_graph = \&undirected_copy;

sub directed_copy {
    my $g = shift;
    $g->expect_undirected;
    my $c = Graph::Directed->new;
    for my $v ($g->isolated_vertices) { # TODO: if iv ...
	$c->add_vertex($v);
    }
    for my $e ($g->edges05) {
	my @e = @$e;
	$c->add_edge(@e);
	$c->add_edge(reverse @e);
    }
    return $c;
}

*directed_copy_graph = \&directed_copy;

###
# Cache or not.
#

my %_cache_type =
    (
     'connectivity'        => '_ccc',
     'strong_connectivity' => '_scc',
     'biconnectivity'      => '_bcc',
     'SPT_Dijkstra'        => '_spt_di',
     'SPT_Bellman_Ford'    => '_spt_bf',
    );

sub _check_cache {
    my ($g, $type, $code) = splice @_, 0, 3;
    my $c = $_cache_type{$type};
    if (defined $c) {
	my $a = $g->get_graph_attribute($c);
	unless (defined $a && $a->[ 0 ] == $g->[ _G ]) {
	    $a->[ 0 ] = $g->[ _G ];
	    $a->[ 1 ] = $code->( $g, @_ );
	    $g->set_graph_attribute($c, $a);
	}
	return $a->[ 1 ];
    } else {
	Carp::croak("Graph: unknown cache type '$type'");
    }
}

sub _clear_cache {
    my ($g, $type) = @_;
    my $c = $_cache_type{$type};
    if (defined $c) {
	$g->delete_graph_attribute($c);
    } else {
	Carp::croak("Graph: unknown cache type '$type'");
    }
}

sub connectivity_clear_cache {
    my $g = shift;
    _clear_cache($g, 'connectivity');
}

sub strong_connectivity_clear_cache {
    my $g = shift;
    _clear_cache($g, 'strong_connectivity');
}

sub biconnectivity_clear_cache {
    my $g = shift;
    _clear_cache($g, 'biconnectivity');
}

sub SPT_Dijkstra_clear_cache {
    my $g = shift;
    _clear_cache($g, 'SPT_Dijkstra');
    $g->delete_graph_attribute('SPT_Dijkstra_first_root');
}

sub SPT_Bellman_Ford_clear_cache {
    my $g = shift;
    _clear_cache($g, 'SPT_Bellman_Ford');
}

###
# Connected components.
#

sub _connected_components_compute {
    my $g = shift;
    my %cce;
    my %cci;
    my $cc = 0;
    if ($g->has_union_find) {
	my $UF = $g->_get_union_find();
	my $V  = $g->[ _V ];
	my %icce; # Isolated vertices.
	my %icci;
	my $icc = 0;
	for my $v ( $g->unique_vertices ) {
	    $cc = $UF->find( $V->_get_path_id( $v ) );
	    if (defined $cc) {
		$cce{ $v } = $cc;
		push @{ $cci{ $cc } }, $v;
	    } else {
		$icce{ $v } = $icc;
		push @{ $icci{ $icc } }, $v;
		$icc++;
	    }
	}
	if ($icc) {
	    @cce{ keys %icce } = values %icce;
	    @cci{ keys %icci } = values %icci;
	}
    } else {
	my @u = $g->unique_vertices;
	my %r; @r{ @u } = @u;
	my $froot = sub {
	    (each %r)[1];
	};
	my $nroot = sub {
	    $cc++ if keys %r;
	    (each %r)[1];
	};
	my $t = Graph::Traversal::DFS->new($g,
					   first_root => $froot,
					   next_root  => $nroot,
					   pre => sub {
					       my ($v, $t) = @_;
					       $cce{ $v } = $cc;
					       push @{ $cci{ $cc } }, $v;
					       delete $r{ $v };
					   },
					   @_);
	$t->dfs;
    }
    return [ \%cce, \%cci ];
}

sub _connected_components {
    my $g = shift;
    my $ccc = _check_cache($g, 'connectivity',
			   \&_connected_components_compute, @_);
    return @{ $ccc };
}

sub connected_component_by_vertex {
    my ($g, $v) = @_;
    $g->expect_undirected;
    my ($CCE, $CCI) = $g->_connected_components();
    return $CCE->{ $v };
}

sub connected_component_by_index {
    my ($g, $i) = @_;
    $g->expect_undirected;
    my ($CCE, $CCI) = $g->_connected_components();
    return defined $CCI->{ $i } ? @{ $CCI->{ $i } } : ( );
}

sub connected_components {
    my $g = shift;
    $g->expect_undirected;
    my ($CCE, $CCI) = $g->_connected_components();
    return values %{ $CCI };
}

sub same_connected_components {
    my $g = shift;
    $g->expect_undirected;
    if ($g->has_union_find) {
	my $UF = $g->_get_union_find();
	my $V  = $g->[ _V ];
	my $u = shift;
	my $c = $UF->find( $V->_get_path_id ( $u ) );
	my $d;
	for my $v ( @_) {
	    return 0
		unless defined($d = $UF->find( $V->_get_path_id( $v ) )) &&
		       $d eq $c;
	}
	return 1;
    } else {
	my ($CCE, $CCI) = $g->_connected_components();
	my $u = shift;
	my $c = $CCE->{ $u };
	for my $v ( @_) {
	    return 0
		unless defined $CCE->{ $v } &&
		       $CCE->{ $v } eq $c;
	}
	return 1;
    }
}

my $super_component = sub { join("+", sort @_) };

sub connected_graph {
    my ($g, %opt) = @_;
    $g->expect_undirected;
    my $cg = Graph->new(undirected => 1);
    if ($g->has_union_find && $g->vertices == 1) {
	# TODO: super_component?
	$cg->add_vertices($g->vertices);
    } else {
	my $sc_cb =
	    exists $opt{super_component} ?
		$opt{super_component} : $super_component;
	for my $cc ( $g->connected_components() ) {
	    my $sc = $sc_cb->(@$cc);
	    $cg->add_vertex($sc);
	    $cg->set_vertex_attribute($sc, 'subvertices', [ @$cc ]);
	}
    }
    return $cg;
}

sub is_connected {
    my $g = shift;
    $g->expect_undirected;
    my ($CCE, $CCI) = $g->_connected_components();
    return keys %{ $CCI } == 1;
}

sub is_weakly_connected {
    my $g = shift;
    $g->expect_directed;
    $g->undirected_copy->is_connected(@_);
}

*weakly_connected = \&is_weakly_connected;

sub weakly_connected_components {
    my $g = shift;
    $g->expect_directed;
    $g->undirected_copy->connected_components(@_);
}

sub weakly_connected_component_by_vertex {
    my $g = shift;
    $g->expect_directed;
    $g->undirected_copy->connected_component_by_vertex(@_);
}

sub weakly_connected_component_by_index {
    my $g = shift;
    $g->expect_directed;
    $g->undirected_copy->connected_component_by_index(@_);
}

sub same_weakly_connected_components {
    my $g