graph.pm

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

package Graph;

use strict;

BEGIN {
    if (0) { # SET THIS TO ZERO FOR TESTING AND RELEASES!
	$SIG{__DIE__ } = \&__carp_confess;
	$SIG{__WARN__} = \&__carp_confess;
    }
    sub __carp_confess { require Carp; Carp::confess(@_) }
}

use Graph::AdjacencyMap qw(:flags :fields);

use vars qw($VERSION);

$VERSION = '0.84';

require 5.006; # Weak references are absolutely required.

use Graph::AdjacencyMap::Heavy;
use Graph::AdjacencyMap::Light;
use Graph::AdjacencyMap::Vertex;
use Graph::UnionFind;
use Graph::TransitiveClosure;
use Graph::Traversal::DFS;
use Graph::MSTHeapElem;
use Graph::SPTHeapElem;
use Graph::Undirected;

use Heap071::Fibonacci;
use List::Util qw(shuffle first);
use Scalar::Util qw(weaken);

sub _F () { 0 } # Flags.
sub _G () { 1 } # Generation.
sub _V () { 2 } # Vertices.
sub _E () { 3 } # Edges.
sub _A () { 4 } # Attributes.
sub _U () { 5 } # Union-Find.

my $Inf;

BEGIN {
    local $SIG{FPE}; 
    eval { $Inf = exp(999) } ||
	eval { $Inf = 9**9**9 } ||
	    eval { $Inf = 1e+999 } ||
		{ $Inf = 1e+99 };  # Close enough for most practical purposes.
}

sub Infinity () { $Inf }

# Graphs are blessed array references.
# - The first element contains the flags.
# - The second element is the vertices.
# - The third element is the edges.
# - The fourth element is the attributes of the whole graph.
# The defined flags for Graph are:
# - _COMPAT02 for user API compatibility with the Graph 0.20xxx series.
# The vertices are contained in either a "simplemap"
# (if no hypervertices) or in a "map".
# The edges are always in a "map".
# The defined flags for maps are:
# - _COUNT for countedness: more than one instance
# - _HYPER for hyperness: a different number of "coordinates" than usual;
#   expects one for vertices and two for edges
# - _UNORD for unordered coordinates (a set): if _UNORD is not set
#   the coordinates are assumed to be meaningfully ordered
# - _UNIQ for unique coordinates: if set duplicates are removed,
#   if not, duplicates are assumed to meaningful
# - _UNORDUNIQ: just a union of _UNORD and UNIQ
# Vertices are assumed to be _UNORDUNIQ; edges assume none of these flags.

use Graph::Attribute array => _A, map => 'graph';

sub _COMPAT02 () { 0x00000001 }

sub stringify {
    my $g = shift;
    my $o = $g->is_undirected;
    my $e = $o ? '=' : '-';
    my @e =
	map {
	    my @v =
		map {
		    ref($_) eq 'ARRAY' ? "[" . join(" ", @$_) . "]" : "$_"
		}
	    @$_;
	    join($e, $o ? sort { "$a" cmp "$b" } @v : @v) } $g->edges05;
    my @s = sort { "$a" cmp "$b" } @e;
    push @s, sort { "$a" cmp "$b" } $g->isolated_vertices;
    join(",", @s);
}

sub eq {
    "$_[0]" eq "$_[1]"
}

sub ne {
    "$_[0]" ne "$_[1]"
}

use overload
    '""' => \&stringify,
    'eq' => \&eq,
    'ne' => \≠

sub _opt {
    my ($opt, $flags, %flags) = @_;
    while (my ($flag, $FLAG) = each %flags) {
	if (exists $opt->{$flag}) {
	    $$flags |= $FLAG if $opt->{$flag};
	    delete $opt->{$flag};
	}
	if (exists $opt->{my $non = "non$flag"}) {
	    $$flags &= ~$FLAG if $opt->{$non};
	    delete $opt->{$non};
	}
    }
}

sub is_compat02 {
    my ($g) = @_;
    $g->[ _F ] & _COMPAT02;
}

*compat02 = \&is_compat02;

sub has_union_find {
    my ($g) = @_;
    ($g->[ _F ] & _UNIONFIND) && defined $g->[ _U ];
}

sub _get_union_find {
    my ($g) = @_;
    $g->[ _U ];
}

sub _opt_get {
    my ($opt, $key, $var) = @_;
    if (exists $opt->{$key}) {
	$$var = $opt->{$key};
	delete $opt->{$key};
    }
}

