perllib/Graph.pm

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