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

On 1/6/07, demerphq <[email protected]> wrote:
> On 12/29/06, Shlomi Fish <shlomif-ik1l9ssToec+JF/[email protected]> wrote:
> > You should implement a function called "connected" that will receive such an
> > input and return its connected components, where a connected component is such
> > that for every two nodes in it, there's a path from one to the other. So for
> > the graph above the function will return:
> >
> > [
> >     [[$A,$B],[$B,$E],[$B,$F],[$F,$E]],
> >     [[$D,$C]],
> > ]
[...]
> > Input:
> > ------
> >
> > connected($list), where $list = \@list, and @list is made entirely of [$i,$j]
> > where $i and $j are integers.
> >
> > Output:
> > -------
> >
> > $ret = connected($list) where:
> >
> >     @comp1 = [ [$i1,$j1], [$i2, $j2], [$i3, $j3] ];
> >     @comp2 = [ [$k1,$l1], [$k2, $l2],... ];
> >     @components = ( \@comp1, \@comp2,... );
> >     $ret = [ @components ];
> >
> > ---------------------------
> >
> > Have fun!
>
> Hi, below is my solution.
>
> It wasnt clear to me what should happen for input like [[1,2],[2,1]]
> and [[1,2],[1,2]] so I made it output [[[1,2],[2,1]]] and
> [[[1,2],[1,2]]] respectively in such cases.
[...]

I got a little over-distracted by this quiz and did two further
implementations of my original solution. One is simpler and more
perlish and the other is a linked list implementation that would shine
in C but probably doesnt do too well in Perl due to using so many
opcodes. Neither use explicit sorting, instead doing an ordered merge,
and like my original solution neither uses recursion.

Thanks Shlomi, this was fun. :-)
Yves

sub connected_indexlist {
    my ( $input ) = @_;

    my %node;          # hash of node number to ref holding the group idx
    my @group = undef; # knock out zero slot so valid indexes evaluate to TRUE.

    for my $idx (0..$#$input) {
        my $edge = $input->[$idx];
        my $g1 = $node{$edge->[0]};
        my $g2 = $node{$edge->[1]};
        if (!$g1 && !$g2) {
            my $group = push(@group, []) - 1;
            $g1 = \$group;
        } elsif (!$g1 || !$g2) {
            $g1 ||= $g2;
        } elsif ( $$g1 != $$g2 ) {
            ( $g1, $g2 ) = ( $g2, $g1 ) if $$g1 > $$g2;
            my ( $a1, $a2 ) = @group[$$g1,$$g2];
            my @merge ;
            while (@$a1 && @$a2) {
                if ($a1->[0] < $a2->[0]) {
                    push @merge, shift @$a1;
                } else {
                    push @merge, shift @$a2;
                }
            }
            push @merge, @$a1, @$a2;
            $group[$$g1] = \@merge;
            undef $group[$$g2];
            $$g2 = $$g1;
        }
        push @{$group[$$g1]}, $idx;
        $node{$edge->[0]} = $node{$edge->[1]} = $g1;
    }
    my @ret = map { $_ ? [ map { $input->[$_] } @$_ ] : () } @group;
    return \@ret;
}


sub connected_linkedlist {
    my ( $input ) = @_;

    my %node;          # hash of node number to ref holding the group idx
    my @head=(undef);
    my @tail=(undef);
    my @next;

    for my $idx (0..$#$input) {
        my $edge = $input->[$idx];

        my $g1 = $node{$edge->[0]};
        my $g2 = $node{$edge->[1]};

        if ( ! $g1 && ! $g2 ) {
            # Both nodes unknown, make a new group
            my $group = push(@head, $idx) - 1;
            push @tail, undef;
            $g1 = \$group; # so we can do a "bulk update" by assigning to $$g1
        } elsif ( ! $g1 || ! $g2 ) {
            # One node known, insert into its group
            $g1 ||= $g2;
        } elsif ( $$g1 != $$g2 ) {
            # Both nodes known but in different groups,  so merge the groups.
            ( $g1, $g2 ) = ( $g2, $g1 ) if $$g1 > $$g2;
            my ( $csr1, $csr2 ) = @head[ $$g1, $$g2 ];
            while ( defined( $csr1 ) && defined( $csr2 ) ) {
                # Invariant: $csr1 < $csr2
                if ($csr2 > $tail[$$g1]) { # are the two lists end to end?
                    # Concatenate them together and finish
                    $next[$tail[$$g1]] = $csr2;
                    $tail[$$g1] = $tail[$$g2];
                    last;
                } else { # Lists overlap somewhat
                    # Scan forward to find where the overlap starts.
                    while ( $next[$csr1] < $csr2 ) {
                        $csr1 = $next[$csr1]
                    }
                    # attach the current position in the first list
                    # to the start of the second
                    ($csr1, $next[$csr1] ) = ( $next[$csr1], $csr2 );
                    # scan forward on the second list to get all stuff
                    # that needs to be inserted
                    while ( defined $next[$csr2] && $next[$csr2] < $csr1 ) {
                        $csr2 = $next[$csr2]
                    };
                    # attach the current position in the second list
                    # to the continuation point in the first.
                    ($csr2, $next[$csr2] ) = ( $next[$csr2], $csr1 );
                }
            }
            $head[$$g2] = $tail[$$g2] = undef;
            $$g2 = $$g1;
        } # else: # Both known, but in the same group already

        # At this point $$g1 is the group that $input->[$idx] must be added to

        $next[$tail[$$g1]] = $idx     # Update the next pointer
            if defined $tail[$$g1];   #   if necessary

        $tail[$$g1] = $idx;           # Update the tail as well

        $node{$edge->[0]} = $node{$edge->[1]} = $g1;  # and the node mappings
    }

    # Convert the working representation into the required format for return
    my @ret;
    for my $elem ( @head ) {
        next unless defined $elem;
        my @group;
        do {
           push @group, $input->[$elem];
           $elem = $next[$elem];
        } while $elem;
        push @ret, \@group;
    }
    return \@ret;
}





-- 
perl -Mre=debug -e "/just|another|perl|hacker/"