Actions from laurent_r Movable Type Pro 4.38 2020-05-21T18:51:11Z http://blogs.perl.org/mt/mt-cp.fcgi?__mode=feed&_type=actions&blog_id=0&id=4694 Posted Perl Weekly Challenge 61: Max Subarray Product and IP Address Partition to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9770 2020-05-21T17:51:11Z 2020-05-21T17:53:16Z These are some answers to the Week 61 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a couple of days (May 24, 2020). This blog post offers some solutions... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 61 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (May 24, 2020). 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: Max Sub-Array Product

Given a list of 4 or more numbers, write a script to find the contiguous sublist that has the maximum product.

Example:

Input: [ 2, 5, -1, 3 ]

Output: [ 2, 5 ] which gives maximum product 10.

### Max Sub-Array Product in Raku

Let’s start with a simple loop over a list of indices, as we would do in most procedural programming languages. We loop over the existing indices of the input array, compute the product of each item with the next one, and store in the `@max` array the max product so far, as well as the two items that led to it:

``````use v6;

my @input = @*ARGS;
my @max = @input * @input, @input, @input;
for 1..^@input.end -> \$i {
@max = @input[\$i] * @input[\$i+1], @input[\$i], @input[\$i+1]
if @max < @input[\$i] * @input[\$i+1];
}
say "Max product is @max for values @max and @max";
``````

This is an example run of this program:

``````\$ perl6 max-product.p6 3 5 7 9 3 6 12 4
Max product is 72 for values 6 and 12
``````

But, Raku being what it is, we can use its expressive power to design a much better (or, at least, much shorter) solution:

``````use v6;

say @*ARGS.rotor(2 => -1).max({\$_ * \$_});
``````

We use the `rotor` built-in method to generate a list of overlapping 2-item `seqs`. For example, with an input of `3 5 7 9`, `rotor(2 => -1)` generates the following list: `((3 5) (5 7) (7 9))`. Then we use the `max` built-in method to find the 2-item `seq` having the largest product.

These are two sample runs of this one-liner program:

``````\$ perl6 max-product2.p6 3 5 7 9 3 6 12 4
(6 12)

\$ perl6 max-product2.p6 3 5 7 9 3 6 12 4 85 3
(4 85)
``````

### Max Sub-Array Product in Perl

Perl doesn’t have the built-ins used in our second Raku solution. So we will simply port to Perl the first Raku solution:

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

my @input = @ARGV;
die "please supply at least two integers" if @input < 2;
my @max = (\$input * \$input, \$input, \$input);
for my \$i (1..\$#input) {
@max = (\$input[\$i] * \$input[\$i+1], \$input[\$i], \$input[\$i+1])
if \$max < \$input[\$i] * \$input[\$i+1];
}
say "Max product is \$max for values \$max and \$max";
``````

Example runs:

``````\$ perl max-product.pl 3 5 7 9 3 6 12 4
Max product is 72 for values 6 and 12

\$ perl max-product.pl 3 5 7 9 3 6 12 4 85 3
Max product is 340 for values 4 and 85
``````

You are given a string containing only digits (0..9). The string should have between 4 and 12 digits.

Write a script to print every possible valid IPv4 address that can be made by partitioning the input string.

For the purpose of this challenge, a valid IPv4 address consists of four “octets” i.e. A, B, C and D, separated by dots (.).

Each octet must be between 0 and 255, and must not have any leading zeroes. (e.g., 0 is OK, but 01 is not.)

Example:

Input: 25525511135,

Output:

``````255.255.11.135
255.255.111.35
``````

### IPv4 Address Partitions in Raku

Here again, we could build a procedural solution as we would probably do in most programming languages (and as we will do in Perl below).

But we can again use Raku’s expressive power to design a simpler solution. In this case, we’ll use regexes.

Using the `:exhaustive` (or `:ex`) adverb makes it possible to generate all possible matches of a pattern.

To start with, we will define a regex subpattern to match an octet. I would normally write a subpattern looking like this:

``````my \$octet = rx{(\d ** 1..3) <?{0 <= \$0 <= 255}>};
``````

This basically says Raku to match a number of 1 to 3 digits comprised between 0 and 255. The `<?{0 <= \$0 <= 255}>` is a code assertion within the pattern to limit the value of an octet to the `0..255` range. But, for some reason, the task specification says that an octet should not start with 0 (unless the octet is 0 itself). So, our subpattern will be a little bit more complicated (see below). In the rest of the code, we use the `:ex` adverb to generate all partitions matching four times the `\$octet` subppattern:

``````use v6;

my \$octet = rx {( || 0
|| <[ 1..9 ]> \d ** 0..2
) <?{0 <= \$0 <= 255}>
};
sub MAIN (Int \$in = 122202128) {
for \$in ~~ m:ex/^ (<\$octet>) ** 4 \$/ -> \$match {
say join ".", \$match;
}
}
``````

These are a few sample runs:

``````\$ perl6 ip.p6
122.202.12.8
122.202.1.28
122.20.212.8
122.20.21.28
122.20.2.128
12.220.212.8
12.220.21.28
12.220.2.128
12.2.202.128
1.22.202.128

\$ perl6 ip.p6 2765645
27.65.64.5
27.65.6.45
27.6.56.45
2.76.56.45

\$ perl6 ip.p6 12345678
123.45.67.8
123.45.6.78
123.4.56.78
12.34.56.78
1.234.56.78

\$ perl6 ip.p6 122022128
122.0.221.28
122.0.22.128
12.202.212.8
12.202.21.28
12.202.2.128
12.20.221.28
12.20.22.128
1.220.221.28
1.220.22.128
``````

### IPv4 Address Partitions in Perl

We use the recursive `partition` subroutine to generate all possible partitions of the input numeric string that match the octet specification:

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

sub partition {
my (\$out, @in) = @_;
for my \$nb_digits (0..2) {
return if \$nb_digits > \$#in;
my \$num = join "", @in[0..\$nb_digits];
return if \$num > 255;
return if \$num =~ /^0\d/;
my @left_digits = @in[\$nb_digits+1..\$#in];
my \$new_out = \$out eq "" ? \$num : (\$out . ".\$num");
if (@left_digits == 0) {
say \$new_out if \$new_out =~ /^\d+\.\d+\.\d+\.\d+\$/;
return;
}
partition (\$new_out, @left_digits);
}
}

my \$in = shift // 25525511135;
my @digits = split //, \$in;
partition "", @digits;
``````

Here are a few example runs of this program:

``````\$ perl ip.pl
255.255.11.135
255.255.111.35

\$ perl ip.pl 2765645
2.76.56.45
27.6.56.45
27.65.6.45
27.65.64.5

\$ perl ip.pl 122202128
1.22.202.128
12.2.202.128
12.220.2.128
12.220.21.28
12.220.212.8
122.20.2.128
122.20.21.28
122.20.212.8
122.202.1.28
122.202.12.8

\$ perl ip.pl 12345678
1.234.56.78
12.34.56.78
123.4.56.78
123.45.6.78
123.45.67.8
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 31, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 60: Excel Columns and Find Numbers to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9766 2020-05-17T17:51:45Z 2020-05-17T17:54:39Z These are some answers to the Week 60 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Please note that this blog post will be shorter than usual, since I’m a bit short of time to prepare it. Task... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 60 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Please note that this blog post will be shorter than usual, since I’m a bit short of time to prepare it.

Write a script that accepts a number and returns the Excel Column Name it represents and vice-versa.

Excel columns start at A and increase lexicographically using the 26 letters of the English alphabet, A..Z. After Z, the columns pick up an extra “digit”, going from AA, AB, etc., which could (in theory) continue to an arbitrary number of digits. In practice, Excel sheets are limited to 16,384 columns.

Example:

``````Input Number: 28
Output: AB

Output: 30
``````

### Excel Columns in Raku

We first create a lazy infinite list, `@cols`, of Excel column names. Note that we start with an empty string to avoid an off-by-one issue (as Excel column numbers starts at 1, not 0). We then create a hash mapping column names to column numbers.

We use two multi `MAIN` subroutines, one to convert number to names, and one to convert names to number.

``````use v6;

constant \MAX = 16_384;
my @cols = '', 'A', 'B' ... *;
my %nums = map { @cols[\$_] => \$_}, 1..MAX;

multi sub MAIN (Int \$n = 28) {
say "Column \$n = @cols[\$n]";
}

multi sub MAIN (Str \$col-name where * ~~ /^<[A..Z]>+\$/) {
say "Column \$col-name = %nums{\$col-name}";
}
``````

These are a few sample runs:

``````\$ perl6 excel-cols.p6
Column 28 = AB

\$ perl6 excel-cols.p6 44
Column 44 = AR

\$ perl6 excel-cols.p6 431
Column 431 = PO

\$ perl6 excel-cols.p6 AB
Column AB = 28

\$ perl6 excel-cols.p6 AR
Column AR = 44

\$ perl6 excel-cols.p6 PO
Column PO = 431
``````

### Excel Columns in Perl

This is essentially a port to Perl of the Raku program. Since we cannot have lazy infinite lists in Perl, we define a `MAXLET` constant (equal to “XFD”, corresponding to 16384 in numeric notation). Similarly, since we cannot have multiple `MAIN` subroutines in Perl, we analyze whether the input value is an integer or a string of letters between A and Z to decide in which direction to perform the conversion:

``````use strict;
use warnings;
use feature qw /say/;
use constant MAXNUM => 16_384;
use constant MAXLET => 'XFD';

my @cols = ('', 'A'..MAXLET);
my %nums = map { \$cols[\$_] => \$_ } 1..MAXNUM;
my \$in = shift // 28;
if (\$in =~ /^\d+\$/) {
say "Column \$in = \$cols[\$in]";
} elsif ( \$in =~ /^[A-Z]+\$/ ) {
say "Column \$in = \$nums{\$in}";
} else {
say "\$in is invalid input.";
}
``````

Example output:

``````\$ perl excel-cols.pl AA
Column AA = 27

\$ perl excel-cols.pl ZZ
Column ZZ = 702

\$ perl excel-cols.pl 16000
Column 16000 = WQJ

\$ perl excel-cols.pl 16384
Column 16384 = XFD
``````

Write a script that accepts list of positive numbers (`@L`) and two positive numbers `\$X` and `\$Y`.

The script should print all possible numbers made by concatenating the numbers from `@L`, whose length is exactly `\$X` but value is less than `\$Y`.

Example input:

``````@L = (0, 1, 2, 5);
\$X = 2;
\$Y = 21;
``````

With this input, the output should be:

``````10, 11, 12, 15, 20
``````

## Finding Numbers in Raku

We use the `combinations` to generate digit combinations, and the `permutations` method on these combinations, concatenate the permutations generated into numbers and then print out numbers whose length and value match the input criteria.

``````sub MAIN (Int \$length, Int \$max-val, Str \$list) {
my @L = | \$list.split(" ") xx \$length;
my @out;
for @L.combinations: 1..\$length -> \$seq {
for \$seq.permutations>>.join('') -> \$num {
push @out, +\$num if \$num < \$max-val
and \$num.Int.chars == \$length;
}
}
.say for @out.sort.squish;
}
``````

Sample runs:

``````\$ perl6 find-numbers.p6 2 50 "3 4 5"
33
34
35
43
44
45

\$ perl6 find-numbers.p6 2 21 "0 1 2 5"
10
11
12
15
20

\$ perl6 find-numbers.p6 3 145 "0 1 2 5 12 31"
100
101
102
105
110
111
112
115
120
121
122
125
131
``````

## Finding Numbers in Perl

Here, we write a recursive `permute` subroutine to generate all possible numbers from the input list, and then print out the numbers whose length and value match the input criteria.

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

my \$length = shift;
my \$max_val = shift;
my @L = @ARGV;

sub permute {
my (\$seed, @list) = @_;
return if length \$seed > \$length;
for my \$val (@list) {
next if \$seed eq "" and \$val == 0;
my \$new_seed = 0 + (\$seed . \$val);
say \$new_seed if length \$new_seed == \$length
and \$new_seed < \$max_val;
permute(\$new_seed, @list);
}
}

permute "", @L;
``````

Sample runs:

``````\$ perl find-numbers.pl 2 41 3 1 2 5
33
31
32
35
13
11
12
15
23
21
22
25

\$ perl find-numbers.pl 2 21 0 1 2 5
10
11
12
15
20
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 24, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 59: Linked Lists and Bit Sums to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9759 2020-05-10T14:58:36Z 2020-05-10T15:06:44Z These are some answers to the Week 59 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a few hours. This blog post offers some solutions to this challenge, please... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 59 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few hours. 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 linked list and a value k. Write a script to partition the linked list such that all nodes less than k come before nodes greater than or equal to k. Make sure you preserve the original relative order of the nodes in each of the two partitions.

For example:

``````Linked List: 1 → 4 → 3 → 2 → 5 → 2

k = 3
``````

Expected Output: 1 → 2 → 2 → 4 → 3 → 5.

A linked list is a linear collection of data items, which are often called nodes, in which each data item holds a value (or several values) and a link to the next item of the collection. Each node points to the next. It is a data structure consisting of a collection of nodes which together represent a sequence. Usually, each node contains some data and a reference (in other words, a link) to the next node in the sequence. This structure is very useful in low-level languages such as C, since it allows for easy insertion or removal of elements at any position in the sequence.

Now, both Perl and Raku make it possible to easily add or remove data items at any position in an array. Therefore, I do not see any reason to implement a low-level linked list in these languages. In the course of the two last Perl Weekly Challenges, I showed how a binary tree could be implemented as a simple flat array with an implicit data structure. It would be a regression to bend over backward and implement a linked-list in Perl or Raku. And it would be a case of over-engineering. In brief, I’ll use simple arrays for this task.

However, for the sake of completeness, I’ll show a brief implementation of actual linked lists in Perl. But I do not recommend using it.

### Linked List Partition in Raku

The `partition` subroutine simply feeds two arrays with values less than k or values greater than or equal to k, and returns merged data in the proper order.

``````use v6;

sub partition (\$k, @list) {
my @before = grep {\$_ < \$k}, @list;
my @after = grep {\$_ >= \$k}, @list;
return |@before, |@after;
}

sub MAIN (\$k, Str \$list-str = "1 4 3 2 5 2") {
my @list = \$list-str.comb(/\d+/);
my @result = partition \$k, @list;
say @result.join(" → ");
}
``````

This displays the following output:

``````\$ perl6 linked1.p6 3
1 → 2 → 2 → 4 → 3 → 5

\$ perl6 linked1.p6  4 "3 5 4 5 8 7 9 2"
3 → 2 → 5 → 4 → 5 → 8 → 7 → 9
``````

However, it can be made simpler and possibly slightly more efficient using the classify built-in function of Raku as shown in this very simple example:

``````use v6;

my \$k = 3;
my @vals = <1 4 3 2 5 2>;
my %out = classify { \$_ < \$k ?? 'before' !! 'after'}, @vals;
say join " → ", |%out<before>, |%out<after>;
``````

This duly prints the correct result:

``````\$ perl6 linked2.p6
1 → 2 → 2 → 4 → 3 → 5
``````

We could even reduce it to a Raku one-liner:

``````\$ perl6 -e 'say join " ", (classify { \$_ < 3 ?? "b" !! "a" }, <1 4 3 2 5 2>)<b a>'
1 2 2 4 3 5
``````

Similarly, we could use the categorize method and an method-invocation syntax:

``````\$ perl6 -e '<1 4 3 2 5 2>.categorize({ \$_ < 3 ?? "b" !! "a" })<b a>.join(" ").say'
1 2 2 4 3 5
``````

### Linked List Partition in Perl

This is a Perl port of the first Raku solution above, with a `partition` subroutine to split the input into two arrays:

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

sub partition {
my \$k = shift;
my @before = grep {\$_ < \$k} @_;
my @after = grep {\$_ >= \$k} @_;
return @before, @after;
}

my \$k = shift;
my \$list_str = shift // "1 4 3 2 5 2";
my @list = \$list_str =~ /\d+/g;
my @result = partition \$k, @list;
say join " → ", @result;
``````

Two execution examples:

``````\$ perl linked1.pl 3
1 → 2 → 2 → 4 → 3 → 5

\$ perl linked1.pl 3 "1 4 3 4 5 6 7 2 1"
1 → 2 → 1 → 4 → 3 → 4 → 5 → 6 → 7
``````

As I said before, I really do not recommend the implementation of an actual linked list to solve this problem.

But, just in case you think that I balk at doing it because I don’t know how to do it, or more generally in the event that you would like to see how this could be implemented, this is one possible way to do it, using nested hashes:

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

my \$input = shift;
my \$L;
for my \$val (reverse split / /, \$input) {
my \$pt = { value => \$val, next => \$L };
\$L = \$pt;
}
return \$L;
}