sub _opt_unknown {
    my ($opt) = @_;
    if (my @opt = keys %$opt) {
	my $f = (caller(1))[3];
	require Carp;
	Carp::confess(sprintf
		      "$f: Unknown option%s: @{[map { qq['$_'] } sort @opt]}",
		      @opt > 1 ? 's' : '');
    }
}

sub new {
    my $class = shift;
    my $gflags = 0;
    my $vflags;
    my $eflags;
    my %opt = _get_options( \@_ );

    if (ref $class && $class->isa('Graph')) {
	no strict 'refs';
        for my $c (qw(undirected refvertexed compat02
                      hypervertexed countvertexed multivertexed
                      hyperedged countedged multiedged omniedged)) {
#            $opt{$c}++ if $class->$c; # 5.00504-incompatible
	    if (&{"Graph::$c"}($class)) { $opt{$c}++ }
        }
#        $opt{unionfind}++ if $class->has_union_find; # 5.00504-incompatible
	if (&{"Graph::has_union_find"}($class)) { $opt{unionfind}++ }
    }

    _opt_get(\%opt, undirected   => \$opt{omniedged});
    _opt_get(\%opt, omnidirected => \$opt{omniedged});

    if (exists $opt{directed}) {
	$opt{omniedged} = !$opt{directed};
	delete $opt{directed};
    }

    my $vnonomni =
	$opt{nonomnivertexed} ||
	    (exists $opt{omnivertexed} && !$opt{omnivertexed});
    my $vnonuniq =
	$opt{nonuniqvertexed} ||
	    (exists $opt{uniqvertexed} && !$opt{uniqvertexed});

    _opt(\%opt, \$vflags,
	 countvertexed	=> _COUNT,
	 multivertexed	=> _MULTI,
	 hypervertexed	=> _HYPER,
	 omnivertexed	=> _UNORD,
	 uniqvertexed	=> _UNIQ,
	 refvertexed	=> _REF,
	);

    _opt(\%opt, \$eflags,
	 countedged	=> _COUNT,
	 multiedged	=> _MULTI,
	 hyperedged	=> _HYPER,
	 omniedged	=> _UNORD,
	 uniqedged	=> _UNIQ,
	);

    _opt(\%opt, \$gflags,
	 compat02      => _COMPAT02,
	 unionfind     => _UNIONFIND,
	);

    if (exists $opt{vertices_unsorted}) { # Graph 0.20103 compat.
	my $unsorted = $opt{vertices_unsorted};
	delete $opt{vertices_unsorted};
	require Carp;
	Carp::confess("Graph: vertices_unsorted must be true")
	    unless $unsorted;
    }

    my @V;
    if ($opt{vertices}) {
	require Carp;
	Carp::confess("Graph: vertices should be an array ref")
	    unless ref $opt{vertices} eq 'ARRAY';
	@V = @{ $opt{vertices} };
	delete $opt{vertices};
    }

    my @E;
    if ($opt{edges}) {
	unless (ref $opt{edges} eq 'ARRAY') {
	    require Carp;
	    Carp::confess("Graph: edges should be an array ref of array refs");
	}
	@E = @{ $opt{edges} };
	delete $opt{edges};
    }

    _opt_unknown(\%opt);

    my $uflags;
    if (defined $vflags) {
	$uflags = $vflags;
	$uflags |= _UNORD unless $vnonomni;
	$uflags |= _UNIQ  unless $vnonuniq;
    } else {
	$uflags = _UNORDUNIQ;
	$vflags = 0;
    }

    if (!($vflags & _HYPER) && ($vflags & _UNORDUNIQ)) {
	my @but;
	push @but, 'unordered' if ($vflags & _UNORD);
	push @but, 'unique'    if ($vflags & _UNIQ);
	require Carp;
	Carp::confess(sprintf "Graph: not hypervertexed but %s",
		      join(' and ', @but));
    }

    unless (defined $eflags) {
	$eflags = ($gflags & _COMPAT02) ? _COUNT : 0;
    }

    if (!($vflags & _HYPER) && ($vflags & _UNIQ)) {
	require Carp;
	Carp::confess("Graph: not hypervertexed but uniqvertexed");
    }

    if (($vflags & _COUNT) && ($vflags & _MULTI)) {
	require Carp;
	Carp::confess("Graph: both countvertexed and multivertexed");
    }

    if (($eflags & _COUNT) && ($eflags & _MULTI)) {
	require Carp;
	Carp::confess("Graph: both countedged and multiedged");
    }

    my $g = bless [ ], ref $class || $class;

    $g->[ _F ] = $gflags;
    $g->[ _G ] = 0;
    $g->[ _V ] = ($vflags & (_HYPER | _MULTI)) ?
	Graph::AdjacencyMap::Heavy->_new($uflags, 1) :
	    (($vflags & ~_UNORD) ?
	     Graph::AdjacencyMap::Vertex->_new($uflags, 1) :
	     Graph::AdjacencyMap::Light->_new($g, $uflags, 1));
    $g->[ _E ] = (($vflags & _HYPER) || ($eflags & ~_UNORD)) ?
	Graph::AdjacencyMap::Heavy->_new($eflags, 2) :
	    Graph::AdjacencyMap::Light->_new($g, $eflags, 2);

    $g->add_vertices(@V) if @V;

    if (@E) {
	for my $e (@E) {
	    unless (ref $e eq 'ARRAY') {
		require Carp;
		Carp::confess("Graph: edges should be array refs");
	    }
	    $g->add_edge(@$e);
	}
    }

    if (($gflags & _UNIONFIND)) {
	$g->[ _U ] = Graph::UnionFind->new;
    }

    return $g;
}

