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

Spoiler Alert: This weekly challenge deadline is due in a few days (November 3, 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.

This week, both tasks were contributed by Neil Bowers.

Task # 1: Word Histogram

Create a script that either reads standard input or one or more files specified on the command-line. Count the number of times and then print a summary, sorted by the count of each entry.

So with the following input in file example.txt:

apple
banana
apple
cherry
cherry
apple

the script would display something like:

apple     3
cherry    2
banana    1

For extra credit, add a -csv option to your script, which would generate:

apple,3
cherry,2
banana,1

In other words, we’re supposed to make an histogram reporting the frequency of various words in the input.

Word Histogram in Perl 5

It is just a matter of collecting the frequency data in a %histo hash and then sort and printing the values.

#!/usr/bin/perl
use strict;
use warnings;

my %histo;
while (<>) {
    chomp;
    s/\s+$//;
    next if /^\s*$/; # skipping empty lines
    $histo{$_}++;
}
for my $key (sort { $histo{$b} <=> $histo{$a} } keys %histo) {
    printf "%-20s%d\n", $key, $histo{$key};
}

We can use the shell echo command to pipe some values into the script standard input:

$ echo 'apple
> banana
> apple
> cherry
> cherry
> apple' | perl word_histo.pl
apple               3
cherry              2
banana              1

CSV Extra Credit

For the extra credit, I’ll first create an actual word_test.txt test file:

$ cat word_test.txt
apple
banana
apple
cherry
cherry
apple

The new script will take a first parameter (0 or 1) to determine if the output should be fixed columns as before or CSV. The other parameter(s) will be one or several word files. And, for such a simple CSV, I’ll just do it manually and simply use two different formatting strings for printf. I know some people are adamant on using a CSV module, not me (well, at least, not for such a simple case): no one needs a 40-ton truck to deliver a book shipped by Amazon somewhere in a suburb or in the countryside.

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

my %histo;
my $csv_flag = shift;

while (<>) {
    chomp;
    s/\s+$//;
    next if /^\s*$/; # skipping empty lines
    $histo{$_}++;
}
my $format = $csv_flag ? "%s,%d\n" : "%-20s%d\n";

for my $key (sort { $histo{$b} <=> $histo{$a} } keys %histo) {
    printf $format, $key, $histo{$key};
}

Now, running the script with two file parameters (actually twice the name of the word_test.txt input file just created), once with the first parameter set to a false value (0) and once with it set to a true value (1) to get CSV output:

$ perl word_histo2.pl 0  word_test.txt word_test.txt
apple               6
cherry              4
banana              2

$ perl word_histo2.pl 1  word_test.txt word_test.txt
apple,6
cherry,4
banana,2

Word Histogram in Perl 6/Raku

In Perl 6/Raku, rather than using a hash, we can use a Bag to directly assign frequencies when reading the input files. Sorting the histogram can also be made simpler than in Perl 5: if the code block or subroutine passed to the sort built-in funtion accepts only one parameter, then this code block is not a comparison block or subroutine, but a code object implementing the transformation to be applied to the items to be sorted before using the default cmp comparison routine. Here, the {$histo{$_}} code block passed to the sortfunction, says that sort should apply the standard cmp comparison routine to the values associated with the keys that we want to sort. In addition, the P6/Raku cmp comparison routine and sort built-in function are clever enough to see that they are comparing integers and should therefore apply a numeric sort to the data.

use v6;

sub MAIN (*@files) {
    my $histo = @files.map({.IO.lines}).Bag;
    for reverse sort {$histo{$_}}, keys $histo -> $key {
        printf "%-20s%d\n", $key, $histo{$key};
    }
}

If you prefer another syntax, the histo assignment at the beginning could also be written as follows:

my $histo = (map {.IO.lines}, @files).Bag;

This program correctly takes into account the files passed as a parameter. For example, passing twice the same word_test.txt input file as before in P5:

$ perl6 word_histo.p6 word_test.txt word_test.txt
apple               6
cherry              4
banana              2

Note that there is (in Perl 6.d) a new IO.CatHandle class for seamlessly gathering input from multiple files, but this did not appear to be necessary here.

Extra Credit: CSV Option

For the extra credit, we could just try to add an optional parameter (with a default value), a Boolean flag to decide whether we want CSV output, and then change the printf formatting string according to its value:

sub MAIN (Int $csv = 0, *@files) { # ...

but that does not really work as expected when no CSV flag argument is passed to the program. It appears that an optional parameter cannot be put before a mandatory one. Changing the order of the arguments does not help, because an optional parameter cannot be put after variadic parameters.

We will therefore use two multi MAIN subroutines to handle cases where a Boolean flag is passed and those where there no such flag. These MAIN subroutines will populate a $*format dynamic scope variable and then call the same readfiles subroutine:

use v6;
subset file of Str where *.IO.f;

multi sub MAIN (Int $csv, *@files where all(@files) ~~ file) {
    my $*format = $csv ?? "%s,%d\n" !! "%-20s%d\n";
    readfiles @files;
}
multi sub MAIN (*@files where all(@files) ~~ file) {
    my $*format = "%-20s%d\n";
    readfiles @files;
}
sub readfiles (@files) {
    my $histo = @files.map({.IO.lines}).Bag;
    for reverse sort {$histo{$_}}, keys $histo -> $key {
        printf $*format, $key, $histo{$key};
    }
}

This can be tested with or without a CSV flag:

$ perl6 word_histo2.p6 word_test.txt word_test.txt
apple               6
cherry              4
banana              2

$ perl6 word_histo2.p6 1 word_test.txt word_test.txt
apple,6
cherry,4
banana,2

$ perl6 word_histo2.p6 0 word_test.txt word_test.txt
apple               6
cherry              4
banana              2

Using Named Parameters

So, now, this works properly, but we may still have a slight problem if the name of the file passed as an argument is a plain integer: this would become ambiguous, and the Moar virtual machine might not be able to tell an integer from a file. This can be solved with named arguments for the Boolean CSV flag, which will also make it possible to write shorter and simpler code:

use v6;
subset file of Str where *.IO.f;

sub MAIN (Bool :$csv, *@files where all(@files) ~~ file) {
    my $format = $csv ?? "%s,%d\n" !! "%-20s%d\n";
    my $histo = @files.map({.IO.lines}).Bag;
    for reverse sort {$histo{$_}}, keys $histo -> $key {
        printf $format, $key, $histo{$key};
    }
}

Now, we need to pass a --csv argument when calling the program at the CLI in order to activate the CSV format:

$ perl6 word_histo2.p6 word_test.txt word_test.txt
apple               6
cherry              4
banana              2

$ perl6 word_histo2.p6 --csv word_test.txt word_test.txt word_test.txt
apple,9
cherry,6
banana,3

Task 2: ASCII Bar Chart

Write a function that takes a hashref where the keys are labels and the values are integer or floating point values. Generate a bar graph of the data and display it to stdout.

The input could be something like:

$data = { apple => 3, cherry => 2, banana => 1 };
generate_bar_graph($data);

And would then generate something like this:

 apple | ############
cherry | ########
banana | ####

If you fancy then please try this as well: (a) the function could let you specify whether the chart should be ordered by (1) the labels, or (2) the values.

ASCII Bar Chart in Perl 5

There is really nothing complicated in generating the bars of the chart: we just need to use the x string repetition operator with the fruit values. However, I would like to standardize somehow the size of output, irrespective of the absolute values. For this, the program loops over the hash a first time to collect the minimum and maximum values, and computes a scaling factor as 10 / ($max - $min), and then uses that $scale_factor for standardizing the length of the bars, so that the bar graph has about the same size for values of 4, 6, and 9 as for values of 40, 60 and 90. The hard coded value of 10 arbitrarily chosen here simply means that the spread between the smallest and the largest value will be represented by 10 units (concretely, 10 # characters). I could have chosen another value, but I wanted the bar graphs to keep relatively small to make sure they remain correctly formatted within the limited page width of this blog post.

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

sub generate_chart {
    my %data = %{$_[0]};
    my ($max, $min);
    for my $key (keys %data) {
        ($max, $min) = ($data{$key}, $data{$key}) unless defined $max;
        $max = $data{$key} if $data{$key} > $max;
        $min = $data{$key} if $data{$key} < $min;
    }
    my $scale_factor = 10 / ($max - $min);
    for my $key (sort { $data{$b} <=> $data{$a} } keys %data) {
        printf "%15s | %s\n", $key, "#" x ($data{$key} * $scale_factor);
    }
}
my $data = { apple => 30, cherry => 60, banana => 10, pear => 40 };
generate_chart $data;

This generates the following output:

$ perl ascii_chart.pl
         cherry | ############
           pear | ########
          apple | ######
         banana | ##

With this scaling, if we now use the following hashref with all values ten times smaller:

my $data = { apple => 3, cherry => 6, banana => 1, pear => 4 };

the program generates more or less the same output (there may occasionally be some slight rounding differences):

$ perl ascii_chart.pl
         cherry | ############
           pear | ########
          apple | ######
         banana | ##

Ordering the Bar Chart in Accordance with Labels or Values

For ordering the bar chart in accordance with labels or values, we could simply have two for loops for printing out the bar chart and use one or the other loop depending on the ordering we selected. But that’s code repetition, and I don’t like to do that for numerous reasons, the main one being that, sometimes in the future, a person in charge of maintaining the project is likely to modify one of the loops and forget to modify the other accordingly. So let’s try to keep it DRY (“don’t repeat yourself”).

The solution suggested here uses a $sort_routine variable containing an anonymous subroutines as a first argument to the sortbuilt-in function. Depending on the $sort_type (label or value) passed to the program, the $sort_routine code reference will contain different code (value will be the default if no argument is passed):

    my $sort_routine = ($sort_type =~ /val/i) 
        ? sub { $data{$b} <=> $data{$a} } 
        : sub {$a cmp $b };

The full program now looks like this:

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

sub generate_chart {
    my %data = %{$_[0]};
    my $sort_type = $_[1] // "val";
    my ($max, $min);
    for my $key (keys %data) {
        ($max, $min) = ($data{$key}, $data{$key}) unless defined $max;
        $max = $data{$key} if $data{$key} > $max;
        $min = $data{$key} if $data{$key} < $min;
    }
    my $scale_factor = 10 / ($max - $min);
    my $sort_routine = ($sort_type =~ /val/i) 
        ? sub { $data{$b} <=> $data{$a} } 
        : sub {$a cmp $b }; 
    for my $key (sort $sort_routine keys %data) {
        printf "%15s | %s\n", $key, "#" x ($data{$key} * $scale_factor);
    }
}
my $sort_type = shift;
my $data = { cherry => 20, apple => 30,  banana => 10, pear => 25};
generate_chart $data, $sort_type;

This is the output generated with various arguments passed to the program:

$ perl ascii_chart2.pl
          apple | ###############
           pear | ############
         cherry | ##########
         banana | #####

$ perl ascii_chart2.pl value
          apple | ###############
           pear | ############
         cherry | ##########
         banana | #####

$ perl ascii_chart2.pl label
          apple | ###############
         banana | #####
         cherry | ##########
           pear | ############

ASCII Bar Chart in Perl 6/Raku

For a start, we will use the same approach as in Perl 5 to scale the bar graph:

use v6;

sub generate_chart (%data) {
    my ($max, $min);
    for keys %data -> $key {
        ($max, $min) = (%data{$key}, %data{$key}) unless defined $max;
        $max = %data{$key} if %data{$key} > $max;
        $min = %data{$key} if %data{$key} < $min;
    }
    my $scale_factor = 10 / ($max - $min);
    for sort { %data{$^b} <=> %data{$^a} }, keys %data -> $key {
        printf "%15s | %s\n", $key, "#" x (%data{$key} * $scale_factor);
    }
}
my $data = { apple => 3, cherry => 6, banana => 1, pear => 4 };
generate_chart $data;

Note that Perl 6/Raku has no real difference between hashes and hash references in most cases.

This produces output similar to what we had in P5:

$ perl6 ascii_chart.p6
         cherry | ############
           pear | ########
          apple | ######
         banana | ##

Ordering the Bar Chart in Accordance with Labels or Values

As in Perl 5, we will use anonymous code references as the first argument to the sort built-in function.

use v6;

sub generate_chart (%data) {
    my ($max, $min);
    for keys %data -> $key {
        ($max, $min) = (%data{$key}, %data{$key}) unless defined $max;
        $max = %data{$key} if %data{$key} > $max;
        $min = %data{$key} if %data{$key} < $min;
    }
    my $scale_factor = 10 / ($max - $min);
    my &sort_routine = ($*sort-type ~~ m:i/val/) 
        ?? { %data{$^b} <=> %data{$^a} } 
        !! {$^a cmp $^b }; 
    for sort &sort_routine, keys %data -> $key {
        printf "%15s | %s\n", $key, "#" x (%data{$key} * $scale_factor);
    }
}
sub MAIN (Str $*sort-type) {
    my $data = { apple => 3, cherry => 6, banana => 1, pear => 4 };
    generate_chart $data;
}

This works as expected:

$ perl6 ascii_chart2.p6 val
         cherry | ############
           pear | ########
          apple | ######
         banana | ##

$ perl6 ascii_chart2.p6 lab
          apple | ######
         banana | ##
         cherry | ############
           pear | ########

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

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (October 27, 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: Illegal Division by Zero

Create a function to check divide by zero error without checking if the denominator is zero.

Illegal Division by Zero in Perl 5

Perl 5 has a number of modules to implement exception handling using the try ... catch pattern found in a number of other languages, such as, for example, Try::Tiny or TryCatch. Even Autodie might actually fit the bill. But, because this is a coding challenge, we prefer to avoid using modules that do the work you're supposed to do.

In fact, not doing anything special will check the division by zero, as shown in these one-liners:

$ perl -E 'say $ARGV[0] / $ARGV[1]' 2 4
0.5

$ perl -E 'say $ARGV[0] / $ARGV[1]' 2 0
Illegal division by zero at -e line 1.

In a way, this simple one-liner does check the divide by zero error. But, OK, maybe that's cheating a bit. So let's try to catch an error in this case.

Since I don't want to use modules here, I'll use the good old eval built-in function. The eval function has two forms (string and block). The string version is sometimes frowned upon for various reasons (notably because it can be dangerous when used carelessly), but it can be very useful when properly used. Anyway, we'll be using here the block version that doesn't have such problems. This form is typically used to trap exceptions (which is what we need here), while also providing the benefit of checking the code within the eval block at compile time.

If there is a syntax error or runtime error, eval returns undef in scalar context, or an empty list in list context, and $@ is set to the error message. (Prior to 5.16, a bug caused undef to be returned in list context for syntax errors, but not for runtime errors. We're using here version 26 of Perl, so we don't care about this former bug which would not have annoyed us anyway in our context.) If there was no error, $@ is set to the empty string.

This is our program:

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

die "We need an input of two numbers\n" unless @ARGV == 2;
my ($numerator, $denominator) = @ARGV;
my $result;
eval {
    $result = $numerator / $denominator;
};
die "$@" if $@;
say "Result of division is: $result";

Running this program with various input values produces the following output:

$ perl illegal_div.pl
We need an input of two numbers

$ perl illegal_div.pl 32
We need an input of two numbers

$ perl illegal_div.pl 32 8
Result of division is: 4

$ perl illegal_div.pl 32 0
Illegal division by zero at illegal_div.pl line 10.

Illegal Division by Zero in Perl 6 (or Raku)

Perl 6 has very rich error handling features, most notably the Exception class. Without going into all the lengthy details, let us say that it's possible to handle exceptional circumstances by supplying a CATCH block. To solve the challenge can be as simple as this:

use v6;

sub MAIN (Numeric $numerator, Numeric $denominator) {
    say "Result of division is: ", $numerator / $denominator;
    CATCH {
        say $*ERR: "Something went wrong here: ", .Str;
        exit; 
    }
}

Using this script first with legal parameters and then with an illegal 0 denominator produces the following output:

$ perl6 try-catch.p6  8 4
Result of division is: 2

$ perl6 try-catch.p6  8 0
Something went wrong here: Attempt to divide by zero when coercing Rational to Str

An exception object is usually contained in the $! special variable, but a CATCH block topicalizes the exception object, meaning that it becomes available in the $_ topical variable (hence the .Str syntax is sufficient to obtain the description of the exception).

Although it is not really needed here, it may sometimes be useful to define the scope of the CATCH block by enclosing it in a try block, for example:

use v6;

sub MAIN (Numeric $numerator, Numeric $denominator) {
    try {
        say "Result of division is: ", $numerator / $denominator;
        CATCH {
            say $*ERR: "Something went wrong here: ", .Str;
            exit; 
        }
    }
}

Actually, defining a try block creates an implicit CATCH block, and this may be used to contain the exception:

use v6;

sub MAIN (Numeric $numerator, Numeric $denominator) {
    try {
        say "Result of division is: ", $numerator / $denominator;
    }
}

The above program does not die and doesn't print anything but exits normally (with the successful exit code, 0, on Unix-like systems) when you pass a zero value for the denominator. We're in effect silencing the exception. Even if you don't want to abort the program when encountering such an error, you might still prefer to tell the user that something went wrong with a message containing the description of the caught exception:

use v6;

sub MAIN (Numeric $numerator, Numeric $denominator) {
    try {
        say "Result of division is: ", $numerator / $denominator;
    } or say "Houston, we've had a problem here: ",  $!.Str;
}

which outputs the following:

$ perl6 try-catch.p6  8 4
Result of division is: 2

$ perl6 try-catch.p6  8 0
Houston, we've had a problem here: Attempt to divide by zero when coercing Rational to Str

Dynamic Variable Name

Create a script to demonstrate creating dynamic variable name, assign a value to the variable and finally print the variable. The variable name would be passed as command line argument.

There are some scripting languages (such as various Unix shells) where it is possible to dynamically create variable names. This is sometimes useful, but it tends to mess up the script's name space.

If I understand the task well, we're requested to use symbolic references, as this is probably the only way to dynamically create variable names in Perl. I must warn you: Symbolic references are evil. Don't use them in Perl. There are better ways, as we will see later.

I could spend quite a bit of time explaining why they are bad, but Mark-Jason Dominus, the author of Higher Order Perl (an excellent book BTW), has already done it much better that I could probably ever do. Please read Mark-Jason's article in three installments on the subject:

• Why it's stupid to `use a variable as a variable name';

• A More Direct Explanation of the Problem;

• What if I'm Really Careful?.

Dynamic Variable Name in Perl 5

If you're using use strict; (and you always use this pragma, right?), you will not be able to use symbolic references and you'll get this type of error:

Can't use string ("foo") as a SCALAR ref while "strict refs" in use at sym_ref.pl line 12.

There are good reasons for that. Symbolic references were quite common in Perl 4 (which was replaced by Perl 5 more than 25 years ago) and they have not been removed completely from Perl 5 in the name of backward compatibility. That's why it is still possible (but highly deprecated) to use them. But they are never needed in Perl 5. With the strict pragma, you're forbidden to use symbolic references since it can be safely assumed that you're not using Perl 4 and they are bad in Perl 5. You'll need to disable part of the Strict benefits to use symbolic references.

In other words, the first thing you need to do if you really want to shoot yourself in the foot and use symbolic references is to disable strict references with the pragma no strict 'refs'; (but again, you really shouldn't be doing that). I hate to have to show this, but, then you can (but really shouldn't) use the variable name as a variable:

#!/usr/bin/perl

use strict;
use warnings;
use feature 'say';
# DON'T DO THIS
no strict 'refs'; # Needed for allowing symbolic references

@ARGV == 2 or die "Please supply two parameters.";
my ($var_name, $var_content) = @ARGV;

# This is bad, don't do it!
$$var_name = $var_content;
say "The variable is called $var_name and its value is $$var_name";

And this works as expected:

$ perl sym_ref.pl foo bar
The variable is called foo and its value is bar

But it is dangerous, for the reasons well explained by Mark-Jason Dominus. Sometimes, I say on forums things like this: "You should probably not use subroutines prototypes unless you really know what you're doing." In the case of symbolic references, I would be more adamant: don't do that, probably even if you think you really know what you're doing.

Note that we have used the eval function in the first task of this challenge. It is also be possible to create dynamic variable names using eval (without using no strict 'refs';), but it is IMHO at least as bad, perhaps even worse, so don't do this either. We will see now how to obtain the same result cleanly.

A Much Better Solution

If you're using symbolic references, you are in fact messing under the hood with a quite special global hash, the symbol table or a lexical pad. It is always far better to use a regular lexical hash (or sometimes a hash of hashes). For example, in our case, a very simple hash:

#!/usr/bin/perl

use strict;
use warnings;
use feature 'say';


@ARGV == 2 or die "Please supply two parameters.";
my %hash;
my ($name, $content) = @ARGV;
$hash{$name} = $content;
say "The item is called $name and its value is $hash{$name}";

This program displays the name of the item and its value:

$ perl sym_ref_fixed.pl foo bar
The item is called foo and its value is bar

Dynamic Variable Name in Perl 6 (Raku)

I do not think that there is anything like symbolic references in Perl 6. So, it seems that it is not possible to literally "demonstrate creating dynamic variable name" in Perl 6. What we can do, however, is to replicate the much better P5 solution and use a hash:

use v6;

sub MAIN (Str $name, Str $value) {
    my %hash = $name => $value;
    say "The item is called $name and its value is %hash{$name}";
}

This program displays the name of the item and its value:

$ perl6 sym_ref.p6 foo bar
The item is called foo and its value is bar

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

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (October 20, 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: Sunday Christmas

Write a script to list dates for Sunday Christmas between 2019 and 2100. For example, 25 Dec 2022 is Sunday.

Christmas on Sunday in Perl 5

I'll be using the Time::Local core module which provides reciprocal functions of the gmtime and localtime built-in functions.

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

say "Years during which Christmas falls on a Sunday:";
for my $year (119..200) {
    my $date = timegm(0, 0, 0, 25, 11, $year);
    say $year + 1900 if (gmtime $date)[6] == 0;
}

Note that both the built-in gmtime and the module timegm functions count the year from 1900 upward (so that 2019 should be input as 119) and start the month count at 0, so that December is considered to be 11.

The above program displays the following:

Years during which Christmas falls on a Sunday:
2022
2033
2039
2044
2050
2061
2067
2072
2078
2089
2095

We could also do it as a (slightly long) one-liner:

$ perl -MTime::Local -E 'say join " ", map {(gmtime $_)[5] + 1900}  grep { (gmtime $_)[6] == 0 } map {timegm(0, 0, 0, 25, 11, $_)} 119..200;'
2022 2033 2039 2044 2050 2061 2067 2072 2078 2089 2095

Christmas on Sunday in Perl 6

In Perl 6, the Date data type offers the built-in methods we need for date computations, including finding day of week.

use v6;
for 2019..2100 -> $year {
    say "Christmas of year $year falls on a Sunday." 
        if Date.new($year, 12, 25).day-of-week == 7;
}

which duly prints out:

Christmas of year 2022 falls on a Sunday.
Christmas of year 2033 falls on a Sunday.
Christmas of year 2039 falls on a Sunday.
Christmas of year 2044 falls on a Sunday.
Christmas of year 2050 falls on a Sunday.
Christmas of year 2061 falls on a Sunday.
Christmas of year 2067 falls on a Sunday.
Christmas of year 2072 falls on a Sunday.
Christmas of year 2078 falls on a Sunday.
Christmas of year 2089 falls on a Sunday.
Christmas of year 2095 falls on a Sunday.

We could also do it in the form of a Perl 6 one-liner:

$ perl6 -e 'say grep {Date.new($_, 12, 25).day-of-week == 7}, 2019..2100;'
(2022 2033 2039 2044 2050 2061 2067 2072 2078 2089 2095)

Integer Triplets Whose Sum is 12

Write a script to print all possible series of 3 numbers, where in each series at least one of the number is even and sum of the three numbers is always 12. For example, 3,4,5.

This is not specified, but we will consider that all three numbers should be strictly positive (i.e. larger than or equal to 1), because if we were to admit 0 as one of the numbers, it would no longer be a real triplet (in the context of addition). A consequence is that the largest number that can be used is 10 (to obtain 12 when adding twice 1).

Integer Triplets in Perl 5

We will use three nested loops for visiting all possibilities for the three numbers. However, we don't want to obtain duplicate triplets such as (1, 2, 9), (2, 1, 9), (9, 1, 2), etc., which are all the same. Therefore, when looping on the second number, we will loop from the first number to 10, and similarly for the third number. Thus, each triplet will be in (non strict) ascending order and won't get any duplicate.

We also need at least one of the three numbers to be even; for that, we can check whether the product of the three numbers is even (more on this later).

Our first (somewhat naïve) implementation could be as follows:

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

for my $i (1..10) {
    for my $j ($i..10) {
        last if $i + $j > 11;
        for my $k ($j..10) {
            next unless $i * $j * $k % 2 == 0; # Check 1 number is even
            my $sum = $i + $j + $k;
            last if $sum > 12;
            say "$i, $j, $k" if $sum == 12;
        }
    }
}

This program prints the following correct result:

$ perl triplet.pl
1, 1, 10
1, 2, 9
1, 3, 8
1, 4, 7
1, 5, 6
2, 2, 8
2, 3, 7
2, 4, 6
2, 5, 5
3, 3, 6
3, 4, 5
4, 4, 4

But we're doing a bit too much work here when we check whether one of the numbers is even. The only case where none of the numbers of a triplet is even is when all three numbers are odd, and the sum of three odd integers cannot be 12 (and, more generally, cannot be an even number). So, we simply don't need to check that one number is even: checking that the sum of the 3 numbers if 12 is sufficient to prove that one at least of the three numbers is even.

So we can rewrite the nested loops as follows:

for my $i (1..10) {
    for my $j ($i..10) {
        last if $i + $j > 11;
        for my $k ($j..10) {
            my $sum = $i + $j + $k;
            last if $sum > 12;
            say "$i, $j, $k" if $sum == 12;
        }
    }
}

And this new version produces the same output.

Integer Triplets in Perl 6

We've seen before that we don't need to check that one of the numbers is even.

For solving this problem in Perl 6, we would like to use the X cross product operator in order to generate all possible triplets and then keep those whose sum is 12.

But if we do something like this:

for 1..10 X 1..10 X 1..10 -> $triplet {
    next unless ([+] | $triplet) == 12;
    say $triplet;
}

we obtain duplicate triplets:

...
(1 2 9)
...
(2 1 9)
...
(2 9 1)
...
(9 1 2)
(9 2 1)
...

We can get rid of this problem by keeping only triplets in which the numbers are in (non strict) ascending order:

use v6;
for 1..10 X 1..10 X 1..10 -> $triplet {
    next unless [<=] | $triplet;  # ascending order
    say $triplet if 12 == [+] $triplet;
}

which produces the desired result:

$ perl6 triplets.p6
(1 1 10)
(1 2 9)
(1 3 8)
(1 4 7)
(1 5 6)
(2 2 8)
(2 3 7)
(2 4 6)
(2 5 5)
(3 3 6)
(3 4 5)
(4 4 4)

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

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

Challenge # 1: Brace Expansion

Write a script to demonstrate brace expansion. For example, script would take command line argument Perl {Daily,Weekly,Monthly,Yearly} Challenge and should expand it and print like below:

Perl Daily Challenge
Perl Weekly Challenge
Perl Monthly Challenge
Perl Yearly Challenge

The specification is not very detailed, and we will not attempt to provide a full-fledged templating system, as this already exists. So we will limit our implementation to the following: an initial sentence fragment, followed by a single list of options between curly brackets, followed by a final sentence fragment.

Brace Expansion In Perl 5

We will supply a command line argument in the form of a string between quote marks, and also provide for a default value for the purpose of testing. The program also attempts to normalize spaces in the output, since it is difficult to predict the exact format (number of spaces) supplied by the user.

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

my $in_str = shift // "Perl {Daily,Weekly,Monthly,Yearly} Challenge";
my ($start, $options, $end) = $in_str =~ /([^{]+) \{ ([^}]+) \} (.+)/x;
s/^ +| +$//g for ($start, $options, $end); # removing leading or trailing spaces
say "$start $_ $end" for split / *, */, $options;

Running the program using the default value and with a poorly formatted input string displays the following result:

$ perl brace-expansion.pl
Perl Daily Challenge
Perl Weekly Challenge
Perl Monthly Challenge
Perl Yearly Challenge

$ perl brace-expansion.pl "Perl {Daily,  Weekly  ,  Monthly,Yearly   }   Challenge"
Perl Daily Challenge
Perl Weekly Challenge
Perl Monthly Challenge
Perl Yearly Challenge

Brace Expansion In Perl 6

Simply porting the same P5 program to Perl 6 is straight forward:

use v6;

sub MAIN (Str $input = 'Perl {Daily,Weekly,Monthly,Yearly} Challenge') {
    my $match = $input ~~ /(<-[{]>+) '{' (<-[}]>+) '}' (.+)/;
    my ($start, $options, $end) = map { ~$_ }, $match[0 .. 2];
    s:g/^ \h+ | \h+ $// for $start, $options, $end;
    say "$start $_ $end" for $options.split(/\s*','\s*/);
}

Running the program using the default value and with a poorly formatted input string displays similar result:

$ perl6 brace-expansion.p6
Perl Daily Challenge
Perl Weekly Challenge
Perl Monthly Challenge
Perl Yearly Challenge

$ ./perl6 brace-expansion.p6 "Perl {Daily,  Weekly  ,  Monthly,Yearly   }   Challenge"
Perl Daily Challenge
Perl Weekly Challenge
Perl Monthly Challenge
Perl Yearly Challenge

Calling C Code from Perl

Write a script to demonstrate calling a C function. It could be any user defined or standard C function.

I had some environment problems and was unable to call a C library from Perl 5. I have done it in the past at work on a Linux environment without too much problem, as far as I can remember, but at home, I'm using Cygwin, and it appears to be a bit more complicated and I don't have much time to work on it

So I'll do the task only in Perl 6.

Using Native Calls in Perl 6

Starting With a Very Simple C Function

I started with a very simple C calc.c program providing an add function:

#include <stdio.h>
int add (int a, int b) {
    return a + b;
}

and a simple Perl 6 script calling it:

use NativeCall;

sub add(int32, int32)
    returns int32
    is native('./calc.dll')
    { * }

say add(3, 4);

It took me a number of faulty tries before I was able to create a shared library, and run the program:

$ gcc -c -fPIC calc.c -o calc.o

$ gcc -shared calc.o -o calc.dll

$ perl6 calc.p6
7

Benchmarking a Pure Perl 6 Program and a Native C Library

Now that we know how to run a basic function from a C library, we can try something more interesting: benchmarking a pure Perl 6 subroutine against a native C function. For this, I chose to use a recursive implementation of the Fibonacci sequence, since execution times get very long even for moderately large input. Of course, it is possible to memoize the recursive Fibonacci subroutine to obtain very small execution times, but I don't want to do it here, since I want to compare naïve recursive implementations to compare their duration.

The fibonacci.c program provides a fib function:

#include <stdio.h>
int fib (int a) {
    if (a == 0 || a == 1) {
        return 1;
    } else {
        return fib(a -1 ) + fib(a - 2);
    }
}

The fibo.p6 program below uses both the native fib function and a pure Perl 6 fib-p6 subroutine and record their execution times:

use v6;
use NativeCall;

sub fib(int32)
    returns int32
    is native('./fibonacci.dll')
    { * }

sub fib-p6 (Int $num) {
    return 1 if $num == 0 or $num == 1;
    return fib-p6($num - 1) + fib-p6($num - 2);
}

sub MAIN (Int $num where * >= 0 = 36 ) {
    my $start-time = INIT now;
    say "C library function: ", fib($num);
    say "Duration C function: ", now - $start-time;
    my $now = now;
    say "P6 subroutine: ", fib-p6 $num;
    say "Duration P6 subroutine: ", now - $now;
}

Compiling the C program, building the shared library and running the benchmark shows the following result:

$ gcc -c -fPIC fibonacci.c -o fibonacci.o

$ gcc -shared fibonacci.o -o fibonacci.dll

$ perl6 fibo.p6
C library function: 24157817
Duration C function: 0.1306511
P6 subroutine: 24157817
Duration P6 subroutine: 37.425447

The result is impressive: 0.13 seconds for the C fib function and 37 seconds for fib-p6 the pure Perl 6 implementation. With the default 36 input value, the C function runs 286 times faster!

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

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days from now (October 6, 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: File Type

Write a script to check the file content without explicitly reading the content. It should accept file name with path as command line argument and print “The file content is binary.” or else “The file content is ascii.” accordingly.

On most operating systems (VMS is an exception to a certain extent), there is no 100%-reliable algorithm to know whether a file is text (ASCII or UTF-8) or binary, but only some heuristic guesses. Usually, programs that attempt to find out whether a file is text or binary read a raw block of bytes (often 4096 bytes) and make some statistics on the number of bytes corresponding to ASCII printable and space characters versus non-printable characters. If the number of non-printable character exceeds a certain fraction of the whole (for example one third, or 10%, or whatever), then the file is deemed to be binary. Also, any file containing a zero byte in the examined portion is considered a binary file.

File Type in Perl 5

In Perl 5, the -T and -B file test operators more or less work as described above. In the program below, we're first using some other file test operators (-e, -z and -f) to check, respectively, that the file exists, that it is not empty and that it is a regular file and then use the -T and -B file test operators.

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


die "Please supply a file name as argument" unless @ARGV == 1;
my $file = shift;
die "File $file does not exist" unless -e $file;
die "File $file is empty" if -z _;
die "File $file isn't a plain file" unless -f _;
if (-B _) {
    say "$file is a binary file";
} elsif (-T _) {
    say "$file is a text file (ASCII or UTF8)";
} else {
    say "Could not determine file type"; # Probaby can't happen
}

Note that once we've used the first such file test operator (here -e), or the stat function, on the file name received as an argument, we can use the special _ filehandle for the other file test operators: this tells Perl that we want to use the same file, and Perl then knows it can use the same stat structure retrieved in the previous call and thus avoids to make further system calls.

This is the output with some arguments:

$ perl file_type.pl
Please supply a file name as argument at file_type.pl line 7.

$ perl file_type.pl foobar
File foobar does not exist at file_type.pl line 9.

$ perl file_type.pl watched-values.pl
watched-values.pl is a text file (ASCII or UTF8)

$ perl file_type.pl amazon.pl.gz
amazon.pl.gz is a binary file

File Type in Perl 6

Perl 6 has most of the Perl 5 test file operators (albeit with a slightly different syntax), but operators equivalent to Perl 5 -T and -B file test operators currently do not exist (or are not yet implemented). We will use these existing file test operators to check that the file exists, that it is not empty and that it is a regular file, but we have to roll out our own is-binary subroutine to try to mimic the Perl 5 -T and -B operators. This subroutine will read a raw block of the first 4096 bytes of the file and examine each byte in turn to make some statistics on space characters and printable characters versus non-printable characters.

The slight difficulty, though, is to determine exactly what should be considered a non-printable character. For lack of a standard definition of such characters, I've decided to consider that byte decimal values 0 to 8 and 14 to 31 correspond to ASCII non-printable characters. Those values will be stored in a set. With such a small number of non-printable characters compared to the full extended ASCII, the proportion of non-printable character would be around 10% on a random bytes binary file. I have decided to consider that a file shall be deemed to be text (ASCII) if there is less than one byte out of 32 that is non-printable, and binary otherwise. In addition, any file for which the buffer contains at least one null byte (value 0) is considered to be binary.

use v6;

sub is-binary ($file) {
    my constant non-printable-bytes = (0..8).Set (|) (14..31).Set;
    my constant block-size = 4096;
    my $fh = $file.IO.open(:r, :bin);
    my $buf = $fh.read(block-size);
    $fh.close;
    my ($printable, $non-printable) = 0, 0;
    for $buf.list -> $byte {
        return True if $byte == 0; # null byte
        if $byte (elem) non-printable-bytes {
            $non-printable++;
        } else {
            $printable++;
        }
    }
    return True if $non-printable * 31 > $printable;
    False;
}

sub MAIN ($file) {
    die "File $file does not exist" unless $file.IO ~~ :e;
    die "File $file is empty" if $file.IO ~~ :z;
    die "File $file isn't a plain file" unless $file.IO ~~ :f;
    say is-binary($file) ?? "File content is binary" !! "File content is text (ASCII)";
}

This appears to work as desired:

$ perl6 file-type.p6
Usage:
  file-type.p6 <file>

$ perl6 file-type.p6 foobar.baz
File foobar.baz does not exist
  in sub MAIN at file-type.p6 line 23
  in block <unit> at file-type.p6 line 1


$ perl6 file-type.p6 file-type.p6
File content is text (ASCII)

$ perl6 file-type.p6 amazon.pl.gz
File content is binary

A Digital Clock

Write a script to display Digital Clock. Feel free to be as creative as you can when displaying digits. We expect bare minimum something like “14:10:11”.

A Digital Clock In Perl 5

For this challenge, we can just write a simple one-liner:

$ perl -e '$|++; while (1) { printf "\r%02d:%02d:%02d", (localtime)[2,1,0]; sleep 1; }'
22:13:27

Two interesting things to say about it: first, we use the \r (carriage return) to go back to the first column of the screen and overwrite the previously displayed time with the new one each time we want to display a new time. This useless \r carriage return character (dating from old typewriters) is often a pain in the neck when dealing with Windows-generated files under Unix or Linux (or the other way around), I'm happy that I could find here some useful purpose for this pesky and usually useless character. The other thing is to set the $| (aka $OUTPUT_AUTOFLUSH) special variable to a true value (1) to force a flush after every print on the output handle (otherwise, the printed lines are buffered and the output gets messy). Also note that this program uses printf with a formatting string to make sure that each number is printed over two characters (with a leading zero when needed). This program will run "forever", until you kill it with a Ctrl C command. It would be easy to add a counter to stop it after a while, if needed.

So, job done? Yes, sure, we're displaying a digital clock. But the task specification suggests to feel free to be creative when displaying the digits. So, let's try to get a nicer output. We could probably use some graphical library such as Tk, but I haven't used it for a fairly long time and I'm also not sure how to use it in Perl 6. We could also possibly use an HTML display, but I fear that would require to run a Web server, and I don't want to run into annoying environment problems. So I decided to simply display the time with ASCII art.

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

my @digit_strings = (
' _  -   - _  -_  -    - _  - _  - _  - _  - _  -     ',
'| | - | - _| -_| -|_| -|_  -|_  -  | -|_| -|_| -  O  ',
'|_| - | -|_  -_| -  | - _| -|_| -  | -|_| - _| -  O  ',
'    -   -    -   -    -    -    -    -    -    -     ');

my @digits = map { [split /-/, $_] } @digit_strings;

sub display_time {
    my @pieces = split //, shift;
    for my $line (0..3) {
        for my $digit (@pieces) {
            $digit = 10 if $digit eq ":";
            print $digits[$line][$digit];
        }
    say "";
    }
}

my $clear_screen = ($^O eq "cygwin" or $^O eq "linux") ? "clear" :  "cls";
while (1) {
    my $time_str = sprintf "%02d:%02d:%02d", (localtime)[2,1,0]; 
    system $clear_screen;
    display_time $time_str;
    sleep 1; 
}

__END__

Example of displayed time:
             _   _           _
 | |_|   O  | | |_    O   |  _|
 |   |   O  |_| |_|   O   | |_

Running the script from the Linux command line (or from a Windows cmd terminal) clears the screen and and displays at the top of the screen the time as shown at the end of the script above.

A Digital Clock In Perl 6

We can use a Perl6 one-line as we did in Perl 5:

$ perl6 -e 'loop { my $d = DateTime.now; printf "\r%02d:%02d:%02d", $d.hour, $d.minute, $d.second; sleep 1;'
14:35:06

As for Perl 5, we're using the \r carriage-return character to overwrite what was displayed previously each time we display a new time. And we don't need to do anything special in Perl 6 to make sure the printed strings are properly flushed.

Let's now try to port our ASCII art display to Perl 6 (I actually wrote the Perl 6 version before the Perl 5 version, but let's pretend we're porting the P5 version).

use v6;

my @digit_strings = (
' _  -   - _  -_  -    - _  - _  - _  - _  - _  -     ',
'| | - | - _| -_| -|_| -|_  -|_  -  | -|_| -|_| -  O  ',
'|_| - | -|_  -_| -  | - _| -|_| -  | -|_| - _| -  O  ',
'    -   -    -   -    -    -    -    -    -    -     ');

my @digits = map { [split /\-/, $_] }, @digit_strings;

sub display_time (Str $time) {
    my @pieces = $time.comb;
    for 0..3 -> $line {
        for @pieces <-> $digit {
            $digit = 10 if $digit eq ":";
            print @digits[$line][$digit];
        }
    say "";
    }
}

my $clear_screen = ($*VM.osname ~~ m:i/cyg | lin/) ?? 
    "clear" !! "cls";
loop {
    my $d = DateTime.now;
    my $time_str = sprintf "%02d:%02d:%02d", 
        $d.hour, $d.minute, $d.second; 
    shell $clear_screen;
    display_time $time_str;
    sleep 1; 
}

=finish

Example of displayed time:
    _        _   _        _   _
 |   |   O  | | |_|   O  | |  _|
 |   |   O  |_|  _|   O  |_| |_

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