my \$k = shift;
my \$list_str = shift // "1 4 3 2 5 2";
# say Dumper \$list;
my (@before, @after);
while (1) {
last unless defined \$list->{value};
my \$temp = \$list->{value};
if (\$temp < \$k) {
push @before, \$temp;
} else {
push @after, \$temp;
}
\$list = \$list->{next}
}
say join " → ", @before, @after;
``````

And this is a sample run:

``````\$ perl  linked2.pl 3
1 → 2 → 2 → 4 → 3 → 5
``````

But again, creating an actual linked list for the problem is, in my humble view, technological overkill.

Helper Function: for this task, you will most likely need a function f(a,b) which returns the count of different bits of binary representation of a and b.

For example, f(1,3) = 1, since:

``````Binary representation of 1 = 01

Binary representation of 3 = 11
``````

There is only 1 different bit. Therefore the subroutine should return 1. Note that if one number is longer than the other in binary, the most significant bits of the smaller number are padded (i.e., they are assumed to be zeroes).

Script Output: your script should accept n positive numbers. Your script should sum the result of f(a,b) for every pair of numbers given.

For example, given 2, 3, 4, the output would be 6, since f(2,3) + f(2,4) + f(3,4) = 1 + 2 + 3 = 6

### Bit Sum in Raku

In the `compare` subroutine, we just produce a binary string (eight digits) for each input number, split the binary string into arrays, loop through both arrays at the same time to compare the individual bits. And we use the combinations built-in method to build every pair of numbers:

``````use v6;

sub compare (UInt \$m, UInt \$n) {
my @a = \$m.fmt('%08b').comb;
my @b = \$n.fmt('%08b').comb;
my \$cnt = 0;
for 0..7 -> \$i {
\$cnt++ if @a[\$i] != @b[\$i];
}
return \$cnt;
}
my \$diff = 0;
for @*ARGS.combinations(2) -> \$seq {
\$diff += compare +\$seq, +\$seq;
}

say \$diff;
``````

This program displays the following output:

``````\$ perl6 bit_sum.p6 2 3 4
6
\$ perl6 bit_sum.p6 32 64 137
10
``````

Using the Raku built-in `Z` or zip operator can make the `compare` subroutine more compact:

``````sub compare (UInt \$m, UInt \$n) {
my \$cnt = 0;
for \$m.fmt('%08b').comb Z \$n.fmt('%08b').comb -> [\$l, \$r] {
\$cnt++ if \$l != \$r;
}
return \$cnt;
}
``````

### Bit Sum in Perl

This is a port to Perl of the first Raku solution above, with a `compare` subroutine to find out the number of different bits between two numbers. Since Perl doesn’t have a built-in `combinations` function, we just use two nested `for` loops to generate every pair of numbers:

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

sub compare {
my (\$m, \$n) = @_;
my @a = split //, sprintf "%08b", \$m;
my @b = split //, sprintf "%08b", \$n;
my \$cnt = 0;
for my \$i (0..7) {
\$cnt++ if \$a[\$i] != \$b[\$i];
}
return \$cnt;
}
my \$diff = 0;
my @nums = @ARGV;
for my \$i (0..\$#nums) {
for my \$j ((\$i+1) .. \$#nums) {
\$diff += compare \$nums[\$i], \$nums[\$j];
}
}
say \$diff;
``````

Sample output:

``````\$ perl bit_sum.pl 2 3 4
6

\$ perl bit_sum.pl 32 64 137
10
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 17, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted # Perl Weekly Challenge 58: Compare Versions and Ordered Lineup to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9747 2020-05-01T17:09:15Z 2020-05-01T17:23:01Z These are some answers to the Week 58 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a couple of days (May 3, 2020). This blog post offers some solutions... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 58 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (May 3, 2020). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Compare two given version number strings `v1` and `v2` such that:

- If `v1 > v2` return 1 - If `v1 < v2` return -1 - Otherwise, return 0

The version numbers are non-empty strings containing only digits, and the dot (“.”) and underscore (“_”) characters. (“_” denotes an alpha/development version, and has a lower precedence than a dot, “.”). Here are some examples:

``````   v1   v2    Result
------ ------ ------
0.1 < 1.1     -1
2.0 > 1.2      1
1.2 < 1.2_5   -1
1.2.1 > 1.2_1    1
1.2.1 = 1.2.1    0
``````

Version numbers may also contain leading zeros. You may handle these how you wish, as long as it’s consistent.

### Compare Versions in Perl

Perl has two binary data comparison operators, `cmp` and `<=>`, which do exactly what is required. For example, `cmp` returns -1, 0, or 1 depending on whether the left argument is stringwise less than, equal to, or greater than the right argument. Similarly, `<=>` returns -1, 0, or 1 depending on whether the left argument is numerically less than, equal to, or greater than the right. In other words, they do exactly what we want, except of course that we have to deal with version number strings.

In my solution, the idea is to split the version string and sort the resulting arrays in such a way that if the major (first) version number makes the difference, then we are done; if not, then we compare the second version number and rank the versions accordingly; if not, we compare the third version number. We assume that versions always have at most three digits. We also assume that version “2.1” can be converted internally into “2.1.0” without any change in the ranking order.

With these assumptions, we can use the following program:

``````use strict;
use warnings;
use feature "say";
use Test::More tests => 5;

sub cmp_versions {
my (\$v1, \$v2) = @_;
s/_/.00/g for (\$v1, \$v2);
my @a1 = split /[._]/, \$v1;
my @a2 = split /[._]/, \$v2;
\$a1 = 0 unless defined \$a1;
\$a2 = 0 unless defined \$a2;
\$a1 <=> \$a2 || \$a1 cmp \$a2 || \$a1 cmp \$a2;
}

is cmp_versions('0.1', '1.1'), -1, "Two-part version numbers";
is cmp_versions('2.0', '1.2'), 1, "Two-part version numbers";
is cmp_versions('1.2', '1.2.5'), -1, "Two-part and three-part version numbers";
is cmp_versions('1.2.1', '1.2_1'), 1, "With underscore";
is cmp_versions('1.2.1', '1.2.1'), 0, "Three-part version numbers";
``````

This program returns correct results for the five test cases:

``````\$ perl cmp_versions.pl
1..5
ok 1 - Two-part version numbers
ok 2 - Two-part version numbers
ok 3 - Two-part and three-part version numbers
ok 4 - With underscore
ok 5 - Three-part version numbers
``````

### Compare Versions in Raku

Raku has a built-in Version class and type. In principle, we could just declare the version number strings as `Version` objects and use the `cmp` operators on them. But that wouldn’t work with version numbers with an underscore in it specified in the task description, such as `1.2_1`, as the Raku `Version` class doesn’t use underscores as separators. We could probably subclass the `Version` class, but that’s a bit too much work in my view for the scope of this task.

We can use the same idea as in Perl, except that in Raku, the `cmp` and `<=>` operators do not return -1, 0 or 1, but the values of the `less`, `same` or `more` objects. At the same time, `less`, `same` or `more` are just `enum` values for -1, 0 or 1, as shown in this definition of `Order` values:

``````enum Order (:Less(-1), :Same(0), :More(1));
``````

In brief, compared to the Perl solution, we need to convert the `Order` values back to their numerical equivalent. This is our solution:

``````use v6
use Test;
plan 5;

sub cmp-versions (\$v1 is copy, \$v2 is copy) {
constant %order = reverse Order.enums;
s:g/_/.00/ for \$v1, \$v2;
my @a1 = split /<[._]>/, \$v1;
my @a2 = split /<[._]>/, \$v2;
\$_ = 0 unless defined \$_ for @a1, @a2;
return %order{@a1 <=> @a2 || @a1 <=> @a2
|| @a1 cmp @a2};
}

is cmp-versions('0.1', '1.1'), -1, "Two-part version numbers";
is cmp-versions('2.0', '1.2'), 1, "Two-part version numbers";
is cmp-versions('1.2', '1.2.5'), -1, "Two-part and three-part version numbers";
is cmp-versions('1.2.1', '1.2_1'), 1, "With underscore";
is cmp-versions('1.2.1', '1.2.1'), 0, "Three-part version numbers";
``````

The result is satisfactory:

``````\$ perl6 cmp_versions.p6
1..5
ok 1 - Two-part version numbers
ok 2 - Two-part version numbers
ok 3 - Two-part and three-part version numbers
ok 4 - With underscore
ok 5 - Three-part version numbers
``````

Write a script to arrange people in a lineup according to how many taller people are in front of each person in line. You are given two arrays. @H is a list of unique heights, in any order. @T is a list of how many taller people are to be put in front of the corresponding person in @H. The output is the final ordering of people’s heights, or an error if there is no solution.

Here is a small example:

``````@H = (2, 6, 4, 5, 1, 3) # Heights
@T = (1, 0, 2, 0, 1, 2) # Number of taller people in front
``````

The ordering of both arrays lines up, so H[i] and T[i] refer to the same person. For example, there are 2 taller people in front of the person with height 4, and there is 1 person in front of the person with height 1.

Here is a diagram of the input arrays @H and @T:

orderedline1.svg

Finally, here is one possible solution that satisfies @H and @T:

orderedline2.svg

As per the last diagram, your script would then output the ordering (5, 1, 2, 6, 3, 4) in this case. (The leftmost element is the “front” of the array.)

Here’s a 64-person example, with answer provided:

``````# Heights
@H = (27, 21, 37,  4, 19, 52, 23, 64,  1,  7, 51, 17, 24, 50,  3,  2,
34, 40, 47, 20,  8, 56, 14, 16, 42, 38, 62, 53, 31, 41, 55, 59,
48, 12, 32, 61,  9, 60, 46, 26, 58, 25, 15, 36, 11, 44, 63, 28,
5, 54, 10, 49, 57, 30, 29, 22, 35, 39, 45, 43, 18,  6, 13, 33);

# Number taller people in front
@T = ( 6, 41,  1, 49, 38, 12,  1,  0, 58, 47,  4, 17, 26,  1, 61, 12,
29,  3,  4, 11, 45,  1, 32,  5,  9, 19,  1,  4, 28, 12,  2,  2,
13, 18, 19,  3,  4,  1, 10, 16,  4,  3, 29,  5, 49,  1,  1, 24,
2,  1, 38,  7,  7, 14, 35, 25,  0,  5,  4, 19, 10, 13,  4, 12);

@A = (35, 23,  5, 64, 37,  9, 13, 25, 16, 44, 50, 40,  2, 27, 36,  6,
18, 54, 20, 39, 56, 45, 12, 47, 17, 33, 55, 30, 26, 51, 42, 53,
49, 41, 32, 15, 22, 60, 14, 46, 24, 59, 10, 28, 62, 38, 58, 63,
8, 48,  4,  7, 31, 19, 61, 43, 57, 11,  1, 34, 21, 52, 29,  3);
``````

You’re free to come up with your own inputs. Here is a 1000-person list, if you like!

At first, it took me a while to really understand the task. Once I understood the requirement, my first reaction was that this was going to be a quite complicated problem, with a large brute force program and a lot of backtracking.

### Designing the Algorithm by Hand

To get a better idea of the task, I settled to solve the small example by hand. I found out relatively quickly that the solution can be constructed iteratively quite easily.

We have this:

``````@H = (2, 6, 4, 5, 1, 3) # Heights
@T = (1, 0, 2, 0, 1, 2) # Number of taller people in front
``````

Let’s pick up the smallest height, 1. We know that there is one taller person before and, since it is the smallest one, there cannot be a smaller before. So the person with heigth 1 can only be in the second position (with index 1 in an array). So our resulting array would be, at this point:

``````(undef, 1)
``````

Next, we take the second smallest, 2, which also has one taller person before. The starting idea would be to put that person in the second position, but it is already occupied by 1. We can just put that person in the next free slot, the third position. There will be a taller item in the first position and there is also a smaller item, 1, before it. So, it’s fine for now:

``````(undef, 1, 2)
``````

The next smallest person is 3, and has two taller ones before. We can initially try to put in in the third position, but it’s occupied by the 2. If we try to put it in the next position (the fourth one), it would still not work, because there would be only one slot available for a taller person (the first version of the program I wrote had this mistake, because I made it too quickly). But we can place this person in the fifth position, so that we have two slots available for taller persons, and we know there cannot be any other smaller person, since all smaller persons have already been placed. So, for now, we have:

``````(undef, 1, 2, undef, 3)
``````

Using the same reasoning iteratively, we can place each person so:

``````(undef, 1, 2, undef, 3, 4)
(5, 1, 2, undef, 3, 4)
(5, 1, 2, 6, 3, 4)
``````

It clearly appears that there is only one solution, since each time through the process there was only one way to place a person. Assuming all heights are unique, we can conclude that for any such problem, there can be only one or zero solution.

### Ordered Lineup in Perl

Once we have the algorithm, implementing it is fairly easy. The first thing we want to do is to make the link between the height and the number of taller people before in the line more robust than two parallel arrays. This is what we do with the `%mapping` hash. Then we pick each height in ascending order and place it in the `@result` array in accordance with the rules described above. At the end of the process, each slot of the array should be populated if there was a solution to the problem. If the problem had no solution, then some of the values in the array should be undefined. So we can just check that: if all values are defined, we just display the array; if there is one or more undefined values, then we print that the problem has no solution.

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

# Heights
my @H = qw/27 21 37 4 19 52 23 64 1 7 51 17 24 50 3 2
34 40 47 20 8 56 14 16 42 38 62 53 31 41 55 59
48 12 32 61 9 60 46 26 58 25 15 36 11 44 63 28
5 54 10 49 57 30 29 22 35 39 45 43 18 6 13 33/;

# Number taller people in front
my @T = qw/6 41 1 49 38 12 1 0 58 47 4 17 26 1 61 12
29 3 4 11 45 1 32 5 9 19 1 4 28 12 2 2
13 18 19 3 4 1 10 16 4 3 29 5 49 1 1 24
2 1 38 7 7 14 35 25 0 5 4 19 10 13 4 12/;

# mapping sizes to number of taller people before
my %mapping;
@mapping{@H} = @T;

my @result;
for my \$height (sort { \$a <=> \$b } @H) {
my \$rank = \$mapping{\$height};
# number of taller people, and add 1 for each
# defined value before the place where we will
# end up placing the current item
my \$i = 0;
while (\$i <= \$rank) {
\$rank++ if defined \$result[\$i++];
}
\$result[\$rank] = \$height;
}
if (0 == grep { not defined \$_ } @result) {
say "@result";
} else {
say "No solution!";
}
``````

This produces the following output with the above input values:

``````\$ perl ordered_line.pl
35 23 5 64 37 9 13 25 16 44 50 40 2 27 36 6 18 54 20 39 56 45 12 47 17 33 55 30 26 51 42 53 49 41 32 15 22 60 14 46 24 59 10 28 62 38 58 63 8 48 4 7 31 19 61 43 57 11 1 34 21 52 29 3
``````

Changing some values to make the problem unsolvable:

``````\$ perl ordered_line.pl
No solution
``````

### Ordered Lineup in Raku

We essentially port the Perl program to Raku:

``````use v6;

# Heights
my @H = < 27 21 37 4 19 52 23 64 1 7 51 17 24 50 3 2
34 40 47 20 8 56 14 16 42 38 62 53 31 41 55 59
48 12 32 61 9 60 46 26 58 25 15 36 11 44 63 28
5 54 10 49 57 30 29 22 35 39 45 43 18 6 13 33 >;

# Number taller people in front
my @T = < 6 41 1 49 38 12 1 0 58 47 4 17 26 1 61 12
29 3 4 11 45 1 32 5 9 19 1 4 28 12 2 2
13 18 19 3 4 1 10 16 4 3 29 5 49 1 1 24
2 1 38 7 7 14 35 25 0 5 4 19 10 13 4 12 >;

# mapping sizes to number of taller people before
my %mapping;
%mapping{@H} = @T;

my @result;
for @H.sort -> \$height {
my \$rank = %mapping{\$height};
my \$i = 0;
\$rank++ if defined @result[\$i++] while \$i <= \$rank;
@result[\$rank] = \$height;
}
say 0 == (grep { ! defined \$_ }, @result).elems ?? "@result[]" !! "No solution!";
``````

We obtain the following output:

``````\$ perl6 ordered_line.p6
35 23 5 64 37 9 13 25 16 44 50 40 2 27 36 6 18 54 20 39 56 45 12 47 17 33 55 30 26 51 42 53 49 41 32 15 22 60 14 46 24 59 10 28 62 38 58 63 8 48 4 7 31 19 61 43 57 11 1 34 21 52 29 3
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 10, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 57: Tree Inversion and Shortest Unique Prefix to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9745 2020-04-26T17:26:58Z 2020-04-27T13:41:12Z These are some answers to the Week 57 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a couple of hours. This blog post offers some solutions to this challenge,... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 57 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of hours. 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 full binary tree of any height, similar to the one below:

