These are some answers to the Week 193 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 December 4, 2022 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: Binary String

You are given an integer, $n > 0.

Write a script to find all possible binary numbers of size $n.

Example 1

Input: $n = 2
Output: 00, 11, 01, 10

Example 2

Input: $n = 3
Output: 000, 001, 010, 100, 111, 110, 101, 011

For this task, all we need to do is to print all the integers between 0 and (2 ** $n) -1, and to display the output in binary format.

Binary String in Raku

This is so simple that we’ll do it in a Raku one-liner. We could use the built-in base method to convert the input integer into a binary string, or the built-in fmt routine. However, since we want to be concise for a one-liner, we’ll simply use the built-in printf function, with a b directive to obtain an unsigned binary integer format.

$ raku -e 'sub MAIN ($n) { printf "%03b ", $_ for 0..2**$n-1; }' 3
000 001 010 011 100 101 110 111
~
$ raku -e 'sub MAIN ($n) { printf "%04b ", $_ for 0..2**$n-1; }' 4
0000 0001 0010 0011 0100 0101 0110 0111 1000 1001 1010 1011 1100 1101 1110 1111

We can slightly improve this one-liner by using the parameter passed to it in the formatting string, so that we don’t need to change the formatting string depending on the input parameter:

$ raku -e 'sub MAIN ($c) {printf "%.*b ", $c, $_ for 0..2**$c-1;}' 3
000 001 010 011 100 101 110 111

Binary String in Perl

Here again, we’ll make a one-liner and use the printf function. Compared to the first Raku implementation, we use the input number in the formatting string, so that we don’t need to change the formatting string for different input integers.

$ perl -e 'my $c = shift; printf "%0${c}b ", $_ for 0..(2**$c) - 1' 3
000 001 010 011 100 101 110 111
~
$ perl -e 'my $c = shift; printf "%0${c}b ", $_ for 0..(2**$c) - 1' 4
0000 0001 0010 0011 0100 0101 0110 0111 1000 1001 1010 1011 1100 1101 1110 1111

Task 2: Odd String

You are given a list of strings of same length, @s.

Write a script to find the odd string in the given list. Use positional value of alphabet starting with 0, i.e. a = 0, b = 1, … z = 25.

> Find the difference array for each string as shown in the example. Then pick the odd one out.

Example 1:

Input: @s = ("adc", "wzy", "abc")
Output: "abc"

Difference array for "adc" => [ d - a, c - d ]
                           => [ 3 - 0, 2 - 3 ]
                           => [ 3, -1 ]

Difference array for "wzy" => [ z - w, y - z ]
                           => [ 25 - 22, 24 - 25 ]
                           => [ 3, -1 ]

Difference array for "abc" => [ b - a, c - b ]
                           => [ 1 - 0, 2 - 1 ]
                           => [ 1, 1 ]

The difference array for "abc" is the odd one.

Example 2:

Input: @s = ("aaa", "bob", "ccc", "ddd")
Output: "bob"

Difference array for "aaa" => [ a - a, a - a ]
                           => [ 0 - 0, 0 - 0 ]
                           => [ 0, 0 ]

Difference array for "bob" => [ o - b, b - o ]
                           => [ 14 - 1, 1 - 14 ]
                           => [ 13, -13 ]

Difference array for "ccc" => [ c - c, c - c ]
                           => [ 2 - 2, 2 - 2 ]
                           => [ 0, 0 ]

Difference array for "ddd" => [ d - d, d - d ]
                           => [ 3 - 3, 3 - 3 ]
                           => [ 0, 0 ]

The difference array for "bob" is the odd one.

The difference array is an array containing the distances between the successive letter. The task description suggests that we use “positional value of alphabet starting with 0, i.e. a = 0, b = 1, … z = 25.” This can easily be done, but, since we compute only differences between letters, we could use any other positional arrangement, including ASCII. I’ll use the task description suggestion for Raku and ASCII values in Perl.

I did not understand at first what the odd difference array is supposed to be. Judging from the examples, it appears that several input strings will produce the same difference array (for example, ‘abc’ and ‘bcd’ will both produce the same (1, 1) array), and one (or possibly some) will produce unique difference arrays. And we’re supposed to find that (or those) unique array(s).