sub countvertexed { $_[0]->[ _V ]->_is_COUNT }
sub multivertexed { $_[0]->[ _V ]->_is_MULTI }
sub hypervertexed { $_[0]->[ _V ]->_is_HYPER }
sub omnivertexed  { $_[0]->[ _V ]->_is_UNORD }
sub uniqvertexed  { $_[0]->[ _V ]->_is_UNIQ  }
sub refvertexed   { $_[0]->[ _V ]->_is_REF   }

sub countedged    { $_[0]->[ _E ]->_is_COUNT }
sub multiedged    { $_[0]->[ _E ]->_is_MULTI }
sub hyperedged    { $_[0]->[ _E ]->_is_HYPER }
sub omniedged     { $_[0]->[ _E ]->_is_UNORD }
sub uniqedged     { $_[0]->[ _E ]->_is_UNIQ  }

*undirected   = \&omniedged;
*omnidirected = \&omniedged;
sub directed { ! $_[0]->[ _E ]->_is_UNORD }

*is_directed      = \&directed;
*is_undirected    = \&undirected;

*is_countvertexed = \&countvertexed;
*is_multivertexed = \&multivertexed;
*is_hypervertexed = \&hypervertexed;
*is_omnidirected  = \&omnidirected;
*is_uniqvertexed  = \&uniqvertexed;
*is_refvertexed   = \&refvertexed;

*is_countedged    = \&countedged;
*is_multiedged    = \&multiedged;
*is_hyperedged    = \&hyperedged;
*is_omniedged     = \&omniedged;
*is_uniqedged     = \&uniqedged;

sub _union_find_add_vertex {
    my ($g, $v) = @_;
    my $UF = $g->[ _U ];
    $UF->add( $g->[ _V ]->_get_path_id( $v ) );
}

sub add_vertex {
    my $g = shift;
    if ($g->is_multivertexed) {
	return $g->add_vertex_by_id(@_, _GEN_ID);
    }
    my @r;
    if (@_ > 1) {
	unless ($g->is_countvertexed || $g->is_hypervertexed) {
	    require Carp;
	    Carp::croak("Graph::add_vertex: use add_vertices for more than one vertex or use hypervertexed");
	}
	for my $v ( @_ ) {
	    if (defined $v) {
		$g->[ _V ]->set_path( $v ) unless $g->has_vertex( $v );
	    } else {
		require Carp;
		Carp::croak("Graph::add_vertex: undef vertex");
	    }
	}
    }
    for my $v ( @_ ) {
	unless (defined $v) {
	    require Carp;
	    Carp::croak("Graph::add_vertex: undef vertex");
	}
    }
    $g->[ _V ]->set_path( @_ );
    $g->[ _G ]++;
    $g->_union_find_add_vertex( @_ ) if $g->has_union_find;
    return $g;
}

sub has_vertex {
    my $g = shift;
    my $V = $g->[ _V ];
    return exists $V->[ _s ]->{ $_[0] } if ($V->[ _f ] & _LIGHT);
    $V->has_path( @_ );
}

sub vertices05 {
    my $g = shift;
    my @v = $g->[ _V ]->paths( @_ );
    if (wantarray) {
	return $g->[ _V ]->_is_HYPER ?
	    @v : map { ref $_ eq 'ARRAY' ? @$_ : $_ } @v;
    } else {
	return scalar @v;
    }
}