``````    1
/  \
2    3
/ \  / \
4   5 6  7
``````

Write a script to invert the tree, by mirroring the children of every node, from left to right. The expected output from the tree above would be:

``````    1
/  \
3    2
/ \  / \
7   6 5  4
``````

The input can be any sensible machine-readable binary tree format of your choosing, and the output should be the same format.

Bonus: In addition to the above, you may wish to pretty-print your binary tree in a human readable text-based format as above.

I'll definitely take the bonus, because making auxiliary subroutines to represent graphically the trees is the best way to check that inversion subroutine works correctly (or to see the errors, if any). But I will not represent the tree edges (the `/` and `\` connecting vertically the letters), because it becomes a bit difficult with 4 levels and more or less unmanageable (and quite ugly) when there are more that 4 levels. For example, I chose to represent a 5-level binary tree as follows:

``````                1
2               3
4       5       6       7
8   9   a   b   c   d   e   f
g h i j k l m n o p q r s t u v
``````

I decided to implement two different subroutines for the display: one `bft` (breadth-first traversal) subroutine to construct an intermediate array of arrays in which each level of the tree is contained in one subarray:

``````[ [2 3] [4 5 6 7] [8 9 a b c d e f] [g h i j k l m n o p q r s t u v]]
``````

and one `display` subroutine to produce the graphical ASCII representation. The reason for doing that is that the `display` subroutine can thus be reused, independently of the internal tree representation.

## Tree Inversion In Perl

I have discussed in my blog post of last week 3 different ways to represent a binary tree: hash of hashes, array of arrays and a simple flat array, but presented only the array of arrays solution in Perl. This week, I'll use an array of arrays and a flat array.

### Tree Inversion Using an Array of Arrays

For each node, the first array item is the current value, the second item the left child and the third item the right child. For example, the binary tree shown in the task description could be initialized as follows:

``````my \$tree = [1, [2, , ], [3, , ]];
``````

In this implementation, the `bft` and `invert` subroutines are both recursive to perform a depth-first traversal of the binary tree.

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;

my \$tree = [1, [2, [4, , ], [5, ['a'], ['b']]],
[3, [6, ['c'], ['d']], [7, ['e'], ['f']]]];

sub invert {
my \$node = shift;
invert(\$node->) if defined \$node->;
invert(\$node->) if defined \$node->;
(\$node->, \$node->) = (\$node->, \$node->)
if defined \$node-> and defined \$node->
}
my @bft_tree;
bft (\$tree, 0);
say "Tree before inversion:";
display(\@bft_tree);
invert(\$tree);
@bft_tree = ();
bft (\$tree, 0);
say "\nTree after inversion:";
display(\@bft_tree);

sub bft {          # Breadth First Traversal
my (\$node, \$level) = @_;
push @{\$bft_tree[\$level]}, \$node->;
bft(\$node->, \$level + 1) if defined \$node->;
bft(\$node->, \$level + 1) if defined \$node->;
}
sub display {
my \$bft_tree = shift;
my \$start = scalar @{\$bft_tree->[-1]};
my \$sep_val = (2 * \$start) - 1;
for my \$line (@\$bft_tree) {
my \$sep = " " x \$sep_val;
say " " x \$start, join \$sep, @\$line;
\$start /= 2;
\$sep_val = (\$sep_val - 1) / 2;
}
}
``````

This is the output displayed by this program:

``````\$ perl invert_tree.pl
Tree before inversion:
1
2       3
4   5   6   7
8 9 a b c d e f

Tree after inversion:
1
3       2
7   6   5   4
f e d c b a 9 8
``````

### Tree Inversion Using a Flat Array

Binary trees can also be stored in breadth-first order as an array with an implicit data structure. This is similar to what is commonly done for binary heaps (i.e. a binary tree that keeps a partial order). Here, we're not interested with partial order, but the idea is to use an array with the following properties. The item with subscript 0 is the value of the root node. The index of an element is used to compute the index of its parent and the indices of its children. The basic idea is that, for any node, the index of its parent is about half the index of the current node, and, conversely, the indices of the children are about twice the index of the current node. More precisely, for a tree starting at index 0, the exact formulas for a node with index `\$n` are commonly as follows:

• parent: `int( (\$n-1)/2 )`
• left child: `2*\$n + 1`
• right child: `2*\$n + 2`

The root node is at index 0, and its children are at positions 1 and 2. The children of item with index 1 are at positions 3 and 4 and the children of 2 are at positions 5 and 6.

These rules may seem a bit complicated (and it is a bit tedious to compute these things manually), but they're in fact quite easy to implement in a program:

``````sub children { my \$i = shift; 2*\$i + 1, 2*\$i + 2 }
sub parent { my \$i = shift; (\$i-1) / 2; }
``````

The `parent` subroutine is provided here for the purpose of completeness, it is not needed in our program.

Note that it is very easy to populate the binary-heap-like array from a graphical representation: you just need to perform a breadth-first traversal (and provide empty slots for missing nodes, but that's not necessary here, since we are only dealing with full binary trees). For example, this binary tree:

``````    1
/  \
2    3
/ \  / \
4   5 6  7
``````

can be encoded as:

``````my \$tree = [1 , 2, 3, 4, 5, 6, 7];
``````

or even:

``````my \$tree = [1 .. 7];
``````

Now, the `invert` subroutine becomes very simple, since we can use the `bft` to get an array of arrays by level, reverse the components and flatten the overall structure:

``````sub invert {
my \$bft_tree = bft(shift);
return [ map {reverse @\$_} @\$bft_tree ];
}
``````

or even with a single code line:

``````sub invert {
return [ map { reverse @\$_ } @{bft(shift)} ];
}
``````

The `bft` subroutine could be a recursive subroutine as before:

``````sub bft2 {
my (\$index, \$level) = @_;
push @{\$bft_tree[\$level]}, \$tree->[\$index];
my (\$left, \$right) = children \$index;
bft(\$left, \$level + 1) if defined \$tree->[\$left];
bft(\$right, \$level + 1) if defined \$tree->[\$right];
}
``````

but I find it simpler to use a `while` loop to traverse the tree:

``````sub bft {               # Breadth First Traversal
my \$tree = shift;
my (\$index, \$level) = (0, 0);
my @bft_tree;
while (\$index < scalar @\$tree) {
my \$new_index = \$index + 2 ** \$level - 1;
push @{\$bft_tree[\$level++]}, @{\$tree}[\$index .. \$new_index];
\$index = \$new_index + 1;
}
return \@bft_tree;
}
``````

This is the final code for the whole program:

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;

sub children { my \$i = shift; 2*\$i+1, 2*\$i+2 }
sub parent { my \$i = shift; (\$i-1)/2; }  # not needed here

sub display {
my \$bft_tree = bft(shift);
my \$start = scalar @{\$bft_tree->[-1]};
my \$sep_val = (2 * \$start) - 1;
for my \$line (@\$bft_tree) {
my \$sep = " " x \$sep_val;
say " " x \$start, join \$sep, @\$line;
\$start /= 2;
\$sep_val = (\$sep_val - 1) / 2;
}
}
sub bft {               # Breadth First Traversal
my \$tree = shift;
my (\$index, \$level) = (0, 0);
my @bft_tree;
while (\$index < scalar @\$tree) {
my \$new_index = \$index + 2 ** \$level - 1;
push @{\$bft_tree[\$level++]}, @{\$tree}[\$index .. \$new_index];
\$index = \$new_index + 1;
}
return \@bft_tree;
}
sub invert {
return [ map { reverse @\$_ } @{bft(shift)} ];
}

my \$tree = [ 1..9, 'a'..'v' ];
say "\nTree before inversion";
display \$tree;
my \$inverted_tree = invert(\$tree);
say "\nInverted tree";
display \$inverted_tree;
``````

This program produces the following output:

``````\$ perl invert_tree2.pl
Tree before inversion
1
2               3
4       5       6       7
8   9   a   b   c   d   e   f
g h i j k l m n o p q r s t u v

Inverted tree
1
3               2
7       6       5       4
f   e   d   c   b   a   9   8
v u t s r q p o n m l k j i h g
``````

## Tree Inversion In Raku

### Using a Flat Array

We'll start with a flat array. Please refer to the Tree Inversion Using a Flat Array section just above for explanations about the use of flat arrays to store binary trees. The Raku code below is essentially a port of the Perl code:

``````use v6;

sub children (Int \$i) { 2*\$i+1, 2*\$i+2 }
sub parent (Int \$i) { (\$i-1)/2; }  # not needed here

sub display (\$tree) {
my @bft_tree = bft(\$tree);
my \$start = (@bft_tree[*-1]).elems;
my \$sep_val = (2 * \$start) - 1;
for @bft_tree -> @line {
my \$sep = " " x \$sep_val;
say " " x \$start, join \$sep, @line;
\$start /= 2;
\$sep_val = (\$sep_val - 1) / 2;
}
}
sub bft (\$tree) {               # Breadth First Traversal
my (\$index, \$level) = (0, 0);
my @bft_tree;
while (\$index <= \$tree.end) {
my \$new_index = \$index + 2 ** \$level - 1;
(@bft_tree[\$level++]).append(\$tree[\$index .. \$new_index]);
\$index = \$new_index + 1;
}
return @bft_tree;
}
sub invert (\$tree) {
return [ map { | reverse @\$_ }, bft(\$tree) ];
}

my \$tree = (1..9, 'a'..'v').flat;
say \$tree;
say "\nTree before inversion";
display \$tree;
my \$inverted_tree = invert(\$tree);
say "\nInverted tree";
say "\$inverted_tree\n";
display \$inverted_tree;
``````

Running the program displays more or less the same output as before:

``````\$ perl6 invert_tree2.p6
(1 2 3 4 5 6 7 8 9 a b c d e f g h i j k l m n o p q r s t u v)

Tree before inversion:
1
2               3
4       5       6       7
8   9   a   b   c   d   e   f
g h i j k l m n o p q r s t u v

Inverted tree:
1 3 2 7 6 5 4 f e d c b a 9 8 v u t s r q p o n m l k j i h g

1
3               2
7       6       5       4
f   e   d   c   b   a   9   8
v u t s r q p o n m l k j i h g
``````

### Using a Hash of Hashes

A hash of hashes is probably the most explicit and clearest implementation of a binary tree. But it tends to be quite verbose.

A node is a hash consisting in three elements: its value (an integer), its left child and its right child. The children may be undefined when we are at the lowest level of the tree (i.e. when the node is a "leaf"). So a node could be implemented as a hash with three keys, `v` (value), `l` (left child) and `r` (right child). The children, when they are defined, are themselves nodes, so the structure is nested and can be explored recursively. For example, the following binary tree:

``````    1
/  \
2    3
/ \  / \
4   5 6  7
``````

can be encoded as:

``````my %tree =  v => 1,
l => { v => 2, l => {v => 4}, r => {v => 5} },
r => { v => 3, l => {v => 6}, r => {v => 7} },
;
``````

In this quick and simple implementation, we use global variables for the tree and for the breadth-first array, to avoid the pain of carrying them around back and forth in the successive recursive subroutine calls. In a real-life application, it would be more proper to pass them as arguments and return values of subroutines, or to use dynamic variables.

``````use v6;

my %tree =  v => 1,
l => { v => 2, l => {v => 4}, r => {v => 5} },
r => { v => 3, l => {v => 6}, r => {v => 7} },
;
my @bft-tree;

sub display (\$tree) {
my \$start = (@bft-tree[*-1]).elems;
my \$sep_val = (2 * \$start) - 1;
for @bft-tree -> @line {
my \$sep = " " x \$sep_val;
say " " x \$start, join \$sep, @line;
\$start /= 2;
\$sep_val = (\$sep_val - 1) / 2;
}
}
sub bft (%node, \$level) {
push @bft-tree[\$level], %node<v>;
bft(%node<l>, \$level + 1) if defined %node<l>;
bft(%node<r>, \$level + 1) if defined %node<r>;
}
sub invert (%node) {
invert(%node<l>) if defined %node<l>;
invert(%node<r>) if defined %node<r>;
(%node<l>, %node<r>) = %node<r>, %node<l>
if defined %node<l> and defined %node<r>;
}
bft %tree, 0;
say "Tree before inversion:";
display(@bft-tree);
invert(%tree);
@bft-tree = ();
bft %tree, 0;
say "\nTree after inversion";
display(@bft-tree);
``````

This program produces the following output:

``````\$ ./perl6 invert_tree3.p6
Tree before inversion:
1
2   3
4 5 6 7

Tree after inversion
1
3   2
7 6 5 4
``````

## Task 2: Shortest Unique Prefix

Write a script to find the shortest unique prefix for each each word in the given list. The prefixes will not necessarily be of the same length.

Sample Input:

``````[ "alphabet", "book", "carpet", "cadmium", "cadeau", "alpine" ]
``````

Expected Output:

``````[ "alph", "b", "car", "cadm", "cade", "alpi" ]
``````

For solving this task, we'll need to examine every combination of two elements of the input list, which means essentially two nested loops. And checking the letters to obtain a unique prefix requires a third nested loop. To alleviate the combinational explosion, we'll start by storing each word in a hash of arrays in accordance with the word's initial letter, so that we can then compare only words with the same initial letter.

### Shortest Unique Prefix in Perl

This is my Perl implementation:

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;

my @prefixes;
my %letters;
for my \$word (@words) {
push @{\$letters{ substr \$word, 0, 1 }}, \$word;
}
for my \$letter (sort keys %letters) {
push @prefixes, \$letter and next if @{\$letters{\$letter}} == 1;
my \$candidate;
for my \$word1 ( @{\$letters{\$letter}} ) {
my \$prefix_length = 1;
for my \$word2 (@{\$letters{\$letter}} ) {
next if \$word1 eq \$word2;
my \$i = 1;
\$i++ while substr(\$word1, \$i, 1) eq substr(\$word2, \$i, 1);
if (\$i > \$prefix_length) {
\$candidate = substr(\$word1, 0, \$i + 1);
\$prefix_length = \$i
}
}
push @prefixes, \$candidate;
}
}
say "@prefixes";
``````

The output is correct:

``````\$ perl prefix.pl
``````

### Shortest Unique Prefix in Raku

Since I'm not entirely satisfied with my Perl implementation, which is a bit too complicated in my view (but was too lazy to change it), I won't port my Perl program to Raku this time, but will try a different approach. This is my Raku implementation:

``````use v6;

my @prefixes;
my %letters;
%letters.push(substr(\$_, 0, 1) =>  \$_) for @words;
for %letters.keys.sort -> \$let {
push @prefixes, \$let and next if %letters{\$let}.elems == 1;
my \$candidate;
for %letters{\$let}.flat -> \$word {
for 2..\$word.chars -> \$i {
my \$cand = substr \$word, 0, \$i;
my \$count = %letters{\$let}.grep({\$cand eq substr(\$_, 0, \$i)}).elems;
push @prefixes, \$cand and last if \$count == 1;
}
}
}
say @prefixes;
``````

And this is the output:

``````\$ ./perl6 prefix.p6
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 3, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge # 56: Diff-k and Path Sum to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9734 2020-04-18T18:57:20Z 2020-04-18T19:06:14Z These are some answers to the Week 56 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a couple of days (April 19, 2020). This blog post offers some solutions... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 56 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (April 19, 2020). 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 `@N` of positive integers (sorted) and another non negative integer k.

Write a script to find if there exists 2 indices `i` and `j` such that `A[i] - A[j] = k` and `i != j`.

It should print the pairs of indices, if any such pairs exist.

Example:

``````@N = (2, 7, 9)
\$k = 2
``````

Output : 2,1

Since the array items are not necessarily adjacent and we have to print all the matching pairs, I do not see any other way than basically trying all pairs. Well, since the array is sorted, we don’t really need to test all possible pairs, but only all combinations of 2 elements of the input array.

### Diff-k in Perl

There are some CPAN modules to generate combinations, but, as usual, I consider that it would somewhat cheating to use a ready-made solution. So, I’ll do it “the hard way” and manually generate the combinations. This is quite simple. The program uses two nested loops to iterate over the array, and prints out the pairs for which the difference is the target. The target difference and the array are passed as two arguments to the program. If no argument is passed, then the program uses some default values.

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;

sub find_diff {
my (\$diff, @array) = @_;
for my \$i (0..\$#array - 1) {
for my \$j (\$i +1.. \$#array) {
say "Indices \$j and \$i (values: \$array[\$j], \$array[\$i])"
if \$array[\$j] - \$array[\$i] == \$diff;
}
}
}
my \$k = shift // 2;
my @N = @ARGV;
@N = (2, 7, 9) unless @N;
find_diff \$k, @N;
``````

Here are some sample runs:

``````\$ perl find_diff.pl
Indices 2 and 1 (values: 9, 7)

\$ perl find_diff.pl 2 4 5 7 9 11 15 17
Indices 2 and 1 (values: 7, 5)
Indices 3 and 2 (values: 9, 7)
Indices 4 and 3 (values: 11, 9)
Indices 6 and 5 (values: 17, 15)

\$ perl find_diff.pl 4 4 5 7 9 11 15 17
Indices 3 and 1 (values: 9, 5)
Indices 4 and 2 (values: 11, 7)
Indices 5 and 4 (values: 15, 11)
``````

### Diff-k in Raku

Raku has a built-in method, `combinations`, which can generate all combinations of two (or any other number, or even a range of numbers) items from an input list. So, our program will just generate all combinations of indices and print out those matching the criteria:

``````use v6;

sub find-diff (\$diff,  @array) {
for (0..@array.end).combinations: 2 -> (\$i, \$j) {
say "Indices \$j and \$i (values: @array[\$j], @array[\$i])"
if @array[\$j] - @array[\$i] == \$diff;
}
}
my (\$k, @N);
if @*ARGS.elems > 2 {
(\$k, @N) = @*ARGS;
} else {
\$k = 2;
@N = 2, 7, 9;
}
find-diff \$k, @N;
``````

The program uses arguments passed to it (or default values if there isn’t enough arguments).

Here are some sample runs:

``````\$ perl6 find_diff.p6
Indices 2 and 1 (values: 9, 7)

\$ perl6 find_diff.p6  2 4 5 7 9 11 15 17
Indices 2 and 1 (values: 7, 5)
Indices 3 and 2 (values: 9, 7)
Indices 4 and 3 (values: 11, 9)
Indices 6 and 5 (values: 17, 15)

\$ perl6 find_diff.p6  4 4 5 7 9 11 15 17
Indices 3 and 1 (values: 9, 5)
Indices 4 and 2 (values: 11, 7)
Indices 5 and 4 (values: 15, 11)
``````

You are given a binary tree and a sum, write a script to find if the tree has a path such that adding up all the values along the path equals the given sum. Only complete paths (from root to leaf node) may be considered for a sum.

Example: given the below binary tree and sum = 22,

``````      5
/ \
4   8
/   / \
11  13  9
/  \      \
7    2      1
``````

For the given binary tree, the partial path sum 5 → 8 → 9 = 22 is not valid.

The script should return the path 5 → 4 → 11 → 2 whose sum is 22.

So basically we have to implement a depth-first tree traversal algorithm. Once this is done, finding the paths matching the criteria is quite easy.

The first question to be answered is: how do we represent a binary tree? There are a number of possibilities. We’ll just present three.

The most obvious way might be a nested hash of hashes. Each node by a hash with three items: the current node value, a reference to the left child and a reference to the right child. For example, the top of the binary tree shown above could look like this: `{ val => 5, left => {val => 4, left => { val => 11}}, right => { val => 8, left => { val => 13}, right { val => 9 }}}`. Or, in a more graphical way:

``````{ val => 5,
left => {
val => 4,
left => {
val => 11
}
},
right => {
val => 8,
left => {
val => 13
},
right {
val => 9
}
}
}
``````

But that’s quite verbose, I don’t like doing so much typing. A more concise way would to use a nested array of arrays. For each node, the first array item is the current value, the second item the left child and the third item the right child. The top of the tree shown above might look like this: `[5, [4, ], [8, , ]]`. Or, more graphically:

``````[
5,
[
4, 
],
[
8, 
]
]
``````

We could even use a simple flat array in a way similar to what is commonly done for binary heaps (i.e. a binary tree that keeps a partial order). Here we’re not interested with partial order, but the idea is to use an array with the following properties. The item with subscript 0 is the value of the root node. The index of an element is used to compute the index of its parent and the indices of its children. The basic idea is that, for any node, the index of its parent is about half the index of the current node, and, conversely, the indices of the children are about twice the index of the current node. More precisely, for a tree starting at index 0, the exact formulas for a node with index `\$n` are commonly as follows:

• parent: `int( (\$n-1)/2 )`
• left child: `2*\$n + 1`
• right child: `2*\$n + 2`

The root node is at index 0, and its children are at positions 1 and 2. The children of item with index 1 are at positions 3 and 4 and the children of 2 are at positions 5 and 6.

These rules may seem a bit complicated (and it is a bit tedious to compute these things manually), but they’re in fact quite easy to implement and the binary tree:

``````      5
/ \
4   8
/   / \
11  13  9
``````

would be represented by this simple array:

``````[5, 4, 8, 11, , 13, 9]
``````

We will implement such a data structure in the Raku solutions below.

Note that it is very easy to populate the binary-heap-like array from a graphical representation: you just need to perform a breadth-first traversal and provide empty slots for missing nodes.

### Path Sum in Perl

We’ll use a nested array of arrays to represent the binary tree. We implement a recursive `dfs` (for depth-first search) subroutine to traverse the various paths of the tree. At each call of the subroutine, we keep track of the current sum and of the current path. When we reach a leaf (no more child), we print the path if the current sum is equal to the target value.

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;

my \$tree = [5, [4, [11, , ]], [8, , [9, ]]] ;

sub dfs {
my (\$node, \$target, \$sum, \$path) = @_;
my \$new_sum = \$sum + \$node->;
unless (exists \$node-> or exists \$node->) {
say \$new_sum, " -> @\$path \$node->" if \$new_sum == \$target;
}
dfs(\$node->, \$target, \$new_sum, [@\$path, \$node->])
if defined \$node->;
dfs(\$node->, \$target, \$new_sum, [@\$path, \$node->])
if defined \$node->;
}

my \$target = shift // 22;
dfs(\$tree, \$target, 0, []);
``````

The default target is 22, but we can pass another value to the program.

Here are a few runs:

``````\$ perl bin_tree_sum.pl
22 -> 5 4 11 2

\$ perl  bin_tree_sum.pl 23
23 -> 5 8 9 1

\$ perl  bin_tree_sum.pl 22
22 -> 5 4 11 2

\$ perl  bin_tree_sum.pl 27
27 -> 5 4 11 7

\$ perl  bin_tree_sum.pl 26
26 -> 5 8 13
``````

### Path Sum in Raku

We’ll implement two solutions for the tree.

#### Implementing the Tree as a Nested Array of Arrays

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

``````use v6;

my @tree = [5, [4, [11, , ]], [8, , [9, ]]] ;

sub dfs (@node, \$target, \$sum, @path) {
my \$new-sum = \$sum + @node;
unless @node:exists or @node:exists {
say \$new-sum, " -> @path[] @node" if \$new-sum == \$target;
}
dfs(@node, \$target, \$new-sum, (@path, @node).flat)
if defined @node;
dfs(@node, \$target, \$new-sum, (@path, @node).flat)
if defined @node;
}

my \$target = @*ARGS.elems == 1 ?? @*ARGS !! 22;
dfs(@tree, \$target, 0, []);
``````

Here are a few runs:

``````\$ perl6  bin_tree_sum.p6
22 -> 5 4 11 2

\$ perl6  bin_tree_sum.p6 22
22 -> 5 4 11 2

\$ perl6  bin_tree_sum.p6 24

\$ perl6  bin_tree_sum.p6 26
26 -> 5 8 13

\$ perl6  bin_tree_sum.p6 23
23 -> 5 8 9 1
``````

#### Implementing the Tree as a Flat Array (Binary-Heap-like)

As explained above, we can use a flat array to represent a binary tree, with the following rules: the indices of the children of a node with index `\$n` are as follows:

• left child: `2*\$n + 1`
• right child: `2*\$n + 2`

In Raku, it isn’t possible to just leave an “empty slot” when defining an array. We need to provide undefined values, such as, for example, `Nil`, `Any`, or `Int`. We’ll use `Int` since it is the most consistent option with a tree made of integers.

The code isn’t much more complicated than before:

``````use v6;

my @tree = [5, 4, 8, 11, Int, 13, 9, 7, 2, Int, Int, Int, Int, 1];

sub dfs (\$index, \$target, \$sum, @path) {
sub children (\$i) { 2*\$i+1, 2*\$i+2 }
my \$cur-val = @tree[\$index];
my \$new-sum = \$sum + \$cur-val;
my (\$left, \$right) = children \$index;
unless defined @tree[\$left] or defined @tree[\$right] {
say \$new-sum, " -> @path[] \$cur-val" if \$new-sum == \$target;
}
dfs(\$left, \$target, \$new-sum, (@path, \$cur-val).flat)
if defined @tree[\$left];
dfs(\$right, \$target, \$new-sum, (@path, \$cur-val).flat)
if defined @tree[\$right];
}

my \$target = @*ARGS.elems == 1 ?? @*ARGS !! 22;
my \$root-node = 0;
dfs(\$root-node, \$target, 0, []);
``````

Here are a few runs:

``````\$ perl6 bin_tree_sum2.p6
22 -> 5 4 11 2

\$ perl6 bin_tree_sum2.p6 22
22 -> 5 4 11 2

\$ perl6 bin_tree_sum2.p6 23
23 -> 5 8 9 1

\$ perl6 bin_tree_sum2.p6 24

\$ perl6 bin_tree_sum2.p6 26
26 -> 5 8 13
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, April 26, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Commented on Perl Weekly Challenge 54: k-th Permutation Sequence and the Collatz Conjecture in laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9723#1810255 2020-04-16T07:46:36Z laurent_r Concerning the caching difficulties in the case of the "extra-credit" for the Collatz sequence, I have found a much better caching strategy, explained in the following blog post: http://blogs.perl.org/users/laurent_r/2020/04/revisiting-the-collatz-sequence-pwc-54.html.

]]>
Posted Revisiting the Collatz Sequence (PWC 54) to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9732 2020-04-15T23:00:44Z 2020-04-15T23:11:58Z In my blog post related to Perl Weekly Challenge 54 posted on April 4, 2020, the section about the "extra credit" task concerning the Collatz conjecture described in some details the difficulties encountered when trying to cache the data: the... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 In my blog post related to Perl Weekly Challenge 54 posted on April 4, 2020, the section about the "extra credit" task concerning the Collatz conjecture described in some details the difficulties encountered when trying to cache the data: the volume of data is very large. I'm blogging again on the subject because of new findings.

