Actions from laurent_r Movable Type Pro 4.38 2023-05-30T18:30:13Z https://blogs.perl.org/mt/mt-cp.cgi?__mode=feed&_type=actions&blog_id=0&id=4694 Posted Perl Weekly Challenge 219: Sorted Squares to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11117 2023-05-30T17:30:13Z 2023-05-30T17:32:38Z These are some answers to the Week 219, 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 June 4, 2023 at 23:59).... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 219, 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 June 4, 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.

## Sorted Squares

You are given a list of numbers.

Write a script to square each number in the list and return the sorted list, increasing order.

Example 1

``````Input: @list = (-2, -1, 0, 3, 4)
Output: (0, 1, 4, 9, 16)
``````

Example 2

``````Input: @list = (5, -4, -1, 3, 6)
Output: (1, 9, 16, 25, 36)
``````

### Sorted Squares in Raku

This is quite simple. The program uses a pipeline to chain a code block to replace the input values by their squares (`map {\$_²}`) and the sort routine. Note that, in Raku, the `sort` built-in function is clever enough to sort numbers numerically and strings lexicographically, so that we don't need to specify the type of `sort` we want to use. Please also note that the `²` postfix operator returns the square of the operand.

``````sub sorted-squares (@in) {
return sort map {\$_²}, @in;
}

for (-2, -1, 0, 3, 4), (5, -4, -1, 3, 6) -> @test {
say "@test[]".fmt("%-15s => "), sorted-squares @test;
}
``````

This program displays the following output:

``````\$ raku ./sorted-squares.raku
-2 -1 0 3 4     => (0 1 4 9 16)
5 -4 -1 3 6     => (1 9 16 25 36)
``````

This script is so simple that we can transform it into a Raku one-liner:

``````\$ raku -e 'say sort map {\$_²}, @*ARGS' -2 -1 0 3 4
(0 1 4 9 16)
``````

### Sorted Squares in Perl

This is a port to Perl of the same data pipeline. Please refer to the above section for explanations if needed. Note that, in Perl, we need to specify that we want a numeric sort (with the `{\$a <=> \$b}` block).

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

sub sorted_squares {
return sort {\$a <=> \$b} map \$_ * \$_, @_;
}

for my \$test ([-2, -1, 0, 3, 4], [5, -4, -1, 3, 6]) {
printf "%-15s => ", "@\$test";
say join " ", sorted_squares @\$test;
}
``````

This program displays the following output:

``````\$ perl ./sorted-squares.pl
-2 -1 0 3 4     => 0 1 4 9 16
5 -4 -1 3 6     => 1 9 16 25 36
``````

Note that we can also turn this program into a simple Perl one-liner:

``````\$ perl -E 'say join " ", sort {\$a <=> \$b} map \$_ * \$_,
@ARGV'  2 -1 0 -3 4
0 1 4 9 16
``````

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

]]>
Posted Perl Weekly Challenge 218: Maximum Product and Matrix Score to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11116 2023-05-29T21:32:24Z 2023-05-29T21:34:24Z These are some answers to the Week 218 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Note: the programs presented here were written several days ago, but I was unable to write this blog post in time due... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 218 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Note: the programs presented here were written several days ago, but I was unable to write this blog post in time due to various reasons, including lack of time and some serious problems with my computer.

You are given a list of 3 or more integers.

Write a script to find the 3 integers whose product is the maximum and return it.

Example 1

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

1 x 2 x 3 => 6
``````

Example 2

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

2 x 3 x 4 => 24
``````

Example 3

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

1 x 1 x 3 => 3
``````

Example 4

``````Input: @list = (-8, 2, -9, 0, -4, 3)
Output: 216

-9 × -8 × 3 => 216
``````

### Maximum Product in Raku

The program first sorts the input integers in ascending order of their absolute values. Then it looks for products of either only positive values, or products with an even count of negative values. Since the number of edge cases can become somewhat large, I decided to go to brute force once the first simple cases have been tested with no solution.

``````sub max-prod (@in) {
my @list = reverse sort { .abs }, @in;
return [*] @list[0..2] if @list[0..2].all > 0
or @list[0..2].one > 0;
if @list[0..2].all < 0 {
# find first positive value to replace one neg
my \$first = @list[3..@list.end].first({ \$_ > 0});
return [*] (@list[0..1], \$first).flat if \$first.defined;
}
# brute force if we get here
my @comb-prods = gather {
for @list.combinations: 3 -> @comb {
take [*] @comb;
}
}
return @comb-prods.max;
}
for (3, 1, 2), (4, 1, 3, 2), (-1, 0, 1, 3, 1),
(-8, 2, -9, 0, -4, 3), (-8, 2, 3, 5, 6) -> @test {
say "@test[]".fmt("%-15s => "), max-prod @test;
}
``````

This program displays the following output:

``````\$ raku ./max-prod.raku
3 1 2           => 6
4 1 3 2         => 24
-1 0 1 3 1      => 3
-8 2 -9 0 -4 3  => 216
-8 2 3 5 6      => 90
``````

### Maximum Product in Perl

The program first sorts the input integers in ascending order of their absolute values. Then it looks for products of either only positive values, or products with an even count of negative values. Note that I decided to go for brute force one step earlier than in Raku.

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

sub prod {
my \$prod = shift;
\$prod *= \$_ for @_;
return \$prod;
}

sub max_prod {
my @list = sort { abs(\$b) <=> abs(\$a) } @_;
return prod @list[0..2] if 0 < prod @list[0..2];
# brute force if we get here
my \$max = \$_;
for my \$i (0..\$#list) {
for my \$j (\$i+1..\$#list) {
for my \$k (\$j+1..\$#list) {
my \$prod = \$list[\$i] * \$list[\$j] * \$list[\$k];
\$max = \$prod if \$prod > \$max;
}
}
}
return \$max;
}
for my \$test ([3, 1, 2], [4, 1, 3, 2], [-1, 0, 1, 3, 1],
[-8, 2, -9, 0, -4, 3], [-8, 2, 3, 5, 6]) {
printf "%-15s => ", "@\$test";
say max_prod @\$test;
}
``````

This program displays the following output:

``````\$ perl ./max-prod.pl
3 1 2           => 6
4 1 3 2         => 24
-1 0 1 3 1      => 3
-8 2 -9 0 -4 3  => 216
-8 2 3 5 6      => 90
``````

You are given a m x n binary matrix i.e. having only 1 and 0.

You are allowed to make as many moves as you want to get the highest score.

``````A move can be either toggling each value in a row or column.
``````

To get the score, convert the each row binary to dec and return the sum.

Example 1:

``````Input: @matrix = [ [0,0,1,1],
[1,0,1,0],
[1,1,0,0], ]
Output: 39

Move #1: convert row #1 => 1100
[ [1,1,0,0],
[1,0,1,0],
[1,1,0,0], ]

Move #2: convert col #3 => 101
[ [1,1,1,0],
[1,0,0,0],
[1,1,1,0], ]

Move #3: convert col #4 => 111
[ [1,1,1,1],
[1,0,0,1],
[1,1,1,1], ]

Score: 0b1111 + 0b1001 + 0b1111 => 15 + 9 + 15 => 39
``````

Example 2:

Input: @matrix = [  ] Output: 1

### Matrix Score in Raku

The `toggle_col` toggles values in a matrix column. The rest of the program is a heuristic approach rather than an algorithm, i.e. it is quite likely to produce the best result or at least something fairly close to it, but there may be some pathological inputs for which the program won’t be able to find the best solution. The main reason for that is that there is no obvious limit to the number of moves. The general idea is to pack as many `1`’s as possible in the left rows because they are the most significant digits for the final result.

``````sub toggle_col (@in, \$i) {
for 0..@in.end -> \$j {
@in[\$j][\$i] = +not @in[\$j][\$i];
}
}
sub improve-score (@in) {
my \$col-max = @in.elems - 1;
my \$row-max = @in.elems - 1;
for @in -> @row {
if @row == 0 {
\$_ = +not \$_ for @row;
}
}
for 0..\$row-max -> \$index {
my @col;
push @col, @in[\$_][\$index] for 0..\$col-max;
toggle_col(@in, \$index) if @in.elems/2 > [+] @col;
}
return @in;
}

my @test = [0,0,1,1], [1,0,1,0], [1,1,0,0];
say "Test: ", @test;
my @new-mat =  improve-score @test;
say "Result: ", @new-mat;
say "Score: ", [+] map {\$_.join('').parse-base(2)}, @new-mat;
``````

This program displays the following output:

``````\$ raku ./matrix-score.raku
Test: [[0 0 1 1] [1 0 1 0] [1 1 0 0]]
Result: [[1 1 1 1] [1 0 0 1] [1 1 1 1]]
Score: 39
``````

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

]]>
Posted Perl Weekly Challenge 217: Sorted Matrix and Max Number to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11103 2023-05-16T14:09:54Z 2023-05-16T14:44:05Z These are some answers to the Week 217 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 May 21, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 217 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 May 21, 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.

You are given a `n x n` matrix where `n >= 2`.

Write a script to find 3rd smallest element in the sorted matrix.

Example 1

``````Input: @matrix = ([3, 1, 2], [5, 2, 4], [0, 1, 3])
Output: 1

The sorted list of the given matrix: 0, 1, 1, 2, 2, 3, 3, 4, 5.
The 3rd smallest of the sorted list is 1.
``````

Example 2

``````Input: @matrix = ([2, 1], [4, 5])
Output: 4

The sorted list of the given matrix: 1, 2, 4, 5.
The 3rd smallest of the sorted list is 4.
``````

Example 3

``````Input: @matrix = ([1, 0, 3], [0, 0, 0], [1, 2, 1])
Output: 0

The sorted list of the given matrix: 0, 0, 0, 0, 1, 1, 1, 2, 3.
The 3rd smallest of the sorted list is 0.
``````

### Sorted Matrix in Raku

The `find-third-smallest` subroutine simply sorts the values of the matrix in ascending order and returns the third item of the list (index 2). The only slight difficulty is to properly flatten the matrix data structure into a simple list, which requires here the use of two nested calls to the flat routine. The bulk of the work is done in just one code-line.

``````sub find-third-smallest (@matrix) {
return (flat map {.flat}, @matrix).sort;
}

