June 2019 Archives

Perl Weekly Challenge # 14: Van Eck's Sequence and US States

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

Challenge # 1: Van Eck's Sequence

Write a script to generate Van Eck’s sequence starts with 0. For more information, please check out wikipedia page. This challenge was proposed by team member Andrezgz.

Jan Ritsema van Eck's sequence is an integer sequence defined recursively as follows. Let a(0) = 0. Then, for n ≥ 0, if there exists an m < n such that a(m) = a(n), take the largest such m and set a(n+1) = n − m; otherwise a(n+1) = 0. Thus, the first occurrence of an integer in the sequence is followed by a 0, and the second and subsequent occurrences are followed by the size of the gap between the two most recent occurrences.

This time, I'll start with Perl 6 (but complete the challenge in both P5 and P6).

Van Eck's Sequence in Perl 6

The definition is quite simple, but, for some reason (maybe the heatwave striking a good part of Western Europe these days), it took me more time (about 30 minutes) than I expected to get it right. Anyway, here we go:

use v6;

my @a = 0,;
for ^20 -> $n {
    my $result = 0;
    for reverse ^$n -> $m {
        $result = $n - $m and last if @a[$m] == @a[$n];
            # Note: $m is always smaller than $n, so $n - $m > 0
    }
    push @a, $result;
}
say @a;

Not much to say about it: we just apply the definition, and the code is pretty small. This outputs the following sequence:

~ perl6 vaneck.p6
[0 0 1 0 2 0 2 2 1 6 0 5 0 2 6 5 4 0 5 3 0]

Since we have nested loops, I have been thinking whether it might be possible to store the values in a hash or a set, or use a junction, to avoid performing the inner loop when possible.

But looking at a longer version of the sequence, for example:

[0 0 1 0 2 0 2 2 1 6 0 5 0 2 6 5 4 0 5 3 0 3 2 9 0 4 9 3 6 14 0 6 3 5 15 0 5 3 5 2 17 0 6 11 0 3 8 0 3 3 1 42 0 5 15 20 0 4 32 0 3 11 18 0 4 7 0 3 7 3 2 31 0 6 31 3 6 3 2 8 33]

it appears that, except at the very beginning of the sequence, zeros are relatively rare, meaning that there are only few cases where we will go through the whole list and not find an $m within the inner loop. Therefore, there is probably no or little point trying to optimize away the inner loop by a lookup mechanism: we will not get a very significant performance improvement.

Maybe a solution using the gather/take construct to produce lazy lists would be more idiomatic Perl 6 code. Let's see what we can do.

use v6;

sub MAIN ( UInt $max ) {
    my @a = lazy gather {
        take 0;
        for 0..* -> $n {
            my $result = 0;
            for reverse ^$n -> $m {
                $result = $n - $m and last if @a[$m] == @a[$n];
            }
            take $result;
        }
    }
    say join " ", @a[0..$max];
}

It works and produces the same output as before, and using a lazy infinite list may look slightly more Perl-6-ish, but it does not make the code simpler, quite to the contrary. So, ultimately, I tend to prefer my first solution.

Van Eck's Sequence in Perl 5

Translating the first P6 version into P5 is very easy:

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

my $max = shift;
my @a = (0);
for my $n (0..$max - 1) {
    my $result = 0;
    for my $m (reverse 0..$n-1){
        $result = $n - $m and last if $a[$m] == $a[$n];
    }
    push @a, $result;
}
say "@a";

And this outputs the same as the P6 script:

    $ perl vaneck.pl 20
    0 0 1 0 2 0 2 2 1 6 0 5 0 2 6 5 4 0 5 3 0

The Longest English Word from 2-Letter US States Abbreviations

Using only the official postal (2-letter) abbreviations for the 50 U.S. states, write a script to find the longest English word you can spell? Here is the list of U.S. states abbreviations as per wikipedia page. This challenge was proposed by team member Neil Bowers.

The examples provided clarify the requirement:

Pennsylvania + Connecticut = PACT
Wisconsin + North Dakota = WIND
Maine + Alabama = MEAL
California + Louisiana + Massachusetts + Rhode Island = Calamari

We don't know, however, whether a State abbreviation can be used more than once. We'll assume it's possible, but there would probably very little to change to prohibit reuse of abbreviations if needed.

The list of 50 US States abbreviations used by the United States Postal Service taken from the above-mentioned Wikipedia page is as follows:

AL AK AZ AR CA CO CT DE DC FL GA HI ID IL IN IA KS KY LA ME MD MA MI MN MS MO MT NE NV NH NJ NM NY NC ND OH OK OR PA RI SC SD TN TX UT VT VA WA WV WI WY

My understanding is that the District of Columbia (DC) is not really a State (otherwise, there would be 51 States), so we will remove it from the list.

Just as for some previous challenges, I will use a words.txt file containing 113,809 lower-case English words usually accepted for crossword puzzles and other word games. The words.txt file can be found on my Github repository. The original list was contributed to the public domain by Internet activist Grady Ward in the context of the Moby Project. This word list is also mirrored at Project Gutenberg.