The Collatz conjecture concerns a sequence defined as follows: start with any positive integer n. Then each term is obtained from the previous term as follows: if the previous term is even, the next term is one half of the previous term. If the previous term is odd, the next term is 3 times the previous term plus 1. For example, the Collatz sequence for 23 is this:

``````23 70 35 106 53 160 80 40 20 10 5 16 8 4 2 1
``````

The conjecture is that, no matter what input value of n, the sequence will always reach 1. It is usually believed to be true (and no counter-example has ever been found), but, despite a lot of efforts, nobody has been able to prove it, and this is deemed to be a very difficult problem.

Computing the Collatz sequence of a given number is fairly easy and can be done in a simple one-liner:

``````\$ perl -E '\$n = shift; print "\$n "; while (\$n != 1) { \$n = \$n % 2 ? 3 * \$n + 1 : \$n / 2; print "\$n "} ' 26
26 13 40 20 10 5 16 8 4 2 1
``````

The extra-credit task was to calculate the sequence length for all starting numbers up to 1000000 (1e6), and output the starting number and sequence length for the longest 20 sequences.

## The Original Solution

In theory, it wouldn't be very complicated to encapsulate the above code into a loop to compute the Collatz sequence for any range of numbers. Except that going all the way up to 1,000,000 is probably going to take a very long time. One of the reason is that we are going to recompute Collatz sequence successors for the same number again and again many times. If you look at the two above examples, the sequences both end up with the following series: `40 20 10 5 16 8 4 2 1`. So, it might be useful, when we reach 40 for the first time, to compute the end of the sequence only once, and to store it in a hash of arrays (or possibly an array of arrays), in order to retrieve it straight from the hash when we reach 40 once more. And, of course, we can reuse the end of the sequence when computing the Collatz sequence for 40, 80, 160, as well as 52, 104, etc. Such a strategy is called caching or memoizing: storing in memory the result of a computation that we’re likely to have to compute again. It is sometimes described as “trading memory for time.”

Since we want to compute the Collatz sequence for all integers up to 1,000,000, the cache will grow very large (several millions of sequences) and we might run out of memory. In the first version of the program below, I tried to store all sequences up to one million, and the program turned out to be painfully slow. Looking at the system statistics, I found that, after a while, available memory became exhausted and the system would swap memory on the disk, leading to very slow execution. I made a couple of tests, and found that I could store the sequences for all numbers up to about 300,000 without exceeding the available memory of my computer (that number might be different on your computer), thus preventing the process from swapping and getting more or less the optimal performance, hence the MAX constant set to 300,000. Since I knew from earlier tests that the 20 longest sequences would all have more than 400 items, I also hard-coded a lower limit of 400 items for the sequences whose length had to be recorded. Another possibly better solution might have been to maintain a sliding array of the top 20 sequences, but I feared that maintaining this array many times over the execution of the program would end up impairing performance.

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;
use constant MAX => 300000;

my %cache;

sub collatz_seq {
my \$input = shift;
my \$n = \$input;
my @result;
while (\$n != 1) {
if (exists \$cache{\$n}) {
push @result, @{\$cache{\$n}};
last;
} else {
my \$new_n = \$n % 2 ? 3 * \$n + 1 : \$n / 2;
push @result, \$new_n;
\$cache{\$n} = [\$new_n, @{\$cache{\$new_n}}]
if defined (\$cache{\$new_n}) and \$n < MAX;
\$n = \$new_n;
}
}
\$cache{\$input} = [@result] if \$n < MAX;
return @result;
}

my @long_seqs;
for my \$num (1..1000000) {
my @seq = (\$num, collatz_seq \$num);
push @long_seqs, [ \$num, scalar @seq] if scalar @seq > 400;
}

@long_seqs = sort { \$b-> <=> \$a->} @long_seqs;
say  "\$_->: \$_->" for @long_seqs[0..19];
``````

With these optimizations, I was able to reduce execution time to 1 min 7 sec.:

``````\$ time perl collatz.pl
837799: 525
626331: 509
939497: 507
704623: 504
910107: 476
927003: 476
511935: 470
767903: 468
796095: 468
970599: 458
546681: 452
818943: 450
820022: 450
820023: 450
410011: 449
615017: 447
886953: 445
906175: 445
922524: 445
922525: 445

real    1m7,469s
user    1m6,015s
sys     0m1,390s
``````

## Changing the Caching Strategy

A couple of days after I submitted my solution to the Perl Weekly Challenge and posted my blog post mentioned above, I figured out that my caching strategy was in fact quite inefficient: the program doesn't need to cache the full sequence, it would be enough to just store the number of its items. And that reduces considerably the memory footprint and other overhead of the cache.

I originally did not try this change in Perl (and did not intend to do it), but I did it with the Raku solution. Changing the caching strategy made the Raku program 6 times faster (see below).