for ([3, 1, 2], [5, 2, 4], [0, 1, 3]),
([2, 1], [4, 5]),
([1, 0, 3], [0, 0, 0], [1, 2, 1])
-> @test {
say @test, " => ", find-third-smallest(@test);
}
``````

This program displays the following output:

``````\$ raku ./third-smallest.raku
([3 1 2] [5 2 4] [0 1 3]) => 1
([2 1] [4 5]) => 4
([1 0 3] [0 0 0] [1 2 1]) => 0
``````

### Sorted Matrix in Perl

The is no `flat` routine in Perl, but the task is somewhat easier in Perl than in Raku because, in many situations, Perl automatically flattens the arguments to a subroutine. Note that in Perl, we need the `{ \$a <=> \$b }` argument to the `sort` function to force a numeric sort (in Perl, the default is lexicographic sort).

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

sub find_third_smallest {
return (sort { \$a <=> \$b } map { @\$_ } @_);
}

for my \$test ( [ [3, 1, 2], [5, 2, 4], [0, 1, 3] ],
[ [2, 1], [4, 5] ],
[ [1, 0, 3], [0, 0, 0], [1, 2, 1] ] ) {
print map "[@\$_] ", @\$test;
say " => ", find_third_smallest @\$test;
}
``````

This program displays the following output:

``` \$ perl ./third_smallest.pl [3 1 2] [5 2 4] [0 1 3] => 1 [2 1] [4 5] => 4 [1 0 3] [0 0 0] [1 2 1] => 0 ```

You are given a list of positive integers.

Write a script to concatenate the integers to form the highest possible value.

Example 1:

``````Input: @list = (1, 23)
Output: 231
``````

Example 2:

``````Input: @list = (10, 3, 2)
Output: 3210
``````

Example 3:

``````Input: @list = (31, 2, 4, 10)
Output: 431210
``````

Example 4:

``````Input: @list = (5, 11, 4, 1, 2)
Output: 542111
``````

Example 5:

``````Input: @list = (1, 10)
Output: 110
``````

Basically, we need to reorder the input integers in such a way that numbers starting with the largest digit come first. In other words, we need to perform a lexicographic sort (in descending order) on the input integers. In Raku, implementing this approach could be as simple as this, using the leg operator for comparing various input operands within the `sort` built-in function:

``````# Caution: wrong solution
sub reorder (@in) {
return @in.sort({\$^b leg \$^a}).join: "";
}
``````

This gives a correct solution for most input lists, but, unfortunately, this doesn’t work as I originally expected for some input lists. For example, if given the `(1, 10)` input list, the lexicographic sort would produce `(10, 1)`, leading to the number 101, whereas it is obvious that the proper solution is 110.

So, we need some variation to the lexicographic sort in which we would obtain `(1, 10)`.

### Max Number in Raku

So, the `leg` operator sometimes doesn’t work as desired for our purpose when one of the integers to be compared is equal to the beginning of the other, as in the `(10, 1)` example.

At this point, we could decide to go for a radically different approach, but, since it is quite easy to create new operators in Raku, I decided that I’d rather want to keep the approach and to create my own custom `myleg` operator to properly handle the special case described above. Basically, it returns the same thing as `leg`, except when it hits the aforesaid special case.

``````sub infix:<myleg> (\$a, \$b) {
return \$a leg \$b if \$a.chars == \$b.chars;
if \$a.chars > \$b.chars {
my \$c = substr \$a, 0, \$b.chars;
return \$a leg \$b if \$c != \$b;
return (substr \$a, \$b.chars + 1) leg \$c ;
} else {
my \$c = substr \$b, 0, \$a.chars;
return \$a leg \$b if \$c != \$a;
return \$c leg (substr \$b, \$a.chars + 1);
}
}

sub reorder (@in) {
return @in.sort({\$^b myleg \$^a}).join: "";
}

for (1, 23), (10, 3, 2), (31, 2, 4, 10),
(5, 11, 4, 1, 2), (1, 10), (10, 1),
(1, 10), (1, 100), (100, 1) -> @test {
say "@test[]".fmt("%-15s => "), reorder @test;
}
``````

This program now works as expected and displays the following output:

``````\$ raku ./max-number.raku
1 23            => 231
10 3 2          => 3210
31 2 4 10       => 431210
5 11 4 1 2      => 542111
1 10            => 110
10 1            => 110
1 10            => 110
1 100           => 1100
100 1           => 1100
``````

I got a bit carried away by my original (wrong) solution. The code of the `myleg` infix operator could be made much simpler:

``````sub infix:<myleg> (\$a, \$b) {
return \$a~\$b <=> \$b~\$a;
}
``````

The modified program displays the same output as before.

### Max Number in Perl

This is a port to Perl of the Raku program just above. Please refer to the above section for explanations. We cannot create new operators in Perl, but we might as well write a subroutine to be called by the `sort` function.

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

sub mycmp {
my (\$i, \$j) = @_;
return \$i.\$j <=> \$j.\$i;
}

sub reorder {
return join "", sort { mycmp (\$b, \$a) } @_;
}

for my \$test ([1, 23], [10, 3, 2], [31, 2, 4, 10],
[5, 11, 4, 1, 2], [1, 10], [10, 1],
[1, 10], [1, 100], [100, 1]) {
printf "%-15s => ", "@\$test";
say reorder @\$test;
}
``````

This program displays the following output:

``````\$ perl ./max-number.pl
1 23            => 231
10 3 2          => 3210
31 2 4 10       => 431210
5 11 4 1 2      => 542111
1 10            => 110
10 1            => 110
1 10            => 110
1 100           => 1100
100 1           => 1100
``````

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

]]>
Posted Perl Weekly Challenge 216: Registration Number to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11097 2023-05-10T16:42:17Z 2023-05-10T16:43:58Z These are some answers to the Week 216 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 May 14, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 216 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 May 14, 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.

You are given a list of words and a random registration number.

Write a script to find all the words in the given list that has every letter in the given registration number.

Example 1

``````Input: @words = ('abc', 'abcd', 'bcd'), \$reg = 'AB1 2CD'
Output: ('abcd')

The only word that matches every alphabets in the given registration number is 'abcd'.
``````

Example 2

``````Input: @words = ('job', 'james', 'bjorg'), \$reg = '007 JB'
Output: ('job', 'bjorg')
``````

Example 3

``````Input: @words = ('crack', 'road', 'rac'), \$reg = 'C7 RA2'
Output: ('crack', 'rac')
``````

### Registration Number in Raku

We first store the letters of the registration number into a Set. Then, we convert each input word into a set of its letter and use the infix `(<=)` or infix `⊆` (is a subset of or is equal to) set operator to find whether the input word contains all letters of the registration number.

``````sub included (@words, \$reg) {
my \$letters = \$reg.lc.comb.grep({ /<[a..z]>/ }).Set;
my @result;
for @words -> \$wd {
push @result, \$wd if \$letters ⊆ \$wd.lc.comb.Set;
}
return @result;
}
my @tests =
{words => ('abc', 'abcd', 'bcd'), reg => 'AB1 2CD'},
{words => ('job', 'james', 'bjorg'), reg => '007 JB'},
{words => ('crack', 'road', 'rac'), reg => 'C7 RA2'};
for @tests -> %test {
printf "%-30s", "%test<words> - %test<reg> => ";
say included %test<words>, %test<reg>;
}
``````

This program displays the following output:

``````\$ raku ./registration-nr.raku
abc abcd bcd - AB1 2CD =>     [abcd]
job james bjorg - 007 JB =>   [job bjorg]
crack road rac - C7 RA2 =>    [crack rac]
``````

### Registration Number in Perl

This is essentially a port to Perl of the above Raku problem. Since Perl doesn’t have `Sets`, we use hashes instead, and we use a `grep` to find out whether there are letters of the registration number that do not belong to the letters of the input words.

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

sub included {
my @words = @{\$_};
my \$reg = lc \$_;
# say @words;
my @letters = grep { /[a-z]/ } split //, \$reg;
# say @letters;
my @result;
for my \$wd (@words) {
my %wd_lets = map { \$_ => 1 } split //, \$wd;
my @missing = grep { not exists \$wd_lets{\$_} } @letters;
push @result, \$wd if scalar @missing == 0;
}
return @result;
}
my @tests = (
{words => ['abc', 'abcd', 'bcd'], reg => 'AB1 2CD'},
{words => ['job', 'james', 'bjorg'], reg => '007 JB'},
{words => ['crack', 'road', 'rac'], reg => 'C7 RA2'}
);
for my \$test (@tests) {
printf "%-30s", "@{\$test->{words}} - \$test->{reg} => ";
say join " ", included \$test->{words}, \$test->{reg};
}
``````

This program displays the following output:

``````\$ perl ./registration.pl
abc abcd bcd - AB1 2CD =>     abcd
job james bjorg - 007 JB =>   job bjorg
crack road rac - C7 RA2 =>    crack rac
``````

I don’t have time right now for this second task. I may be doing it later.

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

]]>
Posted Perl Weekly Challenge 215: Odd One Out and Number Placement to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11087 2023-05-03T17:45:41Z 2023-05-03T17:52:24Z These are some answers to the Week 215 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 May 7, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 215 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 May 7, 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: Odd One Out

You are given a list of words (alphabetic characters only) of same size.

Write a script to remove all words not sorted alphabetically and print the number of words in the list that are not alphabetically sorted.

Example 1

``````Input: @words = ('abc', 'xyz', 'tsu')
Output: 1

The words 'abc' and 'xyz' are sorted and can't be removed.
The word 'tsu' is not sorted and hence can be removed.
``````

Example 2

``````Input: @words = ('rat', 'cab', 'dad')
Output: 3

None of the words in the given list are sorted.
Therefore all three needs to be removed.
``````

Example 3

``````Input: @words = ('x', 'y', 'z')
Output: 0
``````

First, I’ll assume that “sorted alphabetically” means sorted in ascending alphabetic order, as alphabetic order almost always means ascending alphabetic order (unless explicitly specified otherwise).

Second, we’re requested to remove from the list all words not sorted alphabetically, but should print only the number of words in the list that are not alphabetically sorted. We don’t really need to remove words not sorted alphabetically to count them.