I’ll build a hash to store, for each difference array, the corresponding strings. Then I’ll loop over the hash keys and display those for which there is only one string in the value.

Odd String in Raku

The diff-array subroutine computes the difference array for the input string. %transco is a hash containing the mapping between letters and integers. For each string in the input list, we store in the result hash the difference array as a key, and the list of strings as a value. We then display the result pairs for which the value has only one string.

my %transco = ("a".."z" Z 0..25).flat; # a => 0, b => 1 ...

sub diff-array ($str) {
    my @diff;
    for 1..^$str.chars -> $i {
        push @diff, 
            %transco{substr($str, $i, 1)} 
            - %transco{substr($str, $i-1, 1)};
    }
    return @diff;
}

for <adc wzy abc>, <aaa bob ccc ddd> -> @test {
    my %result;
    for @test -> $st {
        push %result, (diff-array $st) => $st;
    }
    # say %result;
    for %result.keys -> $k {
        say @test, " -> ", %result{$k} if %result{$k}.elems == 1;
    }
}

This program display the following output:

$ raku ./odd-string.raku
(adc wzy abc) -> abc
(aaa bob ccc ddd) -> bob

Odd String in Perl

This is a port to Perl of the Raku program above, except that, as mentioned earlier, we use the ASCII values (the built-in ord function) to compute the difference arrays. We obtain a hash of arrays and pick the hash items for which here is only one string.

use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;

sub diff_array  {
    my $str = shift;
    my @diff;
    for my $i (1.. length($str) - 1) {
        push @diff, 
            ord(substr($str, $i, 1)) 
            - ord(substr($str, $i-1, 1));
    }
    return "@diff";
}

for my $test ([<adc wzy abc>], [<aaa bob ccc ddd>]) {
    my %result;
    for my $st (@$test) {
        push @{$result{diff_array $st}}, $st;
    }
    # say Dumper \%result;
    for my $k (keys %result) {
        say "@$test -> ", @{$result{$k}} if scalar @{$result{$k}} == 1;
    }
}

This program display the following output:

$ perl  ./odd-string.pl
adc wzy abc -> abc
aaa bob ccc ddd -> bob

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

These are some answers to the Week 192 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, 27, 2022 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: Binary Flip

You are given a positive integer, $n.

Write a script to find the binary flip.

Example 1

Input: $n = 5
Output: 2

First find the binary equivalent of the given integer, 101.
Then flip the binary digits 0 -> 1 and 1 -> 0 and we get 010.
So Binary 010 => Decimal 2.

Example 2

Input: $n = 4
Output: 3

Decimal 4 = Binary 100
Flip 0 -> 1 and 1 -> 0, we get 011.
Binary 011 = Decimal 3

Example 3

Input: $n = 6
Output: 1

Decimal 6 = Binary 110
Flip 0 -> 1 and 1 -> 0, we get 001.
Binary 001 = Decimal 1

In theory, we should probably use the binary operators to solve this problem. In practice, it will be easier (and also faster), both in Raku and in Perl, to convert the input integer into a binary string, perform the binary flip as a string operation, and then convert the resulting binary string into an integer.

Binary Flip in Raku

We can use the built-in base method to convert the input integer into a binary string, and the built-in parse-base method to perform the opposite conversion. Then we use the tr/// in-place transliteration operator to transform 0s into 1s and vice-versa.

sub flip (Int $n) {
    my $bin = $n.base(2);
    $bin ~~ tr/10/01/;
    return $bin.parse-base(2);
}

for 5, 4, 6 -> $test {
    say "$test => ", flip($test);
}

This program displays the following output:

$ raku ./bin-flip.raku
5 => 2
4 => 3
6 => 1

This program is so simple that it can easily be coded as a Raku one-liner:

$ raku -e 'say (TR/10/01/ given (+@*ARGS[0]).base(2)).parse-base(2);' 5
2

$ raku -e 'say (TR/10/01/ given (+@*ARGS[0]).base(2)).parse-base(2);' 4
3

$ raku -e 'say (TR/10/01/ given (+@*ARGS[0]).base(2)).parse-base(2);' 6
1

