graph.pm

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

                    sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @e
                : @e;
	} else {
	    die "edges02: unimplemented option";
	}
    } else {
	my @e = map { ($_) x $g->get_edge_count(@$_) } $g->edges05( @_ );
	wantarray ?
          map { @$_ }
              sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @e
          : @e;
    }
}

sub unique_edges {
    my $g = shift;
    ($g->is_compat02) ? $g->edges02( @_ ) : $g->edges05( @_ );
}

sub edges {
    my $g = shift;
    if ($g->is_compat02) {
	return $g->edges02( @_ );
    } else {
	if ($g->is_multiedged || $g->is_countedged) {
	    if (wantarray) {
		my @E;
		for my $e ( $g->edges05 ) {
		    push @E, ($e) x $g->get_edge_count(@$e);
		}
		return @E;
	    } else {
		my $E = 0;
		for my $e ( $g->edges05 ) {
		    $E += $g->get_edge_count(@$e);
		}
		return $E;
	    }
	} else {
	    return $g->edges05;
	}
    }
}

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

###
# by_id
#

sub add_vertex_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    $g->[ _V ]->set_path_by_multi_id( @_ );
    $g->[ _G ]++;
    $g->_union_find_add_vertex( @_ ) if $g->has_union_find;
    return $g;
}

sub add_vertex_get_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $id = $g->[ _V ]->set_path_by_multi_id( @_, _GEN_ID );
    $g->[ _G ]++;
    $g->_union_find_add_vertex( @_ ) if $g->has_union_find;
    return $id;
}

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

sub delete_vertex_by_id {
    my $g = shift;
    $g->expect_multivertexed;
    my $V = $g->[ _V ];
    return unless $V->has_path_by_multi_id( @_ );
    # TODO: what to about the edges at this vertex?
    # If the multiness of this vertex goes to zero, delete the edges?
    $V->del_path_by_multi_id( @_ );
    $g->[ _G ]++;
    return $g;
}

sub get_multivertex_ids {
    my $g = shift;
    $g->expect_multivertexed;
    $g->[ _V ]->get_multi_ids( @_ );
}

sub add_edge_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $id = pop;
    my @e = $g->_add_edge( @_ );
    $g->[ _E ]->set_path( @e, $id );
    $g->[ _G ]++;
    $g->_union_find_add_edge( @e ) if $g->has_union_find;
    return $g;
}

sub add_edge_get_id {
    my $g = shift;
    $g->expect_multiedged;
    my @i = $g->_add_edge( @_ );
    my $id = $g->[ _E ]->set_path_by_multi_id( @i, _GEN_ID );
    $g->_union_find_add_edge( @i ) if $g->has_union_find;
    $g->[ _G ]++;
    return $id;
}

sub has_edge_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $id = pop;
    my @i = $g->_vertex_ids( @_ );
    return 0 if @i == 0 && @_;
    $g->[ _E ]->has_path_by_multi_id( @i, $id );
}

sub delete_edge_by_id {
    my $g = shift;
    $g->expect_multiedged;
    my $V = $g->[ _E ];
    my $id = pop;
    my @i = $g->_vertex_ids( @_ );
    return unless $V->has_path_by_multi_id( @i, $id );
    $V->del_path_by_multi_id( @i, $id );
    $g->[ _G ]++;
    return $g;
}

sub get_multiedge_ids {
    my $g = shift;
    $g->expect_multiedged;
    my @id = $g->_vertex_ids( @_ );
    return unless @id;
    $g->[ _E ]->get_multi_ids( @id );
}

###
# Neighbourhood.
#

sub vertices_at {
    my $g = shift;
    my $V = $g->[ _V ];
    return @_ unless ($V->[ _f ] & _HYPER);
    my %v;
    my @i;
    for my $v ( @_ ) {
	my $i = $V->_get_path_id( $v );
	return unless defined $i;
	push @i, ( $v{ $v } = $i );
    }
    my $Vi = $V->_ids;
    my @v;
    while (my ($i, $v) = each %{ $Vi }) {
	my %i;
	my $h = $V->[_f ] & _HYPER;
	@i{ @i } = @i if @i; # @todo: nonuniq hyper vertices?
	for my $u (ref $v eq 'ARRAY' && $h ? @$v : $v) {
	    my $j = exists $v{ $u } ? $v{ $u } : ( $v{ $u } = $i );
	    if (defined $j && exists $i{ $j }) {
		delete $i{ $j };
		unless (keys %i) {
		    push @v, $v;
		    last;
		}
	    }
	}
    }
    return @v;
}

sub _edges_at {
    my $g = shift;
    my $V = $g->[ _V ];
    my $E = $g->[ _E ];
    my @e;
    my $en = 0;
    my %ev;
    my $h = $V->[_f ] & _HYPER;
    for my $v ( $h ? $g->vertices_at( @_ ) : @_ ) {
	my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v );
	next unless defined $vi;
	my $Ei = $E->_ids;
	while (my ($ei, $ev) = each %{ $Ei }) {
	    if (wantarray) {
		for my $j (@$ev) {
		    push @e, [ $ei, $ev ]
			if $j == $vi && !$ev{$ei}++;
		}
	    } else {
		for my $j (@$ev) {
		    $en++ if $j == $vi;
		}
	    }		    
	}
    }
    return wantarray ? @e : $en;
}