For the purpose of testing the programs below, the words.txt file is located in my current directory.

The word.txt input file contains words with only lowercase alphabetical ASCII characters. We'll probably need to turn them to upper case at some point (or to turn the State abbreviations to lower case).

Since all State abbreviations are 2-letter codes, we'll consider only words with an even number of letters. There are probably several ways to fulfill the requirement, but the simplest seems to break each word of our list into strings of two letters and to check whether each such string belongs to the State codes.

The Longest English Word in Perl 6

We first populate a Set with all the 50 State codes. Then we go through the word.txt file and, for each word with an even letter count, we break the word into pairs of characters and check whether each pair belongs to the set of State codes. If such is the case, we store the word in the $longest-word variable if it is longer than the previous value of $longest-word.

use v6;

my $codes = set < 
    AL AK AZ AR CA CO CT DE FL GA 
    HI ID IL IN IA KS KY LA ME MD 
    MA MI MN MS MO MT NE NV NH NJ 
    NM NY NC ND OH OK OR PA RI SC 
    SD TN TX UT VT VA WA WV WI WY >;

sub valid (Str $word) {
    for $word.uc.comb(2) -> $letter-pair {
        return False unless $letter-pair (elem) $codes;
    }
    return True;
}   

my $longest-word = "";
my $max-size = 0;
for "words.txt".IO.lines -> $word {
    next unless $word.chars %% 2;
    $longest-word = $word and $max-size = $word.chars 
        if valid $word and $word.chars > $max-size;
}
say $longest-word;

The longest word displayed on the screen when running the program is armorial, an eight-letter word.

Note that the $max-size variable isn't really needed, it is used only to cache the length of the current $longest-word in order to avoid recalculating it again and again each time through the loop and hopefully make the calculation a bit faster.

Adding a code line to print out intermediate results shows that my word list has in fact 13 eight-letter words made of US States postal codes:

armorial
calamine
gamodeme
ganymede
lavalava
mainland
malarial
mandarin
melamine
memorial
moorland
scincoid
utilidor

Also note that, since the program keeps track of the maximum size so far, it would be possible to improve performance by skipping words whose length is less than the longest candidate so far. But the script runs very fast (less than half a second), so I did not really bother to introduce this refinement.

Assuming we want to do it, the main loop of the above script would be rewritten as follows:

my $longest-word = "";
my $max-size = 0;
for "words.txt".IO.lines -> $word {
    my $length = $word.chars;
    next if $length % 2 or $length <= $max-size;
    $longest-word = $word and $max-size = $length 
        if valid $word;
}
say $longest-word;

With this change, the timing gets down to less than 0.3 second.

The Longest English Word in Perl 5

Perl 5 does not have sets, but we can use a hash instead. Also, to split the words of words.txt into two-letter strings, I use a regex. Otherwise, translating the code into Perl 5 is fairly straight forward:

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

my %codes = map { $_ => 1 } qw /
    AL AK AZ AR CA CO CT DE FL GA 
    HI ID IL IN IA KS KY LA ME MD 
    MA MI MN MS MO MT NE NV NH NJ 
    NM NY NC ND OH OK OR PA RI SC 
    SD TN TX UT VT VA WA WV WI WY /;

sub valid {
    my $word = uc shift;
    for my $letter_pair ( $word =~ /\w\w/g ) {
        return 0 unless defined $codes{$letter_pair};
    }
    return 1;
}

my $longest_word = "";
my $max_size = 0;
my $dict = "words.txt";
open my $IN, "<", $dict or die "Unable to open $dict $!";
while (my $word = <$IN>) {
    $word =~ s/[\n\r]+//g;
    next if length($word) % 2;  #skip if odd length
    $longest_word = $word and $max_size = length $word 
        if valid $word and length $word > $max_size;
}
say $longest_word;

And the printed result is again armorial.

The P5 script is a bit longer than the P6 script, but that's essentially because of some simple boiler-plate code needed in P5 (e.g. to open and read a file, etc.). I'm happy that I don't have to do that in P6, but that's not where P6 really shines brighter than P5.

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

Perl Weekly Challenge # 13: Fridays and Mutually Recursive Subroutines

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

Spoiler Alert: This weekly challenge deadline is due in several days from now (June 23, 2019). This blog post offers some solutions to this challenge, please don't read on if you intend to complete the challenge on your own.

Challenge # 1: Thank God, It's Friday

Write a script to print the date of last Friday of every month of a given year. For example, if the given year is 2019 then it should print the following:

2019/01/25
2019/02/22
2019/03/29
2019/04/26
2019/05/31
2019/06/28
2019/07/26
2019/08/30
2019/09/27
2019/10/25
2019/11/29
2019/12/27

Fridays in Perl 5

For this challenge, I'll use the Time::Local core module to generate dates within the given year (dates between the 21st and the 31st of each month) and the built-in gmtime function to find out if a given date occurs on a Friday. A small difficulty, however is that the timegm function of this module fails and exits if the date passed is invalid. So I used instead the timegm_nocheck which does not fail on, for example, Feb. 30, but returns in that case the epoch for Feb. 1. So, I only needed to check whether that function returned a different day in the month to stop the loop (the last statement in the code below) on non existing dates.

