September 2023 Archives

Perl Weekly Challenge 236: Exact Change

These are some answers to the Week 236, 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 October 1, 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: Exact Change

You are asked to sell juice each costs $5. You are given an array of bills. You can only sell ONE juice to each customer but make sure you return exact change back. You only have $5, $10 and $20 notes. You do not have any change in hand at first.

Write a script to find out if it is possible to sell to each customer with correct change.

Example 1

Input: @bills = (5, 5, 5, 10, 20)
Output: true

From the first 3 customers, we collect three $5 bills in order.
From the fourth customer, we collect a $10 bill and give back a $5.
From the fifth customer, we give a $10 bill and a $5 bill.
Since all customers got correct change, we output true.

Example 2

Input: @bills = (5, 5, 10, 10, 20)
Output: false

From the first two customers in order, we collect two $5 bills.
For the next two customers in order, we collect a $10 bill and give back a $5 bill.
For the last customer, we can not give the change of $15 back because we only have two $10 bills.
Since not every customer received the correct change, the answer is false.

Example 3

Input: @bills = (5, 5, 5, 20)
Output: true

Exact Change in Raku

The sell-juice subroutine keeps track of the available change available. It loops on the bills provided by customers and check each time whether the necessary change is available. It also adds the banknote provided by the customer in the %change hash. It returns False when the change is not available. If we get through to the end of the input array, then we return True. Note that for an input of 20, we need to give back 15. We first try to give a 10 and a 5 banknote and, if not possible (no available 10 banknote), then we try to give back three 5 banknotes.

sub sell-juice (@in) {
    # %change stores the stock of bank notes. No need to 
    # count $20 notes but it makes the code more generic
    my %change = '5' => 0, '10' => 0, '20' => 0;
    for @in -> $i {
        %change{$i}++;
        given $i {
            when 5 {next}
            when 10 {
                return False if %change{5} < 1;
                %change{5}--;
                next;
            }
            when 20 {
                if %change{10} > 0 and %change{5} > 0 {
                    %change{10}--; %change{5}--;
                    next;
                } elsif %change{5} >= 3 {
                    %change{5} -= 3; next;
                } else {
                    return False;
                }
            }
        }
    }
    return True;
}

my @tests = <5 5 5 10 20>, <5 5 10 10 20>, <5 5 5 20>;
for @tests -> @test {
    printf "%-15s => ", "@test[]";
    say sell-juice @test;
}

This program displays the following output:

$ raku ./exact-change.raku
5 5 5 10 20     => True
5 5 10 10 20    => False
5 5 5 20        => True

Exact Change in Perl

This is a port to Perl of the above Raku program. The only significant change is that the given ... when construct is replaced with nested if ... then ... else conditionals. Asides from that, please refer to the above section if you need further explanations.

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

sub sell_juice {
    # %change stores the stock of bank notes. No need to 
    # count $20 notes but it makes the code more generic
    my %change = ('5' => 0, '10' => 0, '20' => 0);
    for my $i (@_){
        $change{$i}++;
        next if $i == 5;
        if ($i == 10) {
            return "false" if $change{5} < 1;
            $change{5}--;
            next;
        } elsif ($i == 20) {
            if ($change{10} > 0 and $change{5} > 0) {
                $change{10}--; $change{5}--;
                next;
            } elsif ($change{5} >= 3) {
                $change{5} -= 3; next;
            } else {
                return "false";
            }
        }
    }
    return "true";
}

my @tests = ([<5 5 5 10 20>], [<5 5 10 10 20>], [<5 5 5 20>]);
for my $test (@tests) {
    printf "%-15s => ", "@$test";
    say sell_juice @$test;
}

This program displays the following output:

$ perl exact-change.pl
5 5 5 10 20     => true
5 5 10 10 20    => false
5 5 5 20        => true

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

Perl Weekly Challenge 236: Array Loops

These are some answers to the Week 236, Task 2, 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 October 1, 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 2: Array Loops

You are given an array of unique integers.

Write a script to determine how many loops are in the given array.

To determine a loop: Start at an index and take the number at array[index] and then proceed to that index and continue this until you end up at the starting index.

Example 1

Input: @ints = (4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10)
Output: 3

To determine the 1st loop, start at index 0, the number at that index is 4, proceed to index 4, the number at that index is 15, proceed to index 15 and so on until you're back at index 0.

