Perl Weekly Challenge 53: Rotate Matrix and Vowel Strings

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.

Task 1: Rotate Matrix

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]

Task 2: Vowel Strings

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.

Perl Weekly Challenge 52: Stepping Numbers and Lucky Winner

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 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[0] - $digits[1]) == 1 &&
        abs($digits[1] - $digits[2]) == 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[0] - $val[1]) == 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.

Task 2: Lucky Winner

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];
ask();
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;
        }
    }
    ask();
}

sub ask {
    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  {
    my $move = ask();
    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;
        }
    }
}

sub ask () {
    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.

Perl Weekly Challenge # 50: Merge Intervals and Noble Numbers

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 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->[0] <=> $b->[0] } @intervals; 
my @merged;
# say Dumper \@intervals;
my $current = $intervals[0];
for my $i (1..$#intervals) {
    if ($intervals[$i][0] > $current->[1]) {
        push @merged, $current;
        $current = $intervals[$i];
    } else {
        next unless $intervals[$i][1] > $current->[1];
        $current->[1] = $intervals[$i][1];
    }
}
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 { $_[0] }, @intervals; 
my @merged;
my $current = @intervals[0];
for 1..@intervals.end -> $i {
    if (@intervals[$i][0] > $current[1]) {
        push @merged, $current;
        $current = @intervals[$i];
    } else {
        next unless @intervals[$i][1] > $current[1];
        $current[1] = @intervals[$i][1];
    }
}
push @merged, $current;
say @merged;

And this prints out the expected result:

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

Task 2: Noble Integers

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.

Perl Weekly Challenge: Smallest Multiple and LRU Cache

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.

