laurent_r

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days from now (on September 10, 2023 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Similar Words

You are given an array of words made up of alphabets only.

Write a script to find the number of pairs of similar words. Two words are similar if they consist of the same characters.

Example 1

Input: @words = ("aba", "aabb", "abcd", "bac", "aabc")
Output: 2

Pair 1: similar words ("aba", "aabb")
Pair 2: similar words ("bac", "aabc")

Example 2

Input: @words = ("aabb", "ab", "ba")
Output: 3

Pair 1: similar words ("aabb", "ab")
Pair 2: similar words ("aabb", "ba")
Pair 3: similar words ("ab", "ba")

Example 3

Input: @words = ("nba", "cba", "dba")
Output: 0

I'm not too satisfied with this task. If we take examples 1 and 2, we have on the one hand two distinct pairs, leading to a result of 2. Fine. But on the other hand, we have really one triplet, which can indeed be considered as three pairs, but, in my humble opinion, the results of examples 1 and 2 are dissimilar and cannot really be compared, as they are built in a quite different way. Well, fair enough, we'll implement our solution in accordance with the examples.

Similar Words in Raku

We first build "normalized" versions of the input words, i.e. strings in which duplicate letters are removed and the remaining letters sorted in alphabetic order. We use a hash to count the number of words having a given normalized form. We remove normalized string that have only one occurrence. Finally, we compute the number of pairs that can be built from the hash values.

sub similar (@in) {
    my %words;
    %words{$_}++ for map { $_.comb.sort.squish.join("")}, @in;
    %words = map { $_ => %words{$_}}, grep {%words{$_} > 1}, %words.keys;
    my $count = 0;
    $count += ([*] 1..%words{$_})/2 for %words.keys;
    return $count;
}

for <aba aabb abcd bac aabc>, <aabb ab ba>,
    <nba cba dba> -> @test {
    printf "%-30s => ", "@test[]";
    say similar @test;
}

This program displays the following output:

$ raku ./similar-words.raku
aba aabb abcd bac aabc         => 2
aabb ab ba                     => 3
nba cba dba                    => 0

Similar Words in Perl

This is essentially a port to Perl of the Raku program above, please refer to the previous section if you need explanations. The only significant changes are that we used separate subroutines: unique_srt, to "normalize" the words, and fact to compute the factorial of an integer.

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

sub unique_srt {
    my %letters = map { $_ => 0 } split //, $_[0];
    return join "", sort keys %letters;
}
sub fact {
    my $num = shift;
    my $fact = 1;
    $fact *= $_ for 2..$num;
    return $fact;
}
sub similar {
    my %words;
    $words{$_}++ for map { unique_srt $_ } @_;
    %words = map { $_ => $words{$_}} grep {$words{$_} > 1} keys %words;
    my $count = 0;
    $count += (fact $words{$_})/2 for keys %words;
    return $count;
}

for my $test ([<aba aabb abcd bac aabc>], 
    [<aabb ab ba>], [<nba cba dba>]) {
    printf "%-25s => ", "@$test";
    say similar @$test;
}

This program displays the following output:

aba aabb abcd bac aabc    => 2
aabb ab ba                => 3
nba cba dba               => 0

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 September 17, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.