Perl Weekly Challenge 165: Scalable Vector Graphics

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

This week, Task 1 and part of Task 2 relate to Scalable Vector Graphics (SVG). I’d been using SVG a very long time ago and certainly didn’t remember any of the details. So, in my first blog relating to PWC 165, I stated that I didn’t have time for that and covered only the part of the challenge not related to SVG. I also said that, in the event that I find some time over the weekend, I might come back and fulfill the SVG part. I thought at the time that this was rather unlikely, but I was finally able to cover the SVG part, at least in Raku.

Task 1: Scalable Vector Graphics (SVG)

Scalable Vector Graphics (SVG) are not made of pixels, but lines, ellipses, and curves, that can be scaled to any size without any loss of quality. If you have ever tried to resize a small JPG or PNG, you know what I mean by “loss of quality”! What many people do not know about SVG files is, they are simply XML files, so they can easily be generated programmatically.

For this task, you may use external library, such as Perl’s SVG library, maintained in recent years by our very own Mohammad S Anwar. You can instead generate the XML yourself; it’s actually quite simple. The source for the example image for Task #2 might be instructive.

Your task is to accept a series of points and lines in the following format, one per line, in arbitrary order:

Point: x,y

Line: x1,y1,x2,y2

Example:

53,10
53,10,23,30
23,30

Then, generate an SVG file plotting all points, and all lines. If done correctly, you can view the output .svg file in your browser.

Scalable Vector Graphics (SVG) in Raku

I created two subroutines, make-point and make-line, to create the necessary data structures. The last item of the @input has three parts and should generate a warning, since input items should have either 2 or 4 parts.

Note that SVG probably includes a scaling factor, but I couldn’t find any information about it. So I rolled out my own \SCALE scaling factor to make the output larger and more readable.

use SVG;
my \SCALE = 5;

my ( @points, @lines);
my @input = <53,10  53,10,23,30  23,30  34,35,36>;
for @input -> $val {
    my @items = split /','/, $val;
    if @items.elems == 2 {
        make-point(@items)
    } elsif @items.elems == 4 {
        make-line(@items);
    } else { 
        note "Error on item ", @items;
    }
}

say ( SVG.serialize(svg => [ width => 500, height => 500, |@points, |@lines ] ));

sub make-point (@dots) {
    @dots = map { $_ * SCALE }, @dots;
    my $point = circle =>  
        [ cx => @dots[0],
          cy => @dots[1],
          r => 3,
          fill => 'forestgreen' ];
    push @points, $point;
}

sub make-line (@dots) {
    @dots = map { $_ * SCALE }, @dots;
    my $line = line => 
        [ x1 => @dots[0],
          y1 => @dots[1],
          x2 => @dots[2],
          y2 => @dots[3],
          stroke => 'navy' ];
    push @lines, $line;
}

The SVG output, slightly reformatted for better readability, is as follows:

<svg xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" 
xmlns:xlink="http://www.w3.org/1999/xlink" width="500" height="500">
<circle cx="265" cy="50" r="3" fill="forestgreen" />
<circle cx="115" cy="150" r="3" fill="forestgreen" />
<line x1="265" y1="50" x2="115" y2="150" stroke="navy" /></svg>

And this is a graphical rendering of it:

svg1bis.png

Scalable Vector Graphics (SVG) in Perl

In Perl, for a change, we will write directly the SVG data.

use strict;
use warnings;
use feature "say";
use constant SCALE => 5;

my ( @points, @lines);
my $out = qq{<svg xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" 
xmlns:xlink="http://www.w3.org/1999/xlink" width="500" height="500">\n};
my @input = qw<53,10 53,10,23,30  23,30  34,35,36>;
for my $val (@input) {
    my @items = split /,/, $val;
    # say "@items";
    if (@items == 2) {
        make_point(@items)
    } elsif (@items == 4) {
        make_line(@items);
    } else { 
        warn "Error on item ", @items;
    }
}
$out .= "</svg>";
say $out;

sub make_point {
    my @dots = map $_ * SCALE, @_;
    my $point = qq{<circle cx= "$dots[0]" cy="$dots[1]" r="3" fill="forestgreen"/>\n};
    $out .= $point;
}

sub make_line {
    my @dots = map $_ * SCALE, @_;
    my $line = qq{<line x1="$dots[0]" y1="$dots[1]" x2="$dots[2]" y2="$dots[3]" };
    $line .= qq{stroke="navy" />\n};
    $out .= $line
}

This program displays the following SVG output:

<svg xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg"
xmlns:xlink="http://www.w3.org/1999/xlink" width="500" height="500">
<circle cx= "265" cy="50" r="3" fill="forestgreen"/>
<line x1="265" y1="50" x2="115" y2="150" stroke="navy" />
<circle cx= "115" cy="150" r="3" fill="forestgreen"/>
</svg>

And this is the graphgical rendering:

svg1bis.png

Task 2: Line of Best Fit

