Re: [QUIZ] Perl 'Medium' Quiz: Graph Connected Components (#2006-12-29)

In article <9b18b3110701180634q2885bfa6ja4e337ffaed06cc-JsoAwUIsXosN+BqQ9rBEUg@public.gmane.org>,
	demerphq <[email protected]> writes:
> I think you missed the requirement that the arrays be returned in the
> same order to which their first element was encountered in the input.
>

Right, I missed that, I only kept edges inside a component in the
original order. The fixed version below returns the components in the
order that their first edge is seen. Gives me an excuse to use the
rarely used return value of push.

sub connected {
   my ($edges) = @_;

   my (%uf, %components, @components);
   $uf{root(\%uf, $uf{$_->[0]} ||= $_->[0])} = $uf{$_->[1]} ||= $_->[1] for
       @$edges;
   for my $edge (@$edges) {
       my $root = root(\%uf, $edge->[1]);
       push @components, $components{$root} if
           1 == push @{$components{$root}}, $edge;
   }
   return @components;
}

sub root {
   my ($uf, $u) = @_;
   $u = $uf->{$u} = $uf->{$uf->{$u}} while $uf->{$u} ne $u;
   return $u;
}

> Also it seems this class of algorithm cant handle multiple edeges
> between two nodes. Is that right?
>

No, multiple edges will work just fine. It will return an edge as many
times as it appears in the input.

I think (variations on) fast union find is the proper algorithm for this
problem. At least it's the only one that I know that is essentially
O(edges) (Ignoring the practically irrelevant inverse ackerman,
assuming perl hash lookup is linear and assuming array extension has an 
amortized linear cost). It also matches quite well with perl 
datastructures, though not perfectly. The %uf hash values could
have been made into real perl references, but the self reference at 
the end will not automatically get cleaned up on program exit. If we knew the 
integers assigned to the edges are the consecutive numbers starting 
from 0 (or 1), it would also probably be better to use an array instead
of a hash for the union pointers.

I'd be very interested to hear if there are other (essentially) linear
algorithms.

Here is the same code using real perl references, assuming node numbers
without holes (does not impact correctness, but does impact speed and
memory usage) and with sub root unrolled:

sub connected {
   my ($edges) = @_;

   my (@uf, %components, @components);

   # Create an array of self references
   my $max = -1;
   for my $edge (@$edges) {
       $max = $edge->[0] if $edge->[0] > $max;
       $max = $edge->[1] if $edge->[1] > $max;
   }
   $#uf = $max;
   $_ = \$_ for @uf;
       
   # Do standard unioning
   for my $edge (@$edges) {
       my $u = $uf[$edge->[0]];
       $u = $$u = $$$u while $$u != $u;
       $$u = $uf[$edge->[1]];
   }

   # Collect components
   for my $edge (@$edges) {
       my $u = $uf[$edge->[1]];
       $u = $$u = $$$u while $$u != $u;
       # or maybe use pack on refaddr instead....
       my $root = "$u";
       push @components, $components{$root} if 
           1 == push @{$components{$root}}, $edge;
   }

   # Force garbage collection
   $_ = undef for @uf;

   return @components;
}

Or, less tricky, the same but without perl references:

sub connected {
   my ($edges) = @_;

   my (@uf, @components, @order);

   # Create an array of self references
   my $max = -1;
   for my $edge (@$edges) {
       $max = $edge->[0] if $edge->[0] > $max;
       $max = $edge->[1] if $edge->[1] > $max;
   }
   @uf = 0..$max;
       
   # Do standard unioning
   for my $edge (@$edges) {
       my $u = $edge->[0];
       $u = $uf[$u] = $uf[$uf[$u]] while $uf[$u] != $u;
       $uf[$u] = $edge->[1];
   }

   # Collect components
   $#components = $max;
   for my $edge (@$edges) {
       my $u = $edge->[1];
       $u = $uf[$u] = $uf[$uf[$u]] while $uf[$u] != $u;
       push @order, $components[$u] if 
           1 == push @{$components[$u]}, $edge;
   }

   return @order;
}