Merge pull request #3343 from jo-37/contrib

Solutions to challenge 096

2 files changed, 244 insertions, 0 deletions

diff --git a/challenge-096/jo-37/perl/ch-1.pl b/challenge-096/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..4646532d1c
--- /dev/null
+++ b/challenge-096/jo-37/perl/ch-1.pl
@@ -0,0 +1,64 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0;
+
+our ($tests, $examples);
+
+run_tests() if $tests || $examples;    # does not return
+
+say(<<EOS), exit unless @ARGV;
+usage: $0 [-examples] [-tests] [--] [phrase...]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+phrase...
+   phrases to be reversed.  All given phrases will be concatenated.
+
+EOS
+
+
+### Input and Output
+
+say qq{"@{reverse_words(@ARGV)}"};
+
+
+### Implementation
+
+# Return a reference to an array containing the reversed list of words.
+sub reverse_words {
+    local $_ = "@_";
+    # Special split behaviour:
+    # - removes leading whitspace when PATTERN is omitted or ' '
+    # - uses /\s+/ as split pattern when omitted or ' '
+    # - strips trailing empty fields when LIMIT is omitted or zero
+    [reverse split];
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+        is reverse_words('The Weekly Challenge'),
+            [qw(Challenge Weekly The)], 'Example 1';
+        is reverse_words('    Perl and   Raku are  part of the same family  '),
+            [qw(family same the of part are Raku and Perl)], 'Example 2';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+        is reverse_words(' a b'), [qw(b a)], 'strip leading whitespace';
+        is reverse_words('a b '), [qw(b a)], 'strip trailing whitspace';
+        is reverse_words('a  b'), [qw(b a)], 'trim intermediate whitespace';
+        is reverse_words(qw(a b c)), [qw(c b a)], 'multiple args';
+    }
+
+    done_testing;
+    exit;
+}
diff --git a/challenge-096/jo-37/perl/ch-2.pl b/challenge-096/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..cdb9eaa346
--- /dev/null
+++ b/challenge-096/jo-37/perl/ch-2.pl
@@ -0,0 +1,180 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0 '!float';
+use PDL;
+use experimental 'signatures';
+
+our ($tests, $examples, $verbose);
+
+run_tests() if $tests || $examples;    # does not return
+
+say(<<EOS), exit unless @ARGV == 2;
+usage: $0 [-tests] [-examples] [-verbose] [--] [source target]
+
+-tests
+    run some tests
+
+-examples
+    run the examples from the challenge
+ 
+-verbose
+    display edit operations and internal distance matrix
+
+source target
+   calculate levenshtein distance between source and target words
+
+EOS
+
+
+### Input and Output
+
+say levenshtein_distance($ARGV[0], $ARGV[1]);
+
+
+### Implementation
+
+
+sub cost;
+sub min_ind;
+
+# Calculate the Levenshtein distance between two words, i.e. the minimum
+# number of insert, delete or replace actions to transform the first
+# word into the second.  PDL implementation of the Wagner-Fischer
+# algorithm, see https://en.wikipedia.org/wiki/Wagner-Fischer_algorithm
+sub levenshtein_distance ($source, $target) {
+
+    # Split words into arrays and (un)shift by one to match matrix
+    # dimensions.
+    my @source = (undef, split //, $source);
+    my @target = (undef, split //, $target);
+
+    # Prepare distance matrix holding BAD values only.
+    my $dist = zeros(long, @source + 0, @target + 0)->setvaltobad(0);
+
+    # Fill first row and column with ascending sequences as the costs of
+    # removing or inserting a prefix of that length.
+    $dist->slice(',(0)') .= sequence $dist->dim(0);
+    $dist->slice('(0),') .= sequence $dist->dim(1);
+
+    # To fill the remaining fields, loop over the indices of all BAD
+    # values.  With the index order provided by "whichND" the required
+    # "flood filling" is achieved.
+    for my $idx ($dist->isbad->whichND->dog) {
+
+        # Character pair for index position.
+        my $cs = $source[$idx->at(0)];
+        my $ct = $target[$idx->at(1)];
+
+        # 2x2 neighborhood matrix preceeding index.
+        my $nb = $dist->range($idx - 1, 2);
+
+        # 2x2 transition cost matrix.
+        my $trans = cost $cs ne $ct;
+
+        # The cost to reach the new field is the minimum of the sums of
+        # the previous cost and the transition cost.
+        $dist->indexND($idx) .= min $nb + $trans;
+    }
+
+    explain_edit(\@source, \@target, $dist) if $verbose;
+
+    # The requested Levenshtein distance is the bottom right matrix
+    # element.
+    $dist->indexND($dist->shape - 1);
+}
+
+# Backtrack the steps that led to the lower right corner of the distance
+# matrix and describe the corresponding edit operations.
+sub explain_edit ($source, $target, $dist) {
+
+    # Collect edit operations.
+    my @edit;
+
+    # Start at bottom right corner.
+    my $idx = $dist->shape - 1;
+
+    # Stop at upper left corner.
+    while (any $idx) {
+
+        # Character pair for index position.
+        my $cs = $source->[$idx->at(0)];
+        my $ct = $target->[$idx->at(1)];
+
+        # 2x2 neighborhood matrix preceeding index, truncated to BAD
+        # values across the matrix' borders.
+        my $nb = $dist->range($idx - 1, 2, 'truncate');
+
+        # The field preceeding the current field holds the minimum
+        # within the neighborhood.  Find the minimum and the
+        # corresponding index.  On a non-unique minimum, this will
+        # prefer the diagonal "replace" move.
+        my ($min, $pred) = min_ind $nb;
+
+        # Record the edit operation.
+        unshift @edit,
+            any($pred) ?
+                $pred->at(0) ?
+                    "ins($ct)" :
+                    "del($cs)" :
+                $dist->indexND($idx) == $min ?
+                    "keep($cs)" :
+                    "repl($cs,$ct)";
+
+        # Move to predecessor field.
+        $idx = $idx - 1 + $pred;
+    }
+
+    {
+        no warnings 'uninitialized';
+        say @$source, ' -> ', @$target, ':';
+    }
+    say "@edit";
+    say "Levenshtein distance = ", $dist->indexND($dist->shape - 1);
+    say "Wagner-Fischer distance matrix:", $dist;
+}
+
+# Cost matrix for a single insert, delete and keep/replace.
+sub cost ($repl) {
+    long([0, 1], [1, 0])->setvaltobad(0)->set(0, 0, $repl);
+}
+
+# Find the minimum in an N-dim piddle together with the corresponding
+# index.
+sub min_ind ($pdl) {
+	my $min = min $pdl;
+	my $index = whichND($pdl == $min)->slice(',(0)');
+
+    ($min, $index);
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+        is levenshtein_distance('kitten', 'sitting'), 3, 'example 1';
+        is levenshtein_distance('sunday', 'monday'), 2, 'example 2';
+        is levenshtein_distance('Saturday', 'Sunday'), 3,
+            'example from wikipedia';
+        is levenshtein_distance('parachute', 'headache'), 5,
+            'another example';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+        is levenshtein_distance('abcdef', 'uvwxyz'), 6, 'replace all';
+        is levenshtein_distance('def', 'abcdef'), 3, 'insert prefix';
+        is levenshtein_distance('abcdef', 'def'), 3, 'delete prefix';
+        is levenshtein_distance('abcdef', 'uvwdef'), 3, 'replace prefix';
+        is levenshtein_distance('abc', 'abcdef'), 3, 'insert suffix';
+        is levenshtein_distance('abcdef', 'abc'), 3, 'delete suffix';
+        is levenshtein_distance('abcdef', 'abcxyz'), 3, 'replace suffix';
+        is levenshtein_distance('abef', 'abcdef'), 2, 'insert infix';
+        is levenshtein_distance('abcdef', 'abef'), 2, 'delete infix';
+        is levenshtein_distance('abcdef', 'abwxef'), 2, 'replace infix';
+    }
+    done_testing;
+    exit;
+}