February 2020 Archives

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.

Perl Weekly Challenge 47: Roman Calculator and Gapful Numbers

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

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

I have really very little time to complete this blog post in time for the deadline. My explanations will be minimal, sorry about that.

Roman Calculator

Write a script that accepts two roman numbers and operation. It should then perform the operation on the give roman numbers and print the result.

For example,

perl ch-1.pl V + VI

It should print

XI

There are two possible ways to solve such a task: to try to implement a Roman numerals computation algorithm, or to convert Roman numerals to our usual numbers, make the calculations and convert the result back to Roman nummerals. To me, it is quite obvious that the second solution is the simplest and best.

Most people know more or less how Roman numerals work. They use Latin letters to represent numbers:

|---------------------------------------------------|
| Symbol |  I  |  V  |  X  |  L  |  C  |  D  |  M   |
|---------------------------------------------------|
| Value  |  1  |  5  |  10 |  50 | 100 | 500 | 1000 |
|---------------------------------------------------|

In general, Roman numerals use additive notation: for example, MCLXXIII means 1000 + 100 + 50 + 20 + 3 = 1173. Or, at least, this is so when the symbols are written from left to right in decreasing value order.

If, however, a given symbol has a smaller value than a symbol placed on its right, then this is an example of subtractive notation: in that case, the smaller symbol is subtracted from the one its right. For example, IV means 1 subtracted from 5, i.e. 5 - 1 = 4. Similarly, IX and XC respectively mean 10 - 1 = 9 and 100 - 10 = 90. And MCMXLIX corresponds to 1000 + ( 1000 - 100) + (50 - 10) + (10 - 1) = 1949.

The overall problem, though, is that there is no general standard for Roman numerals. Applying the rules above makes it possible to decode more or less unambiguously any Roman numeral coded according to such aforesaid rules, but there may be several different possible ways to encode a number into a Roman numeral. For example, 99 could be encoded as XCXI or IC (or even XCVIIII or possibly LXXXXVIIII). The first transcription (XCXI) seems to be the most frequent one, so this is the one we will chose when encoding to Roman numerals. Still, IC seems to be a valid Roman numeral for 99, so we will try at least to be able to decode it if we find it.

Note that there is no Roman numeral for zero and the largest possible Roman numeral with the above rules is 3,999.

Roman Numeral Calculation in Perl

I’ll reuse the from_roman and to_roman subroutines used in Perl Weekly Challenge 10. Please refer to this post to get explanations on how this works.

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


my %rom_tab = (I => 1,  V => 5, X => 10, L => 50, C => 100, D => 500, M => 1000);

sub from_roman {
    my $roman = uc shift;
    my $numeric = 0;
    my $prev_letter = "M";
    for my $letter (split //, $roman) {
        $numeric -= 2 * $rom_tab{$prev_letter} 
            if $rom_tab{$letter} > $rom_tab{$prev_letter};
        $numeric += $rom_tab{$letter};
        $prev_letter = $letter;
    }
    return $numeric;
}

sub to_roman {
    my $arabic = shift;
    warn "$arabic out of bounds" unless $arabic > 0 and $arabic < 4000;
    my %hash = %rom_tab;
    $hash{$_->[0]} = $_->[1] for (['IV', 4], ['IX', 9], ['XL', 40], 
        ['XC', 90], ['CD', 400], ['CM', 900] );
    my $roman = "";
    for my $key (sort { $hash{$b} <=> $hash{$a} } keys %hash) {
        my $num = int ($arabic / $hash{$key});
        $roman .= $key x $num;
        $arabic -= $hash{$key} * $num; 
    }
    return $roman;
}

my @input;
for (@ARGV) {
    push @input, $_ if /[-+*\/]/;
    push @input, from_roman $_ if /[ivxlcdm]+/i;
}
die "Need at least three parameters" if @input < 3; # we need at least 1 operator and two operands
my $result = eval join ' ', @input;
say "@ARGV = ", to_roman $result;

These are a few examples of output:

$ perl  roman_calc.pl X + X
X + X = XX

$ perl  roman_calc.pl V + X
V + X = XV

$ perl  roman_calc.pl V + X + III
V + X + III = XVIII

$ perl  roman_calc.pl V + X + III + V
V + X + III + V = XXIII

Roman Numeral Calculation in Raku

I’ll reuse the from-roman and to-roman subroutines used in Perl Weekly Challenge 10. Please refer to this post to get explanations on how this works.

use v6;
use MONKEY-SEE-NO-EVAL;

subset Roman-str of Str where $_ ~~ /^<[IVXLCDMivxlcdm]>+$/;

my %rom-tab = < I 1   V 5   X 10   L 50   C 100  D 500  M 1000 
               IV 4  IX 9   XL 40  XC 90  CD 400   CM 900 >;