Binary Flip in Perl

In Perl, we can use sprintf to convert the input integer into a binary string, and oct for the reverse conversion. The oct function:

Interprets EXPR as an octal string and returns the corresponding value. (If EXPR happens to start off with “0x”, interprets it as a hex string. If EXPR starts off with “0b”, it is interpreted as a binary string.)

So we only need to prefix the flipped string with 0b. And we use the tr/// operator to perform the binary flip:

use strict; use warnings; use feature qw/say/;

sub flip {
    my $bin = sprintf "%b", shift;
    $bin =~ tr/10/01/;
    return oct("0b" . $bin);
}

for my $test (5, 4, 6) {
    say "$test => ", flip($test);
}

This program displays the following output:

$ perl ./bin-flip.pl
5 => 2
4 => 3
6 => 1

Task 2: Equal Distribution

You are given a list of integers greater than or equal to zero, @list.

Write a script to distribute the number so that members are same. If you succeed then print the total moves otherwise print -1.

Please follow the rules (as suggested by Neils van Dijke (2022-11-21 13:00):

>1) You can only move a value of ‘1’ per move >2) You are only allowed to move a value of ‘1’ to a direct neighbor/adjacent cell

Example 1:

Input: @list = (1, 0, 5)
Output: 4

Move #1: 1, 1, 4
(2nd cell gets 1 from the 3rd cell)

Move #2: 1, 2, 3
(2nd cell gets 1 from the 3rd cell)

Move #3: 2, 1, 3
(1st cell get 1 from the 2nd cell)

Move #4: 2, 2, 2
(2nd cell gets 1 from the 3rd cell)

Example 2:

Input: @list = (0, 2, 0)
Output: -1

It is not possible to make each same.

Example 3:

Input: @list = (0, 3, 0)
Output: 2

Move #1: 1, 2, 0
(1st cell gets 1 from the 2nd cell)

Move #2: 1, 1, 1
(3rd cell gets 1 from the 2nd cell)

First, it should be pretty obvious that there is a solution if and only if the sum of the digits of the input list is evenly divisible by the number of items in the list. Thus, in the second example provided with the task, there is no solution because the sum of the list elements is 2, which is not a multiple of 3, the number of items in the list.

Second, the final solution will have all their elements set to the average of the list items. For instance, in the case of example 1, all elements of the final list are equal to 2, i.e. (1 + 0 + 5) / 3.

Finally, the least number of moves to equalize (1, 0, 5) is the same as the least number of moves to equalize (5, 0, 1) (it is sort of commutative). This means that we can always start from the left and move to the right (and don’t need to try in the other direction). So, if we start from the left, we need to add 1 to 1 to get the target value of 2. For this move to be legal, we need to carry over the change, i.e. subtract 1 from the next value, and, after this first move, we get (2, -1, 5). We don’t care about temporary negative values, and we can see that we’ll need three additional moves to get the center value to 2. At that point, the most right value will have been decremented 3 times and will be equal to 2. Job done, we need in total 4 moves. We only need to generalize this to any number of items.

Equal Distribution in Raku

We simply implement the process described in the comments on the task description just above.

sub equalize (@nums is copy) {
    my $sum = [+] @nums;
    return -1 if $sum % @nums.elems;
    my $target = $sum / @nums.elems;
    my $count = 0;
    my $carry = 0;
    for @nums <-> $num {
        $num -= $carry;
        $carry = $target - $num;
        $count += $carry.abs;
    }
    return $count;
}

for <1 0 5>, <0 2 0>, <0 3 0>, <3 0 3>, <2 2 2>, 
    <1 0 5 2>, <2 5 0 1>, <1 0 5 3>, <6 0 0> -> @test {
    say @test, " \t -> ", equalize @test;
}

This program displays the following output:

$ raku ./equal-dist.raku
(1 0 5)          -> 4
(0 2 0)          -> -1
(0 3 0)          -> 2
(3 0 3)          -> 2
(2 2 2)          -> 0
(1 0 5 2)        -> 4
(2 5 0 1)        -> 4
(1 0 5 3)        -> -1
(6 0 0)          -> 6

Equal Distribution in Perl

We also simply implement the process described above in the discussion of the task.