#!/usr/bin/perl
use strict;
use warnings;
use feature "say";
use Time::Local qw/timegm_nocheck/ ;


my $year = shift // 2019;
for my $month (0..11) {
    my @last_friday;
    for my $day (20..31) {
        my $epoch = 
            timegm_nocheck(0, 0, 12, $day, $month, $year - 1900);
        my @date_details = gmtime $epoch;
        last if $date_details[3] != $day;
        @last_friday = @date_details if $date_details[6] == 5;
    }
    printf "%d/%02d/%d\n", $year, $month + 1, $last_friday[3];
}

The script uses a parameter passed to it for the year and defaults to 2019 if no parameter is passed.

This outputs the following:

$ perl friday.pl
2019/01/25
2019/02/22
2019/03/29
2019/04/26
2019/05/31
2019/06/28
2019/07/26
2019/08/30
2019/09/27
2019/10/25
2019/11/29
2019/12/27

I admit that this program relies on a non-documented behavior, which is not the best and the cleanest. But I don't have much time this week to investigate other modules, as I'll attend a local Perl workshop in the second half of this week.

To avoid relying on non-documented behavior, it isn't difficult to determine the various month lengths, for example:

#!/usr/bin/perl
use strict;
use warnings;
use feature "say";
use Time::Local;

sub is_leap_year {
    my $year = shift;
    return $year % 4 == 0; # works for years between 1901 and 2099
}

my @month_lengths = qw/ 31 28 31 30 31 30 31 31 30 31 30 31/;
my $year = shift // 2019;

for my $month (0..11) {
    my $month_length = $month_lengths[$month];
    $month_length = 29 if $month == 1 
        and is_leap_year $year; # Feb is 1
    my @last_friday;
    for my $day (20..$month_length) {
        my $epoch = timegm(0, 0, 12, $day, $month, $year - 1900);
        my @date_details = gmtime $epoch;
        @last_friday = @date_details if $date_details[6] == 5;
    }
    printf "%d/%02d/%d\n", $year, $month + 1, $last_friday[3];
}

This works correctly, including for a year where the last Friday of February falls on Feb. 29:

$ perl friday.pl 2008
2008/01/25
2008/02/29
2008/03/28
2008/04/25
2008/05/30
2008/06/27
2008/07/25
2008/08/29
2008/09/26
2008/10/31
2008/11/28
2008/12/26

Note that the is_leap_year subroutine above is really computing Julian leap years, not Gregorian leap years commonly used nowadays, but that's fine for all years between 1901 to 2099. For years outside that range, we would need a full Gregorian leap year calculation, for example:

sub is_leap_year {
    my $year = shift;
    return 0 if $year % 4;   # not divisible by 4
    return 1 if $year % 100; # divisible by 4, not by 100
    return 0 if $year % 400; # divisible by 100, not by 400
    return 1;                # divisible by 400
}

Fridays in Perl 6

Perl 6 has powerful Date and DateTime data types which make date and time computations fairly easy. We could have nested loops for months ans days as in the P5 solution, but I decided to follow another path: we look at all the days of the year, filter out those that are not Fridays and print out the Fridays picked up just before any month change:

use v6;

sub MAIN (UInt $year = 2019) {
    my $year-length = 
        DateTime.new(:year($year)).is-leap-year ?? 366 !! 365;
    my $day = Date.new("$year-01-01");
    my $month = 1;
    my $last-friday;
    for 1..$year-length {
         $day = $day.succ;
         next unless $day.day-of-week == 5;
         if $day.month != $month {
            $month = $day.month;
            say $last-friday;
        }
        $last-friday = $day;
    }
    say $last-friday;
}

This prints out the same result as the P5 solution:

~ perl6 friday.pl6 2008
2008-01-25
2008-02-29
2008-03-28
2008-04-25
2008-05-30
2008-06-27
2008-07-25
2008-08-29
2008-09-26
2008-10-31
2008-11-28
2008-12-26

Challenge 2: Mutually Recursive Subroutines and Hofstadter Female and Male Sequences

Write a script to demonstrate Mutually Recursive methods. Two methods are mutually recursive if the first method calls the second and the second calls first in turn. Using the mutually recursive methods, generate Hofstadter Female and Male sequences.

 F ( 0 ) = 1   ;   M ( 0 ) = 0
 F ( n ) = n − M ( F ( n − 1 ) ) , n > 0
 M ( n ) = n − F ( M ( n − 1 ) ) , n > 0.

There is nothing complicated about mutually recursive subroutines. As with any recursive subroutine, you just need to make sure there is a base case to stop recursion (and that the base case will eventually be reached). The Wikipedia link provided in the question gives the beginning of the two sequences, which will help us checking our results:

F: 1, 1, 2, 2, 3, 3, 4, 5, 5, 6, 6, 7, 8, 8, 9, 9, 10, 11, 11, 12, 13, ... 
M: 0, 0, 1, 2, 2, 3, 4, 4, 5, 6, 6, 7, 7, 8, 9, 9, 10, 11, 11, 12, 12, ...