my @ordered_romans = reverse sort { %rom-tab{$_} }, keys %rom-tab;

sub from-roman (Roman-str $roman) {
    my $numeric = 0;
    my $prev_letter = "M";
    for $roman.uc.comb -> $letter {
        $numeric -= 2 * %rom-tab{$prev_letter} 
            if %rom-tab{$letter} > %rom-tab{$prev_letter};
        $numeric += %rom-tab{$letter};
        $prev_letter = $letter;
    }
    return $numeric;
}

sub to-roman (Int $arabic is copy where  { 0 < $_ < 4000 }) {
    my $roman = "";
    for @ordered_romans -> $key {
        my $num = ($arabic / %rom-tab{$key}).Int;
        $roman ~= $key x $num;
        $arabic -= %rom-tab{$key} * $num; 
    }
    return $roman;
}

my @input;
for @*ARGS {
    push @input, $_ if /<[-+*\/]>/;
    push @input, from-roman $_ if m:i/<[ivxlcdm]>+/;
}
die "Need at least three parameters" if @input < 3; # we need at least 1 operator and two operands
my $result = EVAL join ' ', @input;
say "@*ARGS[] = ", to-roman $result;

Some sample runs:

$ perl6 roman_calc.p6 III + V
III + V = VIII

$ perl6 roman_calc.p6 III + V + X
III + V + X = XVIII

$ perl6 roman_calc.p6 III + V + X - I
III + V + X - I = XVII

Gapful Numbers

Write a script to print first 20 Gapful Numbers greater than or equal to 100. Please check out the page for more information about Gapful Numbers.

Gapful numbers are numbers that are divisible by the number formed by their first and last digit. Numbers up to 100 trivially have this property and are excluded.

Basically, we need to check for all numbers from 100 on whether they are divisible by the number formed by the concatenation of their first and last digits, and stop the process once we have collected 20 numbers.

Gapful Numbers in Perl

There are several ways to extract the first and the last digits of a number. The first that came to my mind was a simple regex:

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

my @gapful = ();
my $current = 100;
do {
    my ($start, $end) = $current =~ /^(\d)\d+(\d)$/;
    push @gapful, $current unless $current % ($start . $end);
    $current ++;
} until $#gapful >= 19;
say "@gapful";

This program displays the following output:

$ perl gapful.pl
100 105 108 110 120 121 130 132 135 140 143 150 154 160 165 170 176 180 187 190

Although performance really doesn’t matter very much for such a simple task, using the substr built-in function might be more efficient that a regex. Here, we only show the loop, without the boilerplate code at the beginning of the program:

do {
    my $div = join '', substr ($current, 0, 1), substr ($current, -1, 1);
    push @gapful, $current unless $current % $div;
    $current ++;
} while $#gapful < 19;
say "@gapful";

This produces the same output as above.

Another way is to split each number into individual digits and to use a slice to pick up the first and last ones:

while ($#gapful < 19) {
    my $div = join '', (split //, $current)[0, -1];
    push @gapful, $current unless $current % $div;
    $current++;
};
say "@gapful";

This also produces the same output.

Gapful Numbers in Raku

In Raku, we don’t need a loop to manage the number of gapful numbers: we can just create a lazy infinite list of such numbers and get the first 20 ones:

my @gapful = grep { $_ %% .comb[0,*-1].join }, 100..*;
say @gapful[0..19];

We have again the sale output as before.

This is now so short and simple that we can boil it down to a Raku one-liner:

$ perl6 -e 'say (grep { $_ %% .comb[0,*-1].join}, 100..*)[0..19];'
(100 105 108 110 120 121 130 132 135 140 143 150 154 160 165 170 176 180 187 190)

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

Perl Weekly Challenge 46: Garbled Message and Room Open

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

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

Garbled Message

The communication system of an office is broken and message received are not completely reliable. To send message Hello, it ended up sending these following:

H x l 4 !
c e - l o
z e 6 l g
H W l v R
q 9 m # o

Similarly, another day we received a message repeatedly like below:

P + 2 l ! a t o
1 e 8 0 R $ 4 u
5 - r ] + a > /
P x w l b 3 k \
2 e 3 5 R 8 y u
< ! r ^ ( ) k 0

Write a script to decrypt the above repeated message (one message repeated 6 times).

HINT: Look for characters repeated in a particular position in all six messages received.

Basically, the idea is that any letter that is repeated at the same position in several transmissions is deemed to be correct. For example, in the case of the first message, the letter ‘H’ occurs twice in the first position of the message, so the message is deemed to start with ‘H.’ Similarly, in the second position, we have twice an ‘e,’ and so on to complete the word ‘Hello.’

Garbled Message in Perl

Although it could undoubtedly be done directly, I decided that the easiest way was first to perform a matrix transposition on the data and then to explore the resulting lines to find duplicate letters.

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

