1package Graph; 2 3use strict; 4 5BEGIN { 6 if (0) { # SET THIS TO ZERO FOR TESTING AND RELEASES! 7 $SIG{__DIE__ } = \&__carp_confess; 8 $SIG{__WARN__} = \&__carp_confess; 9 } 10 sub __carp_confess { require Carp; Carp::confess(@_) } 11} 12 13use Graph::AdjacencyMap qw(:flags :fields); 14 15use vars qw($VERSION); 16 17$VERSION = '0.96'; 18 19require 5.006; # Weak references are absolutely required. 20 21my $can_deep_copy_Storable = 22 eval 'require Storable; require B::Deparse; $Storable::VERSION >= 2.05 && $B::Deparse::VERSION >= 0.61' && !$@; 23 24sub _can_deep_copy_Storable () { 25 return $can_deep_copy_Storable; 26} 27 28use Graph::AdjacencyMap::Heavy; 29use Graph::AdjacencyMap::Light; 30use Graph::AdjacencyMap::Vertex; 31use Graph::UnionFind; 32use Graph::TransitiveClosure; 33use Graph::Traversal::DFS; 34use Graph::MSTHeapElem; 35use Graph::SPTHeapElem; 36use Graph::Undirected; 37 38use Heap071::Fibonacci; 39use List::Util qw(shuffle first); 40use Scalar::Util qw(weaken); 41 42use Safe; # For deep_copy(). 43 44sub _F () { 0 } # Flags. 45sub _G () { 1 } # Generation. 46sub _V () { 2 } # Vertices. 47sub _E () { 3 } # Edges. 48sub _A () { 4 } # Attributes. 49sub _U () { 5 } # Union-Find. 50sub _S () { 6 } # Successors. 51sub _P () { 7 } # Predecessors. 52 53my $Inf; 54 55BEGIN { 56 local $SIG{FPE}; 57 eval { $Inf = exp(999) } || 58 eval { $Inf = 9**9**9 } || 59 eval { $Inf = 1e+999 } || 60 { $Inf = 1e+99 }; # Close enough for most practical purposes. 61} 62 63sub Infinity () { $Inf } 64 65# Graphs are blessed array references. 66# - The first element contains the flags. 67# - The second element is the vertices. 68# - The third element is the edges. 69# - The fourth element is the attributes of the whole graph. 70# The defined flags for Graph are: 71# - _COMPAT02 for user API compatibility with the Graph 0.20xxx series. 72# The vertices are contained in either a "simplemap" 73# (if no hypervertices) or in a "map". 74# The edges are always in a "map". 75# The defined flags for maps are: 76# - _COUNT for countedness: more than one instance 77# - _HYPER for hyperness: a different number of "coordinates" than usual; 78# expects one for vertices and two for edges 79# - _UNORD for unordered coordinates (a set): if _UNORD is not set 80# the coordinates are assumed to be meaningfully ordered 81# - _UNIQ for unique coordinates: if set duplicates are removed, 82# if not, duplicates are assumed to meaningful 83# - _UNORDUNIQ: just a union of _UNORD and UNIQ 84# Vertices are assumed to be _UNORDUNIQ; edges assume none of these flags. 85 86use Graph::Attribute array => _A, map => 'graph'; 87 88sub _COMPAT02 () { 0x00000001 } 89 90sub stringify { 91 my $g = shift; 92 my $u = $g->is_undirected; 93 my $e = $u ? '=' : '-'; 94 my @e = 95 map { 96 my @v = 97 map { 98 ref($_) eq 'ARRAY' ? "[" . join(" ", @$_) . "]" : "$_" 99 } 100 @$_; 101 join($e, $u ? sort { "$a" cmp "$b" } @v : @v) } $g->edges05; 102 my @s = sort { "$a" cmp "$b" } @e; 103 push @s, sort { "$a" cmp "$b" } $g->isolated_vertices; 104 join(",", @s); 105} 106 107sub eq { 108 "$_[0]" eq "$_[1]" 109} 110 111sub ne { 112 "$_[0]" ne "$_[1]" 113} 114 115use overload 116 '""' => \&stringify, 117 'eq' => \&eq, 118 'ne' => \≠ 119 120sub _opt { 121 my ($opt, $flags, %flags) = @_; 122 while (my ($flag, $FLAG) = each %flags) { 123 if (exists $opt->{$flag}) { 124 $$flags |= $FLAG if $opt->{$flag}; 125 delete $opt->{$flag}; 126 } 127 if (exists $opt->{my $non = "non$flag"}) { 128 $$flags &= ~$FLAG if $opt->{$non}; 129 delete $opt->{$non}; 130 } 131 } 132} 133 134sub is_compat02 { 135 my ($g) = @_; 136 $g->[ _F ] & _COMPAT02; 137} 138 139*compat02 = \&is_compat02; 140 141sub has_union_find { 142 my ($g) = @_; 143 ($g->[ _F ] & _UNIONFIND) && defined $g->[ _U ]; 144} 145 146sub _get_union_find { 147 my ($g) = @_; 148 $g->[ _U ]; 149} 150 151sub _opt_get { 152 my ($opt, $key, $var) = @_; 153 if (exists $opt->{$key}) { 154 $$var = $opt->{$key}; 155 delete $opt->{$key}; 156 } 157} 158 159sub _opt_unknown { 160 my ($opt) = @_; 161 if (my @opt = keys %$opt) { 162 my $f = (caller(1))[3]; 163 require Carp; 164 Carp::confess(sprintf 165 "$f: Unknown option%s: @{[map { qq['$_'] } sort @opt]}", 166 @opt > 1 ? 's' : ''); 167 } 168} 169 170sub new { 171 my $class = shift; 172 my $gflags = 0; 173 my $vflags; 174 my $eflags; 175 my %opt = _get_options( \@_ ); 176 177 if (ref $class && $class->isa('Graph')) { 178 no strict 'refs'; 179 for my $c (qw(undirected refvertexed compat02 180 hypervertexed countvertexed multivertexed 181 hyperedged countedged multiedged omniedged 182 __stringified)) { 183# $opt{$c}++ if $class->$c; # 5.00504-incompatible 184 if (&{"Graph::$c"}($class)) { $opt{$c}++ } 185 } 186# $opt{unionfind}++ if $class->has_union_find; # 5.00504-incompatible 187 if (&{"Graph::has_union_find"}($class)) { $opt{unionfind}++ } 188 } 189 190 _opt_get(\%opt, undirected => \$opt{omniedged}); 191 _opt_get(\%opt, omnidirected => \$opt{omniedged}); 192 193 if (exists $opt{directed}) { 194 $opt{omniedged} = !$opt{directed}; 195 delete $opt{directed}; 196 } 197 198 my $vnonomni = 199 $opt{nonomnivertexed} || 200 (exists $opt{omnivertexed} && !$opt{omnivertexed}); 201 my $vnonuniq = 202 $opt{nonuniqvertexed} || 203 (exists $opt{uniqvertexed} && !$opt{uniqvertexed}); 204 205 _opt(\%opt, \$vflags, 206 countvertexed => _COUNT, 207 multivertexed => _MULTI, 208 hypervertexed => _HYPER, 209 omnivertexed => _UNORD, 210 uniqvertexed => _UNIQ, 211 refvertexed => _REF, 212 refvertexed_stringified => _REFSTR , 213 __stringified => _STR, 214 ); 215 216 _opt(\%opt, \$eflags, 217 countedged => _COUNT, 218 multiedged => _MULTI, 219 hyperedged => _HYPER, 220 omniedged => _UNORD, 221 uniqedged => _UNIQ, 222 ); 223 224 _opt(\%opt, \$gflags, 225 compat02 => _COMPAT02, 226 unionfind => _UNIONFIND, 227 ); 228 229 if (exists $opt{vertices_unsorted}) { # Graph 0.20103 compat. 230 my $unsorted = $opt{vertices_unsorted}; 231 delete $opt{vertices_unsorted}; 232 require Carp; 233 Carp::confess("Graph: vertices_unsorted must be true") 234 unless $unsorted; 235 } 236 237 my @V; 238 if ($opt{vertices}) { 239 require Carp; 240 Carp::confess("Graph: vertices should be an array ref") 241 unless ref $opt{vertices} eq 'ARRAY'; 242 @V = @{ $opt{vertices} }; 243 delete $opt{vertices}; 244 } 245 246 my @E; 247 if ($opt{edges}) { 248 unless (ref $opt{edges} eq 'ARRAY') { 249 require Carp; 250 Carp::confess("Graph: edges should be an array ref of array refs"); 251 } 252 @E = @{ $opt{edges} }; 253 delete $opt{edges}; 254 } 255 256 _opt_unknown(\%opt); 257 258 my $uflags; 259 if (defined $vflags) { 260 $uflags = $vflags; 261 $uflags |= _UNORD unless $vnonomni; 262 $uflags |= _UNIQ unless $vnonuniq; 263 } else { 264 $uflags = _UNORDUNIQ; 265 $vflags = 0; 266 } 267 268 if (!($vflags & _HYPER) && ($vflags & _UNORDUNIQ)) { 269 my @but; 270 push @but, 'unordered' if ($vflags & _UNORD); 271 push @but, 'unique' if ($vflags & _UNIQ); 272 require Carp; 273 Carp::confess(sprintf "Graph: not hypervertexed but %s", 274 join(' and ', @but)); 275 } 276 277 unless (defined $eflags) { 278 $eflags = ($gflags & _COMPAT02) ? _COUNT : 0; 279 } 280 281 if (!($vflags & _HYPER) && ($vflags & _UNIQ)) { 282 require Carp; 283 Carp::confess("Graph: not hypervertexed but uniqvertexed"); 284 } 285 286 if (($vflags & _COUNT) && ($vflags & _MULTI)) { 287 require Carp; 288 Carp::confess("Graph: both countvertexed and multivertexed"); 289 } 290 291 if (($eflags & _COUNT) && ($eflags & _MULTI)) { 292 require Carp; 293 Carp::confess("Graph: both countedged and multiedged"); 294 } 295 296 my $g = bless [ ], ref $class || $class; 297 298 $g->[ _F ] = $gflags; 299 $g->[ _G ] = 0; 300 $g->[ _V ] = ($vflags & (_HYPER | _MULTI)) ? 301 Graph::AdjacencyMap::Heavy->_new($uflags, 1) : 302 (($vflags & ~_UNORD) ? 303 Graph::AdjacencyMap::Vertex->_new($uflags, 1) : 304 Graph::AdjacencyMap::Light->_new($g, $uflags, 1)); 305 $g->[ _E ] = (($vflags & _HYPER) || ($eflags & ~_UNORD)) ? 306 Graph::AdjacencyMap::Heavy->_new($eflags, 2) : 307 Graph::AdjacencyMap::Light->_new($g, $eflags, 2); 308 309 $g->add_vertices(@V) if @V; 310 311 if (@E) { 312 for my $e (@E) { 313 unless (ref $e eq 'ARRAY') { 314 require Carp; 315 Carp::confess("Graph: edges should be array refs"); 316 } 317 $g->add_edge(@$e); 318 } 319 } 320 321 if (($gflags & _UNIONFIND)) { 322 $g->[ _U ] = Graph::UnionFind->new; 323 } 324 325 return $g; 326} 327 328sub countvertexed { $_[0]->[ _V ]->_is_COUNT } 329sub multivertexed { $_[0]->[ _V ]->_is_MULTI } 330sub hypervertexed { $_[0]->[ _V ]->_is_HYPER } 331sub omnivertexed { $_[0]->[ _V ]->_is_UNORD } 332sub uniqvertexed { $_[0]->[ _V ]->_is_UNIQ } 333sub refvertexed { $_[0]->[ _V ]->_is_REF } 334sub refvertexed_stringified { $_[0]->[ _V ]->_is_REFSTR } 335sub __stringified { $_[0]->[ _V ]->_is_STR } 336 337sub countedged { $_[0]->[ _E ]->_is_COUNT } 338sub multiedged { $_[0]->[ _E ]->_is_MULTI } 339sub hyperedged { $_[0]->[ _E ]->_is_HYPER } 340sub omniedged { $_[0]->[ _E ]->_is_UNORD } 341sub uniqedged { $_[0]->[ _E ]->_is_UNIQ } 342 343*undirected = \&omniedged; 344*omnidirected = \&omniedged; 345sub directed { ! $_[0]->[ _E ]->_is_UNORD } 346 347*is_directed = \&directed; 348*is_undirected = \&undirected; 349 350*is_countvertexed = \&countvertexed; 351*is_multivertexed = \&multivertexed; 352*is_hypervertexed = \&hypervertexed; 353*is_omnidirected = \&omnidirected; 354*is_uniqvertexed = \&uniqvertexed; 355*is_refvertexed = \&refvertexed; 356*is_refvertexed_stringified = \&refvertexed_stringified; 357 358*is_countedged = \&countedged; 359*is_multiedged = \&multiedged; 360*is_hyperedged = \&hyperedged; 361*is_omniedged = \&omniedged; 362*is_uniqedged = \&uniqedged; 363 364sub _union_find_add_vertex { 365 my ($g, $v) = @_; 366 my $UF = $g->[ _U ]; 367 $UF->add( $g->[ _V ]->_get_path_id( $v ) ); 368} 369 370sub add_vertex { 371 my $g = shift; 372 if ($g->is_multivertexed) { 373 return $g->add_vertex_by_id(@_, _GEN_ID); 374 } 375 my @r; 376 if (@_ > 1) { 377 unless ($g->is_countvertexed || $g->is_hypervertexed) { 378 require Carp; 379 Carp::croak("Graph::add_vertex: use add_vertices for more than one vertex or use hypervertexed"); 380 } 381 for my $v ( @_ ) { 382 if (defined $v) { 383 $g->[ _V ]->set_path( $v ) unless $g->has_vertex( $v ); 384 } else { 385 require Carp; 386 Carp::croak("Graph::add_vertex: undef vertex"); 387 } 388 } 389 } 390 for my $v ( @_ ) { 391 unless (defined $v) { 392 require Carp; 393 Carp::croak("Graph::add_vertex: undef vertex"); 394 } 395 } 396 $g->[ _V ]->set_path( @_ ); 397 $g->[ _G ]++; 398 $g->_union_find_add_vertex( @_ ) if $g->has_union_find; 399 return $g; 400} 401 402sub has_vertex { 403 my $g = shift; 404 my $V = $g->[ _V ]; 405 return exists $V->[ _s ]->{ $_[0] } if ($V->[ _f ] & _LIGHT); 406 $V->has_path( @_ ); 407} 408 409sub vertices05 { 410 my $g = shift; 411 my @v = $g->[ _V ]->paths( @_ ); 412 if (wantarray) { 413 return $g->[ _V ]->_is_HYPER ? 414 @v : map { ref $_ eq 'ARRAY' ? @$_ : $_ } @v; 415 } else { 416 return scalar @v; 417 } 418} 419 420sub vertices { 421 my $g = shift; 422 my @v = $g->vertices05; 423 if ($g->is_compat02) { 424 wantarray ? sort @v : scalar @v; 425 } else { 426 if ($g->is_multivertexed || $g->is_countvertexed) { 427 if (wantarray) { 428 my @V; 429 for my $v ( @v ) { 430 push @V, ($v) x $g->get_vertex_count($v); 431 } 432 return @V; 433 } else { 434 my $V = 0; 435 for my $v ( @v ) { 436 $V += $g->get_vertex_count($v); 437 } 438 return $V; 439 } 440 } else { 441 return @v; 442 } 443 } 444} 445 446*vertices_unsorted = \&vertices_unsorted; # Graph 0.20103 compat. 447 448sub unique_vertices { 449 my $g = shift; 450 my @v = $g->vertices05; 451 if ($g->is_compat02) { 452 wantarray ? sort @v : scalar @v; 453 } else { 454 return @v; 455 } 456} 457 458sub has_vertices { 459 my $g = shift; 460 scalar $g->[ _V ]->has_paths( @_ ); 461} 462 463sub _add_edge { 464 my $g = shift; 465 my $V = $g->[ _V ]; 466 my @e; 467 if (($V->[ _f ]) & _LIGHT) { 468 for my $v ( @_ ) { 469 $g->add_vertex( $v ) unless exists $V->[ _s ]->{ $v }; 470 push @e, $V->[ _s ]->{ $v }; 471 } 472 } else { 473 my $h = $g->[ _V ]->_is_HYPER; 474 for my $v ( @_ ) { 475 my @v = ref $v eq 'ARRAY' && $h ? @$v : $v; 476 $g->add_vertex( @v ) unless $V->has_path( @v ); 477 push @e, $V->_get_path_id( @v ); 478 } 479 } 480 return @e; 481} 482 483sub _union_find_add_edge { 484 my ($g, $u, $v) = @_; 485 $g->[ _U ]->union($u, $v); 486} 487 488sub add_edge { 489 my $g = shift; 490 if ($g->is_multiedged) { 491 unless (@_ == 2 || $g->is_hyperedged) { 492 require Carp; 493 Carp::croak("Graph::add_edge: use add_edges for more than one edge"); 494 } 495 return $g->add_edge_by_id(@_, _GEN_ID); 496 } 497 unless (@_ == 2) { 498 unless ($g->is_hyperedged) { 499 require Carp; 500 Carp::croak("Graph::add_edge: graph is not hyperedged"); 501 } 502 } 503 my @e = $g->_add_edge( @_ ); 504 $g->[ _E ]->set_path( @e ); 505 $g->[ _G ]++; 506 $g->_union_find_add_edge( @e ) if $g->has_union_find; 507 return $g; 508} 509 510sub _vertex_ids { 511 my $g = shift; 512 my $V = $g->[ _V ]; 513 my @e; 514 if (($V->[ _f ] & _LIGHT)) { 515 for my $v ( @_ ) { 516 return () unless exists $V->[ _s ]->{ $v }; 517 push @e, $V->[ _s ]->{ $v }; 518 } 519 } else { 520 my $h = $g->[ _V ]->_is_HYPER; 521 for my $v ( @_ ) { 522 my @v = ref $v eq 'ARRAY' && $h ? @$v : $v; 523 return () unless $V->has_path( @v ); 524 push @e, $V->_get_path_id( @v ); 525 } 526 } 527 return @e; 528} 529 530sub has_edge { 531 my $g = shift; 532 my $E = $g->[ _E ]; 533 my $V = $g->[ _V ]; 534 my @i; 535 if (($V->[ _f ] & _LIGHT) && @_ == 2) { 536 return 0 unless 537 exists $V->[ _s ]->{ $_[0] } && 538 exists $V->[ _s ]->{ $_[1] }; 539 @i = @{ $V->[ _s ] }{ @_[ 0, 1 ] }; 540 } else { 541 @i = $g->_vertex_ids( @_ ); 542 return 0 if @i == 0 && @_; 543 } 544 my $f = $E->[ _f ]; 545 if ($E->[ _a ] == 2 && @i == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. 546 @i = sort @i if ($f & _UNORD); 547 return exists $E->[ _s ]->{ $i[0] } && 548 exists $E->[ _s ]->{ $i[0] }->{ $i[1] } ? 1 : 0; 549 } else { 550 return defined $E->_get_path_id( @i ) ? 1 : 0; 551 } 552} 553 554sub edges05 { 555 my $g = shift; 556 my $V = $g->[ _V ]; 557 my @e = $g->[ _E ]->paths( @_ ); 558 wantarray ? 559 map { [ map { my @v = $V->_get_id_path($_); 560 @v == 1 ? $v[0] : [ @v ] } 561 @$_ ] } 562 @e : @e; 563} 564 565sub edges02 { 566 my $g = shift; 567 if (@_ && defined $_[0]) { 568 unless (defined $_[1]) { 569 my @e = $g->edges_at($_[0]); 570 wantarray ? 571 map { @$_ } 572 sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @e 573 : @e; 574 } else { 575 die "edges02: unimplemented option"; 576 } 577 } else { 578 my @e = map { ($_) x $g->get_edge_count(@$_) } $g->edges05( @_ ); 579 wantarray ? 580 map { @$_ } 581 sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @e 582 : @e; 583 } 584} 585 586sub unique_edges { 587 my $g = shift; 588 ($g->is_compat02) ? $g->edges02( @_ ) : $g->edges05( @_ ); 589} 590 591sub edges { 592 my $g = shift; 593 if ($g->is_compat02) { 594 return $g->edges02( @_ ); 595 } else { 596 if ($g->is_multiedged || $g->is_countedged) { 597 if (wantarray) { 598 my @E; 599 for my $e ( $g->edges05 ) { 600 push @E, ($e) x $g->get_edge_count(@$e); 601 } 602 return @E; 603 } else { 604 my $E = 0; 605 for my $e ( $g->edges05 ) { 606 $E += $g->get_edge_count(@$e); 607 } 608 return $E; 609 } 610 } else { 611 return $g->edges05; 612 } 613 } 614} 615 616sub has_edges { 617 my $g = shift; 618 scalar $g->[ _E ]->has_paths( @_ ); 619} 620 621### 622# by_id 623# 624 625sub add_vertex_by_id { 626 my $g = shift; 627 $g->expect_multivertexed; 628 $g->[ _V ]->set_path_by_multi_id( @_ ); 629 $g->[ _G ]++; 630 $g->_union_find_add_vertex( @_ ) if $g->has_union_find; 631 return $g; 632} 633 634sub add_vertex_get_id { 635 my $g = shift; 636 $g->expect_multivertexed; 637 my $id = $g->[ _V ]->set_path_by_multi_id( @_, _GEN_ID ); 638 $g->[ _G ]++; 639 $g->_union_find_add_vertex( @_ ) if $g->has_union_find; 640 return $id; 641} 642 643sub has_vertex_by_id { 644 my $g = shift; 645 $g->expect_multivertexed; 646 $g->[ _V ]->has_path_by_multi_id( @_ ); 647} 648 649sub delete_vertex_by_id { 650 my $g = shift; 651 $g->expect_multivertexed; 652 $g->expect_non_unionfind; 653 my $V = $g->[ _V ]; 654 return unless $V->has_path_by_multi_id( @_ ); 655 # TODO: what to about the edges at this vertex? 656 # If the multiness of this vertex goes to zero, delete the edges? 657 $V->del_path_by_multi_id( @_ ); 658 $g->[ _G ]++; 659 return $g; 660} 661 662sub get_multivertex_ids { 663 my $g = shift; 664 $g->expect_multivertexed; 665 $g->[ _V ]->get_multi_ids( @_ ); 666} 667 668sub add_edge_by_id { 669 my $g = shift; 670 $g->expect_multiedged; 671 my $id = pop; 672 my @e = $g->_add_edge( @_ ); 673 $g->[ _E ]->set_path_by_multi_id( @e, $id ); 674 $g->[ _G ]++; 675 $g->_union_find_add_edge( @e ) if $g->has_union_find; 676 return $g; 677} 678 679sub add_edge_get_id { 680 my $g = shift; 681 $g->expect_multiedged; 682 my @i = $g->_add_edge( @_ ); 683 my $id = $g->[ _E ]->set_path_by_multi_id( @i, _GEN_ID ); 684 $g->_union_find_add_edge( @i ) if $g->has_union_find; 685 $g->[ _G ]++; 686 return $id; 687} 688 689sub has_edge_by_id { 690 my $g = shift; 691 $g->expect_multiedged; 692 my $id = pop; 693 my @i = $g->_vertex_ids( @_ ); 694 return 0 if @i == 0 && @_; 695 $g->[ _E ]->has_path_by_multi_id( @i, $id ); 696} 697 698sub delete_edge_by_id { 699 my $g = shift; 700 $g->expect_multiedged; 701 $g->expect_non_unionfind; 702 my $V = $g->[ _E ]; 703 my $id = pop; 704 my @i = $g->_vertex_ids( @_ ); 705 return unless $V->has_path_by_multi_id( @i, $id ); 706 $V->del_path_by_multi_id( @i, $id ); 707 $g->[ _G ]++; 708 return $g; 709} 710 711sub get_multiedge_ids { 712 my $g = shift; 713 $g->expect_multiedged; 714 my @id = $g->_vertex_ids( @_ ); 715 return unless @id; 716 $g->[ _E ]->get_multi_ids( @id ); 717} 718 719### 720# Neighbourhood. 721# 722 723sub vertices_at { 724 my $g = shift; 725 my $V = $g->[ _V ]; 726 return @_ unless ($V->[ _f ] & _HYPER); 727 my %v; 728 my @i; 729 for my $v ( @_ ) { 730 my $i = $V->_get_path_id( $v ); 731 return unless defined $i; 732 push @i, ( $v{ $v } = $i ); 733 } 734 my $Vi = $V->_ids; 735 my @v; 736 while (my ($i, $v) = each %{ $Vi }) { 737 my %i; 738 my $h = $V->[_f ] & _HYPER; 739 @i{ @i } = @i if @i; # @todo: nonuniq hyper vertices? 740 for my $u (ref $v eq 'ARRAY' && $h ? @$v : $v) { 741 my $j = exists $v{ $u } ? $v{ $u } : ( $v{ $u } = $i ); 742 if (defined $j && exists $i{ $j }) { 743 delete $i{ $j }; 744 unless (keys %i) { 745 push @v, $v; 746 last; 747 } 748 } 749 } 750 } 751 return @v; 752} 753 754sub _edges_at { 755 my $g = shift; 756 my $V = $g->[ _V ]; 757 my $E = $g->[ _E ]; 758 my @e; 759 my $en = 0; 760 my %ev; 761 my $h = $V->[_f ] & _HYPER; 762 for my $v ( $h ? $g->vertices_at( @_ ) : @_ ) { 763 my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v ); 764 next unless defined $vi; 765 my $Ei = $E->_ids; 766 while (my ($ei, $ev) = each %{ $Ei }) { 767 if (wantarray) { 768 for my $j (@$ev) { 769 push @e, [ $ei, $ev ] 770 if $j == $vi && !$ev{$ei}++; 771 } 772 } else { 773 for my $j (@$ev) { 774 $en++ if $j == $vi; 775 } 776 } 777 } 778 } 779 return wantarray ? @e : $en; 780} 781 782sub _edges { 783 my $g = shift; 784 my $n = pop; 785 my $i = $n == _S ? 0 : -1; # _edges_from() or _edges_to() 786 my $V = $g->[ _V ]; 787 my $E = $g->[ _E ]; 788 my $N = $g->[ $n ]; 789 my $h = $V->[ _f ] & _HYPER; 790 unless (defined $N && $N->[ 0 ] == $g->[ _G ]) { 791 $g->[ $n ]->[ 1 ] = { }; 792 $N = $g->[ $n ]; 793 my $u = $E->[ _f ] & _UNORD; 794 my $Ei = $E->_ids; 795 while (my ($ei, $ev) = each %{ $Ei }) { 796 next unless @$ev; 797 my $e = [ $ei, $ev ]; 798 if ($u) { 799 push @{ $N->[ 1 ]->{ $ev->[ 0] } }, $e; 800 push @{ $N->[ 1 ]->{ $ev->[-1] } }, $e; 801 } else { 802 my $e = [ $ei, $ev ]; 803 push @{ $N->[ 1 ]->{ $ev->[$i] } }, $e; 804 } 805 } 806 $N->[ 0 ] = $g->[ _G ]; 807 } 808 my @e; 809 my @at = $h ? $g->vertices_at( @_ ) : @_; 810 my %at; @at{@at} = (); 811 for my $v ( @at ) { 812 my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v ); 813 next unless defined $vi && exists $N->[ 1 ]->{ $vi }; 814 push @e, @{ $N->[ 1 ]->{ $vi } }; 815 } 816 if (wantarray && $g->is_undirected) { 817 my @i = map { $V->_get_path_id( $_ ) } @_; 818 for my $e ( @e ) { 819 unless ( $e->[ 1 ]->[ $i ] == $i[ $i ] ) { 820 $e = [ $e->[ 0 ], [ reverse @{ $e->[ 1 ] } ] ]; 821 } 822 } 823 } 824 return @e; 825} 826 827sub _edges_from { 828 push @_, _S; 829 goto &_edges; 830} 831 832sub _edges_to { 833 push @_, _P; 834 goto &_edges; 835} 836 837sub _edges_id_path { 838 my $g = shift; 839 my $V = $g->[ _V ]; 840 [ map { my @v = $V->_get_id_path($_); 841 @v == 1 ? $v[0] : [ @v ] } 842 @{ $_[0]->[1] } ]; 843} 844 845sub edges_at { 846 my $g = shift; 847 map { $g->_edges_id_path($_ ) } $g->_edges_at( @_ ); 848} 849 850sub edges_from { 851 my $g = shift; 852 map { $g->_edges_id_path($_ ) } $g->_edges_from( @_ ); 853} 854 855sub edges_to { 856 my $g = shift; 857 map { $g->_edges_id_path($_ ) } $g->_edges_to( @_ ); 858} 859 860sub successors { 861 my $g = shift; 862 my $E = $g->[ _E ]; 863 ($E->[ _f ] & _LIGHT) ? 864 $E->_successors($g, @_) : 865 Graph::AdjacencyMap::_successors($E, $g, @_); 866} 867 868sub predecessors { 869 my $g = shift; 870 my $E = $g->[ _E ]; 871 ($E->[ _f ] & _LIGHT) ? 872 $E->_predecessors($g, @_) : 873 Graph::AdjacencyMap::_predecessors($E, $g, @_); 874} 875 876sub _all_successors { 877 my $g = shift; 878 my @init = @_; 879 my %todo; 880 @todo{@init} = @init; 881 my %seen; 882 my %init = %todo; 883 my %self; 884 while (keys %todo) { 885 my @todo = values %todo; 886 for my $t (@todo) { 887 $seen{$t} = delete $todo{$t}; 888 for my $s ($g->successors($t)) { 889 $self{$s} = $s if exists $init{$s}; 890 $todo{$s} = $s unless exists $seen{$s}; 891 } 892 } 893 } 894 for my $v (@init) { 895 delete $seen{$v} unless $g->has_edge($v, $v) || $self{$v}; 896 } 897 return values %seen; 898} 899 900sub all_successors { 901 my $g = shift; 902 $g->expect_directed; 903 return $g->_all_successors(@_); 904} 905 906sub _all_predecessors { 907 my $g = shift; 908 my @init = @_; 909 my %todo; 910 @todo{@init} = @init; 911 my %seen; 912 my %init = %todo; 913 my %self; 914 while (keys %todo) { 915 my @todo = values %todo; 916 for my $t (@todo) { 917 $seen{$t} = delete $todo{$t}; 918 for my $p ($g->predecessors($t)) { 919 $self{$p} = $p if exists $init{$p}; 920 $todo{$p} = $p unless exists $seen{$p}; 921 } 922 } 923 } 924 for my $v (@init) { 925 delete $seen{$v} unless $g->has_edge($v, $v) || $self{$v}; 926 } 927 return values %seen; 928} 929 930sub all_predecessors { 931 my $g = shift; 932 $g->expect_directed; 933 return $g->_all_predecessors(@_); 934} 935 936sub neighbours { 937 my $g = shift; 938 my $V = $g->[ _V ]; 939 my @s = map { my @v = @{ $_->[ 1 ] }; shift @v; @v } $g->_edges_from( @_ ); 940 my @p = map { my @v = @{ $_->[ 1 ] }; pop @v; @v } $g->_edges_to ( @_ ); 941 my %n; 942 @n{ @s } = @s; 943 @n{ @p } = @p; 944 map { $V->_get_id_path($_) } keys %n; 945} 946 947*neighbors = \&neighbours; 948 949sub all_neighbours { 950 my $g = shift; 951 my @init = @_; 952 my @v = @init; 953 my %n; 954 my $o = 0; 955 while (1) { 956 my @p = $g->_all_predecessors(@v); 957 my @s = $g->_all_successors(@v); 958 @n{@p} = @p; 959 @n{@s} = @s; 960 @v = values %n; 961 last if @v == $o; # Leave if no growth. 962 $o = @v; 963 } 964 for my $v (@init) { 965 delete $n{$v} unless $g->has_edge($v, $v); 966 } 967 return values %n; 968} 969 970*all_neighbors = \&all_neighbours; 971 972sub all_reachable { 973 my $g = shift; 974 $g->directed ? $g->all_successors(@_) : $g->all_neighbors(@_); 975} 976 977sub delete_edge { 978 my $g = shift; 979 $g->expect_non_unionfind; 980 my @i = $g->_vertex_ids( @_ ); 981 return $g unless @i; 982 my $i = $g->[ _E ]->_get_path_id( @i ); 983 return $g unless defined $i; 984 $g->[ _E ]->_del_id( $i ); 985 $g->[ _G ]++; 986 return $g; 987} 988 989sub delete_vertex { 990 my $g = shift; 991 $g->expect_non_unionfind; 992 my $V = $g->[ _V ]; 993 return $g unless $V->has_path( @_ ); 994 my $E = $g->[ _E ]; 995 for my $e ( $g->_edges_at( @_ ) ) { 996 $E->_del_id( $e->[ 0 ] ); 997 } 998 $V->del_path( @_ ); 999 $g->[ _G ]++; 1000 return $g; 1001} 1002 1003sub get_vertex_count { 1004 my $g = shift; 1005 $g->[ _V ]->_get_path_count( @_ ) || 0; 1006} 1007 1008sub get_edge_count { 1009 my $g = shift; 1010 my @e = $g->_vertex_ids( @_ ); 1011 return 0 unless @e; 1012 $g->[ _E ]->_get_path_count( @e ) || 0; 1013} 1014 1015sub delete_vertices { 1016 my $g = shift; 1017 $g->expect_non_unionfind; 1018 while (@_) { 1019 my $v = shift @_; 1020 $g->delete_vertex($v); 1021 } 1022 return $g; 1023} 1024 1025sub delete_edges { 1026 my $g = shift; 1027 $g->expect_non_unionfind; 1028 while (@_) { 1029 my ($u, $v) = splice @_, 0, 2; 1030 $g->delete_edge($u, $v); 1031 } 1032 return $g; 1033} 1034 1035### 1036# Degrees. 1037# 1038 1039sub _in_degree { 1040 my $g = shift; 1041 return undef unless @_ && $g->has_vertex( @_ ); 1042 my $in = 0; 1043 $in += $g->get_edge_count( @$_ ) for $g->edges_to( @_ ); 1044 return $in; 1045} 1046 1047sub in_degree { 1048 my $g = shift; 1049 $g->_in_degree( @_ ); 1050} 1051 1052sub _out_degree { 1053 my $g = shift; 1054 return undef unless @_ && $g->has_vertex( @_ ); 1055 my $out = 0; 1056 $out += $g->get_edge_count( @$_ ) for $g->edges_from( @_ ); 1057 return $out; 1058} 1059 1060sub out_degree { 1061 my $g = shift; 1062 $g->_out_degree( @_ ); 1063} 1064 1065sub _total_degree { 1066 my $g = shift; 1067 return undef unless @_ && $g->has_vertex( @_ ); 1068 $g->is_undirected ? 1069 $g->_in_degree( @_ ) : 1070 $g-> in_degree( @_ ) - $g-> out_degree( @_ ); 1071} 1072 1073sub degree { 1074 my $g = shift; 1075 if (@_) { 1076 $g->_total_degree( @_ ); 1077 } elsif ($g->is_undirected) { 1078 my $total = 0; 1079 $total += $g->_total_degree( $_ ) for $g->vertices05; 1080 return $total; 1081 } else { 1082 return 0; 1083 } 1084} 1085 1086*vertex_degree = \°ree; 1087 1088sub is_sink_vertex { 1089 my $g = shift; 1090 return 0 unless @_; 1091 $g->successors( @_ ) == 0 && $g->predecessors( @_ ) > 0; 1092} 1093 1094sub is_source_vertex { 1095 my $g = shift; 1096 return 0 unless @_; 1097 $g->predecessors( @_ ) == 0 && $g->successors( @_ ) > 0; 1098} 1099 1100sub is_successorless_vertex { 1101 my $g = shift; 1102 return 0 unless @_; 1103 $g->successors( @_ ) == 0; 1104} 1105 1106sub is_predecessorless_vertex { 1107 my $g = shift; 1108 return 0 unless @_; 1109 $g->predecessors( @_ ) == 0; 1110} 1111 1112sub is_successorful_vertex { 1113 my $g = shift; 1114 return 0 unless @_; 1115 $g->successors( @_ ) > 0; 1116} 1117 1118sub is_predecessorful_vertex { 1119 my $g = shift; 1120 return 0 unless @_; 1121 $g->predecessors( @_ ) > 0; 1122} 1123 1124sub is_isolated_vertex { 1125 my $g = shift; 1126 return 0 unless @_; 1127 $g->predecessors( @_ ) == 0 && $g->successors( @_ ) == 0; 1128} 1129 1130sub is_interior_vertex { 1131 my $g = shift; 1132 return 0 unless @_; 1133 my $p = $g->predecessors( @_ ); 1134 my $s = $g->successors( @_ ); 1135 if ($g->is_self_loop_vertex( @_ )) { 1136 $p--; 1137 $s--; 1138 } 1139 $p > 0 && $s > 0; 1140} 1141 1142sub is_exterior_vertex { 1143 my $g = shift; 1144 return 0 unless @_; 1145 $g->predecessors( @_ ) == 0 || $g->successors( @_ ) == 0; 1146} 1147 1148sub is_self_loop_vertex { 1149 my $g = shift; 1150 return 0 unless @_; 1151 for my $s ( $g->successors( @_ ) ) { 1152 return 1 if $s eq $_[0]; # @todo: multiedges, hypervertices 1153 } 1154 return 0; 1155} 1156 1157sub sink_vertices { 1158 my $g = shift; 1159 grep { $g->is_sink_vertex($_) } $g->vertices05; 1160} 1161 1162sub source_vertices { 1163 my $g = shift; 1164 grep { $g->is_source_vertex($_) } $g->vertices05; 1165} 1166 1167sub successorless_vertices { 1168 my $g = shift; 1169 grep { $g->is_successorless_vertex($_) } $g->vertices05; 1170} 1171 1172sub predecessorless_vertices { 1173 my $g = shift; 1174 grep { $g->is_predecessorless_vertex($_) } $g->vertices05; 1175} 1176 1177sub successorful_vertices { 1178 my $g = shift; 1179 grep { $g->is_successorful_vertex($_) } $g->vertices05; 1180} 1181 1182sub predecessorful_vertices { 1183 my $g = shift; 1184 grep { $g->is_predecessorful_vertex($_) } $g->vertices05; 1185} 1186 1187sub isolated_vertices { 1188 my $g = shift; 1189 grep { $g->is_isolated_vertex($_) } $g->vertices05; 1190} 1191 1192sub interior_vertices { 1193 my $g = shift; 1194 grep { $g->is_interior_vertex($_) } $g->vertices05; 1195} 1196 1197sub exterior_vertices { 1198 my $g = shift; 1199 grep { $g->is_exterior_vertex($_) } $g->vertices05; 1200} 1201 1202sub self_loop_vertices { 1203 my $g = shift; 1204 grep { $g->is_self_loop_vertex($_) } $g->vertices05; 1205} 1206 1207### 1208# Paths and cycles. 1209# 1210 1211sub add_path { 1212 my $g = shift; 1213 my $u = shift; 1214 while (@_) { 1215 my $v = shift; 1216 $g->add_edge($u, $v); 1217 $u = $v; 1218 } 1219 return $g; 1220} 1221 1222sub delete_path { 1223 my $g = shift; 1224 $g->expect_non_unionfind; 1225 my $u = shift; 1226 while (@_) { 1227 my $v = shift; 1228 $g->delete_edge($u, $v); 1229 $u = $v; 1230 } 1231 return $g; 1232} 1233 1234sub has_path { 1235 my $g = shift; 1236 my $u = shift; 1237 while (@_) { 1238 my $v = shift; 1239 return 0 unless $g->has_edge($u, $v); 1240 $u = $v; 1241 } 1242 return $g; 1243} 1244 1245sub add_cycle { 1246 my $g = shift; 1247 $g->add_path(@_, $_[0]); 1248} 1249 1250sub delete_cycle { 1251 my $g = shift; 1252 $g->expect_non_unionfind; 1253 $g->delete_path(@_, $_[0]); 1254} 1255 1256sub has_cycle { 1257 my $g = shift; 1258 @_ ? ($g->has_path(@_, $_[0]) ? 1 : 0) : 0; 1259} 1260 1261sub has_a_cycle { 1262 my $g = shift; 1263 my @r = ( back_edge => \&Graph::Traversal::has_a_cycle ); 1264 push @r, 1265 down_edge => \&Graph::Traversal::has_a_cycle 1266 if $g->is_undirected; 1267 my $t = Graph::Traversal::DFS->new($g, @r, @_); 1268 $t->dfs; 1269 return $t->get_state('has_a_cycle'); 1270} 1271 1272sub find_a_cycle { 1273 my $g = shift; 1274 my @r = ( back_edge => \&Graph::Traversal::find_a_cycle); 1275 push @r, 1276 down_edge => \&Graph::Traversal::find_a_cycle 1277 if $g->is_undirected; 1278 my $t = Graph::Traversal::DFS->new($g, @r, @_); 1279 $t->dfs; 1280 $t->has_state('a_cycle') ? @{ $t->get_state('a_cycle') } : (); 1281} 1282 1283### 1284# Attributes. 1285 1286# Vertex attributes. 1287 1288sub set_vertex_attribute { 1289 my $g = shift; 1290 $g->expect_non_multivertexed; 1291 my $value = pop; 1292 my $attr = pop; 1293 $g->add_vertex( @_ ) unless $g->has_vertex( @_ ); 1294 $g->[ _V ]->_set_path_attr( @_, $attr, $value ); 1295} 1296 1297sub set_vertex_attribute_by_id { 1298 my $g = shift; 1299 $g->expect_multivertexed; 1300 my $value = pop; 1301 my $attr = pop; 1302 $g->add_vertex_by_id( @_ ) unless $g->has_vertex_by_id( @_ ); 1303 $g->[ _V ]->_set_path_attr( @_, $attr, $value ); 1304} 1305 1306sub set_vertex_attributes { 1307 my $g = shift; 1308 $g->expect_non_multivertexed; 1309 my $attr = pop; 1310 $g->add_vertex( @_ ) unless $g->has_vertex( @_ ); 1311 $g->[ _V ]->_set_path_attrs( @_, $attr ); 1312} 1313 1314sub set_vertex_attributes_by_id { 1315 my $g = shift; 1316 $g->expect_multivertexed; 1317 my $attr = pop; 1318 $g->add_vertex_by_id( @_ ) unless $g->has_vertex_by_id( @_ ); 1319 $g->[ _V ]->_set_path_attrs( @_, $attr ); 1320} 1321 1322sub has_vertex_attributes { 1323 my $g = shift; 1324 $g->expect_non_multivertexed; 1325 return 0 unless $g->has_vertex( @_ ); 1326 $g->[ _V ]->_has_path_attrs( @_ ); 1327} 1328 1329sub has_vertex_attributes_by_id { 1330 my $g = shift; 1331 $g->expect_multivertexed; 1332 return 0 unless $g->has_vertex_by_id( @_ ); 1333 $g->[ _V ]->_has_path_attrs( @_ ); 1334} 1335 1336sub has_vertex_attribute { 1337 my $g = shift; 1338 $g->expect_non_multivertexed; 1339 my $attr = pop; 1340 return 0 unless $g->has_vertex( @_ ); 1341 $g->[ _V ]->_has_path_attr( @_, $attr ); 1342} 1343 1344sub has_vertex_attribute_by_id { 1345 my $g = shift; 1346 $g->expect_multivertexed; 1347 my $attr = pop; 1348 return 0 unless $g->has_vertex_by_id( @_ ); 1349 $g->[ _V ]->_has_path_attr( @_, $attr ); 1350} 1351 1352sub get_vertex_attributes { 1353 my $g = shift; 1354 $g->expect_non_multivertexed; 1355 return unless $g->has_vertex( @_ ); 1356 my $a = $g->[ _V ]->_get_path_attrs( @_ ); 1357 ($g->is_compat02) ? (defined $a ? %{ $a } : ()) : $a; 1358} 1359 1360sub get_vertex_attributes_by_id { 1361 my $g = shift; 1362 $g->expect_multivertexed; 1363 return unless $g->has_vertex_by_id( @_ ); 1364 $g->[ _V ]->_get_path_attrs( @_ ); 1365} 1366 1367sub get_vertex_attribute { 1368 my $g = shift; 1369 $g->expect_non_multivertexed; 1370 my $attr = pop; 1371 return unless $g->has_vertex( @_ ); 1372 $g->[ _V ]->_get_path_attr( @_, $attr ); 1373} 1374 1375sub get_vertex_attribute_by_id { 1376 my $g = shift; 1377 $g->expect_multivertexed; 1378 my $attr = pop; 1379 return unless $g->has_vertex_by_id( @_ ); 1380 $g->[ _V ]->_get_path_attr( @_, $attr ); 1381} 1382 1383sub get_vertex_attribute_names { 1384 my $g = shift; 1385 $g->expect_non_multivertexed; 1386 return unless $g->has_vertex( @_ ); 1387 $g->[ _V ]->_get_path_attr_names( @_ ); 1388} 1389 1390sub get_vertex_attribute_names_by_id { 1391 my $g = shift; 1392 $g->expect_multivertexed; 1393 return unless $g->has_vertex_by_id( @_ ); 1394 $g->[ _V ]->_get_path_attr_names( @_ ); 1395} 1396 1397sub get_vertex_attribute_values { 1398 my $g = shift; 1399 $g->expect_non_multivertexed; 1400 return unless $g->has_vertex( @_ ); 1401 $g->[ _V ]->_get_path_attr_values( @_ ); 1402} 1403 1404sub get_vertex_attribute_values_by_id { 1405 my $g = shift; 1406 $g->expect_multivertexed; 1407 return unless $g->has_vertex_by_id( @_ ); 1408 $g->[ _V ]->_get_path_attr_values( @_ ); 1409} 1410 1411sub delete_vertex_attributes { 1412 my $g = shift; 1413 $g->expect_non_multivertexed; 1414 return undef unless $g->has_vertex( @_ ); 1415 $g->[ _V ]->_del_path_attrs( @_ ); 1416} 1417 1418sub delete_vertex_attributes_by_id { 1419 my $g = shift; 1420 $g->expect_multivertexed; 1421 return undef unless $g->has_vertex_by_id( @_ ); 1422 $g->[ _V ]->_del_path_attrs( @_ ); 1423} 1424 1425sub delete_vertex_attribute { 1426 my $g = shift; 1427 $g->expect_non_multivertexed; 1428 my $attr = pop; 1429 return undef unless $g->has_vertex( @_ ); 1430 $g->[ _V ]->_del_path_attr( @_, $attr ); 1431} 1432 1433sub delete_vertex_attribute_by_id { 1434 my $g = shift; 1435 $g->expect_multivertexed; 1436 my $attr = pop; 1437 return undef unless $g->has_vertex_by_id( @_ ); 1438 $g->[ _V ]->_del_path_attr( @_, $attr ); 1439} 1440 1441# Edge attributes. 1442 1443sub _set_edge_attribute { 1444 my $g = shift; 1445 my $value = pop; 1446 my $attr = pop; 1447 my $E = $g->[ _E ]; 1448 my $f = $E->[ _f ]; 1449 my @i; 1450 if ($E->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. 1451 @_ = sort @_ if ($f & _UNORD); 1452 my $s = $E->[ _s ]; 1453 $g->add_edge( @_ ) unless exists $s->{ $_[0] } && exists $s->{ $_[0] }->{ $_[1] }; 1454 @i = @{ $g->[ _V ]->[ _s ] }{ @_ }; 1455 } else { 1456 $g->add_edge( @_ ) unless $g->has_edge( @_ ); 1457 @i = $g->_vertex_ids( @_ ); 1458 } 1459 $g->[ _E ]->_set_path_attr( @i, $attr, $value ); 1460} 1461 1462sub set_edge_attribute { 1463 my $g = shift; 1464 $g->expect_non_multiedged; 1465 my $value = pop; 1466 my $attr = pop; 1467 my $E = $g->[ _E ]; 1468 $g->add_edge( @_ ) unless $g->has_edge( @_ ); 1469 $E->_set_path_attr( $g->_vertex_ids( @_ ), $attr, $value ); 1470} 1471 1472sub set_edge_attribute_by_id { 1473 my $g = shift; 1474 $g->expect_multiedged; 1475 my $value = pop; 1476 my $attr = pop; 1477 # $g->add_edge_by_id( @_ ) unless $g->has_edge_by_id( @_ ); 1478 my $id = pop; 1479 $g->[ _E ]->_set_path_attr( $g->_vertex_ids( @_ ), $id, $attr, $value ); 1480} 1481 1482sub set_edge_attributes { 1483 my $g = shift; 1484 $g->expect_non_multiedged; 1485 my $attr = pop; 1486 $g->add_edge( @_ ) unless $g->has_edge( @_ ); 1487 $g->[ _E ]->_set_path_attrs( $g->_vertex_ids( @_ ), $attr ); 1488} 1489 1490sub set_edge_attributes_by_id { 1491 my $g = shift; 1492 $g->expect_multiedged; 1493 my $attr = pop; 1494 $g->add_edge_by_id( @_ ) unless $g->has_edge_by_id( @_ ); 1495 my $id = pop; 1496 $g->[ _E ]->_set_path_attrs( $g->_vertex_ids( @_ ), $id, $attr ); 1497} 1498 1499sub has_edge_attributes { 1500 my $g = shift; 1501 $g->expect_non_multiedged; 1502 return 0 unless $g->has_edge( @_ ); 1503 $g->[ _E ]->_has_path_attrs( $g->_vertex_ids( @_ ) ); 1504} 1505 1506sub has_edge_attributes_by_id { 1507 my $g = shift; 1508 $g->expect_multiedged; 1509 return 0 unless $g->has_edge_by_id( @_ ); 1510 my $id = pop; 1511 $g->[ _E ]->_has_path_attrs( $g->_vertex_ids( @_ ), $id ); 1512} 1513 1514sub has_edge_attribute { 1515 my $g = shift; 1516 $g->expect_non_multiedged; 1517 my $attr = pop; 1518 return 0 unless $g->has_edge( @_ ); 1519 $g->[ _E ]->_has_path_attr( $g->_vertex_ids( @_ ), $attr ); 1520} 1521 1522sub has_edge_attribute_by_id { 1523 my $g = shift; 1524 $g->expect_multiedged; 1525 my $attr = pop; 1526 return 0 unless $g->has_edge_by_id( @_ ); 1527 my $id = pop; 1528 $g->[ _E ]->_has_path_attr( $g->_vertex_ids( @_ ), $id, $attr ); 1529} 1530 1531sub get_edge_attributes { 1532 my $g = shift; 1533 $g->expect_non_multiedged; 1534 return unless $g->has_edge( @_ ); 1535 my $a = $g->[ _E ]->_get_path_attrs( $g->_vertex_ids( @_ ) ); 1536 ($g->is_compat02) ? (defined $a ? %{ $a } : ()) : $a; 1537} 1538 1539sub get_edge_attributes_by_id { 1540 my $g = shift; 1541 $g->expect_multiedged; 1542 return unless $g->has_edge_by_id( @_ ); 1543 my $id = pop; 1544 return $g->[ _E ]->_get_path_attrs( $g->_vertex_ids( @_ ), $id ); 1545} 1546 1547sub _get_edge_attribute { # Fast path; less checks. 1548 my $g = shift; 1549 my $attr = pop; 1550 my $E = $g->[ _E ]; 1551 my $f = $E->[ _f ]; 1552 if ($E->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. 1553 @_ = sort @_ if ($f & _UNORD); 1554 my $s = $E->[ _s ]; 1555 return unless exists $s->{ $_[0] } && exists $s->{ $_[0] }->{ $_[1] }; 1556 } else { 1557 return unless $g->has_edge( @_ ); 1558 } 1559 my @i = $g->_vertex_ids( @_ ); 1560 $E->_get_path_attr( @i, $attr ); 1561} 1562 1563sub get_edge_attribute { 1564 my $g = shift; 1565 $g->expect_non_multiedged; 1566 my $attr = pop; 1567 return undef unless $g->has_edge( @_ ); 1568 my @i = $g->_vertex_ids( @_ ); 1569 return undef if @i == 0 && @_; 1570 my $E = $g->[ _E ]; 1571 $E->_get_path_attr( @i, $attr ); 1572} 1573 1574sub get_edge_attribute_by_id { 1575 my $g = shift; 1576 $g->expect_multiedged; 1577 my $attr = pop; 1578 return unless $g->has_edge_by_id( @_ ); 1579 my $id = pop; 1580 $g->[ _E ]->_get_path_attr( $g->_vertex_ids( @_ ), $id, $attr ); 1581} 1582 1583sub get_edge_attribute_names { 1584 my $g = shift; 1585 $g->expect_non_multiedged; 1586 return unless $g->has_edge( @_ ); 1587 $g->[ _E ]->_get_path_attr_names( $g->_vertex_ids( @_ ) ); 1588} 1589 1590sub get_edge_attribute_names_by_id { 1591 my $g = shift; 1592 $g->expect_multiedged; 1593 return unless $g->has_edge_by_id( @_ ); 1594 my $id = pop; 1595 $g->[ _E ]->_get_path_attr_names( $g->_vertex_ids( @_ ), $id ); 1596} 1597 1598sub get_edge_attribute_values { 1599 my $g = shift; 1600 $g->expect_non_multiedged; 1601 return unless $g->has_edge( @_ ); 1602 $g->[ _E ]->_get_path_attr_values( $g->_vertex_ids( @_ ) ); 1603} 1604 1605sub get_edge_attribute_values_by_id { 1606 my $g = shift; 1607 $g->expect_multiedged; 1608 return unless $g->has_edge_by_id( @_ ); 1609 my $id = pop; 1610 $g->[ _E ]->_get_path_attr_values( $g->_vertex_ids( @_ ), $id ); 1611} 1612 1613sub delete_edge_attributes { 1614 my $g = shift; 1615 $g->expect_non_multiedged; 1616 return unless $g->has_edge( @_ ); 1617 $g->[ _E ]->_del_path_attrs( $g->_vertex_ids( @_ ) ); 1618} 1619 1620sub delete_edge_attributes_by_id { 1621 my $g = shift; 1622 $g->expect_multiedged; 1623 return unless $g->has_edge_by_id( @_ ); 1624 my $id = pop; 1625 $g->[ _E ]->_del_path_attrs( $g->_vertex_ids( @_ ), $id ); 1626} 1627 1628sub delete_edge_attribute { 1629 my $g = shift; 1630 $g->expect_non_multiedged; 1631 my $attr = pop; 1632 return unless $g->has_edge( @_ ); 1633 $g->[ _E ]->_del_path_attr( $g->_vertex_ids( @_ ), $attr ); 1634} 1635 1636sub delete_edge_attribute_by_id { 1637 my $g = shift; 1638 $g->expect_multiedged; 1639 my $attr = pop; 1640 return unless $g->has_edge_by_id( @_ ); 1641 my $id = pop; 1642 $g->[ _E ]->_del_path_attr( $g->_vertex_ids( @_ ), $id, $attr ); 1643} 1644 1645### 1646# Compat. 1647# 1648 1649sub vertex { 1650 my $g = shift; 1651 $g->has_vertex( @_ ) ? @_ : undef; 1652} 1653 1654sub out_edges { 1655 my $g = shift; 1656 return unless @_ && $g->has_vertex( @_ ); 1657 my @e = $g->edges_from( @_ ); 1658 wantarray ? map { @$_ } @e : @e; 1659} 1660 1661sub in_edges { 1662 my $g = shift; 1663 return unless @_ && $g->has_vertex( @_ ); 1664 my @e = $g->edges_to( @_ ); 1665 wantarray ? map { @$_ } @e : @e; 1666} 1667 1668sub add_vertices { 1669 my $g = shift; 1670 $g->add_vertex( $_ ) for @_; 1671 return $g; 1672} 1673 1674sub add_edges { 1675 my $g = shift; 1676 while (@_) { 1677 my $u = shift @_; 1678 if (ref $u eq 'ARRAY') { 1679 $g->add_edge( @$u ); 1680 } else { 1681 if (@_) { 1682 my $v = shift @_; 1683 $g->add_edge( $u, $v ); 1684 } else { 1685 require Carp; 1686 Carp::croak("Graph::add_edges: missing end vertex"); 1687 } 1688 } 1689 } 1690 return $g; 1691} 1692 1693### 1694# More constructors. 1695# 1696 1697sub copy { 1698 my $g = shift; 1699 my %opt = _get_options( \@_ ); 1700 1701 my $c = 1702 (ref $g)->new(map { $_ => $g->$_ ? 1 : 0 } 1703 qw(directed 1704 compat02 1705 refvertexed 1706 hypervertexed 1707 countvertexed 1708 multivertexed 1709 hyperedged 1710 countedged 1711 multiedged 1712 omniedged 1713 __stringified)); 1714 for my $v ($g->isolated_vertices) { $c->add_vertex($v) } 1715 for my $e ($g->edges05) { $c->add_edge(@$e) } 1716 1717 return $c; 1718} 1719 1720*copy_graph = \© 1721 1722sub _deep_copy_Storable { 1723 my $g = shift; 1724 my $safe = new Safe; 1725 local $Storable::Deparse = 1; 1726 local $Storable::Eval = sub { $safe->reval($_[0]) }; 1727 return Storable::thaw(Storable::freeze($g)); 1728} 1729 1730sub _deep_copy_DataDumper { 1731 my $g = shift; 1732 my $d = Data::Dumper->new([$g]); 1733 use vars qw($VAR1); 1734 $d->Purity(1)->Terse(1)->Deepcopy(1); 1735 $d->Deparse(1) if $] >= 5.008; 1736 eval $d->Dump; 1737} 1738 1739sub deep_copy { 1740 if (_can_deep_copy_Storable()) { 1741 return _deep_copy_Storable(@_); 1742 } else { 1743 return _deep_copy_DataDumper(@_); 1744 } 1745} 1746 1747*deep_copy_graph = \&deep_copy; 1748 1749sub transpose_edge { 1750 my $g = shift; 1751 if ($g->is_directed) { 1752 return undef unless $g->has_edge( @_ ); 1753 my $c = $g->get_edge_count( @_ ); 1754 my $a = $g->get_edge_attributes( @_ ); 1755 my @e = reverse @_; 1756 $g->delete_edge( @_ ) unless $g->has_edge( @e ); 1757 $g->add_edge( @e ) for 1..$c; 1758 $g->set_edge_attributes(@e, $a) if $a; 1759 } 1760 return $g; 1761} 1762 1763sub transpose_graph { 1764 my $g = shift; 1765 my $t = $g->copy; 1766 if ($t->directed) { 1767 for my $e ($t->edges05) { 1768 $t->transpose_edge(@$e); 1769 } 1770 } 1771 return $t; 1772} 1773 1774*transpose = \&transpose_graph; 1775 1776sub complete_graph { 1777 my $g = shift; 1778 my $c = $g->new( directed => $g->directed ); 1779 my @v = $g->vertices05; 1780 for (my $i = 0; $i <= $#v; $i++ ) { 1781 for (my $j = 0; $j <= $#v; $j++ ) { 1782 next if $i >= $j; 1783 if ($g->is_undirected) { 1784 $c->add_edge($v[$i], $v[$j]); 1785 } else { 1786 $c->add_edge($v[$i], $v[$j]); 1787 $c->add_edge($v[$j], $v[$i]); 1788 } 1789 } 1790 } 1791 return $c; 1792} 1793 1794*complement = \&complement_graph; 1795 1796sub complement_graph { 1797 my $g = shift; 1798 my $c = $g->new( directed => $g->directed ); 1799 my @v = $g->vertices05; 1800 for (my $i = 0; $i <= $#v; $i++ ) { 1801 for (my $j = 0; $j <= $#v; $j++ ) { 1802 next if $i >= $j; 1803 if ($g->is_undirected) { 1804 $c->add_edge($v[$i], $v[$j]) 1805 unless $g->has_edge($v[$i], $v[$j]); 1806 } else { 1807 $c->add_edge($v[$i], $v[$j]) 1808 unless $g->has_edge($v[$i], $v[$j]); 1809 $c->add_edge($v[$j], $v[$i]) 1810 unless $g->has_edge($v[$j], $v[$i]); 1811 } 1812 } 1813 } 1814 return $c; 1815} 1816 1817*complete = \&complete_graph; 1818 1819### 1820# Transitivity. 1821# 1822 1823sub is_transitive { 1824 my $g = shift; 1825 Graph::TransitiveClosure::is_transitive($g); 1826} 1827 1828### 1829# Weighted vertices. 1830# 1831 1832my $defattr = 'weight'; 1833 1834sub _defattr { 1835 return $defattr; 1836} 1837 1838sub add_weighted_vertex { 1839 my $g = shift; 1840 $g->expect_non_multivertexed; 1841 my $w = pop; 1842 $g->add_vertex(@_); 1843 $g->set_vertex_attribute(@_, $defattr, $w); 1844} 1845 1846sub add_weighted_vertices { 1847 my $g = shift; 1848 $g->expect_non_multivertexed; 1849 while (@_) { 1850 my ($v, $w) = splice @_, 0, 2; 1851 $g->add_vertex($v); 1852 $g->set_vertex_attribute($v, $defattr, $w); 1853 } 1854} 1855 1856sub get_vertex_weight { 1857 my $g = shift; 1858 $g->expect_non_multivertexed; 1859 $g->get_vertex_attribute(@_, $defattr); 1860} 1861 1862sub has_vertex_weight { 1863 my $g = shift; 1864 $g->expect_non_multivertexed; 1865 $g->has_vertex_attribute(@_, $defattr); 1866} 1867 1868sub set_vertex_weight { 1869 my $g = shift; 1870 $g->expect_non_multivertexed; 1871 my $w = pop; 1872 $g->set_vertex_attribute(@_, $defattr, $w); 1873} 1874 1875sub delete_vertex_weight { 1876 my $g = shift; 1877 $g->expect_non_multivertexed; 1878 $g->delete_vertex_attribute(@_, $defattr); 1879} 1880 1881sub add_weighted_vertex_by_id { 1882 my $g = shift; 1883 $g->expect_multivertexed; 1884 my $w = pop; 1885 $g->add_vertex_by_id(@_); 1886 $g->set_vertex_attribute_by_id(@_, $defattr, $w); 1887} 1888 1889sub add_weighted_vertices_by_id { 1890 my $g = shift; 1891 $g->expect_multivertexed; 1892 my $id = pop; 1893 while (@_) { 1894 my ($v, $w) = splice @_, 0, 2; 1895 $g->add_vertex_by_id($v, $id); 1896 $g->set_vertex_attribute_by_id($v, $id, $defattr, $w); 1897 } 1898} 1899 1900sub get_vertex_weight_by_id { 1901 my $g = shift; 1902 $g->expect_multivertexed; 1903 $g->get_vertex_attribute_by_id(@_, $defattr); 1904} 1905 1906sub has_vertex_weight_by_id { 1907 my $g = shift; 1908 $g->expect_multivertexed; 1909 $g->has_vertex_attribute_by_id(@_, $defattr); 1910} 1911 1912sub set_vertex_weight_by_id { 1913 my $g = shift; 1914 $g->expect_multivertexed; 1915 my $w = pop; 1916 $g->set_vertex_attribute_by_id(@_, $defattr, $w); 1917} 1918 1919sub delete_vertex_weight_by_id { 1920 my $g = shift; 1921 $g->expect_multivertexed; 1922 $g->delete_vertex_attribute_by_id(@_, $defattr); 1923} 1924 1925### 1926# Weighted edges. 1927# 1928 1929sub add_weighted_edge { 1930 my $g = shift; 1931 $g->expect_non_multiedged; 1932 if ($g->is_compat02) { 1933 my $w = splice @_, 1, 1; 1934 $g->add_edge(@_); 1935 $g->set_edge_attribute(@_, $defattr, $w); 1936 } else { 1937 my $w = pop; 1938 $g->add_edge(@_); 1939 $g->set_edge_attribute(@_, $defattr, $w); 1940 } 1941} 1942 1943sub add_weighted_edges { 1944 my $g = shift; 1945 $g->expect_non_multiedged; 1946 if ($g->is_compat02) { 1947 while (@_) { 1948 my ($u, $w, $v) = splice @_, 0, 3; 1949 $g->add_edge($u, $v); 1950 $g->set_edge_attribute($u, $v, $defattr, $w); 1951 } 1952 } else { 1953 while (@_) { 1954 my ($u, $v, $w) = splice @_, 0, 3; 1955 $g->add_edge($u, $v); 1956 $g->set_edge_attribute($u, $v, $defattr, $w); 1957 } 1958 } 1959} 1960 1961sub add_weighted_edges_by_id { 1962 my $g = shift; 1963 $g->expect_multiedged; 1964 my $id = pop; 1965 while (@_) { 1966 my ($u, $v, $w) = splice @_, 0, 3; 1967 $g->add_edge_by_id($u, $v, $id); 1968 $g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w); 1969 } 1970} 1971 1972sub add_weighted_path { 1973 my $g = shift; 1974 $g->expect_non_multiedged; 1975 my $u = shift; 1976 while (@_) { 1977 my ($w, $v) = splice @_, 0, 2; 1978 $g->add_edge($u, $v); 1979 $g->set_edge_attribute($u, $v, $defattr, $w); 1980 $u = $v; 1981 } 1982} 1983 1984sub get_edge_weight { 1985 my $g = shift; 1986 $g->expect_non_multiedged; 1987 $g->get_edge_attribute(@_, $defattr); 1988} 1989 1990sub has_edge_weight { 1991 my $g = shift; 1992 $g->expect_non_multiedged; 1993 $g->has_edge_attribute(@_, $defattr); 1994} 1995 1996sub set_edge_weight { 1997 my $g = shift; 1998 $g->expect_non_multiedged; 1999 my $w = pop; 2000 $g->set_edge_attribute(@_, $defattr, $w); 2001} 2002 2003sub delete_edge_weight { 2004 my $g = shift; 2005 $g->expect_non_multiedged; 2006 $g->delete_edge_attribute(@_, $defattr); 2007} 2008 2009sub add_weighted_edge_by_id { 2010 my $g = shift; 2011 $g->expect_multiedged; 2012 if ($g->is_compat02) { 2013 my $w = splice @_, 1, 1; 2014 $g->add_edge_by_id(@_); 2015 $g->set_edge_attribute_by_id(@_, $defattr, $w); 2016 } else { 2017 my $w = pop; 2018 $g->add_edge_by_id(@_); 2019 $g->set_edge_attribute_by_id(@_, $defattr, $w); 2020 } 2021} 2022 2023sub add_weighted_path_by_id { 2024 my $g = shift; 2025 $g->expect_multiedged; 2026 my $id = pop; 2027 my $u = shift; 2028 while (@_) { 2029 my ($w, $v) = splice @_, 0, 2; 2030 $g->add_edge_by_id($u, $v, $id); 2031 $g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w); 2032 $u = $v; 2033 } 2034} 2035 2036sub get_edge_weight_by_id { 2037 my $g = shift; 2038 $g->expect_multiedged; 2039 $g->get_edge_attribute_by_id(@_, $defattr); 2040} 2041 2042sub has_edge_weight_by_id { 2043 my $g = shift; 2044 $g->expect_multiedged; 2045 $g->has_edge_attribute_by_id(@_, $defattr); 2046} 2047 2048sub set_edge_weight_by_id { 2049 my $g = shift; 2050 $g->expect_multiedged; 2051 my $w = pop; 2052 $g->set_edge_attribute_by_id(@_, $defattr, $w); 2053} 2054 2055sub delete_edge_weight_by_id { 2056 my $g = shift; 2057 $g->expect_multiedged; 2058 $g->delete_edge_attribute_by_id(@_, $defattr); 2059} 2060 2061### 2062# Error helpers. 2063# 2064 2065my %expected; 2066@expected{qw(directed undirected acyclic)} = qw(undirected directed cyclic); 2067 2068sub _expected { 2069 my $exp = shift; 2070 my $got = @_ ? shift : $expected{$exp}; 2071 $got = defined $got ? ", got $got" : ""; 2072 if (my @caller2 = caller(2)) { 2073 die "$caller2[3]: expected $exp graph$got, at $caller2[1] line $caller2[2].\n"; 2074 } else { 2075 my @caller1 = caller(1); 2076 die "$caller1[3]: expected $exp graph$got, at $caller1[1] line $caller1[2].\n"; 2077 } 2078} 2079 2080sub expect_undirected { 2081 my $g = shift; 2082 _expected('undirected') unless $g->is_undirected; 2083} 2084 2085sub expect_directed { 2086 my $g = shift; 2087 _expected('directed') unless $g->is_directed; 2088} 2089 2090sub expect_acyclic { 2091 my $g = shift; 2092 _expected('acyclic') unless $g->is_acyclic; 2093} 2094 2095sub expect_dag { 2096 my $g = shift; 2097 my @got; 2098 push @got, 'undirected' unless $g->is_directed; 2099 push @got, 'cyclic' unless $g->is_acyclic; 2100 _expected('directed acyclic', "@got") if @got; 2101} 2102 2103sub expect_multivertexed { 2104 my $g = shift; 2105 _expected('multivertexed') unless $g->is_multivertexed; 2106} 2107 2108sub expect_non_multivertexed { 2109 my $g = shift; 2110 _expected('non-multivertexed') if $g->is_multivertexed; 2111} 2112 2113sub expect_non_multiedged { 2114 my $g = shift; 2115 _expected('non-multiedged') if $g->is_multiedged; 2116} 2117 2118sub expect_multiedged { 2119 my $g = shift; 2120 _expected('multiedged') unless $g->is_multiedged; 2121} 2122 2123sub expect_non_unionfind { 2124 my $g = shift; 2125 _expected('non-unionfind') if $g->has_union_find; 2126} 2127 2128sub _get_options { 2129 my @caller = caller(1); 2130 unless (@_ == 1 && ref $_[0] eq 'ARRAY') { 2131 die "$caller[3]: internal error: should be called with only one array ref argument, at $caller[1] line $caller[2].\n"; 2132 } 2133 my @opt = @{ $_[0] }; 2134 unless (@opt % 2 == 0) { 2135 die "$caller[3]: expected an options hash, got a non-even number of arguments, at $caller[1] line $caller[2].\n"; 2136 } 2137 return @opt; 2138} 2139 2140### 2141# Random constructors and accessors. 2142# 2143 2144sub __fisher_yates_shuffle (@) { 2145 # From perlfaq4, but modified to be non-modifying. 2146 my @a = @_; 2147 my $i = @a; 2148 while ($i--) { 2149 my $j = int rand ($i+1); 2150 @a[$i,$j] = @a[$j,$i]; 2151 } 2152 return @a; 2153} 2154 2155BEGIN { 2156 sub _shuffle(@); 2157 # Workaround for the Perl bug [perl #32383] where -d:Dprof and 2158 # List::Util::shuffle do not like each other: if any debugging 2159 # (-d) flags are on, fall back to our own Fisher-Yates shuffle. 2160 # The bug was fixed by perl changes #26054 and #26062, which 2161 # went to Perl 5.9.3. If someone tests this with a pre-5.9.3 2162 # bleadperl that calls itself 5.9.3 but doesn't yet have the 2163 # patches, oh, well. 2164 *_shuffle = $^P && $] < 5.009003 ? 2165 \&__fisher_yates_shuffle : \&List::Util::shuffle; 2166} 2167 2168sub random_graph { 2169 my $class = (@_ % 2) == 0 ? 'Graph' : shift; 2170 my %opt = _get_options( \@_ ); 2171 my $random_edge; 2172 unless (exists $opt{vertices} && defined $opt{vertices}) { 2173 require Carp; 2174 Carp::croak("Graph::random_graph: argument 'vertices' missing or undef"); 2175 } 2176 if (exists $opt{random_seed}) { 2177 srand($opt{random_seed}); 2178 delete $opt{random_seed}; 2179 } 2180 if (exists $opt{random_edge}) { 2181 $random_edge = $opt{random_edge}; 2182 delete $opt{random_edge}; 2183 } 2184 my @V; 2185 if (my $ref = ref $opt{vertices}) { 2186 if ($ref eq 'ARRAY') { 2187 @V = @{ $opt{vertices} }; 2188 } else { 2189 Carp::croak("Graph::random_graph: argument 'vertices' illegal"); 2190 } 2191 } else { 2192 @V = 0..($opt{vertices} - 1); 2193 } 2194 delete $opt{vertices}; 2195 my $V = @V; 2196 my $C = $V * ($V - 1) / 2; 2197 my $E; 2198 if (exists $opt{edges} && exists $opt{edges_fill}) { 2199 Carp::croak("Graph::random_graph: both arguments 'edges' and 'edges_fill' specified"); 2200 } 2201 $E = exists $opt{edges_fill} ? $opt{edges_fill} * $C : $opt{edges}; 2202 delete $opt{edges}; 2203 delete $opt{edges_fill}; 2204 my $g = $class->new(%opt); 2205 $g->add_vertices(@V); 2206 return $g if $V < 2; 2207 $C *= 2 if $g->directed; 2208 $E = $C / 2 unless defined $E; 2209 $E = int($E + 0.5); 2210 my $p = $E / $C; 2211 $random_edge = sub { $p } unless defined $random_edge; 2212 # print "V = $V, E = $E, C = $C, p = $p\n"; 2213 if ($p > 1.0 && !($g->countedged || $g->multiedged)) { 2214 require Carp; 2215 Carp::croak("Graph::random_graph: needs to be countedged or multiedged ($E > $C)"); 2216 } 2217 my @V1 = @V; 2218 my @V2 = @V; 2219 # Shuffle the vertex lists so that the pairs at 2220 # the beginning of the lists are not more likely. 2221 @V1 = _shuffle @V1; 2222 @V2 = _shuffle @V2; 2223 LOOP: 2224 while ($E) { 2225 for my $v1 (@V1) { 2226 for my $v2 (@V2) { 2227 next if $v1 eq $v2; # TODO: allow self-loops? 2228 my $q = $random_edge->($g, $v1, $v2, $p); 2229 if ($q && ($q == 1 || rand() <= $q) && 2230 !$g->has_edge($v1, $v2)) { 2231 $g->add_edge($v1, $v2); 2232 $E--; 2233 last LOOP unless $E; 2234 } 2235 } 2236 } 2237 } 2238 return $g; 2239} 2240 2241sub random_vertex { 2242 my $g = shift; 2243 my @V = $g->vertices05; 2244 @V[rand @V]; 2245} 2246 2247sub random_edge { 2248 my $g = shift; 2249 my @E = $g->edges05; 2250 @E[rand @E]; 2251} 2252 2253sub random_successor { 2254 my ($g, $v) = @_; 2255 my @S = $g->successors($v); 2256 @S[rand @S]; 2257} 2258 2259sub random_predecessor { 2260 my ($g, $v) = @_; 2261 my @P = $g->predecessors($v); 2262 @P[rand @P]; 2263} 2264 2265### 2266# Algorithms. 2267# 2268 2269my $MST_comparator = sub { ($_[0] || 0) <=> ($_[1] || 0) }; 2270 2271sub _MST_attr { 2272 my $attr = shift; 2273 my $attribute = 2274 exists $attr->{attribute} ? 2275 $attr->{attribute} : $defattr; 2276 my $comparator = 2277 exists $attr->{comparator} ? 2278 $attr->{comparator} : $MST_comparator; 2279 return ($attribute, $comparator); 2280} 2281 2282sub _MST_edges { 2283 my ($g, $attr) = @_; 2284 my ($attribute, $comparator) = _MST_attr($attr); 2285 map { $_->[1] } 2286 sort { $comparator->($a->[0], $b->[0], $a->[1], $b->[1]) } 2287 map { [ $g->get_edge_attribute(@$_, $attribute), $_ ] } 2288 $g->edges05; 2289} 2290 2291sub MST_Kruskal { 2292 my ($g, %attr) = @_; 2293 2294 $g->expect_undirected; 2295 2296 my $MST = Graph::Undirected->new; 2297 2298 my $UF = Graph::UnionFind->new; 2299 for my $v ($g->vertices05) { $UF->add($v) } 2300 2301 for my $e ($g->_MST_edges(\%attr)) { 2302 my ($u, $v) = @$e; # TODO: hyperedges 2303 my $t0 = $UF->find( $u ); 2304 my $t1 = $UF->find( $v ); 2305 unless ($t0 eq $t1) { 2306 $UF->union($u, $v); 2307 $MST->add_edge($u, $v); 2308 } 2309 } 2310 2311 return $MST; 2312} 2313 2314sub _MST_add { 2315 my ($g, $h, $HF, $r, $attr, $unseen) = @_; 2316 for my $s ( grep { exists $unseen->{ $_ } } $g->successors( $r ) ) { 2317 $HF->add( Graph::MSTHeapElem->new( $r, $s, $g->get_edge_attribute( $r, $s, $attr ) ) ); 2318 } 2319} 2320 2321sub _next_alphabetic { shift; (sort keys %{ $_[0] })[0] } 2322sub _next_numeric { shift; (sort { $a <=> $b } keys %{ $_[0] })[0] } 2323sub _next_random { shift; (values %{ $_[0] })[ rand keys %{ $_[0] } ] } 2324 2325sub _root_opt { 2326 my $g = shift; 2327 my %opt = @_ == 1 ? ( first_root => $_[0] ) : _get_options( \@_ ); 2328 my %unseen; 2329 my @unseen = $g->vertices05; 2330 @unseen{ @unseen } = @unseen; 2331 @unseen = _shuffle @unseen; 2332 my $r; 2333 if (exists $opt{ start }) { 2334 $opt{ first_root } = $opt{ start }; 2335 $opt{ next_root } = undef; 2336 } 2337 if (exists $opt{ get_next_root }) { 2338 $opt{ next_root } = $opt{ get_next_root }; # Graph 0.201 compat. 2339 } 2340 if (exists $opt{ first_root }) { 2341 if (ref $opt{ first_root } eq 'CODE') { 2342 $r = $opt{ first_root }->( $g, \%unseen ); 2343 } else { 2344 $r = $opt{ first_root }; 2345 } 2346 } else { 2347 $r = shift @unseen; 2348 } 2349 my $next = 2350 exists $opt{ next_root } ? 2351 $opt{ next_root } : 2352 $opt{ next_alphabetic } ? 2353 \&_next_alphabetic : 2354 $opt{ next_numeric } ? \&_next_numeric : 2355 \&_next_random; 2356 my $code = ref $next eq 'CODE'; 2357 my $attr = exists $opt{ attribute } ? $opt{ attribute } : $defattr; 2358 return ( \%opt, \%unseen, \@unseen, $r, $next, $code, $attr ); 2359} 2360 2361sub _heap_walk { 2362 my ($g, $h, $add, $etc) = splice @_, 0, 4; # Leave %opt in @_. 2363 2364 my ($opt, $unseenh, $unseena, $r, $next, $code, $attr) = $g->_root_opt(@_); 2365 my $HF = Heap071::Fibonacci->new; 2366 2367 while (defined $r) { 2368 # print "r = $r\n"; 2369 $add->($g, $h, $HF, $r, $attr, $unseenh, $etc); 2370 delete $unseenh->{ $r }; 2371 while (defined $HF->top) { 2372 my $t = $HF->extract_top; 2373 # use Data::Dumper; print "t = ", Dumper($t); 2374 if (defined $t) { 2375 my ($u, $v, $w) = $t->val; 2376 # print "extracted top: $u $v $w\n"; 2377 if (exists $unseenh->{ $v }) { 2378 $h->set_edge_attribute($u, $v, $attr, $w); 2379 delete $unseenh->{ $v }; 2380 $add->($g, $h, $HF, $v, $attr, $unseenh, $etc); 2381 } 2382 } 2383 } 2384 return $h unless defined $next; 2385 $r = $code ? $next->( $g, $unseenh ) : shift @$unseena; 2386 } 2387 2388 return $h; 2389} 2390 2391sub MST_Prim { 2392 my $g = shift; 2393 $g->expect_undirected; 2394 $g->_heap_walk(Graph::Undirected->new(), \&_MST_add, undef, @_); 2395} 2396 2397*MST_Dijkstra = \&MST_Prim; 2398 2399*minimum_spanning_tree = \&MST_Prim; 2400 2401### 2402# Cycle detection. 2403# 2404 2405*is_cyclic = \&has_a_cycle; 2406 2407sub is_acyclic { 2408 my $g = shift; 2409 return !$g->is_cyclic; 2410} 2411 2412sub is_dag { 2413 my $g = shift; 2414 return $g->is_directed && $g->is_acyclic ? 1 : 0; 2415} 2416 2417*is_directed_acyclic_graph = \&is_dag; 2418 2419### 2420# Backward compat. 2421# 2422 2423sub average_degree { 2424 my $g = shift; 2425 my $V = $g->vertices05; 2426 2427 return $V ? $g->degree / $V : 0; 2428} 2429 2430sub density_limits { 2431 my $g = shift; 2432 2433 my $V = $g->vertices05; 2434 my $M = $V * ($V - 1); 2435 2436 $M /= 2 if $g->is_undirected; 2437 2438 return ( 0.25 * $M, 0.75 * $M, $M ); 2439} 2440 2441sub density { 2442 my $g = shift; 2443 my ($sparse, $dense, $complete) = $g->density_limits; 2444 2445 return $complete ? $g->edges / $complete : 0; 2446} 2447 2448### 2449# Attribute backward compat 2450# 2451 2452sub _attr02_012 { 2453 my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5; 2454 if ($g->is_compat02) { 2455 if (@_ == 0) { return $ga->( $g ) } 2456 elsif (@_ == 1) { return $va->( $g, @_ ) } 2457 elsif (@_ == 2) { return $ea->( $g, @_ ) } 2458 else { 2459 die sprintf "$op: wrong number of arguments (%d)", scalar @_; 2460 } 2461 } else { 2462 die "$op: not a compat02 graph" 2463 } 2464} 2465 2466sub _attr02_123 { 2467 my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5; 2468 if ($g->is_compat02) { 2469 if (@_ == 1) { return $ga->( $g, @_ ) } 2470 elsif (@_ == 2) { return $va->( $g, @_[1, 0] ) } 2471 elsif (@_ == 3) { return $ea->( $g, @_[1, 2, 0] ) } 2472 else { 2473 die sprintf "$op: wrong number of arguments (%d)", scalar @_; 2474 } 2475 } else { 2476 die "$op: not a compat02 graph" 2477 } 2478} 2479 2480sub _attr02_234 { 2481 my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5; 2482 if ($g->is_compat02) { 2483 if (@_ == 2) { return $ga->( $g, @_ ) } 2484 elsif (@_ == 3) { return $va->( $g, @_[1, 0, 2] ) } 2485 elsif (@_ == 4) { return $ea->( $g, @_[1, 2, 0, 3] ) } 2486 else { 2487 die sprintf "$op: wrong number of arguments (%d)", scalar @_; 2488 } 2489 } else { 2490 die "$op: not a compat02 graph"; 2491 } 2492} 2493 2494sub set_attribute { 2495 my $g = shift; 2496 $g->_attr02_234('set_attribute', 2497 \&Graph::set_graph_attribute, 2498 \&Graph::set_vertex_attribute, 2499 \&Graph::set_edge_attribute, 2500 @_); 2501 2502} 2503 2504sub set_attributes { 2505 my $g = shift; 2506 my $a = pop; 2507 $g->_attr02_123('set_attributes', 2508 \&Graph::set_graph_attributes, 2509 \&Graph::set_vertex_attributes, 2510 \&Graph::set_edge_attributes, 2511 $a, @_); 2512 2513} 2514 2515sub get_attribute { 2516 my $g = shift; 2517 $g->_attr02_123('get_attribute', 2518 \&Graph::get_graph_attribute, 2519 \&Graph::get_vertex_attribute, 2520 \&Graph::get_edge_attribute, 2521 @_); 2522 2523} 2524 2525sub get_attributes { 2526 my $g = shift; 2527 $g->_attr02_012('get_attributes', 2528 \&Graph::get_graph_attributes, 2529 \&Graph::get_vertex_attributes, 2530 \&Graph::get_edge_attributes, 2531 @_); 2532 2533} 2534 2535sub has_attribute { 2536 my $g = shift; 2537 return 0 unless @_; 2538 $g->_attr02_123('has_attribute', 2539 \&Graph::has_graph_attribute, 2540 \&Graph::has_vertex_attribute, 2541 \&Graph::get_edge_attribute, 2542 @_); 2543 2544} 2545 2546sub has_attributes { 2547 my $g = shift; 2548 $g->_attr02_012('has_attributes', 2549 \&Graph::has_graph_attributes, 2550 \&Graph::has_vertex_attributes, 2551 \&Graph::has_edge_attributes, 2552 @_); 2553 2554} 2555 2556sub delete_attribute { 2557 my $g = shift; 2558 $g->_attr02_123('delete_attribute', 2559 \&Graph::delete_graph_attribute, 2560 \&Graph::delete_vertex_attribute, 2561 \&Graph::delete_edge_attribute, 2562 @_); 2563 2564} 2565 2566sub delete_attributes { 2567 my $g = shift; 2568 $g->_attr02_012('delete_attributes', 2569 \&Graph::delete_graph_attributes, 2570 \&Graph::delete_vertex_attributes, 2571 \&Graph::delete_edge_attributes, 2572 @_); 2573 2574} 2575 2576### 2577# Simple DFS uses. 2578# 2579 2580sub topological_sort { 2581 my $g = shift; 2582 my %opt = _get_options( \@_ ); 2583 my $eic = $opt{ empty_if_cyclic }; 2584 my $hac; 2585 if ($eic) { 2586 $hac = $g->has_a_cycle; 2587 } else { 2588 $g->expect_dag; 2589 } 2590 delete $opt{ empty_if_cyclic }; 2591 my $t = Graph::Traversal::DFS->new($g, %opt); 2592 my @s = $t->dfs; 2593 $hac ? () : reverse @s; 2594} 2595 2596*toposort = \&topological_sort; 2597 2598sub _undirected_copy_compute { 2599 my $g = shift; 2600 my $c = Graph::Undirected->new; 2601 for my $v ($g->isolated_vertices) { # TODO: if iv ... 2602 $c->add_vertex($v); 2603 } 2604 for my $e ($g->edges05) { 2605 $c->add_edge(@$e); 2606 } 2607 return $c; 2608} 2609 2610sub undirected_copy { 2611 my $g = shift; 2612 $g->expect_directed; 2613 return _check_cache($g, 'undirected', \&_undirected_copy_compute); 2614} 2615 2616*undirected_copy_graph = \&undirected_copy; 2617 2618sub directed_copy { 2619 my $g = shift; 2620 $g->expect_undirected; 2621 my $c = Graph::Directed->new; 2622 for my $v ($g->isolated_vertices) { # TODO: if iv ... 2623 $c->add_vertex($v); 2624 } 2625 for my $e ($g->edges05) { 2626 my @e = @$e; 2627 $c->add_edge(@e); 2628 $c->add_edge(reverse @e); 2629 } 2630 return $c; 2631} 2632 2633*directed_copy_graph = \&directed_copy; 2634 2635### 2636# Cache or not. 2637# 2638 2639my %_cache_type = 2640 ( 2641 'connectivity' => '_ccc', 2642 'strong_connectivity' => '_scc', 2643 'biconnectivity' => '_bcc', 2644 'SPT_Dijkstra' => '_spt_di', 2645 'SPT_Bellman_Ford' => '_spt_bf', 2646 'undirected' => '_undirected', 2647 ); 2648 2649sub _check_cache { 2650 my ($g, $type, $code) = splice @_, 0, 3; 2651 my $c = $_cache_type{$type}; 2652 if (defined $c) { 2653 my $a = $g->get_graph_attribute($c); 2654 unless (defined $a && $a->[ 0 ] == $g->[ _G ]) { 2655 $a->[ 0 ] = $g->[ _G ]; 2656 $a->[ 1 ] = $code->( $g, @_ ); 2657 $g->set_graph_attribute($c, $a); 2658 } 2659 return $a->[ 1 ]; 2660 } else { 2661 Carp::croak("Graph: unknown cache type '$type'"); 2662 } 2663} 2664 2665sub _clear_cache { 2666 my ($g, $type) = @_; 2667 my $c = $_cache_type{$type}; 2668 if (defined $c) { 2669 $g->delete_graph_attribute($c); 2670 } else { 2671 Carp::croak("Graph: unknown cache type '$type'"); 2672 } 2673} 2674 2675sub connectivity_clear_cache { 2676 my $g = shift; 2677 _clear_cache($g, 'connectivity'); 2678} 2679 2680sub strong_connectivity_clear_cache { 2681 my $g = shift; 2682 _clear_cache($g, 'strong_connectivity'); 2683} 2684 2685sub biconnectivity_clear_cache { 2686 my $g = shift; 2687 _clear_cache($g, 'biconnectivity'); 2688} 2689 2690sub SPT_Dijkstra_clear_cache { 2691 my $g = shift; 2692 _clear_cache($g, 'SPT_Dijkstra'); 2693 $g->delete_graph_attribute('SPT_Dijkstra_first_root'); 2694} 2695 2696sub SPT_Bellman_Ford_clear_cache { 2697 my $g = shift; 2698 _clear_cache($g, 'SPT_Bellman_Ford'); 2699} 2700 2701sub undirected_copy_clear_cache { 2702 my $g = shift; 2703 _clear_cache($g, 'undirected_copy'); 2704} 2705 2706### 2707# Connected components. 2708# 2709 2710sub _connected_components_compute { 2711 my $g = shift; 2712 my %cce; 2713 my %cci; 2714 my $cc = 0; 2715 if ($g->has_union_find) { 2716 my $UF = $g->_get_union_find(); 2717 my $V = $g->[ _V ]; 2718 my %icce; # Isolated vertices. 2719 my %icci; 2720 my $icc = 0; 2721 for my $v ( $g->unique_vertices ) { 2722 $cc = $UF->find( $V->_get_path_id( $v ) ); 2723 if (defined $cc) { 2724 $cce{ $v } = $cc; 2725 push @{ $cci{ $cc } }, $v; 2726 } else { 2727 $icce{ $v } = $icc; 2728 push @{ $icci{ $icc } }, $v; 2729 $icc++; 2730 } 2731 } 2732 if ($icc) { 2733 @cce{ keys %icce } = values %icce; 2734 @cci{ keys %icci } = values %icci; 2735 } 2736 } else { 2737 my @u = $g->unique_vertices; 2738 my %r; @r{ @u } = @u; 2739 my $froot = sub { 2740 (each %r)[1]; 2741 }; 2742 my $nroot = sub { 2743 $cc++ if keys %r; 2744 (each %r)[1]; 2745 }; 2746 my $t = Graph::Traversal::DFS->new($g, 2747 first_root => $froot, 2748 next_root => $nroot, 2749 pre => sub { 2750 my ($v, $t) = @_; 2751 $cce{ $v } = $cc; 2752 push @{ $cci{ $cc } }, $v; 2753 delete $r{ $v }; 2754 }, 2755 @_); 2756 $t->dfs; 2757 } 2758 return [ \%cce, \%cci ]; 2759} 2760 2761sub _connected_components { 2762 my $g = shift; 2763 my $ccc = _check_cache($g, 'connectivity', 2764 \&_connected_components_compute, @_); 2765 return @{ $ccc }; 2766} 2767 2768sub connected_component_by_vertex { 2769 my ($g, $v) = @_; 2770 $g->expect_undirected; 2771 my ($CCE, $CCI) = $g->_connected_components(); 2772 return $CCE->{ $v }; 2773} 2774 2775sub connected_component_by_index { 2776 my ($g, $i) = @_; 2777 $g->expect_undirected; 2778 my ($CCE, $CCI) = $g->_connected_components(); 2779 return defined $CCI->{ $i } ? @{ $CCI->{ $i } } : ( ); 2780} 2781 2782sub connected_components { 2783 my $g = shift; 2784 $g->expect_undirected; 2785 my ($CCE, $CCI) = $g->_connected_components(); 2786 return values %{ $CCI }; 2787} 2788 2789sub same_connected_components { 2790 my $g = shift; 2791 $g->expect_undirected; 2792 if ($g->has_union_find) { 2793 my $UF = $g->_get_union_find(); 2794 my $V = $g->[ _V ]; 2795 my $u = shift; 2796 my $c = $UF->find( $V->_get_path_id ( $u ) ); 2797 my $d; 2798 for my $v ( @_) { 2799 return 0 2800 unless defined($d = $UF->find( $V->_get_path_id( $v ) )) && 2801 $d eq $c; 2802 } 2803 return 1; 2804 } else { 2805 my ($CCE, $CCI) = $g->_connected_components(); 2806 my $u = shift; 2807 my $c = $CCE->{ $u }; 2808 for my $v ( @_ ) { 2809 return 0 2810 unless defined $CCE->{ $v } && 2811 $CCE->{ $v } eq $c; 2812 } 2813 return 1; 2814 } 2815} 2816 2817my $super_component = sub { join("+", sort @_) }; 2818 2819sub connected_graph { 2820 my ($g, %opt) = @_; 2821 $g->expect_undirected; 2822 my $cg = Graph->new(undirected => 1); 2823 if ($g->has_union_find && $g->vertices == 1) { 2824 # TODO: super_component? 2825 $cg->add_vertices($g->vertices); 2826 } else { 2827 my $sc_cb = 2828 exists $opt{super_component} ? 2829 $opt{super_component} : $super_component; 2830 for my $cc ( $g->connected_components() ) { 2831 my $sc = $sc_cb->(@$cc); 2832 $cg->add_vertex($sc); 2833 $cg->set_vertex_attribute($sc, 'subvertices', [ @$cc ]); 2834 } 2835 } 2836 return $cg; 2837} 2838 2839sub is_connected { 2840 my $g = shift; 2841 $g->expect_undirected; 2842 my ($CCE, $CCI) = $g->_connected_components(); 2843 return keys %{ $CCI } == 1; 2844} 2845 2846sub is_weakly_connected { 2847 my $g = shift; 2848 $g->expect_directed; 2849 $g->undirected_copy->is_connected(@_); 2850} 2851 2852*weakly_connected = \&is_weakly_connected; 2853 2854sub weakly_connected_components { 2855 my $g = shift; 2856 $g->expect_directed; 2857 $g->undirected_copy->connected_components(@_); 2858} 2859 2860sub weakly_connected_component_by_vertex { 2861 my $g = shift; 2862 $g->expect_directed; 2863 $g->undirected_copy->connected_component_by_vertex(@_); 2864} 2865 2866sub weakly_connected_component_by_index { 2867 my $g = shift; 2868 $g->expect_directed; 2869 $g->undirected_copy->connected_component_by_index(@_); 2870} 2871 2872sub same_weakly_connected_components { 2873 my $g = shift; 2874 $g->expect_directed; 2875 $g->undirected_copy->same_connected_components(@_); 2876} 2877 2878sub weakly_connected_graph { 2879 my $g = shift; 2880 $g->expect_directed; 2881 $g->undirected_copy->connected_graph(@_); 2882} 2883 2884sub _strongly_connected_components_compute { 2885 my $g = shift; 2886 my $t = Graph::Traversal::DFS->new($g); 2887 my @d = reverse $t->dfs; 2888 my @c; 2889 my $h = $g->transpose_graph; 2890 my $u = 2891 Graph::Traversal::DFS->new($h, 2892 next_root => sub { 2893 my ($t, $u) = @_; 2894 my $root; 2895 while (defined($root = shift @d)) { 2896 last if exists $u->{ $root }; 2897 } 2898 if (defined $root) { 2899 push @c, []; 2900 return $root; 2901 } else { 2902 return; 2903 } 2904 }, 2905 pre => sub { 2906 my ($v, $t) = @_; 2907 push @{ $c[-1] }, $v; 2908 }, 2909 @_); 2910 $u->dfs; 2911 return \@c; 2912} 2913 2914sub _strongly_connected_components { 2915 my $g = shift; 2916 my $type = 'strong_connectivity'; 2917 my $scc = _check_cache($g, $type, 2918 \&_strongly_connected_components_compute, @_); 2919 return defined $scc ? @$scc : ( ); 2920} 2921 2922sub strongly_connected_components { 2923 my $g = shift; 2924 $g->expect_directed; 2925 $g->_strongly_connected_components(@_); 2926} 2927 2928sub strongly_connected_component_by_vertex { 2929 my $g = shift; 2930 my $v = shift; 2931 $g->expect_directed; 2932 my @scc = $g->_strongly_connected_components( next_alphabetic => 1, @_ ); 2933 for (my $i = 0; $i <= $#scc; $i++) { 2934 for (my $j = 0; $j <= $#{ $scc[$i] }; $j++) { 2935 return $i if $scc[$i]->[$j] eq $v; 2936 } 2937 } 2938 return; 2939} 2940 2941sub strongly_connected_component_by_index { 2942 my $g = shift; 2943 my $i = shift; 2944 $g->expect_directed; 2945 my $c = ( $g->_strongly_connected_components(@_) )[ $i ]; 2946 return defined $c ? @{ $c } : (); 2947} 2948 2949sub same_strongly_connected_components { 2950 my $g = shift; 2951 $g->expect_directed; 2952 my @scc = $g->_strongly_connected_components( next_alphabetic => 1, @_ ); 2953 my @i; 2954 while (@_) { 2955 my $v = shift; 2956 for (my $i = 0; $i <= $#scc; $i++) { 2957 for (my $j = 0; $j <= $#{ $scc[$i] }; $j++) { 2958 if ($scc[$i]->[$j] eq $v) { 2959 push @i, $i; 2960 return 0 if @i > 1 && $i[-1] ne $i[0]; 2961 } 2962 } 2963 } 2964 } 2965 return 1; 2966} 2967 2968sub is_strongly_connected { 2969 my $g = shift; 2970 $g->expect_directed; 2971 my $t = Graph::Traversal::DFS->new($g); 2972 my @d = reverse $t->dfs; 2973 my @c; 2974 my $h = $g->transpose; 2975 my $u = 2976 Graph::Traversal::DFS->new($h, 2977 next_root => sub { 2978 my ($t, $u) = @_; 2979 my $root; 2980 while (defined($root = shift @d)) { 2981 last if exists $u->{ $root }; 2982 } 2983 if (defined $root) { 2984 unless (@{ $t->{ roots } }) { 2985 push @c, []; 2986 return $root; 2987 } else { 2988 $t->terminate; 2989 return; 2990 } 2991 } else { 2992 return; 2993 } 2994 }, 2995 pre => sub { 2996 my ($v, $t) = @_; 2997 push @{ $c[-1] }, $v; 2998 }, 2999 @_); 3000 $u->dfs; 3001 return @{ $u->{ roots } } == 1 && keys %{ $u->{ unseen } } == 0; 3002} 3003 3004*strongly_connected = \&is_strongly_connected; 3005 3006sub strongly_connected_graph { 3007 my $g = shift; 3008 my %attr = @_; 3009 3010 $g->expect_directed; 3011 3012 my $t = Graph::Traversal::DFS->new($g); 3013 my @d = reverse $t->dfs; 3014 my @c; 3015 my $h = $g->transpose; 3016 my $u = 3017 Graph::Traversal::DFS->new($h, 3018 next_root => sub { 3019 my ($t, $u) = @_; 3020 my $root; 3021 while (defined($root = shift @d)) { 3022 last if exists $u->{ $root }; 3023 } 3024 if (defined $root) { 3025 push @c, []; 3026 return $root; 3027 } else { 3028 return; 3029 } 3030 }, 3031 pre => sub { 3032 my ($v, $t) = @_; 3033 push @{ $c[-1] }, $v; 3034 } 3035 ); 3036 3037 $u->dfs; 3038 3039 my $sc_cb; 3040 my $hv_cb; 3041 3042 _opt_get(\%attr, super_component => \$sc_cb); 3043 _opt_get(\%attr, hypervertex => \$hv_cb); 3044 _opt_unknown(\%attr); 3045 3046 if (defined $hv_cb && !defined $sc_cb) { 3047 $sc_cb = sub { $hv_cb->( [ @_ ] ) }; 3048 } 3049 unless (defined $sc_cb) { 3050 $sc_cb = $super_component; 3051 } 3052 3053 my $s = Graph->new; 3054 3055 my %c; 3056 my @s; 3057 for (my $i = 0; $i < @c; $i++) { 3058 my $c = $c[$i]; 3059 $s->add_vertex( $s[$i] = $sc_cb->(@$c) ); 3060 $s->set_vertex_attribute($s[$i], 'subvertices', [ @$c ]); 3061 for my $v (@$c) { 3062 $c{$v} = $i; 3063 } 3064 } 3065 3066 my $n = @c; 3067 for my $v ($g->vertices) { 3068 unless (exists $c{$v}) { 3069 $c{$v} = $n; 3070 $s[$n] = $v; 3071 $n++; 3072 } 3073 } 3074 3075 for my $e ($g->edges05) { 3076 my ($u, $v) = @$e; # @TODO: hyperedges 3077 unless ($c{$u} == $c{$v}) { 3078 my ($p, $q) = ( $s[ $c{ $u } ], $s[ $c{ $v } ] ); 3079 $s->add_edge($p, $q) unless $s->has_edge($p, $q); 3080 } 3081 } 3082 3083 if (my @i = $g->isolated_vertices) { 3084 $s->add_vertices(map { $s[ $c{ $_ } ] } @i); 3085 } 3086 3087 return $s; 3088} 3089 3090### 3091# Biconnectivity. 3092# 3093 3094sub _biconnectivity_out { 3095 my ($state, $u, $v) = @_; 3096 if (exists $state->{stack}) { 3097 my @BC; 3098 while (@{$state->{stack}}) { 3099 my $e = pop @{$state->{stack}}; 3100 push @BC, $e; 3101 last if defined $u && $e->[0] eq $u && $e->[1] eq $v; 3102 } 3103 if (@BC) { 3104 push @{$state->{BC}}, \@BC; 3105 } 3106 } 3107} 3108 3109sub _biconnectivity_dfs { 3110 my ($g, $u, $state) = @_; 3111 $state->{num}->{$u} = $state->{dfs}++; 3112 $state->{low}->{$u} = $state->{num}->{$u}; 3113 for my $v ($g->successors($u)) { 3114 unless (exists $state->{num}->{$v}) { 3115 push @{$state->{stack}}, [$u, $v]; 3116 $state->{pred}->{$v} = $u; 3117 $state->{succ}->{$u}->{$v}++; 3118 _biconnectivity_dfs($g, $v, $state); 3119 if ($state->{low}->{$v} < $state->{low}->{$u}) { 3120 $state->{low}->{$u} = $state->{low}->{$v}; 3121 } 3122 if ($state->{low}->{$v} >= $state->{num}->{$u}) { 3123 _biconnectivity_out($state, $u, $v); 3124 } 3125 } elsif (defined $state->{pred}->{$u} && 3126 $state->{pred}->{$u} ne $v && 3127 $state->{num}->{$v} < $state->{num}->{$u}) { 3128 push @{$state->{stack}}, [$u, $v]; 3129 if ($state->{num}->{$v} < $state->{low}->{$u}) { 3130 $state->{low}->{$u} = $state->{num}->{$v}; 3131 } 3132 } 3133 } 3134} 3135 3136sub _biconnectivity_compute { 3137 my ($g) = @_; 3138 my %state; 3139 @{$state{BC}} = (); 3140 @{$state{BR}} = (); 3141 %{$state{V2BC}} = (); 3142 %{$state{BC2V}} = (); 3143 @{$state{AP}} = (); 3144 $state{dfs} = 0; 3145 my @u = _shuffle $g->vertices; 3146 for my $u (@u) { 3147 unless (exists $state{num}->{$u}) { 3148 _biconnectivity_dfs($g, $u, \%state); 3149 _biconnectivity_out(\%state); 3150 delete $state{stack}; 3151 } 3152 } 3153 3154 # Mark the components each vertex belongs to. 3155 my $bci = 0; 3156 for my $bc (@{$state{BC}}) { 3157 for my $e (@$bc) { 3158 for my $v (@$e) { 3159 $state{V2BC}->{$v}->{$bci}++; 3160 } 3161 } 3162 $bci++; 3163 } 3164 3165 # Any isolated vertices get each their own component. 3166 for my $v ($g->vertices) { 3167 unless (exists $state{V2BC}->{$v}) { 3168 $state{V2BC}->{$v}->{$bci++}++; 3169 } 3170 } 3171 3172 for my $v ($g->vertices) { 3173 for my $bc (keys %{$state{V2BC}->{$v}}) { 3174 $state{BC2V}->{$bc}->{$v}->{$bc}++; 3175 } 3176 } 3177 3178 # Articulation points / cut vertices are the vertices 3179 # which belong to more than one component. 3180 for my $v (keys %{$state{V2BC}}) { 3181 if (keys %{$state{V2BC}->{$v}} > 1) { 3182 push @{$state{AP}}, $v; 3183 } 3184 } 3185 3186 # Bridges / cut edges are the components of two vertices. 3187 for my $v (keys %{$state{BC2V}}) { 3188 my @v = keys %{$state{BC2V}->{$v}}; 3189 if (@v == 2) { 3190 push @{$state{BR}}, \@v; 3191 } 3192 } 3193 3194 # Create the subgraph components. 3195 my @sg; 3196 for my $bc (@{$state{BC}}) { 3197 my %v; 3198 my $w = Graph::Undirected->new(); 3199 for my $e (@$bc) { 3200 my ($u, $v) = @$e; 3201 $v{$u}++; 3202 $v{$v}++; 3203 $w->add_edge($u, $v); 3204 } 3205 push @sg, [ keys %v ]; 3206 } 3207 3208 return [ $state{AP}, \@sg, $state{BR}, $state{V2BC}, ]; 3209} 3210 3211sub biconnectivity { 3212 my $g = shift; 3213 $g->expect_undirected; 3214 my $bcc = _check_cache($g, 'biconnectivity', 3215 \&_biconnectivity_compute, @_); 3216 return defined $bcc ? @$bcc : ( ); 3217} 3218 3219sub is_biconnected { 3220 my $g = shift; 3221 my ($ap) = ($g->biconnectivity(@_))[0]; 3222 return $g->edges >= 2 ? @$ap == 0 : undef ; 3223} 3224 3225sub is_edge_connected { 3226 my $g = shift; 3227 my ($br) = ($g->biconnectivity(@_))[2]; 3228 return $g->edges >= 2 ? @$br == 0 : undef; 3229} 3230 3231sub is_edge_separable { 3232 my $g = shift; 3233 my ($br) = ($g->biconnectivity(@_))[2]; 3234 return $g->edges >= 2 ? @$br > 0 : undef; 3235} 3236 3237sub articulation_points { 3238 my $g = shift; 3239 my ($ap) = ($g->biconnectivity(@_))[0]; 3240 return @$ap; 3241} 3242 3243*cut_vertices = \&articulation_points; 3244 3245sub biconnected_components { 3246 my $g = shift; 3247 my ($bc) = ($g->biconnectivity(@_))[1]; 3248 return @$bc; 3249} 3250 3251sub biconnected_component_by_index { 3252 my $g = shift; 3253 my $i = shift; 3254 my ($bc) = ($g->biconnectivity(@_))[1]; 3255 return $bc->[ $i ]; 3256} 3257 3258sub biconnected_component_by_vertex { 3259 my $g = shift; 3260 my $v = shift; 3261 my ($v2bc) = ($g->biconnectivity(@_))[3]; 3262 return defined $v2bc->{ $v } ? keys %{ $v2bc->{ $v } } : (); 3263} 3264 3265sub same_biconnected_components { 3266 my $g = shift; 3267 my $u = shift; 3268 my @u = $g->biconnected_component_by_vertex($u, @_); 3269 return 0 unless @u; 3270 my %ubc; @ubc{ @u } = (); 3271 while (@_) { 3272 my $v = shift; 3273 my @v = $g->biconnected_component_by_vertex($v); 3274 if (@v) { 3275 my %vbc; @vbc{ @v } = (); 3276 my $vi; 3277 for my $ui (keys %ubc) { 3278 if (exists $vbc{ $ui }) { 3279 $vi = $ui; 3280 last; 3281 } 3282 } 3283 return 0 unless defined $vi; 3284 } 3285 } 3286 return 1; 3287} 3288 3289sub biconnected_graph { 3290 my ($g, %opt) = @_; 3291 my ($bc, $v2bc) = ($g->biconnectivity, %opt)[1, 3]; 3292 my $bcg = Graph::Undirected->new; 3293 my $sc_cb = 3294 exists $opt{super_component} ? 3295 $opt{super_component} : $super_component; 3296 for my $c (@$bc) { 3297 $bcg->add_vertex(my $s = $sc_cb->(@$c)); 3298 $bcg->set_vertex_attribute($s, 'subvertices', [ @$c ]); 3299 } 3300 my %k; 3301 for my $i (0..$#$bc) { 3302 my @u = @{ $bc->[ $i ] }; 3303 my %i; @i{ @u } = (); 3304 for my $j (0..$#$bc) { 3305 if ($i > $j) { 3306 my @v = @{ $bc->[ $j ] }; 3307 my %j; @j{ @v } = (); 3308 for my $u (@u) { 3309 if (exists $j{ $u }) { 3310 unless ($k{ $i }{ $j }++) { 3311 $bcg->add_edge($sc_cb->(@{$bc->[$i]}), 3312 $sc_cb->(@{$bc->[$j]})); 3313 } 3314 last; 3315 } 3316 } 3317 } 3318 } 3319 } 3320 return $bcg; 3321} 3322 3323sub bridges { 3324 my $g = shift; 3325 my ($br) = ($g->biconnectivity(@_))[2]; 3326 return defined $br ? @$br : (); 3327} 3328 3329### 3330# SPT. 3331# 3332 3333sub _SPT_add { 3334 my ($g, $h, $HF, $r, $attr, $unseen, $etc) = @_; 3335 my $etc_r = $etc->{ $r } || 0; 3336 for my $s ( grep { exists $unseen->{ $_ } } $g->successors( $r ) ) { 3337 my $t = $g->get_edge_attribute( $r, $s, $attr ); 3338 $t = 1 unless defined $t; 3339 if ($t < 0) { 3340 require Carp; 3341 Carp::croak("Graph::SPT_Dijkstra: edge $r-$s is negative ($t)"); 3342 } 3343 if (!defined($etc->{ $s }) || ($etc_r + $t) < $etc->{ $s }) { 3344 my $etc_s = $etc->{ $s } || 0; 3345 $etc->{ $s } = $etc_r + $t; 3346 # print "$r - $s : setting $s to $etc->{ $s } ($etc_r, $etc_s)\n"; 3347 $h->set_vertex_attribute( $s, $attr, $etc->{ $s }); 3348 $h->set_vertex_attribute( $s, 'p', $r ); 3349 $HF->add( Graph::SPTHeapElem->new($r, $s, $etc->{ $s }) ); 3350 } 3351 } 3352} 3353 3354sub _SPT_Dijkstra_compute { 3355} 3356 3357sub SPT_Dijkstra { 3358 my $g = shift; 3359 my %opt = @_ == 1 ? (first_root => $_[0]) : @_; 3360 my $first_root = $opt{ first_root }; 3361 unless (defined $first_root) { 3362 $opt{ first_root } = $first_root = $g->random_vertex(); 3363 } 3364 my $spt_di = $g->get_graph_attribute('_spt_di'); 3365 unless (defined $spt_di && exists $spt_di->{ $first_root } && $spt_di->{ $first_root }->[ 0 ] == $g->[ _G ]) { 3366 my %etc; 3367 my $sptg = $g->_heap_walk($g->new, \&_SPT_add, \%etc, %opt); 3368 $spt_di->{ $first_root } = [ $g->[ _G ], $sptg ]; 3369 $g->set_graph_attribute('_spt_di', $spt_di); 3370 } 3371 3372 my $spt = $spt_di->{ $first_root }->[ 1 ]; 3373 3374 $spt->set_graph_attribute('SPT_Dijkstra_root', $first_root); 3375 3376 return $spt; 3377} 3378 3379*SSSP_Dijkstra = \&SPT_Dijkstra; 3380 3381*single_source_shortest_paths = \&SPT_Dijkstra; 3382 3383sub SP_Dijkstra { 3384 my ($g, $u, $v) = @_; 3385 my $sptg = $g->SPT_Dijkstra(first_root => $u); 3386 my @path = ($v); 3387 my %seen; 3388 my $V = $g->vertices; 3389 my $p; 3390 while (defined($p = $sptg->get_vertex_attribute($v, 'p'))) { 3391 last if exists $seen{$p}; 3392 push @path, $p; 3393 $v = $p; 3394 $seen{$p}++; 3395 last if keys %seen == $V || $u eq $v; 3396 } 3397 @path = () if @path && $path[-1] ne $u; 3398 return reverse @path; 3399} 3400 3401sub __SPT_Bellman_Ford { 3402 my ($g, $u, $v, $attr, $d, $p, $c0, $c1) = @_; 3403 return unless $c0->{ $u }; 3404 my $w = $g->get_edge_attribute($u, $v, $attr); 3405 $w = 1 unless defined $w; 3406 if (defined $d->{ $v }) { 3407 if (defined $d->{ $u }) { 3408 if ($d->{ $v } > $d->{ $u } + $w) { 3409 $d->{ $v } = $d->{ $u } + $w; 3410 $p->{ $v } = $u; 3411 $c1->{ $v }++; 3412 } 3413 } # else !defined $d->{ $u } && defined $d->{ $v } 3414 } else { 3415 if (defined $d->{ $u }) { 3416 # defined $d->{ $u } && !defined $d->{ $v } 3417 $d->{ $v } = $d->{ $u } + $w; 3418 $p->{ $v } = $u; 3419 $c1->{ $v }++; 3420 } # else !defined $d->{ $u } && !defined $d->{ $v } 3421 } 3422} 3423 3424sub _SPT_Bellman_Ford { 3425 my ($g, $opt, $unseenh, $unseena, $r, $next, $code, $attr) = @_; 3426 my %d; 3427 return unless defined $r; 3428 $d{ $r } = 0; 3429 my %p; 3430 my $V = $g->vertices; 3431 my %c0; # Changed during the last iteration? 3432 $c0{ $r }++; 3433 for (my $i = 0; $i < $V; $i++) { 3434 my %c1; 3435 for my $e ($g->edges) { 3436 my ($u, $v) = @$e; 3437 __SPT_Bellman_Ford($g, $u, $v, $attr, \%d, \%p, \%c0, \%c1); 3438 if ($g->undirected) { 3439 __SPT_Bellman_Ford($g, $v, $u, $attr, \%d, \%p, \%c0, \%c1); 3440 } 3441 } 3442 %c0 = %c1 unless $i == $V - 1; 3443 } 3444 3445 for my $e ($g->edges) { 3446 my ($u, $v) = @$e; 3447 if (defined $d{ $u } && defined $d{ $v }) { 3448 my $d = $g->get_edge_attribute($u, $v, $attr); 3449 if (defined $d && $d{ $v } > $d{ $u } + $d) { 3450 require Carp; 3451 Carp::croak("Graph::SPT_Bellman_Ford: negative cycle exists"); 3452 } 3453 } 3454 } 3455 3456 return (\%p, \%d); 3457} 3458 3459sub _SPT_Bellman_Ford_compute { 3460} 3461 3462sub SPT_Bellman_Ford { 3463 my $g = shift; 3464 3465 my ($opt, $unseenh, $unseena, $r, $next, $code, $attr) = $g->_root_opt(@_); 3466 3467 unless (defined $r) { 3468 $r = $g->random_vertex(); 3469 return unless defined $r; 3470 } 3471 3472 my $spt_bf = $g->get_graph_attribute('_spt_bf'); 3473 unless (defined $spt_bf && 3474 exists $spt_bf->{ $r } && $spt_bf->{ $r }->[ 0 ] == $g->[ _G ]) { 3475 my ($p, $d) = 3476 $g->_SPT_Bellman_Ford($opt, $unseenh, $unseena, 3477 $r, $next, $code, $attr); 3478 my $h = $g->new; 3479 for my $v (keys %$p) { 3480 my $u = $p->{ $v }; 3481 $h->add_edge( $u, $v ); 3482 $h->set_edge_attribute( $u, $v, $attr, 3483 $g->get_edge_attribute($u, $v, $attr)); 3484 $h->set_vertex_attribute( $v, $attr, $d->{ $v } ); 3485 $h->set_vertex_attribute( $v, 'p', $u ); 3486 } 3487 $spt_bf->{ $r } = [ $g->[ _G ], $h ]; 3488 $g->set_graph_attribute('_spt_bf', $spt_bf); 3489 } 3490 3491 my $spt = $spt_bf->{ $r }->[ 1 ]; 3492 3493 $spt->set_graph_attribute('SPT_Bellman_Ford_root', $r); 3494 3495 return $spt; 3496} 3497 3498*SSSP_Bellman_Ford = \&SPT_Bellman_Ford; 3499 3500sub SP_Bellman_Ford { 3501 my ($g, $u, $v) = @_; 3502 my $sptg = $g->SPT_Bellman_Ford(first_root => $u); 3503 my @path = ($v); 3504 my %seen; 3505 my $V = $g->vertices; 3506 my $p; 3507 while (defined($p = $sptg->get_vertex_attribute($v, 'p'))) { 3508 last if exists $seen{$p}; 3509 push @path, $p; 3510 $v = $p; 3511 $seen{$p}++; 3512 last if keys %seen == $V; 3513 } 3514 # @path = () if @path && "$path[-1]" ne "$u"; 3515 return reverse @path; 3516} 3517 3518### 3519# Transitive Closure. 3520# 3521 3522sub TransitiveClosure_Floyd_Warshall { 3523 my $self = shift; 3524 my $class = ref $self || $self; 3525 $self = shift unless ref $self; 3526 bless Graph::TransitiveClosure->new($self, @_), $class; 3527} 3528 3529*transitive_closure = \&TransitiveClosure_Floyd_Warshall; 3530 3531sub APSP_Floyd_Warshall { 3532 my $self = shift; 3533 my $class = ref $self || $self; 3534 $self = shift unless ref $self; 3535 bless Graph::TransitiveClosure->new($self, path => 1, @_), $class; 3536} 3537 3538*all_pairs_shortest_paths = \&APSP_Floyd_Warshall; 3539 3540sub _transitive_closure_matrix_compute { 3541} 3542 3543sub transitive_closure_matrix { 3544 my $g = shift; 3545 my $tcm = $g->get_graph_attribute('_tcm'); 3546 if (defined $tcm) { 3547 if (ref $tcm eq 'ARRAY') { # YECHHH! 3548 if ($tcm->[ 0 ] == $g->[ _G ]) { 3549 $tcm = $tcm->[ 1 ]; 3550 } else { 3551 undef $tcm; 3552 } 3553 } 3554 } 3555 unless (defined $tcm) { 3556 my $apsp = $g->APSP_Floyd_Warshall(@_); 3557 $tcm = $apsp->get_graph_attribute('_tcm'); 3558 $g->set_graph_attribute('_tcm', [ $g->[ _G ], $tcm ]); 3559 } 3560 3561 return $tcm; 3562} 3563 3564sub path_length { 3565 my $g = shift; 3566 my $tcm = $g->transitive_closure_matrix; 3567 $tcm->path_length(@_); 3568} 3569 3570sub path_predecessor { 3571 my $g = shift; 3572 my $tcm = $g->transitive_closure_matrix; 3573 $tcm->path_predecessor(@_); 3574} 3575 3576sub path_vertices { 3577 my $g = shift; 3578 my $tcm = $g->transitive_closure_matrix; 3579 $tcm->path_vertices(@_); 3580} 3581 3582sub is_reachable { 3583 my $g = shift; 3584 my $tcm = $g->transitive_closure_matrix; 3585 $tcm->is_reachable(@_); 3586} 3587 3588sub for_shortest_paths { 3589 my $g = shift; 3590 my $c = shift; 3591 my $t = $g->transitive_closure_matrix; 3592 my @v = $g->vertices; 3593 my $n = 0; 3594 for my $u (@v) { 3595 for my $v (@v) { 3596 next unless $t->is_reachable($u, $v); 3597 $n++; 3598 $c->($t, $u, $v, $n); 3599 } 3600 } 3601 return $n; 3602} 3603 3604sub _minmax_path { 3605 my $g = shift; 3606 my $min; 3607 my $max; 3608 my $minp; 3609 my $maxp; 3610 $g->for_shortest_paths(sub { 3611 my ($t, $u, $v, $n) = @_; 3612 my $l = $t->path_length($u, $v); 3613 return unless defined $l; 3614 my $p; 3615 if ($u ne $v && (!defined $max || $l > $max)) { 3616 $max = $l; 3617 $maxp = $p = [ $t->path_vertices($u, $v) ]; 3618 } 3619 if ($u ne $v && (!defined $min || $l < $min)) { 3620 $min = $l; 3621 $minp = $p || [ $t->path_vertices($u, $v) ]; 3622 } 3623 }); 3624 return ($min, $max, $minp, $maxp); 3625} 3626 3627sub diameter { 3628 my $g = shift; 3629 my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_); 3630 return defined $maxp ? (wantarray ? @$maxp : $max) : undef; 3631} 3632 3633*graph_diameter = \&diameter; 3634 3635sub longest_path { 3636 my ($g, $u, $v) = @_; 3637 my $t = $g->transitive_closure_matrix; 3638 if (defined $u) { 3639 if (defined $v) { 3640 return wantarray ? 3641 $t->path_vertices($u, $v) : $t->path_length($u, $v); 3642 } else { 3643 my $max; 3644 my @max; 3645 for my $v ($g->vertices) { 3646 next if $u eq $v; 3647 my $l = $t->path_length($u, $v); 3648 if (defined $l && (!defined $max || $l > $max)) { 3649 $max = $l; 3650 @max = $t->path_vertices($u, $v); 3651 } 3652 } 3653 return wantarray ? @max : $max; 3654 } 3655 } else { 3656 if (defined $v) { 3657 my $max; 3658 my @max; 3659 for my $u ($g->vertices) { 3660 next if $u eq $v; 3661 my $l = $t->path_length($u, $v); 3662 if (defined $l && (!defined $max || $l > $max)) { 3663 $max = $l; 3664 @max = $t->path_vertices($u, $v); 3665 } 3666 } 3667 return wantarray ? @max : @max - 1; 3668 } else { 3669 my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_); 3670 return defined $maxp ? (wantarray ? @$maxp : $max) : undef; 3671 } 3672 } 3673} 3674 3675sub vertex_eccentricity { 3676 my ($g, $u) = @_; 3677 $g->expect_undirected; 3678 if ($g->is_connected) { 3679 my $max; 3680 for my $v ($g->vertices) { 3681 next if $u eq $v; 3682 my $l = $g->path_length($u, $v); 3683 if (defined $l && (!defined $max || $l > $max)) { 3684 $max = $l; 3685 } 3686 } 3687 return $max; 3688 } else { 3689 return Infinity(); 3690 } 3691} 3692 3693sub shortest_path { 3694 my ($g, $u, $v) = @_; 3695 $g->expect_undirected; 3696 my $t = $g->transitive_closure_matrix; 3697 if (defined $u) { 3698 if (defined $v) { 3699 return wantarray ? 3700 $t->path_vertices($u, $v) : $t->path_length($u, $v); 3701 } else { 3702 my $min; 3703 my @min; 3704 for my $v ($g->vertices) { 3705 next if $u eq $v; 3706 my $l = $t->path_length($u, $v); 3707 if (defined $l && (!defined $min || $l < $min)) { 3708 $min = $l; 3709 @min = $t->path_vertices($u, $v); 3710 } 3711 } 3712 return wantarray ? @min : $min; 3713 } 3714 } else { 3715 if (defined $v) { 3716 my $min; 3717 my @min; 3718 for my $u ($g->vertices) { 3719 next if $u eq $v; 3720 my $l = $t->path_length($u, $v); 3721 if (defined $l && (!defined $min || $l < $min)) { 3722 $min = $l; 3723 @min = $t->path_vertices($u, $v); 3724 } 3725 } 3726 return wantarray ? @min : $min; 3727 } else { 3728 my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_); 3729 return defined $minp ? (wantarray ? @$minp : $min) : undef; 3730 } 3731 } 3732} 3733 3734sub radius { 3735 my $g = shift; 3736 $g->expect_undirected; 3737 my ($center, $radius) = (undef, Infinity()); 3738 for my $v ($g->vertices) { 3739 my $x = $g->vertex_eccentricity($v); 3740 ($center, $radius) = ($v, $x) if defined $x && $x < $radius; 3741 } 3742 return $radius; 3743} 3744 3745sub center_vertices { 3746 my ($g, $delta) = @_; 3747 $g->expect_undirected; 3748 $delta = 0 unless defined $delta; 3749 $delta = abs($delta); 3750 my @c; 3751 my $r = $g->radius; 3752 if (defined $r) { 3753 for my $v ($g->vertices) { 3754 my $e = $g->vertex_eccentricity($v); 3755 next unless defined $e; 3756 push @c, $v if abs($e - $r) <= $delta; 3757 } 3758 } 3759 return @c; 3760} 3761 3762*centre_vertices = \¢er_vertices; 3763 3764sub average_path_length { 3765 my $g = shift; 3766 my @A = @_; 3767 my $d = 0; 3768 my $m = 0; 3769 my $n = $g->for_shortest_paths(sub { 3770 my ($t, $u, $v, $n) = @_; 3771 my $l = $t->path_length($u, $v); 3772 if ($l) { 3773 my $c = @A == 0 || 3774 (@A == 1 && $u eq $A[0]) || 3775 ((@A == 2) && 3776 (defined $A[0] && 3777 $u eq $A[0]) || 3778 (defined $A[1] && 3779 $v eq $A[1])); 3780 if ($c) { 3781 $d += $l; 3782 $m++; 3783 } 3784 } 3785 }); 3786 return $m ? $d / $m : undef; 3787} 3788 3789### 3790# Simple tests. 3791# 3792 3793sub is_multi_graph { 3794 my $g = shift; 3795 return 0 unless $g->is_multiedged || $g->is_countedged; 3796 my $multiedges = 0; 3797 for my $e ($g->edges05) { 3798 my ($u, @v) = @$e; 3799 for my $v (@v) { 3800 return 0 if $u eq $v; 3801 } 3802 $multiedges++ if $g->get_edge_count(@$e) > 1; 3803 } 3804 return $multiedges; 3805} 3806 3807sub is_simple_graph { 3808 my $g = shift; 3809 return 1 unless $g->is_countedged || $g->is_multiedged; 3810 for my $e ($g->edges05) { 3811 return 0 if $g->get_edge_count(@$e) > 1; 3812 } 3813 return 1; 3814} 3815 3816sub is_pseudo_graph { 3817 my $g = shift; 3818 my $m = $g->is_countedged || $g->is_multiedged; 3819 for my $e ($g->edges05) { 3820 my ($u, @v) = @$e; 3821 for my $v (@v) { 3822 return 1 if $u eq $v; 3823 } 3824 return 1 if $m && $g->get_edge_count($u, @v) > 1; 3825 } 3826 return 0; 3827} 3828 3829### 3830# Rough isomorphism guess. 3831# 3832 3833my %_factorial = (0 => 1, 1 => 1); 3834 3835sub __factorial { 3836 my $n = shift; 3837 for (my $i = 2; $i <= $n; $i++) { 3838 next if exists $_factorial{$i}; 3839 $_factorial{$i} = $i * $_factorial{$i - 1}; 3840 } 3841 $_factorial{$n}; 3842} 3843 3844sub _factorial { 3845 my $n = int(shift); 3846 if ($n < 0) { 3847 require Carp; 3848 Carp::croak("factorial of a negative number"); 3849 } 3850 __factorial($n) unless exists $_factorial{$n}; 3851 return $_factorial{$n}; 3852} 3853 3854sub could_be_isomorphic { 3855 my ($g0, $g1) = @_; 3856 return 0 unless $g0->vertices == $g1->vertices; 3857 return 0 unless $g0->edges05 == $g1->edges05; 3858 my %d0; 3859 for my $v0 ($g0->vertices) { 3860 $d0{ $g0->in_degree($v0) }{ $g0->out_degree($v0) }++ 3861 } 3862 my %d1; 3863 for my $v1 ($g1->vertices) { 3864 $d1{ $g1->in_degree($v1) }{ $g1->out_degree($v1) }++ 3865 } 3866 return 0 unless keys %d0 == keys %d1; 3867 for my $da (keys %d0) { 3868 return 0 3869 unless exists $d1{$da} && 3870 keys %{ $d0{$da} } == keys %{ $d1{$da} }; 3871 for my $db (keys %{ $d0{$da} }) { 3872 return 0 3873 unless exists $d1{$da}{$db} && 3874 $d0{$da}{$db} == $d1{$da}{$db}; 3875 } 3876 } 3877 for my $da (keys %d0) { 3878 for my $db (keys %{ $d0{$da} }) { 3879 return 0 unless $d1{$da}{$db} == $d0{$da}{$db}; 3880 } 3881 delete $d1{$da}; 3882 } 3883 return 0 unless keys %d1 == 0; 3884 my $f = 1; 3885 for my $da (keys %d0) { 3886 for my $db (keys %{ $d0{$da} }) { 3887 $f *= _factorial(abs($d0{$da}{$db})); 3888 } 3889 } 3890 return $f; 3891} 3892 3893### 3894# Analysis functions. 3895 3896sub subgraph_by_radius 3897{ 3898 my ($g, $n, $rad) = @_; 3899 3900 return unless defined $n && defined $rad && $rad >= 0; 3901 3902 my $r = (ref $g)->new; 3903 3904 if ($rad == 0) { 3905 return $r->add_vertex($n); 3906 } 3907 3908 my %h; 3909 $h{1} = [ [ $n, $g->successors($n) ] ]; 3910 for my $i (1..$rad) { 3911 $h{$i+1} = []; 3912 for my $arr (@{ $h{$i} }) { 3913 my ($p, @succ) = @{ $arr }; 3914 for my $s (@succ) { 3915 $r->add_edge($p, $s); 3916 push(@{ $h{$i+1} }, [$s, $g->successors($s)]) if $i < $rad; 3917 } 3918 } 3919 } 3920 3921 return $r; 3922} 3923 3924sub clustering_coefficient { 3925 my ($g) = @_; 3926 my %clustering; 3927 3928 my $gamma = 0; 3929 3930 for my $n ($g->vertices()) { 3931 my $gamma_v = 0; 3932 my @neigh = $g->successors($n); 3933 my %c; 3934 for my $u (@neigh) { 3935 for my $v (@neigh) { 3936 if (!$c{"$u-$v"} && $g->has_edge($u, $v)) { 3937 $gamma_v++; 3938 $c{"$u-$v"} = 1; 3939 $c{"$v-$u"} = 1; 3940 } 3941 } 3942 } 3943 if (@neigh > 1) { 3944 $clustering{$n} = $gamma_v/(@neigh * (@neigh - 1) / 2); 3945 $gamma += $gamma_v/(@neigh * (@neigh - 1) / 2); 3946 } else { 3947 $clustering{$n} = 0; 3948 } 3949 } 3950 3951 $gamma /= $g->vertices(); 3952 3953 return wantarray ? ($gamma, %clustering) : $gamma; 3954} 3955 3956sub betweenness { 3957 my $g = shift; 3958 3959 my @V = $g->vertices(); 3960 3961 my %Cb; # C_b{w} = 0 3962 3963 $Cb{$_} = 0 for @V; 3964 3965 for my $s (@V) { 3966 my @S; # stack (unshift, shift) 3967 3968 my %P; # P{w} = empty list 3969 $P{$_} = [] for @V; 3970 3971 my %sigma; # \sigma{t} = 0 3972 $sigma{$_} = 0 for @V; 3973 $sigma{$s} = 1; 3974 3975 my %d; # d{t} = -1; 3976 $d{$_} = -1 for @V; 3977 $d{$s} = 0; 3978 3979 my @Q; # queue (push, shift) 3980 push @Q, $s; 3981 3982 while (@Q) { 3983 my $v = shift @Q; 3984 unshift @S, $v; 3985 for my $w ($g->successors($v)) { 3986 # w found for first time 3987 if ($d{$w} < 0) { 3988 push @Q, $w; 3989 $d{$w} = $d{$v} + 1; 3990 } 3991 # Shortest path to w via v 3992 if ($d{$w} == $d{$v} + 1) { 3993 $sigma{$w} += $sigma{$v}; 3994 push @{ $P{$w} }, $v; 3995 } 3996 } 3997 } 3998 3999 my %delta; 4000 $delta{$_} = 0 for @V; 4001 4002 while (@S) { 4003 my $w = shift @S; 4004 for my $v (@{ $P{$w} }) { 4005 $delta{$v} += $sigma{$v}/$sigma{$w} * (1 + $delta{$w}); 4006 } 4007 if ($w ne $s) { 4008 $Cb{$w} += $delta{$w}; 4009 } 4010 } 4011 } 4012 4013 return %Cb; 4014} 4015 4016### 4017# Debugging. 4018# 4019 4020sub _dump { 4021 require Data::Dumper; 4022 my $d = Data::Dumper->new([$_[0]],[ref $_[0]]); 4023 defined wantarray ? $d->Dump : print $d->Dump; 4024} 4025 40261; 4027