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