sub _edges_from {
    my $g = shift;
    my $V = $g->[ _V ];
    my $E = $g->[ _E ];
    my @e;
    my $o = $E->[ _f ] & _UNORD;
    my $en = 0;
    my %ev;
    my $h = $V->[_f ] & _HYPER;
    for my $v ( $h ? $g->vertices_at( @_ ) : @_ ) {
	my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v );
	next unless defined $vi;
	my $Ei = $E->_ids;
	if (wantarray) {
	    if ($o) {
		while (my ($ei, $ev) = each %{ $Ei }) {
		    next unless @$ev;
		    push @e, [ $ei, $ev ]
			if ($ev->[0] == $vi || $ev->[-1] == $vi) && !$ev{$ei}++;
		}
	    } else {
		while (my ($ei, $ev) = each %{ $Ei }) {
		    next unless @$ev;
		    push @e, [ $ei, $ev ]
			if $ev->[0] == $vi && !$ev{$ei}++;
		}
	    }
	} else {
	    if ($o) {
		while (my ($ei, $ev) = each %{ $Ei }) {
		    next unless @$ev;
		    $en++ if ($ev->[0] == $vi || $ev->[-1] == $vi);
		}
	    } else {
		while (my ($ei, $ev) = each %{ $Ei }) {
		    next unless @$ev;
		    $en++ if $ev->[0] == $vi;
		}
	    }
	}
    }
    if (wantarray && $g->is_undirected) {
	my @i = map { $V->_get_path_id( $_ ) } @_;
	for my $e ( @e ) {
	    unless ( $e->[ 1 ]->[ 0 ] == $i[ 0 ] ) { # @todo
		$e = [ $e->[ 0 ], [ reverse @{ $e->[ 1 ] } ] ];
	    }
	}
    }
    return wantarray ? @e : $en;
}

sub _edges_to {
    my $g = shift;
    my $V = $g->[ _V ];
    my $E = $g->[ _E ];
    my @e;
    my $o = $E->[ _f ] & _UNORD;
    my $en = 0;
    my %ev;
    my $h = $V->[_f ] & _HYPER;
    for my $v ( $h ? $g->vertices_at( @_ ) : @_ ) {
	my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v );
	next unless defined $vi;
	my $Ei = $E->_ids;
	if (wantarray) {
	    if ($o) {
		while (my ($ei, $ev) = each %{ $Ei }) {
		    next unless @$ev;
		    push @e, [ $ei, $ev ]
			if ($ev->[-1] == $vi || $ev->[0] == $vi) && !$ev{$ei}++;
		}
	    } else {
		while (my ($ei, $ev) = each %{ $Ei }) {
		    next unless @$ev;
		    push @e, [ $ei, $ev ]
			if $ev->[-1] == $vi && !$ev{$ei}++;
		}
	    }
	} else {
	    if ($o) {
		while (my ($ei, $ev) = each %{ $Ei }) {
		    next unless @$ev;
		    $en++ if $ev->[-1] == $vi || $ev->[0] == $vi;
		}
	    } else {
		while (my ($ei, $ev) = each %{ $Ei }) {
		    next unless @$ev;
		    $en++ if $ev->[-1] == $vi;
		}
	    }
	}
    }
    if (wantarray && $g->is_undirected) {
	my @i = map { $V->_get_path_id( $_ ) } @_;
	for my $e ( @e ) {
	    unless ( $e->[ 1 ]->[ -1 ] == $i[ -1 ] ) { # @todo
		$e = [ $e->[ 0 ], [ reverse @{ $e->[ 1 ] } ] ];
	    }
	}
    }
    return wantarray ? @e : $en;
}

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

sub edges_at {
    my $g = shift;
    map { $g->_edges_id_path($_ ) } $g->_edges_at( @_ );
}

sub edges_from {
    my $g = shift;
    map { $g->_edges_id_path($_ ) } $g->_edges_from( @_ );
}

sub edges_to {
    my $g = shift;
    map { $g->_edges_id_path($_ ) } $g->_edges_to( @_ );
}

sub successors {
    my $g = shift;
    my $E = $g->[ _E ];
    ($E->[ _f ] & _LIGHT) ?
	$E->_successors($g, @_) :
	Graph::AdjacencyMap::_successors($E, $g, @_);
}

sub predecessors {
    my $g = shift;
    my $E = $g->[ _E ];
    ($E->[ _f ] & _LIGHT) ?
	$E->_predecessors($g, @_) :
	Graph::AdjacencyMap::_predecessors($E, $g, @_);
}