Hofstadter Female and Male Sequences in Perl 5

We just need to apply the mathematical definition:

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

sub female {
    my $n = shift;
    return 1 if $n == 0;   # base case
    return $n - male (female ($n - 1));
}
sub male {
    my $n = shift;
    return 0 if $n == 0;   #base case
    return $n - female (male ($n - 1));
}
say "Female sequence: ";
printf "%d ", female $_ for 0..30;
say "";
say "Male sequence:";
printf "%d ", male $_ for 0..30;
say "";

This displays the following output:

$ perl hofstadter.pl
Female sequence:
1 1 2 2 3 3 4 5 5 6 6 7 8 8 9 9 10 11 11 12 13 13 14 14 15 16 16 17 17 18 19
Male sequence:
0 0 1 2 2 3 4 4 5 6 6 7 7 8 9 9 10 11 11 12 12 13 14 14 15 16 16 17 17 18 19

Performance Problems for Large Input Values

The female and male subroutines will become very slow for (moderately) large input values. For example, changing the program to print only the female value of a number passed as an argument to the program (and removing the deep recursion warnings with a no warnings "recursion"; pragma), I obtain the following run times for input values 50, 100, 150 and 200:

$ time perl hofstadter.pl 50
Female sequence:
31

real    0m0,054s
user    0m0,015s
sys     0m0,030s

Laurent@LAPTOP-LHI8GLRC ~
$ time perl hofstadter.pl 100
Female sequence:
62

real    0m0,866s
user    0m0,828s
sys     0m0,031s

Laurent@LAPTOP-LHI8GLRC ~
$ time perl hofstadter.pl 150
Female sequence:
93

real    0m11,728s
user    0m11,656s
sys     0m0,047s

Laurent@LAPTOP-LHI8GLRC ~
$ time perl hofstadter.pl 200
Female sequence:
124

real    1m29,175s
user    1m28,984s
sys     0m0,030s

As it can be seen, execution times grow very fast even for moderate increases of the input value: 0.86 sec for 100, 11.7 sec for 1500 and 89 sec for 200. The figures are typical of an exponential complexity (the durations are more or less multiplied by 10 each time you add 50 to the input value). This isn't gonna work if you want significantly larger input values.

Solving the Performance Problem with the Memoize Module

For larger input values, it would be necessary to cache the intermediate results to avoid recomputing them again and again. For this, we can use Mark Jason Dominus's Memoize core module, which does the caching (or, more precisely, memoization) for you with very little effort:

#!/usr/bin/perl
use strict;
use warnings;
use feature "say";
no warnings "recursion";
use Memoize;

memoize('female', 'male');

sub female {
    my $n = shift;
    return 1 if $n == 0;   # base case
    return $n - male (female ($n - 1));
}
sub male {
    my $n = shift;
    return 0 if $n == 0;   #base case
    return $n - female (male ($n - 1));
}
say "Female sequence: ";
say female shift;

Now the execution times become small (less than 0.1 sec for an input value of 200) and no longer grow exponentially:

$ time perl hofstadter.pl 100
Female sequence:
62

real    0m0,072s
user    0m0,015s
sys     0m0,015s

Laurent@LAPTOP-LHI8GLRC ~
$ time perl hofstadter.pl 150
Female sequence:
93

real    0m0,085s
user    0m0,015s
sys     0m0,046s

Laurent@LAPTOP-LHI8GLRC ~
$ time perl hofstadter.pl 200
Female sequence:
124

real    0m0,093s
user    0m0,046s
sys     0m0,030s

For an input value of 200, the program now runs almost 1,000 times faster. Even with an input value of 1000, the run time is less than a second (real: 0,829s).

Of course, it wouldn't be very complicated to do the caching yourself, but I wanted to use the opportunity to show this beautiful Memoize module, which so simple to use (I've just added two very simple code lines) and so efficient. Take a look at the Perl 6 version below if you want some ideas on how to do the caching manually.

Hofstadter Female and Male Sequences in Perl 6

Very little change (basically only the introduction of subroutine signatures) is required to translate the first P5 version into Perl 6:

use v6;

sub female (UInt:D $n) {
    return 1 if $n == 0;   # base case
    return $n - male (female ($n - 1));
}
sub male (UInt:D $n) {
    return 0 if $n == 0;   #base case
    return $n - female (male ($n - 1));
}
say "Female sequence:";
printf "%d ", female $_ for 0..30;
say "";
say "Male sequence:";
printf "%d ", male $_ for 0..30;

This displays the same as the P5 version:

Female sequence:
1 1 2 2 3 3 4 5 5 6 6 7 8 8 9 9 10 11 11 12 13 13 14 14 15 16 16 17 17 18 19
Male sequence:
0 0 1 2 2 3 4 4 5 6 6 7 7 8 9 9 10 11 11 12 12 13 14 14 15 16 16 17 17 18 19

Using Multi Subs for Dealing With the Base Case

