1package 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 7use strict; 8 9use Graph::AdjacencyMap qw(:flags :fields); 10use base 'Graph::AdjacencyMap'; 11 12use Scalar::Util qw(weaken); 13 14use Graph::AdjacencyMap::Heavy; 15use Graph::AdjacencyMap::Vertex; 16 17sub _V () { 2 } # Graph::_V 18sub _E () { 3 } # Graph::_E 19sub _F () { 0 } # Graph::_F 20 21sub _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 35sub 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 59sub 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 74sub _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 89sub _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 103sub has_paths { 104 my $m = shift; 105 my ($n, $f, $a, $i, $s) = @$m; 106 keys %$s; 107} 108 109sub 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 124sub _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 131sub 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 158sub __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 173sub _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 186sub __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 201sub _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 214sub __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 241sub _is_COUNT () { 0 } 242sub _is_MULTI () { 0 } 243sub _is_HYPER () { 0 } 244sub _is_UNIQ () { 0 } 245sub _is_REF () { 0 } 246 2471; 248