perllib/Graph/AdjacencyMap/Light.pm

   1 package Graph::AdjacencyMap::Light;
   2
   3 # THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY.
   4 # THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND
   5 # ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES.
   6
   7 use strict;
   8
   9 use Graph::AdjacencyMap qw(:flags :fields);
  10 use base 'Graph::AdjacencyMap';
  11
  12 use Scalar::Util qw(weaken);
  13
  14 use Graph::AdjacencyMap::Heavy;
  15 use Graph::AdjacencyMap::Vertex;
  16
  17 sub _V () { 2 } # Graph::_V
  18 sub _E () { 3 } # Graph::_E
  19 sub _F () { 0 } # Graph::_F
  20
  21 sub _new {
  22     my ($class, $graph, $flags, $arity) = @_;
  23     my $m = bless [ ], $class;
  24     $m->[ _n ] = 0;
  25     $m->[ _f ] = $flags | _LIGHT;
  26     $m->[ _a ] = $arity;
  27     $m->[ _i ] = { };
  28     $m->[ _s ] = { };
  29     $m->[ _p ] = { };
  30     $m->[ _g ] = $graph;
  31     weaken $m->[ _g ]; # So that DESTROY finds us earlier.
  32     return $m;
  33 }
  34
  35 sub set_path {
  36     my $m = shift;
  37     my ($n, $f, $a, $i, $s, $p) = @$m;
  38     if ($a == 2) {
  39         @_ = sort @_ if ($f & _UNORD);
  40     }
  41     my $e0 = shift;
  42     if ($a == 2) {
  43         my $e1 = shift;
  44         unless (exists $s->{ $e0 } && exists $s->{ $e0 }->{ $e1 }) {
  45             $n = $m->[ _n ]++;
  46             $i->{ $n } = [ $e0, $e1 ];
  47             $s->{ $e0 }->{ $e1 } = $n;
  48             $p->{ $e1 }->{ $e0 } = $n;
  49         }
  50     } else {
  51         unless (exists $s->{ $e0 }) {
  52             $n = $m->[ _n ]++;
  53             $s->{ $e0 } = $n;
  54             $i->{ $n } = $e0;
  55         }
  56     }
  57 }
  58
  59 sub has_path {
  60     my $m = shift;
  61     my ($n, $f, $a, $i, $s) = @$m;
  62     return 0 unless $a == @_;
  63     my $e;
  64     if ($a == 2) {
  65         @_ = sort @_ if ($f & _UNORD);
  66         $e = shift;
  67         return 0 unless exists $s->{ $e };
  68         $s = $s->{ $e };
  69     }
  70     $e = shift;
  71     exists $s->{ $e };
  72 }
  73
  74 sub _get_path_id {
  75     my $m = shift;
  76     my ($n, $f, $a, $i, $s) = @$m;
  77     return undef unless $a == @_;
  78     my $e;
  79     if ($a == 2) {
  80         @_ = sort @_ if ($f & _UNORD);
  81         $e = shift;
  82         return undef unless exists $s->{ $e };
  83         $s = $s->{ $e };
  84     }
  85     $e = shift;
  86     $s->{ $e };
  87 }
  88
  89 sub _get_path_count {
  90     my $m = shift;
  91     my ($n, $f, $a, $i, $s) = @$m;
  92     my $e;
  93     if (@_ == 2) {
  94         @_ = sort @_ if ($f & _UNORD);
  95         $e = shift;
  96         return undef unless exists $s->{ $e };
  97         $s = $s->{ $e };
  98     }
  99     $e = shift;
 100     return exists $s->{ $e } ? 1 : 0;
 101 }
 102
 103 sub has_paths {
 104     my $m = shift;
 105     my ($n, $f, $a, $i, $s) = @$m;
 106     keys %$s;
 107 }
 108
 109 sub paths {
 110     my $m = shift;
 111     my ($n, $f, $a, $i) = @$m;
 112     if (defined $i) {
 113         my ($k, $v) = each %$i;
 114         if (ref $v) {
 115             return values %{ $i };
 116         } else {
 117             return map { [ $_ ] } values %{ $i };
 118         }
 119     } else {
 120         return ( );
 121     }
 122 }
 123
 124 sub _get_id_path {
 125     my $m = shift;
 126     my ($n, $f, $a, $i) = @$m;
 127     my $p = $i->{ $_[ 0 ] };
 128     defined $p ? ( ref $p eq 'ARRAY' ? @$p : $p ) : ( );
 129 }
 130
 131 sub del_path {
 132     my $m = shift;
 133     my ($n, $f, $a, $i, $s, $p) = @$m;
 134     if (@_ == 2) {
 135         @_ = sort @_ if ($f & _UNORD);
 136         my $e0 = shift;
 137         return 0 unless exists $s->{ $e0 };
 138         my $e1 = shift;
 139         if (defined($n = $s->{ $e0 }->{ $e1 })) {
 140             delete $i->{ $n };
 141             delete $s->{ $e0 }->{ $e1 };
 142             delete $p->{ $e1 }->{ $e0 };
 143             delete $s->{ $e0 } unless keys %{ $s->{ $e0 } };
 144             delete $p->{ $e1 } unless keys %{ $p->{ $e1 } };
 145             return 1;
 146         }
 147     } else {
 148         my $e = shift;
 149         if (defined($n = $s->{ $e })) {
 150             delete $i->{ $n };
 151             delete $s->{ $e };
 152             return 1;
 153         }
 154     }
 155     return 0;
 156 }
 157
 158 sub __successors {
 159     my $E = shift;
 160     return wantarray ? () : 0 unless defined $E->[ _s ];
 161     my $g = shift;
 162     my $V = $g->[ _V ];
 163     return wantarray ? () : 0 unless defined $V && defined $V->[ _s ];
 164     # my $i = $V->_get_path_id( $_[0] );
 165     my $i =
 166         ($V->[ _f ] & _LIGHT) ?
 167             $V->[ _s ]->{ $_[0] } :
 168             $V->_get_path_id( $_[0] );
 169     return wantarray ? () : 0 unless defined $i && defined $E->[ _s ]->{ $i };
 170     return keys %{ $E->[ _s ]->{ $i } };
 171 }
 172
 173 sub _successors {
 174     my $E = shift;
 175     my $g = shift;
 176     my @s = $E->__successors($g, @_);
 177     if (($E->[ _f ] & _UNORD)) {
 178         push @s, $E->__predecessors($g, @_);
 179         my %s; @s{ @s } = ();
 180         @s = keys %s;
 181     }
 182     my $V = $g->[ _V ];
 183     return wantarray ? map { $V->[ _i ]->{ $_ } } @s : @s;
 184 }
 185
 186 sub __predecessors {
 187     my $E = shift;
 188     return wantarray ? () : 0 unless defined $E->[ _p ];
 189     my $g = shift;
 190     my $V = $g->[ _V ];
 191     return wantarray ? () : 0 unless defined $V && defined $V->[ _s ];
 192     # my $i = $V->_get_path_id( $_[0] );
 193     my $i =
 194         ($V->[ _f ] & _LIGHT) ?
 195             $V->[ _s ]->{ $_[0] } :
 196             $V->_get_path_id( $_[0] );
 197     return wantarray ? () : 0 unless defined $i && defined $E->[ _p ]->{ $i };
 198     return keys %{ $E->[ _p ]->{ $i } };
 199 }
 200
 201 sub _predecessors {
 202     my $E = shift;
 203     my $g = shift;
 204     my @p = $E->__predecessors($g, @_);
 205     if ($E->[ _f ] & _UNORD) {
 206         push @p, $E->__successors($g, @_);
 207         my %p; @p{ @p } = ();
 208         @p = keys %p;
 209     }
 210     my $V = $g->[ _V ];
 211     return wantarray ? map { $V->[ _i ]->{ $_ } } @p : @p;
 212 }
 213
 214 sub __attr {
 215     # Major magic takes place here: we rebless the appropriate 'light'
 216     # map into a more complex map and then redispatch the method.
 217     my $m = $_[0];
 218     my ($n, $f, $a, $i, $s, $p, $g) = @$m;
 219     my ($k, $v) = each %$i;
 220     my @V = @{ $g->[ _V ] };
 221     my @E = $g->edges; # TODO: Both these (ZZZ) lines are mysteriously needed!
 222     # ZZZ: an example of failing tests is t/52_edge_attributes.t.
 223     if (ref $v eq 'ARRAY') { # Edges, then.
 224         # print "Reedging.\n";
 225         @E = $g->edges; # TODO: Both these (ZZZ) lines are mysteriously needed!
 226         $g->[ _E ] = $m = Graph::AdjacencyMap::Heavy->_new($f, 2);
 227         $g->add_edges( @E );
 228     } else {
 229         # print "Revertexing.\n";
 230         $m = Graph::AdjacencyMap::Vertex->_new(($f & ~_LIGHT), 1);
 231         $m->[ _n ] = $V[ _n ];
 232         $m->[ _i ] = $V[ _i ];
 233         $m->[ _s ] = $V[ _s ];
 234         $m->[ _p ] = $V[ _p ];
 235         $g->[ _V ] = $m;
 236     }
 237     $_[0] = $m;
 238     goto &{ ref($m) . "::__attr" }; # Redispatch.
 239 }
 240
 241 sub _is_COUNT    () { 0 }
 242 sub _is_MULTI    () { 0 }
 243 sub _is_HYPER    () { 0 }
 244 sub _is_UNIQ     () { 0 }
 245 sub _is_REF      () { 0 }
 246
 247 1;