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:

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.

These are some answers to the Week 161 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 April 24, 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: Abecedarian Words

An abecedarian word is a word whose letters are arranged in alphabetical order. For example, “knotty” is an abecedarian word, but “knots” is not. Output or return a list of all abecedarian words in the dictionary, sorted in decreasing order of length.

Optionally, using only abecedarian words, leave a short comment in your code to make your reviewer smile.

Abecedarian Words in Raku

Here, we use some nice features of Raku. The 'dictionary.txt'.IO.lines construct returns all the lines of the input file one by one. Then we grep these lines and keep only those in which the letters are arranged in the lexicographic order using the [] meta-operator with the infix le less than or equal to operator. Since the comparison routine passed to sort (i.e. .chars) takes only one argument, this routine is automatically applied to both sides of the comparisons made for the purpose of sorting.

my @abecedarian =  'dictionary.txt'.IO.lines.grep({[le] .comb});
say (reverse sort {.chars}, @abecedarian)[0..25];

My original implementation was a one-liner, but I decided to break it into two lines for better readability.

This short program displays the following output:

$ raku ./abecedarian.raku
(knotty glossy floppy floors effort choppy choosy chintz chimps chilly chills cellos billow bellow begins almost accost access accept accent abhors mossy moors lorry loops hoops)

Abecedarian Words in Perl

This Perl program does essentially the same thing as the Raku program above, but we have to use two explicit nested loops.

my @abecedarian;
my $dict = "./dictionary.txt";
open my $IN, "<", $dict or die "Cannot open $dict $!";
WORD: while (my $word = <$IN>) {
    chomp $word;
    my $old = 'a';
    for my $char (split //, $word) {
        next WORD if $char lt $old;
        $old = $char;
    }
    push @abecedarian, $word;
}
my @out = sort { length $b <=> length $a } @abecedarian;
say $_ for @out[0..25];

This program displays the following output:

$ perl ./abecedarian.pl
abhors
accent
accept
access
accost
almost
begins
bellow
billow
cellos
chills
chilly
chimps
chintz
choosy
choppy
effort
floors
floppy
glossy
knotty
abbey
abbot
abhor
abort
adept

Task 2: Pangrams

A pangram is a sentence or phrase that uses every letter in the English alphabet at least once. For example, perhaps the most well known pangram is:

the quick brown fox jumps over the lazy dog

Using the provided dictionary, so that you don’t need to include individual copy, generate at least one pangram.

Your pangram does not have to be a syntactically valid English sentence (doing so would require far more work, and a dictionary of nouns, verbs, adjectives, adverbs, and conjunctions). Also note that repeated letters, and even repeated words, are permitted.

BONUS: Constrain or optimize for something interesting (completely up to you), such as:

* Shortest possible pangram (difficult)
* Pangram which contains only abecedarian words (see challenge 1)
* Pangram such that each word "solves" exactly one new letter. For example, such a pangram might begin with (newly solved letters in bold):
    a ah hi hid die ice tea ...
    What is the longest possible pangram generated with this method? (All solutions will contain 26 words, so focus on the letter count.)
* Pangrams that have the weirdest (PG-13) Google image search results
* Anything interesting goes!

Well, as for the bonus, sorry, this coming Sunday is the presidential election here in France. As a city counselor in my home town, I’m heavily involved in the election process from early morning to very late evening, and I will have no time to deal with the bonus.

Pangrams in Raku

We use a $seen SetHash to store the letters that we’ve already met. Then, for each word in the dictionary, we add it to the @pangram array if it has at least one new letter not in $seen. We stop the process when the $seen SetHash has 26 letters (i.e. we’ve seen all letters of the alphabet).

my  $seen = SetHash.new;
my @pangram;
for 'dictionary.txt'.IO.lines -> $word {
    my @new_letters = grep {not $seen{$_}}, $word.comb;
    next if @new_letters == 0;
    $seen ∪= @new_letters;      # set union operator
    push @pangram, $word;
    last if $seen.elems == 26;
}
say @pangram;

This program dispays the following output:

$ raku ./pangram.raku
[a aardvark aback abacus abacuses abandon abandoning abandonment abbey abdominal abhor abject ablaze abrupt acknowledge acquaint adrift affix]

Pangram in Perl