On April 5, 2020 (one day after my original blog post), 1nick published a very interesting message on the Perl Monks forum in which he presented another strategy: parallelizing the process using MCE::Map Each worker is handed only the beginning and end of the chunk of the sequence it will process, and workers communicate amongst themselves to keep track of the overall task. With this change (and no caching), this program ran 5 times faster, on a 12-core machine (the full program is presented in Nick's post). Following that initial post, an extremely interesting discussion emerged between Nick and several other Perl monks. I really cannot summarize this discussion here, just follow the link if you're interested (it's really worth the effort). Note that I saw this Perl Monks thread of discussion only on April 14.

Given that discussion on the Perl Monks forum, I felt compelled to implement the modified caching strategy (caching the sequence lengths rather than the sequences themselves) in the Perl version.

The computer on which I ran the next test is slower than the one where I ran those above. These are the timings of my original program for this computer:

``````real    1m37,551s
user    1m9,375s
sys     0m21,031s
``````

This is now my first implementation with the new caching strategy:

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use constant MAX => 1000000;

my %cache = (2 => 2);

sub collatz_seq {
my \$input = shift;
my \$n = \$input;
my \$result = 0;
while (\$n != 1) {
if (exists \$cache{\$n}) {
\$result += \$cache{\$n};
last;
} else {
my \$new_n = \$n % 2 ? 3 * \$n + 1 : \$n / 2;
\$result++;
\$cache{\$n} = \$cache{\$new_n} + 1
if defined \$cache{\$new_n} and \$n < MAX;
\$n = \$new_n;
}
}
\$cache{\$input} = \$result if \$input < MAX;
return \$result;
}

my @long_seqs;
for my \$num (1..1000000) {
my \$seq_length = collatz_seq \$num;
push @long_seqs, [ \$num, \$seq_length ] if \$seq_length > 400;
}

@long_seqs = sort { \$b-> <=> \$a->} @long_seqs;
say  "\$_->: \$_->" for @long_seqs[0..19];
``````

This program produces the same outcome, but is nearly 3 times faster:

``````real    0m34,207s
user    0m34,108s
sys     0m0,124s
``````

It's pretty good, but still not as good as Nick's parallelized solution (which ran 5 times faster).

## Using an Array Instead of a Hash

But we now end up with a cache having essentially one entry per input number in the 1..1000000 range. So, I thought, perhaps it might be better to use an array, rather than a hash, for the cache (accessing an array item should be faster than a hash lookup).

This is the code for this new implementation:

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use constant MAX => 1000000;

my @cache = (0, 1, 2);

sub collatz_seq {
my \$input = shift;
my \$n = \$input;
my \$result = 0;
while (\$n != 1) {
if (defined \$cache[\$n]) {
\$result += \$cache[\$n];
last;
} else {
my \$new_n = \$n % 2 ? 3 * \$n + 1 : \$n / 2;
\$result++;
\$cache[\$n] = \$cache[\$new_n] + 1
if defined \$cache[\$new_n] and \$n < MAX;
\$n = \$new_n;
}
}
\$cache[\$input] = \$result if \$input < MAX;
return \$result;
}

my @long_seqs;
for my \$num (1..1000000) {
my \$seq_length = collatz_seq \$num;
push @long_seqs, [ \$num, \$seq_length ] if \$seq_length > 400;
}

@long_seqs = sort { \$b-> <=> \$a->} @long_seqs;
say  "\$_->: \$_->" for @long_seqs[0..19];
``````

With this new implementation, we still obtain the same result, but the program is now more than 55 times faster than my original one (and almost 20 times faster than the solution using a hash for the cache):

``````\$ time perl collatz3.pl
837799: 525
626331: 509
[Lines omitted for brevity]
922524: 445
922525: 445

real    0m1,755s
user    0m1,687s
sys     0m0,061s
``````

I strongly suspected that using an array would be faster, but I frankly did not expect such a huge gain until I tested it.

So, it is true that throwing more CPU cores at the problem makes the solution significantly faster (although to a limited extent with my computer that has only 4 cores). But using a better algorithm can often be a better solution. The best, of course, would be to do both, and this can be done, as we will see below.

## Further Optimizations

After I presented those results on the Perl Monks forum, another Perl monk, Mario Roy, the person who wrote the MCE::Map used by Nick and a number of other very useful Perl modules for parallel processing, suggested three further optimizations:

1. Replaced division by 2.

``````\$n >> 1;
``````

2. Removed one level of branching.

``````while (\$n != 1) {
\$result += \$cache[\$n], last
if defined \$cache[\$n];

my \$new_n = \$n % 2 ? 3 * \$n + 1 : \$n >> 1;
\$result++;
\$cache[\$n] = \$cache[\$new_n] + 1
if defined \$cache[\$new_n] and \$n < \$max;

\$n = \$new_n;
}
``````

3. Lastly, reduced the number of loop iterations.

``````while (\$n != 1) {
\$result += \$cache[\$n], last
if defined \$cache[\$n];

\$n % 2 ? ( \$result += 2, \$new_n = (3 * \$n + 1) >> 1 )
: ( \$result += 1, \$new_n = \$n >> 1 );

\$cache[\$n] = \$cache[\$new_n] + (\$n % 2 ? 2 : 1)
if defined \$cache[\$new_n] and \$n < \$max;

\$n = \$new_n;
}
``````

On his computer and with a larger range (up to 1e7 instead of 1e6), he obtained the following timings:

``````collatz3_a.pl 1e7  13.130s  (a) original
collatz3_b.pl 1e7  12.394s  (b) a + replaced division with >> 1
collatz3_c.pl 1e7  12.261s  (c) b + removed 1 level of branching
collatz3_d.pl 1e7   9.170s  (d) c + reduced loop iterations
``````

So, that's about 30% faster. Interesting, I would not have thought such micro-optimizations would provide such a significant gain. I’ll have to remember that. But that was just the first step of Mario’s approach, the really good things come now.

## Combining Caching and Parallel Execution

In another Perl Monks post, Mario Roy showed how to combine caching with parallel execution using the File::Map module that implements mapped memory, which can be shared between threads or forked processes. With a 32-core CPU, Mario was able to reduce the execution duration to less than 0.7 second! Wow! Please follow the link for the details.

So, yes, it is possible to combine caching with parallel execution.

## New Caching Strategy in Raku

As mentioned earlier, when the idea came to me to store the sequence lengths rather than the sequences themselves, I originally tried to implement it in Raku. I'll cover that in detail in my review of the Raku solutions, but let me provide here a summary.

Remember that the original solution took about 9 minutes with Raku.

This is the first implementation (using sequence length in a hash):

``````use v6;

my %cache = 2 => 2;

sub collatz-seq (UInt \$in) {
my \$length = 0;
my \$n = \$in;
while \$n != 1 {
if %cache{\$n} :exists {
\$length += %cache{\$n};
last;
} else {
my \$new_n = \$n % 2 ?? 3 * \$n + 1 !! \$n / 2;
\$length++;
%cache{\$n} = %cache{\$new_n} + 1
if defined (%cache{\$new_n}) and \$new_n <= 2000000;
\$n = \$new_n.Int;
}
}
%cache{\$in} = \$length if \$in <= 2000000;
return \$length;
}

my @long-seqs;
for 1..1000000 -> \$num {
my \$seq-length = collatz-seq \$num;
push @long-seqs, [ \$num, \$seq-length] if \$seq-length > 400;
}
@long-seqs = sort { \$^b <=> \$^a}, @long-seqs;
say  "\$_: \$_" for @long-seqs[0..19];
``````

This new program displays the same output as the previous one, but runs about 6 times faster:

``````\$ time perl6 collatz2.p6
837799: 525
626331: 509
939497: 507
[Lines omitted for brevity]
906175: 445
922524: 445
922525: 445

real    1m31,660s
user    0m0,000s
sys     0m0,062s
``````

This is the code for the implementation using an array instead of a hash for the cache:

``````use v6;

my @cache = 0, 1, 2;

sub collatz-seq (UInt \$in) {
my \$length = 0;
my \$n = \$in;
while \$n != 1 {
if defined @cache[\$n] {
\$length += @cache[\$n];
last;
} else {
my \$new_n = \$n % 2 ?? 3 * \$n + 1 !! \$n / 2;
\$length++;
@cache[\$n] = @cache[\$new_n] + 1
if defined @cache[\$new_n] and \$new_n <= 2000000;
\$n = \$new_n.Int;
}
}
@cache[\$in] = \$length;
return \$length;
}

my @long-seqs;
for 2..1000000 -> \$num {
my \$seq-length = collatz-seq \$num;
push @long-seqs, [ \$num, \$seq-length] if \$seq-length > 200;
}
@long-seqs = sort { \$^b <=> \$^a}, @long-seqs;
say  "\$_: \$_" for @long-seqs[0..19];
``````

And the new program runs about twice faster than with a hash (and 12 times faster than the original code):

``````\$ time ./perl6 collatz3.p6
837799: 525
626331: 509
[Lines omitted for brevity]
906175: 445
922524: 445
922525: 445

real    0m45,735s
user    0m0,015s
sys     0m0,046s
``````

Interestingly, the Perl program runs 3 times faster after the first optimization, and 55 times faster after the second optimization, where as the Raku program runs 6 times faster after the first optimization and 12 times faster after the second one. It is not necessarily surprising that some optimizations work better with one language and others with another language, but I somehow did not expect such a large discrepancy.

Raku has a very good support for parallel execution and concurrent programming. I'm pretty sure it should be possible to make good use of this capability, but I haven't really looked at that topic for at least four years, so I don't think I could come up with a good parallel solution without spending quite a bit of effort and time. Also, with my poor computer with only four cores, I would certainly not be able to get results anywhere close to Mario Roy with his 32-core platform.

## Wrapping-up

Perl Weekly Challenge 56 is up for your perusal!

]]>
Posted Perl Weekly Challenge 55: Binary Numbers and Wave Arrays to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9730 2020-04-12T20:16:03Z 2020-04-12T20:24:56Z These are some answers to the Week 55 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Task # 1: Flipping Binary Numbers You are given a binary number B, consisting of N binary digits 0 or 1: s0,... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 55 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

## Task # 1: Flipping Binary Numbers

You are given a binary number B, consisting of N binary digits 0 or 1: s0, s1, …, s(N-1).

Choose two indices L and R such that 0 ≤ L ≤ R < N and flip the digits s(L), s(L+1), …, s(R). By flipping, we mean change 0 to 1 and vice-versa.

For example, given the binary number 010, the possible flip pair results are listed below:

``````L=0, R=0 the result binary: 110
L=0, R=1 the result binary: 100
L=0, R=2 the result binary: 101
L=1, R=1 the result binary: 000
L=1, R=2 the result binary: 001
L=2, R=2 the result binary: 011
``````

Write a script to find the indices (L,R) that results in a binary number with maximum number of 1s. If you find more than one maximal pair L,R then print all of them.

Continuing our example, note that we had three pairs (L=0, R=0), (L=0, R=2), and (L=2, R=2) that resulted in a binary number with two 1s, which was the maximum. So we would print all three pairs.

There may be an analytical solution. For example, we may look for the longest sequence of 0s. But that’s not guaranteed to produce the maximum number of 1s. For example, the longest sequence of 0 may be 00000. But if we have somewhere else the sequence, 000010000, then is would be better to flip that sequence. It seems quite difficult to automatize the analysis. Especially, it seems difficult to make sure that we find all maximum index pairs. So we’ll use brute force: try all possibilities and pick up the best one(s).

### Flipping Binary Numbers in Perl

The brute force algorithm is quite straight forward. We use nested loops to iterate over every possible `\$left-\$right` pair and store the index pair and the resulting string into an array (with the index being the number of 1s). Then, we just pick up the items with the highest array subscript:

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

sub flip {
my \$bin_nr = shift;
die "Please supply a binary string."
unless \$bin_nr =~ /^*\$/;
my @chars = split //, \$bin_nr;
my @result;
for my \$left (0..\$#chars) {
for my \$right (\$left..\$#chars) {
my @tmp_chars = @chars;
for my \$i (\$left..\$right) {
\$tmp_chars[\$i] = \$chars[\$i] ? 0 : 1;
}
my \$count = scalar grep \$_ == 1, @tmp_chars;
\$result[\$count] .= "\$left-\$right: @tmp_chars\n";
}
}
return \$result[-1];
}
say flip shift // "01011" ;
``````

Running the program a couple of times produces the following output:

``````\$ perl binstr.pl 01001110000011
7-11: 0 1 0 0 1 1 1 1 1 1 1 1 1 1

\$ perl binstr.pl 010011100010011
7-12: 0 1 0 0 1 1 1 1 1 1 0 1 1 1 1
``````

### Flipping Binary Numbers in Raku

We just use the same brute-force algorithm in Raku:

``````use v6;

sub flip (\$bin-nr) {
my @chars = \$bin-nr.comb;
my @result;
for 0..@chars.end -> \$left {
for \$left..@chars.end -> \$right {
my @tmp-chars = @chars;
for \$left..\$right -> \$i {
@tmp-chars[\$i] = @chars[\$i] == 1  ?? 0 !! 1;
}
my \$count = [+] @tmp-chars;
@result[\$count] ~= "\$left-\$right: @tmp-chars[]\n";
}
}
return @result[*-1];
}
sub MAIN (Str \$in where \$in ~~ /^ <>+ \$/ = "01011") {
say flip \$in;
}
``````

Running this program with the same input binary strings displays the same output as before:

``````\$ perl6 binstr.p6 01001110000011
7-11: 0 1 0 0 1 1 1 1 1 1 1 1 1 1

\$ perl6 binstr.p6 010011100010011
7-12: 0 1 0 0 1 1 1 1 1 1 0 1 1 1 1
``````

Any array N of non-unique, unsorted integers can be arranged into a wave-like array such that `n1 ≥ n2 ≤ n3 ≥ n4 ≤ n5` and so on.

For example, given the array `[1, 2, 3, 4]`, possible wave arrays include `[2, 1, 4, 3]` or `[4, 1, 3, 2]`, since `2 ≥ 1 ≤ 4 ≥ 3` and `4 ≥ 1 ≤ 3 ≥ 2`. This is not a complete list.

Write a script to print all possible wave arrays for an integer array N of arbitrary length.

Notes:

When considering N of any length, note that the first element is always greater than or equal to the second, and then the ≤, ≥, ≤, … sequence alternates until the end of the array.

Since we want to find all possible wave arrays, we’ll need to explore all possibilities, and we need again brute force. The pure brute force algorithm would be to generate all permutations and retain those matching the wave criteria. We can use an improved brute-force solution that builds only the permutations whose beginning matches the wave criteria, thereby reducing significantly the number of possibilities to explore.

### Wave Arrays in Perl

To build the permutations, we use the `add_1_item` recursive subroutine that is called with three arguments: a mode, the input values and the output values. The mode is a flip-flop Boolean variable that tells us if the next item should be greater than the previous one (or equal), or if it should be less. Each time we add an item, we flip `\$mode` from 1 to 0 or vice-versa. The `add_1_item` subroutine picks each of the input values, adds it to the output if the wave criteria is met, and it calls itself recursively. Note that our first implementation simply printed each result when found. But that did not work properly when there was some duplicate values in the input, as it would print several times the same wave sequences (which is probably undesired). Therefore, we’ve put the outcome in the `%results` hash to remove duplicate wave sequences before printing them.

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

my %results;

my (\$mode, \$input, \$output) = @_;
unless (@\$input) {
\$results{"@\$output"} = 1;
return;
}
my \$last = \$output->[-1];
for my \$i (0..\$#\$input) {
if (\$mode == 0) {
next if \$input->[\$i] > \$last;
[@\$output, \$input->[\$i]]);

} else {
next if \$input->[\$i] < \$last;
[@\$output, \$input->[\$i]]);
}
}
}
my @in = (1, 2, 3, 4);
@in = @ARGV if defined \$ARGV;
for my \$i (0..\$#in) {
}
say for sort keys %results;
``````

We display here two sample runs:

``````\$ perl wave.pl 1 2 3 4
2 1 4 3
3 1 4 2
3 2 4 1
4 1 3 2
4 2 3 1

\$ perl wave.pl  3 4 5 2 1
2 1 4 3 5
2 1 5 3 4
3 1 4 2 5
3 1 5 2 4
3 2 4 1 5
3 2 5 1 4
4 1 3 2 5
4 1 5 2 3
4 2 3 1 5
4 2 5 1 3
4 3 5 1 2
5 1 3 2 4
5 1 4 2 3
5 2 3 1 4
5 2 4 1 3
5 3 4 1 2
``````

### Wave Arrays in Raku

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

``````use v6;

my SetHash \$results;

sub add_1_item (\$mode, @input, @output) {
unless @input.elems {
\$results{"@output[]"}++;
return;
}

my \$last = @output[*-1];
for 0..@input.end -> \$i {
if (\$mode == 0) {
next if @input[\$i] > \$last;
(@output, @input[\$i]).flat);

} else {
next if @input[\$i] < \$last;
(@output, @input[\$i]).flat);
}
}
}

my @in = 1, 2, 3, 4;
@in = @*ARGS if @*ARGS.elems > 0;
for 0..@in.end -> \$i {
my @out = @in[\$i],;
}
.say for \$results.keys.sort;
``````

This is the output for two sample runs:

``````\$ perl6 wave.p6  3 4 2 1
2 1 4 3
3 1 4 2
3 2 4 1
4 1 3 2
4 2 3 1

\$ perl6 wave.p6   3 4 5 2 1
2 1 4 3 5
2 1 5 3 4
3 1 4 2 5
3 1 5 2 4
3 2 4 1 5
3 2 5 1 4
4 1 3 2 5
4 1 5 2 3
4 2 3 1 5
4 2 5 1 3
4 3 5 1 2
5 1 3 2 4
5 1 4 2 3
5 2 3 1 4
5 2 4 1 3
5 3 4 1 2
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, April 19, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Commented on CY's take on PWC#054 in Moments on Perl or other Programming Issues tag:blogs.perl.org,2020:/users/c_y_fung//3481.9722#1810210 2020-04-04T17:47:09Z laurent_r Hi,

