Graph::ChuLiuEdmonds - Find minimum spanning trees in a directed graph.

    use Graph;
    use Graph::ChuLiuEdmonds;

    my $graph = Graph::Directed->new(vertices=>[qw(a b c d)]);
    $graph->add_weighted_edges(qw(a b 3 c d 7 d a 2 d b 1 c a 2));
    my $msts = $graph->MST_ChuLiuEdmonds($graph);
    ...

  my $msts = $graph->MST_ChuLiuEdmond();

  my $msts = $graph->MST_ChuLiuEdmond();

    perldoc Graph::ChuLiuEdmonds

package Graph::ChuLiuEdmonds;

use warnings;
use strict;

use Carp;
our $VERSION = '0.05';
our $DEBUG=0;

sub Graph::MST_ChuLiuEdmonds_no_copy {
  my ($graph)=@_;
  carp("graph not directed") unless $graph->is_directed;
  return _MST($graph);
}

sub Graph::MST_ChuLiuEdmonds {
  my ($graph)=@_;
  carp("graph not directed") unless $graph->is_directed;
  return _MST($graph->deep_copy);
}

sub _MST {
  my ($g)=@_;

  my %in; # in the resulting (or partial) MST, this will map a vertex Y to the vertex X
          # in which the unique edge incoming to Y starts
          # i.e maps Y => X if X->Y is an edge of the resulting MST

  # phase 1: add best edges and contract cycles
  my $cycle_no=0;
  my @V = $g->vertices;
  my $_no_vertices=@V;
  my @C;
  my ($x,$y,$w,$e);
  while (@V) {
    print "Graph: $g\n" if $DEBUG;
    $y = shift @V;
    my $best_w;
    print STDERR "selecting incoming edges for vertex $y\n" if $DEBUG;
    for my $e ($g->edges_to($y)) {
      $w = $g->get_edge_weight( $e->[0], $y );
      if (!defined($best_w) or $w<$best_w) {
	$best_w=$w;
	$x=$e->[0];
      }
    }
    next unless defined $best_w;
    print STDERR "best $x-$y: $best_w\n" if $DEBUG;
    # we add the best incoming edge edge to $y
    $in{$y}=$x;
    # now we check it does not add a cycle to the MST:
    my @cycle_nodes=($y);
    my $i=0;
    do {
      unshift @cycle_nodes, $x;
      $x=$in{$x};
      die "BUG: looking for a cycle caused an infinite loop" if $i++ > $_no_vertices; # just for sure: should never happen.
    } while (defined($x) and $x ne $y);
    if (defined $x) {
      # the new edge made a cycle:
      # contract
      my $cycle = 'CYCLE:'.($cycle_no++);
      print STDERR "$cycle: @cycle_nodes\n" if $DEBUG;
      my @cycle_weights = map { 
	print STDERR "  $_: $cycle_nodes[$_-1],$cycle_nodes[$_]\n" if $DEBUG;
	$g->get_edge_weight($cycle_nodes[$_-1],$cycle_nodes[$_]) } 0..$#cycle_nodes;
      print STDERR "cycle weights: @cycle_weights\n" if $DEBUG;
      push @V,$cycle;

      $g->add_vertex($cycle); # will represent the contracted @cycle_nodes

      my %in_cycle; @in_cycle{@cycle_nodes}=();

      # for each vertex in which ends an edge starting on the cycle,
      # find the lightest edge to be preserved
      my %from=(); my %fromW=();
      for $x (@cycle_nodes) {
	for my $e ($g->edges_from($x)) {
	  $y=$e->[1];
	  next if exists $in_cycle{$y};
	  if (exists $in{$y} and exists $in_cycle{$in{$y}}) {
	    $in{$y}=$cycle;
	  }
	  $w=$g->get_edge_weight($x,$y);
	  if (!exists($fromW{$y}) or $w < $fromW{$y}) {
	    $from{$y}=$x;
	    $fromW{$y}=$w;
	  }
	}
      }
      for $y (keys %from) {
	print STDERR "adding edge $cycle -> $y weight $fromW{$y}\n" if $DEBUG;
	$g->add_weighted_edge($cycle, $y, $fromW{$y});
      }

      # Similarly for edges that end on the cycle.
      # For each such edge X->Y with Y on the cycle
      # we compute a weight as w(X->Y)+the weight of the arc
      # of the cycle starting at Y and ending on a node preceding Y
      # in the cycle. For a fixed X we find Y on the cycle
      # for which this computed weight is minimal.
      my %to;
      my %toW=(); my $i=0;
      my $C=0; $C+=$_ for @cycle_weights; # weight of the whole cycle
      for $y (@cycle_nodes) {
	for $e ($g->edges_to($y)) {
	  $x=$e->[0];
	  next if exists $in_cycle{$x};
	  $w=$g->get_edge_weight($x,$y)+$C-$cycle_weights[$i];
	  if (!exists($toW{$x}) or $w < $toW{$x}) {
	    $to{$x}=$y;
	    $toW{$x}=$w;
	  }
	}
	$i++;
      }
      for my $x (keys %to) {
	print STDERR "adding edge $x -> $cycle weight $toW{$x}\n" if $DEBUG;
	$g->add_weighted_edge($x, $cycle, $toW{$x});
      }

      # delete the nodes of the @cycle_nodes
      $g->delete_vertices(@cycle_nodes);
      delete @in{@cycle_nodes};
      push @C,[$cycle,\@cycle_nodes,\@cycle_weights,\%to,\%from,\%toW,\%fromW];
    }
  }
  # ok, now we have processed all nodes, including the nodes
  # representing the contracted cycles.
  # there is at most one incoming edge to
  # each node (and exactly one if there was
  # at least one in the original graph).

  # prune all edges that are not in the resulting (contracted) MST
  print STDERR "before phase2: $g\n" if $DEBUG;
  for $y ($g->vertices) {
    $x=$in{$y};
    $g->delete_edges(map { @$_[0,1] } grep { !defined($x) or ($_->[0] ne $x) } $g->edges_to($y));
  }
  # phase 2: expand all cycles
  print STDERR "phase2: $g\n" if $DEBUG;
  while (@C) {
    my $C = pop @C;
    my ($cycle,$cycle_nodes,$cycle_weights,$to,$from,$toW,$fromW)=@$C;

    print STDERR "expanding: $cycle\n" if $DEBUG;
    $g->add_vertices(@$cycle_nodes);

    # fix incoming edge
    ($e) = $g->edges_to($cycle); # should now be at most one
    if ($e) {
      $x=$e->[0];
      $y = $to->{$x};
      $g->add_weighted_edge($x,$y,$toW->{$x});
      for my $i (0..$#$cycle_nodes) {
	$g->add_weighted_edge($cycle_nodes->[$i-1],$cycle_nodes->[$i],$cycle_weights->[$i]) unless $cycle_nodes->[$i] eq $y;
      }
    } else {
      # the whole graph starts at this cycle
      # find the edge with the lowest weight and disconnect there
      my $max;
      my $max_i; # the worst edge on the cycle
      my $i = 0;
      for my $w (@$cycle_weights) {
	if (!defined($max) or $w>$max) {
	  $max = $w;
	  $max_i=$i;
	}
	$i++
      }
      for $i (0..$#$cycle_nodes) {
	$g->add_weighted_edge($cycle_nodes->[$i-1],$cycle_nodes->[$i],$cycle_weights->[$i]) unless $i==$max_i;
      }
    }
    # fix outgoing edge
    for $e ($g->edges_from($cycle)) {
      $y = $e->[1];
      $x = $from->{$y};
      print STDERR "restoring edge $x -> $e->[1]\n" if $DEBUG;
      $g->add_weighted_edge($x,$y,$fromW->{$y});
    }
    $g->delete_vertex($cycle);
    print STDERR "expanded: $g\n" if $DEBUG;
  }
  # all cycles expanded, we are done!
  print STDERR "MST: $g\n" if $DEBUG;
  return $g;
}

1; # End of Graph::ChuLiuEdmonds