I wish you good success with your workshop and look forward to seeing the videos.

]]>*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.

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

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
```

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)
```

*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).

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.

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)
```

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.

]]>*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.

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
```

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
```

*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.

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
```

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!

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.

]]>*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.

*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.

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
```

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
```

*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”.*

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.

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 |_| |_
```

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.

]]>*Write a script to find the intersection of two straight lines. The co-ordinates of the two lines should be provided as command line parameter. For example:*

The two ends of Line 1 are represented as co-ordinates (a,b) and (c,d).

The two ends of Line 2 are represented as co-ordinates (p,q) and (r,s).

*The script should print the co-ordinates of point of intersection of the above two lines.*

This is really elementary math, but, as I haven't used any linear algebra for many years, I needed about 10 to 15 minutes with a pencil and a piece of paper to work out how to find the equation of a straight line going through two points and how to compute the intersection of two lines. For the benefits of those of you in the same situation, let me briefly summarize how this works. You may jump to the next section if you don't need any refresher on these subjects.

The equation of a straight line is usually written as `y = ax + b`

(or, in some countries, `y = mx + b`

or `y = mx + c`

, but it's just the name of the coefficients changing), where `x`

and `y`

are the coordinates of any point belonging to the line, `a`

is the slope (or gradient, i.e. how steep the line is) of the line, and `b`

the y-intercept (the value of `y`

when `x`

is zero, or the place where the line crosses the `Y`

axis). The slope is the change in `y`

divided by the change in `x`

. For finding the slope of a line going through two points with coordinates `x1, y1`

and `x2, y2`

, the slope `a`

is the ordinate (`y`

) difference of the points divided by their abscissa (`x`

) difference:

```
a = (y2 - y1) / (x2 - x1)
```

Of course, we have a division by zero problem if `x2`

equals `x1`

(i.e. the line is vertical, at least in an orthonormal base or Cartesian plane), but we'll come back to that special edge case later.

For finding the y-intercept (`b`

), you just need to reformulate `y = ax + b`

as `b = y - ax`

, and to replace `a`

by the slope found with the above formula, and `y`

and `x`

by the coordinates of any of the two points.

For finding the intersection point of two lines `y = a1 * x + b1`

and `y = a2 * x + b2`

, you need to figure out that it is the point of the lines for which the ordinate (`y`

) is the same for an equal value of the abscissa (`x`

), i.e. write the following equations:

```
a1 * x + b1 = a2 * x + b2
<=>
(a1 - a2) *x = b2 - b1
<=>
x = (b2 - b1) / (a1 - a2) # (if a1 != a2)
```

Once the abscissa `x`

of the intersection has been found, it is easy to find its ordinate `y`

using the equation of any of the two lines.

If the lines' slopes are equal, then the equation above has a division by zero problem, which reflects the fact that the line segments defined by the point pairs are parallel or colinear, meaning that the problem has no solution (there is no intersection point).

With the above knowledge secured, it is fairly easy to write a Perl 5 program computing the intersection point of two lines defined by two point pairs.

We use the `find_line`

subroutine twice (once for every point pair) to find the slope and y-intercept of each line and the `find-intersect`

subroutine to find the coordinates of the point where the two lines intersect.

There is one slight complication, though: if one (and only one) of the point pairs have points with the same abscissa, we cannot write a linear equation for that pair of points, but the straight line is nonetheless well defined (provided the ordinates are different): it is a vertical line where all point have the same abscissa (`x`

value). We cannot write an equation for such a line, but may still find the intersection point with the other line: it is the point of that other line having this abscissa. This pesky edge case accounts for a good chunk (20 code lines) of the code below.

```
#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
sub find_line {
my ($x1, $y1, $x2, $y2) = @_;
my $slope = ($y2 - $y1) / ($x2 - $x1);
# find b for y1 = slope * x1 + b
my $b = $y1 - $slope * $x1;
return $slope, $b;
}
sub find_intersect {
my ($a1, $b1, $a2, $b2) = @_;
# solve y = ax + b for a1, b1 and a2, b2
# i.e.: a1 x + b1 = a2 x + b2 <=> x (a1 - a2) = b2 - b1
die "The segments are parallel or colinear, no intersection point!" if ($a1 == $a2);
my $abscissa = ($b2 - $b1) / ($a1 - $a2);
say "x = $abscissa";
my $ordinate = $a1 * $abscissa + $b1;
return $abscissa, $ordinate;
}
my ($a1, $b1, $a2, $b2);
if (@ARGV == 8) {
die "The two segments are vertical, no intersection point"
if $ARGV[0] == $ARGV[2] and $ARGV[4] == $ARGV[6];
if ($ARGV[0] == $ARGV[2]) {
#First segment is vertical
my $abscissa = $ARGV[0];
($a2, $b2) = find_line @ARGV[4..7];
my $ordinate = $a2 * $abscissa + $b2;
say "Intersection point: $abscissa, $ordinate";
exit 0;
}
if ($ARGV[4] == $ARGV[6]) {
# Second segment is vertical
my $abscissa = $ARGV[4];
($a1, $b1) = find_line @ARGV[0..3];
my $ordinate = $a1 * $abscissa + $b1;
say "Intersection point: $abscissa, $ordinate";
exit 0;
}
($a1, $b1) = find_line @ARGV[0..3];
($a2, $b2) = find_line @ARGV[4..7];
} else {
# default test values if arguments are missing or insufficient
($a1, $b1) = find_line 3, 1, 5, 3;
($a2, $b2) = find_line 3, 3, 6, 0;
}
say "a1: $a1";
say "b1: $b1";
say "a2: $a2";
say "b2: $b2";
my ($x, $y) = find_intersect ($a1, $b1, $a2, $b2);
say "Intersection point abscissa: $x";
say "Intersection point ordinate: $y";
```

Note that, in a real-life program, we should really check that the points of each pair are distinct (to properly define a straight line), but I did not want to clutter the code with even more edge cases: I'll assume that the user knows what she or he is doing and will pass arguments making sense. We'll do more of these argument checks in the Perl 6 version.

With no argument, the program uses the default values and duly prints the following:

```
$ perl intersection.pl
a1: 1
b1: -2
a2: -1
b2: 6
x = 4
Intersection point abscissa: 4
Intersection point ordinate: 2
```

These are a few example runs on edge cases:

```
$ perl intersection.pl 3 4 3 6 7 8 9 10
Intersection point: 3, 4
$ perl intersection.pl 3 4 3 6 8 8 9 10
Intersection point: 3, -2
$ perl intersection.pl 3 4 3 6 3 3 6 0
Intersection point: 3, 3
$ perl intersection.pl 4 4 4 6 3 3 6 0
Intersection point: 4, 2
$ perl intersection.pl 3 1 5 3 3 3 3 0
Intersection point: 3, 1
```

We could simply translate the P5 program in Perl 6, but this type of problem calls for object-oriented programming. So, we will define a `Point`

type and a `Segment`

class (with two `Point`

attributes) providing the `slope`

and `y-intercept`

methods to compute the equation of a line passing through the two points. The `Point`

role also provides a `gist`

method enabling pretty printing of the point coordinates when using the `say`

built-in function on a `Point`

instance.

```
use v6;
role Point {
has $.x;
has $.y;
method gist {
return "\n- Abscissa: $.x\n- Ordinate: $.y.";
}
}
class Segment {
has Point $.start;
has Point $.end;
method slope {
return ($.end.y - $.start.y) / ($.end.x - $.start.x);
}
method y-intercept {
my $slope = self.slope;
return $.start.y - $slope * $.start.x;
}
method line-coordinates { # used only for debugging purpose
return self.slope, self.y-intercept;
}
}
sub compute-intersection (Segment $s1, Segment $s2) {
my $abscissa = ($s2.y-intercept - $s1.y-intercept) /
($s1.slope - $s2.slope);
my $ordinate = $s1.slope * $abscissa + $s1.y-intercept;
my $intersection = Point.new( x => $abscissa, y => $ordinate);
}
multi MAIN ( $a1, $b1, # start of line segment 1
$a2, $b2, # end of line segment 1
$a3, $b3, # start of line segment 2
$a4, $b4 # end of line segment 2
) {
my $segment1 = Segment.new(
start => Point.new(x => $a1, y => $b1),
end => Point.new(x => $a2, y => $b2)
);
my $segment2 = Segment.new(
start => Point.new(x => $a3, y => $b3),
end => Point.new(x => $a4, y => $b4)
);
say "Coordinates of intersection point: ",
compute-intersection $segment1, $segment2;
}
multi MAIN () {
say "Using default input values for testing. ";
say "Should display point (2, 4).";
my $segment1 = Segment.new(
start => Point.new(x => 3, y => 1),
end => Point.new(x => 5, y => 3)
);
my $segment2 = Segment.new(
start => Point.new(x => 3, y => 3),
end => Point.new(x => 6, y => 0)
);
# say "Segment 1: ", $segment1.line-coordinates;
# say "Segment 2: ", $segment2.line-coordinates;
say "Coordinates of intersection point: ",
compute-intersection $segment1, $segment2;
}
```

This is a sample run of the program:

```
$ perl6 intersection.p6 3 1 5 3 3 3 6 0
Coordinates of intersection point:
- Abscissa: 4
- Ordinate: 2.
```

As it is, this program isn't doing any validation on its arguments. So we will add a `valid-args`

subroutine for that purpose and also check that the computed segments are not parallel.

```
use v6;
role Point {
has $.x;
has $.y;
method gist {
return "\n- Abscissa: $.x\n- Ordinate: $.y.";
}
}
class Segment {
has Point $.start;
has Point $.end;
method slope {
return ($.end.y - $.start.y) / ($.end.x - $.start.x);
}
method y-intercept {
my $slope = self.slope;
return $.start.y - $slope * $.start.x;
}
method line-coordinates {
return self.slope, self.y-intercept;
}
}
sub compute-intersection (Segment $s1, Segment $s2) {
my $abscissa = ($s2.y-intercept - $s1.y-intercept) /
($s1.slope - $s2.slope);
my $ordinate = $s1.slope * $abscissa + $s1.y-intercept;
my $intersection = Point.new( x => $abscissa, y => $ordinate);
}
multi MAIN ( $a1, $b1, # start of line segment 1
$a2, $b2, # end of line segment 1
$a3, $b3, # start of line segment 2
$a4, $b4 # end of line segment 2
) {
exit unless valid-args |@*ARGS;
my $segment1 = Segment.new(
start => Point.new(x => $a1, y => $b1),
end => Point.new(x => $a2, y => $b2)
);
my $segment2 = Segment.new(
start => Point.new(x => $a3, y => $b3),
end => Point.new(x => $a4, y => $b4)
);
say "Segments are parallel or colinear." and exit
if $segment1.slope == $segment2.slope;
say "Coordinates of intersection point: ",
compute-intersection $segment1, $segment2;
}
multi MAIN () {
say "Using default input values for testing. Should display poinr (2, 4).";
my $segment1 = Segment.new(
start => Point.new(x => 3, y => 1),
end => Point.new(x => 5, y => 3)
);
my $segment2 = Segment.new(
start => Point.new(x => 3, y => 3),
end => Point.new(x => 6, y => 0)
);
say "Coordinates of intersection point: ",
compute-intersection $segment1, $segment2;
}
sub valid-args ( $a1, $b1, # start of line segment 1
$a2, $b2, # end of line segment 1
$a3, $b3, # start of line segment 2
$a4, $b4 # end of line segment 2
) {
unless @*ARGS.all ~~ /<[\d]>+/ {
say "Non numeric argument. Can't continue.";
return False;
}
if $a1 == $a2 and $b1 == $b2 {
say "The first two points are the same. Cannot draw a line.";
return False;
}
if $a3 == $a4 and $b3 == $b4 {
say "The last two points are the same. Cannot draw a line.";
return False;
}
if $a1 == $a2 and $a3 == $a4 {
say "The two segments are vertical. No intersection.";
return False;
}
if $a1 == $a2 {
# First segment is vertical but not the second one
my $segment2 = Segment.new(
start => Point.new(x => $a3, y => $b3),
end => Point.new(x => $a4, y => $b4)
);
my $ordinate = $segment2.slope
* $a1 + $segment2.y-intercept;
my $interception = Point.new(x => $a1, y => $ordinate);
say "Coordinates of intersection point: ", $interception;
return False;
}
if $a3 == $a4 {
# Second segment is vertical but not the first one
my $segment1 = Segment.new(
start => Point.new(x => $a1, y => $b1),
end => Point.new(x => $a2, y => $b2)
);
my $ordinate = $segment1.slope
* $a3 + $segment1.y-intercept;
my $interception = Point.new(x => $a3, y => $ordinate);
say "Coordinates of intersection point: ", $interception;
return False;
}
return True;
}
```

Running the program with some examples of valid or invalid arguments displays the following:

```
$ perl6 intersection.p6 3 1 5 3 3 3 n 0
Non numeric argument. Can't continue.
$ perl6 intersection.p6 3 1 5 3 3 3 5.4 0
Coordinates of intersection point:
- Abscissa: 3.888889
- Ordinate: 1.888889.
$ perl6 intersection.p6 3 1 5 3 3 3 6.0 0
Coordinates of intersection point:
- Abscissa: 4
- Ordinate: 2.
$ perl6 intersection.p6 3 1 5 3 6 2 10 6
Segments are parallel or colinear.
$ perl6 intersection.p6 3 1 3 1 3 3 6 0
The first two points are the same. Cannot draw a line.
$ perl6 intersection.p6 3 1 3 2 3 5 3 0
The two segments are vertical. Cannot find an intersection.
```

*Write a script that allows you to capture/display historical data. It could be an object or a scalar. For example:*

my $x = 10; $x = 20; $x -= 5;

This week was very busy for me and I'm running a bit out of time. My answers to this task will be somewhat minimalist.

I do not know whether it is possible to override the `=`

operator in Perl 5 and have no time to find out. Another possibility might be to use the `tie`

function or something similar to associate a value with an object, but I have used it only very rarely and have very limited experience with it, and I also don't have enough time to experiment with it. Therefore, I'll cheat a little bit and use an `$assign`

code reference for assigning new values to a watched variable. The `create_watched_value`

subroutine acts as a watched variable constructor and is a function factory that returns three closures, `$assign`

, `$get_past_values`

, and `$get_current_values`

. The main code then uses these code references to perform various assignments and output.

```
#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
sub create_watched_value {
my $value = shift;
my @past_values;
my $assign = sub {
my $new_val = shift;
push @past_values, $value;
$value = $new_val;
};
my $get_past_values = sub {
return "@past_values";
};
my $get_current_value = sub {
return $value;
};
return $assign, $get_past_values, $get_current_value;
}
my ($assign, $get_past, $get_current) = create_watched_value 10;
say "Current: ", $get_current->();
$assign->(15);
say "Current: ", $get_current->();
$assign->(20);
say "Current: ", $get_current->();
$assign->(5);
say "Current: ", $get_current->();
say "Past: ", $get_past->();
```

This program runs fine and displays the following output:

```
$ perl watched-values.pl
Current: 10
Current: 15
Current: 20
Current: 5
Past: 10 15 20
```

I initially tried to redefine the `=`

assignment operator but that appears to be impossible:

```
Cannot override infix operator '=', as it is a special form handled directly by the compiler
```

So, I decided to create my own `=:=`

assignment operator for watched variables. Besides that, the program uses the `WatchedValue`

class to enable the storing of current and past values.

```
use v6;
class WatchedValue {
has Int $.current-value is rw;
has @.past-values = ();
method get-past-values {
return @.past-values;
}
}
multi sub infix:<=:=> (WatchedValue $y, Int $z) {
push $y.past-values, $y.current-value;
$y.current-value = $z;
}
my $x = WatchedValue.new(current-value => 10);
say "Current: ", $x.current-value;
$x =:= 15;
say "Current: ", $x.current-value;
$x =:= 5;
say "Current: ", $x.current-value;
$x =:= 20;
say "Current: ", $x.current-value;
say "Past values: ", $x.get-past-values;
```

When running the program; I get warnings for each assignment:

```
Useless use of "=:=" in expression "$x =:= 15" in sink context (line 18)
```

I do not know how to suppress these warnings (it seems that the `no warnings ...`

pragma isn't implemented yet), but the program otherwise runs correctly and displays the successive values:

```
Current: 10
Current: 15
Current: 5
Current: 20
Past values: [10 15 5]
```

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

]]>I try again:

Yeah, well, I understand what you mean and I mostly agree, Yet, but, strictly speaking, this is true only for x > 0. You have to add or subtract pi when x is negative, and atan2(y, x) is usually defined for x == 0 (at least for values of y other than 0), even though y/x would lead to an exception when x = 0. I chose to give a geometrical interpretation of atan2 (the rectangular coordinates of a point in the plan) in my update to avoid having to deal with all these edge-case difficulties in algebra.

]]>]]>

]]>

*Spoiler Alert:* This weekly challenge deadline is due in several days from now (September 22, 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, which you're strongly encouraged to do.

*Create a script that accepts two strings, let us call it, “stones” and “jewels”. It should print the count of “alphabet” from the string “stones” found in the string “jewels”. For example, if your stones is “chancellor” and “jewels” is “chocolate”, then the script should print “8”. To keep it simple, only A-Z,a-z characters are acceptable. Also make the comparison case sensitive.*

We're given two strings and need to find out how many characters of the second string can be found in the first string.

This is straight forward. Our script should be given two arguments (else we abort the program). We split the first string into individual letters and store them in the `%letters`

hash. Note that we filter out any character not in the `[A-Za-z]`

character class. Then we split the second string into individual letters, keep only letters found in the `%letters`

hash and finally coerce the resulting list of letters in a scalar context to transform it in a letter count (note that the `scalar`

keyword isn't really needed here, as we have a scalar context anyway, but I included it to make it easier to understand).

```
#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
@ARGV == 2 or die "This script needs two strings are parameters";
my ($str1, $str2) = @ARGV;
my %letters = map {$_ => 1} grep /[A-Za-z]/, split "", $str1;
my $count = scalar grep { exists $letters{$_}} split "", $str2;
say "$str2 has $count letters from $str1";
```

Running the program:

```
$ perl count_letters.pl chocolate chancellor
chancellor has 8 letters from chocolate
$ perl count_letters.pl chancellor chocolate
chocolate has 8 letters from chancellor
$ perl count_letters.pl chancellor CHOCOLATE
CHOCOLATE has 0 letters from chancellor
```

We get the expected result. The last test shows that the comparison is case-sensitive, as requested in the specification.

We will use more or less the same idea as in P5, except that we'll use a set instead of a hash for storing unique letters of the first string.

```
use v6;
sub MAIN (Str $str1, Str $str2) {
my $letters = $str1.comb.grep( /<[A..Za..z]>/ ).Set;
my $count = $str2.comb.grep( { $_ (elem) $letters} ).elems;
say "$str2 has $count letters from $str1";
}
```

This works as expected:

```
$ perl6 count_letters.p6 chocolate chancellor
chancellor has 8 letters from chocolate
$ perl6 count_letters.p6 chocolate CHANCELLOR
CHANCELLOR has 0 letters from chocolate
```

*Create a script that prints mean angles of the given list of angles in degrees. Please read wiki page that explains the formula in details with an example.*

In mathematics, a mean of circular quantities is a mean which is sometimes better-suited for quantities like angles, day times, and fractional parts of real numbers. This is necessary since most of the usual means may not be appropriate on circular quantities. For example, the arithmetic mean of 0° and 360° is 180°, which is misleading because for most purposes 360° is the same thing as 0°.

A common formula for the mean of a list of angles is:

We just need to apply the formula, after having converted the input values from degrees to radians.

The Wikipedia page has the following example, that we will use in our tests: consider the following three angles as an example: 10, 20, and 30 degrees. Intuitively, calculating the mean would involve adding these three angles together and dividing by 3, in this case indeed resulting in a correct mean angle of 20 degrees. By rotating this system anticlockwise through 15 degrees the three angles become 355 degrees, 5 degrees and 15 degrees. The naive mean is now 125 degrees, which is the wrong answer, as it should be 5 degrees.

There are a number of modules that could be used here to convert degrees to radians and radians to degrees, to compute arithmetic means and perhaps even to compute directly mean angles. But that wouldn't be a challenge if we were just using modules to dodge the real work.

So I wrote the `deg2rad`

and `rad2deg`

subroutines to do the angle unit conversions, and computed the arithmetic means of sines and cosines in a `for`

loop.

As I do not have a use for such a program, I will implement the necessary subroutine and just use them in a series of tests.

```
#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;
use constant PI => atan2(1, 0) * 2;
use Test::More;
plan tests => 9;
sub deg2rad { return $_[0] * PI /180; }
sub rad2deg { return $_[0] * 180 / PI }
sub mean {
my @angles = map { deg2rad $_ } @_;
my $count = @angles;
my ($sum_sin, $sum_cos) = (0, 0);
for my $angle (@angles) {
$sum_sin += sin $angle;
$sum_cos += cos $angle;
}
return rad2deg atan2 $sum_sin/$count, $sum_cos/$count;
}
is deg2rad(0), 0, "To rad: 0 degree";
is deg2rad(90), PI/2, "To rad: 90 degrees";
is deg2rad(180), PI, "To rad: 180 degrees";
is rad2deg(PI/2), 90, "To degrees: 90 degrees";
is rad2deg(PI), 180, "To degrees: 180 degrees";
is deg2rad(rad2deg(PI)), PI, "Roundtrip rad -> deg -> rad";
is rad2deg(deg2rad(90)), 90, "Roundtrip deg -> rad -> deg";
is mean(10, 20, 30), 20, "Mean of 10, 20, 30 degrees";
is mean(355, 5, 15), 5, "Mean of 355, 5, 15 degrees";
```

Running the tests displays the following:

```
$ perl angle-mean.pl
1..9
ok 1 - To rad: 0 degree
ok 2 - To rad: 90 degrees
ok 3 - To rad: 180 degrees
ok 4 - To degrees: 90 degrees
ok 5 - To degrees: 180 degrees
ok 6 - Roundtrip rad -> deg -> rad
ok 7 - Roundtrip deg -> rad -> deg
ok 8 - Mean of 10, 20, 30 degrees
ok 9 - Mean of 355, 5, 15 degrees
```

*Update:* As pointed out in a comment by *Saif* below, there is no need to divide both arguments of the `atan2`

built-in function: these arguments represent the abscissa and the ordinate of a point in the plan. Whether the two Cartesian coordinates are divided by `count`

or not does not change the resulting polar angle calculated by `atan2`

. Thus, we don't need to perform this division, and we don't even need the `$count`

variable. The `mean`

subroutine can be simplified as follows:

```
sub mean {
my @angles = map { deg2rad $_ } @_;
my ($sum_sin, $sum_cos) = (0, 0);
for my $angle (@angles) {
$sum_sin += sin $angle;
$sum_cos += cos $angle;
}
return rad2deg atan2 $sum_sin, $sum_cos;
}
```

The tests display the same results as before.

*End update.*

We will use essentially the same idea as in P5.

```
use v6;
use Test;
sub deg2rad (Numeric $deg) { return $deg * pi /180; }
sub rad2deg (Numeric $rad) { return $rad * 180 / pi }
sub mean (*@degrees) {
my @radians = map { deg2rad $_ }, @degrees;
my $count = @radians.elems;
my $avg-sin = ([+] @radians.map( {sin $_})) / $count;
my $avg-cos = ([+] @radians.map( {cos $_})) / $count;
return rad2deg atan2 $avg-sin, $avg-cos;
}
plan 9;
is deg2rad(0), 0, "To rad: 0 degree";
is deg2rad(90), pi/2, "To rad: 90 degrees";
is deg2rad(180), pi, "To rad: 180 degrees";
is rad2deg(pi/2), 90, "To degrees: 90 degrees";
is rad2deg(pi), 180, "To degrees: 180 degrees";
is deg2rad(rad2deg(pi)), pi, "Roundtrip rad -> deg -> rad";
is rad2deg(deg2rad(90)), 90, "Roundtrip deg -> rad -> deg";
is-approx mean(10, 20, 30), 20, "Mean of 10, 20, 30 degrees";
is-approx mean(355, 5, 15), 5, "Mean of 355, 5, 15 degrees";
```

And this is the output produced when running the script:

```
perl6 angle-mean.p6
1..9
ok 1 - To rad: 0 degree
ok 2 - To rad: 90 degrees
ok 3 - To rad: 180 degrees
ok 4 - To degrees: 90 degrees
ok 5 - To degrees: 180 degrees
ok 6 - Roundtrip rad -> deg -> rad
ok 7 - Roundtrip deg -> rad -> deg
ok 8 - Mean of 10, 20, 30 degrees
ok 9 - Mean of 355, 5, 15 degrees
```

Note that I had to use the `is-approx`

function of the Test module (instead of the simple `is`

function) for tests computing the mean because I would otherwise get failed tests due to rounding issues:

```
# Failed test 'Mean of 10, 20, 30 degrees'
# at angle-mean.p6 line 22
# expected: '20'
# got: '19.999999999999996'
not ok 9 - Mean of 355, 5, 15 degrees
```

As you can see, the program computes 19.999999999999996, where I expect 20, which is nearly the same numeric value.

I actually expected similar problems with Perl 5, but, for some reason, it did not occur. Perhaps the P5 `Test::More`

module has a built-in approximate numeric comparison that silently takes care of such problems.

*Update:* as note above in the P5 section of this task following *Saif*'s comment, we don't really need to divide the arguments of the `atan2`

built-in function by the number of angles. The `mean`

subroutine can be simplified as follows:

```
sub mean (*@degrees) {
my @radians = map { deg2rad $_ }, @degrees;
my $sum-sin = [+] @radians.map( {sin $_});
my $sum-cos = [+] @radians.map( {cos $_});
return rad2deg atan2 $sum-sin, $sum-cos;
}
```

The tests display the same results as before.

*End update.*

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

]]>I have been thinking about your suggestion. Assuming I've understood it correctly, I'm afraid it cannot be used in the general case. Although it seems to work well in the case of our specific list of names (all my sequences end up with Audino, which cannot have any successor), there could be cases where the longest sequence does not end with a name that has no successor in the input list, but ends with a name that has one (or possibly several) successor(s) in the input list, since that successor cannot be used because that successor has already been used before.

As an example of another possible problem, suppose you have the following list of names: abc cbd dec cba baz. The only name with no successor is baz, but baz is not part of the longest sequence. The longest sequence is (abc cbd dec cba) or (cba abc cbd dec). Computing the list backward from baz will not lead you anywhere near the longest sequence. So, while your optimization may work well with the Pokémon list provided by Mohammad, I don't think it works in the general case (again, assuming I've understood your proposal correctly).

Best, Laurent.

]]>thank you very much for your input. I thought, when considering how to solve the task, about whether doing it backward would help, but could not see any benefit of doing so at the time. Right now, it is almost midnight here and I'm just coming back from a Paris Perl Mongers social meeting, meaning that I had some glasses of wine. Not the best situation to think clearly about your comments. I'll come back tomorrow evening and try to think more about your suggestions.

Cheers, Laurent.

]]>

for some reason, the correction you suggested wasn't successful. But your diagnosis was certainly right. I made a slightly different correction aimed at removing the grep, and the execution time was almost halved. You can see above the update I made to my post (with due credit to you). Thank you very much for your enlightening idea.

Cheers, Laurent.

]]>