Last, but not least, the specification is quite ambiguous, but I disagree with example 2: I consider that ‘cab’ and ‘dad’ are properly sorted, just like the two first words of example 1 are sorted. Otherwise, if we had a list of, say, 100 sorted words preceded with just 1 word out of order, we would have to declare that none of the words in the given list are sorted, which hardly makes sense. So, to me, the output for example 2 should be one, as only one word (‘rat’) needs to be removed (or possibly relocated) to obtain a sorted list.

### Odd One Out in Raku

This program counts the number of times a word is less than its predecessor in the alphabetic order.

``````sub find-non-sorted (@in) {
my @out = @in;
my \$count = 0;
for 1..@in.end -> \$i {
if @in[\$i] lt @in[\$i-1] {
\$count++;
} else {
push @out, @in[\$i];
}
}
say @out;
return \$count;
}
for <abc xyz tsu>, <rat cab dad>, <x y z> -> @test {
printf "%-15s => ", ~@test;
say find-non-sorted @test;
}
``````

This program displays the following output:

``````\$ raku ./odd-one-out.raku
abc xyz tsu     => 1
x y z           => 0
``````

### Odd One Out in Perl

This program counts the number of times a word is less than its predecessor in the alphabetic order.

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

sub find_non_sorted {
my @in = @_;
my @out = \$in;
my \$count = 0;
for my \$i (1..\$#in) {
if (\$in[\$i] lt \$in[\$i-1]) {
\$count++;
} else {
push @out, \$in[\$i];
}
}
# say @out;
return \$count;
}

for my \$test ([<abc xyz tsu>], [<rat cab dad>], [<x y z>]) {
printf "%-15s => ", "@\$test";
say find_non_sorted @\$test;
}
``````

This program displays the following output:

``````\$ perl ./odd-one-out.pl
abc xyz tsu     => 1
x y z           => 0
``````

You are given a list of numbers having just 0 and 1. You are also given placement count (`>=1`).

Write a script to find out if it is possible to replace 0 with 1 in the given list. The only condition is that you can only replace when there is no 1 on either side. Print 1 if it is possible, otherwise 0.

Example 1:

``````Input: @numbers = (1,0,0,0,1), \$count = 1
Output: 1

You are asked to replace only one 0 as given count is 1.
We can easily replace middle 0 in the list i.e. (1,0,1,0,1).
``````

Example 2:

``````Input: @numbers = (1,0,0,0,1), \$count = 2
Output: 0

You are asked to replace two 0's as given count is 2.
It is impossible to replace two 0's.
``````

Example 3:

``````Input: @numbers = (1,0,0,0,0,0,0,0,1), \$count = 3
Output: 1
``````

Expressing “there is no 1 on either side” in Raku or Perl code is a bit of a pain in the neck, as there are numerous edge cases, notably when the zero or zeros to be removed are at the very beginning or very end of the input list. For example, if we’re trying to remove two zeros, if could be done in lists such as (0,0), (1,0,0,0), or (1,0,0,0,0,1). So, depending on the situation, we may need two, three, or four consecutive zeros to be able to remove two zeros.

To me, the simplest is to convert the input list into a string and to let the regex engine do the bulk of the work, which can be expressed in a single and simple code line both in Raku and Perl..

### Number Placement in Raku

We convert the input digits into a string and use the regexes’ negative lookaround assertions to express the “there is no 1 on either side” rule. In the

``````/ <!after 1> [0 ** {\$count}] <!before 1>/
``````

regex, `<!after 1>` is a negative lookbehind assertion, which means that the group of zeros matched by `[0 ** {\$count}]` should not be preceded by a 1 (it can be either preceded by another zero, or at the beginning of the string. Similarly, `<!before 1>` is a negative lookahead assertion, meaning that the group of zeros matched by `[0 ** {\$count}]` should not be followed by a 1.

``````sub find-zeros (@in, \$count) {
return False if \$count == 0 or @in.elems < \$count;
my \$str = join "", @in;
return so (\$str ~~ / <!after 1> [0 ** {\$count}] <!before 1>/)
}

for <0 0 0 1>, <0 0>, <1 0 0 1>, <1 0 0 0 1>,
<1 0 0 0 0 0 0 1> -> @test {
for 0..5 -> \$cnt {
printf "%d - %-16s => ", \$cnt, "@test[]";
say + find-zeros @test, \$cnt;
}
}
``````

This program displays the following output:

``````\$ raku ./number-placement.raku
0 - 0 0 0 1          => 0
1 - 0 0 0 1          => 1
2 - 0 0 0 1          => 1
3 - 0 0 0 1          => 0
4 - 0 0 0 1          => 0
5 - 0 0 0 1          => 0
0 - 0 0              => 0
1 - 0 0              => 1
2 - 0 0              => 1
3 - 0 0              => 0
4 - 0 0              => 0
5 - 0 0              => 0
0 - 1 0 0 1          => 0
1 - 1 0 0 1          => 0
2 - 1 0 0 1          => 0
3 - 1 0 0 1          => 0
4 - 1 0 0 1          => 0
5 - 1 0 0 1          => 0
0 - 1 0 0 0 1        => 0
1 - 1 0 0 0 1        => 1
2 - 1 0 0 0 1        => 0
3 - 1 0 0 0 1        => 0
4 - 1 0 0 0 1        => 0
5 - 1 0 0 0 1        => 0
0 - 1 0 0 0 0 0 0 1  => 0
1 - 1 0 0 0 0 0 0 1  => 1
2 - 1 0 0 0 0 0 0 1  => 1
3 - 1 0 0 0 0 0 0 1  => 1
4 - 1 0 0 0 0 0 0 1  => 1
5 - 1 0 0 0 0 0 0 1  => 0
``````

### Number Placement in Perl

This a port to Perl of the Raku program above. Please refer to the previous section for additional explanations. We convert the input digits into a string and use the regexes’ negative lookaround assertions. In Perl, `(?<!1)` is a negative lookbehind assertion (no 1 before), and `(?!1)` a negative lookahead assertion (no 1 after).

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

sub find_zeros {
my @in = @{\$_};
my \$count = \$_;
return 0 if \$count == 0 or @in < \$count;
my \$str = join "", @in;
return 1 if \$str =~ /(?<!1)0{\$count}(?!1)/;
0;
}

for my \$test ([<0 0 0 1>], [<0 0>], [<1 0 0 1>], [<1 0 0 0 1>],
[<1 0 0 0 0 0 0 1>]) {
for my \$cnt (0..5) {
printf "%d - %-16s => ", \$cnt, "@\$test";
say find_zeros \$test, \$cnt;
}
}
``````

This program displays the following output:

``````\$ perl ./number-placement.pl
0 - 0 0 0 1          => 0
1 - 0 0 0 1          => 1
2 - 0 0 0 1          => 1
3 - 0 0 0 1          => 0
4 - 0 0 0 1          => 0
5 - 0 0 0 1          => 0
0 - 0 0              => 0
1 - 0 0              => 1
2 - 0 0              => 1
3 - 0 0              => 0
4 - 0 0              => 0
5 - 0 0              => 0
0 - 1 0 0 1          => 0
1 - 1 0 0 1          => 0
2 - 1 0 0 1          => 0
3 - 1 0 0 1          => 0
4 - 1 0 0 1          => 0
5 - 1 0 0 1          => 0
0 - 1 0 0 0 1        => 0
1 - 1 0 0 0 1        => 1
2 - 1 0 0 0 1        => 0
3 - 1 0 0 0 1        => 0
4 - 1 0 0 0 1        => 0
5 - 1 0 0 0 1        => 0
0 - 1 0 0 0 0 0 0 1  => 0
1 - 1 0 0 0 0 0 0 1  => 1
2 - 1 0 0 0 0 0 0 1  => 1
3 - 1 0 0 0 0 0 0 1  => 1
4 - 1 0 0 0 0 0 0 1  => 1
5 - 1 0 0 0 0 0 0 1  => 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 May 14, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 213: Fun Sort to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11078 2023-04-17T19:02:02Z 2023-04-17T19:06:19Z These are some answers to the Week 213 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 April 23, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 213 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 April 23, 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.

You are given a list of positive integers.

Write a script to sort the all even integers first then all odds in ascending order.

Example 1

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

Example 2

``````Input: @list = (1,2)
Output: (2,1)
``````

Example 3

``````Input: @list = (1)
Output: (1)
``````

### Fun Sort in Raku

In theory, this task should ideally use a special comparison subroutine to be used with `sort` that leads to the desired sorting order.

It is, however, simpler to separate even and odd numbers into two lists (for example using `grep`), sort the lists and then reassemble the lists in the proper order.

``````sub fun-sort (@in) {
return (@in.grep({\$_ %% 2}).sort,
@in.grep({\$_ % 2}).sort).flat;
}

for <1 2 3 4 5 6>, <1 2>, (1,),
1..15, (1..15).reverse -> @test {
say fun-sort @test;
}
``````

This program displays the following output:

``````\$ raku ./fun-sort.raku
(2 4 6 1 3 5)
(2 1)
(1)
(2 4 6 8 10 12 14 1 3 5 7 9 11 13 15)
(2 4 6 8 10 12 14 1 3 5 7 9 11 13 15)
``````

For the fun of it, or perhaps for the sake of trying to be pedantic `;-)` , let’s see how we can do the same using a special comparison subroutine. Note that `Less` and `More` (and also `Same`) are special values provided by the Order `enum` and are respectively equal to -1 and 1 (and 0). When the `fun-cmp` subroutine returns `Less` (i.e. -1), then the `sort` routine knows that the first parameter (`\$a` in this case) should be ordered before the second one (`\$b`). Conversely, the first parameter should be ordered after the second one if the comparison subroutine returns `More`. When both parameters are even, or both are odd, we just use the `<=>` numeric comparison operator (which also returns `Less`, `More`, or `Same` to the `sort` function).

``````sub fun-cmp (\$a, \$b) {
if \$a %% 2 {
return \$a <=> \$b if \$b %% 2;
return Less;
} else {
return \$a <=> \$b unless \$b %% 2;
return More;
}
}

for <1 2 3 4 5 6>, <1 2>, (1,),
1..15, (1..15).reverse -> @test {
say sort &fun-cmp, @test;
}
``````

This program displays the following output:

``````\$ raku ./fun-sort2.raku
(2 4 6 1 3 5)
(2 1)
(1)
(2 4 6 8 10 12 14 1 3 5 7 9 11 13 15)
(2 4 6 8 10 12 14 1 3 5 7 9 11 13 15)
``````

### Fun Sort in Perl

This is a port to Perl of the first Raku program above, splitting the input into two lists (even and odd numbers), sorting them separately and reassembling the sorted sub-lists at the end.

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

sub fun_sort {
return (sort { \$a <=> \$b } grep { \$_ % 2 == 0 } @_),
(sort { \$a <=> \$b } grep { \$_ % 2 != 0 } @_);
}

for my \$test ([<1 2 3 4 5 6>], [(1, 2)], [(1)],
[1..15], [reverse (1..15)]) {
say join " ", fun_sort @\$test;
}
``````

This program displays the following output:

``````\$ perl ./fun-sort.pl
2 4 6 1 3 5
2 1
1
2 4 6 8 10 12 14 1 3 5 7 9 11 13 15
2 4 6 8 10 12 14 1 3 5 7 9 11 13 15
``````

Note that we could also first sort the input and then split the result into even and odd numbers and finally rearrange them:

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

sub fun_sort {
my @sorted = sort { \$a <=> \$b } @_;
return (grep { \$_ % 2 == 0 } @sorted),
(grep { \$_ % 2 != 0 } @sorted);
}

for my \$test ([<1 2 3 4 5 6>], [(1, 2)], [(1)],
[1..15], [reverse (1..15)]) {
say join " ", fun_sort @\$test;
}
``````

This program displays the same output as before:

``````2 4 6 1 3 5
2 1
1
2 4 6 8 10 12 14 1 3 5 7 9 11 13 15
2 4 6 8 10 12 14 1 3 5 7 9 11 13 15
``````

Finally, just as in Raku, we can also be pedantic in Perl and write a special comparison subroutine:

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

sub fun_cmp {
if (\$a % 2 == 0) {
return \$a <=> \$b unless \$b % 2;
return -1;
} else {
return \$a <=> \$b if \$b % 2;
return 1;
}
}

for my \$test ([<1 2 3 4 5 6>], [(1, 2)], [(1)],
[1..15], [reverse (1..15)]) {
say join " ", sort { fun_cmp } @\$test;
}
``````

This program displays again the same output:

``````2 4 6 1 3 5
2 1
1
2 4 6 8 10 12 14 1 3 5 7 9 11 13 15
2 4 6 8 10 12 14 1 3 5 7 9 11 13 15
``````

This second task will be handled later, if I find the time.

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

]]>
Posted Perl Weekly Challenge 212: Rearrange Groups to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11076 2023-04-13T19:02:28Z 2023-04-13T19:07:23Z These are some answers to the Week 212 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 April 16, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 212 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 April 16, 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.