Perl 6 has the notion of multi subs, which might be used for dealing with the base case needed to stop recursion. Multi subs are subroutines with the same name but a different signature to deal with different cases.

multi sub female (0) { 1; }   # base case
multi sub female (UInt:D $n) {
    return $n - male (female ($n - 1));
}
multi sub male (0) { 0; }    # base case
multi sub male (UInt:D $n) {
    return $n - female (male ($n - 1));
}
say "Female sequence:";
printf "%d ", female $_ for 0..30;
say "";
say "Male sequence:";
printf "%d ", male $_ for 0..30;

This prints the same output as before.

The Performance Problem, Again

Of course, for large input values, we have the same performance problem as in Perl 5, except that it is even worse since Perl 6 is currently significantly slower than Perl 5.

Let's change the script to compute only one female value and measure the time taken:

use v6;

sub female (UInt:D $n) {
    return 1 if $n == 0;   # base case
    return $n - male (female ($n - 1));
}
sub male (UInt:D $n) {
    return 0 if $n == 0;   #base case
    return $n - female (male ($n - 1));
}
sub MAIN (UInt $input) {
    say "Female $input: ", female $input;
    say "Time taken: ", now - INIT now;
}

These are the execution times for input values 50 and 100:

~ perl6 hofstadter.p6 50
Female 50: 31
Time taken: 0.2816245

Laurent@LAPTOP-LHI8GLRC ~
~ perl6 hofstadter.p6 100
Female 100: 62
Time taken: 10.96803473

They are quite bad.

Caching the Intermediate Results for Solving the Performance Problem

I do not think that Mark Jason Dominus's Memoize module has been ported yet to Perl 6. So let's see how we can cache manually the intermediate results.

We are storing intermediate results in the @*female and @*male dynamic-scope arrays. When the result exists in the array, we just return it, and we compute it and store it in the array when the result is not known yet (and implicitly return the result in the array in that case). Note that the two base cases are now handled through the initialization of the @*female and @*male arrays

use v6;

sub female (UInt:D $n) {
    return @*female[$n] if defined @*female[$n];
    @*female[$n] = $n - male (female ($n - 1));
}
sub male (UInt:D $n) {
    return @*male[$n] if defined @*male[$n];
    @*male[$n] = $n - female (male ($n - 1));
}
sub MAIN (UInt $input) {
    my @*female = 1,;
    my @*male = 0,;
    say "Female $input: ", female $input;
    say "Time taken: ", now - INIT now;
}

Now, this is very fast:

~ perl6 hofstadter.p6 50
Female 50: 31
Time taken: 0.0124059

Laurent@LAPTOP-LHI8GLRC ~
~ perl6 hofstadter.p6 100
Female 100: 62
Time taken: 0.02777636

For the female of 1,000, it seems that our manually optimized P6 program runs even much faster than the memoized Perl 5 version:

~ perl6 hofstadter.p6 1000
Female 1000: 618
Time taken: 0.0585017

Once again, point demonstrated: yes, unfortunately, Perl 6 is currently significantly slower than Perl 5, but that may not matter very much if you take the time to optimize your algorithm when possible. The hand-crafted caching done in the program above took about 10 minutes of my time.

Wrapping up

The next week Perl Weekly Challenge is due to start soon. If you want to participate to this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 6 p.m. BST (British summer time) on Sunday, June 30. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge # 12: Euclid's Numbers and Directories

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

Spoiler Alert: This weekly challenge deadline is due in several days from now (June 16, 2019). This blog post offers some solutions to this challenge, please don't read on if you intend to complete the challenge on your own.

Challenge # 1: Euclid's Numbers

The numbers formed by adding one to the products of the smallest primes are called the Euclid Numbers (see wiki). Write a script that finds the smallest Euclid Number that is not prime. This challenge was proposed by Laurent Rosenfeld.

I did not even remember I proposed this challenge to my friend Mohammad Anwar.

So far, in my blogs about the Perl Weekly Challenge, I have always prepared and presented the Perl 5 solutions first and then the Perl 6 solutions, as it seems to be slightly more natural to do it in this order. This time, for a change, I'll do it the other way around and start with a Perl 6 solution. This way, I'll not be tempted to just translate a P5 solution into P6.

Euclid's Numbers in Perl 6

For this, we can use two infinite (lazy) lists: one for the primes and one for Euclid's numbers, and then pick up the first Euclid's number that is not prime:

use v6;

my @primes = grep {.is-prime}, 1..*;
my @euclids = map {1 + [*] @primes[0..$_]}, 0..*;
say @euclids.first(not *.is-prime);

which prints 30031 (which is not prime as it is the product 59 × 509).

Note that we don't really need to populate an intermediate temporary array with Euclid's numbers and can find directly the first such number that is not prime:

use v6;

my @primes = grep {.is-prime}, 1..*;
say (map {1 + [*] @primes[0..$_]}, 0..*).first(not *.is-prime);

But it probably wouldn't make much sense to also try to get rid of the @primes array, because we are in fact using it many times in the process of computing Euclid's numbers, so it is probably better to cache the primes.