my $garbled = <<'END_MSG';
P + 2 l ! a t o
1 e 8 0 R $ 4 u
5 - r ] + a > /
P x w l b 3 k \
2 e 3 5 R 8 y u
< ! r ^ ( ) k 0
END_MSG

my @AoA = map { [ split /\s+/, $_] } split /[\r\n]+/, $garbled;
my @transposed;
for my $i (0 .. $#AoA) {
  $transposed[$_][$i] = $AoA[$i][$_] for 0.. scalar @{$AoA[$i]} -1;
}
my @msg = "";
for my $line_ref (@transposed) {
    my %counter;
    $counter{$_}++ for @$line_ref;
    push @msg, grep { $counter{$_} > 1 } keys %counter;
}
say @msg;

This program displays the following output:

$ perl garbled.pl
PerlRaku

Garbled Message in Raku

Just as in Perl, I first made a matrix transposition of the data and then looked for duplicate letters in each line:

use v6;

my $garbled = q:to/END_MSG/;
P + 2 l ! a t o
1 e 8 0 R $ 4 u
5 - r ] + a > /
P x w l b 3 k \
2 e 3 5 R 8 y u
< ! r ^ ( ) k 0
END_MSG

my @AoA = map { my @a = split /\s+/, $_; @a }, split /<[\r\n]>+/, $garbled;
my @transposed;
for (0 .. @AoA.end) -> $i {
    @transposed[$_][$i] = @AoA[$i][$_] for 0.. (@AoA[$i]).elems -1;
}
my @msg = "";
for @transposed -> $line {
    my BagHash $counter;
    $counter{$_}++ for @$line;
    push @msg, grep { $counter{$_} > 1 }, keys $counter;
}
say join "", @msg;

This program produces the same output:

$ perl6 garbled.p6
PerlRaku

Is the room open?

There are 500 rooms in a hotel with 500 employees having keys to all the rooms. The first employee opened main entrance door of all the rooms. The second employee then closed the doors of room numbers 2,4,6,8,10 and so on to 500. The third employee then closed the door if it was opened or opened the door if it was closed of rooms 3,6,9,12,15 and so on to 500. Similarly, the fourth employee did the same as the third but only room numbers 4,8,12,16 and so on to 500. This goes on until all employees has had a turn.

Write a script to find out all the rooms still open at the end.

There is an analytical way to solve this problem (as we’ll see later), but let’s just apply the process as described in the task formulation.

Open Rooms in Perl