Loops are as below:
[4 15 1 6 13 5 0]
[3 8 7 18 9 16 12 17 2]
[14 11 19 10]

Example 2

Input: @ints = (0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3,18,15,19)
Output: 6

Loops are as below:
[0]
[1]
[13 9 14 17 18 15 5 8 2]
[7 11 4 6 10 16 3]
[12]
[19]

Example 3

Input: @ints = (9,8,3,11,5,7,13,19,12,4,14,10,18,2,16,1,0,15,6,17)
Output: 1

Loop is as below:
[9 4 5 7 19 17 15 1 8 12 18 6 13 2 3 11 10 14 16 0]

I may have missed something, but I really don't understand the examples. Let's take example 1:

(4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10)

We start with index 0 and obtain, as specified in the example, the following loop:

[4 15 1 6 13 5 0]

But why does the second loop in the example start with 3 (i.e. index 2)? We can start with index 1 (value 6) and obtain the following loop:

(Starting with index 1)
  index   value
    1       6
    6       13
    13      5
    5       0
    0       4
    4       15
    15      1

Similarly, if we start with index 3, we obtain the following loop:

(Starting with index 3)
  index   value
    3       8
    8       7
    7       18
    18      9
    9       16
    16      12
    12      17
    17      2
    2       3

And, with index 4:

(Starting with index 4)
  index   value
    4       15
    15      1
    1       6
    6       13
    13      5
    5       0
    0       4

And so on.

In fact, since values in the given examples seem to be permutations of the input array indexes, starting with any index will lead to a loop, so that with an array of 20 values, we will find 20 possible loops.

So my results will not be the same as those provided with the examples.

Array Loops in Raku

We iterate on every item of the input array as a start value, and for every value, we follow the index until we find a loop. If a loop is found, we increment a counter and, at the end, return the counter to the calling code.

sub find-loops (@in) {
    my $count = 0;
    for 0..@in.end -> $i {
        my $j = $i;
        loop {
            last unless @in[$j].defined;
            # say "\t", $j, "\t", @in[$j];
            ++$count and last if @in[$j] == $i;
            $j = @in[$j];
        }
    }
    return $count;
}

my @tests = 
    (4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10),
    (0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3,18,15,19),
    (9,8,3,11,5,7,13,19,12,4,14,10,18,2,16,1,0,15,6,17),
    (0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3);

for @tests -> @test {
    say @test;
    say "\tNumber of loops: ", find-loops @test;
}

This program displays the following output:

$ raku ./array-loops.raku
(4 6 3 8 15 0 13 18 7 16 14 19 17 5 11 1 12 2 9 10)
        Number of loops: 20
(0 1 13 7 6 8 10 11 2 14 16 4 12 9 17 5 3 18 15 19)
        Number of loops: 20
(9 8 3 11 5 7 13 19 12 4 14 10 18 2 16 1 0 15 6 17)
        Number of loops: 20
(0 1 13 7 6 8 10 11 2 14 16 4 12 9 17 5 3)
        Number of loops: 10

Array Loops in Perl

This Perl program works exactly as the above Raku program. Please refer to the previous sections if you need explanations.

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

sub find_loops {
    my @in = @_;
    my $count = 0;
    for my $i (0..$#in) {
        my $j = $i;
        # say $i;
        while (1) {
            last unless defined $in[$j];
            # say "\t", $j, "\t", @in[$j];
            ++$count and last if $in[$j] == $i;
            $j = $in[$j];
        }
    }
    return $count;
}

my @tests = (
    [4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10],
    [0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3,18,15,19],
    [9,8,3,11,5,7,13,19,12,4,14,10,18,2,16,1,0,15,6,17],
    [0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3]);

for my $test (@tests) {
    say "@$test";
    say "\tNumber of loops: ", find_loops @$test;
}

This program displays the following output:

$ perl ./array-loops.pl
4 6 3 8 15 0 13 18 7 16 14 19 17 5 11 1 12 2 9 10
        Number of loops: 20
0 1 13 7 6 8 10 11 2 14 16 4 12 9 17 5 3 18 15 19
        Number of loops: 20
9 8 3 11 5 7 13 19 12 4 14 10 18 2 16 1 0 15 6 17
        Number of loops: 20