When you have a scatter plot of points, a line of best fit is the line that best describes the relationship between the points, and is very useful in statistics. Otherwise known as linear regression, here is an example of what such a line might look like:

line_of_best_fit.jpg

The method most often used is known as the least squares method, as it is straightforward and efficient, but you may use any method that generates the correct result.

Calculate the line of best fit for the following 48 points:

333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89

Using your rudimentary graphing engine from Task #1, graph all points, as well as the line of best fit.

So, Task 2 is about line of best fit or linear regression.

If we consider a cloud of n points with coordinates (x, y), the line of best fit is defined as follows:

The equation for the slope m is:

    n * sum(xy) - sum(x) * sum(y)
m = -----------------------------
    n * sum(x²) - sum(x) * sum(x)

The y-intercept (i.e. value of y on the vertical axis, when x = 0) b is:

    sum(y) - m * sum(x)
b = -------------------
           n

The equation of the line is:

y = mx + b

Line of Best Fit in Raku

The following program is an application of the explanations above. We split the input string on spaces and on commas, to get an array of (x, y) values. The lsm subroutine applies the above least square method formulas to find the slope and intercept. Note that for displaying line of best fit equation, we had to handle two different cases, depending on whether the intercept is positive or negative. Otherwise, for a negative intercept, we would display the line equation as follows:

The equation of the line of best fit is: y = 1.00 x + -1.00

which is not satisfactory.

Also note the use of the » hyper operator when reading the input data to apply the second split to each of the values returned by the first split.

Besides, we reuse the make-point and make-line subroutines created above (slightly modified) for preparing the SVG output.

use SVG;
my \SCALE = 1;

my $input =
   '333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
    341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
    284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
    128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
    215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
    275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89';

my @points = $input.split(/\s+/)>>.split(/','/);
my (@dots, @lines);
make-point($_) for @points;
my ($slope, $intercept) = lsm(@points);
say "Slope: $slope, intercept = $intercept";
my $sign = $intercept < 0 ?? '-' !! '+';
printf "The equation of the line of best fit is: y = %.2f x %s %.2f \n\n", $slope, $sign, $intercept.abs;
# compute some arbitrary values for the line - say for x = 400
my $x = 400;
my $y = $slope * $x + $intercept;
make-line([0, $intercept, $x, $y]);
say ( SVG.serialize(svg => [ width => 500, height => 500, |@dots, |@lines ]));

sub lsm (@points) {
    my ($s-x, $s-y, $s-xy, $s-x2) = 0 xx 4;
    for @points -> $point {
        my ($x, $y) = $point[0, 1];
        # say "$x $y";
        $s-x += $x;
        $s-y += $y;
        $s-xy += $x * $y;
        $s-x2 += $x ** 2;
    }
    my $n = @points.elems;
    my $slope = ($n * $s-xy - $s-x * $s-y) / ($n * $s-x2 - $s-x ** 2);
    my $intercept = ($s-y - $slope * $s-x) / $n;
    return $slope, $intercept;
}

sub make-point (@points is copy) {
    @points = map { $_ * SCALE }, @points;
    my $point = circle =>  
        [ cx => @points[0],
          cy => @points[1],
          r => 3,
          fill => 'forestgreen' ];
    push @dots, $point;
}

sub make-line (@dots) {
    @dots = map { $_ * SCALE }, @dots;
    my $line = line => 
        [ x1 => @dots[0],
          y1 => @dots[1],
          x2 => @dots[2],
          y2 => @dots[3],
          stroke => 'navy' ];
    push @lines, $line;
}

This program displays the following output:

$ ./raku lsm2.raku
Slope: -0.2999565, intercept = 200.132272536
The equation of the line of best fit is: y = -0.30 x + 200.13

