Merge pull request #4027 from jo-37/contrib

Solutions to challenge 111

2 files changed, 200 insertions, 0 deletions

diff --git a/challenge-111/jo-37/perl/ch-1.pl b/challenge-111/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..4c29382e43
--- /dev/null
+++ b/challenge-111/jo-37/perl/ch-1.pl
@@ -0,0 +1,152 @@
+#!/usr/bin/perl -s
+#
+use v5.16;
+use PDL;
+use Test2::V0 '!float';
+use Benchmark 'cmpthese';
+use experimental 'signatures';
+
+our ($tests, $examples);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV;
+usage: $0 [-examples] [-tests] [--] [value m...]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests and benchmarks
+
+value
+    value to search for
+
+m...
+    The matrix' elements.  Each row is given as a single argument.  The
+    individual elements are separated by comma and/or blanks, e.g.
+    '1 2 3' '4 5 6' '7 8 9' or 1,2,3 4,5,6 7,8,9
+
+EOS
+
+
+### Input and Output
+
+{
+    my $value = shift;
+    my $matrix = [map {[split /[, ] */]} @ARGV];
+    say bsearch_matrix($matrix, v(0), @$matrix**2, $value);
+}
+
+
+### Implementations
+
+# Perform a binary search within the matrix.  It would be pointless to
+# convert the matrix into a 1-d array as this operation has a complexity
+# of O(n²), whereas a binary search may be performed in O(log n).
+# Therefore List::MoreUtils::bsearch is of no use for this task and we
+# need to implement our own binary search.
+# It needs large matrices for the binary search to become faster than a
+# PDL scan.  While for the given 5x5 matrix there is a tie, the scan
+# is faster until the size goes up to 100x100.
+#
+# $matrix: the matrix as an AoA reference
+# $low: lower linear search index, inclusive
+# $high: higher linear search index, exclusive
+# $value: search value
+# The caller's $_[1] and $_[2] have to be writable and will be modified!
+sub bsearch_matrix ($matrix, $low, $high, $value) {
+    my $low_val = get_at($matrix, $low);
+    return 1 if $value == $low_val;
+    return 0 if $value < $low_val;
+    return 0 if $low + 1 == $high;
+
+    # Split the search interval and select the appropriate part.
+    my $mean = int(($low + $high) / 2);
+    @_[1, 2] = $value < get_at($matrix, $mean) ?
+        ($low, $mean) : ($mean, $high);
+
+    # Recursion without stack growth.
+    goto &{(__SUB__)};
+}
+
+# Retrieve matrix element by linear index.
+sub get_at ($m, $l) {
+    $m->[$l / @$m][$l % @$m];
+}
+
+# Turn the argument into an independent, writable value.
+# Enforces call-by-value when applied to a subroutine parameter.
+sub v ($v) {$v}
+
+# Alternative PDL solution.  Simple and fast, though not optimal.
+sub scan_matrix($pdl, $value) {
+    any $pdl == $value;
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    my $m = [
+        [  1,  2,  3,  5,  7 ],
+        [  9, 11, 15, 19, 20 ],
+        [ 23, 24, 25, 29, 31 ],
+        [ 32, 33, 39, 40, 42 ],
+        [ 45, 47, 48, 49, 50 ]];
+    my $high = @$m**2;
+
+    SKIP: {
+        skip "examples" unless $examples;
+
+        my $pdl = long $m;
+        ok !bsearch_matrix($m, v(0), v($high), 35), 'example 1, bsearch';
+        ok !scan_matrix($pdl, 35), 'example 1, scan';
+        ok bsearch_matrix($m, v(0), v($high), 39),  'example 2, bsearch';
+        ok scan_matrix($pdl, 39),  'example 2, scan';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+        
+        # Some edge cases.
+        ok bsearch_matrix($m, v(0), v($high), 1),  'first element';
+        ok bsearch_matrix($m, v(0), v($high), 50),  'last element';
+        ok !bsearch_matrix($m, v(0), v($high), 0),  'below min';
+        ok !bsearch_matrix($m, v(0), v($high), 51),  'above max';
+
+        # bsearch is taking over:
+        for (5, 80, 160) {
+            my $pdl = sequence long, $_, $_;
+            my $matrix = $pdl->unpdl;
+            my $high = @$matrix**2;
+            my $value = $high - 1;
+            say "\n${_}x${_}:";
+            cmpthese(-1, {
+                    scan => sub {scan_matrix($pdl, $value)},
+                    bsearch => sub {
+                        bsearch_matrix($matrix, v(0), v($high), $value)
+                    }
+                });
+        }
+	}
+
+    done_testing;
+    exit;
+}
+
+__DATA__
+5x5:
+            Rate    scan bsearch
+scan    115925/s      --     -0%
+bsearch 115925/s      0%      --
+
+80x80:
+           Rate bsearch    scan
+bsearch 47999/s      --    -21%
+scan    60703/s     26%      --
+
+160x160:
+           Rate    scan bsearch
+scan    25599/s      --    -39%
+bsearch 42309/s     65%      --
diff --git a/challenge-111/jo-37/perl/ch-2.pl b/challenge-111/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..c514bdcf27
--- /dev/null
+++ b/challenge-111/jo-37/perl/ch-2.pl
@@ -0,0 +1,48 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use warnings;
+use experimental 'postderef';
+
+# The task states "find the longest English words".  This could be meant
+# as "all words having the maximum length".  My local dictionary has
+# only one longest word of this kind, which does not qualify as "longest
+# words" - a plural.
+# Therefore I'll interpret the term "the longest words" in a way that
+# multiple words may be found.
+#
+# Here $n defines "the longest words".  In addition to the word(s)
+# having the maximum length, all lengths down to max_len - $n are
+# considered as "long", resulting in a larger set of "longest words" if
+# $n > 0.
+our $n;
+$n //= 1;
+
+die <<EOS unless @ARGV;
+usage: $0 [-n=<n>] dict...
+
+-n=<n>
+    Specify the maximum length difference from the maximum length for
+    words to be printed.  Default: 1.  Use -n=0 to print the maximum
+    length word(s) only.
+
+dict...
+    dictionary file name(s), e.g. /usr/share/dict/words
+
+EOS
+
+
+my @word;
+
+while (<>) {
+    chomp;
+    $_ = lc;
+    # Detect a "self-sorted" word and add it to an array of words having
+    # the same length.
+    push $word[length]->@*, $_ if join('', sort split //) eq $_;
+}
+
+# Reverse the order of the collected arrays, pick the first
+# $n + 1 thereof, dereference these and print the words.
+# @word may contain gaps.
+say for map {$_ ? @$_ : ()} (reverse @word)[0 .. $n];