using a cache, I was able to run the extra credit in 1 min 7 sec. Take a look at my blog post to see the details.

Cheers, Laurent.

]]>
Posted Perl Weekly Challenge 54: k-th Permutation Sequence and the Collatz Conjecture to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9723 2020-04-04T17:33:29Z 2020-04-16T07:55:30Z These are some answers to the Week 54 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a couple of days (April 5, 2020). This blog post offers some solutions... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 54 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (April 5, 2020). 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: kth Permutation Sequence

Write a script to accept two integers n (>=1) and k (>=1). It should print the kth permutation of n integers. For more information, please follow the wiki page.

For example, n=3 and k=4, the possible permutation sequences are listed below:

``````123
132
213
231
312
321
``````

The script should print the 4th permutation sequence 231.

It took me some questioning to figure out the requirement. My understanding is that the program should first generate a list of integers between 1 and `n` and then look for permutations in ascending order, and finally display the kth permutation.

### kth Permutation in Perl

We write a recursive `permute` subroutine that generates permutations in the desired ascending order. Then we can just stop recursion once it has been called k times (thus avoiding to calculate all permutations when no needed).

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

my (\$n, \$k) = @ARGV;
my \$err_msg = "Please supply two integer parameters freater than 0\n";
die \$err_msg unless \$n and \$k;
die \$err_msg if \$n !~ /^\d{1,2}\$/ or \$k !~ /^\d+\$/;
my @start = 1..\$n;
permute("", @start);

