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

On Friday 29 December 2006 21:41, Shlomi Fish wrote:
> Hi all and Happy New Year!
>
> Here's a quiz for the new year. My sister received this challenge for her
> college homework, and had to write some Standard ML code to solve it, a
> task which I helped her with. I hope you enjoy it too.
>

The first thing I did before translating the SML code to Perl was write some 
tests:

<<<<<<<<<<<<<
#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 8;

use Connected_Functional;
# use Julien_Quint;

# TEST
is_deeply(connected([]), [],
    "Empty graph",
);
# TEST
is_deeply(connected([[1,2]]), [[[1,2]]],
    "One edge",
);
# TEST
is_deeply(connected([[1,3],[1,2]]), [[[1,3],[1,2]]],
    "Two connected edges",
);

# TEST
is_deeply(connected([[1,2],[3,4]]), [[[1,2]],[[3,4]]],
    "Two disconnected edges",
);


# TEST
is_deeply(
    connected(
        [[1,2],[3,4],[7,8],[1,3],[5,6],[8,6]]
    ),
    [
        [ [1,2], [3,4], [1,3] ],
        [ [7,8], [5,6], [8,6] ],
    ],
    "Two interleaving components",
);

# TEST
is_deeply(
    connected(
        [[1,2],[3,4],[90,90],[7,8],[1,3],[5,6],[8,6]]
    ),
    [
        [ [1,2], [3,4], [1,3] ],
        [ [90, 90] ],
        [ [7,8], [5,6], [8,6] ],
    ],
    "A self-link",
);

# TEST
is_deeply(
    connected(
        [[2,5],[5,6],[2,4],[8,12],[5,7],[4,9]]
    ),
    [
       [ [2,5], [5,6], [2,4], [5,7],[4,9] ],
       [ [8,12] ],
    ],
    "Funky ordering",
);
# TEST
is_deeply(
    connected(
        [[6,9],[100,102],[1,2],[3,4],[7,8],[1,3],[5,6],[8,6],[102,101]]
    ),
    [
        [ [6,9], [7,8], [5,6], [8,6] ],
        [ [100,102], [102,101], ],
        [ [1,2], [3,4], [1,3] ],

    ],
    "Grand finale",
);
>>>>>>>>>>>>>

Not all the tests were present in the initial version. Some of them were added 
later as bugs were discovered in the original SML code.

My solution works in two parts:

1. The do_connected() function is a recursive function that find the connected 
components but does not guarantee they'll be ordered correctly. It acts on 
Graph::Connected::Edge's that are edges' objects that contain the start 
vertex, the end vertex, and the index of the edge within the array.

2. The connected() function calls do_connected, then sorts the arrays 
according to their indexes (internally and externally), and finally converts 
the "G::C::Edge" objects back to tuples.

Here it is in all of its glory:

<<<<<<<<<<<<
use strict;
use warnings;

use List::Util (qw(reduce));
use List::MoreUtils (qw(any part));

# TODO : Remove later.
use Data::Dumper;

package Graph::Connected::Edge;

use base 'Class::Accessor';

# s and e are start and end.
__PACKAGE__->mk_accessors(qw(idx s e));

package main;

sub join_array
{
    return reduce { [@$a,@$b] } [], @_;
}

sub do_connected
{
    my $list = shift;

    if (! @$list)
    {
        return [];
    }

    my ($edge, @rest) = @$list;

    my ($i, $j) = ($edge->s(), $edge->e());

    my $connected_recurse = do_connected(\@rest);

    my $is_connected = sub {
        my $x = shift;
        return any { 
            my ($i1, $j1) = ($_->s(), $_->e());
            ($i==$i1) || ($i==$j1) || ($j==$i1) || ($j==$j1)
        } @$x;
    };

    my ($conn_to_edge, $not_conn_to_edge) = 
        part { $is_connected->($_) ? 0 : 1 } @$connected_recurse;

    $conn_to_edge ||= [];
    $not_conn_to_edge ||= [];

    my $component = join_array([$edge], @$conn_to_edge);

    return [$component,@$not_conn_to_edge];
}

sub connected
{
    my $list = shift;

    my @objects_list = 
        map { 
            my $e = $list->[$_]; 
            Graph::Connected::Edge->new(
                {
                    's' => $e->[0],
                    'e' => $e->[1],
                    'idx' => $_,
                }
            );
        } (0 .. $#$list);
    
    my $ret_unsorted = do_connected(\@objects_list);

    my @ret_inside_sorted = (map { [ sort { $a->idx() <=> $b->idx() } @$_ ] } 
@$ret_unsorted);

    my @ret_outside_sorted = (sort { $a->[0]->idx() <=> $b->[0]->idx() } 
@ret_inside_sorted);

    my @ret_wo_indexes = (map { [ map { [ $_->s(), $_->e() ] } @$_ ] } 
@ret_outside_sorted);

    return \@ret_wo_indexes;
}

1;
>>>>>>>>>>>>

Regards,

	Shlomi Fish

---------------------------------------------------------------------
Shlomi Fish      shlomif-ik1l9ssToec+JF/[email protected]
Homepage:        http://www.shlomifish.org/

Chuck Norris wrote a complete Perl 6 implementation in a day but then
destroyed all evidence with his bare hands, so no one will know his secrets.