May 2022 Archives

Perl Weekly Challenge 167: Circular Primes

These are some answers to the Week 167 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 June 5, 2022 at 23:59). 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: Circular Primes

Write a script to find out first 10 circular primes having at least 3 digits (base 10).

Please checkout wikipedia for more information.

A circular prime is a prime number with the property that the number generated at each intermediate step when cyclically permuting its (base 10) digits will also be prime.

Output:

113, 197, 199, 337, 1193, 3779, 11939, 19937, 193939, 199933

Given the task specification, I think that the suggested output is wrong. But I’ll come back to that later on.

Circular Primes in Raku

Raku has the built-in is-prime routine, which uses the fast Miller-Rabin test and makes the task quite easy. Fast as the is-prime routine may be, there is no reason loosing time running it on even numbers. So we start with a sequence generating odd numbers above 100. The rotate-and-test subroutine checks if rotations of the input number generate only prime numbers.

my $max = 10;
my $count = 0;
for 101, 103  ...*  -> $n {
    next unless $n.is-prime;
    next unless rotate-and-test $n;
    print "$n ";
    $count++;
    last if $count >= $max;
}

sub rotate-and-test ($i is copy) {
    my $nb = $i.chars - 1;
    for 0..^$nb {
        $i = substr($i, 1) ~ substr($i, 0, 1);
        return False unless $i.is-prime;
    }
    return True;
}

This program displays the following output:

$ raku ./circ-primes.raku
113 131 197 199 311 337 373 719 733 919

Note that my output here above is not the same as the example output provided with the task specification. But, clearly, 131 is a circular prime, since 113 is one (and 311 is also one). It appears that, in the output provided with the task specification, 131 and 311 are removed from the suggested solution because one item (113) of that cycle has already been displayed. But there is nothing in the task specification that tells us that it should be so. So, being a little bit stubborn, I won’t change my result. It would be easy to do so, though, as I will show in my Perl solution to the task below.

Circular Primes in Perl

Perl Circular Primes According to the Specification

Perl doesn’t have a built-in is_prime function, so we will implement our own subroutine. For this, we will test even division by prime numbers up to the square root of 919. Since we know from our Raku implementation that the largest number we need to test is 919, so that we need a list of primes up to 31. We will simply hard-code that list. The rest of the solution is essentially a port to Perl of the Raku program above.

use warnings;
use feature "say";
use constant MAX => 10;

my @primes = (2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31); #Init small primes

sub is_prime {
   my $n = shift;
   for my $p (@primes) {
       return 1 if $p >= $n;
       return 0 if $n % $p == 0;
   }
   return 1;
}

sub rotate_and_test {
    my $i = shift;
    my $nb = length $i - 1;
    for (1..$nb) {
        $i = substr($i, 1) . substr($i, 0, 1);
        return 0 unless is_prime $i;
        $seen{$i} = 1;
    }
    return 1;
}

my $max = 10;
my $count = 0;
my $n = 99;
while (1) {
    $n += 2;
    next unless is_prime $n;
    next if $seen{$n};
    next unless rotate_and_test $n;
    print "$n ";
    $count++;
    last if $count >= MAX;
}

This script displays the following output:

$ perl ./circ-primes.pl
113 131 197 199 311 337 373 719 733 919

Perl Circular Primes to Match the Suggested Solution

As noted before, my solution above is not the same as the solution suggested in the specification.

The reason for this difference is that the suggested solution is probably taken from the cited Wikipedia article, which does not provide a list of circular primes, but “the complete listing of the smallest representative prime from all known cycles of circular primes.”

In other words, this list removes 131 and 311 from the output, since 113 has already been displayed. It is not difficult to remove such numbers from the output, since we have already tried them. So, all we need to do is to store all tested numbers in a hash.

However, we will test primality of numbers much larger than before (up to about 1,000,000), so that we now need a list of primes up to about 1,000. We can no longer hard-code such a list of primes. So, we will use a smaller list of hard-coded primes, and add a loop to find all primes below 1,000.

use strict;
use warnings;
use feature "say";
use constant MAX => 10;

my %seen;
my @primes = (2, 3, 5, 7, 11); # Init small primes
my $i = $primes[-1];
LOOP: while (1) {    # get primes until 1000
    $i += 2;
    last if $i > 1000;
    my $sqrt = sqrt $i;
    for my $p (@primes) {
        last if $p >= $sqrt;
        next LOOP if $i % $p == 0;
    }
    push @primes, $i;
}

sub is_prime {
   my $n = shift;
   for my $p (@primes) {
       return 1 if $p >= $n;
       return 0 if $n % $p == 0;
   }
   return 1;
}

