laurent_r

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.