This is my response to the Perl Weekly Challenge #162.
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.
«Generate» is a wonderfully ambiguous word (as is «compute», by the way). Let us be creative (or stupid):
File: isbn13-stupid
#! /usr/bin/env raku
subset ISBN where
/^ <[0..9]>**3 "-" <[0..9]> "-" <[0..9]>**3 "-" <[0..9]>**5 "-" <[0..9]> $ /; # [1]
unit sub MAIN (ISBN $isbn13); # [2]
say $isbn13.substr(16); # [3]
[1] A custom type (set up with subset, and used in [2]) to
verify the ISBN-13 number; three digits (specified with the **3 quantifier), a
dash (a literal dash, as it is in quotes), one digit, a dash, three digits, a dash, 5 digits,
a dash, and the final digit (the check digit).
Note the use of <[0..9]>
to match any of the 10 digits (from 0 to 9), and not \d - which would match a
lot of Unicode characters classified with a
Numeric
type.
[2] Off we go.
[3] Print the last digit.
Running it:
$ ./isbn13-stupid
Usage:
./isbn13-stupid <isbn13>
$ ./isbn13-stupid 978-0-306-40615-7
7
That is ok.
But these are also «valid»:
$ ./isbn13-stupid 978-0-306-40615-6
6
$ ./isbn13-stupid 978-0-306-40615-5
5
Garbage in, garbage out...
Let us do it the right way:
File: isbn13
#! /usr/bin/env raku
subset ISBN where
/^ <[0..9]>**3 "-" <[0..9]> "-" <[0..9]>**3 "-" <[0..9]>**5 "-" <[0..9]> $/;
unit sub MAIN (ISBN $isbn13, :v(:$verbose));
my $digits = S:g/\-// given $isbn13; # [1]
my @digits = $digits.comb; # [2]
my $check = @digits.pop; # [2a]
my @odd = @digits[0, 2 ... *]; # [3]
my @even = @digits[1, 3 ... *]; # [3a]
my $sum = @odd.sum * 3 + @even.sum; # [4]
my $r = (10 - $sum) % 10; # [4a]
say ": Source: $isbn13\n: Digits: $digits\n: Base: { @digits.join }"
if $verbose;
say ($r == $check) # [5]
?? "The Check Digit is correct"
!! "The Check Digit is wrong (should have been $r)";
[1]
Get rid of the hyphens, with the non-destructive substitution operator
S///, applied on the read-only isbn-variable with given. The
modified result is returned.
See
docs.raku.org/language/operators#S///_non-destructive_substitution for more
information about S///.
See
docs.raku.org/syntax/given
for more information about given.
[2] The individual digits, and get rid of the checksum digit [2a].
[3] Using an array slice to get every other digit. Note that «odd» refers to the 1-based indices in the wikipedia article, and not the zero-based indices used here.
[4] Get the sum, with the odd (index-wise) digits multiplied with 3. Apply the modulo logic to get the checksum digit [4a].
[5] Do we have the correct checksum digit?
Running it:
$ ./isbn13 -v 978-0-306-40615-7
: Source: 978-0-306-40615-7
: Digits: 9780306406157
: Base: 978030640615
The Check Digit is correct
$ ./isbn13 -v 978-0-306-40615-6
: Source: 978-0-306-40615-6
: Digits: 9780306406156
: Base: 978030640615
The Check Digit is wrong (should have been 7)
$ ./isbn13 -v 978-0-306-40615-5
: Source: 978-0-306-40615-5
: Digits: 9780306406155
: Base: 978030640615
The Check Digit is wrong (should have been 7)
Looking good.
It is possible to write it slighlty more compact:
File: isbn13-shorter
#! /usr/bin/env raku
subset ISBN where
/^ <[0..9]>**3 "-" <[0..9]> "-" <[0..9]>**3 "-" <[0..9]>**5 "-" <[0..9]> $/;
unit sub MAIN (ISBN $isbn13, :v(:$verbose));
my $digits = S:g/\-// given $isbn13;
my @digits = $digits.comb;
my $check = @digits.pop;
my $r = (10 - ( @digits[0, 2 ... *].sum * 2 + @digits.sum)) % 10; # [1]
say ": Source: $isbn13\n: Digits: $digits\n: Base: { @digits.join }"
if $verbose;
say ($r == $check)
?? "The Check Digit is correct"
!! "The Check Digit is wrong (should have been $r)";
[1] this time take the sum of the whole array, and add the odd ones an additional two times.
Running it gives the expected result:
$ ./isbn13-shorter 978-0-306-40615-7
The Check Digit is correct
$ ./isbn13-shorter 978-0-306-40615-6
The Check Digit is wrong (should have been 7)
Implement encryption and decryption using the Wheatstone-Playfair cipher.
Example2:
(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"
#! /usr/bin/env raku
unit sub MAIN (Str :k(:$key), Str :s(:$string), :d(:$decode),
:v(:$verbose)); # [1]
my %todo = ('A' .. 'I', 'K' .. 'Z').Set; # [2]
my @key; # [3]
my $padding = 'X'; # [4]
my $one = $decode ?? -1 !! 1; # [5]
for $key.uc.comb -> $char # [6]
{
next if $char eq " "; # [7]
next unless %todo{$char}; # [8]
%todo{$char} :delete; # [9]
@key.push: $char; # [10]
}
for sort keys %todo -> $todo # [11]
{
@key.push: $todo; # [11a]
}
if $verbose
{
say ": Key: @key[ 0 .. 4]";
say ": Key: @key[ 5 .. 9]";
say ": Key: @key[10 .. 14]";
say ": Key: @key[15 .. 19]";
say ": Key: @key[20 .. 24]";
}
[1] Named argments for the key and string. Also note the flag for decode, as the encryption does not round trip (as opposed to e.g. Rotate 13). We will get back to this in [5] - and later.
[2] The letters to use in the key matrix. As a Set, so that we can avoid
the tiresome values of an ordinary hash. Note that the result will be coerced to a
hash, because of the % on the variable we assign the Set to.
[3] The key matrix (as a one dimentional array).
[4] The padding character. This could be turned into a command line option.
[5] The round trip problem. Encode adds 1 to an index, so decode has to subtract 1.
[6] Iterate over the characters in the key string, after converting
the string to uppercase letters (with uc).
See
docs.raku.org/routine/uc
for more information about uc.
[7] Skip spaces. (Not really needed, as they would be catched in [8], but it makes it abundantly clear that we do ignore spaces.)
[8] Skip characters that we have not done already. Note that this will also skip
illegal characters (i.e. anything not in %todo initially), without
complaining.
[9] Remove the character from the list of unused characters.
[10] Add it to the key array.
[10] Add the remaining letters (i.e. not encountered in the key string) to the key array. Alphabetically.
Running it, with verbose mode to show what is going on (so far):
$ ./wheatstone-playfair -k="playfair example" -s="hide the gold in the tree stump" -v
: Key: P L A Y F
: Key: I R E X M
: Key: B C D G H
: Key: K N O Q S
: Key: T U V W Z
…
Note that I have chosen to represent the key matrix (a two-dimentional array) as a simple (one-dimentional) array.
File: wheatstone-playfair (partial)
my %index-trans = # [12]
(
0 => "0.0", 1 => "0.1", 2 => "0.2", 3 => "0.3", 4 => "0.4",
5 => "1.0", 6 => "1.1", 7 => "1.2", 8 => "1.3", 9 => "1.4",
10 => "2.0", 11 => "2.1", 12 => "2.2", 13 => "2.3", 14 => "2.4",
15 => "3.0", 16 => "3.1", 17 => "3.2", 18 => "3.3", 19 => "3.4",
20 => "4.0", 21 => "4.1", 22 => "4.2", 23 => "4.3", 24 => "4.4",
);
my %rev; # [13]
for sort keys %index-trans -> $key # [13a]
{
%rev{%index-trans{$key}} = $key; # [13b]
}
my @x = $string.uc.words>>.comb.flat.map: { $_ eq "J" ?? "I" !! $_ }; # [14]
say ": String: { @x.join }" if $verbose;
[12] This is the result of the one-dimentional array; a mapping between one-dimentional indices and the two-dimentional ones (on the form row,column). I could (should) have used an array here, as indicated by the indices.
[13] We need the reverse mapping as well. This loop sets it up for us.
[14] Coerce the string to uppercase, turn it into words (with comb) to get
rid of spaces), each word into individual characters (with >>.comb) and
the list of lists to a single list (with flat). Finally we use map
to convert the letter J to I, if present.
Running it again:
$ ./wheatstone-playfair -k="playfair example" -s="hide the gold in the tree stump" -v
: Key: P L A Y F
: Key: I R E X M
: Key: B C D G H
: Key: K N O Q S
: Key: T U V W Z
: String: HIDETHEGOLDINTHETREESTUMP
…
Ok so far.
File: wheatstone-playfair (partial)
my @pairs; # [14]
my $first = @x.shift; # [15]
while (@x) # [16]
{
if @x[0] eq $first # [17]
{
@pairs.push: $first ~ $padding; # [17a]
}
else
{
@pairs.push: $first ~ @x.shift; # [18]
}
$first = @x.elems ?? @x.shift !! Any; # [19]
}
@pairs.push: $first ~ $padding if $first; # [20]
say ": Pairs: { @pairs.join(" ") }" if $verbose;
[14] The translated pairs of characters will end up here.
[15] Get the first character.
[16] As long as there are more characters to do,
[17] A duplicate character? Add the padding character and add the pair.
[18] If not, add the next character and add the pair.
[19] Set up the first character, if there are any more left.
[20] No more characters, but we may have a leftover. If so add the pair with padding.
Running it, yet again:
$ ./wheatstone-playfair -k="playfair example" -s="hide the gold in the tree stump" -v
: Key: P L A Y F
: Key: I R E X M
: Key: B C D G H
: Key: K N O Q S
: Key: T U V W Z
: String: HIDETHEGOLDINTHETREESTUMP
: Pairs: HI DE TH EG OL DI NT HE TR EX ES TU MP
The pairs look ok.
File: wheatstone-playfair (the final part)
my @result; # [21]
for @pairs -> $pair # [22]
{
@result:push: wheatstone-playfair($pair); # [22a]
}
say @result>>.lc.join; # [23]
sub get-index ($letter) # [24]
{
for ^@key.chars -> $index # [25]
{
return %index-trans{$index} if @key[$index] eq $letter; # [25a]
}
die "Not found"; # [26]
}
sub wheatstone-playfair ($pair) # [27]
{
my ($a, $b) = $pair.comb; # [28]
my ($a-row, $a-col) = get-index($a).split("."); # [29]
my ($b-row, $b-col) = get-index($b).split("."); # [29]
my $trans = ""; # [30]
my $rule = "";
if $a-row != $b-row && $a-col != $b-col # [31]
{
$trans = @key[%rev{$a-row ~ "." ~ $b-col}] ~
@key[%rev{$b-row ~ "." ~ $a-col}];
$rule = 'rect';
}
elsif $a-row == $b-row # [32]
{
$trans = @key[%rev{$a-row ~ "." ~ ( ($a-col + $one) % 5 ) }] ~
@key[%rev{$b-row ~ "." ~ ( ($b-col + $one) % 5 ) }];
$rule = 'row';
}
elsif $a-col == $b-col # [33]
{
$trans = @key[%rev{ ( ($a-row + $one) % 5) ~ "." ~ $a-col }] ~
@key[%rev{ ( ($b-row + $one) % 5) ~ "." ~ $b-col }];
$rule = 'col';
}
say ": $pair -> $a-row $a-col + $b-row $b-col -> $trans [$rule]"
if $verbose;
return $trans; # [34]
}
[21] The result (pair of two letters) will end up here.
[22] Iterate over the pairs from the input string, and convert them.
[23] Coerce the result to lowercase, and print them as a single string.
[24] This procedure will get the index of a given letter.
[25] Iterate over the indices, look for the letter, and return the index if found [25a].
[26] Die if we got an illegal letter.
[27] This procedure will translate the pair to a new pair, using the Wheatstone Playfair algorithm.
[28] The individual letters.
[29] Get the index (row and column) of both.
[30] The translated characters will end up here.
[31] A rectangle.
[32] On the same row. Note the negative sign on $one, when we decode.
[33] On the same column.
[34] Return the translated characters.
Running it:
$ ./wheatstone-playfair -k="playfair example" -s="hide the gold in the tree stump" -v
: Key: P L A Y F
: Key: I R E X M
: Key: B C D G H
: Key: K N O Q S
: Key: T U V W Z
: String: HIDETHEGOLDINTHETREESTUMP
: Pairs: HI DE TH EG OL DI NT HE TR EX ES TU MP
: HI -> 2 4 + 1 0 -> BM [rect]
: DE -> 2 2 + 1 2 -> OD [col]
: TH -> 4 0 + 2 4 -> ZB [rect]
: EG -> 1 2 + 2 3 -> XD [rect]
: OL -> 3 2 + 0 1 -> NA [rect]
: DI -> 2 2 + 1 0 -> BE [rect]
: NT -> 3 1 + 4 0 -> KU [rect]
: HE -> 2 4 + 1 2 -> DM [rect]
: TR -> 4 0 + 1 1 -> UI [rect]
: EX -> 1 2 + 1 3 -> XM [row]
: ES -> 1 2 + 3 4 -> MO [rect]
: TU -> 4 0 + 4 1 -> UV [row]
: MP -> 1 4 + 0 0 -> IF [rect]
bmodzbxdnabekudmuixmmouvif
$ ./wheatstone-playfair -k="perl and raku" -v -s="siderwrdulfipaarkcrw" -d
: Key: P E R L A
: Key: N D K U B
: Key: C F G H I
: Key: M O Q S T
: Key: V W X Y Z
: String: SIDERWRDULFIPAARKCRW
: Pairs: SI DE RW RD UL FI PA AR KC RW
: SI -> 3 3 + 2 4 -> TH [rect]
: DE -> 1 1 + 0 1 -> EW [col]
: RW -> 0 2 + 4 1 -> EX [rect]
: RD -> 0 2 + 1 1 -> EK [rect]
: UL -> 1 3 + 0 3 -> LY [col]
: FI -> 2 1 + 2 4 -> CH [row]
: PA -> 0 0 + 0 4 -> AL [row]
: AR -> 0 4 + 0 2 -> LE [row]
: KC -> 1 2 + 2 0 -> NG [rect]
: RW -> 0 2 + 4 1 -> EX [rect]
thewexeklychallengex
Without verbose mode:
$ ./wheatstone-playfair -k="playfair example" -s="hide the gold in the tree stump"
bmodzbxdnabekudmuixmmouvif
$ ./wheatstone-playfair -k="perl and raku" -s="siderwrdulfipaarkcrw" -d
thewexeklychallengex
The other way:
$ ./wheatstone-playfair -k="perl and raku" -s="the weekly challenge"
siderwrdulfipaarkcrw
$ ./wheatstone-playfair -k="playfair example" -s="bmodzbxdnabekudmuixmmouvif" -d
hidethegoldinthetrexestump
OK.
Or, perhaps not.
We may have a problem with the edges, with negative indices (the -1 rule for decoding, for the row and column rules). Let us check:
$ ./wheatstone-playfair -k="perl and raku" -v -s="the weekly challengeitz"
: Key: P E R L A
: Key: N D K U B
: Key: C F G H I
: Key: M O Q S T
: Key: V W X Y Z
: String: THEWEEKLYCHALLENGEITZ
: Pairs: TH EW EX EK LY CH AL LE NG EI TZ
: TH -> 3 4 + 2 3 -> SI [rect]
: EW -> 0 1 + 4 1 -> DE [col]
: EX -> 0 1 + 4 2 -> RW [rect]
: EK -> 0 1 + 1 2 -> RD [rect]
: LY -> 0 3 + 4 3 -> UL [col]
: CH -> 2 0 + 2 3 -> FI [row]
: AL -> 0 4 + 0 3 -> PA [row]
: LE -> 0 3 + 0 1 -> AR [row]
: NG -> 1 0 + 2 2 -> KC [rect]
: EI -> 0 1 + 2 4 -> AF [rect]
: TZ -> 3 4 + 4 4 -> ZA [col]
siderwrdulfipaarkcafza
$ ./wheatstone-playfair -k="perl and raku" -v -s="the weekly challengeiab" -d
: Key: P E R L A
: Key: N D K U B
: Key: C F G H I
: Key: M O Q S T
: Key: V W X Y Z
: String: THEWEEKLYCHALLENGEIAB
: Pairs: TH EW EX EK LY CH AL LE NG EI AB
: TH -> 3 4 + 2 3 -> SI [rect]
: EW -> 0 1 + 4 1 -> WO [col]
: EX -> 0 1 + 4 2 -> RW [rect]
: EK -> 0 1 + 1 2 -> RD [rect]
: LY -> 0 3 + 4 3 -> YS [col]
: CH -> 2 0 + 2 3 -> IG [row]
: AL -> 0 4 + 0 3 -> LR [row]
: LE -> 0 3 + 0 1 -> RP [row]
: NG -> 1 0 + 2 2 -> KC [rect]
: EI -> 0 1 + 2 4 -> AF [rect]
: AB -> 0 4 + 1 4 -> ZA [col]
siworwrdysiglrrpkcafza
The last one is just to show that we actually get the last row, when we go up from the first one. (Ignore the actually decoded text, as it is rubbish.)
The reason it works is that the modulo operator (%) handles negative
values:
> say -2 %5 # -> 3
> say -1 %5 # -> 4
> say 0 %5 # -> 0
> say 1 %5 # -> 1
> say 2 %5 # -> 2
> say 3 %5 # -> 3
> say 4 %5 # -> 4
> say 5 %5 # -> 0
See
docs.raku.org/routine/% for more information about the modulo operator %.
The other issue is the one-dimentional array, and the use of wrappers (%index-trans,
which really should have been an array, and %rev) to translate between one and two
dimentions. Let us get rid of those wrappers, and use the one-dimentional array the whole time:
#! /usr/bin/env raku
unit sub MAIN (Str :k(:$key), Str :s(:$string), :d(:$decode), :v(:$verbose));
my %todo = ('A' .. 'I', 'K' .. 'Z').Set;
my @key;
my $padding = 'X';
my $one = $decode ?? -1 !! 1;
for $key.uc.comb -> $char
{
next if $char eq " ";
next unless %todo{$char};
%todo{$char} :delete;
@key.push: $char;
}
for sort keys %todo -> $todo
{
@key.push: $todo;
}
if $verbose
{
say ": Key: @key[ $_ * 5 .. $_ * 5 + 4]" for ^5; # [1]
}
my %rev; for ^@key.elems -> $index { %rev{@key[$index]} = $index } # [2]
my @x = $string.uc.words>>.comb.flat.map: { $_ eq "J" ?? "I" !! $_ };
say ": String: { @x.join }" if $verbose;
my @pairs;
my $first = @x.shift;
while (@x)
{
if @x[0] eq $first
{
@pairs.push: $first ~ $padding;
}
else
{
@pairs.push: $first ~ @x.shift;
}
$first = @x.elems ?? @x.shift !! Any;
}
@pairs.push: $first ~ $padding if $first;
say ": Pairs: { @pairs.join(" ") }" if $verbose;
my @result;
for @pairs -> $pair
{
@result.push: wheatstone-playfair($pair);
}
say @result>>.lc.join;
sub wheatstone-playfair ($pair)
{
my ($a, $b) = $pair.comb;
my ($a-row, $a-col) = (%rev{$a} div 5, %rev{$a} % 5); # [3]
my ($b-row, $b-col) = (%rev{$b} div 5, %rev{$b} % 5); # [3]
my $trans = "";
my $rule = "";
if $a-row == $b-row
{
$trans = @key[$a-row * 5 + ( ($a-col + $one) % 5 ) ] ~ # [4]
@key[$b-row * 5 + ( ($b-col + $one) % 5 ) ]; # [4]
$rule = 'row';
}
elsif $a-col == $b-col
{
$trans = @key[( ($a-row + $one) % 5) * 5 + $a-col ] ~ # [4]
@key[( ($b-row + $one) % 5) * 5 + $b-col ]; # [4]
$rule = 'col';
}
else # $a-row != $b-row && $a-col != $b-col # [5]
{
$trans = @key[$a-row * 5 + $b-col] ~ # [4]
@key[$b-row * 5 + $a-col]; # [4]
$rule = 'rect';
}
say ": $pair -> $a-row $a-col + $b-row $b-col -> $trans [$rule]"
if $verbose;
return $trans;
}
[1] Note the loop this time. Shorter code, but harder to read.
[2] The forward mapping is just an array lookup, with the index, this time. We already have the array. This hash does the reverse lookup (from letter to index).
[3] Getting the row (with integer division) and column (modulo) numbers directly.
[4] Getting back to the indices is a little more work, but not that much.
[5] Note the changed order of the tests this time; first if we have the same row, then if we have the same column, and finally the else that catches a rectangle - without having to test for it. If the letters are not on the same row - or column, they are on different rows and columns, and we have a rectangle.
Running it:
$ ./wheatstone-playfair2 -k="playfair example" -s="hide the gold in the tree stump" -v
: Key: P L A Y F
: Key: I R E X M
: Key: B C D G H
: Key: K N O Q S
: Key: T U V W Z
: String: HIDETHEGOLDINTHETREESTUMP
: Pairs: HI DE TH EG OL DI NT HE TR EX ES TU MP
: HI -> 2 4 + 1 0 -> BM [rect]
: DE -> 2 2 + 1 2 -> OD [col]
: TH -> 4 0 + 2 4 -> ZB [rect]
: EG -> 1 2 + 2 3 -> XD [rect]
: OL -> 3 2 + 0 1 -> NA [rect]
: DI -> 2 2 + 1 0 -> BE [rect]
: NT -> 3 1 + 4 0 -> KU [rect]
: HE -> 2 4 + 1 2 -> DM [rect]
: TR -> 4 0 + 1 1 -> UI [rect]
: EX -> 1 2 + 1 3 -> XM [row]
: ES -> 1 2 + 3 4 -> MO [rect]
: TU -> 4 0 + 4 1 -> UV [row]
: MP -> 1 4 + 0 0 -> IF [rect]
bmodzbxdnabekudmuixmmouvif
$ ./wheatstone-playfair2 -k="perl and raku" -v -s="siderwrdulfipaarkcrw" -d
: Key: P E R L A
: Key: N D K U B
: Key: C F G H I
: Key: M O Q S T
: Key: V W X Y Z
: String: SIDERWRDULFIPAARKCRW
: Pairs: SI DE RW RD UL FI PA AR KC RW
: SI -> 3 3 + 2 4 -> TH [rect]
: DE -> 1 1 + 0 1 -> EW [col]
: RW -> 0 2 + 4 1 -> EX [rect]
: RD -> 0 2 + 1 1 -> EK [rect]
: UL -> 1 3 + 0 3 -> LY [col]
: FI -> 2 1 + 2 4 -> CH [row]
: PA -> 0 0 + 0 4 -> AL [row]
: AR -> 0 4 + 0 2 -> LE [row]
: KC -> 1 2 + 2 0 -> NG [rect]
: RW -> 0 2 + 4 1 -> EX [rect]
thewexeklychallengex
And that's it.