0 1 13 7 6 8 10 11 2 14 16 4 12 9 17 5 3
        Number of loops: 10

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

Perl Weekly Challenge 235: Duplicate Zeros

These are some answers to the Week 235, Task 2, 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 September 24, 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 2: Duplicate Zeros

You are given an array of integers.

Write a script to duplicate each occurrence of ZERO in the given array and shift the remaining to the right but make sure the size of array remain the same.

Example 1

Input: @ints = (1, 0, 2, 3, 0, 4, 5, 0)
Ouput: (1, 0, 0, 2, 3, 0, 0, 4)

Example 2

Input: @ints = (1, 2, 3)
Ouput: (1, 2, 3)

Example 3

Input: @ints = (0, 3, 0, 4, 5)
Ouput: (0, 0, 3, 0, 0)

We don't really know what should happen if keeping the array size leads to the removal of the zero just added. We will assume the added zero is just chopped off, like this:

Input: @ints = (0, 3, 2, 0, 4)
Ouput: (0, 0, 3, 2, 0)

Duplicate Zeros in Raku

The duplicate-zeros subroutine uses the map function to build a new array in which any zero from the input array is repeated and other values are just copied untouched. After that, the subroutine returns a splice of the resulting array having the size of the input array.

sub duplicate-zeros (@in) {
    my @result = map { $_ == 0 ?? |(0, 0) !! $_ }, @in;
    return @result[0..@in.end];
}

for <1 0 2 3 0 4 5 0>,  <1 2 3>, <0 3 0 4 5> -> @test {
    printf "%-18s => ", "@test[]";
    say duplicate-zeros @test;
}

This program displays the following output:

$ raku ./duplicate-zeros.raku
1 0 2 3 0 4 5 0    => (1 0 0 2 3 0 0 4)
1 2 3              => (1 2 3)
0 3 0 4 5          => (0 0 3 0 0)

Duplicate Zeros in Perl

This Perl program does the same thing as the above Raku program. Please refer to the above section for any explanation.

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

