laurent_r

These are some answers to the Week 293, Task 1, of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on November 3, 2024, at 23:59). This blog post provides some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1:

You are given a list of dominoes, @dominoes.

Write a script to return the number of dominoes that are similar to any other domino.

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

Example 1

Input: @dominoes = ([1, 3], [3, 1], [2, 4], [6, 8])
Output: 2

Similar Dominoes: $dominoes[0], $dominoes[1]

Example 2

Input: @dominoes = ([1, 2], [2, 1], [1, 1], [1, 2], [2, 2])
Output: 3

Similar Dominoes: $dominoes[0], $dominoes[1], $dominoes[3]

First, I would say that dominoes (1, 3) and (3,1) are not really similar, they are equal, they are the same domino seen from a different angle.

Then we are not said what to do when you have for example dominoes (1, 3), (3,1), (2,4) and (4,2), i.e. two pairs of "similar" dominoes. And the examples provided don't clarify this case. I'll consider that, in that case, we have 4 similar dominoes, even if they are similar two by two.

To make things simple, I've chosen to represent dominoes as simple strings: rather than having a pair of integers such as (3,1), I'll use the string "31". Common domino sets have square ends with 0 (blank) to 6 spots. So this representation is sufficient and not ambiguous. There are, however, some extended domino sets with square ends having more than 6 spots. In the event that there are more than 9 spots (I've never seen that, but it could happen), we would need to change an input tile representation to a string with a separator, for example 11-13, and slightly modify the sort-dom subroutine accordingly (but the change is really simple).

Similar Dominoes in Raku

The first thing this program does is to "normalize" tiles, i.e. reorganize them so that the tiles square ends always appear in ascending order (done by the sort-dom subroutine). Once this is done, we simply need to count the dominoes of each type (done in the $histo histogram) and finally count the histogram values greater than 1. The $histo data structure is a Bag, i.e. an immutable collection of distinct objects with integer weights.

sub sort-dom ($dom) {
    my ($a, $b) = $dom.comb;
    return $a < $b ?? "$a$b" !! "$b$a";
}

sub similar-dom (@doms) {
    my $histo = bag map { sort-dom $_ }, @doms;
    my $count = 0;
    $count += $_ for grep { $_ > 1 }, $histo.values;
    return $count;
}

my @tests = <13 31 24 68>, <12 21 11 12 22>, <31 24 13 56 24>;
for @tests -> @test {
    printf "%-15s => ", "@test[]";
    say similar-dom @test;
}

This program displays the following output:

$ raku ./similar-dominoes.raku
13 31 24 68     => 2
12 21 11 12 22  => 3
31 24 13 56 24  => 4

Similar Dominoes in Perl

This is a port to Perl of the above Raku program. The only significant difference is that it uses a hash instead of a Bag. Please refer to the above two sections if you need explanations.

use strict;
use warnings;
use feature 'say';

sub sort_dom  {
    my $dom = shift;
    my ($a, $b) = split //, $dom;
    return $a < $b ? $dom : "$b$a";
}

sub similar_dom {
    my %histo;  
    $histo{$_}++ for map { sort_dom $_ } @_;
    my $count = 0;
    $count += $_ for grep { $_ > 1 } values %histo;
    return $count;
}

my @tests = ( [<13 31 24 68>], [<12 21 11 12 22>], 
                [<31 24 13 56 24>] );
for my $test (@tests) {
    printf "%-15s => ", "@$test";
    say similar_dom @$test;
}

This program displays the following output:

$ perl ./similar-dominoes.pl
13 31 24 68     => 2
12 21 11 12 22  => 3
31 24 13 56 24  => 4

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on November 10, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.