<svg xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" 
xmlns:xlink="http://www.w3.org/1999/xlink" width="500" height="500">
<circle cx="333" cy="129" r="3" fill="forestgreen" /><circle cx="39" cy="189" r="3" fill="forestgreen" />
<circle cx="140" cy="156" r="3" fill="forestgreen" /><circle cx="292" cy="134" r="3" fill="forestgreen" />
<circle cx="393" cy="52" r="3" fill="forestgreen" /><circle cx="160" cy="166" r="3" fill="forestgreen" />
<circle cx="362" cy="122" r="3" fill="forestgreen" /><circle cx="13" cy="193" r="3" fill="forestgreen" />
<circle cx="341" cy="104" r="3" fill="forestgreen" /><circle cx="320" cy="113" r="3" fill="forestgreen" />
<circle cx="109" cy="177" r="3" fill="forestgreen" /><circle cx="203" cy="152" r="3" fill="forestgreen" />
<circle cx="343" cy="100" r="3" fill="forestgreen" /><circle cx="225" cy="110" r="3" fill="forestgreen" />
<circle cx="23" cy="186" r="3" fill="forestgreen" /><circle cx="282" cy="102" r="3" fill="forestgreen" />
<circle cx="284" cy="98" r="3" fill="forestgreen" /><circle cx="205" cy="133" r="3" fill="forestgreen" />
<circle cx="297" cy="114" r="3" fill="forestgreen" /><circle cx="292" cy="126" r="3" fill="forestgreen" />
<circle cx="339" cy="112" r="3" fill="forestgreen" /><circle cx="327" cy="79" r="3" fill="forestgreen" />
<circle cx="253" cy="136" r="3" fill="forestgreen" /><circle cx="61" cy="169" r="3" fill="forestgreen" />
<circle cx="128" cy="176" r="3" fill="forestgreen" /><circle cx="346" cy="72" r="3" fill="forestgreen" />
<circle cx="316" cy="103" r="3" fill="forestgreen" /><circle cx="124" cy="162" r="3" fill="forestgreen" />
<circle cx="65" cy="181" r="3" fill="forestgreen" /><circle cx="159" cy="137" r="3" fill="forestgreen" />
<circle cx="212" cy="116" r="3" fill="forestgreen" /><circle cx="337" cy="86" r="3" fill="forestgreen" />
<circle cx="215" cy="136" r="3" fill="forestgreen" /><circle cx="153" cy="137" r="3" fill="forestgreen" />
<circle cx="390" cy="104" r="3" fill="forestgreen" /><circle cx="100" cy="180" r="3" fill="forestgreen" />
<circle cx="76" cy="188" r="3" fill="forestgreen" /><circle cx="77" cy="181" r="3" fill="forestgreen" />
<circle cx="69" cy="195" r="3" fill="forestgreen" /><circle cx="92" cy="186" r="3" fill="forestgreen" />
<circle cx="275" cy="96" r="3" fill="forestgreen" /><circle cx="250" cy="147" r="3" fill="forestgreen" />
<circle cx="34" cy="174" r="3" fill="forestgreen" /><circle cx="213" cy="134" r="3" fill="forestgreen" />
<circle cx="186" cy="129" r="3" fill="forestgreen" /><circle cx="189" cy="154" r="3" fill="forestgreen" />
<circle cx="361" cy="82" r="3" fill="forestgreen" /><circle cx="363" cy="89" r="3" fill="forestgreen" />
<line x1="0" y1="200.132272536" x2="400" y2="80.149672431" stroke="navy" />
</svg>

And this is a graphiical rendering of it:

svg2.png

Wrapping up

The next week Perl Weekly Challenge will 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 May 29, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 165: Line of Best Fit

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

Spoiler Alert: This weekly challenge deadline is due in a few of days from now (on May 22, 2022 at 24:00). This blog post offers some (partial) solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

This week, Task 1 and part of Task 2 relate to Scalable Vector Graphics (SVG). I’ve been using SVG a very long time ago and certainly don’t remember any of the details. SVG is certainly not very difficult, and I would be delighted to refresh my memory on this subject, but it takes quite a bit of time to assimilate all the possibilities and options, and I don’t have time for that now. So, I will only cover for the moment the part of the challenge not related to SVG. In the (relatively unlikely) event that I find some time over the weekend, I might come back and fulfill the SVG part.

Update: I eventually covered the SVG part in Raku here.

So, Task 2 is about line of best fit or linear regression.

When you have a scatter plot of points, a line of best fit is the line that best describes the relationship between the points, and is very useful in statistics. Otherwise known as linear regression, here is an example of what such a line might look like:

line_of_best_fit.jpg

The method most often used is known as the least squares method, as it is straightforward and efficient, but you may use any method that generates the correct result.

Calculate the line of best fit for the following 48 points:

333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89

If we consider a cloud of n points with coordinates (x, y), the line of best fit is defined as follows:

The equation for the slope m is:

    n * sum(xy) - sum(x) * sum(y)
m = -----------------------------
    n * sum(x²) - sum(x) * sum(x)

The y-intercept (i.e. value of y on the vertical axis, when x = 0) b is:

    sum(y) - m * sum(x)
b = -------------------
           n

The equation of the line is:

y = mx + b

Line of Best Fit in Raku

The following program is just an application of the explanations above. We split the input string on spaces and on commas, to get an array of (x, y) values. The lsm subroutine applies the above least square method formulas to find the slope and intercept. Note that for displaying line of best fit equation, we had to handle two different cases, depending on whether the intercept is positive or negative. Otherwise, for a negative intercept, we would display the line equation as follows:

The equation of the line of best fit is: y = 1.00 x + -1.00

which is not satisfactory.

Also note the use of the » hyper operator when reading the input data to apply the second split to each of the values returned by the first split.

my $input =
   '333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
    341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
    284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
    128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
    215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
    275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89';

# $input = '1,0 2,1 3,2 4,3'; # test with a negative intercept

my @points = $input.split(/\s+/)».split(/','/);
my ($slope, $intercept) = lsm(@points);
say "Slope: $slope, intercept = $intercept";
my $sign = $intercept < 0 ?? '-' !! '+'; 
printf "The equation of the line of best fit is: y = %.2f x %s %.2f \n", $slope, $sign, $intercept.abs;