use strict;
use warnings;
use feature qw/say/;


sub equalize {
    my @nums = @{$_[0]};
    my $sum = 0;
    $sum += $_ for @nums;
    return -1 if $sum % scalar @nums;
    my $target = $sum / scalar @nums;
    my $count = 0;
    my $carry = 0;
    for my $num (@nums) {
        $num -= $carry;
        $carry = $target - $num;
        $count += abs $carry;
    }
    return $count;
}
for my $test ([<1 0 5>], [<0 2 0>], [<0 3 0>], 
              [<3 0 3>], [<2 2 2>], [<1 0 5 2>], 
              [<2 5 0 1>], [<1 0 5 3>], [<6 0 0>]) {
    say "@$test\t -> ", equalize $test;
}

This program displays the following output:

$ perl ./equal-dist.pl
1 0 5    -> 4
0 2 0    -> -1
0 3 0    -> 2
3 0 3    -> 2
2 2 2    -> 0
1 0 5 2  -> 4
2 5 0 1  -> 4
1 0 5 3  -> -1
6 0 0    -> 6

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

These are some answers to the Week 191 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, 20, 2022 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: Twice Largest

You are given list of integers, @list.

Write a script to find out whether the largest item in the list is at least twice as large as each of the other items.

Example 1

Input: @list = (1,2,3,4)
Output: -1

The largest in the given list is 4. However 4 is not greater than twice of every remaining elements.
1 x 2 < 4
2 x 2 > 4
2 x 3 > 4

Example 2

Input: @list = (1,2,0,5)
Output: 1

The largest in the given list is 5. Also 5 is greater than twice of every remaining elements.
1 x 2 < 5
2 x 2 < 5
0 x 2 < 5

Example 3

Input: @list = (2,6,3,1)
Output: 1

The largest in the given list is 6. Also 6 is greater than twice of every remaining elements.
2 x 2 < 6
3 x 2 < 6
1 x 2 < 6

Example 4

Input: @list = (4,5,2,3)
Output: -1

The largest in the given list is 5. Also 5 is not greater than twice of every remaining elements.
4 x 2 > 5
2 x 2 < 5
3 x 2 > 5

Our task is to find out whether the largest item in the list is at least twice as large as each of the other items. This is not the same thing as twice larger, which may be construed to mean larger than twice each other item. In other words, we need to use >=, not >. For example, in example 1, we have:

2 x 2 > 4

which is obviously wrong. Similarly, in example 3, 3 x 2 < 6 is also wrong. The required output provided with the examples is in line with this understanding, in spite of the somewhat erroneous notation in the explanations.

Twice Largest in Raku

We only need to compare the largest item with twice the second largest item. Since the lists of integers are very small, we can just sort the item (in descending order) and work with the first two items in the list.

Note that we lazily use sort to find the two largest items of the list; as already discusses in PWC 189 and elsewhere, this is not the best algorithmic method (and it might not be good for very long lists), but it is the fastest to develop. Saving development time is sometimes more important than saving a few CPU cycles. The resulting code is fairly concise and very easy to understand.

sub is-twice-as-large (@input) {
    my @sorted = reverse sort @input;
    return @sorted[0] >= 2 * @sorted[1];
}
for <1 2 3 4>, <1 2 0 5>, <2 6 3 1>, <4 5 2 3> -> @test {
    say @test, " -> ", is-twice-as-large(@test) ?? 1 !! -1;
}

This script displays the following output:

$ raku ./twice.raku
(1 2 3 4) -> -1
(1 2 0 5) -> 1
(2 6 3 1) -> 1
(4 5 2 3) -> -1

Twice Largest in Perl

This is a port to Perl of the Raku program above. The explanations and comments made above also apply here.

use strict;
use warnings;
use feature qw/say/;

sub is_twice_as_large {
    my @sorted = sort { $b <=> $a } @_;
    return $sorted[0] >= 2 * $sorted[1];
}
for my $test ( [<1 2 3 4>], [<1 2 0 5>], 
               [<2 6 3 1>], [<4 5 2 3>] ) {
    say "@$test -> ", is_twice_as_large(@$test) ? 1 : -1;
}

This script displays the following output:

