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
Top comments (0)