Task 1: Smallest Multiple

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 =~ /^[01]*$/) {
        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[0] // 743;
my @multiples = map { $num * $_ }, 1..*;
say @multiples.first: /^<[01]>+$/; # default 743: -> 10110001

This produces the following output:

$ ./perl6 multiples.p6
10110001

$ ./perl6 multiples.p6 421
100110011

Task 2: LRU Cache

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: @{$_[0]} \n", "Cache: ", Dumper $_[1];}
    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.

Perl Weekly Challenge 48: Survivor and Palindrome Dates

These are some answers to the Week 48 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (February 23, 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: The Survivor

There are 50 people standing in a circle in positions 1 to 50. The person standing at position 1 has a sword. He kills the next person i.e. standing at position 2 and passes on the sword to the immediate next, i.e. person standing at position 3. Now the person at position 3 does the same and it goes on until only one survives.

Write a script to find out the survivor.

This is sometimes called the Josephus Problem, named after Flavius Josephus, a Jewish historian of the 1st century who allegedly escaped collective suicide of defeated Jewish soldiers trapped by Roman soldiers by finding the right position to be the survivor.

The idea is that you remove every second person in a circle until there is only one person left, and the problem is to find the rank of that last person. There is an analytical solution (well two different ones, depending on whether the initial number of persons is even or odd), but it’s more fun to do it in the way the task is described (at least if you set aside the gory details about the sword and the killing).

We’ll set up the initial 50 persons (or whatever other number) in an array and, at each step in the process, remove the first two persons in the row, while adding the first one at then end of the array.

Survivor in Perl

This first implementation does just what we have described above: we shift the first person in the array and push him or her at the end of the array and shift (i.e. remove) the second person, and we do that in a loop until there is only one person left:

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

my $number = shift // 50;
my @persons = 1 .. $number; # we can do that because 
                            # we don't use the array indices
do {
    push @persons, shift @persons;
    shift @persons;
    say "@persons";
} until @persons == 1;
say "Person @persons is the survivor.\n";

We will first run this program with a parameter of 10, because it will be easier to visualize the process with only ten steps:

$ perl survivor.pl 10
3 4 5 6 7 8 9 10 1
5 6 7 8 9 10 1 3
7 8 9 10 1 3 5
9 10 1 3 5 7
1 3 5 7 9
5 7 9 1
9 1 5
5 9
5
Person 5 is the survivor.

Commenting out the intermediate array displays and passing a parameter of 50 (or no parameter to use the default value), we’ll find that the survivor is the person with number 37:

$ perl survivor.pl
Person 37 is the survivor.

Although this is really not a problem here, there is a slight inefficiency in the above implementation: at each step through the process, we’re checking how many persons are left in the array. In fact, we are eliminating one person at each step, and therefore know in advance that we want to iterate through the process one time less that the initial number of persons (e.g. 49 times for an initial count of 50). Thus, we can use a for loop without having to check the array size:

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

my $number = shift // 50;

my @persons = 1 .. $number;
for (1.. $number - 1) {
    push @persons, shift @persons;
    shift @persons;
} 
say "Person @persons is the survivor.\n";

This also prints that person 37 is the survivor.

Survivor in Raku

Our Raku solution will be almost the same as the second Perl solution. In fact, the for loop is exactly the same, only the retrieval of the parameter passed to the program and the printing statement at the end are slightly different:

use v6;

my $number = @*ARGS ?? @*ARGS[0] !! 50;

my $number = 50;
my @persons = 1 .. $number;

for (1.. $number - 1) {
    push @persons, shift @persons;
    shift @persons;
}
say "Person @persons[] is the survivor.\n";

And this prints out the same:

$ perl6 survivor.p6
Person 37 is the survivor.

Task 2: Palindrome Dates

Write a script to print all Palindrome Dates between 2000 and 2999. The format of date is mmddyyyy. For example, the first one was on October 2, 2001 as it is represented as 10022001.

The first idea might be to check every date within the given range, but that’s a lot of dates (more than 365,000 dates), and that brute force approach might take quite a bit of time and is quite inelegant.

We can very strongly reduce the number of dates to be checked by noticing that for every mmdd month-day combination, there can be at most only one year to produce a palindromic date; conversely, for any year in the range, there can be at most only one date that is a palindrome. So we can either check every month-day combination or check every year of the range. I decided to go for this second solution, because, as we shall see, we can still strongly reduce the number of possibilities that we need to check (and the code will be slightly simpler).

Of course, we’ll also need to make sure that the dates we produce are valid.

Palindrome Dates in Perl

We start with the idea of checking every year in the range. Suppose we’re looking at 2001, we reverse the year and get 1002 which, if the format is mmdd, corresponds to Oct. 2, 2001. 2000, on the other hand, cannot have a palindromic date since 00 isn’t a valid month number. 2002 is a palindromic year, but we can’t find a palindromic date in it because 20 isn’t a valid month number.

Now, consider year 2301, which produces in reverse 1032. The number 32 cannot be a day in the month, and the same reasoning applies to any year thereafter, so that we only need to check the range between 2001 and 2299, and we end up with only about 300 dates to check. As a side consequence, all the tentative days in month that we will find will be 02, 12, or 22. The very good news here is that any month can have such days in month, and we don’t need to worry about months with 28, 29, 30, and 31 days. In other words, we can check that the tentative day in month is in the 01-31 range (although, in fact, checking the 01-22 range would be sufficient), and that the tentative month is in the 01-12 range. As a result (and contrary to what I initially thought), we don’t even need to use any module to check that the dates we obtain are correct, they are bound to be valid.

Thus, our program is fairly simple:

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

for my $year (2000 .. 2300) {
    my ($month, $day) = (reverse $year) =~ /(\d\d)(\d\d)/;
    next if $month > 12 or $month < 1 or $day > 31 or $day < 1;
    say "$month/$day/$year is a palindromic date.";
}

Running this program produces 36 palindromic dates in the 2000-2999 range:

$ perl palindromic_date.pl
10/02/2001 is a palindromic date.
01/02/2010 is a palindromic date.
11/02/2011 is a palindromic date.
02/02/2020 is a palindromic date.
12/02/2021 is a palindromic date.
03/02/2030 is a palindromic date.
04/02/2040 is a palindromic date.
05/02/2050 is a palindromic date.
06/02/2060 is a palindromic date.
07/02/2070 is a palindromic date.
08/02/2080 is a palindromic date.
09/02/2090 is a palindromic date.
10/12/2101 is a palindromic date.
01/12/2110 is a palindromic date.
11/12/2111 is a palindromic date.
02/12/2120 is a palindromic date.
12/12/2121 is a palindromic date.
03/12/2130 is a palindromic date.
04/12/2140 is a palindromic date.
05/12/2150 is a palindromic date.
06/12/2160 is a palindromic date.
07/12/2170 is a palindromic date.
08/12/2180 is a palindromic date.
09/12/2190 is a palindromic date.
10/22/2201 is a palindromic date.
01/22/2210 is a palindromic date.
11/22/2211 is a palindromic date.
02/22/2220 is a palindromic date.
12/22/2221 is a palindromic date.
03/22/2230 is a palindromic date.
04/22/2240 is a palindromic date.
05/22/2250 is a palindromic date.
06/22/2260 is a palindromic date.
07/22/2270 is a palindromic date.
08/22/2280 is a palindromic date.
09/22/2290 is a palindromic date.

Palindrome Dates in Raku

We can translate the same program into Raku. Please read the reasoning in the Perl section just above (if you didn’t) to understand why we limit the range to the 2000..2300 range and why we don’t need to further verify the validity of the obtained dates.

use v6;

for 2000 .. 2300 -> $year {
    my ($month, $day) = ($year.flip ~~ /(\d\d)(\d\d)/)[0, 1];
    next if $month > 12 or $month < 1 or $day > 31 or $day < 1;
    say "$month/$day/$year is a palindromic date.";
}

This produces the same result as before:

$ perl6 palindromic_date.p6
10/02/2001 is a palindromic date.
01/02/2010 is a palindromic date.
11/02/2011 is a palindromic date.
[Lines omitted for brevity]
08/22/2280 is a palindromic date.
09/22/2290 is a palindromic date.

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