sub lsm (@points) {
    my ($s-x, $s-y, $s-xy, $s-x2) = 0 xx 4;
    for @points -> $point {
        my ($x, $y) = $point[0, 1];
        $s-x += $x;
        $s-y += $y;
        $s-xy += $x * $y;
        $s-x2 += $x ** 2;
    }
    my $n = @points.elems;
    my $slope = ($n * $s-xy - $s-x * $s-y) / ($n * $s-x2 - $s-x ** 2);
    my $intercept = ($s-y - $slope * $s-x) / $n;
    return $slope, $intercept;
}

This program displays the following output:

$ raku ./lsm.raku
10366, 6497, 1220463, 2847440
Slope: -0.2999565, intercept = 200.132272536
The equation of the line of best fit is: y = -0.30 x + 200.13

Uncomment the line redefining the input string to display the result with a negative intercept:

$ raku ./lsm.raku
Slope: 1, intercept = -1
The equation of the line of best fit is: y = 1.00 x - 1.00

Line of Best Fit in Perl

We are applying here the same equations as before in Raku. For the final display of the line equation, we also have to handle separate cases, depending on whether the intercept is positive or negative. Perl doesn’t have the » hyper-operator, but it is quite easy to replace it with a map.

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

my $input =
   '333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
    341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
    284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
    128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
    215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
    275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89';

# $input = '1,0 2,1 3,2 4,3';   # test with a negative intercept

my @points = map { [split /,/, $_] } split /\s+/, $input;
my ($sl, $inter) = lsm(@points);
say "Slope: $sl, intercept = $inter";
my $sign = $inter < 0 ? '-' : '+';
printf "The equation of the line of best fit is: y = %.2f x %s %.2f \n", $sl, $sign, abs $inter;

sub lsm {
    my @points = @_;
    my ($s_x, $s_y, $s_xy, $s_x2) = (0, 0, 0, 0);
    for my $point (@points) {
        my ($x, $y) = ($point->[0], $point->[1]);
        $s_x += $x;
        $s_y += $y;
        $s_xy += $x * $y;
        $s_x2 += $x ** 2;
    }
    my $n = scalar @points;
    my $slope = ($n * $s_xy - $s_x * $s_y) / ($n * $s_x2 - $s_x ** 2);
    my $intercept = ($s_y - $slope * $s_x) / $n;
    return $slope, $intercept;
}

This program displays the following output:

$ perl ./lsm.pl
Slope: -0.299956500261231, intercept = 200.132272535582
The equation of the line of best fit is: y = -0.30 x + 200.13

Uncomment the line redefining the input string to display the result with a negative intercept:

$ perl ./lsm.pl
Slope: 1, intercept = -1
The equation of the line of best fit is: y = 1.00 x - 1.00

Wrapping up

The next week Perl Weekly Challenge will 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 May 29, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 164: Prime Palindromes and Happy Numbers

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

Spoiler Alert: This weekly challenge deadline is due in a few of days from now (on May 15, 2022 at 24:00). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Prime Palindromes

Write a script to find all prime numbers less than 1000, which are also palindromes in base 10. Palindromic numbers are numbers whose digits are the same in reverse. For example, 313 is a palindromic prime, but 337 is not, even though 733 (337 reversed) is also prime.

Prime Palindromes in Raku

We use a data pipeline (chained method invocations) with two grep statements, one to keep palindromes and one to keep prime numbers. This leads to a fairly concise one-line solution:

say (1..^1000).grep({ $_ == .flip }).grep({.is-prime});

This works because, with such chained method invocations, the output of the first grep is fed as input to the second grep. This script displays the following output:

$ raku ./prime-palindrome.raku
(2 3 5 7 11 101 131 151 181 191 313 353 373 383 727 757 787 797 919 929)

We can also do it as a Raku one-liner:

$ raku -e 'say (1..^1000).grep({ $_ == .flip }).grep({.is-prime});'
(2 3 5 7 11 101 131 151 181 191 313 353 373 383 727 757 787 797 919 929)

Prime Palindromes in Perl

Perl doesn’t have a built-in function to determine whether an integer is prime, so we write our own is_prime subroutine. Since we’re eventually going to test only slightly more than 100 small integers, there is no need to aggressively optimize the performance of this subroutine. The program runs in significantly less than a tenth of a second.

Once we have implemented the is-prime subroutine, we can use a data pipeline (piped function calls) as before to solve the problem in just one code line:

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

sub is_prime {
    my $num = shift;
    return 1 if $num == 2;
    return 0 unless $num % 2;
    my $test = 3;
    while ($test < $num/2) {
        return 0 if $num % $test == 0;
        $test += 2;
    }
    return 1;
}

say map "$_ ", grep { is_prime $_} grep {$_ == reverse $_} 1..999;

This data pipeline should be read from right to left: we start with a range of integers between 1 and 999, apply a first filter (grep {$_ == reverse $_}) to keep only the palindromic integers, apply a second filter to retain only the primes, and finally a map to properly format the output (add a space between the values).