This Perl implementation is a port of the Raku program above. In Perl, we use a regular hash to store the letters already seen.

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

my  (%seen, @pangram);
my $dict = "./dictionary.txt";
open my $IN, "<", $dict or die "Cannot open $dict $!";
while (my $word = <$IN>) {
    chomp $word;
    my @new_letters = grep {not $seen{$_}} split //, $word;
    next if @new_letters == 0;
    $seen{$_} = 1 for @new_letters;
    push @pangram, $word;
    last if scalar keys %seen == 26;
}
say "@pangram";

This program displays the following output:

$ perl ./pangram.pl
a aardvark aback abacus abacuses abandon abandoning abandonment abbey abdominal abhor abject ablaze abrupt acknowledge acquaint adrift affix

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

These are some answers to the Week 160 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 April 17, 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: Four is Magic

You are given a positive number, $n < 10.

Write a script to generate English text sequence starting with the English cardinal representation of the given number, the word ‘is’ and then the English cardinal representation of the count of characters that made up the first word, followed by a comma. Continue until you reach four.

Example 1:

Input: $n = 5
Output: Five is four, four is magic.

Example 2:

Input: $n = 7
Output: Seven is five, five is four, four is magic.

Example 3:

Input: $n = 6
Output: Six is three, three is five, five is four, four is magic.

Four is four letter-long, so we might enter into an endless loop if the specific case for four did not exist: “four is four, four is four, four is four, etc.” This is the only case where the English name for a digit has a number of letters equal to the digit. Note that we are also lucky that, with English names of integers, we don’t get into an endless loop involving two (or more) numbers. If 5 was written “fiv” in English, we would get into this endless loop between 5 and 3: “fiv is three, three is fiv, fiv is three, etc.” So we are rather lucky that this doesn’t happen in English, but there are certainly other languages where this wouldn’t work.

Four is Magic in Raku

That’s fairly straight forward. We define an array @numbers of integers between 0 and 9 spelled in English. We then iterate through the numbers until we reach 4, at which point we break out of the loop with a return statement.

sub is-magic (Int $n is copy) {
    my @numbers = <zero one two three four five six seven eight nine>;
    my $output = "";
    loop {
        my $letter-count = @numbers[$n].chars;
        if $n == 4 {
            return $output ~ "four is magic.";
        } else {
            $output ~= "@numbers[$n] is @numbers[$letter-count], ";
            $n = $letter-count;
        }
    }
}
for 1..9 -> $n {
  say "$n: ", is-magic($n).tc;
}

This program displays the following output:

$ raku ./magic4.raku
1: One is three, three is five, five is four, four is magic.
2: Two is three, three is five, five is four, four is magic.
3: Three is five, five is four, four is magic.
4: Four is magic.
5: Five is four, four is magic.
6: Six is three, three is five, five is four, four is magic.
7: Seven is five, five is four, four is magic.
8: Eight is five, five is four, four is magic.
9: Nine is four, four is magic.

Four is Magic in Perl

This is essentially the same in Perl. We define an array @numbers of integers between 0 and 9 spelled in English. We then iterate through the numbers until we reach 4, at which point we break out of the loop with a return statement.

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

sub is_magic {
    my $n = shift;
    my @numbers = qw<zero one two three four five six seven eight nine>;
    my $output = "";
    while (1) {
        my $letter_count = length $numbers[$n];
        if ($n == 4) {
            return $output . "four is magic.";
        } else {
            $output .= "$numbers[$n] is $numbers[$letter_count], ";
            $n = $letter_count;
        }
    }
}
for my $m (1..9) {
  say "$m: ", ucfirst(is_magic($m));
}

This program displays the following output:

$ perl magic4.pl
1: One is three, three is five, five is four, four is magic.
2: Two is three, three is five, five is four, four is magic.
3: Three is five, five is four, four is magic.
4: Four is magic.
5: Five is four, four is magic.
6: Six is three, three is five, five is four, four is magic.
7: Seven is five, five is four, four is magic.
8: Eight is five, five is four, four is magic.
9: Nine is four, four is magic.

Task 2: Equilibrium Index

You are give an array of integers, @n.

Write a script to find out the Equilibrium Index of the given array, if found.

For an array A consisting n elements, index i is an equilibrium index if the sum of elements of subarray A[0…i-1] is equal to the sum of elements of subarray A[i+1…n-1].