You are given a word having alphabetic characters only, and a list of positive integers of the same length.

Write a script to print the new word generated after jumping forward each letter in the given word by the integer in the list. The given list would have exactly the number as the total alphabets in the given word.

Example 1

``````Input: \$word = 'Perl' and @jump = (2,22,19,9)
Output: Raku

'P' jumps 2 place forward and becomes 'R'.
'e' jumps 22 place forward and becomes 'a'. (jump is cyclic i.e. after 'z' you go back to 'a')
'r' jumps 19 place forward and becomes 'k'.
'l' jumps 9 place forward and becomes 'u'.
``````

Example 2

``````Input: \$word = 'Raku' and @jump = (24,4,7,17)
Output: 'Perl'
``````

This task was the subject of this post published on April 10, 2023.

You are given a list of integers and group size greater than zero.

Write a script to split the list into equal groups of the given size where integers are in sequential order. If it can’t be done then print -1.

Example 1:

``````Input: @list = (1,2,3,5,1,2,7,6,3) and \$size = 3
Output: (1,2,3), (1,2,3), (5,6,7)
``````

Example 2:

``````Input: @list = (1,2,3) and \$size = 2
Output: -1
``````

Example 3:

``````Input: @list = (1,2,4,3,5,3) and \$size = 3
Output: (1,2,3), (3,4,5)
``````

Example 4:

``````Input: @list = (1,5,2,6,4,7) and \$size = 3
Output: -1
``````

First, there was initially an error in Example 3 above of the task specification (`\$size` was 2 instead of 3, and that did not fit with the suggested output), but this has been fixed now.

Next, I first thought of sorting the input list of integers and, assuming for example a group size of 3, to try sequences of 3 successive integers in the list. But then I thought that it would be easier to store the input in a Raku Bag and to remove items used to construct groups as we go. As this turned out to be quite simple, I decided, as you will see, to use the same method in Perl, simulating bags with hashes.

### Rearrange Groups in Raku

First, note that `bags` are immutable in Raku. This means that you cannot change the inner items of the bag (or add or remove items), but this does not preclude you from re-assigning bags, as we do in the last statement of the `while` loop in the code below.

Using bags means that we can use operators with set theory semantics, such as the infix `(<=)` or infix `⊆` is a subset of or equal to,infix⊆), or the infix `(-)`, infix `∖` set difference,infix%E2%88%96), operators.

In the `rearrange` subroutine, the `while` loop runs as long as there are some items left in the bag. The loop looks for the smallest item in the bag, construct a sequence (`\$list`) of `\$size` successive items. If `\$list` is a subset of (or equal to) the bag, we store the `\$list` into the `@result` and remove the items of the `\$list` from the bag. If `\$list` is not part of the bag, then we failed and return -1. If we get normally out of the loop (because the bag is now empty), then we succeeded to build equal groups of items and can return the `@result`.

``````sub rearrange (@in, \$size) {
my @result;
return -1 unless @in.elems %% \$size;
my \$bag  = @in.Bag;
while (\$bag) {
my \$min = \$bag.min.key;
my @list = \$min..^(\$min + \$size);
return -1 unless @list ⊆ \$bag;
push @result, @list;
\$bag = \$bag (-) @list;  # set difference
}
return @result;
}

for ((1,2,3,5,1,2,7,6,3), 3), ((1,2,3), 2), ((1,2,3), 3),
((1,2,4,3,5,3), 3), ((1,5,2,6,4,7), 3),
((1,5,2,6,4,7), 2) -> @test {
say @test;
say rearrange(|@test), "\n";
}
``````

This script displays the following output:

``````\$ raku ./rearrange-groups.raku
((1 2 3 5 1 2 7 6 3) 3)
[[1 2 3] [1 2 3] [5 6 7]]

((1 2 3) 2)
-1

((1 2 3) 3)
[[1 2 3]]

((1 2 4 3 5 3) 3)
[[1 2 3] [3 4 5]]

((1 5 2 6 4 7) 3)
-1

((1 5 2 6 4 7) 2)
[[1 2] [4 5] [6 7]]
``````

### Rearrange Groups in Perl

I initially thought of using a different technique for solving the task in Perl, since there is no built-in `bag` data structure in Perl, but then I found that it was quite easy to simulate a `bag` with a hash containing an histogram of the input values. So this program essentially works the same as the Raku implementation (read the previous section if you need explanations). The `for` loop checks that all the values of `\$list` exist in the bag and remove these items from the bag.

``````use warnings;
use feature "say";

sub rearrange {
my @in = @{\$_};
my \$size = \$_;
my @result;
return "-1" if @in % \$size;
my %bag;
\$bag{\$_}++ for @in;
while (%bag) {
my \$min = (sort { \$a <=> \$b } keys %bag);
my @list = \$min..(\$min + \$size -1);
for my \$item (@list) {
return "-1" unless exists \$bag{\$item};
\$bag{\$item}--;
delete \$bag{\$item} if \$bag{\$item} == 0;
}
push @result, \@list;
}
return @result;
}

for my \$test( [[1,2,3,5,1,2,7,6,3], 3],
[[1,2,3], 2], [[1,2,3], 3],
[[1,2,4,3,5,3], 3],
[[1,5,2,6,4,7], 3],
[[1,5,2,6,4,7], 2] )
{
say "(@{\$test->})", " ", "(\$test->)";
my @result = rearrange(@\$test);
if (\$result == "-1") {
say -1;
} else {
say map { "[@\$_] " } @result;
}
say " ";
}
``````

This script displays the following output:

``````\$ perl ./rearrange-groups.pl
(1 2 3 5 1 2 7 6 3) (3)
[1 2 3] [1 2 3] [5 6 7]

(1 2 3) (2)
-1

(1 2 3) (3)
[1 2 3]

(1 2 4 3 5 3) (3)
[1 2 3] [3 4 5]

(1 5 2 6 4 7) (3)
-1

(1 5 2 6 4 7) (2)
[1 2] [4 5] [6 7]
``````

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

]]>
Posted Perl Weekly Challenge 212: Jumping Letters to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11073 2023-04-10T21:36:04Z 2023-04-13T19:12:52Z These are some answers to the Week 212 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 April 16, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 212 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 April 16, 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.

You are given a word having alphabetic characters only, and a list of positive integers of the same length.

Write a script to print the new word generated after jumping forward each letter in the given word by the integer in the list. The given list would have exactly the number as the total alphabets in the given word.

Example 1

``````Input: \$word = 'Perl' and @jump = (2,22,19,9)
Output: Raku

'P' jumps 2 place forward and becomes 'R'.
'e' jumps 22 place forward and becomes 'a'. (jump is cyclic, i.e. after 'z' you go back to 'a')
'r' jumps 19 place forward and becomes 'k'.
'l' jumps 9 place forward and becomes 'u'.
``````

Example 2

``````Input: \$word = 'Raku' and @jump = (24,4,7,17)
Output: 'Perl'
``````

### Jumping Letters in Raku

The ord routine translates a letter into its ASCII code (well, really, it’s a Unicode code point, but it is equivalent for our purpose here with values less than 128). The chr performs the inverse operation. So we can simply convert each letter of the input, add the relevant jump value and convert the result back to a letter. One little complication is that we need to subtract 26 from the code point if it gets beyond the upper case and lower case letter ranges after having added the jump value.

``````sub jump-letter (\$letter, \$val) {
my \$new_ascii = \$letter.ord + \$val;
return (\$new_ascii - 26).chr if \$new_ascii > 'z'.ord;
return (\$new_ascii - 26).chr if \$letter le 'Z'
and \$new_ascii > 'Z'.ord;
return \$new_ascii.chr;
}
my @test = "Perl", <2 22 19 9>;
for ("Perl", <2 22 19 9>), ("Raku", <24 4 7 17>) -> @test {
printf "%-10s => ", "@test";
for @test.comb Z @test.Array -> \$a {
print jump-letter \$a, \$a;
}
say " ";
}
``````

