File Coverage

blib/lib/Graph/AdjacencyMap.pm

Criterion	Covered	Total	%
statement	286	288	99.3
branch	174	190	91.5
condition	71	81	87.6
subroutine	58	58	100.0
pod	19	19	100.0
total	608	636	95.6

package Graph::AdjacencyMap;

use strict;
use warnings;

# $SIG{__DIE__ } = \&Graph::__carp_confess;
# $SIG{__WARN__} = \&Graph::__carp_confess;

my $empty = {};
sub _empty () { $empty }

my (@FLAGS, %FLAG_COMBOS, %FLAG2I, @FIELDS);
BEGIN {
    @FLAGS = qw(_COUNT _MULTI _UNORD _REF _UNIONFIND _LIGHT _STR);
    %FLAG_COMBOS = (
	_COUNTMULTI => [qw(_COUNT _MULTI)],
	_REFSTR => [qw(_REF _STR)],
    );
    # Next id, Flags, Arity, Index to path, path to index,
    # successors, predecessors: 2-level hashes to array-ref of path IDs
    # attributes - two-level for MULTI, node/multi count
    @FIELDS = qw(_n _f _arity _i _pi _s _p _attr _count);
    for my $i (0..$#FLAGS) {
	my $n = $FLAGS[$i];
	my $f = 1 << $i;
	$FLAG2I{$n} = $f;
	no strict 'refs';
	*$n = sub () { $f };
	*{"_is$n"} = sub { $_[0]->[ 1 ] & $f }; # 1 = _f
    }
    for my $k (keys %FLAG_COMBOS) {
	my $f = 0;
	$f |= $_ for map $FLAG2I{$_}, @{ $FLAG_COMBOS{$k} };
	no strict 'refs';
	*$k = sub () { return $f }; # return to dodge pointless 5.22 stricture
	*{"_is$k"} = sub { $_[0]->[ 1 ] & $f }; # 1 = _f
    }
    for my $i (0..$#FIELDS) {
	no strict 'refs';
	*{ $FIELDS[$i] }= sub () { $i };
    }
}

sub _new {
    my ($class, $flags, $arity) = @_;
    my $hyper = !$arity;
    my $need_s = $arity != 1;
    my $need_p = $need_s && !($flags & _UNORD);
    bless [
	0, $flags, $arity, [], {},
	($need_s ? {} : undef), ($need_p ? {} : undef),
	[], [],
    ], $class;
}

require Exporter;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter);
%EXPORT_TAGS =
    (flags =>  [@FLAGS, keys %FLAG_COMBOS, qw(_GEN_ID)],
     fields => \@FIELDS);
@EXPORT_OK = map @$_, values %EXPORT_TAGS;

my $_GEN_ID = 0;

sub _GEN_ID () { \$_GEN_ID }

sub stringify {
    my ($f, $arity, $m) = (@{ $_[0] }[ _f, _arity ], $_[0]);
    my ($multi, @rows) = $f & _MULTI;
    my @p = $m->paths;
    @p = $arity == 1 ? sort @p :
	map $_->[0], sort { $a->[1] cmp $b->[1] }
	    ($arity == 0 && !($f & _UNORD))
		? map [$_, join '|', map "@$_", @$_], @p
		: map [$_,"@$_"], @p; # use the Schwartz
    if ($arity == 2) {
	require Set::Object;
	my ($pre, $suc, @s) = (Set::Object->new(map $_->[0], @p), Set::Object->new(map $_->[1], @p));
	@rows = ([ 'to:', @s = sort $suc->members ], map {
	    my $p = $_;
	    [ $p, map {
		my $text = defined(my $id = $m->has_path([$p, $_])) ? 1 : '';
		my $attrs = !$text ? undef :
		    $multi ? $m->[ _attr ][$id] : $m->_get_path_attrs([$p, $_]);
		defined $attrs ? $m->_dumper($attrs) : $text;
	    } @s ];
	} sort $pre->members);
    } else {
	@rows = map {
	    my $attrs = $multi
		? $m->[ _attr ][ $m->has_path($_) ] : $m->_get_path_attrs($_);
	    [ $m->_dumper($_),
		($m->get_ids_by_paths([ $_ ], 0))[0].
		    (!defined $attrs ? '' : ",".$m->_dumper($attrs)) ];
	} @p;
    }
    join '',
	map "$_\n",
	"@{[ref $m]} arity=$arity flags: @{[_stringify_fields($m->[ _f ])]}",
	map join(' ', map sprintf('%4s', $_), @$_),
	@rows;
}