This program displays the following output:

$ perl ./prime-palindrome.pl
1 2 3 5 7 11 101 131 151 181 191 313 353 373 383 727 757 787 797 919 929

Task 2: Happy Numbers

Write a script to find the first 8 Happy Numbers in base 10. For more information, please check out Wikipedia.

Starting with any positive integer, replace the number by the sum of the squares of its digits, and repeat the process until the number equals 1 (where it will stay), or it loops endlessly in a cycle which does not include 1.

Those numbers for which this process end in 1 are happy numbers, while those numbers that do not end in 1 are unhappy numbers.

Example:

19 is Happy Number in base 10, as shown:

19 => 1^2 + 9^2
   => 1   + 81
   => 82 => 8^2 + 2^2
         => 64  + 4
         => 68 => 6^2 + 8^2
               => 36  + 64
               => 100 => 1^2 + 0^2 + 0^2
                      => 1 + 0 + 0
                      => 1

Basically, we need a subroutine to perform iteratively the process of replacing the current number with the sum of the squares of its digit. If we find 1, then we’ve found an happy number and can return a true value to break out of the process. If we find a number that we have already seen, then we have entered into an endless loop, which means that have found an unhappy (or sad) number, and we can return a false value to break out of the process.

Happy Numbers in Raku

The is-happy subroutine implements the algorithm described above. We use a SetHash to store the intermediate values and check whether we have entered into an endless loop. Note that we create an infinite lazy list of happy numbers, and then print out the number of happy numbers that we need.

sub is-happy(Int $n is copy) {
    my $seen = SetHash.new;
    loop {
        return True if $n == 1;
        return False if $n ∈ $seen;
        $seen{$n} = True;
        $n = $n.comb.map({$_ ** 2}).sum;
    }
}
my @happy-numbers = grep {is-happy $_}, 1..Inf;
say @happy-numbers[0..7];

This program displays the following output:

$ raku ./happy-numbers.raku
(1 7 10 13 19 23 28 31)

Happy Numbers in Perl

In Perl, the is_happy subroutine implements again the algorithm outlined above. We use a plain hash to store the intermediate values and check whether we have entered into an endless loop.

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

sub is_happy {
    my $n = shift;
    my %seen;
    while (1) {
        return 1 if $n == 1;
        return 0 if exists $seen{$n};
        $seen{$n} = 1;
        my $sum = 0;
        $sum += $_ for map $_ ** 2, split //, $n;
        $n = $sum;
    }
}
my $count = 0;
my $i = 1;
while ($count < 8) {
    if (is_happy $i) {
        print "$i ";
        $count++;
    }
    $i++;
}
say "";

This program displays the following output:

$ perl ./happy-numbers.pl
1 7 10 13 19 23 28 31

Wrapping up

The next week Perl Weekly Challenge will 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 May 22, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 163: Sum Bitwise Operator and Summations

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on May 8, 2022 at 24:00). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Sum Bitwise Operator

You are given list positive numbers, @n.

Write script to calculate the sum of bitwise & operator for all unique pairs.

Example 1:

Input: @n = (1, 2, 3)
Output: 3

Since (1 & 2) + (2 & 3) + (1 & 3) => 0 + 2 + 1 =>  3.

Example 2:

Input: @n = (2, 3, 4)
Output: 2

Since (2 & 3) + (2 & 4) + (3 & 4) => 2 + 0 + 0 =>  2.

Sum Bitwise Operator in Raku

In Raku, the numeric bitwise AND is spelled ~&, not &. We will use it together with the reduction operator) [~&] on all possible unordered pairs (generated with the combinations method). We then sum the partial results.

for <1 2 3>, <2 3 4> -> @n {
    say @n, " -> ", ([~&] $_ for @n.combinations(2)).sum;
}

This script displays the following results:

$ raku ./bitwise-sum.raku
(1 2 3) -> 3
(2 3 4) -> 2

This is almost a one-liner, except for the fact that we need more than one line only because there are two tests. We can easily rewrite it as a pure Raku one-liner:

$ raku -e 'say ([~&] $_ for @*ARGS.combinations(2)).sum;' 1 2 3
3
$ raku -e 'say ([~&] $_ for @*ARGS.combinations(2)).sum;' 2 3 4
2

Sum Bitwise Operator in Perl

In Perl, we write a combine2 subroutine with two nested loops to generate a list of pairs. We then add the results of the & operators on such pairs.

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

sub combine2 {
    my @combinations;
    my @in = @_;
    for my $i (0..$#in) {
        for my $j ($i + 1 .. $#in) {
            push @combinations, [$in[$i], $in[$j]];
        }
    }
    return @combinations;
}

for my $test ([qw <1 2 3>], [qw <2 3 4>]) {
    my $sum = 0;
    $sum += $_->[0] & $_->[1] for combine2 @$test;
    say "@$test -> ", $sum;
}

This program displays the following output:

$ perl ./bitwise-sum.pl
1 2 3 -> 3
2 3 4 -> 2

Task 2: Summations

You are given a list of positive numbers, @n.

Write a script to find out the summations as described below.

Example 1:

Input: @n = (1, 2, 3, 4, 5)
Output: 42

    1 2 3  4  5
      2 5  9 14
        5 14 28
          14 42
             42

The nth Row starts with the second element of the (n-1)th row.
The following element is sum of all elements except first element of previous row.
You stop once you have just one element in the row.

Example 2:

Input: @n = (1, 3, 5, 7, 9)
Output: 70

    1 3  5  7  9
      3  8 15 24
         8 23 47
           23 70
              70

Summations in Raku

We will use the triangular reduction operator [\+]. It returns a lazy list of all intermediate partial results, which happens to be exactly what we need here.

sub summations (@in) {
    my @result = @in;
    for 1..@result.end {
        @result = [\+] @result[1..*-1];
        return @result[0] if @result.elems == 1;
    }
}

for <1 2 3 4 5>, <1 3 5 7 9> -> @test {
    say @test, " -> ", summations @test;
}

This program displays the following output:

$ raku ./summations.raku
(1 2 3 4 5) -> 42
(1 3 5 7 9) -> 70

Summations in Perl

We use a sum subroutine, which returns the sum of its arguments. We then use a for loop to compute the partial sums.

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

sub sum {
    my $sum = 0;
    $sum += $_ for @_;
    return $sum;
}

sub summations {
    my @result = @_;
    for (1..$#result) {
        my @temp;
        push @temp, sum (@result[1..$_]) for 1..$#result;
        @result = @temp;
        return $result[0] if @result == 1;
    }
}
for my $test ([qw <1 2 3 4 5>], [qw <1 3 5 7 9>]) {
    say "@$test -> ", summations @$test;
}

This program displays the following output:

$ perl ./summations.pl
1 2 3 4 5 -> 42
1 3 5 7 9 -> 70

Wrapping up

The next week Perl Weekly Challenge will 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 May 15, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 162: ISBN-13 and Wheatstone-Playfair

These are some answers to the Week 162 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 (on May 1st, 2022 at 24:00). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: ISBN-13

Write a script to generate the check digit of given ISBN-13 code. Please refer wikipedia for more information.

Example

ISBN-13 check digit for '978-0-306-40615-7' is 7.

This how Wikipedia describes the calculation of the ISBN-13 check digit:

Appendix 1 of the International ISBN Agency’s official user manual describes how the 13-digit ISBN check digit is calculated. The ISBN-13 check digit, which is the last digit of the ISBN, must range from 0 to 9 and must be such that the sum of all the thirteen digits, each multiplied by its (integer) weight, alternating between 1 and 3, is a multiple of 10.

Formally, using modular arithmetic, this is rendered:

ISBN_formula.png

The calculation of an ISBN-13 check digit begins with the first twelve digits of the 13-digit ISBN (thus excluding the check digit itself). Each digit, from left to right, is alternately multiplied by 1 or 3, then those products are summed modulo 10 to give a value ranging from 0 to 9. Subtracted from 10, that leaves a result from 1 to 10. A zero replaces a ten, so, in all cases, a single check digit results.

For example, the ISBN-13 check digit of 978-0-306-40615-? is calculated as follows:

s = 9×1 + 7×3 + 8×1 + 0×3 + 3×1 + 0×3 + 6×1 + 4×3 + 0×1 + 6×3 + 1×1 + 5×3
  =  9 + 21 +  8 +  0 +  3 + 0 +  6 + 12 +  0 + 18 + 1 + 15
  = 93
93 / 10 = 9 remainder 3
10 –  3 = 7

Thus, the check digit is 7, and the complete sequence is ISBN 978-0-306-40615-7.

Once we understand the process, this is pretty straight forward.

ISBN-13 in Raku

Here, we take advantage of the possibility in Raku to use 2 loop variables in the signature of a pointy block (and pick two values from the input list), as this makes it very easy alternate multiplications by 1 and by 3.

my $isbn = "978-0-306-40615-";
my $sum = 0;
for $isbn.comb.grep(/\d/) -> $i, $j {
    $sum += $i + 3 * $j;
}
my $check = 10 - $sum % 10;
say $check;

This program displays the following output:

$ raku ./isbn-13.raku
7

ISBN-13 in Perl

In Perl, we multiply each value by $k, with $k alternating between 1 and 3.

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

my $isbn = "978-0-306-40615-";
my $sum = 0;
my $k = 1;
for my $i (grep {/\d/} split //, $isbn) {
    $sum += $k * $i;
    $k = $k == 1 ? 3 : 1;
}
my $check = 10 - $sum % 10;
say $check;

This program displays the following output:

$ perl ./isbn-13.pl
7

Task 2: Wheatstone-Playfair

Implement encryption and decryption using the Wheatstone-Playfair cipher.

Examples:

(These combine I and J, and use X as padding.)