Note that in the program below, we’re limiting the number of doors and employees to 50 (the MAX constant`), rather than 500, This is just to make the output shorter and easier to read.

use strict;
use warnings;
use feature "say";
use Data::Dumper;
use constant MAX => 50;

# 1 => open, 0 => closed

my @rooms = (1) x (MAX + 1); # (first employee)
my $start = 1;
for (2..MAX) {
    $start++;
    my $door = $start;
    while ($door <= MAX) {
        $rooms[$door] = $rooms[$door] ? 0 : 1;
        $door += $start;
    }
}
say join " ", @rooms[1..MAX];

This program displays the following output:

$ perl hotel.pl
1 0 0 1 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0

There are a few interesting things to notice in the pattern of the result, but we’ll come back to that after the Raku solution.

Open Rooms in Raku

We’re also limiting the number of doors and employees to 50 (the MAX constant), rather than 500, to make the output shorter and easier to read.

use v6;
constant MAX = 50;
my @rooms = 1 xx MAX + 1; # (first employee)
my $start = 1;
for 2..MAX {
    $start++;
    my $door = $start;
    while $door <= MAX {
        @rooms[$door] = @rooms[$door] ?? 0 !! 1;
        $door += $start;
    }
  # say [+] @rooms[1..MAX];
}
say join " ", @rooms[1..MAX];

This displays the same output as the Perl program.

Further Analysis

I was originally surprised at the small number of doors open at the end of the process. I thought it would be interesting to see how the number of open doors evolves with each iteration. Reactivating the line commented out in the Raku program above makes it possible to see that (we’re now using the 500 rooms of the original task description):

250
250
293
277
276
269
243
260
248
247
244
... (Lines omitted for brevity)
28
27
26
25
24
23
22

Rather than giving out all the numbers, let’s plot them on a chart:

doors_open.jpg

The pattern is somewhat unexpected: after some relatively large oscillations at the very beginning, the number of open doors oscillates around 250 doors until about the 250th employee, and, after that, it starts to decline quite regularly done. That’s interesting, but I’m not quite sure what to make of that.

So I decided to examine something else: let’s look at which doors are open at the end of the process. For this, I changed the last line of the Raku program to:

say join " ", grep {@rooms[$_]}, 1..MAX;

This is the output of this modified program:

$ perl6 hotel.p6
1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484

Now, that’s very interesting: one can immediately see that the open doors at the end of the process are those whose room number are perfect squares.

Some tests showed that this seems to remain true for other values of the MAX constant.

The reason for it seems to be the following: at the end of the process, a door is open if it has been changed an odd number of times and closed if it has been changed an even number of times. And, during the iterations, a door is changed each time the number being examined divides evenly the room number. In addition, perfect squares are the only numbers that have an odd number of unique divisors (for example, 16 has five unique divisors: 1, 2, 4, 8 16), so they are the only ones that are changed an odd number of times and correspond to doors that are open at the end of the process. Any number that is not a perfect square, by contrast, has an even number of divisors. This might be worth a more rigorous mathematical demonstration, but I guess you get the point.

So, finally, to list the doors which are open at the end of the process, we could just use a Perl one-liner:

$ perl -E 'say join " ", map {$_**2} 1..500**.5;'
1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484

Or a Raku one-liner:

$ perl6 -e 'say join " ", map {$_**2}, 1..500**.5;'
1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400 441 484

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

Perl Weekly Challenge 45: Square Secret Code and Source Dumper

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

Task # 1: Square Secret Code

The square secret code mechanism first removes any space from the original message. Then it lays down the message in a row of 8 columns. The coded message is then obtained by reading down the columns going left to right.

For example, the message is “The quick brown fox jumps over the lazy dog”.

Then the message would be laid out as below:

thequick
brownfox
jumpsove
rthelazy
dog

The code message would be as below:

tbjrd hruto eomhg qwpe unsl ifoa covz kxey

Write a script that accepts a message from command line and prints the equivalent coded message.

Square Secret Code in Perl

Let’s do a first program implementing the task exactly as described:

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

my $msg = shift // "The quick brown fox jumps over the lazy dog";
$msg =~ s/\s+//g;
$msg =~ s/(.{8})/$1\n/g;
my @lines = split /\n/, $msg;
for my $i (0..7) {
    print map { substr  $_, $i, 1 if length $_ >= $i} @lines;
    print " ";
}

This works as expected:

$ perl square.pl "The quick brown fox jumps over the lazy dog"
Tbjrd hruto eomhg qwpe unsl ifoa covz kxey

But we don’t really need to lay out the message over rows of 8 characters and can simplify a bit the code using an array of strings as follows:

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

my $msg = shift // "The quick brown fox jumps over the lazy dog";
$msg =~ s/\s+//g;
my @letters = map { /.{1,8}/g; } $msg;
for my $i (0..7) {
    print map { substr  $_, $i, 1 if length $_ >= $i} @letters;
    print " ";
}

This produces the same output as before.

Square Secret Code in Raku

Here, we’re just porting the second Perl version above:

use v6;

my $msg = @*ARGS ?? shift @*ARGS 
    !! "The quick brown fox jumps over the lazy dog";
$msg ~~ s:g/\s+//;
my @letters = map { ~ $_}, $msg ~~ m:g/ .**1..8/;
for 0..7 -> $i {
    print " ", join "", map { substr  $_, $i, 1 if .chars >= $i}, @letters;
    #print " ";
}

This displays the following output:

$ perl6 square.p6 "The quick brown fox jumps over the lazy dog"
 Tbjrd hruto eomhg qwpe unsl ifoa covz kxey

Task # 2: Source Dumper

Write a script that dumps its own source code. For example, say, the script name is ch-2.pl then the following command should return nothing.

$ perl ch-2.pl | diff - ch-2.pl

Source Dumper in Perl

In Perl, the $0 special variable contains the name of the program. So, it is just a matter of opening the file and printing its lines:

use strict;
use warnings;

my $progr = "./$0";
open my $IN, "<", $progr or die "Unable to open $progr $!";
print while <$IN>;
close $IN;

Running the program duly prints its contents:

$ perl pgm_dump.pl
use strict;
use warnings;

my $progr = "./$0";
open my $IN, "<", $progr or die "Unable to open $progr $!";
print while <$IN>;
close $IN;

And a diff between the program output and the program code prints out nothing:

$ perl pgm_dump.pl | diff - pgm_dump.pl

Source Dumper in Raku

In Raku, the program name (and path) is contained in the $?FILE compile-time variable. So solving the task is very easy:

use v6;

my $progr = "$?FILE";
$progr.IO.slurp.say;

which duly prints:

$ perl6 pgm_dump.p6
use v6;

my $progr = "$?FILE";
$progr.IO.slurp.say;

Actually, we don’t need the intermediate $progr variable:

use v6;

$?FILE.IO.slurp.say;

which also prints the expected output:

$ perl6 pgm_dump.p6
use v6;

$?FILE.IO.slurp.say;

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

About laurent_r

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