1package Graph::AdjacencyMap; 2 3use strict; 4 5require Exporter; 6use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS); 7@ISA = qw(Exporter); 8@EXPORT_OK = qw(_COUNT _MULTI _COUNTMULTI _GEN_ID 9 _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT 10 _n _f _a _i _s _p _g _u _ni _nc _na _nm); 11%EXPORT_TAGS = 12 (flags => [qw(_COUNT _MULTI _COUNTMULTI _GEN_ID 13 _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT)], 14 fields => [qw(_n _f _a _i _s _p _g _u _ni _nc _na _nm)]); 15 16sub _COUNT () { 0x00000001 } 17sub _MULTI () { 0x00000002 } 18sub _COUNTMULTI () { _COUNT|_MULTI } 19sub _HYPER () { 0x00000004 } 20sub _UNORD () { 0x00000008 } 21sub _UNIQ () { 0x00000010 } 22sub _REF () { 0x00000020 } 23sub _UNORDUNIQ () { _UNORD|_UNIQ } 24sub _UNIONFIND () { 0x00000040 } 25sub _LIGHT () { 0x00000080 } 26 27my $_GEN_ID = 0; 28 29sub _GEN_ID () { \$_GEN_ID } 30 31sub _ni () { 0 } # Node index. 32sub _nc () { 1 } # Node count. 33sub _na () { 2 } # Node attributes. 34sub _nm () { 3 } # Node map. 35 36sub _n () { 0 } # Next id. 37sub _f () { 1 } # Flags. 38sub _a () { 2 } # Arity. 39sub _i () { 3 } # Index to path. 40sub _s () { 4 } # Successors / Path to Index. 41sub _p () { 5 } # Predecessors. 42sub _g () { 6 } # Graph (AdjacencyMap::Light) 43 44sub _V () { 2 } # Graph::_V() 45 46sub _new { 47 my $class = shift; 48 my $map = bless [ 0, @_ ], $class; 49 return $map; 50} 51 52sub _ids { 53 my $m = shift; 54 return $m->[ _i ]; 55} 56 57sub has_paths { 58 my $m = shift; 59 return defined $m->[ _i ] && keys %{ $m->[ _i ] }; 60} 61 62sub _dump { 63 my $d = Data::Dumper->new([$_[0]],[ref $_[0]]); 64 defined wantarray ? $d->Dump : print $d->Dump; 65} 66 67sub _del_id { 68 my ($m, $i) = @_; 69 my @p = $m->_get_id_path( $i ); 70 $m->del_path( @p ) if @p; 71} 72 73sub _new_node { 74 my ($m, $n, $id) = @_; 75 my $f = $m->[ _f ]; 76 my $i = $m->[ _n ]++; 77 if (($f & _MULTI)) { 78 $id = 0 if $id eq _GEN_ID; 79 $$n = [ $i, 0, undef, { $id => { } } ]; 80 } elsif (($f & _COUNT)) { 81 $$n = [ $i, 1 ]; 82 } else { 83 $$n = $i; 84 } 85 return $i; 86} 87 88sub _inc_node { 89 my ($m, $n, $id) = @_; 90 my $f = $m->[ _f ]; 91 if (($f & _MULTI)) { 92 if ($id eq _GEN_ID) { 93 $$n->[ _nc ]++ 94 while exists $$n->[ _nm ]->{ $$n->[ _nc ] }; 95 $id = $$n->[ _nc ]; 96 } 97 $$n->[ _nm ]->{ $id } = { }; 98 } elsif (($f & _COUNT)) { 99 $$n->[ _nc ]++; 100 } 101 return $id; 102} 103 104sub __get_path_node { 105 my $m = shift; 106 my ($p, $k); 107 my $f = $m->[ _f ]; 108 if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. 109 @_ = sort @_ if ($f & _UNORD); 110 return unless exists $m->[ _s ]->{ $_[0] }; 111 $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ]; 112 $k = [ $_[0], $_[1] ]; 113 } else { 114 ($p, $k) = $m->__has_path( @_ ); 115 } 116 return unless defined $p && defined $k; 117 my $l = defined $k->[-1] ? $k->[-1] : ""; 118 return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l ); 119} 120 121sub set_path_by_multi_id { 122 my $m = shift; 123 my ($p, $k) = $m->__set_path( @_ ); 124 return unless defined $p && defined $k; 125 my $l = defined $k->[-1] ? $k->[-1] : ""; 126 return $m->__set_path_node( $p, $l, @_ ); 127} 128 129sub get_multi_ids { 130 my $m = shift; 131 my $f = $m->[ _f ]; 132 return () unless ($f & _MULTI); 133 my ($e, $n) = $m->__get_path_node( @_ ); 134 return $e ? keys %{ $n->[ _nm ] } : (); 135} 136 137sub _has_path_attrs { 138 my $m = shift; 139 my $f = $m->[ _f ]; 140 my $id = pop if ($f & _MULTI); 141 $m->__attr( \@_ ); 142 if (($f & _MULTI)) { 143 my ($p, $k) = $m->__has_path( @_ ); 144 return unless defined $p && defined $k; 145 my $l = defined $k->[-1] ? $k->[-1] : ""; 146 return keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } } ? 1 : 0; 147 } else { 148 my ($e, $n) = $m->__get_path_node( @_ ); 149 return undef unless $e; 150 return ref $n && $#$n == _na && keys %{ $n->[ _na ] } ? 1 : 0; 151 } 152} 153 154sub _set_path_attrs { 155 my $m = shift; 156 my $f = $m->[ _f ]; 157 my $attr = pop; 158 my $id = pop if ($f & _MULTI); 159 $m->__attr( @_ ); 160 push @_, $id if ($f & _MULTI); 161 my ($p, $k) = $m->__set_path( @_ ); 162 return unless defined $p && defined $k; 163 my $l = defined $k->[-1] ? $k->[-1] : ""; 164 $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l }; 165 if (($f & _MULTI)) { 166 $p->[-1]->{ $l }->[ _nm ]->{ $id } = $attr; 167 } else { 168 # Extend the node if it is a simple id node. 169 $p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l }; 170 $p->[-1]->{ $l }->[ _na ] = $attr; 171 } 172} 173 174sub _has_path_attr { 175 my $m = shift; 176 my $f = $m->[ _f ]; 177 my $attr = pop; 178 my $id = pop if ($f & _MULTI); 179 $m->__attr( \@_ ); 180 if (($f & _MULTI)) { 181 my ($p, $k) = $m->__has_path( @_ ); 182 return unless defined $p && defined $k; 183 my $l = defined $k->[-1] ? $k->[-1] : ""; 184 exists $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; 185 } else { 186 my ($e, $n) = $m->__get_path_node( @_ ); 187 return undef unless $e; 188 return ref $n && $#$n == _na ? exists $n->[ _na ]->{ $attr } : undef; 189 } 190} 191 192sub _set_path_attr { 193 my $m = shift; 194 my $f = $m->[ _f ]; 195 my $val = pop; 196 my $attr = pop; 197 my $id = pop if ($f & _MULTI); 198 my ($p, $k); 199 $m->__attr( \@_ ); # _LIGHT maps need this to get upgraded when needed. 200 push @_, $id if ($f & _MULTI); 201 if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_REF|_UNIQ|_HYPER|_UNIQ))) { 202 @_ = sort @_ if ($f & _UNORD); 203 $m->[ _s ]->{ $_[0] } ||= { }; 204 $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ]; 205 $k = [ $_[0], $_[1] ]; 206 } else { 207 ($p, $k) = $m->__set_path( @_ ); 208 } 209 return unless defined $p && defined $k; 210 my $l = defined $k->[-1] ? $k->[-1] : ""; 211 $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l }; 212 if (($f & _MULTI)) { 213 $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr } = $val; 214 } else { 215 # Extend the node if it is a simple id node. 216 $p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l }; 217 $p->[-1]->{ $l }->[ _na ]->{ $attr } = $val; 218 } 219 return $val; 220} 221 222sub _get_path_attrs { 223 my $m = shift; 224 my $f = $m->[ _f ]; 225 my $id = pop if ($f & _MULTI); 226 $m->__attr( \@_ ); 227 if (($f & _MULTI)) { 228 my ($p, $k) = $m->__has_path( @_ ); 229 return unless defined $p && defined $k; 230 my $l = defined $k->[-1] ? $k->[-1] : ""; 231 $p->[-1]->{ $l }->[ _nm ]->{ $id }; 232 } else { 233 my ($e, $n) = $m->__get_path_node( @_ ); 234 return unless $e; 235 return $n->[ _na ] if ref $n && $#$n == _na; 236 return; 237 } 238} 239 240sub _get_path_attr { 241 my $m = shift; 242 my $f = $m->[ _f ]; 243 my $attr = pop; 244 my $id = pop if ($f & _MULTI); 245 $m->__attr( \@_ ); 246 if (($f & _MULTI)) { 247 my ($p, $k) = $m->__has_path( @_ ); 248 return unless defined $p && defined $k; 249 my $l = defined $k->[-1] ? $k->[-1] : ""; 250 return $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; 251 } else { 252 my ($e, $n) = $m->__get_path_node( @_ ); 253 return undef unless $e; 254 return ref $n && $#$n == _na ? $n->[ _na ]->{ $attr } : undef; 255 } 256} 257 258sub _get_path_attr_names { 259 my $m = shift; 260 my $f = $m->[ _f ]; 261 my $id = pop if ($f & _MULTI); 262 $m->__attr( \@_ ); 263 if (($f & _MULTI)) { 264 my ($p, $k) = $m->__has_path( @_ ); 265 return unless defined $p && defined $k; 266 my $l = defined $k->[-1] ? $k->[-1] : ""; 267 keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; 268 } else { 269 my ($e, $n) = $m->__get_path_node( @_ ); 270 return undef unless $e; 271 return keys %{ $n->[ _na ] } if ref $n && $#$n == _na; 272 return; 273 } 274} 275 276sub _get_path_attr_values { 277 my $m = shift; 278 my $f = $m->[ _f ]; 279 my $id = pop if ($f & _MULTI); 280 $m->__attr( \@_ ); 281 if (($f & _MULTI)) { 282 my ($p, $k) = $m->__has_path( @_ ); 283 return unless defined $p && defined $k; 284 my $l = defined $k->[-1] ? $k->[-1] : ""; 285 values %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; 286 } else { 287 my ($e, $n) = $m->__get_path_node( @_ ); 288 return undef unless $e; 289 return values %{ $n->[ _na ] } if ref $n && $#$n == _na; 290 return; 291 } 292} 293 294sub _del_path_attrs { 295 my $m = shift; 296 my $f = $m->[ _f ]; 297 my $id = pop if ($f & _MULTI); 298 $m->__attr( \@_ ); 299 if (($f & _MULTI)) { 300 my ($p, $k) = $m->__has_path( @_ ); 301 return unless defined $p && defined $k; 302 my $l = defined $k->[-1] ? $k->[-1] : ""; 303 delete $p->[-1]->{ $l }->[ _nm ]->{ $id }; 304 unless (keys %{ $p->[-1]->{ $l }->[ _nm ] } || 305 (defined $p->[-1]->{ $l }->[ _na ] && 306 keys %{ $p->[-1]->{ $l }->[ _na ] })) { 307 delete $p->[-1]->{ $l }; 308 } 309 } else { 310 my ($e, $n) = $m->__get_path_node( @_ ); 311 return undef unless $e; 312 if (ref $n) { 313 $e = _na == $#$n && keys %{ $n->[ _na ] } ? 1 : 0; 314 $#$n = _na - 1; 315 return $e; 316 } else { 317 return 0; 318 } 319 } 320} 321 322sub _del_path_attr { 323 my $m = shift; 324 my $f = $m->[ _f ]; 325 my $attr = pop; 326 my $id = pop if ($f & _MULTI); 327 $m->__attr( \@_ ); 328 if (($f & _MULTI)) { 329 my ($p, $k) = $m->__has_path( @_ ); 330 return unless defined $p && defined $k; 331 my $l = defined $k->[-1] ? $k->[-1] : ""; 332 delete $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; 333 $m->_del_path_attrs( @_, $id ) 334 unless keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; 335 } else { 336 my ($e, $n) = $m->__get_path_node( @_ ); 337 return undef unless $e; 338 if (ref $n && $#$n == _na && exists $n->[ _na ]->{ $attr }) { 339 delete $n->[ _na ]->{ $attr }; 340 return 1; 341 } else { 342 return 0; 343 } 344 } 345} 346 347sub _is_COUNT { $_[0]->[ _f ] & _COUNT } 348sub _is_MULTI { $_[0]->[ _f ] & _MULTI } 349sub _is_HYPER { $_[0]->[ _f ] & _HYPER } 350sub _is_UNORD { $_[0]->[ _f ] & _UNORD } 351sub _is_UNIQ { $_[0]->[ _f ] & _UNIQ } 352sub _is_REF { $_[0]->[ _f ] & _REF } 353 354sub __arg { 355 my $m = shift; 356 my $f = $m->[ _f ]; 357 my @a = @{$_[0]}; 358 if ($f & _UNIQ) { 359 my %u; 360 if ($f & _UNORD) { 361 @u{ @a } = @a; 362 @a = values %u; 363 } else { 364 my @u; 365 for my $e (@a) { 366 push @u, $e if $u{$e}++ == 0; 367 } 368 @a = @u; 369 } 370 } 371 # Alphabetic or numeric sort, does not matter as long as it unifies. 372 @{$_[0]} = ($f & _UNORD) ? sort @a : @a; 373} 374 375sub _successors { 376 my $E = shift; 377 my $g = shift; 378 my $V = $g->[ _V ]; 379 map { my @v = @{ $_->[ 1 ] }; 380 shift @v; 381 map { $V->_get_id_path($_) } @v } $g->_edges_from( @_ ); 382} 383 384sub _predecessors { 385 my $E = shift; 386 my $g = shift; 387 my $V = $g->[ _V ]; 388 if (wantarray) { 389 map { my @v = @{ $_->[ 1 ] }; 390 pop @v; 391 map { $V->_get_id_path($_) } @v } $g->_edges_to( @_ ); 392 } else { 393 return $g->_edges_to( @_ ); 394 } 395} 396 3971; 398__END__ 399=pod 400 401=head1 NAME 402 403Graph::AdjacencyMap - create and a map of graph vertices or edges 404 405=head1 SYNOPSIS 406 407 Internal. 408 409=head1 DESCRIPTION 410 411B<This module is meant for internal use by the Graph module.> 412 413=head2 Object Methods 414 415=over 4 416 417=item del_path(@id) 418 419Delete a Map path by ids. 420 421=item del_path_by_multi_id($id) 422 423Delete a Map path by a multi(vertex) id. 424 425=item get_multi_ids 426 427Return the multi ids. 428 429=item has_path(@id) 430 431Return true if the Map has the path by ids, false if not. 432 433=item has_paths 434 435Return true if the Map has any paths, false if not. 436 437=item has_path_by_multi_id($id) 438 439Return true ifd the a Map has the path by a multi(vertex) id, false if not. 440 441=item paths 442 443Return all the paths of the Map. 444 445=item set_path(@id) 446 447Set the path by @ids. 448 449=item set_path_by_multi_id 450 451Set the path in the Map by the multi id. 452 453=back 454 455=head1 AUTHOR AND COPYRIGHT 456 457Jarkko Hietaniemi F<jhi@iki.fi> 458 459=head1 LICENSE 460 461This module is licensed under the same terms as Perl itself. 462 463=cut 464