diff options
| -rwxr-xr-x | challenge-162/jo-37/perl/ch-1.pl | 72 | ||||
| -rwxr-xr-x | challenge-162/jo-37/perl/ch-2.pl | 129 |
2 files changed, 201 insertions, 0 deletions
diff --git a/challenge-162/jo-37/perl/ch-1.pl b/challenge-162/jo-37/perl/ch-1.pl new file mode 100755 index 0000000000..c89be8ff48 --- /dev/null +++ b/challenge-162/jo-37/perl/ch-1.pl @@ -0,0 +1,72 @@ +#!/usr/bin/perl -s + +use v5.16; +use Test2::V0; +use List::MoreUtils 'reduce_0'; +use experimental 'signatures'; + +our ($tests, $examples); + +run_tests() if $tests || $examples; # does not return + +die <<EOS unless @ARGV; +usage: $0 [-examples] [-tests] [ISBN] + +-examples + run the examples from the challenge + +-tests + run some tests + +ISBN + Check if the given string is a valid ISBN-13 code. + +EOS + + +### Input and Output + +say 0 + check_isbn13(shift); + + +### Implementation + +# An ISBN-13 code already contains the check digit. Returning the +# trailing digit would solve the task: If it was not the correct check +# digit, it would not have been an ISBN-13 code. +# +# Solving a slightly different task instead: Check if a given a string +# looks like a valid ISBN-13 code. +sub check_isbn13 ($isbn) { + $isbn =~ m{ + # 4 nonempty elements plus check digit separated by hyphens + ^\d+-\d+-\d+-\d+-\d\z + (?(?{ + length != 17 || # not 13 digits and 4 separators + # weighted digit sum not a multiple of 10 + (reduce_0 {$a + $b * (($_ % 2) * 2 + 1)} split /-*/) % 10; + }) (*FAIL)) # not an ISBN code + }x; +} + + +### Examples and tests + +sub run_tests { + SKIP: { + skip "examples" unless $examples; + + is check_isbn13('978-0-306-40615-7'), T(), 'example 1' + } + + SKIP: { + skip "tests" unless $tests; + + is check_isbn13('978-0-596-00027-1'), T(), 'my old "camel"'; + is check_isbn13('978-0-596-0000027-1'), F(), 'length'; + is check_isbn13('978-0-596-00027-2'), F(), 'check digit'; + } + + done_testing; + exit; +} diff --git a/challenge-162/jo-37/perl/ch-2.pl b/challenge-162/jo-37/perl/ch-2.pl new file mode 100755 index 0000000000..d2bf667dc5 --- /dev/null +++ b/challenge-162/jo-37/perl/ch-2.pl @@ -0,0 +1,129 @@ +#!/usr/bin/perl -s + +use v5.16; +use Test2::V0; +use Math::Prime::Util 'todigits'; +use experimental qw(signatures postderef); + +our ($tests, $examples, $decrypt); + +run_tests() if $tests || $examples; # does not return + +die <<EOS unless @ARGV == 2; +usage: $0 [-examples] [-tests] [-decrypt] [KEY TEXT] + +-examples + run the examples from the challenge + +-tests + run some tests + +-decrypt + decrypt given text instead of encrypting it. + +KEY + Passphrase to be used as encryption key. + +TEXT + Text to be encrypted or decrypted. + +EOS + + +### Input and Output + +say playfair($ARGV[1], gen_table($ARGV[0]), $decrypt); + + +### Implementation + +# Build the encryption table and a reverse lookup map from the provided +# passphrase. +sub gen_table ($key) { + # Append all letters to the passphrase as required. + my @key = canonify($key . join '', 'a' .. 'z'); + my %backw; + my @forw; + # Process unseen letters until the table is filled. + while (keys %backw < 25) { + my $letter; + do { + $letter = shift @key; + } while exists $backw{$letter}; + my ($row, $col) = todigits scalar keys %backw, 5, 2; + $backw{$letter} = [$row, $col]; + $forw[$row][$col] = $letter; + } + \(@forw, %backw); +} + +sub playfair ($text, $forw, $backw, $decrypt) { + # Encryption and decryption are almost symmetric, they differ in the + # lookup direction for same-row or same-column pairs only. + my $shift = $decrypt ? -1 : 1; + my @text = canonify($text); + # Build letter pairs and apply rule 1. + my @pairs; + while (@text) { + my $x = shift @text; + push @pairs, [$x, (!@text || $x eq $text[0] ? 'x' : shift @text)]; + } + # Encrypt or decrypt the letter pairs (x, y). The coordinates of a + # letter in the encryption table are stored in the reverse lookup + # map. + my $coded; + for my $pair (@pairs) { + # Unconditionally apply rule 4. + my ($rx, $cy, $ry, $cx) = map $backw->{$pair->[$_]}->@*, 0, 1; + # Modify the result in case of rule 2. + ($cy, $cx) = map {($_ + $shift) % 5} $cx, $cy if $rx == $ry; + # Modify the result in case of rule 3. + ($rx, $ry) = map {($_ + $shift) % 5} $rx, $ry if $cx == $cy; + # Collect the encrypted/decrypted letter pair. + $coded .= $forw->[$rx][$cx] . $forw->[$ry][$cy]; + } + $coded; +} + +# Convert the text to lower case, transform j into i, remove all +# non-letters, squash multiple consecutive x's and split the result +# into single letters. +sub canonify ($text) { + split //, lc($text) =~ tr/j/i/r =~ tr/a-z//cdr =~ tr/x//sr; +} + + +### Examples and tests + +sub run_tests { + SKIP: { + skip "examples" unless $examples; + + my ($fw, $bw) = gen_table('playfair example'); + is playfair('hide the gold in the tree stump', $fw, $bw, 0), + 'bmodzbxdnabekudmuixmmouvif', 'example 1'; + + ($fw, $bw) = gen_table('perl and raku'); + is playfair('siderwrdulfipaarkcrw', $fw, $bw, 1), + 'thewexeklychallengex', 'example 2'; + } + + SKIP: { + skip "tests" unless $tests; + + my ($fw, $bw) = gen_table(''); + is playfair('aaa', $fw, $bw, 0), 'cvcvcv', 'repeated letter'; + is playfair('xxa', $fw, $bw, 0), 'vc', 'repeated x'; + + # The behavior for an x-only text is not specified by the rules. + # Here it is trimmed to a single x that gets a second x as its + # pair, thus encoding a double x. Now we have an unexpected + # same-row-same-column situation that results in a shift in both + # row and column and leads to an illegal encryption that cannot + # be decrypted correctly. + is playfair('xx', $fw, $bw, 0), 'dd', 'double x'; + } + + done_testing; + exit; +} |