encrypt("playfair example", "hide the gold in the tree stump") = "bmodzbxdnabekudmuixmmouvif"

decrypt("perl and raku", "siderwrdulfipaarkcrw") = "thewexeklychallengex"

This is a description of the Wheatstone-Playfair cipher algorithm provided by the Wikipedia page referred to above:

The Playfair cipher uses a 5 by 5 table containing a key word or phrase. Memorization of the keyword and 4 simple rules was all that was required to create the 5 by 5 table and use the cipher.

To generate the key table, one would first fill in the spaces in the table (a modified Polybius square) with the letters of the keyword (dropping any duplicate letters), then fill the remaining spaces with the rest of the letters of the alphabet in order (usually omitting “J” or “Q” to reduce the alphabet to fit; other versions put both “I” and “J” in the same space). The key can be written in the top rows of the table, from left to right, or in some other pattern, such as a spiral beginning in the upper-left-hand corner and ending in the center. The keyword together with the conventions for filling in the 5 by 5 table constitute the cipher key.

To encrypt a message, one would break the message into digrams (groups of 2 letters) such that, for example, “HelloWorld” becomes HE LL OW OR LD. These digrams will be substituted using the key table. Since encryption requires pairs of letters, messages with an odd number of characters usually append an uncommon letter, such as “X”, to complete the final digram. The two letters of the digram are considered opposite corners of a rectangle in the key table. To perform the substitution, apply the following 4 rules, in order, to each pair of letters in the plaintext:

  • If both letters are the same (or only one letter is left), add an “X” after the first letter. Encrypt the new pair and continue. Some variants of Playfair use “Q” instead of “X”, but any letter, itself uncommon as a repeated pair, will do.

  • If the letters appear on the same row of your table, replace them with the letters to their immediate right respectively (wrapping around to the left side of the row if a letter in the original pair was on the right side of the row).

  • If the letters appear on the same column of your table, replace them with the letters immediately below respectively (wrapping around to the top side of the column if a letter in the original pair was on the bottom side of the column).

  • If the letters are not on the same row or column, replace them with the letters on the same row respectively but at the other pair of corners of the rectangle defined by the original pair. The order is important – the first letter of the encrypted pair is the one that lies on the same row as the first letter of the plaintext pair.

To decrypt, use the inverse (opposite) of the last 3 rules, and the first as-is (dropping any extra “X”s or “Q”s that do not make sense in the final message when finished).

See the referred Wikipedia page for further information and a detailed example.

The data structure to store the cipher table will consist in an array (@c2l, coordinates to letter) for trans-coding from coordinates to letters, and a hash (%l2c, letter to coordinates) for trans-coding from letter to coordinates. Since the Playfair cipher uses a 5 by 5 table, we can have only 25 letters, so that occurrences of letter J will be replaced by I.

When decrypting a message, the Playfair cipher uses the same rules as when encrypting, except that we need to move one step left instead of right or one step up instead of down. We will use the same convert subroutine for both encrypting and decrypting and pass a “direction” parameter of 1 for encrypting and -1 for decrypting; this direction parameter determines whether we move right/down or left/up.

Wheatstone-Playfair in Raku

my (@c2l, %l2c);   # coordinates to letter, letter to coordinates

sub make-cipher-table (Str $in) {
    @c2l = ();
    %l2c = ();
    my $key = $in.lc;
    $key ~~ s:g/j/i/; # we can handle 25 letters, replace J's with I's
    $key ~~ s:g/\W//; # remove non alphanumecicals chars
    my @chars = ($key.comb, 'a'..'i', 'k'..'z').flat;
    my $i = 0;
    for @chars -> $let {
        next if %l2c{$let}:exists;
        my $row = $i div 5;
        my $col = $i % 5;
        $i++;
        %l2c{$let} = $row, $col;
        @c2l[$row][$col] = $let;
    }
}

sub encrypt ($in) {
    my $msg = $in.lc;
    $msg ~~ s:g/j/i/; 
    $msg ~~ s:g/\W//; # remove non alphanumecicals chars
    $msg ~~ s:g/(.)$0/$0x$0/;  # adding 'x' between two identical letters
    $msg ~= "x" if $msg.chars % 2;  # padding
    return convert(1, $msg);
}

sub decrypt ($in) {
  return convert(-1, $in);
}

sub convert (Int $d, Str $msg) {
    # $d (direction) = 1 for encrypting and -1 for decrypting
    my $out = "";
    my $second;
    for $msg.comb -> $first, $second {
        my ($row1, $row2) = %l2c{$first}[0], %l2c{$second}[0];
        my ($col1, $col2) = %l2c{$first}[1], %l2c{$second}[1];
        if $row1 == $row2 {                     # same row
            $out ~= (@c2l[$row1][($col1 + $d)%5]) ~
                    (@c2l[$row2][($col2 + $d)%5]);
        } elsif $col1 == $col2 {                # same column
            $out ~= (@c2l[($row1 + $d) %5][$col1]) ~
                    (@c2l[($row2 + $d) %5][$col2]);
        } else {                                # rectangle
            $out ~= (@c2l[$row1][$col2]) ~ 
                    (@c2l[$row2][$col1]);
        }
    }
    return $out;
}