This script displays the following output:

``````\$ raku ./jumping-letters.raku
Perl       => Raku
Raku       => Perl
``````

### Jumping Letters in Perl

This is a port to Perl of the Raku program above. Please refer to the previous section if you need some explanations.

``````use strict;
use warnings;
use feature "say";

sub jump_letter  {
my (\$letter, \$val) = @_;
my \$new_ascii = ord(\$letter) + \$val;
return chr(\$new_ascii - 26) if \$new_ascii > ord 'z';
return chr(\$new_ascii - 26) if \$letter le 'Z'
and \$new_ascii > ord 'Z';
return chr \$new_ascii;
}

for my \$test (["Perl", [<2 22 19 9>]], ["Raku", [<24 4 7 17>]]) {
printf "%-10s => ", "\$test->";
my @letters = split //, \$test->;
for my \$i (0..\$#letters) {
print jump_letter \$letters[\$i], \$test->[\$i];
}
say " ";
}
``````

This script displays the following output:

``````\$ perl  ./jumping-letters.pl
Perl       => Raku
Raku       => Perl
``````

You are given a list of integers and group size greater than zero.

Write a script to split the list into equal groups of the given size where integers are in sequential order. If it can’t be done then print -1.

Example 1:

``````Input: @list = (1,2,3,5,1,2,7,6,3) and \$size = 3
Output: (1,2,3), (1,2,3), (5,6,7)
``````

Example 2:

``````Input: @list = (1,2,3) and \$size = 2
Output: -1
``````

Example 3:

``````Input: @list = (1,2,4,3,5,3) and \$size = 2
Output: (1,2,3), (3,4,5)
``````

Example 4:

``````Input: @list = (1,5,2,6,4,7) and \$size = 3
Output: -1
``````

First, I think that example 3 above is wrong. I believe that `size` should probably be 3 for the example to make sense.

Update: this error in the task specifications has now been fixed.

Second, even though I started working on this second task (and think I probably have a working solution in Raku), I have no time today to complete this task, and probably won’t have time for several days. I still wanted to make my solutions to task 1 available today. I’ll hopefully write a new blog post or update this one later on.

Update: I have now written a second blog post dated April 13, 2023, providing solutions to this task 2 of the challenge.

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

]]>
Commented on Perl Weekly Challenge 211: Toeplitz Matrix and Split Same Average in laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11071#1811395 2023-04-10T19:18:58Z laurent_r Thanks for your comment. And, yes, you're right, and I know this. But sometimes I prefer to use scalar to explicitly show that I'm interested with just the size of the array.

]]>
Posted Perl Weekly Challenge 211: Toeplitz Matrix and Split Same Average to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11071 2023-04-09T22:56:18Z 2023-04-09T23:12:01Z These are some answers to the Week 211 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Task 1: Toeplitz Matrix You are given a matrix m x n. Write a script to find out if the given matrix... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 211 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

You are given a matrix `m x n`.

Write a script to find out if the given matrix is Toeplitz Matrix.

A matrix is Toeplitz if every diagonal from top-left to bottom-right has the same elements.

Example 1

``````Input: @matrix = [ [4, 3, 2, 1],
[5, 4, 3, 2],
[6, 5, 4, 3],
]
Output: true
``````

Example 2

``````Input: @matrix = [ [1, 2, 3],
[3, 2, 1],
]
Output: false
``````

One way to do that is to find if any item of the matrix has the same value as the item immediately above and immediately left. We return `False` for any case where this is not the case, and `True` if we get to the end of the loop.

### Toeplitz Matrix in Raku

The implementation is fairly straight forward:

``````sub is-toeplitz (@in) {
for 1..@in.end -> \$i {
for 1..@in.end -> \$j {
# say "\$i \$j @in[\$i][\$j] @in[\$i-1][\$j-1]";
return False if @in[\$i][\$j] != @in[\$i-1][\$j-1];
}
}
return True;
}

for ( <4 3 2 1>, <5 4 3 2>, <6 5 4 3> ),
( <3 2 1 0>, <4 3 2 1>, <5 4 3 2> ),
( <3 2 1 0>, <4 3 2 1>, <5 5 3 2> ),
( <1 2 3>, <3 2 1> ) -> @test {
say @test;
say is-toeplitz(@test), "\n";
}
``````

This program displays the following output:

``````\$ raku ./toeplitz-matrix.raku
((4 3 2 1) (5 4 3 2) (6 5 4 3))
True

((3 2 1 0) (4 3 2 1) (5 4 3 2))
True

((3 2 1 0) (4 3 2 1) (5 5 3 2))
False

((1 2 3) (3 2 1))
False
``````

### Toeplitz Matrix in Perl

This is a port to Perl of the Raku program above:

``````use strict;
use warnings;
use feature "say";

sub is_toeplitz {
my @in = @_;
my \$j_max = scalar @{\$in} - 1;
for my \$i (1..\$#in) {
for my \$j (1..\$j_max) {
# say "\$i \$j \$in[\$i][\$j] \$in[\$i-1][\$j-1]";
return "false" if \$in[\$i][\$j] != \$in[\$i-1][\$j-1];
}
}
return "true";
}

for my \$test
( [ [<4 3 2 1>], [<5 4 3 2>], [<6 5 4 3>] ],
[ [<3 2 1 0>], [<4 3 2 1>], [<5 4 3 2>] ],
[ [<3 2 1 0>], [<4 3 2 1>], [<5 5 3 2>] ],
[ [<1 2 3>], [<3 2 1>] ] ) {
say "[ ", (join ", ", map "[@\$_]", @\$test), " ]";
say is_toeplitz(@\$test), "\n";
}
``````

This program displays the following output:

``````\$ perl ./toeplitz-matrix.pl
[ [4 3 2 1], [5 4 3 2], [6 5 4 3] ]
true

[ [3 2 1 0], [4 3 2 1], [5 4 3 2] ]
true

[ [3 2 1 0], [4 3 2 1], [5 5 3 2] ]
false

[ [1 2 3], [3 2 1] ]
false
``````

## Task 2: Split Same Average

You are given an array of integers.

Write a script to find out if the given can be split into two separate arrays whose average are the same.

Example 1:

``````Input: @nums = (1, 2, 3, 4, 5, 6, 7, 8)
Output: true

We can split the given array into (1, 4, 5, 8) and (2, 3, 6, 7).
The average of the two arrays are the same i.e. 4.5.
``````

Example 2:

``````Input: @list = (1, 3)
Output: false
``````

Let us notice that each sub-array should have the same average as the full array’s average. So, we simply need to find a sub-array that has the same average, the other sub-array is bound to have the same average.

An additional comment is that there can be several solutions. In the case of the `(1, 2, 3, 4, 5, 6, 7, 8)` array, we find solution not the same as the one in the task specification, i.e. `[(1 2 3 6 7 8) (4 5)]`, but it is also a correct solution to the task, as both arrays have an average of 4.5.

### Split Same Average in Raku

``````sub avg (@a) { return ([+] @a) / @a.elems; }

sub find-partition (@current, @left) {
return if @left.elems <= 1;
# say "Current: ", avg @current if @current.elems > 0;
if @current.elems > 0 and \$*target == avg @current  {
push @*result, @current;
return;
}
for 0..@left.end -> \$i {
find-partition( (@current, @left[\$i]).flat,
(@left[0..\$i-1, \$i+1..@left.end]).flat);
return if @*result.elems > 0;
}
}

sub start-partition (@in) {
my \$*target = avg @in;
my @*result;
my @current;
find-partition @current, @in;
return @*result;
}

for <1 2 3 4 5 6 7 8>, <1 2 3>, <1 3> -> @test {
my @output = start-partition @test;
print @test, " => ";
if @output.elems == 0 {
say "false";
} else {
print "true : ";
push @output, (@test (-) @output).keys;
say @output;
}
}
``````

This program displays the following output:

``````\$ raku  ./split-same-avg.raku
1 2 3 4 5 6 7 8 => true : [(1 2 3 6 7 8) (4 5)]
1 2 3 => true : [(2) (1 3)]
1 3 => false
``````

### Split Same Average in Perl

``````use strict;
use warnings;
use feature "say";

my (\$target, @result);

sub avg {
my \$nb_elems = scalar @_;
my \$sum = shift;
\$sum += \$_ for @_;
return \$sum / \$nb_elems;
}