Euclid's Numbers in Perl 5

For this challenge, I reused the find_primes and is_prime subroutines that I described in some details in my previous blog post about Perl Weekly Challenge 8 on perfect numbers (and some other earlier posts). Please refer to that blog if you need explanations on these subroutines. Once you have these subroutines to generate a list of prime numbers, generating a list of Euclid's numbers and checking whether each generated Euclid's number is prime is straight forward:

#!/usr/bin/perl
use strict;
use warnings;
use feature "say";
use constant largest_num => 1000;

sub find_primes {
    my $num = 3;
    my @primes = (2, 3);
    while (1) {
        $num += 2;     # check only odd numbers
        last if $num > largest_num;
        my $limit = int $num ** 0.5;
        my $num_is_prime = 1;
        for my $prime (@primes) {
            last if $prime > $limit;
            if ($num % $prime == 0) {
                # $num evenly divided by $prime, exit the for loop
                $num_is_prime = 0;
                last;
            }
        }
        push @primes, $num if $num_is_prime;
    }
    return @primes;
}

my @prime_numbers = find_primes;  

sub is_prime {
    my $num = shift;
    my $limit = 1 + int $num ** 0.5;
    for my $p (@prime_numbers) {
        return 1 if $p > $limit;
        return 0 if $num % $p == 0;
    }
    warn "Something got wrong (primes list too small)\n";
    return 0; # If we've reached this point, then our list of 
              # primes is too small, we don't know if the argument
              # is prime, issue a warning and return a false 
              # value to be on the safe side of things
}

for my $i (0..20) {
    my $euclid_1 = 1;
    $euclid_1 *= $prime_numbers[$_] for 0..$i;
    my $euclid = $euclid_1 + 1;
    say $euclid and last unless is_prime $euclid;   
}

The program displays the following output:

$ perl euclid.pl
30031

Common Directory Paths

Write a script that finds the common directory path, given a collection of paths and directory separator. For example, if the following paths are supplied:

/a/b/c/d
/a/b/cd
/a/b/cc
/a/b/c/d/e

and the path separator is /. Your script should return /a/b as common directory path.

Common Directory Paths in Perl 6

For this, I created the compare-paths subroutine to compare two paths, and then use the reduce built-in function to apply compare-paths to the whole list of paths:

use v6;
sub compare-paths ($a, $b) {
    join $*sep, 
        gather for $a.split($*sep) Z $b.split($*sep) -> ($p, $q) {
            last unless $p eq $q;
            take $p;
        }
}
my $*sep = '/';
my @paths = </a/b/c /a/b/c/e /a/b/c/d/e /a/b/c/f>;
say reduce &compare-paths, @paths;

which duly displays /a/b/c.

The compare-paths subroutine splits both paths on the separator, uses the "zip" operator to create pairs of path parts and checks which parts are equal. The gather/take construct picks up the parts that are the same and returns the corresponding path.

Another way to solve the challenge would be to create a new compare-paths operator and use the [] reduction meta-operator to generate the result:

use v6;
sub infix:<compare-paths> ($a, $b) {
    join $*sep, 
        gather for $a.split($*sep) Z $b.split($*sep) -> ($p, $q) {
            last unless $p eq $q;
            take $p;
        }
}
my $*sep = '/';
my @paths = </a/b/c /a/b/c/e /a/b/c/d/e /a/b/c/f>;
say [compare-paths] @paths;

Common Directory Paths in Perl 5

Here is a way to do it in Perl 5:

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

die "This program needs a separator and at least 2 paths\n" 
    if @ARGV < 3;
my ($separator, @paths) = @ARGV;
chomp @paths;
my @common_path = split $separator, shift @paths;
for my $new_path (@paths) {
    my @new_path_pieces = split $separator, $new_path;
    my $min_length = @new_path_pieces < @common_path ? 
        @new_path_pieces : @common_path;
    for my $i (0..$min_length - 1) {
        if ($common_path[$i] ne $new_path_pieces[$i]) {
            @common_path = @common_path[0..$i-1];
            last;
        }
    }
}
say join $separator, @common_path;

Note, however, that the List::Util core module also provides a reduce subroutine making it possible to create a solution similar to the P6 solution:

#!/usr/bin/perl
use strict;
use warnings;
use feature "say";
use List::Util qw/reduce/;

sub compare {
    my ($sep, $p1, $p2) = @_;
    my @path1 = split /$sep/, $p1;
    my @path2 = split /$sep/, $p2;
    my $min_length = @path1 < @path2 ? @path1 : @path2;
    for my $i (0..$min_length - 1) {
        if ($path1[$i] ne $path2[$i]) {
            return join $sep, @path1[0..$i-1];
        }
    }
    return join $sep, @path1[0..$min_length - 1];
}

die "This program needs a separator and at least 2 paths\n" 
    if @ARGV < 3;
my ($separator, @paths) = @ARGV;
chomp @paths;
say reduce {compare($separator, $a, $b)} @paths;

The Perl 5 solution is still much less concise than the Perl 6 solution.