$ perl twice.pl
1 2 3 4 -> -1
1 2 0 5 -> 1
2 6 3 1 -> 1
4 5 2 3 -> -1

Task 2: Cute List

You are given an integer, 0 < $n <= 15.

Write a script to find the number of orderings of numbers that form a cute list.

With an input @list = (1, 2, 3, .. $n) for positive integer $n, an ordering of @list is cute if for every entry, indexed with a base of 1, either

1) $list[$i] is evenly divisible by $i or 2) $i is evenly divisible by $list[$i]

Example

Input: $n = 2
Ouput: 2

Since $n = 2, the list can be made up of two integers only i.e. 1 and 2.
Therefore we can have two list i.e. (1,2) and (2,1).

@list = (1,2) is cute since $list[1] = 1 is divisible by 1 
and $list[2] = 2 is divisible by 2.

I wish we had a non-trivial example with more items in the input list, but my understanding is as follows: for a given integer $n, we first build the list of positive integers from 1 to $n and then check every permutation of the list to verify whether it is a cute list, as defined by the two divisibility properties stated above.

Cute List in Raku

The count-cute subroutine generates all permutations of the input list and, for each permutation, calls the is-cute subroutine to figure out whether such permutation is a cute list.

For the purpose of testing, we run the count-cute subroutine for every integer between 1 and 10. We did no go further because the program is becoming very slow for even moderately large input values: the number of permutations of a list grows as the factorial of the number of its items, so that we have essentially an exponential explosion. The performance is further slowed down by the fact that checking each permutation takes longer when the permutations have more items.

sub is-cute (@list) {
    my @new = (0, @list).flat;
    for 1..@list.elems -> $i {
        return False unless $i %% @new[$i] or @new[$i] %% $i;
    }
    return True;
}

sub count-cute ($k) {
    my $count = 0;
    for (1..$k).permutations -> @perm {
        $count++ if is-cute @perm;
    }
    return $count;
}

for 1..10 -> $j {
    say "$j -> ", count-cute $j;
}

This script displays the following output and timings:

$ time raku ./cute-list.raku
1 -> 1
2 -> 2
3 -> 3
4 -> 8
5 -> 10
6 -> 36
7 -> 41
8 -> 132
9 -> 250
10 -> 700

real    0m36,083s
user    0m0,000s
sys     0m0,031s

Using the Native Calling Interface and replacing the is-cute subroutine by a C is_cute function improves the performance quite a bit, but not enough to solve or even significantly alleviate the combinatorial nightmare:

real    0m26,208s
user    0m0,000s
sys     0m0,015s

Cute List in Perl

This is essentially a port to Perl of the Raku program above. Please refer to the comments above for further information. Since Perl doesn’t have a built-in permutations routine, we build our own recursive permute subroutine. Note that the Perl implementation is about twice faster than the Raku implementation. Raku is still significantly slower than Perl, but the good news is that its performance is slowly catching up.

use strict;
use warnings;
use feature qw/say/;

my @permutations;

sub is_cute {
    my @new = (0, @_);
    for my $i (1.. scalar @_) {
        return 0 if $i % $new[$i] and $new[$i] % $i;
    }
    return 1;
}

sub permute {
    my ($done, $left) = @_;
    if (scalar @$left == 0) {
        push @permutations, $done;
        return;
    }
    my @left = @$left;
    permute([ @$done, $left[$_]], [@left[0..$_-1], @left[$_+1..$#left]]) for 0..$#left;
}

sub count_cute {
    my $k = shift;
    my $count = 0;
    @permutations = ();
    permute([], [1..$k]);
    for my $perm (@permutations) {
        $count++ if is_cute @$perm;
    }
    return $count;
}

for my $j (1..10) {
    say "$j -> ", count_cute $j;
}

This script displays the following output and timings:

$ time perl ./cute-list.pl
1 -> 1
2 -> 2
3 -> 3
4 -> 8
5 -> 10
6 -> 36
7 -> 41
8 -> 132
9 -> 250
10 -> 700

real    0m18,773s
user    0m17,687s
sys     0m0,858s

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

These are some answers to the Week 190 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, 13, 2022 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: Capital Detection

You are given a string with alphabetic characters only: A..Z and a..z.

Write a script to find out if the usage of Capital is appropriate if it satisfies at least one of the following rules:

1) Only first letter is capital and all others are small. 2) Every letter is small. 3) Every letter is capital.