sub permute {
my (\$str, @vals) = @_;
if (scalar @vals == 0) {
say \$str and exit unless --\$k;
return;
}
permute("\$str " . \$vals[\$_], @vals[0..\$_-1], @vals[\$_+1..\$#vals]) for 0..\$#vals;
}
``````

With the parameters n=3 and k=4, the program displays the following output:

``````\$ perl permute.pl 3 4
2 3 1
``````

Note that I have decided to insert a space between the individual digits, as it makes it easier to visualize the individual values of the output when `n` is greater than 9 (and thus has more than one digit). For example, for the 350,000th permutation of the `1-35` range:

``````\$ time perl permute.pl 35 350000
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 35 32 30 27 33 29 28 34 31

real    0m0,928s
user    0m0,890s
sys     0m0,030s
``````

This is fairly fast: we’ve just computed the first 350,000 permutations of 35 items in less than one second. In case you need more speed with larger input values, you might try modules like Algorithm::Permute or ntheory. They are likely to be significantly faster. But I did not feel it was needed here.

### kth Permutation in Raku

Raku has a built-in method, permutations that returns all possible permutations of a list as a `Seq` of lists. In addition, if the input list is in ascending order, the output permutation will also be in ascending order.

For example, with an input list of 1, 2, 3, the fourth permutation is:

``````perl6 -e 'say (1..3).permutations;'
(2 3 1)
``````

In addition, although the documentation doesn’t state it explicitly, it appears that the `permutations` method acts lazily, i.e. it only generates the permutations needed for computing the desired final result. For example, the following one-liner computes the result (the 4th permutation) almost immediately (in less than one hundredth of a second):

``````\$ perl6 -e 'say (1..20).permutations; say now - INIT now;'
(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 19 20 18)
0.0089752
``````

which would obviously not be the case if it had to compute every permutation of a 20-item list before finding the fourth one (for a 20-item list, the number of permutations is 20!, i.e. 2432902008176640000, or about 2.4 billions of billions).

So we can write a one-liner script that accepts two integers i and k and prints the kth permutation of n integers as per the requirement:

``````\$ perl6 -e 'say (1..@*ARGS).permutations[@*ARGS-1];' 3 4
(2 3 1)
``````

If you prefer a stand-alone script, we can write this:

``````use v6;

sub MAIN (Int \$n where * > 0, Int \$k where * > 0) {
(1..\$n).permutations[\$k - 1].say;
}
``````

This outputs the same result as before:

``````\$ ./perl6 permute.p6 3 4
(2 3 1)
``````

## Task 2: the Collatz Conjecture

It is thought that the following sequence will always reach 1:

``````\$n = \$n / 2 when \$n is even
\$n = 3*\$n + 1 when \$n is odd
``````

For example, if we start at 23, we get the following sequence:

``````23 → 70 → 35 → 106 → 53 → 160 → 80 → 40 → 20 → 10 → 5 → 16 → 8 → 4 → 2 → 1
``````

Write a function that finds the Collatz sequence for any positive integer. Notice how the sequence itself may go far above the original starting number.

Extra Credit: have your script calculate the sequence length for all starting numbers up to 1000000 (1e6), and output the starting number and sequence length for the longest 20 sequences.

The Collatz conjecture concerns a sequence defined as follows: start with any positive integer n. Then each term is obtained from the previous term as follows: if the previous term is even, the next term is one half of the previous term. If the previous term is odd, the next term is 3 times the previous term plus 1. The conjecture is that, no matter what value of n, the sequence will always reach 1. This conjecture is named after Lothar Collatz who introduced it in 1937. It is sometimes known as the Syracuse problem (and some other names). It is usually believed to be true (and no counter-example has been found), but, despite a lot of efforts, nobody has been able to prove it, and this is deemed to be a very difficult problem.

### The Collatz Conjecture in Perl

For the purpose of the basic task, this is fairly straight forward. Here, we write a `next_collatz` subroutine that, given an integer computes the next number in the Collatz sequence. And we call that subroutine in a loop until we reach 1:

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;

sub next_collatz {
my \$num = shift;
\$num % 2 ? 3 * \$num + 1 : \$num / 2;
}

my \$n = shift;
my @result = (\$n);
while (1) {
\$n = next_collatz \$n;
push @result, \$n;
last if \$n == 1;
}
say "@result";
``````

These are some example outputs:

``````\$ perl collatz.pl 23
23 70 35 106 53 160 80 40 20 10 5 16 8 4 2 1

\$ perl collatz.pl 24
24 12 6 3 10 5 16 8 4 2 1

\$ perl collatz.pl 25
25 76 38 19 58 29 88 44 22 11 34 17 52 26 13 40 20 10 5 16 8 4 2 1

\$ perl collatz.pl 26
26 13 40 20 10 5 16 8 4 2 1

\$ perl collatz.pl 27
27 82 41 124 62 31 94 47 142 71 214 107 322 161 484 242
121 364 182 91 274 137 412 206 103 310 155 466 233 700
350 175 526 263 790 395 1186 593 1780 890 445 1336 668
334 167 502 251 754 377 1132 566 283 850 425 1276 638
319 958 479 1438 719 2158 1079 3238 1619 4858 2429
7288 3644 1822 911 2734 1367 4102 2051 6154 3077 9232
4616 2308 1154 577 1732 866 433 1300 650 325 976 488
244 122 61 184 92 46 23 70 35 106 53 160 80 40 20
10 5 16 8 4 2 1
``````

(The latest example just above was slightly reformatted for the purpose of this blog post.)

#### Extra Credit: Collatz Sequence for all Numbers up to 1,000,000

In theory, it wouldn’t be very complicated to encapsulate the above program into an outer loop to compute the Collatz sequence for any range of numbers. Except that going all the way up to 1,000,000 is probably going to take ages. One of the reason is that we’re going to recompute Collatz sequence successors for the same number again and again many times. If you look at the above examples, the sequences all end up with the following sequence: `16 8 4 2 1`. So, it might be useful, when we reach 16 for the first time, to compute the end of the sequence only once, and to store it in a hash of arrays (or possibly an array of arrays), in order to retrieve it straight from the hash when we reach 16 once more. Similarly, the sequence for 25 end with `40 20 10 5 16 8 4 2 1`. If we store this sequence somewhere, then we don’t have to compute it once more when we reach 40 while computing the Collatz sequence for 27, and, or course, also when we compute the Collatz sequence for 40, 80, 160, as well as 13, 26, 52, etc. Such a strategy is called caching or memoizing: storing in memory the result of a computation that we’re likely to have to compute again. It is sometimes described as “trading memory for time.”

There is a core module, called Memoize, written my Mark Jason Dominus, that is very easy to use can do the caching automatically for you. The problem though is that it wouldn’t be very practical to use it here, because we don’t want to cache just the next item in the sequence, but all the rest of the sequence down to 1. So it might be better to implement a cache ourselves, manually (that’s not very difficult, as we shall see).

There is another problem though, which is much more delicate. Since the requirement is to compute the Collatz sequence for all integers up to 1,000,000, the cache will grow very large (several millions of sequences) and we might run out of memory. In the first version of the program below, I tried to store all sequences up to one million, and the program turned out to be painfully slow. Looking at the system statistics, I found that, after a while, available memory became exhausted and the system would swap memory on the disk, leading to very slow execution. I made a couple of tests, and found that I could store the sequences for all numbers up to about 300,000 without exceeding the available memory of my computer (that number might be different on your computer), thus preventing the process from swapping and getting more or less the best possible performance, hence the `MAX` constant set to 300,000. Since I knew from earlier tests that the 20 longest sequences would all have more than 400 items, I also hard-coded a lower limit of 400 items for the sequences whose length had to be recorded. Another possibly better solution might have been to maintain a sliding array of the top 20 sequences, but I feared that maintaining this array many times over the execution of the program would end up impairing performance.

``````#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;
use constant MAX => 300000;

my %cache;

sub collatz_seq {
my \$input = shift;
my \$n = \$input;
my @result;
while (\$n != 1) {
if (exists \$cache{\$n}) {
push @result, @{\$cache{\$n}};
last;
} else {
my \$new_n = \$n % 2 ? 3 * \$n + 1 : \$n / 2;
push @result, \$new_n;
\$cache{\$n} = [\$new_n, @{\$cache{\$new_n}}]
if defined (\$cache{\$new_n}) and \$n < MAX;
\$n = \$new_n;
}
}
\$cache{\$input} = [@result] if \$n < MAX;
return @result;
}

my @long_seqs;
for my \$num (1..1000000) {
my @seq = (\$num, collatz_seq \$num);
push @long_seqs, [ \$num, scalar @seq] if scalar @seq > 400;
}

@long_seqs = sort { \$b-> <=> \$a->} @long_seqs;
say  "\$_->: \$_->" for @long_seqs[0..19];
# say "@{\$cache{\$long_seqs}}";
``````

With these optimizations, I was able to reduce execution time to 1 min 7 sec.:

``````\$ time perl collatz.pl
837799: 525
626331: 509
939497: 507
704623: 504
910107: 476
927003: 476
511935: 470
767903: 468
796095: 468
970599: 458
546681: 452
818943: 450
820022: 450
820023: 450
410011: 449
615017: 447
886953: 445
906175: 445
922524: 445
922525: 445

real    1m7,469s
user    1m6,015s
sys     0m1,390s
``````

Uncomment the last statement if you want to see the longest sequence (with 525 items).

Update: A couple of days after I posted this, I figured out a much better caching strategy removing the difficulties explained above and giving much better performance. It is explained in this blog post.

### The Collatz Conjecture in Raku

For the purpose of the basic task, this is fairly straight forward. Just as for the Perl solution, we write a `collatz-seq` subroutine that, given an integer computes the next number in the Collatz sequence. And we call that subroutine in a loop until we reach 1:

``````use v6;

sub collatz-seq (UInt \$in) {
my \$n = \$in;
my @result = gather {
while \$n != 1 {
my \$new-n = \$n % 2 ?? 3 * \$n + 1 !! \$n / 2;
take \$new-n;
\$n = \$new-n;
}
}
return \$in, |@result;
}
sub MAIN (UInt \$in) {
my @seq = collatz-seq \$in;
print "Collatz sequence for \$in: ", @seq, "\n";
}
``````

Here are a few sample runs:

``````\$ perl6  collatz_1.p6 8
Collatz sequence for 8: 8 4 2 1

\$ perl6  collatz_1.p6 23
Collatz sequence for 23: 23 70 35 106 53 160 80 40 20 10 5 16 8 4 2 1

\$ perl6  collatz_1.p6 25
Collatz sequence for 25: 25 76 38 19 58 29 88 44 22 11 34 17 52 26 13 40 20 10 5 16 8 4 2 1
``````

Note that I used the `print` function rather than the `say` function here, because `say` would abbreviate long sequences (for example, the sequence for 27 would end with an ellipsis: `...`).

#### Extra Credit: Collatz Sequence for all Numbers up to 1,000,000

Please refer to the Extra Credit subsection in the Perl section above for a detailed discussion of the caching strategy. The program below is essentially a port to Raku of the Perl program above:

``````use v6;

my %cache = 2 => [2, 1];

sub collatz_seq (UInt \$in) {
my @result;
my \$n = \$in;
while \$n != 1 {
if %cache{\$n} :exists {
push @result, |@(%cache{\$n});
last;
} else {
my \$new_n = \$n % 2 ?? 3 * \$n + 1 !! \$n / 2;
push @result, \$new_n;
%cache{\$n} = [\$new_n, |%cache{\$new_n}]
if defined (%cache{\$new_n}) and \$new_n <= 200000;
\$n = \$new_n.Int;
}
}
%cache{\$in} = @result if \$in <= 200000;
return @result;
}

my @long_seqs;
for 1..1000000 -> \$num {
my \$seq = collatz_seq \$num;
push @long_seqs, [ \$num, \$seq.elems] if \$seq.elems > 400;
}
@long_seqs = sort { \$^b <=> \$^a}, @long_seqs;
say  "\$_: \$_" for @long_seqs[0..19];
``````

This program displays more or less the same output as the previous Perl program:

``````\$ perl6 collatz.p6
837799: 525
626331: 509
939497: 507
704623: 504
910107: 476
927003: 476
511935: 470
767903: 468
796095: 468
970599: 458
546681: 452
818943: 450
820022: 450
820023: 450
410011: 449
615017: 447
886953: 445
906175: 445
922524: 445
922525: 445
``````

This program ran in more than 9 minutes, so Raku is still significantly slower than Perl (at least for such CPU intensive computations).

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, April 12, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 53: Rotate Matrix and Vowel Strings to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9716 2020-03-28T12:14:51Z 2020-03-28T12:19:48Z These are some answers to the Week 53 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a couple of days (March 29, 2020). This blog post offers some solutions... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 53 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (March 29, 2020). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Write a script to rotate the following matrix by given 90/180/270 degrees clockwise.

``````[ 1, 2, 3 ]
[ 4, 5, 6 ]
[ 7, 8, 9 ]
``````

For example, if you rotate by 90 degrees then expected result should be like below:

``````[ 7, 4, 1 ]
[ 8, 5, 2 ]
[ 9, 6, 3 ]
``````

This is fairly straight forward. We will write a subroutine to rotate a matrix by 90°, and then we just need to call that subroutine twice to rotate by 180°, and once more to rotate by 270°. We’ll also write a subroutine to display the matrices in a relatively compact graphical form.

### Rotate Matrix in Perl

Nothing complicated, we just need to have a clear mind representation of the matrix structure and be a bit cautious when managing array indices. Note that, trying various syntaxes, I re-discovered that you can use `\$#{\$input}` or even, simpler, `\$#\$input` for getting the last index of the `\$input` arrayref, and even `\$#{@\$input[\$row]}` to get the last index of the `row` subarray in an array of arrays. Granted, this last example looks a bit like line noise, but it works fine.

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

sub display_matrix {
my \$matrix = shift;
for my \$row (@\$matrix) {
say "[", join(", ", @\$row), "]";
}
}

sub rotate_90 {
my \$input = shift;
my @output;
for my \$row (0 .. \$#\$input) {
for my \$col (0 .. \$#{@\$input[\$row]}) {
\$output[\$col][\$#{@\$input[\$row]} - \$row] = \$input->[\$row][\$col];
}
}
return \@output;
}
sub rotate_180 {rotate_90 rotate_90 @_}
sub rotate_270 {rotate_90 rotate_180 @_}

my \$matrix_ref = [
[1, 2 ,3],
[4, 5, 6],
[7, 8, 9],
];
say "Initial matrix:";
display_matrix(\$matrix_ref);
say "\nMatrix rotated 90°";
display_matrix rotate_90 \$matrix_ref;
say "\nMatrix rotated 180°";
display_matrix rotate_180 \$matrix_ref;
say "\nMatrix rotated 270°";
display_matrix rotate_270 \$matrix_ref;
say "\nRotate 360 (sanity check, should be the initial matrix)";
display_matrix rotate_270 rotate_90 \$matrix_ref;
``````

Running this program leads to the following output:

``````\$ perl rotate_matrix.pl
Initial matrix:
[1, 2, 3]
[4, 5, 6]
[7, 8, 9]

Matrix rotated 90°
[7, 4, 1]
[8, 5, 2]
[9, 6, 3]

Matrix rotated 180°
[9, 8, 7]
[6, 5, 4]
[3, 2, 1]

Matrix rotated 270°
[3, 6, 9]
[2, 5, 8]
[1, 4, 7]

Rotate 360 (sanity check, should be the initial matrix)
[1, 2, 3]
[4, 5, 6]
[7, 8, 9]
``````

There is probably a simpler way to do that using slices, but while this seems quite easy if you know in advance that you’re gonna get a 3 x 3 matrix, it appeared to me that this is not so simple for square matrices of unknown dimensions and even more so for non-square matrices.

### Rotate Matrix in Raku

I’m pretty sure that there must be some Raku built-in operators or routines that could make the thing easier, but nothing obvious came to my mind. So I decided to be lazy and simply port the Perl solution:

``````use v6;

sub display_matrix (@matrix) {
for @matrix -> \$row {
say "[", join(", ", \$row), "]";
}
}
sub rotate_90 (@input) {
my @output;
for 0 .. @input.end -> \$row {
for 0 .. @input[\$row].end -> \$col {
@output[\$col][@input[\$row].end - \$row] = @input[\$row][\$col];
}
}
return @output;
}
sub rotate_180 (@matrix) {rotate_90 rotate_90 @matrix}
sub rotate_270 (@matrix) {rotate_90 rotate_180 @matrix}

my \$matrix = (
[1, 2 ,3],
[4, 5, 6],
[7, 8, 9],
);
say "Initial matrix:";
display_matrix(\$matrix);
say "\nMatrix rotated 90°";
display_matrix rotate_90 \$matrix;
say "\nMatrix rotated 180°";
display_matrix rotate_180 \$matrix;
say "\nMatrix rotated 270°";
display_matrix rotate_270 \$matrix;
say "\nRotate 360 (sanity check, should be the initial matrix)";
display_matrix rotate_270 rotate_90 \$matrix;
``````

This program displays almost exactly the same as the equivalent Perl program:

``````\$ perl6 rotate_matrix.p6
Initial matrix:
[1 2 3]
[4 5 6]
[7 8 9]

Matrix rotated 90°
[7 4 1]
[8 5 2]
[9 6 3]

Matrix rotated 180°
[9 8 7]
[6 5 4]
[3 2 1]

Matrix rotated 270°
[3 6 9]
[2 5 8]
[1 4 7]

Rotate 360 (sanity check, should be the initial matrix)
[1 2 3]
[4 5 6]
[7 8 9]
``````

Write a script to accept an integer 1 <= N <= 5 that would print all possible strings of size N formed by using only vowels (a, e, i, o, u).

The string should follow the following rules:

1. ‘a’ can only be followed by ‘e’ and ‘i’.
2. ‘e’ can only be followed by ‘i’.
3. ‘i’ can only be followed by ‘a’, ‘e’, ‘o’, and ‘u’.
4. ‘o’ can only be followed by ‘a’ and ‘u’.
5. ‘u’ can only be followed by ‘o’ and ‘e’.

For example, if the given integer N = 2 then script should print the following strings:

``````ae
ai
ei
ia
io
iu
ie
oa
ou
uo
ue
``````

Although this is not explicitly stated, we will take it for granted that some letters may be repeated in the strings, provided they follow the rules. For example, since ‘u’ may be followed by ‘o’, and ‘o’ may be followed by ‘u’, strings such as “uou” or “ouo” are valid.

### Vowel Strings in Perl

One good way to implement the rules (such as ‘a’ can only be followed by ‘e’ and ‘i’) is to build a hash of arrays (`%successors`) where the keys are the vowels, and the values arrays of vowels that can follow the vowel given in the key (so, for example: `a => ['e', 'i']`). For any letter that we insert into a string, the hash will give us the list of letters that we can insert next. To cover the tree of possibilities, the easiest is to built a recursive subroutine (`make_str`) that will print all the permitted combinations.

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

my %successors = (
a => ['e', 'i'],
e => ['i'],
i => [qw /a e o u/],
o => ['a', 'u'],
u => ['e', 'o']
);
my @vowels = sort keys %successors;
my \$error_msg = "Please pass a parameter between 1 and 5.";
my \$str_size = shift or die \$error_msg;
die \$error_msg unless \$str_size =~ /^[1-5]\$/;

for my \$start (@vowels) {
make_str(\$str_size -1, \$start, \$start);
}

sub make_str {
my (\$left, \$last, \$string) = @_;
say \$string and return unless \$left; # Stop the recursion
for my \$next (@{\$successors{\$last}}) {
my \$new_str = \$string . \$next;
make_str(\$left -1, \$next, \$new_str);
}
}
``````

Here are some sample runs of this program:

``````\$ perl vowel_strings.pl
Please pass a parameter between 1 and 5. at vowel_strings.pl line 14.

\$ perl vowel_strings.pl 2
ae
ai
ei
ia
ie
io
iu
oa
ou
ue
uo

\$ perl vowel_strings.pl 3
aei
aia
aie
aio
aiu
eia
eie
eio
eiu
iae
iai
iei
ioa
iou
iue
iuo
oae
oai
oue
ouo
uei
uoa
uou
``````

Rather than building the allowed strings using the hash as above, we could build a list of all vowel combinations (e.g. using the `glob` built-in function) having the right size, and then filter out those not matching the succession rules. We won’t present here an implementation of this strategy (the code can be shorter, but this tends to be somewhat inefficient when the string size exceeds 2 or 3), but we will show one such implementation below in Raku.

### Vowel Strings in Raku

#### Porting to Raku the Perl Program

To start with, we will use hash of arrays (`%successors`) where the keys are the vowels, and the values arrays of vowels that can follow the vowel given in the key, as in our Perl implementation. For any letter that we insert into a string, the hash will give us the list of letters that we can insert next. And we will also use a recursive subroutine (`make_str`) to generate the full tree of permitted combinations.

``````use v6;

my %successors = (
'a' => ['e', 'i'],
'e' => ['i'],
'i' => [qw /a e o u/],
'o' => ['a', 'u'],
'u' => ['e', 'o']
);
my @vowels = sort %successors.keys;
sub MAIN (UInt \$str_size where 1 <= * <= 5) {
my \$error_msg = "Please pass a parameter between 1 and 5.";
die \$error_msg unless \$str_size ~~ /^<[1..5]>\$/;
for @vowels -> \$start {
make_str(\$str_size -1, \$start, \$start);
}
}
sub make_str (UInt \$left, Str \$last, Str \$string) {
say \$string and return unless \$left;
for |%successors{\$last} -> \$next {
my \$new_str = \$string ~ \$next;
make_str(\$left -1, \$next, \$new_str);
}
}
``````

These are two sample runs:

``````\$ perl6 vowel_strings.p6
Usage:
vowel_strings.p6 <str_size>

\$ perl6 vowel_strings.p6 3
aei
aia
aie
aio
aiu
eia
eie
eio
eiu
iae
iai
iei
ioa
iou
iue
iuo
oae
oai
ouo
ouo
uei
uoa
uou
``````

#### Generating all Vowels Combinations and Keeping the Valid Strings

Given that Raku has the `combinations` and `permutations` built-in methods, it would seem interesting to use them to generate all the candidate strings and then to filter out those not matching the rules.

But this turned out to be a bit more difficult than expected. First, if we want to to get strings such as “aia,” neither of the built-in methods mentioned before can do that. We need to “multiply” the original list of vowels and that leads to a lot of permutations and/or combinations, and also to duplicate strings that will need to be removed. In the program below, we first generate all combinations of `\$size` letters, then all permutations of these combinations, and use some regexes to remove strings with unwanted letter combinations. And we use a `SetHash` (`\$result`) to remove duplicates:

``````sub MAIN (UInt \$size where 1 <= * <= 5) {
my @vowels = | qw/a e i o u / xx (\$size - 1);
my SetHash \$result;
for @vowels.combinations(\$size) -> \$seq {
for | \$seq.permutations>>.join('') {
next if /(\w) \$0/;
next if  /ao|au|ea|eo|eu|oe|oi|ua|ui/;
\$result{\$_}++;
}
}
.say for \$result.keys.sort;
}
``````

This program produces the same results as before, but is quite slow (about 3.5 second for strings of 4 letters, versus 0.35 second for the original Raku program). Obviously, this program does a large amount of unnecessary work. We can reduce this by removing part of the duplicates earlier on, with two calls to the `unique` method:

``````sub MAIN (UInt \$size where 1 <= * <= 5) {
my @vowels = | qw/a e i o u / xx (\$size - 1);
my SetHash \$result;
for @vowels.combinations(\$size).unique(:with(&[eqv])) -> \$seq {
for | \$seq.permutations>>.join('').unique {
next if /(\w) \$0/;
next if  /ao|au|ea|eo|eu|oe|oi|ua|ui/;
\$result{\$_}++;
}
}
.say for \$result.keys.sort;
}
``````

For strings of 4 letters, the execution time is now a bit less that 2 seconds. We could further improve performance by fine tuning the number of times the original vowel alphabet is duplicated. For example, using only twice the original alphabet for strings of 4 letters (instead of 3 times as in the above program), the execution time is reduced to 0.8 second. Still significantly longer than the original Raku program.

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, April 5, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge 52: Stepping Numbers and Lucky Winner to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9709 2020-03-22T23:42:39Z 2020-03-23T22:52:59Z These are some answers to the Week 52 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Task 1: Stepping Numbers Write a script to accept two numbers between 100 and 999. It should then print all Stepping Numbers... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 52 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Write a script to accept two numbers between 100 and 999. It should then print all Stepping Numbers between them.

A number is called a stepping number if the adjacent digits have a difference of 1. For example, 456 is a stepping number but 129 is not.

Just to make things slightly clearer, I would say that all adjacent digits should have an absolute difference of 1, so that 542, 454, or 654 are also stepping numbers.

### Stepping Numbers in Perl

Given that the range is quite small, we can use a brute force approach on all numbers between the input values: check for every number in the range whether it fits the definition.

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

die "Please provide two numbers between 100 and 999" if @ARGV != 2;
my (\$start, \$end) = @ARGV;
chomp \$end;
die "Invalid parameters" if \$start !~ /^\d{3}\$/ or \$end !~ /^\d{3}\$/;
(\$start, \$end) = (\$end, \$start) if \$start > \$end;
for my \$num (\$start..\$end) {
my @digits = split //, \$num;
if (abs(\$digits - \$digits) == 1 &&
abs(\$digits - \$digits) == 1) {
say "\$num is a stepping number.";
}
}
``````

This is an example execution:

``````\$ perl stepping_numbers.pl 600 230
232 is a stepping number.
234 is a stepping number.
321 is a stepping number.
323 is a stepping number.
343 is a stepping number.
345 is a stepping number.
432 is a stepping number.
434 is a stepping number.
454 is a stepping number.
456 is a stepping number.
543 is a stepping number.
545 is a stepping number.
565 is a stepping number.
567 is a stepping number.
``````

Note that there is another possible approach: we could construct only stepping numbers and check that they are in the range. We will show this in Raku.

### Stepping Numbers in Raku

Using essentially the same brute-force algorithm as in Perl might lead to the following code:

``````use v6;

subset Three-digits of Int where 99 < * < 1000;

multi sub prefix:<dif1> (List \$val) {
abs(\$val - \$val) == 1 ?? True !! False;
}

sub MAIN (Three-digits \$start is copy, Three-digits \$end is copy) {
(\$start, \$end) = (\$end, \$start) if \$start > \$end;

for \$start..\$end -> \$num {
my \$flag = True;
for \$num.comb.rotor: 2 => -1 -> \$seq {
\$flag = False unless dif1 \$seq;
}
say "\$num is a stepping number." if \$flag;
}
}
``````

This is an example output:

``````\$ perl6 3-digits.p6 200 400
210 is a stepping number.
212 is a stepping number.
232 is a stepping number.
234 is a stepping number.
321 is a stepping number.
323 is a stepping number.
343 is a stepping number.
345 is a stepping number.
``````

But, as said earlier, we could use a different algorithm: we could construct only stepping numbers and check that they are in the range. This leads to the following solution:

``````subset Three-digits of Int where 99 < * < 1000;

sub func (Three-digits \$start is copy, Three-digits \$end is copy) {
(\$start, \$end) = (\$end, \$start) if \$start > \$end;
for 1..9 -> \$i {
for \$i-1, \$i+1 -> \$j {
for \$j-1, \$j+1 -> \$k {
my \$num = 100*\$i + 10*\$j + \$k;
say "\$num is a stepping number." if \$start < \$num < \$end;
}
}
}
}
``````

This program displays the same result as the previous solution when given the same inputs. Note that the outer loop (`for 1..9 -> \$i {`) could easily be improved in terms of performance by using the first digit of the input numbers for the range. However, the program is so fast that this is not required.

Suppose there are following coins arranged on a table in a line in random order.

``````£1, 50p, 1p, 10p, 5p, 20p, £2, 2p
``````

Suppose you are playing against the computer. Player can only pick one coin at a time from either ends. Find out the lucky winner, who has the larger amounts in total?

I do not fully understand the last sentence as a clear task. My interpretation will be to write a computer program that will win each time it can.

Looking at the challenge, the winner is the player that picks the 200p coin, since the sum of all other coins is less than 200p. Since, in any game, one of the player can end up picking the 200p coin, we don’t need to care about the other coins, we just need to optimize our strategy to get the 200p coin.

For this, we should try to leave an odd number of coins on either side of the 200p coin, so that the other player is forced to leave an even number of coins and eventually 0 coin on either side. With 8 coins, the first player can always win.

### Lucky Winner in Perl

Optimizing for the 200p coin leads to the following program:

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

my @coins = @ARGV > 0 ? @ARGV : (100, 50, 1, 10, 5, 20, 200, 2);

my (\$index200) = grep \$coins[\$_] == 200, 0..\$#coins;
my @before = @coins[0..\$index200-1];
my @after = @coins[\$index200+1..\$#coins];
while (my \$move = <STDIN>) {
chomp \$move;
last if \$move eq "";
my \$coin;
if (\$move eq "B") {
\$coin = shift @before // 200;
} elsif (\$move eq "E") {
\$coin = pop @after // 200;
} else {
say "Invalid choice"; next;
}
if (\$coin == 200) {
say "You win!"; last;
}
if (@before == 0) {
say "I pick the 200p coin at start and win"; last;
} elsif (@after == 0) {
say "I pick the 200p coin at end and win"; last;
}
if (@before % 2 == 0) {
\$coin = shift @before;
} elsif (@after %2 == 0) {
\$coin = pop @after;
} else {
# no winning move, let's hope for a mistake
if (@before > @after) {
\$coin = shift @before;
} else {
\$coin = pop @after;
}
}
}

say "New situation = @before 200 @after";
say "Pick a coin at beginning (B) or end (E)";
}
``````

Running it displays the following sample output:

``````\$ perl  coins.pl
New situation = 100 50 1 10 5 20 200 2
Pick a coin at beginning (B) or end (E)
B
New situation = 1 10 5 20 200 2
Pick a coin at beginning (B) or end (E)
B
New situation = 5 20 200 2
Pick a coin at beginning (B) or end (E)
B
New situation = 20 200
Pick a coin at beginning (B) or end (E)
E
You win!
``````

Or:

``````\$ perl  coins.pl
New situation = 100 50 1 10 5 20 200 2
Pick a coin at beginning (B) or end (E)
E
I pick the 200p coin at end and win
``````

### Lucky winner in Raku

Just as in Perl, we are looking for the 200p coin:

``````my @coins = @*ARGS.elems > 0 ?? @*ARGS !! (100, 50, 1, 10, 5, 20, 200, 2);

say @coins;
my (\$index200) = grep { @coins[\$_] == 200}, 0..@coins.end;
my @before = @coins[0..\$index200-1];
my @after = @coins[\$index200+1..@coins.end];
loop  {
last if \$move eq "";
my \$coin;
if (\$move eq "B") {
\$coin = @before.elems ?? shift @before !! 200;
} elsif (\$move eq "E") {
\$coin = @after.elems ?? pop @after !! 200;
} else {
say "Invalid choice"; next;
}
if (\$coin == 200) {
say "You win!"; last;
}
if (@before.elems == 0) {
say "I pick the 200p coin at start and win"; last;
} elsif (@after.elems == 0) {
say "I pick the 200p coin at end and win"; last;
}
if (@before %% 2) {
\$coin = shift @before;
} elsif (@after %% 2) {
\$coin = pop @after;
} else {
# no winning move, let's hope for a mistake
if (@before.elems > @after.elems) {
\$coin = shift @before;
} else {
\$coin = pop @after;
}
}
}

say "New situation = @before[] 200 @after[]";
my \$choice = prompt "Pick a coin at beginning (B) or end (E) ";
}
``````

This program leads to similar results as the Perl program:

``````\$ perl6 coins.p6
[100 50 1 10 5 20 200 2]
New situation = 100 50 1 10 5 20 200 2
Pick a coin at beginning (B) or end (E) E
I pick the 200p coin at end and win
``````

Or:

``````\$ perl6 coins.p6
[100 50 1 10 5 20 200 2]
New situation = 100 50 1 10 5 20 200 2
Pick a coin at beginning (B) or end (E) B
New situation = 1 10 5 20 200 2
Pick a coin at beginning (B) or end (E) B
New situation = 5 20 200 2
Pick a coin at beginning (B) or end (E) B
New situation = 20 200
Pick a coin at beginning (B) or end (E) E
You win!
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, March 29, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge # 50: Merge Intervals and Noble Numbers to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9689 2020-03-08T17:25:19Z 2020-03-23T22:43:31Z These are some answers to the Week 50 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Task 1: Merge Intervals Write a script to merge the given intervals where ever possible. [2,7], [3,9], [10,12], [15,19], [18,22] The script... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 50 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Write a script to merge the given intervals where ever possible.

``````[2,7], [3,9], [10,12], [15,19], [18,22]
``````

The script should merge [2, 7] and [3, 9] together to return [2, 9].

Similarly it should also merge [15, 19] and [18, 22] together to return [15, 22].

The final result should be something like below:

``````[2, 9], [10, 12], [15, 22]
``````

The example shows that intervals should be merged only if they overlap, but not if they are contiguous (in the example, [2,9] is not merged with [10, 12]).

### Merge Intervals in Perl

For each interval except the first one, we check whether it overlaps with the previous one (stored in the `\$current` variable); if it does overlap, we build a new interval merging it with `\$current`.

``````use strict;
use warnings;
use feature "say";
use Data::Dumper;

my @intervals = ([2,7], [3,4], [5,9], [10,12], [15,19], [18,22], [0,1], [24,35], [25,30]);
@intervals =  sort { \$a-> <=> \$b-> } @intervals;
my @merged;
# say Dumper \@intervals;
my \$current = \$intervals;
for my \$i (1..\$#intervals) {
if (\$intervals[\$i] > \$current->) {
push @merged, \$current;
\$current = \$intervals[\$i];
} else {
next unless \$intervals[\$i] > \$current->;
\$current-> = \$intervals[\$i];
}
}
push @merged, \$current;
say Dumper \@merged;
``````

Running this program displays the expected result:

``````\$ perl intervals.pl
\$VAR1 = [
[
0,
1
],
[
2,
9
],
[
10,
12
],
[
15,
22
],
[
25,
30
]
];
``````

### Merge Intervals in Raku

We use the same algorithm as in Perl:

``````my @intervals = [2,7], [3,4], [5,9], [10,12], [15,19], [18,22], [0,1], [24,35], [25,30];
@intervals =  sort { \$_ }, @intervals;
my @merged;
my \$current = @intervals;
for 1..@intervals.end -> \$i {
if (@intervals[\$i] > \$current) {
push @merged, \$current;
\$current = @intervals[\$i];
} else {
next unless @intervals[\$i] > \$current;
\$current = @intervals[\$i];
}
}
push @merged, \$current;
say @merged;
``````

And this prints out the expected result:

``````[[0 1] [2 9] [10 12] [15 22] [24 35]]
``````

You are given a list, @L, of three or more random integers between 1 and 50. A Noble Integer is an integer N in @L, such that there are exactly N integers greater than N in @L. Output any Noble Integer found in @L, or an empty list if none were found.

An interesting question is whether or not there can be multiple Noble Integers in a list.

For example,

Suppose we have list of 4 integers [2, 6, 1, 3].

Here we have 2 in the above list, known as Noble Integer, since there are exactly 2 integers in the list i.e.3 and 6, which are greater than 2.

Therefore the script would print 2.

Can there be multiple noble integers? Yes. For example, in the list [3, 3, 4, 5, 6], both 3 in the list are noble integers, but if we print “3 is a noble integer” twice, the information will be correct, but somewhat incomplete. However, since we have no requirement for such a case, we will deem such information to be sufficient. When all integers in the list are unique, there can be at most one noble number: if, in a given list, 4 is noble, that means there are 4 integers larger than 4; in such a case, there obviously cannot be 5 integers larger than 5.

### Noble Integers in Perl

Basically, for each integer in the list, we need to count how many integers are larger, which means that we would need two nested loops. It will be faster to first sort the list. For example, the list provided as an example in the task description would yield [1, 2, 3, 6]. Since there are four items in the list, we can compare the value of any element with the size of the list minus the index of such element minus 1. Here, we have 4 - 1 - 1 = 2, so 2 is a noble integer in that list. If we had [1, 2, 3, 6, 8, 9], we could similarly compute for item 3: 6 - 2 - 1 = 3, and find that 3 is a noble item in the list.

But we can do something much simpler: we can sort the list in descending order, and then just compare the value of each element with its index. In the case of the list provided in the task description, we obtain the following list: [6, 3, 2, 1], and can see immediately that the item with index 2 has a value of 2, therefore 2 is a noble integer for that list. It is quite easy to show that, in any zero-indexed list, the index of an item is always equal to the number of items preceding it and, in the case of a list sorted in descending order, the index of an item is always equal to the number of larger items. With this in mind, the code is quite simple:

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

my \$list_size = int(rand 10) + 3;
my @list = map {int(rand 50) + 1 } 1..\$list_size;
say \$list_size, "/", "@list";

# my @list = (2, 6, 1, 3,5, 8);

@list = sort {\$b <=> \$a} @list; #descending sort
say \$list_size, " / ", "@list";
for (0..\$#list) {
say "\$list[\$_] is noble." if \$list[\$_] == \$_;
}
``````

We have to run the program a few times before we get a list with a noble integer:

``````\$ perl noble_nr.pl
8/26 19 22 29 46 15 35 14
8 / 46 35 29 26 22 19 15 14

\$ perl noble_nr.pl
6/21 2 34 21 23 47
6 / 47 34 23 21 21 2

\$ perl noble_nr.pl
12/26 3 29 13 41 14 19 23 50 26 36 41
12 / 50 41 41 36 29 26 26 23 19 14 13 3

\$ perl noble_nr.pl
8/19 14 9 42 5 6 11 48
8 / 48 42 19 14 11 9 6 5
6 is noble.
``````

### Noble Integers in Raku

We will use the same approach as in Perl: sort the list in descending order and compare the index of each item with its value. Note that, in Raku, we use the `pick` method on the range, so that there is no need to coerce the generated random numbers to integers and we also won’t have any duplicate (thereby eliminating the edge case mentioned above).

``````use v6;

my \$list-size = (3..11).pick;
my @list = (1..50).pick(\$list-size).sort.reverse;
say @list;
for (0..@list.end) {
say "@list[\$_] is noble." if @list[\$_] == \$_;
}
``````

After running the program a few times with no noble integer found, we finally find one:

``````[47 46 18 15 4 3]
4 is noble.
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, March 15, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>
Posted Perl Weekly Challenge: Smallest Multiple and LRU Cache to laurent_r tag:blogs.perl.org,2020:/users/laurent_r//3226.9677 2020-02-28T22:29:51Z 2020-02-28T22:40:05Z These are some answers to the Week 49 of the Perl Weekly Challenge organized by Mohammad S. Anwar. Spoiler Alert: This weekly challenge deadline is due in a couple of days (March 1, 2020). This blog post offers some solutions... laurent_r http://blogs.perl.org/mt/mt-cp.fcgi?__mode=view&blog_id=3226&id=4694 These are some answers to the Week 49 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (March 1, 2020). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Write a script to accept a positive number as command line argument and print the smallest multiple of the given number consists of digits 0 and 1.

For example:

For given number 55, the smallest multiple is 110 consisting of digits 0 and 1.

An attempt to mathematically analyze the problem might start as follows. The multiple has to end with 0 or 1. So, if our given number ends with 5 (as in the case of the 55 example above), the multiplicator has to end with 0, 2, 4, 6, or 8. That may not look very interesting, but looking at other final digits is sometimes interesting. First, 0 will always produce 0 as a final digit, but this is a trivial solution that will never be the smallest one: for example if a given number multiplied by 1350 is composed only of 0 and 1, then the same number multiplied by 135 will also be composed of 0 and 1, and will be a better (smaller) solution. Given the final digit of the input number, the multiplicator has to end with the following digits:

``````0 -> any digit
1 -> 1
2 -> 5
3 -> 7
4 -> 5
5 -> any even digit
6 -> 5
7 -> 3
8 -> 5
9 -> 9
``````

But from there, it seems quite difficult to analyze further. I don’t have time right now to do that, and will therefore use a brute force approach.

### Smallest Multiple in Perl

We just try every possible muliplicator and check whether the result of the multiplication is composed of digits 0 and 1:

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

my \$num = shift;
my \$i = 1;
while (1) {
my \$result = \$num * \$i;
if (\$result =~ /^*\$/) {
say "\$num * \$i = \$result";
last;
}
\$i++;
}
``````

Running the program with some numbers seems to quickly yield proper results:

``````\$ perl multiples.pl 651
651 * 15361 = 10000011

\$ perl multiples.pl 743
743 * 13607 = 10110001

\$ perl multiples.pl 812
812 * 1355925 = 1101011100
``````

But for some input numbers, it starts to take quite a bit of time, for example about 15 seconds for 1243:

``````\$ time perl multiples.pl 1243
1243 * 80539107 = 100110110001

real    0m15,412s
user    0m15,405s
sys     0m0,000s
``````

For some numbers, the program seems to hang indefinitely, but I have no idea how to figure out whether it is because the solution is just extremely large, or because there is simply no solution.

For example, with input number 12437, the program ran for more than 13 minutes before I got tired and killed it.

``````\$ time perl multiples.pl 12437

real    13m46,762s
user    13m46,296s
sys     0m0,077s
``````

I don’t know whether it would have found the solution just a few seconds or some minutes later, or whether finding the solution would require ages, or even whether there is no solution.

Obviously, our above program would need an upper limit above which we stop looking for a multiple, but I frankly don’t know how large that limit should be. Just pick the one you prefer.

### Smallest Multiple in Raku

We’ll also use the brute force approach in Raku, but with a slightly different approach: we first build a lazy infinite list of multiples of the input number, and then look for the first one that contains only digits 0 and 1:

``````use v6;

my \$num = @*ARGS // 743;
my @multiples = map { \$num * \$_ }, 1..*;
say @multiples.first: /^<>+\$/; # default 743: -> 10110001
``````

This produces the following output:

``````\$ ./perl6 multiples.p6
10110001

\$ ./perl6 multiples.p6 421
100110011
``````

Write a script to demonstrate LRU Cache feature. It should support operations get and set. Accept the capacity of the LRU Cache as command line argument.

Definition of LRU: An access to an item is defined as a get or a set operation of the item. “Least recently used” item is the one with the oldest access time.

For example:

``````capacity = 3
set(1, 3)
set(2, 5)
set(3, 7)

Cache at this point:
[Least recently used] 1,2,3 [most recently used]

get(2)      # returns 5

Cache looks like now:
[Least recently used] 1,3,2 [most recently used]

get(1)      # returns 3

Cache looks like now:
[Least recently used] 3,2,1 [most recently used]

get(4)      # returns -1

Cache unchanged:
[Least recently used] 3,2,1 [most recently used]

set(4, 9)

Cache is full, so pushes out key = 3:
[Least recently used] 2,1,4 [most recently used]

get(3)      # returns -1
``````

A LRU cache discards first the least recent used data item. A LRU algorithm usually requires two data structures: one to keep the data elements and one to keep track of their age, although the two types of information may also be packed into a single data structure. In Perl or in Raku, the most obvious candidates would be to use a hash to store the data elements and an array to keep track of their relative ages. But you could also use an ordered hash (see for example the Perl Hash::Ordered module on the CPAN or the Raku Array::Hash module) to record both types of information in a single data structure.

### LRU Cache in Perl: Objects in Functional Programming

Wanting to implement one or several data structure along with some specific built-in behavior clearly appears to be an ideal case for object-oriented programming. I would bet that many of the challengers will take this path, which is a sufficient reason for me to take another route: I’ll implement my LRU cache object using functional programming. There is, however, another reason: to me, this is much more fun. In the program below, the `create_lru` subroutine acts as a function factory and an object constructor. It keeps track of the three LRU object attributes (`\$capacity`, `%cache`, and `@order`) and returns two code references that can be considered to be the LRU object public methods. The `\$setter` and `\$getter` anonymous subroutines are closures and close over the three object attributes.

``````use strict;
use warnings;
use feature "say";
use Data::Dumper;

sub create_lru {
my \$capacity = shift;
my (%cache, @order);
sub display { say "Order: @{\$_} \n", "Cache: ", Dumper \$_;}
my \$setter = sub {
my (\$key, \$val) = @_;
\$cache{\$key} = \$val;
push @order, \$key;
if (@order > \$capacity) {
my \$invalid = shift @order;
delete \$cache{\$invalid};
}
display \@order, \%cache;
};
my \$getter = sub {
my \$key = shift;
return -1 unless exists \$cache{\$key};
@order = grep { \$_ != \$key } @order;
push @order, \$key;
display \@order, \%cache;
return \$cache{\$key}
};
return \$setter, \$getter;
}

my (\$set, \$get) = create_lru(3);
\$set->(1, 3);
\$set->(2, 5);
\$set->(3, 7);
say "should print  5: ", \$get->(2);
say "should print  3: ", \$get->(1);
say "should print -1: ", \$get->(4);
\$set->(4, 9);
say "should print -1: ", \$get->(3);
``````

Note that the `display` subroutine isn’t necessary, it is used just to show that various data structures evolve in accordance with the task requirements. Also note that, although this wasn’t needed here, it would be perfectly possible to create several distinct LRU objects with this technique (provided you use different names or lexical scopes for the code references storing the values returned by the `create_lru` subroutine).

Running this program displays the following output:

``````\$ perl lru.pl
Order: 1
Cache: \$VAR1 = {
'1' => 3
};

Order: 1 2
Cache: \$VAR1 = {
'1' => 3,
'2' => 5
};

Order: 1 2 3
Cache: \$VAR1 = {
'3' => 7,
'2' => 5,
'1' => 3
};

Order: 1 3 2
Cache: \$VAR1 = {
'3' => 7,
'2' => 5,
'1' => 3
};

should print  5: 5
Order: 3 2 1
Cache: \$VAR1 = {
'3' => 7,
'2' => 5,
'1' => 3
};

should print  3: 3
should print -1: -1
Order: 2 1 4
Cache: \$VAR1 = {
'4' => 9,
'1' => 3,
'2' => 5
};

should print -1: -1
``````

### LRU Cache in Raku

We could use the same functional programming techniques as before in Raku, but, since the Raku OO system is so nice, I’ll create a `LRU-cache` class and instantiate an object of this class:

``````use v6;
class LRU-cache {
has %!cache;
has @!order;
has UInt \$.capacity;

method set (Int \$key, Int \$val) {
%!cache{\$key} = \$val;
push @!order, \$key;
if (@!order > \$.capacity) {
my \$invalid = shift @!order;
%!cache{\$invalid}:delete;
}
self.display;
};
method get (Int \$key) {
return -1 unless %!cache{\$key}:exists;
@!order = grep { \$_ != \$key }, @!order;
push @!order, \$key;
self.display;
return %!cache{\$key}
};
method display { .say for "Order: @!order[]", "Cache:\n{%!cache}" };
}

my \$cache = LRU-cache.new(capacity => 3);
\$cache.set(1, 3);
\$cache.set(2, 5);
\$cache.set(3, 7);
say "should print  5: ", \$cache.get(2);
say "should print  3: ", \$cache.get(1);
say "should print -1: ", \$cache.get(4);
\$cache.set(4, 9);
say "should print -1: ", \$cache.get(3);
``````

Running this program displays more or less the same input as before:

``````Order: 1
Cache:
1   3
Order: 1 2
Cache:
1   3
2   5
Order: 1 2 3
Cache:
1   3
2   5
3   7
Order: 1 3 2
Cache:
1   3
2   5
3   7
should print  5: 5
Order: 3 2 1
Cache:
1   3
2   5
3   7
should print  3: 3
should print -1: -1
Order: 2 1 4
Cache:
1   3
2   5
4   9
should print -1: -1
``````

## Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, March 9, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

]]>