sub find_partition {
my @current = @{\$_};
my @left = @{\$_};
return if scalar @left <= 1;
if (scalar @current > 0 and \$target == avg(@current)) {
push @result, @current;
return;
}
for my \$i (0..\$#left) {
find_partition( [@current, \$left[\$i]], [@left[0..\$i-1, \$i+1..\$#left]]);
return if @result > 0;
}
}

sub start_partition {
my @in = @_;
\$target = avg @in;
@result = ();
my @current;
find_partition [@current], [@in];
return @result;
}

for my \$test ([<1 2 3 4 5 6 7 8>], [<1 2 3>], [<1 3>]) {
my @output = start_partition @\$test;
print "@\$test => ";
if (scalar @output == 0) {
say "false";
} else {
print "true : [@output] ";
my %out = map { \$_ => 1 } @output;
say "[", join " ", grep { not exists \$out{\$_} } @\$test, "]";
}
}
``````

This program displays the following output:

``````\$ perl ./split-same-avg.pl
1 2 3 4 5 6 7 8 => true : [1 2 3 6 7 8] [4 5 ]
1 2 3 => true :  [1 3 ]
1 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 April 16, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 210: Kill and Win and Number Collision to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11065 2023-04-03T19:10:18Z 2023-04-03T19:12:45Z These are some answers to the Week 210 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Task 1: Kill and Win You are given a list of integers. Write a script to get the maximum points. You are... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 210 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

## Task 1: Kill and Win

You are given a list of integers.

Write a script to get the maximum points. You are allowed to take out (kill) any integer and remove from the list. However if you do that then all integers exactly one-less or one-more would also be removed. Find out the total of integers removed.

Example 1

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

First we delete 2 and that would also delete 1 and 3. So the maximum points we get is 6.
``````

Example 2

``````Input: @int = (1, 1, 2, 2, 2, 3)
Output: 11

First we delete 2 and that would also delete both the 1's and the 3. Now we have (2, 2).
Then we delete another 2 and followed by the third deletion of 2. So the maximum points we get is 11.
``````

In my understanding of the process, we will always be able to pick a few integers and thereby remove all integers from the list. So, the sum of removed integers is the sum of the input integer.

### Kill and Win in Raku

``````sub sum-deleted-digits (@in) {
# we can always delete all digits
return [+] @in;
}

for <2 3 1>, <1 1 2 2 2 3> -> @test {
say "@test[]".fmt("%-15s => "), sum-deleted-digits @test;
}
``````

This program displays the following output:

``````\$ raku ./kill-and-win.raku
2 3 1           => 6
1 1 2 2 2 3     => 11
``````

### Kill and Win in Perl

``````sub sum_deleted_digits {
# we can always delete all digits
my \$sum = 0;
\$sum += \$_ for @_;
return \$sum;
}

for my \$test ([<2 3 1>], [<1 1 2 2 2 3>])  {
printf "%-15s => %d \n", "@\$test", sum_deleted_digits @\$test;
}
``````

This program displays the following output:

``````\$ perl ./kill-and-win.pl
2 3 1           => 6
1 1 2 2 2 3     => 11
``````

You are given an array of integers which can move in right direction if it is positive and left direction when negative. If two numbers collide then the smaller one will explode. And if both are same then they both explode. We take the absolute value in consideration when comparing.

All numbers move at the same speed, therefore any 2 numbers moving in the same direction will never collide.

Write a script to find out who survives the collision.

Example 1:

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

The numbers 3 and -1 collide and -1 explodes in the end. So we are left with (2, 3).
``````

Example 2:

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

The numbers 2 and -4 collide and 2 explodes in the end. That gives us (3, -4).
Now the numbers 3 and -4 collide and 3 explodes. Finally we are left with -4.
``````

Example 3:

``````Input: @list = (1, -1)
Output: ()

The numbers 1 and -1 both collide and explode. Nothing left in the end.
``````

### Number Collision in Raku

``````sub number-collision (@in-array) {
my @in = @in-array;
loop {
return () if @in.elems == 0;
my @temp;
for 0..^@in.end -> \$i {
if @in[\$i] > 0 {
if @in[\$i+1] > 0 {
push @temp, @in[\$i];
} else {
next if abs(@in[\$i]) == abs(@in[\$i+1]);
push @temp,
abs(@in[\$i]) > abs(@in[\$i+1]) ??
@in[\$i] !! @in[\$i+1];
}
} elsif @in[\$i] < 0 {
push @temp, @in[\$i] and next
unless @in[\$i-1]:exists;
if @in[\$i-1] < 0 {
push @temp, @in[\$i];
} else {
shift @temp and next
if abs(@in[\$i]) == abs(@in[\$i+1]);
@temp[*-1] =
abs(@in[\$i]) > abs(@in[\$i-1]) ??
@in[\$i] !! @in[\$i-1];
}
} else {     # @in[\$i] == 0
push @temp, @in[\$i];
}
}
return @temp if @temp.all > 0 or @temp.all < 0;
@in = @temp;
}
}

for <2 3 -1>, <3 2 -4>, <1 -1> -> @test {
say "@test[]".fmt("%-10s => "), number-collision @test;
}
``````

This program displays the following output:

``````\$ raku ./number-collision.raku
2 3 -1     => [2 3]
3 2 -4     => [-4]
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 April 9, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 209: Special Bit Characters and Merge Account to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11053 2023-03-20T22:36:20Z 2023-03-20T22:40:07Z These are some answers to the Week 209 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 March 26, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 209 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 March 26, 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: Special Bit Characters

You are given an array of binary bits that ends with 0.

Valid sequences in the bit string are:

`````` -decodes-to-> "a"
[1, 0] -> "b"
[1, 1] -> "c"
``````

Write a script to print 1 if the last character is an “a” otherwise print 0.

Example 1:

``````Input: @bits = (1, 0, 0)
Output: 1

The given array bits can be decoded as 2-bits character (10) followed by 1-bit character (0).
``````

Example 2:

``````Input: @bits = (1, 1, 1, 0)
Output: 0

Possible decode can be 2-bits character (11) followed by 2-bits character (10) i.e. the last character is not 1-bit character.
``````

This is an example of variable-length code. In order to decode such a bit string, we need to start from the beginning of the string. If the string starts with 0, then we have an "a" and can continue decoding with the next bit. If the string starts with 1, then we need to check the next digit, to figure out whether the first letter is a "b or a "c", and we can continue decoding with the third bit. And so on. So, for example, if we have the following string:

``````0110100100111011100
``````

We will effectively split it as follows:

``````0 11 0 10 0 10 0 11 10 11 10 0,
``````

yielding the following decoded string: "acababacbcba."

It is easy to see that such an encoding is totally unambiguous: at any point in the process, there can be only one decoded letter.

But if we pick one bit somewhere in the middle of the bit string, we can't know how to proceed. If it is a 0, this can be an "a", or the second bit of a "b". Similarly, if it is a 1, then it can be the first bit of a "b", or the first or the second bit of a "c". So, we can be sure to always unambiguously decode the string only if we start from the beginning. There are cases, however, where it is possible to decode part of the string starting from somewhere in the middle. For example, if we find two consecutive 0, we know that the second one can only be an "a" and proceed from there. We don't need to proceed from the beginning to find that the last letter in the above bit string is an "a". But, since we cannot be sure to meet such a situation, the best is to start from the beginning as explained above. For much longer strings, looking for the last occurrence of a "00" pattern, and proceed from the second 0 (an "a"), may be an interesting performance improvement, since we're really interested in finding out whether the final 0 is an "a" or the second bit of a "b". With the small examples at hand, this optimization would be useless.

### Special Bit Characters in Raku

The program goes through the bit string and consume either one or two bits, depending on whether the current digit is a 0 or a 1. If the last bit (necessarily a 0) is the start of a group, then it is an "a". Otherwise, it is the second bit of a "10" group (i.e. of a "b"). Note that a `loop` statement alone, without three statements in parentheses, is just an infinite loop, from which we exit with either of the return statements.

``````sub ends-with-a (@in) {
my \$i = 0;
my \$end = @in.end;
loop {
return 1 if \$i == \$end;
\$i += @in[\$i] == 0 ?? 1 !! 2;
return 0 if \$i > \$end;
}
}

for <1 0 0>, <1 1 1 0>, <0 0 0 1 0>, <1 1 0> -> @test {
say (~ @test).fmt("%-12s => "), ends-with-a @test;
}
``````

This program displays the following output:

``````\$ raku ./main.raku
1 0 0        => 1
1 1 1 0      => 0
0 0 0 1 0    => 0
1 1 0        => 1
``````

### Special Bit Characters in Perl

This is a port to Perl of the above Raku program. Please refer to the previous sections if you need additional explanations.

``````use strict;
use warnings;
use feature "say";

sub ends_with_a {
my \$i = 0;
my \$end = \$#_;
while (1) {
return 1 if \$i == \$end;
\$i += \$_[\$i] == 0 ? 1 : 2;
return 0 if \$i > \$end;
}
}

for my \$test ([<1 0 0>], [<1 1 1 0>],
[<0 0 0 1 0>], [<1 1 0>]) {
printf "%-12s => %d\n", "@\$test", ends_with_a @\$test;
}
``````

This program displays the following output:

``````\$ perl ./special-bit-characters.pl
1 0 0        => 1
1 1 1 0      => 0
0 0 0 1 0    => 0
1 1 0        => 1
``````

You are given an array of accounts, i.e. name with list of email addresses.

Write a script to merge the accounts where possible.

Example 1:

``````Input:
@accounts = [ ["A", "a1@a.com", "a2@a.com"],
["B", "b1@b.com"],
["A", "a3@a.com", "a1@a.com"] ]
]

Output: [ ["A", "a1@a.com", "a2@a.com", "a3@a.com"],
["B", "b1@b.com"] ]
``````

Example 2:

``````Input:
@accounts = [ ["A", "a1@a.com", "a2@a.com"],
["B", "b1@b.com"],
["A", "a3@a.com"],
["B"m "b2@b.com", "b1@b.com"] ]

Output: [ ["A", "a1@a.com", "a2@a.com"],
["A", "a3@a.com"],
["B", "b1@b.com", "b2@b.com"] ]
``````

### Merge Account in Raku

We use a hash of hashes to merge items belonging to the same name and remove possible duplicates.

``````sub merge-account (@in) {
my %merged;
for @in -> @part {
my (\$key, @values) = @part;
%merged{\$key}{\$_} = True for @values;
}
return %merged;
}

my @tests = ( <A a1@a.com a2@a.com>,
<B b1@b.com>,
<A a3@a.com a1@a.com> ),
( <A a1@a.com a2@a.com>,
<B b1@b.com>,
<A a3@a.com>,
<B b2@b.com b1@b.com> );
for @tests -> @test {
say @test, " => ";
my %merged = merge-account @test;
for %merged.keys.sort -> \$k {
say "\t[", (join " ", \$k, |%merged{\$k}.keys.sort), "]";
};
say "";
}
``````

This program displays the following output:

``````\$ raku ./merge-account.raku
((A a1@a.com a2@a.com) (B b1@b.com) (A a3@a.com a1@a.com)) =>
[A a1@a.com a2@a.com a3@a.com]
[B b1@b.com]

((A a1@a.com a2@a.com) (B b1@b.com) (A a3@a.com) (B b2@b.com b1@b.com)) =>
[A a1@a.com a2@a.com a3@a.com]
[B b1@b.com b2@b.com]
``````

### Merge Account in Perl

This is a port to Perl of the previous Raku program. We use a hash of hashes to merge items belonging to the same name and remove possible duplicates.

``````use strict;
use warnings;
use feature "say";

sub merge_account {
my %merged;
for my \$part (@_) {
# say   Dumper \$part;
my (\$key, @values) = @\$part;
\$merged{\$key}{\$_} = 1 for @values;
}
# say %merged;
return \%merged;
}

my @tests = ( [ [<A a1\@a.com a2\@a.com>],
[<B b1\@b.com>],
[<A a3\@a.com a1\@a.com>] ],

[ [<A a1\@a.com a2\@a.com>],
[<B b1\@b.com>],
[<A a3\@a.com>],
[<B b2\@b.com b1\@b.com>] ] );

for my \$test (@tests) {
# say Dumper \$test, " => ";
for my \$part (@\$test) {
print join " ", @\$part;
print " - ";
}
say " =>";
my %merged = %{merge_account @\$test};
for my \$k (sort keys %merged) {
say "\t[", (join " ", \$k, sort keys %{\$merged{\$k}}), "]";
};
say "";
}
``````

This program displays the following output:

``````\$ perl  ./merge-account.pl
A a1@a.com a2@a.com - B b1@b.com - A a3@a.com a1@a.com -  =>
[A a1@a.com a2@a.com a3@a.com]
[B b1@b.com]

A a1@a.com a2@a.com - B b1@b.com - A a3@a.com - B b2@b.com b1@b.com -  =>
[A a1@a.com a2@a.com a3@a.com]
[B b1@b.com b2@b.com]
``````

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

]]>
Posted Perl Weekly Challenge 208: Minimum Index Sum and Duplicate and Missing to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11050 2023-03-15T17:16:29Z 2023-03-15T17:22:01Z These are some answers to the Week 208 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 March 19, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 208 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 March 19, 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: Minimum Index Sum