Example 1:

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

Example 2:

Input: @n = (1, 2, 3, 4, 5)
Output: -1 as no Equilibrium Index found.

Example 3:

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

With the small arrays of the examples, we will use a brute force approach: simply testing all possible indices within the range. If the arrays were significantly larger, we might try to predict faster the proper index. The best solution that I can think of may be a binary search approach over the possible indices within the range. For example, with the (1, 2, 3, 4, 5) array, we test the middle item (3), and find that 1 + 2 < 4 + 5. So we try the (1, 2, 3) sub-array and test the middle item (2), and find that 1 < 3. At this point, we can figure that there will be no solution.

Equilibrium Index in Raku

The brute force approach described above is pretty straight forward: we test all possible indices and return the proper index if the sum of the items before it equals the sum of the items after it. If we reach the end of the loop, then there is no solution and we return -1.

sub equilibrium (@ary) {
    for 1..@ary.end-1 -> $i {
        return $i if @ary[0..$i-1].sum == @ary[$i+1..@ary.end].sum;
    }
    return -1;
}
for <1 3 5 7 9>, <1 2 3 4 5>, <2 4 2> -> @a {
    say "@a[]".fmt("%-12s"), " -> ", equilibrium(@a);
}

This script displays the following output:

$ raku ./equilibrium.raku
1 3 5 7 9    -> 3
1 2 3 4 5    -> -1
2 4 2        -> 1

Equilibrium Index in Perl

Again the same brute force approach: we test all possible indices and return the proper index if the sum of the items before it equals the sum of the items after it. If we reach the end of the loop, then there is no solution and we return -1. Note that, in Perl, we had to implement our own sum subroutine since it does not exist as a built-in function. Obviously, I could have used the sum subroutine of various core modules, but, as I have stated many times, I echew using off-the-shelf modules or packages in a coding challenge.

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