Wrapping up

The next week Perl Weekly Challenge is due to start soon. If you want to participate to this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 6 p.m. BST (British summer time) on Sunday, June 23. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge # 11: Fahrenheit Celsius and Identity Matrix

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

Spoiler Alert: This weekly challenge deadline is due in several days from now (June 9, 2019). This blog post offers some solutions to this challenge, please don't read on if you intend to complete the challenge on your own.

Challenge # 1: Fahrenheit and Celsius Scales Intersection

Write a script that computes the equal point in the Fahrenheit and Celsius scales, knowing that the freezing point of water is 32 °F and 0 °C, and that the boiling point of water is 212 °F and 100 °C. This challenge was proposed by Laurent Rosenfeld.

While it is very easy to do the math by hand, find that $Tf = 9/5 * $Tc + 32 and then solve the linear equation x = 9/5 x + 32, it turns out that it is a little bit more complex to write a program doing that with a general purpose programming language. I guess it is probably easy with symbolic or algebraic computation software such as Maple, Mathematica, or Scilab. I'm working on a solution that might do that, but I'm not sure when it will be ready (and even whether it will work out the way I hope). Here we'll use successive numerical approximations.

Fahrenheit Celsius in Perl 5

In the code below, the $speed_diff variable measures the difference of variation between the two scales. It is the coefficient of the slope of the straight line representing one scale compared to another in a graphic representation (and its value is 9/5, or 1.8). In other word, if you move on the Celsius scale by 1 °, you have to move on the Fahrenheit scale by 1.8 °.

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

my %freeze = (F => 32, C => 0);
my %boil = (F => 212, C => 100);
my $speed_diff = ($boil{F} - $freeze{F} ) /($boil{C} - $freeze{C} ) ;

my $c = $freeze{C};
my $f = $freeze{F};

while (abs($c - $f) > 0.2) {
    $f += ($c - $f)/2;
    $c +=  ( ($c - $f) / $speed_diff );
    # say "Approx: $c $f ", $c-$f; # De-comment this line to see the intermediate results 
} 
printf "Fahrenheit and Celsius scales meet at: %.0f\n", $c;

The program displays the following final result (after about 20 iterations):

$ perl Fahrenheit.pl
Fahrenheit and Celsius scales meet at: -40

Note that we use two hashes to store the input values without hard-coding them, but we could have used 4 variables.

Fahrenheit Celsius in Perl 6

Translating the same program in Perl 6 is easy:

use v6;

#`{ Write a script that computes the equal point in the Fahrenheit 
    and Celsius scales, knowing that the freezing point of water 
    is 32 °F and 0 °C, and that the boiling point of water is 212 °F 
    and 100 °C.
  }


my %freeze = (F => 32, C => 0);
my %boil = (F => 212, C => 100);
my $speed_diff = (%boil<F> - %freeze<F> ) / (%boil<C> - %freeze<C> );

my $c = %freeze<C>;
my $f = %freeze<F>;

while abs($c - $f) > 0.2 {
    $f += ($c - $f)/2;
    $c +=  ( ($c - $f) / $speed_diff );
    # say "Approx: $c $f ", $c-$f;
} 
say "Fahrenheit and Celsius scales meet at: ", $c.fmt("%.0f");

And we obtain the same value as in P5 (-40, i.e. -40 °C and -40 °F).

Note that Perl 6 has an approximately-equal operator (=~=) that could have been used in the while loop for comparing $c and $f, but using it would require to first set the tolerance value, so the benefit is limited when used only once. This part of the program could look like this:

{
    my $*TOLERANCE = .01;
    while not $c =~= $f  {
        $f += ($c - $f)/2;
        $c +=  ( ($c - $f) / $speed_diff );
        # say "Approx: $c $f ", $c-$f; 
    } 
}

The $*TOLERANCE value is relative tolerance, not absolute tolerance, so I had to use another value (1%) than the absolute tolerance hard-coded in the original while loop. In brief, using this functionality does not simplify the code for the case in point.

Challenge # 2: Identity Matrix

Write a script to create an Identity Matrix for the given size. For example, if the size is 4, then create Identity Matrix 4x4. For more information about Identity Matrix, please read the Wikipedia page.

An identity matrix is a square matrix with ones on the main diagonal (top left to bottom right) and zeroes everywhere else.

Identity Matrix in Perl 5

Let's start with a boring plain-vanilla solution using two nested loops, as I would probably do in C, Pascal, Ada, or Java:

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

my $size = shift() - 1;
my @matrix;
for my $i (0..$size) {
    for my $j (0..$size-1) {
        if ($i == $j) {
            $matrix[$i][$j] = 1;
        } else {
            $matrix[$i][$j] = 0;
        }
    }
}
say Dumper \@matrix;

When the row index ($i) is equal to the column index ($j), we populate the item with a one. Otherwise, we fill with zeroes.

This program displays the following:

$ perl matrix.pl 3
$VAR1 = [
          [
            1,
            0,
            0
          ],
          [
            0,
            1,
            0
          ],
          [
            0,
            0,
            1
          ]
        ];