You are given two arrays of strings.

Write a script to find out all common strings in the given two arrays with minimum index sum. If no common strings found returns an empty list.

Example 1:

``````Input: @list1 = ("Perl", "Raku", "Love")
@list2 = ("Raku", "Perl", "Hate")

Output: ("Perl", "Raku")

There are two common strings "Perl" and "Raku".
Index sum of "Perl": 0 + 1 = 1
Index sum of "Raku": 1 + 0 = 1
``````

Example 2:

``````Input: @list1 = ("A", "B", "C")
@list2 = ("D", "E", "F")

Output: ()

No common string found, so no result.
``````

Example 3:

``````Input: @list1 = ("A", "B", "C")
@list2 = ("C", "A", "B")

Output: ("A")

There are three common strings "A", "B" and "C".
Index sum of "A": 0 + 1 = 1
Index sum of "B": 1 + 2 = 3
Index sum of "C": 2 + 0 = 2
``````

### Minimum Index Sum in Raku

We need to find the intersection between two arrays of strings. Once we’ve found the intersection, we need to keep the intersection items that have the smallest sum of indexes in the original array. So, it looked like it would be nice to use Bags for the input (with the index as weight integer for each item), and the `∩` or `(&)` infix intersection operator,infix%E2%88%AA) to generate the result. It turns out that this might not be the best choice, because the integer weight associated with a bag item is signifying how many copies of that element are considered “in the bag”. So, if the weight is 0, it means the item is not in the bag and is lost during bag construction. Since array indexes start at 0, we’d be losing the first item of each array. The problem is solved by assigning the index incremented by 1 to the weight. This easily solves the problem, but makes the solution slightly less elegant than I originally hoped it to be.

``````sub min-sum-idx (@s1, @s2) {
my \$b1 = (map {@s1[\$_] => \$_ + 1}, 0..@s1.end).Bag;
my \$b2 = (map {@s2[\$_] => \$_ + 1}, 0..@s2.end).Bag;
my \$result = (map { \$_ =>  \$b1{\$_} + \$b2{\$_}},
(\$b1 ∩ \$b2).keys).Bag;
my \$min = \$result.values.min;
return grep {\$result{\$_} == \$min}, \$result.keys;
}

for (<Perl Raku Love>, <Raku Perl Hate>),
(<A B C>, <D E F>), (<A B C>, <C A B>)
-> @test {
say "@test - @test".fmt("%-35s => "),
min-sum-idx |@test;
}
``````

This program displays the following output:

``````\$ raku ./min-sum_idx.raku
Perl Raku Love - Raku Perl Hate    => (Perl Raku)
A B C - D E F                      => ()
A B C - C A B                      => (A)
``````

### Minimum Index Sum in Perl

For porting the above Raku program to Perl, we replace `Bags` with hashes. We use a `grep` to construct the `@result` intersection of the two input arrays, and a loop to compute the minimum array index sum.

``````use strict;
use warnings;
use feature "say";

sub min_sum_idx {
my @s1 = @{\$_};
my @s2 = @{\$_};

my %h1 = map {\$s1[\$_] => \$_ } 0..\$#s1;
my %h2 = map {\$s2[\$_] => \$_ } 0..\$#s2;
my @result = grep { exists \$h1{\$_} } @s2;
return "()" unless @result;
my %res = map { \$_ => \$h1{\$_} + \$h2{\$_} } @result;
my \$min = \$res{\$result};
for my \$k (keys %res) {
\$min = \$res{\$k} if \$res{\$k} < \$min;
}
return grep {\$res{\$_} == \$min} @result;
}

for my \$test ( [[<Perl Raku Love>], [<Raku Perl Hate>]],
[[<A B C>], [<D E F>]], [[<A B C>], [<C A B>]] ) {

printf "%-14s - %-16s => ",
"@{\$test->}", "@{\$test->}";
say join " ", min_sum_idx @\$test;
}
``````

This program displays the following output:

``````\$ perl  ./min-sum-idx.pl
Perl Raku Love - Raku Perl Hate   => Raku Perl
A B C          - D E F            => ()
A B C          - C A B            => A
``````

## Task 2: Duplicate and Missing

You are given an array of integers in sequence with one missing and one duplicate.

Write a script to find the duplicate and missing integer in the given array. Return -1 if none found.

For the sake of this task, let us assume the array contains no more than one duplicate and missing.

Example 1:

``````Input: @nums = (1,2,2,4)
Output: (2,3)

Duplicate is 2 and Missing is 3.
``````

Example 2:

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

No duplicate and missing found.
``````

Example 3:

``````Input: @nums = (1,2,3,3)
Output: (3,4)

Duplicate is 3 and Missing is 4.
``````

First, we are told that the integers are in sequence. This presumably means that they are sorted in ascending order. If not, we could just add a call to the built-in sort routine at the beginning of our code.

Second, the task specification tells us what to do when there is no missing item and no duplicate, but not what to do when only one of these two values is missing. I’ve decided to report something like `(3, -)` when 3 is a duplicate and there is no missing item, and `(-, 3)` when 3 is a missing value and there is no duplicate.

### Duplicate and Missing in Raku

We simply loop over the input array values and

1. Report a duplicate if one value is equal to the previous one, and
2. Report a missing item if the current item is not one more than the previous one.

sub dupe-and-missing (@nums) { my (\$dupe, \$missing); for 1..@nums.end -> \$i { if @nums[\$i] == @nums[\$i-1] { \$dupe = @nums[\$i]; } elsif @nums[\$i] - @nums[\$i-1] != 1 { \$missing = @nums[\$i-1] + 1; } } return “(\$dupe, \$missing)” if \$dupe and \$missing; return “-1” unless \$dupe or \$missing; return “(\$dupe, -)” if \$dupe; # no missing item return “(-, \$missing)”; # no dupe }

for <1 2 2 4>, <1 2 3 4>, <1 2 3 3>, <1 2 4 5>, <1 1 3 4>, <1 3 4 5>, <1 2 2 3 5> -> @test { say “@test[]”.fmt(“%-12s => “), dupe-and-missing @test; }

This program displays the following output:

``````\$ raku ./dupe_missing.raku
1 2 2 4      => (2, 3)
1 2 3 4      => -1
1 2 3 3      => (3, -)
1 2 4 5      => (-, 3)
1 1 3 4      => (1, 2)
1 3 4 5      => (-, 2)
1 2 2 3 5    => (2, 4)
``````

### Duplicate and Missing in Perl

This is a straight port to Perl of the Raku program above:

``````use strict;
use warnings;
use feature "say";

sub dupe_and_missing {
my @nums = @_;
my (\$dupe, \$missing);
for my \$i (1..\$#nums) {
if (\$nums[\$i] == \$nums[\$i-1]) {
\$dupe = \$nums[\$i];
} elsif (\$nums[\$i] - \$nums[\$i-1] != 1) {
\$missing = \$nums[\$i-1] + 1;
}
}
return "(\$dupe, \$missing)" if \$dupe and \$missing;
return "-1" unless \$dupe or \$missing;
return "(\$dupe, -)" if \$dupe;
return "(-, \$missing)";
}

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

This program displays the following output:

``````\$ perl  ./dupe-missing.pl
1 2 2 4      => (2, 3)
1 2 3 4      => -1
1 2 3 3      => (3, -)
1 2 4 5      => (-, 3)
1 1 3 4      => (1, 2)
1 3 4 5      => (-, 2)
1 2 2 3 5    => (2, 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 March 26, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 207: Keyboard Word and H-Index to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11041 2023-03-06T20:35:00Z 2023-03-06T20:37:26Z These are some answers to the Week 207 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 March 12, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 207 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 March 12, 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.

You are given an array of words.

Write a script to print all the words in the given array that can be types using alphabet on only one row of the keyboard.

Let us assume the keys are arranged as below:

``````Row 1: qwertyuiop
Row 2: asdfghjkl
Row 3: zxcvbnm
``````

Example 1

``````Input: @words = ("Hello","Alaska","Dad","Peace")
``````

Example 2

``````Input: @array = ("OMG","Bye")
Output: ()
``````

Note that in the examples above, the input words are in title case (initial upper case letter), so we will need to perform a case conversion somewhere If we want to obtain any match.

### Keyboard Word in Raku

First, we create an array of three hashes to store the letters of each keyboard row.

Then, the `find-kb-word` subroutine has two nested loops to loop over the input words and the keyboard rows. It then uses an `all` junction for each word/row combination to check whether letters of a word all belong to the same key row.

``````my @rows;
push @rows, %(map { \$_ => True }, \$_.comb)
for "qwertyuiop", "asdfghjkl", "zxcvbnm";

sub find-kb-word (@in) {
my @out;
for @in -> \$word {
for @rows -> %row {
push @out, \$word and next
if %row{all \$word.lc.comb}:exists;
}
}
return @out;
}
<Power Fad Finish Tower Quit True Omit> -> @test {
say find-kb-word @test;
}
``````

This program displays the following output:

``````\$ raku ./keyboard-words.raku
[]
``````

### Keyboard Word in Perl

This is a port to Perl of the above Raku program. The only significant difference is that, since Perl doesn’t have junctions, the `find_kb_word` subroutine uses a `grep` to find whether all letters of a word belong to the same key row.

``````use strict;
use warnings;
use feature "say";

my @rows;
push @rows, {map {\$_ => 1} split //, \$_}
for "qwertyuiop", "asdfghjkl", "zxcvbnm";

[<Power Fad Finish Tower Quit True Omit>]) {
say join " ", find_kb_word(@\$test);
}

sub find_kb_word {
my @out;
for my \$word (@_) {
for my \$row (@rows) {
my \$eligible = 1;
push @out, \$word and last
unless grep {not exists \$row->{\$_}}
split //, lc \$word;
}
}
return @out ? @out : "()";
}
``````

This program displays the following output:

``````\$ perl ./keyboard-words.pl
()
``````

You are given an array of integers containing citations a researcher has received for each paper.

The H-Index is the largest number h such that h articles have at least h citations each. For example, if an author has five publications, with 9, 7, 6, 2, and 1 citations (ordered from greatest to least), then the author’s h-index is 3, because the author has three publications with 3 or more citations. However, the author does not have four publications with 4 or more citations.

Example 1

``````Input: @citations = (10,8,5,4,3)
Output: 4

Because the 4th publication has 4 citations and the 5th has only 3.
``````

Example 2

``````Input: @citations = (25,8,5,3,3)
Output: 3

The H-Index is 3 because the fourth paper has only 3 citations.
``````

### H-Index in Raku

The `h-index` subroutine first sorts the input data in descending order. It then looks for the first item whole value is less that its index + 1 and returns it.

``````sub h-index (@citations) {
my @ordered = @citations.sort.reverse;
for 0..@ordered.end -> \$i {
return \$i if \$i+1 > @ordered[\$i];
}
# If we get here, then all papers qualify
return @ordered.elems;
}
for <10 8 5 4 3>, <25 8 5 3 3>, <12 10 9 5 11> -> @test {
say "@test[]".fmt("%-15s => "), h-index @test;
}
``````

This program displays the following output:

``````\$ raku ./h-index.raku
10 8 5 4 3      => 4
25 8 5 3 3      => 3
12 10 9 5 11    => 5
``````

### H-Index in Perl

This is a port to Perl of the above Raku program.

``````use strict;
use warnings;
use feature "say";

sub h_index {
my @ordered = sort { \$b <=> \$a } @_;
for my \$i (0..\$#ordered) {
return \$i if \$i+1 > \$ordered[\$i];
}
# If we get here, then all papers qualify
return scalar @ordered;
}
for my \$test ([<10 8 5 4 3>], [<25 8 5 3 3>], [<12 10 9 5 11>]) {
printf "%-15s => %d\n", "@\$test", h_index @\$test;
}
``````

This program displays the following output:

``````\$ perl h-index.pl
10 8 5 4 3      => 4
25 8 5 3 3      => 3
12 10 9 5 11    => 5
``````

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

]]>
Posted Perl Weekly Challenge 206: Shortest Time and Array Pairings to laurent_r tag:blogs.perl.org,2023:/users/laurent_r//3226.11038 2023-02-28T21:27:55Z 2023-02-28T22:01:46Z These are some answers to the Week 206 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 March 5, 2023 at 23:59). This blog... laurent_r https://blogs.perl.org/mt/mt-cp.cgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 206 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 March 5, 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.