sub sum {
    my $sum = 0;
    $sum += $_ for @_;
    return $sum;
}
sub equilibrium {
    my @ary = @_;
    for my $i (1..$#ary-1) {
        return $i if sum (@ary[0..$i-1]) == sum (@ary[$i+1..$#ary]);
    }
    return -1;
}
for my $a ([1, 3, 5, 7, 9], [1, 2, 3, 4, 5], [2, 4, 2]) {
    my $formated = sprintf "%-12s", "@$a";
    say "$formated -> ", equilibrium(@$a);
}

This program displays the following output:

$ perl ./equilibrium.pl
1 3 5 7 9    -> 3
1 2 3 4 5    -> -1
2 4 2        -> 1

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

These are some answers to the Week 159 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 April 10, 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: Farey Sequence

Write a script to compute Farey Sequence of the order $n.

Example 1:

Input: $n = 5
Output: 0/1, 1/5, 1/4, 1/3, 2/5, 1/2, 3/5, 2/3, 3/4, 4/5, 1/1.

Example 2:

Input: $n = 7
Output: 0/1, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 2/5, 3/7, 1/2, 4/7, 3/5, 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 1/1.

Example 3:

Input: $n = 4
Output: 0/1, 1/4, 1/3, 1/2, 2/3, 3/4, 1/1.

The Farey sequence of order n is the sequence of completely reduced fractions, either between 0 and 1, or without this restriction, which when in lowest terms have denominators less than or equal to n, arranged in order of increasing size. See this Wikipredia page for additional information.

With the restricted definition, each Farey sequence starts with the value 0, denoted by the fraction 0/1, and ends with the value 1, denoted by the fraction 1/1.

Farey Sequence in Raku

In Raku, the Rat rational data type stores a rational number as a pair of a numerator and denominator. This makes things quite simple, since the same object can be used both for numeric comparison and for displaying it as a completely reduced fraction (using the numerator and denominator methods). We use two nested for loops to generate all possible fractions, store them in a Set to remove duplicates and sort them.

sub farey (Int $n) {
    my @out;
    for 1..$n -> $den {
        for 0..$den -> $num {
            push @out, $num/$den;
        }
    }
    return @out.Set;
}
for 3..7 -> $test {
    say "$test -> ", map { .numerator ~ "/" ~ .denominator },  sort farey($test).keys;
}

This program displays the following output:

$ raku ./farey.raku
3 -> (0/1 1/3 1/2 2/3 1/1)
4 -> (0/1 1/4 1/3 1/2 2/3 3/4 1/1)
5 -> (0/1 1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5 1/1)
6 -> (0/1 1/6 1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5 5/6 1/1)
7 -> (0/1 1/7 1/6 1/5 1/4 2/7 1/3 2/5 3/7 1/2 4/7 3/5 2/3 5/7 3/4 4/5 5/6 6/7 1/1)

Farey Sequence in Perl

In Perl, we simulate Raku’s Rat data type by using anonymous arrays containing a numerator and a denominator. For sorting or storing in a hash (in order to remove duplicates), we use the numerical value of the fraction, whereas we use a string for output.

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

sub farey {
    my $n = shift;
    my (@out, %seen);
    for my $den (1..$n) {
        for my $num (0..$den) {
            next if exists $seen{$num/$den};
            push @out, [$num, $den];
            $seen{$num/$den} = 1;
        }
    }
    return @out;
}
for my $test (3..7) {
    my @result = sort { $a->[0]/$a->[1] <=> $b->[0]/$b->[1] } farey($test);
    print "$test: ";
    print "$_->[0]/$_->[1] " for @result;
    say "";

}

This program displays the following output.

$ perl ./farey.pl
3: 0/1 1/3 1/2 2/3 1/1
4: 0/1 1/4 1/3 1/2 2/3 3/4 1/1
5: 0/1 1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5 1/1
6: 0/1 1/6 1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5 5/6 1/1
7: 0/1 1/7 1/6 1/5 1/4 2/7 1/3 2/5 3/7 1/2 4/7 3/5 2/3 5/7 3/4 4/5 5/6 6/7 1/1

Task 2: Möbius Number

You are given a positive number $n.

Write a script to generate the Moebius Number for the given number. Please refer to Wikipedia page for more informations.

Example 1:

Input: $n = 5
Output: -1

Example 2:

Input: $n = 10
Output: 1

Example 3:

Input: $n = 20
Output: 0

For any positive integer n, the Möbius Function μ has values in {−1, 0, 1} depending on the factorization of n into prime factors:

• μ(n) = +1 if n is a square-free positive integer with an even number of prime factors.

• μ(n) = −1 if n is a square-free positive integer with an odd number of prime factors.

• μ(n) = 0 if n has a squared prime factor.

Moebius Number in Raku

The Möbius subroutine performs the factorization of its input integer. If any of the exponents is larger than 1, then the input number is not square-free and the subroutine returns 0. Otherwise, the subroutine returns 1 if the number of prime factors is even and -1 if it is odd.

sub möbius ($n is copy) {
    my %factors;
    for 2..$n -> $i {
        while  $n %% $i {
            %factors{$i}++;
            $n /= $i;
        }
    }
    return 0 if %factors.values.any > 1;
    return 1 if (%factors.keys.elems %% 2);
    return -1;
}
say "$_: ", möbius $_ for 1..20;

This program displays the following output:

$ raku ./moebius.raku
1: 1
2: -1
3: -1
4: 0
5: -1
6: 1
7: -1
8: 0
9: 0
10: 1
11: -1
12: 0
13: -1
14: 1
15: 1
16: 0
17: -1
18: 0
19: -1
20: 0

Moebius Number in Perl

This is a port to Perl of the Raku program above: the Moebius subroutine performs the factorization of its input integer. If any of the exponents is larger than 1, then the input number is not square-free and the subroutine returns 0. Otherwise, the subroutine returns 1 if the number of prime factors is even and -1 if it is odd.

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

sub moebius {
    my $n = shift;
    my %factors;
    for my $i (2..$n) {
        while  ($n % $i == 0) {
            $factors{$i}++;
            $n /= $i;
        }
    }
    return 0 if grep $_ > 1, values %factors;
    return 1 unless (scalar keys %factors) % 2;
    return -1;
}
say "$_: ", moebius $_ for 1..20;

This program displays the following output:

$ perl ./moebius.pl
1: 1
2: -1
3: -1
4: 0
5: -1
6: 1
7: -1
8: 0
9: 0
10: 1
11: -1
12: 0
13: -1
14: 1
15: 1
16: 0
17: -1
18: 0
19: -1
20: 0

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