Merge pull request #7434 from jo-37/contrib

Solutions to challenge 200

3 files changed, 299 insertions, 0 deletions

diff --git a/challenge-199/jo-37/perl/ch-2.pl b/challenge-199/jo-37/perl/ch-2.pl
index 292be9b25e..ef5a11b322 100755
--- a/challenge-199/jo-37/perl/ch-2.pl
+++ b/challenge-199/jo-37/perl/ch-2.pl
@@ -83,3 +83,19 @@ sub run_tests {
     done_testing;
     exit;
 }
+
+__DATA__
+
+Out of curiosity, rerun James Smith's benchmarks with this
+implementation added.  See
+https://github.com/manwar/perlweeklychallenge-club/blob/master/challenge-199/james-smith/perl/ch-2.pl
+
+          Rate   naive     opt range_1  copy_1  copy_2 range_2 fastest     pdl
+naive   21.5/s      --    -49%    -52%    -53%    -56%    -64%    -84%    -90%
+opt     41.9/s     95%      --     -7%     -8%    -13%    -29%    -70%    -81%
+range_1 45.1/s    110%      8%      --     -1%     -7%    -24%    -67%    -79%
+copy_1  45.8/s    113%      9%      1%      --     -5%    -22%    -67%    -79%
+copy_2  48.4/s    125%     15%      7%      6%      --    -18%    -65%    -78%
+range_2 59.0/s    174%     41%     31%     29%     22%      --    -57%    -73%
+fastest  138/s    543%    230%    207%    202%    186%    134%      --    -36%
+pdl      218/s    912%    419%    382%    375%    350%    269%     57%      --
diff --git a/challenge-200/jo-37/perl/ch-1.pl b/challenge-200/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..422065663b
--- /dev/null
+++ b/challenge-200/jo-37/perl/ch-1.pl
@@ -0,0 +1,124 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0 '!float';
+use PDL;
+use PDL::NiceSlice;
+use experimental 'postderef';
+
+our ($tests, $examples);
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV;
+usage: $0 [-examples] [-tests] [--] [N...]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+N...
+    list of numbers
+
+EOS
+
+
+### Input and Output
+
+main: {
+    local $" = ',';
+    local $, = ', ';
+    say map "(@$_)", arith_slices(@ARGV);
+}
+
+
+### Implementation
+
+# Using PDL to solve the task.  Overkill, once again.
+
+# Some details remain unspecified:
+# - the presentation order of the found arithmetic slices
+# - the treatment of different subslices having the same values
+# This implementation does:
+# - order maximal arithmetic slices by starting index
+# - find subslices by increasing length and by starting index within the
+#   same length
+# - regard subslices having a different starting index or length as
+#   different, regardless of the values therein.
+
+sub arith_slices {
+    return if @_ < 3;
+    my $l = long @_;
+
+    # Calculate differences between consecutive pairs and run-length
+    # encode these.  Only the run lengths are required, the differences
+    # get dropped.
+    my ($rl) = rle $l(1:-1) - $l(0:-2);
+    
+    # The starting indices of each run can be found by taking the
+    # cumulative sums over the run lengths starting with zero.
+    # There are several way to calculate the zero-based cumulative sums.
+    # One of them is to take the difference between the total sum and
+    # the reversed cumulative sums over the reversed list, as can be
+    # seen from this example:
+    # (a, b, c) -> ((a + b + c) - (c + b + a), (a + b + c) - (c + b),
+    # (a + b + c) - c) = (0, a, a + b)
+    # The total sum over the run length equals the length of the list of
+    # differences which is one less than the original list's length.
+    my $idx = $l->dim(0) - 1 - $rl(-1:0)->cumusumover->(-1:0);
+
+    # The differences' run lengths are one below the subarray lengths,
+    # adjust them.
+    $rl += 1;
+
+    # Select subarrays having a minimum length of three, given by their
+    # starting index and their length.
+    my @res;
+    for my $il (cat(where $idx, $rl, $rl > 2)->xchg(0, 1)->dog) {
+        # Pick a maximal arithmetic array slice given by index and
+        # lenght.
+        my $maas = $l->range($il->list);
+
+        # Split each maximal arithmetic array slice into all requested
+        # array slices and collect these.
+        push @res, map $maas->lags(0, 1, $_)
+            ->xchg(0, 1)->(-1:0)->unpdl->@*, 3 .. $maas->dim(0);
+    }
+
+    @res;
+}
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+
+        is [arith_slices(1, 2, 3, 4)],
+            [[1, 2, 3], [2, 3, 4], [1, 2, 3, 4]], 'example 1';
+
+        is [arith_slices(2)], [], 'example 2';
+
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+
+        is [arith_slices(1, 2, 3, 4, 3, 5, 7)],
+            [[1, 2, 3], [2, 3, 4], [1, 2, 3, 4], [3, 5, 7]],
+            'different step sizes';
+
+        is [arith_slices(-2, 0, 2)], [[-2, 0, 2]], 'negative value';
+
+        is [arith_slices(1, 2, 3, 5, 7)], [[1, 2, 3], [3, 5, 7]],
+            'adjacent slices';
+
+        is [arith_slices(0, 0, 0, 0)], [[0, 0, 0], [0, 0, 0], [0, 0, 0, 0]],
+            'slices having equal values';
+	}
+
+    done_testing;
+    exit;
+}
diff --git a/challenge-200/jo-37/perl/ch-2.pl b/challenge-200/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..85df4078e0
--- /dev/null
+++ b/challenge-200/jo-37/perl/ch-2.pl
@@ -0,0 +1,159 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0 '!float';
+use PDL;
+use PDL::NiceSlice;
+use experimental qw(signatures postderef);
+
+our ($tests, $examples, $p, $q);
+$p //= 7;
+$q //= 5;
+die "p too small" if $p < 5;
+die "q too small" if $q < 5;
+
+
+run_tests() if $tests || $examples;	# does not return
+
+die <<EOS unless @ARGV;
+usage: $0 [-examples] [-tests] [-p=P] [-q=Q] [N]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+-p=P
+-q=Q
+    dimensions of the generated 7-segment digits.
+    Defaults: P=7, Q=5
+
+N
+    number to be presented using 7-segment digits.
+
+EOS
+
+
+### Input and Output
+
+say_seven_segments($p, $q, shift);
+
+
+### Implementation
+
+# Fun solution to fun task.
+
+BEGIN {
+    # Define segments as slices within a PxQ piddle together with their
+    # character representation.  In default dimensions 7x5:
+    # ╔═══════╗
+    # ║  ---  ║
+    # ║ |   | ║ upper
+    #_║  ---  ║_
+    # ║ |   | ║
+    # ║  ---  ║ lower
+    # ╚═══════╝
+    # Each segment is described by four elements:
+    # - the character to be printed
+    # - the part index (upper = 0, lower = 1)
+    # - the column index range
+    # - the row index range
+    # Notes:
+    # - Segment 'g' is located at the last row of the upper part.
+    # - The lower part's last row is virtual when the number of rows is
+    #   odd and thus not usable.
+    # - All slices are defined in absolute offsets from some borders and
+    #   thus independent from the actual dimensions.
+    my @segments = (['-', [0], [2, -3], [0]], ['|', [0], [-2], [1, -2]],
+        ['|', [1], [-2], [0, -3]], ['-', [1], [2, -3], [-2]],
+        ['|', [1], [1], [0, -3]], ['|', [0], [1], [1, -2]],
+        ['-', [0], [2, -3], [-1]]);
+    # The following segment definition - when used in size 9x7 -
+    # reproduces the given example.  But I prefer the above design.
+    # my @segments = (['-', [0], [1, -2], [0]], ['|', [0], [-2], [1, -2]],
+    #    ['|', [1], [-2], [0, -3]], ['-', [1], [1, -2], [-2]],
+    #    ['|', [1], [1], [0, -3]], ['|', [0], [1], [1, -2]],
+    #    ['-', [0], [1, -2], [-1]]);
+
+    sub segments ($p, $q) {
+        # Start index of the lower part:
+        my $l = ($q + 1) / 2;
+
+        # Stack the individual segments' pixel planes.
+         cat(
+            map {
+                # Get the pixels for a single segment and set them to their
+                # character representation.
+                my $s = zeroes byte, $p, $q;
+                # Split the pixels into an upper and lower part.
+                my $ul = $s->range([[0, 0], [0, $l]], [$p, $l], 't');
+                # Draw a segment.
+                $ul($_->@[1..3]) .= ord $_->[0];
+                $s;
+            } @segments
+        )->reorder(2, 0, 1);
+    }
+}
+
+# Convert the truth table to an array of index piddles representing
+# the corresponding segments.
+sub decto7 {
+    map indx(map ord, split //) - ord('a'),
+        qw<abcdef bc abdeg abcdg bcfg acdfg acdefg abc abcdefg abcfg>;
+}
+
+sub say_seven_segments ($p, $q, $n) {
+    my $segments = segments($p, $q);
+    my @decto7 = decto7;
+
+    # Create a (P*L)xQ piddle holding the pixels of the given number
+    # (with L as the length of N) by concatenating the individual
+    # digits' pixels line-wise. 
+    my $out = byte cat(
+        # Select the segments as given by the truth table for every
+        # single digit and combine them.
+        map $segments($decto7[$_])->sumover, split //, $n
+    )->clump(0, 2);
+
+    # Print the pixels line-wise, mapping zero to blank and non-zero
+    # to the corresponding character.
+    say map $_ ? chr : ' ', $_->list for $out->dog;
+}
+
+
+### Examples and tests
+
+sub run_tests {
+    use autodie;
+
+    SKIP: {
+        skip "examples" unless $examples;
+
+        say_seven_segments(9, 7, 200); # Sized like the example
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+
+        open my $save, '>&', \*STDOUT;
+        close STDOUT;
+        open STDOUT, '>', \my $capture;
+
+        say_seven_segments(7, 5, 8);
+
+        close STDOUT;
+        open STDOUT, '>&', $save;
+
+        is $capture, <<EOS, 'check eight';
+  ---  
+ |   | 
+  ---  
+ |   | 
+  ---  
+EOS
+	}
+
+    done_testing;
+    exit;
+}