You are given a list of time points, at least 2, in the 24-hour clock format HH:MM.

Write a script to find out the shortest time in minutes between any two time points.

Example 1

``````Input: @time = ("00:00", "23:55", "20:00")
Output: 5

Since the difference between "00:00" and "23:55" is the shortest (5 minutes).
``````

Example 2

``````Input: @array = ("01:01", "00:50", "00:57")
Output: 4
``````

Example 3

``````Input: @array = ("10:10", "09:30", "09:00", "09:55")
Output: 15
``````

### Shortest Time in Raku

If the hour parts of the time stamps are equal, then the `shortest` subroutine simply compares the minute parts (and returns the absolute value of the difference). Otherwise, it transforms the time stamps into minutes and compares the minutes values. If the difference found is larger than half a day, then it is subtracted from a full day to obtain a difference less than 12 hours.

In the main code, the program tests the time stamp against each other to find the smallest time duration.

``````sub shortest (\$t1, \$t2) {
my \$mod = 60 * 12;    # half a day
my (\$h1, \$m1) = split /\:/, \$t1;
my (\$h2, \$m2) = split /\:/, \$t2;
return abs (\$m1 - \$m2) if \$h1 == \$h2;
my \$delta = abs((\$h1 * 60 + \$m1) - (\$h2 * 60 + \$m2));
\$delta = \$mod * 2 - \$delta if \$delta > \$mod;
}

for ("00:00", "23:55", "20:00"),
("01:01", "00:50", "00:57"),
("10:10", "09:30", "09:00", "09:55") -> @test {
my \$min = Inf;
for @test.combinations(2) -> @comb {
my \$diff = shortest @comb, @comb;
\$min = \$diff if \$diff < \$min;
}
say "@test[]".fmt("%-25s => "), \$min;
}
``````

This program displays the following output:

``````\$ raku ./shortest-time.raku
00:00 23:55 20:00         => 5
01:01 00:50 00:57         => 4
10:10 09:30 09:00 09:55   => 15
``````

### Shortest Time in Perl

This is a port to Perl of the Raku program just above. Please refer to the explanations in the above section if needed.

``````use strict;
use warnings;
use feature "say";

sub shortest {
my \$mod = 60 * 12;
my (\$h1, \$m1) = split /:/, \$_;
my (\$h2, \$m2) = split /:/, \$_;
return abs (\$m1 - \$m2) if \$h1 == \$h2;
my \$delta = abs((\$h1 * 60 + \$m1) - (\$h2 * 60 + \$m2));
\$delta = \$mod * 2 - \$delta if \$delta > \$mod;
return \$delta
}

for my \$test (["00:00", "23:55", "20:00"],
["01:01", "00:50", "00:57"],
["10:10", "09:30", "09:00", "09:55"]) {
my \$min = 10000;   # larger than any HH:MM time diff
my @t = @\$test;
for my \$i (0..\$#t) {
for my \$j (\$i+1..\$#t) {
my \$diff = shortest \$t[\$i], \$t[\$j];
\$min = \$diff if \$diff < \$min;
}
}
printf "%-25s => %d\n", "@t", \$min;
}
``````

This program displays the following output:

``````\$ perl  ./shortest-time.pl
00:00 23:55 20:00         => 5
01:01 00:50 00:57         => 4
10:10 09:30 09:00 09:55   => 15
``````

You are given an array of integers having even number of elements.

Write a script to find the maximum sum of the minimum of each pairs.

Example 1

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

Possible Pairings are as below:
a) (1,2) and (3,4). So min(1,2) + min(3,4) => 1 + 3 => 4
b) (1,3) and (2,4). So min(1,3) + min(2,4) => 1 + 2 => 3
c) (1,4) and (2,3). So min(1,4) + min(2,3) => 2 + 1 => 3

So the maxium sum is 4.
``````

Example 2

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

Possible Pairings are as below:
a) (0,2) and (1,3). So min(0,2) + min(1,3) => 0 + 1 => 1
b) (0,1) and (2,3). So min(0,1) + min(2,3) => 0 + 2 => 2
c) (0,3) and (2,1). So min(0,3) + min(2,1) => 0 + 1 => 1

So the maximum sum is 2.
``````

### Array Pairings in Raku

#### Brute-Force Raku Solution

Our first implementation will just blindly follow the specifications: find all pairs, combine them 2 by 2 and find the largest sum of smaller items. To find all pairs, the `pairings` subroutine uses a combination of the `permutation`and `rotor` built-in methods. It then uses the `combinations` method to build the pairs of pairs and find the largest sum of mins.

``````sub pairings (@in) {
my \$max = - Inf;
my @perms = @in.permutations;
for @perms -> \$perm {
for \$perm.rotor(2).combinations(2) -> \$comb {
my \$sum = \$comb.min + \$comb.min;
\$max = \$sum if \$sum > \$max
}
}
return \$max;
}
for <1 2 3 4>, <6 5 4 3 2 1>, <0 2 1 3> -> @test {
say "@test[]".fmt("%-15s => "), pairings @test;
}
``````

This program displays the following output:

``````\$ raku ./pairings.raku
1 2 3 4         => 4
6 5 4 3 2 1     => 8
0 2 1 3         => 2
``````

#### Improved Raku Solution

This is, however, quite inefficient, both from a coding perspective and from a performance standpoint. As soon as the input list grows a bit, the number of permutations will explode and the number of combinations of pairs generated from the permutations even more so. Since we are looking for maximum sums, we can look at the largest numbers. More specifically, since the numbers we will add have to be the minimum of a pair, we basically need the second and fourth largest integers of the input array. So, we simply sort the input and add the second and fourth integers of the sorted list.

This leads to a much simpler and much more efficient solution:

``````sub pairings (@in) {
my @sorted = @in.sort.reverse;
return @sorted + @sorted;
}
for <1 2 3 4>, <6 5 4 3 2 1>, <0 2 1 3> -> @test {
say "@test[]".fmt("%-15s => "), pairings @test;
}
``````

This program displays the same output as the previous program.

### Array Pairings in Perl

Porting the first (“brute-force”) Raku solution to Perl would have been a bit painful, because Perl doesn’t have built-in `permutations`, `rotor`, and `combinations` functions, so that they would have to be hand-rolled (since I usually eschew using CPAN modules in programming challenges). But, fortunately, it is quite easy to port the second (“improved”) solution to Perl:

``````use strict;
use warnings;
use feature "say";

sub pairings {
my @sorted = sort { \$b <=> \$a } @_;
return \$sorted + \$sorted;
}

for my \$test ([<1 2 3 4>], [<6 5 4 3 2 1>],
[<0 2 1 3>], [<34 12 1 11>]) {
printf "%-15s => %d\n", "@\$test", pairings @\$test;
}
``````

This program displays the following output:

``````\$ perl  ./pairings.pl
1 2 3 4         => 4
6 5 4 3 2 1     => 8
0 2 1 3         => 2
34 12 1 11      => 13
``````

## 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 ans

wer the challenge before 23:59 BST (British summer time) on March 12, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>