Example 1

Input: $s = 'Perl'
Output: 1

Example 2

Input: $s = 'TPF'
Output: 1

Example 3

Input: $s = 'PyThon'
Output: 0

Example 4

Input: $s = 'raku'
Output: 1

The easiest here is to use regexes to check whether letters are upper- or lowercase.

Capital Detection in Raku

Raku’s Regexes system has predefined character classes <:Ll> and <:Lu> for, respectively, lowercase and uppercase characters. It is pretty easy to combine them to fulfill the task.

sub is-correct-case ($str) {
    # All lowercase or all uppercase:
    return 1 if $str ~~ /^<:Ll>+$ | ^<:Lu>+$ /;
    # One uppercase followed by only lowercase 
    return 1 if $str ~~ /^<:Lu><:Ll>+$/; 
    return 0;
}
for < Perl TPF PyThon raku Raku RAKU RaKu raKu > -> $str {
    printf "% -8s -> %d\n", $str, is-correct-case $str;
}

This script displays the following output:

$ raku ./capital-detection.raku
Perl     -> 1
TPF      -> 1
PyThon   -> 0
raku     -> 1
Raku     -> 1
RAKU     -> 1
RaKu     -> 0
raKu     -> 0

Capital Detection in Perl

This is a port to Perl of the above Raku program. In Perl, we use the [a-z] and [A-Z] character classes for lowercase and uppercase characters.

use strict;
use warnings;
use feature qw/say/;

sub is_correct_case {
    my $str = shift;
    # All lowercase or all uppercase:
    return 1 if $str =~ /^[a-z]+$|^[A-Z]+$/;
    # One uppercase followed by only lowercase 
    return 1 if $str =~ /^[A-Z][a-z]+$/; 
    return 0;
}
for my $str (<Perl TPF PyThon raku Raku RAKU RaKu raKu>) {
    printf "% -8s -> %d\n", $str, is_correct_case $str;
}

This script displays the following output:

$ perl ./capital-detection.pl
Perl     -> 1
TPF      -> 1
PyThon   -> 0
raku     -> 1
Raku     -> 1
RAKU     -> 1
RaKu     -> 0
raKu     -> 0

Task 2: Decoded List

You are given an encoded string consisting of a sequence of numeric characters: 0..9, $s.

Write a script to find the all valid different decodings in sorted order.

Encoding is simply done by mapping A,B,C,D,… to 1,2,3,4,… etc.

Example 1

Input: $s = 11
Ouput: AA, K

11 can be decoded as (1 1) or (11) i.e. AA or K

Example 2

Input: $s = 1115
Output: AAAE, AAO, AKE, KAE, KO

Possible decoded data are:
(1 1 1 5) => (AAAE)
(1 1 15)  => (AAO)
(1 11 5)  => (AKE)
(11 1 5)  => (KAE)
(11 15)   => (KO)

Example 3

Input: $s = 127
Output: ABG, LG

Possible decoded data are:
(1 2 7) => (ABG)
(12 7)  => (LG)

One question coming to my mind is what to do with zeros. By itself, a 0 cannot be a letter, so we could simply exclude any integer containing a 0. On the other hand, it can be used as part of numbers 10 (letter J) and 20 (letter T). I’ve decided to disregard 0 as a stand-alone digit, but still to use it as part of a two-digit combination when possible.

Decoded List in Raku

We use the decode recursive subroutine to build all the possible 1- or 2-digit combinations from the input number. We store the possible strings in the @result array and sort it at the end for final output. The %map trans-coding matrix is build using the Z zip infix operator.

my %map = (1..26 Z 'A'..'Z').flat;
my @result;
# say %map; # {1 => A, 10 => J, 11 => K, 12 => L,...

sub decode (@list, $out) {
    if @list.elems == 0 {
        push @result, $out;
        return;
    }
    if @list[0] != 0 {
        decode @list[1..@list.end], $out ~ %map{@list[0]};
        return if @list.elems == 1;
        if @list[0] == 1 or (@list[0] == 2 and @list[1] <= 6) {
            decode @list[2..@list.end], $out ~ %map{@list[0] ~ @list[1]};
        }
    }
}