sub vertices {
    my $g = shift;
    my @v = $g->vertices05;
    if ($g->is_compat02) {
        wantarray ? sort @v : scalar @v;
    } else {
	if ($g->is_multivertexed || $g->is_countvertexed) {
	    if (wantarray) {
		my @V;
		for my $v ( @v ) {
		    push @V, ($v) x $g->get_vertex_count($v);
		}
		return @V;
	    } else {
		my $V = 0;
		for my $v ( @v ) {
		    $V += $g->get_vertex_count($v);
		}
		return $V;
	    }
	} else {
	    return @v;
	}
    }
}

*vertices_unsorted = \&vertices_unsorted; # Graph 0.20103 compat.

sub unique_vertices {
    my $g = shift;
    my @v = $g->vertices05;
    if ($g->is_compat02) {
        wantarray ? sort @v : scalar @v;
    } else {
	return @v;
    }
}

sub has_vertices {
    my $g = shift;
    scalar $g->[ _V ]->has_paths( @_ );
}

sub _add_edge {
    my $g = shift;
    my $V = $g->[ _V ];
    my @e;
    if (($V->[ _f ]) & _LIGHT) {
	for my $v ( @_ ) {
	    $g->add_vertex( $v ) unless exists $V->[ _s ]->{ $v };
	    push @e, $V->[ _s ]->{ $v };
	}
    } else {
	my $h = $g->[ _V ]->_is_HYPER;
	for my $v ( @_ ) {
	    my @v = ref $v eq 'ARRAY' && $h ? @$v : $v;
	    $g->add_vertex( @v ) unless $V->has_path( @v );
	    push @e, $V->_get_path_id( @v );
	}
    }
    return @e;
}

sub _union_find_add_edge {
    my ($g, $u, $v) = @_;
    $g->[ _U ]->union($u, $v);
}

sub add_edge {
    my $g = shift;
    if ($g->is_multiedged) {
	unless (@_ == 2 || $g->is_hyperedged) {
	    require Carp;
	    Carp::croak("Graph::add_edge: use add_edges for more than one edge");
	}
	return $g->add_edge_by_id(@_, _GEN_ID);
    }
    unless (@_ == 2) {
	unless ($g->is_hyperedged) {
	    require Carp;
	    Carp::croak("Graph::add_edge: graph is not hyperedged");
	}
    }
    my @e = $g->_add_edge( @_ );
    $g->[ _E ]->set_path( @e );
    $g->[ _G ]++;
    $g->_union_find_add_edge( @e ) if $g->has_union_find;
    return $g;
}

sub _vertex_ids {
    my $g = shift;
    my $V = $g->[ _V ];
    my @e;
    if (($V->[ _f ] & _LIGHT)) {
	for my $v ( @_ ) {
	    return () unless exists $V->[ _s ]->{ $v };
	    push @e, $V->[ _s ]->{ $v };
	}
    } else {
	my $h = $g->[ _V ]->_is_HYPER;
	for my $v ( @_ ) {
	    my @v = ref $v eq 'ARRAY' && $h ? @$v : $v;
	    return () unless $V->has_path( @v );
	    push @e, $V->_get_path_id( @v );
	}
    }
    return @e;
}

sub has_edge {
    my $g = shift;
    my $E = $g->[ _E ];
    my $V = $g->[ _V ];
    my @i;
    if (($V->[ _f ] & _LIGHT) && @_ == 2) {
	return 0 unless
	    exists $V->[ _s ]->{ $_[0] } &&
	    exists $V->[ _s ]->{ $_[1] };
	@i = @{ $V->[ _s ] }{ @_[ 0, 1 ] };
    } else {
	@i = $g->_vertex_ids( @_ );
	return 0 if @i == 0 && @_;
    }
    my $f = $E->[ _f ];
    if ($E->[ _a ] == 2 && @i == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
	@i = sort @i if ($f & _UNORD);
	return exists $E->[ _s ]->{ $i[0] } &&
	       exists $E->[ _s ]->{ $i[0] }->{ $i[1] } ? 1 : 0;
    } else {
	return defined $E->_get_path_id( @i ) ? 1 : 0;
    }
}

sub edges05 {
    my $g = shift;
    my $V = $g->[ _V ];
    my @e = $g->[ _E ]->paths( @_ );
    wantarray ?
	map { [ map { my @v = $V->_get_id_path($_);
		      @v == 1 ? $v[0] : [ @v ] }
		@$_ ] }
            @e : @e;
}

sub edges02 {
    my $g = shift;
    if (@_ && defined $_[0]) {
	unless (defined $_[1]) {
	    my @e = $g->edges_at($_[0]);
	    wantarray ?
		map { @$_ }