PWC 293 Similar Dominos Done Badly

Perl Weekly Challenge 293 gave us a problem that didn't really look that hard, yet I did it wrong at least three times before finishing. It reminded me of the song How to Save a Life, where the refrain goes "Where did I go wrong?"

The Task

You are given a list of dominos, @dominos. 
Write a script to return the number of 
dominoes that are similar to any other domino.

$dominos[i] = [a, b] and $dominos[j] = [c, d]
are the same if either (a = c and b = d) or
(a = d and b = c).

Example 1

• Input: @dominos = ([1, 3], [3, 1], [2, 4], [6, 8])
• Output: 2
• Similar Dominos: $dominos[0], $dominos[1]

Example 2

• Input: @dominos = ([1, 2], [2, 1], [1, 1], [1, 2], [2, 2])
• Output: 3
• Similar Dominos: $dominos[0], $dominos[1], $dominos[3]

Bad Start

First thought: oh, this is one of those compare-all-pairs problems. Double loop, count up the matches. Simple.

my $count = 0;
while ( defined(my $d1 = shift @dominos) )
{
    for my $d2 ( @dominos) 
    {
        if ( ( $d1->[0] == $d2->[0] && $d1->[1] == $d2->[1] )
          || ( $d1->[0] == $d2->[1] && $d1->[1] == $d2->[0] ) )
        {
            $count++;
        }
    }
}
return $count;

Nope. This double-counts the pairs in Example 2. The first time through the loop it finds the three similar dominoes, but then it loops again and finds the matching pair 1 and 3.

Strike 2

Okay, so we need to remove an element from consideration once it's been noted as similar. Let's delete the second member of the pair when we find a match. Annoyingly, I now need to know the index of the matches, but I can take advantage of the indexed feature that was added to Perl a couple of releases ago.

my $count = 0;
while ( defined(my $d1 = shift @dominos) )
{
    for my ($i, $d2) ( indexed @dominos ) 
    {
        if ( ( $d1->[0] == $d2->[0] && $d1->[1] == $d2->[1] )
          || ( $d1->[0] == $d2->[1] && $d1->[1] == $d2->[0] ) )
        {
            $count++;
            delete $dominos[$i];
        }
    }
}
return $count;

Derp. delete replaces the deleted element with an undef, so now the program dies by trying to reference an undefined array element. I need to add code to check for undef. Not very demure; not very mindful.

Strike 3

Easy enough. Instead of delete, use splice. That will compress the deleted element out of the array -- no undef checking needed.

[...]
while ( ... ) {
    for ... {
        if ( ... ) {
            count++;
            splice(@dominos, $i, 1);
        }

Fail. splice does indeed remove the element of the array, but doing that resets the indexes, so my $i index variable is now pointing at the wrong element after the operation, so I'll be skipping some pairs.

Engage Brain

Finally, it dawns on me that pair-wise checking may not be the way to go here. What if we enter the dominoes into a hash, and count the frequencies that way? All we have to do is force dominoes to look similar by always listing the smaller dots first.

sub similar(@dominos)
{
    my %count;
    while ( defined( my $tile = shift @dominos ) )
    {
        my @d = $tile->@*;
        @d = ($d[1], $d[0]) if $d[1] < $d[0];

        $count{ "[$d[0],$d[1]]" }++;
    }
    return sum0 values %count;
}

That looks better. We're only making one pass over the list, and O(1) is always nice. We form a key for the hash that has the pair of numbers in a string, which is going to be useful for debugging, if we need to dump the hash table (but surely we have it right now). Retrieving the counts is easy with applying values to the hash, and List::Util::sum0 will add them up.

And ... nope, still a bug. The hash now contains dominoes that are unique. We need to add a little filter to only count dominoes that show up at least twice.

[...]
    return sum0 { grep $_ > 1 } values %count;

Good grief. Finally, something I'm willing to push to Github