sub duplicate_zeros {
    my @result = map { $_ == 0 ? (0, 0) : $_ } @_;
    return @result[0..$#_];
}

for my $test ([<1 0 2 3 0 4 5 0>], 
    [<1 2 3>], [<0 3 0 4 5>]) {
    printf "%-18s => ", "@$test";
    say join " ", duplicate_zeros @$test;
}

This program displays the following output:

$ perl ./duplicate-zeros.pl
1 0 2 3 0 4 5 0    => 1 0 0 2 3 0 0 4
1 2 3              => 1 2 3
0 3 0 4 5          => 0 0 3 0 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 October 1, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 235: Remove One

These are some answers to the Week 235, 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 September 24, 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: Remove One

You are given an array of integers.

Write a script to find out if removing ONLY one integer makes it strictly increasing order.

Example 1

Input: @ints = (0, 2, 9, 4, 6)
Output: true

Removing ONLY 9 in the given array makes it strictly increasing order.

Example 2

Input: @ints = (5, 1, 3, 2)
Output: false

Example 3

Input: @ints = (2, 2, 3)
Output: true

Remove One in Raku

We simply iterate over the input array and count the items that are out of order (where @in[$i-1] >= @in[$i]). We return False if the number of such items is more than 1, and True otherwise.

sub can-strictly-increase (@in) {
    my $count = 0;
    for 1..@in.end -> $i {
        $count++ if @in[$i-1] >= @in[$i];
    }
    return $count > 1 ?? False !! True;
}

for <0 2 9 4 6>, <5 1 3 2>, <2 2 3>, <3 3 3> -> @test {
    printf "%-12s => ", "@test[]";
    say can-strictly-increase @test;
}

This program displays the following output:

$ raku ./remove-one.raku
0 2 9 4 6    => True
5 1 3 2      => False
2 2 3        => True
3 3 3        => False

Remove One in Perl

This is a port to Perl of the above Raku program, with absolutely no change except for syntax differences.

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

sub can_strictly_increase {
    my $count = 0;
    for my $i (1..$#_) {
        $count++ if $_[$i-1] >= $_[$i];
    }
    return $count > 1 ? "false" : "true";
}

for my $test ([<0 2 9 4 6>], [<5 1 3 2>], 
              [<2 2 3>], [<3 3 3>]) {
    printf "%-12s => ", "@$test";
    say can_strictly_increase @$test;
}

This program displays the following output:

$ perl ./remove-one.pl
0 2 9 4 6    => true
5 1 3 2      => false
2 2 3        => true
3 3 3        => false

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

Perl Weekly Challenge 234: Unequal Triplets

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

Task 2: Unequal Triplets

You are given an array of positive integers.

Write a script to find the number of triplets (i, j, k) that satisfies num[i] != num[j], num[j] != num[k] and num[k] != num[i].

Example 1

Input: @ints = (4, 4, 2, 4, 3)
Ouput: 3

(0, 2, 4) because 4 != 2 != 3
(1, 2, 4) because 4 != 2 != 3
(2, 3, 4) because 2 != 4 != 3

Example 2

Input: @ints = (1, 1, 1, 1, 1)
Ouput: 0

Example 3

Input: @ints = (4, 7, 1, 10, 7, 4, 1, 1)
Output: 28

triplets of 1, 4, 7  = 3x2×2 = 12 combinations
triplets of 1, 4, 10 = 3×2×1 = 6  combinations
triplets of 4, 7, 10 = 2×2×1 = 4  combinations
triplets of 1, 7, 10 = 3x2x1 = 6 combinations

I frankly don't understand the examples 1 and 3.

First, there is nothing saying that the triplets should be in ascending (or any other) order. So, taking example 1, we could add for example the following triplets:

(3, 2, 4) - values 4, 2, 3 (same as triplet (0, 2, 4)
(3, 4, 2) - values 4, 3, 2
(4, 2, 1) - values 3, 2, 4
(4, 1, 2) - values 3, 4, 2
etc.

So, our solutions for the example provided will obviously differ from those given above in the task specification.

Second, we're not asked to output the triplets of indexes, but only the number of triplets. I'll further assume that (0, 2, 4) and (1, 2, 4) are not a valid pair of triplets, because they yield the same values. So we are looking for the number of valid partial permutations of 3 items among the input values. To make sure our permutations are valid, we can simply remove duplicates from the input list.

We don't need to generate the permutations, since there is a mathematical formula that tells us that the number of permutations of r items from an array of n items is computed as follows:

P(n, r) = (n!) / (n - r)!

In our case, since we are looking for triplets, this becomes:

P(n, 3) = (n!) / (n - 3)!

Unequal Triplets in Raku

Based on the above explanations, the count-unequal-triplets subroutine first creates the @unique array with the input values without duplicates, count the unique items and finally uses the math formula above to count the number of unique triplets. Note that the reduction operator together with the multiplication operator (for instance [*] 1..$n) makes it possible to compute directly the factorial of a positive integer (factorial of n in the example).

sub count-unequal-triplets (@in) {
    my @unique = @in.unique;
    my $n = @unique.elems;    # n = count of unique items
    return 0 if $n < 3;
    my $triplet-count = ([*] 2..$n) / ([*] 2..($n - 3));
}

for (4, 4, 2, 4, 3), (1, 1, 1, 1, 1), 
    (4, 7, 1, 10, 7, 4, 1, 1) -> @test {
    printf "%-20s => ", "@test[]";
    say count-unequal-triplets @test;
}

This program displays the following output:

$ raku ./unequal-triplets.raku
4 4 2 4 3            => 6
1 1 1 1 1            => 0
4 7 1 10 7 4 1 1     => 24

Unequal Triplets in Perl

This is a port to Perl of the above Raku program. Compared to the Raku version, we have to define our own fact subroutine to compute the factorial of a positive integer. Otherwise, please refer to the above sections for further explanations.

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

sub fact {
    my $in = shift;
    my $fact = 1;
    $fact *= $_ for 2..$in;
    return $fact;
}

sub count_unequal_triplets {
    my %unique = map { $_ => 1 } @_;
    my $n = scalar keys %unique;    # n = count of unique items
    return 0 if $n < 3;
    my $triplet_count = (fact $n) / (fact $n - 3);
}

for my $test ([4, 4, 2, 4, 3], [1, 1, 1, 1, 1], 
    [4, 7, 1, 10, 7, 4, 1, 1]){
    printf "%-20s => ", "@$test";
    say count_unequal_triplets @$test;
}

This program displays the following output:

$ perl ./unequal-triplets.pl
4 4 2 4 3            => 6
1 1 1 1 1            => 0
4 7 1 10 7 4 1 1     => 24

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

Perl Weekly Challenge 234: Common Characters

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 17, 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: Common Characters

You are given an array of words made up of alphabetic characters only.

Write a script to return all alphabetic characters that show up in all words including duplicates.

Example 1

Input: @words = ("java", "javascript", "julia")
Output: ("j", "a")

Example 2

Input: @words = ("bella", "label", "roller")
Output: ("e", "l", "l")

Example 3

Input: @words = ("cool", "lock", "cook")
Output: ("c", "o")

Common Characters in Raku

The common-chars subroutine first transforms the input words into an array of arrays of letters, and then uses the ,infix%E2%88%A9) set intersection operator to find letters common to all sub-arrays.

sub common-chars (@in) {
    my @letters = map { .comb }, @in;
    return ~ ∩ @letters;
}

for <java javascript julia>, <bella label roller>, 
    <cool lock cook> -> @test {
    printf "%-25s => ", "@test[]";
    say common-chars @test;
}

This program displays the following output:

$ raku ./common-chars.raku
java javascript julia     => [a j]
bella label roller        => [l e]
cool lock cook            => [c o]

Common Characters in Perl

This is essentially a port to Perl of the above Raku program, except that, since Perl doesn't have a set intersection operator, we use the %histo hash to store the letter frequencies, and extract from the histogram letters whose frequency is equal to the input word count.

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

sub common_chars {
    my $count = scalar @_;
    my @letters = map { [ split // ] } @_;
    my %histo;       # letter histogram
    for my $w_ref (@letters) {
        my %unique = map { $_ => 1 } @$w_ref;
        $histo{$_}++ for keys %unique;
    }
    my @result = grep { $histo{$_} == $count } keys %histo;
    return "@result";
}

for my $test ([<java javascript julia>], 
    [<bella label roller>], [<cool lock cook>]) {
    printf "%-25s => ", "@$test";
    say common_chars @$test;
}

This program displays the following output:

$ perl ./common-chars.pl
java javascript julia     => a j
bella label roller        => e l
cool lock cook            => o c

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

Perl Weekly Challenge 233: Frequency Sort

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

You are given an array of integers.

Write a script to sort the given array in increasing order based on the frequency of the values. If multiple values have the same frequency then sort them in decreasing order.

Example 1

Input: @ints = (1,1,2,2,2,3)
Ouput: (3,1,1,2,2,2)

'3' has a frequency of 1
'1' has a frequency of 2
'2' has a frequency of 3

Example 2

Input: @ints = (2,3,1,3,2)
Ouput: (1,3,3,2,2)

'2' and '3' both have a frequency of 2, so they are sorted in decreasing order.

Example 3

Input: @ints = (-1,1,-6,4,5,-6,1,4,1)
Ouput: (5,-1,4,4,-6,-6,1,1,1)

Frequency Sort in Raku

We write a special-comp subroutine to implement the comparison logic to be used with the sort built-in function. An additional note: %*histo is a dynamic scope variable, which means it is seen and accessible in subroutines called by the routine where it is declared.

sub special-comp {
    return $^b <=> $^a if %*histo{$^a} == %*histo{$^b};
    return %*histo{$^a} <=> %*histo{$^b};
}

sub freq-sort (@in) {
    my %*histo;
    %*histo{$_}++ for @in;
    my @sorted = sort &special-comp, %*histo.keys;
    my @result = map { |($_ xx %*histo{$_})}, @sorted;
}

for <1 1 2 2 2 3>, <2 3 1 3 2>, 
    (-1,1,-6,4,5,-6,1,4,1) -> @test {
    printf "%-25s => ", "@test[]";
    say freq-sort @test;
}

This program displays the following output:

$ raku ./frequency-sort.raku
1 1 2 2 2 3               => [3 1 1 2 2 2]
2 3 1 3 2                 => [1 3 3 2 2]
-1 1 -6 4 5 -6 1 4 1      => [5 -1 4 4 -6 -6 1 1 1]

Please note that I am too late and have no time now to complete the Perl version of this program.

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.

Perl Weekly Challenge 233: Separate Digits

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.

About laurent_r

user-pic I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.