sub _stringify_fields {
    return '0' if !$_[0];
    join '|', grep $_[0] & $FLAG2I{$_}, @FLAGS;
}

sub _dumper {
    my (undef, $got) = @_;
    return $got if defined $got and !ref $got;
    require Data::Dumper;
    my $dumper = Data::Dumper->new([$got]);
    $dumper->Indent(0)->Terse(1);
    $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
    $dumper->Dump;
}

sub has_any_paths {
    scalar keys %{ $_[0]->[ _pi ] };
}

sub _set_path_attr_common {
    push @_, 0;
    my ($i) = &__set_path;
    my $attr = (my $m = $_[0])->[ _attr ];
    ($m->[ _f ] & _MULTI) ? \$attr->[ $i ]{ $_[2] } : \$attr->[ $i ];
}

sub _set_path_attrs {
    ${ &{ $_[0]->can('_set_path_attr_common') } } = $_[-1];
}

sub _set_path_attr {
    ${ &{ $_[0]->can('_set_path_attr_common') } }->{ $_[-2] } = $_[-1];
}

sub set_paths {
    map +($_[0]->__set_path($_, 1))[0], @_[1..$#_];
}

sub set_path_by_multi_id {
    push @_, 1;
    goto &__set_path;
}

sub __set_path {
    my $inc_if_exists = pop;
    &__arg;
    my ($f, $a, $map_i, $pi, $map_s, $map_p, $m, $k, $id) = (@{ $_[0] }[ _f, _arity, _i, _pi, _s, _p ], @_);
    my $is_multi = $f & _MULTI;
    my $k_orig = $k;
    $k = __strval($k, $f) if $a == 1 && ($f & _REF) && ref($k);
    my $l = ($a == 0 && !($f & _UNORD)) ? join '|', map join(' ', sort @$_), @$k : $a == 1 ? "$k" : "@$k";
    if (exists $pi->{ $l }) {
	return ($pi->{ $l }) if !($inc_if_exists and ($f & _COUNTMULTI));
	my $nc = \$m->[ _count ][ my $i = $pi->{ $l } ];
	$$nc++, return ($i) if !$is_multi;
	my $na = $m->[ _attr ][ $i ];
	if ($id eq _GEN_ID) {
	    $$nc++ while exists $na->{ $$nc };
	    $id = $$nc;
	}
	$na->{ $id } = { };
	return ($i, $id);
    }
    $map_i->[ $pi->{ $l } = my $i = $m->[ _n ]++ ] = $k_orig;
    $m->[ _attr ][ $i ] = { ($id = ($id eq _GEN_ID) ? 0 : $id) => {} } if $is_multi;
    $m->[ _count ][ $i ] = $is_multi ? 0 : 1 if ($f & _COUNTMULTI);
    _successors_add($f, $a, $map_s, $map_p, $i, $k) if $map_s; # dereffed
    ($i, $id);
}

sub _successors_add {
    my ($f, $a, $map_s, $map_p, $id, $path) = @_;
    my $pairs = _successors_cartesian(($f & _UNORD), $a == 0, $path);
    push @{ $map_s->{ $_->[0] }{ $_->[1] } }, $id for @$pairs;
    return if !$map_p;
    push @{ $map_p->{ $_->[1] }{ $_->[0] } }, $id for @$pairs;
}

sub _successors_del {
    my ($f, $a, $map_s, $map_p, $id, $path) = @_;
    my $pairs = _successors_cartesian(($f & _UNORD), $a == 0, $path);
    for (@$pairs) {
	my ($p, $s) = @$_;
	my @new = grep $_ != $id, @{ $map_s->{ $p }{ $s } };
	if (@new) {
	    $map_s->{ $p }{ $s } = \@new;
	    $map_p->{ $s }{ $p } = \@new if $map_p;
	    next;
	}
	delete $map_s->{ $p }{ $s };
	delete $map_s->{ $p } if !keys %{ $map_s->{ $p } };
	next if !$map_p;
	delete $map_p->{ $s }{ $p };
	delete $map_p->{ $s } if !keys %{ $map_p->{ $s } };
    }
}

sub _successors_cartesian {
    my ($unord, $hyper, $seq) = @_;
    return [ $seq ] if !$unord and !$hyper;
    return [] if $unord and $hyper and !@$seq;
    my ($allow_self, $p_s, $s_s, @pairs);
    if ($unord) {
	require Set::Object;
	my @a = Set::Object->new(@$seq)->members;
	($allow_self, $p_s, $s_s) = (@a < 2, \@a, \@a);
    } else {
	($allow_self, $p_s, $s_s) = (1, @$seq);
    }
    for my $p (@$p_s) {
	push @pairs, map [$p, $_], $allow_self ? @$s_s : grep $p != $_, @$s_s;
    }
    \@pairs;
}

sub _get_path_count {
    return 0 unless my ($i) = &__has_path;
    my $f = (my $m = $_[0])->[ _f ];
    return
        ($f & _COUNT) ? $m->[ _count ][ $i ] :
        ($f & _MULTI) ? scalar keys %{ $m->[ _attr ][ $i ] } : 1;
}

sub has_path {
    ( &__has_path )[0];
}

sub has_path_by_multi_id {
    return undef unless my ($i) = &__has_path;
    return exists $_[0]->[ _attr ][ $i ]{ $_[2] };
}

sub del_path {
    return unless my ($i, $l) = &__has_path;
    return 1 if &_is_COUNT and --$_[0][ _count ][ $i ] > 0;
    $_[0]->_sequence_del($i, $l);
    1;
}

sub del_path_by_multi_id {
    return unless my ($i, $l) = &__has_path;
    delete((my $attrs = (my $m = $_[0])->[ _attr ][ $i ])->{ $_[2] });
    return 1 if keys %$attrs;
    $m->_sequence_del($i, $l);
    1;
}

sub get_multi_ids {
    return unless ((my $m = $_[0])->[ _f ] & _MULTI) and my ($i) = &__has_path;
    keys %{ $m->[ _attr ][ $i ] };
}

sub rename_path {
    my ($m, $from, $to) = @_;
    return 1 if $m->[ _arity ] != 1; # all integers, no names
    return unless my ($i, $l) = $m->__has_path($from);
    $m->[ _i ][ $i ] = $to;
    $to = __strval($to, $m->[ _f ]) if ref($to) and ($m->[ _f ] & _REF);
    $m->[ _pi ]{ $to } = delete $m->[ _pi ]{ $l };
    return 1;
}

sub _del_path_attrs {
    return unless my ($i) = &__has_path;
    my $attr = (my $m = $_[0])->[ _attr ];
    return $attr->[ $i ]{ $_[2] } = undef, 1 if ($m->[ _f ] & _MULTI);
    delete $attr->[ $i ];
}

sub __has_path {
    &__arg;
    my ($f, $a, $pi, $k) = (@{ $_[0] }[ _f, _arity, _pi ], $_[1]);
    $k = __strval($k, $f) if $a == 1 && ($f & _REF) && ref($k);
    my $l = ($a == 0 && !($f & _UNORD)) ? join '|', map join(' ', sort @$_), @$k : $a == 1 ? "$k" : "@$k";
    my $id = $pi->{ $l };
    (defined $id ? $id : return, $l);
}

sub _get_path_attrs {
    return unless my ($i) = &__has_path;
    my $attrs = (my $m = $_[0])->[ _attr ][ $i ];
    ($m->[ _f ] & _MULTI) ? $attrs->{ $_[2] } : $attrs;
}

sub _has_path_attrs {
    keys %{ &{ $_[0]->can('_get_path_attrs') } || return undef } ? 1 : 0;
}

sub _has_path_attr {
    exists(( &{ $_[0]->can('_get_path_attrs') } || return )->{ $_[-1] });
}

sub _get_path_attr {
    ( &{ $_[0]->can('_get_path_attrs') } || return )->{ $_[-1] };
}

sub _get_path_attr_names {
    keys %{ &{ $_[0]->can('_get_path_attrs') } || return };
}

sub _get_path_attr_values {
    values %{ &{ $_[0]->can('_get_path_attrs') } || return };
}

sub _del_path_attr {
    return unless my $attrs = &{ $_[0]->can('_get_path_attrs') };
    return 0 unless exists $attrs->{ my $attr = $_[-1] };
    delete $attrs->{$attr};
    return 1 if keys %$attrs;
    &{ $_[0]->can('_del_path_attrs') };
    1;
}

sub _sequence_del {
    my ($m, $id, $l) = @_;
    my ($f, $a, $map_i, $pi, $map_s, $map_p) = @$m[ _f, _arity, _i, _pi, _s, _p ];
    delete $pi->{ $l };
    delete $m->[ $_ ][ $id ] for _count, _attr;
    my $path = delete $map_i->[ $id ];
    _successors_del($f, $a, $map_s, $map_p, $id, $path) if $map_s;
    return 1;
}

sub get_paths_by_ids {
    my ($i, undef, $list, $deep) = ( @{ $_[0] }[ _i ], @_ );
    $deep ? map [ map [ @$i[ @$_ ] ], @$_ ], @$list : map [ @$i[ @$_ ] ], @$list;
}

sub paths {
    grep defined, @{ $_[0]->[ _i ] || Graph::_empty_array() };
}

sub get_ids_by_paths {
    my ($f, $a, $pi, $m, $list, $ensure, $deep) = ( @{ $_[0] }[ _f, _arity, _pi ], @_ );
    $deep ||= 0;
    my ($is_multi, $is_ref, $is_unord) = (map $f & $_, _MULTI, _REF, _UNORD);
    return map { # Fast path
	my @ret = map {
	    my $id = $pi->{ $a != 1 ? "@$_" : $_ };
	    defined $id ? $id :
		!$ensure ? return :
		($is_multi ? $m->set_path_by_multi_id($_, _GEN_ID) : $m->set_paths($_))[0];
	} $deep ? @$_ : $_;
	$deep ? \@ret : @ret;
    } @$list if $a and !$is_ref and $deep < 2;
    map {
	my @ret = map {
	    my @ret2 = map {
		my $k = $_;
		$k = __strval($k, $f) if $a == 1 && $is_ref && ref($k);
		my $l = ($a == 0 && !$is_unord) ? join '|', map join(' ', sort @$_), @$k : $a == 1 ? "$k" : "@$k";
		my $id = $pi->{ $l };
		defined $id ? $id :
		    !$ensure ? return :
		    ($is_multi ? $m->set_path_by_multi_id($_, _GEN_ID) : $m->set_paths($_))[0];
	    } $deep > 1 ? @$_ : $_;
	    $deep > 1 ? \@ret2 : @ret2;
	} $deep ? @$_ : $_;
	$deep ? \@ret : @ret;
    } @$list;
}

sub _paths_fromto {
    my $offset = pop;
    my ($i, $map_x, @v) = ( @{ $_[0] }[ _i, $offset ], @_[1..$#_] );
    Graph::__carp_confess("undefined vertex") if grep !defined, @v;
    require Set::Object;
    map $i->[ $_ ], Set::Object->new(map @$_, map values %{ $map_x->{ $_ } || _empty }, @v)->members;
}
sub paths_from { push @_, _s; goto &_paths_fromto }
sub paths_to { push @_, _p; goto &_paths_fromto }

sub _cessors {
    my $offset = pop;
    my ($map_x, @v) = ( @{ $_[0] }[ $offset ], @_[1..$#_] );
    Graph::__carp_confess("undefined vertex") if grep !defined, @v;
    require Set::Object;
    Set::Object->new(map keys %{ $map_x->{ $_ } || _empty }, @v)->members;
}
sub successors { push @_, _s; goto &_cessors }
sub predecessors { push @_, _p; goto &_cessors }

sub has_successor {
    my ($map_s, $u, $v) = ( @{ $_[0] }[ _s ], @_[1, 2] );
    Graph::__carp_confess("undefined vertex") if grep !defined, $u, $v;
    exists ${ $map_s->{ $u } || _empty }{ $v };
}

sub __strval {
    my ($k, $f) = @_;
    return $k unless ref $k && ($f & _REF);
    return "$k" if ($f & _STR);
    require Scalar::Util;
    Scalar::Util::refaddr($k);
}

sub __arg {
    my ($f, $a, $m, $k) = (@{ $_[0] }[ _f, _arity ], @_[0, 1]);
    Graph::__carp_confess(sprintf "arguments %d (%s) expected %d for\n".$m->stringify,
	scalar @$k, "@$k", $a)
	if $a > 1 and @$k != $a;
}

sub reindex {
    my ($f, $a, $i2p, $m) = (@{ $_[0] }[ _f, _arity, _i ], $_[0]);
    my $is_ref = $a == 1 && ($f & _REF);
    my $pi = $m->[ _pi ] = {};
    for my $i ( 0..$#{ $i2p } ) {
        next if !defined(my $k = $i2p->[ $i ]); # deleted
        $k = __strval($k, $f) if $is_ref && ref($k);
        $pi->{ $k } = $i;
    }
}

1;
__END__