laurent_r

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.