sub rotate_and_test {
    my $i = shift;
    my $nb = length $i - 1;
    for (1..$nb) {
        $i = substr($i, 1) . substr($i, 0, 1);
        return 0 unless is_prime $i;
        $seen{$i} = 1;
    }
    return 1;
}

my $max = 10;
my $count = 0;
my $n = 99;
while (1) {
    $n += 2;
    next unless is_prime $n;
    next if $seen{$n};
    next unless rotate_and_test $n;
    print "$n ";
    $count++;
    last if $count >= MAX;
}

This script displays the following output:

$ perl  circ-primes.pl
113 197 199 337 1193 3779 11939 19937 193939 199933

We now have the same output as in the task specification, but, being as I said a little bit stubborn, I maintain that my original implementation was a better solution to the task specification.

Task 2: The Gamma Function

Implement subroutine gamma() using the Lanczos approximation method.

[2022-05-31] Ryan Thompson wrote an interesting blog explaining the subject in details. Highly recommended if you are looking for more information. BLOG.

Example:

print gamma(3); # 1.99
print gamma(5); # 24
print gamma(7); # 719.99

The information above about Ryan Thompson’s blog was not available yesterday when I wrote my Raku implementation below, but it is now when I’m writing this blog post.

The Gamma function is sort of an extension to real and complex numbers (except negative integers and zero) of the factorial function. Similarly to the factorial function, it satisfies the recursive relation:

f(1) = 1,

f(x + 1) = x f(x)

For integer input values, we have the following relation between the gamma function and the exponential function:

gamma(n) = (n - 1)!

which will be quite convenient to verify the results of our tests.

For those interested, this is what the Gamma function looks like:

Gamma function.png

But the task is not so much about the gamma function, but more about the Lanczos approximation. I frankly couldn’t say anything about the Lanczos approximation that would not be plagiarized from the cited Wikipedia article (or possibly Ryan’s blog). So, the reader is kindly invited to check these sources.

The gamma Function in Raku

I don’t really understand the details in the Wikipedia article about the Lanczos approximation. So I decided to simply port to Raku the Python implementation provided in this article. This leads to the following Raku program:

use v6;

my @p = <676.5203681218851  -1259.1392167224028
    771.32342877765313      -176.61502916214059
    12.507343278686905      -0.13857109526572012
    9.9843695780195716e-6   1.5056327351493116e-7>;

my constant EPSILON = 1e-07;

sub drop-imaginary(Complex $z) {
    return $z.im.abs < EPSILON ?? $z.re !! $z;
}

sub gamma($z is copy) {
    my $y;
    if $z.re < 0.5 {
        $y = pi / (sin(pi * $z) * gamma(1 - $z));   # reflection formula
    } else {
        $z -= 1;
        my $x = 0.99999999999980993;
        for @p.kv -> $i, $pval {
            $x += $pval / ($z + $i +1);
        }
        my $t = $z + @p.elems - 0.5;
        $y = sqrt(2 * pi) * $t ** ($z + 0.5) * (-$t).exp * $x;
    }
    return drop-imaginary $y;
}

for 1, 3, 5, 6.2, 7, 0.4 -> $i {
    printf "$i -> %.5f\n", gamma $i.Complex;
}

This program displays the following output:

$ ./raku  gamma.raku
1 -> 1.00000
3 -> 2.00000
5 -> 24.00000
6.2 -> 169.40610
7 -> 720.00000
0.4 -> 2.21816

As it can be seen, the relation:

gamma(n) = (n - 1)!

is satisfied for integer input values. For example, we have:

gamma(7) = 720 = 6!

It should be quite easy to port the same Python program to Perl, but I really won’t have time this week. I’m already quite happy that I was able to do it in Raku despite time constraints.

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

Perl Weekly Challenge 166: Hexadecimal Words and K-Directory Diff

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

Task 1: Hexadecimal Words

As an old systems programmer, whenever I needed to come up with a 32-bit number, I would reach for the tired old examples like 0xDeadBeef and 0xC0dedBad. I want more!

Write a program that will read from a dictionary and find 2- to 8-letter words that can be “spelled” in hexadecimal, with the addition of the following letter substitutions:

  • o ⟶ 0 (e.g., 0xf00d = “food”)
  • l ⟶ 1
  • i ⟶ 1
  • s ⟶ 5
  • t ⟶ 7

You can use your own dictionary or you can simply open ../../../data/dictionary.txt (relative to your script’s location in our GitHub repository) to access the dictionary of common words from Week #161.