for 11, 1115, 5115, 127, 1207 -> $num {
    my @digits = $num.comb;
    @result = ();
    decode @digits, "";
    say "$num \t -> ", join ", ", sort @result;
}

This script displays the following output:

$ raku ./decoded-list.raku
11       -> AA, K
1115     -> AAAE, AAO, AKE, KAE, KO
5115     -> EAAE, EAO, EKE
127      -> ABG, LG
1207     -> ATG

Decoded List in Perl

We use the decode recursive subroutine to build all the possible 1- or 2-digit combinations from the input number. We store the possible strings in the @result array and sort it at the end for final output. The %map trans-coding matrix is build by mapping the 'A'..'Z' to a counter incremented by 1 at each step.

use strict;
use warnings;
use feature qw/say/;

my @result;
my $i = 1;
my %map = map { $i++ => $_ } 'A'..'Z';

sub decode {
    my @list = @{$_[0]};
    my $out = $_[1];
    push @result, $out and return if scalar @list == 0;
    if ($list[0] != 0) {
        decode ([@list[1..$#list]], $out . $map{$list[0]});
        return if scalar @list == 1;
        if ($list[0] == 1 or ($list[0] == 2 and $list[1] <= 6)) {
            decode ([@list[2..$#list]], $out . $map{$list[0] . $list[1]});
        }
    }
}    

for my $num (11, 1115, 5115, 127, 1207) {
    my @digits = split //, $num;
    @result = ();
    decode [@digits], "";
    say "$num \t -> ", join ", ", @result;
}

This script displays the following output:

$ perl ./decoded-list.pl
11       -> AA, K
1115     -> AAAE, AAO, AKE, KAE, KO
5115     -> EAAE, EAO, EKE
127      -> ABG, LG
1207     -> ATG

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

These are some answers to the Week 189 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, 6, 2022 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: Greater Character

You are given an array of characters (a..z) and a target character.

Write a script to find out the smallest character in the given array lexicographically greater than the target character.

Example 1

Input: @array = qw/e m u g/, $target = 'b'
Output: e

Example 2

Input: @array = qw/d c e f/, $target = 'a'
Output: c

Example 3

Input: @array = qw/j a r/, $target = 'o'
Output: r

Example 4

Input: @array = qw/d c a f/, $target = 'a'
Output: c

Example 5

Input: @array = qw/t g a l/, $target = 'v'
Output: v

Note that when the array has no item larger than the target value, the behavior is undefined. I do not think that the solution provided for the example 5 is valid. I prefer to state clearly that no solution was found.

Greater Character in Raku

The greater-char subroutine uses grep to build the list of characters lexicographically greater than the target value and returns the smallest one. The ability to use two (or more) loop variables ($k and @test) in a for pointy block is very practical here.

sub greater-char ($target, @input) {
    return @input.grep({ $_ gt $target }).min;
}
for ('b', <e m u g>), ('a', <d c e f>), ('o', <j a r>),
    ('a', <d c a f>), ('v', <t g a l>)  ->  ($k, @test) {
    say "$k, (@test[]) \t -> ", greater-char($k, @test);
}

This program displays the following output:

$ raku ./greater-char.raku
b, (e m u g)     -> e
a, (d c e f)     -> c
o, (j a r)       -> r
a, (d c a f)     -> c
v, (t g a l)     -> Nil

Greater Character in Perl

The greater_char subroutine uses grep to build the list of characters lexicographically greater than the target value and returns the smallest one. Here, we lazily use sort to find the smallest character of the list; this is not the best algorithmic method (and it might not be good for very long lists of characters), but it is the fastest to develop. Saving development time is sometimes better than saving a few CPU cycles.

In the event that the character lists were significantly longer, we could use a min subroutine such as this one developed for a previous Perl Weekly Challenge task:

sub min {
    my $min = shift;
    for (@_) {
        $min = $_ if $_ lt $min;
    }
    return $min;
}

But this is not really needed here, so we use the built-in sort function.

use strict;
use warnings;
use feature qw/say/;

sub greater_char  {
    my @eligible_input = grep { $_ gt $_[0]} @{$_[1]};
    return (sort @eligible_input)[0];
}

for my $test (['b', [<e m u g>]], ['a', [<d c e f>]], 
    ['o', [<j a r>]], ['a', [<d c a f>]], ['v', [<t g a l>]]) {
    say "$test->[0] (@{$test->[1]}) \t -> ", greater_char($test->[0], $test->[1]);
}

This program displays the following output:

$ perl greater-char.pl
b (e m u g)      -> e
a (d c e f)      -> c
o (j a r)        -> r
a (d c a f)      -> c
v (t g a l)      ->

Task 2: Array Degree

You are given an array of 2 or more non-negative integers.

Write a script to find out the smallest slice, i.e. contiguous subarray of the original array, having the degree of the given array.

> The degree of an array is the maximum frequency of an element in the array.

Example 1

Input: @array = (1, 3, 3, 2)
Output: (3, 3)

The degree of the given array is 2.
The possible subarrays having the degree 2 are as below:
(3, 3)
(1, 3, 3)
(3, 3, 2)
(1, 3, 3, 2)

And the smallest of all is (3, 3).

Example 2

Input: @array = (1, 2, 1, 3)
Output: (1, 2, 1)

Example 3

Input: @array = (1, 3, 2, 1, 2)
Output: (2, 1, 2)

Example 4

Input: @array = (1, 1, 2, 3, 2)
Output: (1, 1)

Example 5

Input: @array = (2, 1, 2, 1, 1)
Output: (1, 2, 1, 1)

The definition of the degree of an array doesn’t state what the degree should be when more than one element reaches the maximum frequency. In my implementations, I have changed examples 3 and 4 of the task specification to avoid the problem.

Array Degree in Raku

The get-degree subroutine builds an %histogram hash of input integers with their frequency, and returns the histogram key having the highest value. Then, the main part of the program uses twice the built-in first routine to find the first and last occurrences of the computed degree in the input list.

sub get-degree (@input) {
    my %histogram;
    %histogram{$_}++ for @input;
    return (%histogram.max({$_.value})).key;
}

for <1 3 3 2>, <1 2 1 3>, <4 3 2 1 2> ,
    <1 1 2 3 4>, <2 1 2 1 1> -> @test {
    my $degree = get-degree(@test);
    my $start = @test.first: * == $degree, :k;
    my $end =   @test.first: * == $degree, :k :end;
    say "@test[] \t => @test[$start..$end]";
}

This program displays the following output:

$ raku ./array-degree.raku
1 3 3 2          => 3 3
1 2 1 3          => 1 2 1
4 3 2 1 2        => 2 1 2
1 1 2 3 4        => 1 1
2 1 2 1 1        => 1 2 1 1

Array Degree in Perl

The get_degree subroutine builds an histogram of input integers with their frequency, and returns the histogram key having the highest value. Note that, here again, we lazily use the built-in sort function to find the largest value. Please see my comment in the Greater Character in Perl section above about algorithmically better solutions. In the main part of the program, we just loop once over the list to find the first and last occurrences of the degree in the input list.

use strict;
use warnings;
use feature qw/say/;

sub get_degree {
    my %histo;  # histogram
    $histo{$_}++ for @_;
    return (sort { $histo{$b} <=> $histo{$a} } keys %histo)[0]
}

for my $test ([<1 3 3 2>], [<1 2 1 3>], 
    [<4 3 2 1 2>], [<1 1 2 3 4>], [<2 1 2 1 1>]) {
    my @list = @$test;
    my $degree = get_degree @list;
    my ($start, $end);
    for my $i (0..$#list) {
        if ($list[$i] == $degree) {
            $start = $i unless defined $start;
            $end = $i;
        }
    }
    say "@list \t => @list[$start..$end]";
}

This program displays the following output:

$ perl ./array-degree.pl
1 3 3 2          => 3 3
1 2 1 3          => 1 2 1
4 3 2 1 2        => 2 1 2
1 1 2 3 4        => 1 1
2 1 2 1 1        => 1 2 1 1

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