make-cipher-table("playfair example");
my $msg = "hide the gold in the tree stump";
my $crypted = encrypt($msg);
say "$msg -> $crypted";
say "Round trip: ", decrypt $crypted;

make-cipher-table("perl and raku");
$msg = "siderwrdulfipaarkcrw";
my $decrypted = decrypt $msg;
say "$msg -> $decrypted";

This script displays the following output:

$ raku ./mayfair.raku
hide the gold in the tree stump -> bmodzbxdnabekudmuixmmouvif
Round trip: hidethegoldinthetrexestump
siderwrdulfipaarkcrw -> kmeaxuecnupmfllenbxu

Note that originally did not create the $row1, $col1, $row2, and $col2 intermediate variables, but I had to use them here because, for some reason, the Raku compiler choked at expressions such as:

$out ~= (@c2l[%l2c{$first }[0]][(%l2c{$first }[1] + $d)%5]) ~
        (@c2l[%l2c{$second}[0]][(%l2c{$second}[1] + $d)%5]);

although I think they were correct. Adding extra parentheses or giving other clues to the compiler did not help (or, perhaps, I wasn’t able to find the right clues). As we will see below, the Perl compiler appears to do a better job at such complicated nested expressions. Replacing %l2c{$first}[0] with $row1 (and so on) solved the problem, but I wish I didn’t have to do that.

Wheatstone-Playfair in Perl

This is a port to Perl of the Raku program (except that I did not need to introduce the $row1, $col1, $row2, and $col2 intermediate variables as in Raku.

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

sub make_cipher_table {
    my $key = lc $_[0];
    $key =~ s/j/i/g; # we can handle 25 letters, replace J's with I's
    $key =~ s/\W//g; # remove non alphanumecicals chars
    my @chars = ((split //, $key), 'a'..'i', 'k'..'z');
    my $i = 0;
    my (@c2l, %l2c);   # coordinates to letter, letter to coordinates
    for my $let (@chars) {
        next if exists $l2c{$let};
        my $row = int $i / 5;
        my $col = $i % 5;
        $i++;
        $l2c{$let} = [$row, $col];
        $c2l[$row][$col] = $let;
    }
    return \@c2l, \%l2c
}

sub encrypt {
    my $msg = lc $_[0];
    $msg =~ s/j/i/g; 
    $msg =~ s/\W//g; # remove non alphanumecicals chars
    $msg =~ s/(.)\1/$1x$1/;  # adding 'x' between two identical letters
    $msg =~ "x" if length($msg) % 2;  # padding
    return convert(1, $msg);
}

sub decrypt {
  return convert(-1, $_[0]);
}

my ($c, $l) = make_cipher_table("playfair example");
my @c2l = @$c;
my %l2c = %$l;
my $msg = "hide the gold in the tree stump";
my $crypted = encrypt($msg);
say "$msg -> $crypted";
say "Round trip: ", decrypt $crypted;
($c, $l) = make_cipher_table("perl and raku");
@c2l = @$c;
%l2c = %$l;
$msg = "siderwrdulfipaarkcrw";
my $decrypted = decrypt $msg;
say "$msg -> $decrypted";

sub convert {
    my ($d, $msg) = @_;
    # $d (direction) = 1 for encrypting and -1 for decrypting
    my $out = "";
    my @letters = split //, $msg;
    while (@letters) {
        my ($first, $second) = splice @letters, 0, 2;
        # my ($row1, $row2) = (%l2c{$first}[0], %l2c{$second}[0]);
        # my ($col1, $col2) = (%l2c{$first}[1], %l2c{$second}[1]);
        if ($l2c{$first}[0] == $l2c{$second}[0]) {           # same row
            $out .= ($c2l[$l2c{$first }[0]][($l2c{$first }[1] + $d)%5]) .
                    ($c2l[$l2c{$second}[0]][($l2c{$second}[1] + $d)%5]);
        } elsif ($l2c{$first}[1] == $l2c{$second}[1]) {        # same column
            $out .= ($c2l[($l2c{$first }[0] + $d) %5][$l2c{$first}[1]]) .
                    ($c2l[($l2c{$second}[0] + $d) %5][$l2c{$second}[1]]);
        } else {                                             # rectangle
            $out .= ($c2l[$l2c{$first }[0]][$l2c{$second}[1]]) .
                    ($c2l[$l2c{$second}[0]][$l2c{$first }[1]]);
        }
    }
    return $out;
}

This program displays the following output:

$ perl  ./mayfair.pl
hide the gold in the tree stump -> bmodzbxdnabekudmuixmmouvif
Round trip: hidethegoldinthetrexestump
siderwrdulfipaarkcrw -> thewexeklychallengex

Wrapping up

The next week Perl Weekly Challenge will 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 May 8, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.