Optional Extras (for an 0xAddedFee, of course! * Limit the number of “special” letter substitutions in any one result to keep that result at least somewhat comprehensible. (0x51105010 is an actual example from my sample solution you may wish to avoid!)*

  • Find phrases of words that total 8 characters in length (e.g., 0xFee1Face), rather than just individual words.*

I will not try to fulfill the second optional extra, as I do not really understand what “phrases of words” is supposed to mean. If the idea is to find a list of 8-character words, it is really too easy; if the idea is to manufacture meaningful (and/or grammatically correct) phrases, then it is en entirely different venture.

Hexadecimal Words in Raku

Initial Requirement

The initial task is quite easy: we just skip any word less than 2 characters or more than eitght character, and any word with letters not in the a..f range and not in the olist list of characters. We then use the TR/// non-destructive transliteration operator, which returns the modified string.

for "words.txt".IO.lines -> $line {
    next unless 2 <= $line.chars <= 8;
    next if $line ~~ /<-[a..f olist]>/;
    say "$_ -> 0x", TR/olist/01157/ with $line;
}

This script displays the following output:

$ raku ./hexawords.raku aa -> 0xaa aal -> 0xaa1 aalii -> 0xaa111 aaliis -> 0xaa1115 aals -> 0xaa15 aas -> 0xaa5 aba -> 0xaba abaca -> 0xabaca abacas -> 0xabaca5 abaci -> 0xabac1 abaft -> 0xabaf7 … (Lines omitted for brevity) decibels -> 0xdec1be15 decide -> 0xdec1de decided -> 0xdec1ded decides -> 0xdec1de5 decile -> 0xdec11e … (Lines omitted for brevity) tsade -> 0x75ade tsades -> 0x75ade5 tsadi -> 0x75ad1 tsadis -> 0x75ad15 tsetse -> 0x75e75e tsetses -> 0x75e75e5

Optional extra: Limiting the Number of substitutions

This time, we use the tr/// in-place transliteration operator, which conveniently returns the edit distance between the original value and the resultant string (i.e., in this case, the number of substitutions performed). The maximum number of “special” letter substitutions is passed as an argument to the script (with a default value of 4):

sub MAIN (Int $limit = 4) {
    for "words.txt".IO.lines -> $line {
        next unless 2 <= $line.chars <= 8;
        next if $line ~~ /<-[a..f olist]>/;
        my $word = $line;
        my $dist =  +tr/olist/01157/ for $word;
        say "$line -> 0x", $word if $dist <= $limit
    }
}

This script displays the following output:

$ raku ./hexawords.raku 3
aa -> 0xaa
aal -> 0xaa1
aalii -> 0xaa111
aals -> 0xaa15
aas -> 0xaa5
aba -> 0xaba
...
toted -> 0x707ed
tsade -> 0x75ade
tsades -> 0x75ade5
tsadi -> 0x75ad1

$ ./raku hexawords.raku 2 | wc
   1291    3873   23250

$ ./raku hexawords.raku 5 | wc
   3490   10470   68618

Hexadecimal Words in Perl

Initial Requirement

Using the tr//r option, the operator returns the modified string.

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

my $file_in = "./words.txt";
open my $IN, "<", $file_in or die "unable to open $file_in";
while (my $line = <$IN>) {
    chomp $line;
    next if length $line < 2 or length $line > 8;
    next if $line =~ /[^a-folist]/;
    say "$_ -> 0x", tr/olist/01157/r for $line;
}

This script displays the following output:

$ perl ./hexawords.pl
aa -> 0xaa
aal -> 0xaa1
aalii -> 0xaa111
aaliis -> 0xaa1115
aals -> 0xaa15
aas -> 0xaa5
aba -> 0xaba
abaca -> 0xabaca
abacas -> 0xabaca5
abaci -> 0xabac1
abaft -> 0xabaf7
abas -> 0xaba5
abase -> 0xaba5e
abased -> 0xaba5ed
abases -> 0xaba5e5
abatable -> 0xaba7ab1e
abate -> 0xaba7e
... (Lines omitted for brevity)
totted -> 0x7077ed
tsade -> 0x75ade
tsades -> 0x75ade5
tsadi -> 0x75ad1
tsadis -> 0x75ad15
tsetse -> 0x75e75e
tsetses -> 0x75e75e5

Optional extra: Limiting the Number of substitutions

Here, we don’t use the tr//r option, because we want the operator to return the number of substitutions performed.

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

my $max = shift;
$max = 4 unless defined $max;
my $file_in = "./words.txt";
open my $IN, "<", $file_in or die "unable to open $file_in";
while (my $line = <$IN>) {
    chomp $line;
    next if length $line < 2 or length $line > 8;
    next if $line =~ /[^a-folist]/;
    my $word = $line;
    next if ($word =~ tr/olist/01157/) > $max;
    say $line, " -> 0x", $word;
}

This script displays the following output with a parameter of 2:

$ perl hexawords.pl 2
aa -> 0xaa
aal -> 0xaa1
aals -> 0xaa15
aas -> 0xaa5
aba -> 0xaba
abaca -> 0xabaca
abacas -> 0xabaca5
abaci -> 0xabac1
abaft -> 0xabaf7
...
to -> 0x70
toad -> 0x70ad
tod -> 0x70d
toe -> 0x70e
toed -> 0x70ed
toff -> 0x70ff
toffee -> 0x70ffee
tsade -> 0x75ade

Task 2: K-Directory Diff

Given a few (three or more) directories (non-recursively), display a side-by-side difference of files that are missing from at least one of the directories. Do not display files that exist in every directory.

Since the task is non-recursive, if you encounter a subdirectory, append a /, but otherwise treat it the same as a regular file.

Example:

Given the following directory structure:

dir_a:
Arial.ttf  Comic_Sans.ttf  Georgia.ttf  Helvetica.ttf  Impact.otf  Verdana.ttf  Old_Fonts/

dir_b:
Arial.ttf  Comic_Sans.ttf  Courier_New.ttf  Helvetica.ttf  Impact.otf  Tahoma.ttf  Verdana.ttf

dir_c:
Arial.ttf  Courier_New.ttf  Helvetica.ttf  Impact.otf  Monaco.ttf  Verdana.ttf

The output should look similar to the following:

dir_a          | dir_b           | dir_c
-------------- | --------------- | ---------------
Comic_Sans.ttf | Comic_Sans.ttf  |
               | Courier_New.ttf | Courier_New.ttf
Georgia.ttf    |                 |
               |                 | Monaco.ttf
Old_Fonts/     |                 |
               | Tahoma.ttf      |

I am very late on this and have very little time left, so I’ll do the work of finding the missing files, but will not try obtain the same display.

K-Directory Diff in Raku

Raku as a Set type with operators such as the intersection operator and the does not belong to operator, which make the solution fairly easy:

my @dirs = map {$_ ~~ /\w+$/}, dir("./rootdir");
my %dircontent;
for @dirs -> $dir {
    %dircontent{$dir} = map {~($_ ~~ /\w+$/)}, dir("./rootdir/$dir");
}
say "Content of the dirs: ", %dircontent;
my $intersection = [∩] values %dircontent;
say "Files common to all directories: ", $intersection.keys;
for @dirs -> $dir {
    say "$dir -> ", grep {$_ ∉ $intersection}, values %dircontent{$dir};
}

This script displays the following output

$ raku ./dir_diff.raku
Content of the dirs: {a => (bar bar_a foo foo_a), b => (bar bar_b foo foo_b), c => (bar bar_c foo foo_c)}
Files common to all directories: (foo bar)
a -> (bar_a foo_a)
b -> (bar_b foo_b)
c -> (bar_c foo_c)

K-Directory Diff in Perl

Perl doesn’t have Sets and associated operators, so we will use a hash to record the number of occurrences of various file names. If a file name has a value equal to the number of directories (3 in the example), then this file is present in all directories and should be dismissed from the output.

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

my @dirs = glob("./rootdir/*");
my $nb_dirs = scalar @dirs;
my %dircontent;
for my $dir (@dirs) {
    $dircontent{$dir} = [ map {/(\w+$)/} glob "$dir/*" ];
}
say "Contents of the directories: ";
for my $dir (@dirs) {
    say "$dir: ", join " ", @{$dircontent{$dir}}
}

my %files;
for my $dir (@dirs) {
    $files{$_}++ for @{$dircontent{$dir}}
}
say "\nCommon files: ", join " ", grep { $files{$_} == $nb_dirs } keys %files; 
say "\nFiles not common to all directories: ";
for my $dir (@dirs) {
    say "$dir: ", join " ", grep { $files{$_} < $nb_dirs } @{$dircontent{$dir}};
}

This script displays the following output:

$ perl ./dir_diff.pl
Contents of the directories:
./rootdir/a: bar bar_a foo foo_a
./rootdir/b: bar bar_b foo foo_b
./rootdir/c: bar bar_c foo foo_c

Common files: bar foo

Files not common to all directories:
./rootdir/a: bar_a foo_a
./rootdir/b: bar_b foo_b
./rootdir/c: bar_c foo_c

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

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.

About laurent_r

user-pic I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.