One problem here is that the Data::Dumper module is good to show the data structure in general, but it requires here some careful check to see that this is an identity matrix.

Let's improve our script by adding a subroutine to pretty print our matrix. While we are at it, let's also simplify the code by replacing the if ... else conditional with a ternary operator:

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

sub pretty_print {
    my $matrix_ref = shift;
    for my $rows (@$matrix_ref) {
        say join " ", @$rows;
    }
}

my $size = shift() - 1;
my @matrix;
for my $i (0..$size) {
    for my $j (0..$size) {
        $matrix[$i][$j] = $i == $j ? 1 : 0;
    }
}
pretty_print \@matrix;

Now, the output really looks like an identity matrix:

$ perl matrix.pl 4
1 0 0 0
0 1 0 0
0 0 1 0
0 0 0 1

We could further simplify the code of the nested loops:

for my $i (0..$size) {
    $matrix[$i][$_] = $i == $_ ? 1 : 0 for 0..$size;
}

But that simplification is only mildly interesting. Perhaps, we can do better with the functional paradigm.

Identity Matrix in Functional Perl 5

In my Perl Weekly Challenge # 9: Square Numbers and Functional Programming in Perl blog post on May 26, 2019, I showed some ways to use the functional programming style both in Perl 5 and Perl 6, especially the data stream or data pipeline model. Remember especially that map takes a list of items (e.g. an array) as parameter, applies some transformation to each item, and returns the list of modify items.

Let's use the same techniques for the identity matrix challenge:

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

sub prettify {
    my $matrix = shift;
    return join "\n", map { join " ", @$_ } @$matrix;
}

my $size = shift() - 1;
my @matrix = map { my $i = $_; [map { $i == $_ ? 1 : 0 } 0..$size] }
    0..$size;
say prettify \@matrix;

Note that, since we're aiming at doing functional programming, we have replaced the pretty_print subroutine by a pure function, prettify, with no side effect: it does not print anything, but only returns a printable formatted string, which the user may then decide to print (as we did here), or may possibly do something else, such as storing it into a file for future use.

The script displays the same formatted output as before:

$ perl matrix.pl 5
1 0 0 0 0
0 1 0 0 0
0 0 1 0 0
0 0 0 1 0
0 0 0 0 1

Identity Matrix in Perl 6

I was initially tempted to provide only a functional implementation in Perl 6, but for the benefit of Perl 6 beginners who might read this blog post, I'll start with the plain-vanilla nested loops as in P5:

use v6;

sub pretty-print (@matrix) {
    for @matrix -> @rows {
        say join " ", @rows;
    }
}
sub MAIN (Int $size where * > 0) {
    my @matrix;
    $size--;
    for 0..$size -> $i {
        for 0..$size -> $j {
            @matrix[$i][$j] = $i == $j ?? 1 !! 0;
        }
    }
    pretty-print @matrix;
}

Here, we are using the MAIN subroutine to process the argument passed to the script (which, in this case, must be a strictly positive integer).

The output is the same as in P5:

~ perl6 matrix.p6 5
1 0 0 0 0
0 1 0 0 0
0 0 1 0 0
0 0 0 1 0
0 0 0 0 1

And if the user omits to pass a parameter (or passes an invalid one), a convenient usage line is printed to the screen:

~ perl6 matrix.p6
Usage:
  matrix.p6 <size>

Also note that we don't need in Perl 6 the syntax complications associated with references and dereferencing in P5.

Identity Matrix in Functional Perl 6

A functional implementation in P6 may look like this:

use v6;

sub prettify (@matrix) {
    return join "\n", map { join " ", $_}, @matrix;
}
sub MAIN (Int $size where * > 0) {
    my @matrix = map { my $i = $_; map { $i == $_ ?? 1 !! 0 }, 
        0..$size },  0..$size;
    say prettify @matrix;
}

Note that the populating the identity matrix takes only one code line. The rest is really for prettifying the result and printing it.

We could also use data pipelines with chained method invocations:

sub prettify (@matrix) {
    @matrix.map({join(" ",$_)}).join("\n");
}
sub MAIN (Int $size where * > 0) {
    say prettify (1..$size).map( -> $i
         { (1..$size).map( { $_ == $i ?? 1 !! 0 })});
}

although I'm not really convinced this is any better, as it is a bit difficult to get these pesky closing parentheses and curly brackets right.

Wrapping up

There was a third challenge this week: Using Open Weather Map API, write a script to fetch the current weather for an arbitrary city. Note that you will need to sign up for Open Weather Map’s free tier and then wait a couple hours before your API key will be valid. This challenge was proposed by Joelle Maslak. The API challenge is optional but would love to see your solution.

As mentioned in earlier blog posts, I know next to nothing about this kind of topic, so I won't undertake anything on that subject and even less blog about it. Please try this challenge and provide answers if you know more that I do on such topic.

The next week Perl Weekly Challenge is due to start soon. If you're interested in participating in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 6 p.m. BST (British summer time) on Sunday, June 16. 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 Perl (5 and 6).