sub neighbours {
    my $g = shift;
    my $V  = $g->[ _V ];
    my @s = map { my @v = @{ $_->[ 1 ] }; shift @v; @v } $g->_edges_from( @_ );
    my @p = map { my @v = @{ $_->[ 1 ] }; pop   @v; @v } $g->_edges_to  ( @_ );
    my %n;
    @n{ @s } = @s;
    @n{ @p } = @p;
    map { $V->_get_id_path($_) } keys %n;
}

*neighbors = \&neighbours;

sub delete_edge {
    my $g = shift;
    my @i = $g->_vertex_ids( @_ );
    return $g unless @i;
    my $i = $g->[ _E ]->_get_path_id( @i );
    return $g unless defined $i;
    $g->[ _E ]->_del_id( $i );
    $g->[ _G ]++;
    return $g;
}

sub delete_vertex {
    my $g = shift;
    my $V = $g->[ _V ];
    return $g unless $V->has_path( @_ );
    my $E = $g->[ _E ];
    for my $e ( $g->_edges_at( @_ ) ) {
	$E->_del_id( $e->[ 0 ] );
    }
    $V->del_path( @_ );
    $g->[ _G ]++;
    return $g;
}

sub get_vertex_count {
    my $g = shift;
    $g->[ _V ]->_get_path_count( @_ ) || 0;
}

sub get_edge_count {
    my $g = shift;
    my @e = $g->_vertex_ids( @_ );
    return 0 unless @e;
    $g->[ _E ]->_get_path_count( @e ) || 0;
}

sub delete_vertices {
    my $g = shift;
    while (@_) {
	my $v = shift @_;
	$g->delete_vertex($v);
    }
    return $g;
}

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

###
# Degrees.
#

sub _in_degree {
    my $g = shift;
    return undef unless @_ && $g->has_vertex( @_ );
    my $in =  $g->is_undirected && $g->is_self_loop_vertex( @_ ) ? 1 : 0;
    $in += $g->get_edge_count( @$_ ) for $g->edges_to( @_ );
    return $in;
}

sub in_degree {
    my $g = shift;
    $g->_in_degree( @_ );
}

sub _out_degree {
    my $g = shift;
    return undef unless @_ && $g->has_vertex( @_ );
    my $out =  $g->is_undirected && $g->is_self_loop_vertex( @_ ) ? 1 : 0;
    $out += $g->get_edge_count( @$_ ) for $g->edges_from( @_ );
    return $out;
}

sub out_degree {
    my $g = shift;
    $g->_out_degree( @_ );
}

sub _total_degree {
    my $g = shift;
    return undef unless @_ && $g->has_vertex( @_ );
    $g->is_undirected ?
	$g->_in_degree( @_ ) :
	$g-> in_degree( @_ ) - $g-> out_degree( @_ );
}

sub degree {
    my $g = shift;
    if (@_) {
	$g->_total_degree( @_ );
    } else {
	if ($g->is_undirected) {
	    my $total = 0;
	    $total += $g->_total_degree( $_ ) for $g->vertices05;
	    return $total;
	} else {
	    return 0;
	}
    }
}

*vertex_degree = \&degree;

sub is_sink_vertex {
    my $g = shift;
    return 0 unless @_;
    $g->successors( @_ ) == 0 && $g->predecessors( @_ ) > 0;
}

sub is_source_vertex {
    my $g = shift;
    return 0 unless @_;
    $g->predecessors( @_ ) == 0 && $g->successors( @_ ) > 0;
}

sub is_successorless_vertex {
    my $g = shift;
    return 0 unless @_;
    $g->successors( @_ ) == 0;
}

sub is_predecessorless_vertex {
    my $g = shift;
    return 0 unless @_;
    $g->predecessors( @_ ) == 0;
}

sub is_successorful_vertex {
    my $g = shift;
    return 0 unless @_;
    $g->successors( @_ ) > 0;
}

sub is_predecessorful_vertex {
    my $g = shift;
    return 0 unless @_;
    $g->predecessors( @_ ) > 0;
}

sub is_isolated_vertex {
    my $g = shift;
    return 0 unless @_;
    $g->predecessors( @_ ) == 0 && $g->successors( @_ ) == 0;
}

sub is_interior_vertex {
    my $g = shift;
    return 0 unless @_;
    my $p = $g->predecessors( @_ );
    my $s = $g->successors( @_ );
    if ($g->is_self_loop_vertex( @_ )) {
	$p--;
	$s--;
    }
    $p > 0 && $s > 0;
}

sub is_exterior_vertex {
    my $g = shift;
    return 0 unless @_;
    $g->predecessors( @_ ) == 0 || $g->successors( @_ ) == 0;
}

sub is_self_loop_vertex {
    my $g = shift;
    return 0 unless @_;
    for my $s ( $g->successors( @_ ) ) {
	return 1 if $s eq $_[0]; # @todo: hypervertices
    }
    return 0;
}

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

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

sub successorless_vertices {
    my $g = shift;