Merge pull request #7433 from boblied/master

Week 200 from bob-lied

3 files changed, 201 insertions, 2 deletions

diff --git a/challenge-200/bob-lied/README b/challenge-200/bob-lied/README
index 5a7d2f0335..3d4521e11d 100644
--- a/challenge-200/bob-lied/README
+++ b/challenge-200/bob-lied/README
@@ -1,3 +1,4 @@
-Solutions to weekly challenge 199 by Bob Lied
+Solutions to weekly challenge 200 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-199/
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-200/
+https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-200/bob-lied
diff --git a/challenge-200/bob-lied/perl/ch-1.pl b/challenge-200/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..dfd881146d
--- /dev/null
+++ b/challenge-200/bob-lied/perl/ch-1.pl
@@ -0,0 +1,69 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge Week 200 Task 1 Arithmetic Slice
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given an array of integers.
+# Write a script to find out all Arithmetic Slices for the given array of
+# integers.  An integer array is called arithmetic if it has at least 3
+# elements and the differences between any three consecutive elements are the same.
+#
+# Example 1 Input: @array = (1,2,3,4) Output: (1,2,3), (2,3,4), (1,2,3,4)
+# Example 2 Input: @array = (2) Output: () as no slice found.
+#
+# Example 1 implies that we should get every sub-slice of length at least 3
+# and that output order should have shorter sequences first
+#=============================================================================
+
+use v5.36;
+
+use List::Util qw/all/;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+use constant MINLENGTH => 3;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+die "All args should be numeric" unless all { $_ =~ m/-?\d+/ } @ARGV;
+
+my $answer = aslice(@ARGV); # Should validate all numbers
+say join(", ", map { "(". join(",", $_->@*) .")" } $answer->@*);
+
+sub aslice(@list)
+{
+    my @result = ();
+    while ( @list >= MINLENGTH )
+    {
+        my $diff = $list[1] - $list[0];
+
+        for ( my $i = 2; $i < @list && $list[$i] - $list[$i-1] == $diff ; $i++ )
+        {
+            # Push every sub-slice that is at least MINLENGTH long
+            push @result, [ @list[0..$i] ] if $i >= (MINLENGTH -1 );
+        }
+        shift @list;
+    }
+    return [ sort { scalar(@$a) <=> scalar(@$b) } @result ];
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( aslice( 1,2,3,4 ), [ [1,2,3], [2,3,4], [1,2,3,4] ],  "Example 1");
+    is( aslice( 2       ), [ ],                              "Example 2");
+    is( aslice( 1,2,4,6,9,15,20,25,30,37 ),
+        [ [2,4,6], [15,20,25], [20,25,30], [15,20,25,30] ],  "Bigger list, more diffs");
+    is( aslice( 2,3,5,8,13,21 ), [],                         "No runs of 3");
+    is( aslice( 3,6,4,7,10 ), [[4,7,10]],                    "Non-monotonic");
+    is( aslice( 9,3,1,-1 ), [ [3,1,-1] ],                    "Negative difference");
+
+    done_testing;
+}
+
diff --git a/challenge-200/bob-lied/perl/ch-2.pl b/challenge-200/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..18c23d62fb
--- /dev/null
+++ b/challenge-200/bob-lied/perl/ch-2.pl
@@ -0,0 +1,129 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge Week 200 Task 2 Seven Segment 200
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# A seven segment display is an electronic component, usually used to
+# display digits. The segments are labeled 'a' through 'g' as shown:
+#   
+#    --   <- a
+#  f|  |b
+#    --   <- g
+#  e|  |c
+#    --   <- d
+#
+# The encoding of each digit can be represented compactly as a truth table:
+# 
+# my @truth = qw<abcdef bc abdeg abcdg bcfg acdfg acdefg abc abcdefg abcfg>;
+# 
+# For example, $truth[1] = ‘bc’. The digit 1 would have segments ‘b’ and ‘c’
+# enabled.
+# 
+# Write a program that accepts any decimal number and draws that number
+# as # a horizontal sequence of ASCII seven segment displays, similar to
+# the # following:
+#
+# -------  -------  -------
+#       |  |     |  |     |
+#       |  |     |  |     |
+# -------
+# |        |     |  |     |
+# |        |     |  |     |
+# -------  -------  -------
+#
+# To qualify as a seven segment display, each segment must be drawn (or not
+# drawn) according to your @truth table.
+# The number "200" was of course chosen to celebrate our 200th week!
+#=============================================================================
+
+use v5.36;
+
+# Which segments are on for each digit?
+             #    0    1   2     3    4     5     6     7     8      9
+my @truth = qw<abcdef bc abdeg abcdg bcfg acdfg acdefg abc abcdefg abcfg>;
+
+# 7x7 as one 49-character string, a few different styles
+# aaaaaaa     aaaaa          aaaaa
+# f     f    f     b        ff   bb  Bold version
+# f     b    f     b        ff   bb
+# ggggggg     ggggg          ggggg
+# e     c    e     c        ee   cc
+# e     c    e     c        ee   cc
+# ddddddd     ddddd          ddddd
+#my $Digit = 'aaaaaaaf     bf     bggggggge     ce     cddddddd'; # Match example
+ my $Digit = ' aaaaa f     bf     b ggggg e     ce     c ddddd '; # Rounded corners
+#my $Digit = 'aaaaaaaff   bbff   bbgggggggee   ccee   ccddddddd'; # Bold
+
+# Display characteristics
+ my %Char;
+#$Char{$_} = '-' for qw(a d g); $Char{$_} = '|' for qw(b c e f);
+#$Char{$_} = '=' for qw(a d g); $Char{$_} = '|' for qw(b c e f);
+#$Char{$_} = '#' for qw(a b c d e f g);
+#$Char{$_} = 'o' for qw(a b c d e f g);
+
+# Use Unicode horizontal and vertical bars
+binmode(STDOUT, "encoding(UTF-8)"); # No "wide character" warning
+#$Char{$_} = "\x{2500}" for qw(a d g); $Char{$_} = "\x{2502}" for qw(b c e f);
+ $Char{$_} = "\x{2501}" for qw(a d g); $Char{$_} = "\x{2503}" for qw(b c e f);
+# $Char{$_} = "\x{2550}" for qw(a d g); $Char{$_} = "\x{2551}" for qw(b c e f);
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+displayAsSegment($_) for @ARGV;
+
+sub displayAsSegment($str)
+{
+    # Make a 49-character segment string for each digit
+    my @seg = map { asSegment($_) } split '', $str;
+
+    for my $row ( 0 .. 6 )
+    {
+        # Make a row by taking a 7-char substring of each segment
+        # Top row:    0 ..  6     0 ..  6     0 ..  6
+        #       2:    7    13     7 .. 13     7 .. 13
+        #   ...
+        #       7:   42 .. 48    42 .. 48    42 .. 48
+        say join("  ", map { substr($seg[$_], $row*7, 7) } 0 .. $#seg);
+    }
+}
+
+sub asSegment($digit)
+{
+    my $seven = $Digit;
+    my $t = $truth[$digit];
+
+    # Turn off segments not in the digit
+    $seven =~ s/[^$t]/ /g;
+
+    for my $on ( split '', $t )
+    {
+        $seven =~ s/$on/$Char{$on}/g;
+    }
+    return $seven;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+            my $Digit = ' aaaaa f     bf     b ggggg e     ce     c ddddd ';
+    is( asSegment("0"), ' ----- |     ||     |       |     ||     | ----- ', "asSegment 0");
+    is( asSegment("1"), '             |      |             |      |       ', "asSegment 1");
+    is( asSegment("2"), ' -----       |      | ----- |      |       ----- ', "asSegment 2");
+    is( asSegment("3"), ' -----       |      | -----       |      | ----- ', "asSegment 3");
+    is( asSegment("4"), '       |     ||     | -----       |      |       ', "asSegment 4");
+    is( asSegment("5"), ' ----- |      |       -----       |      | ----- ', "asSegment 5");
+    is( asSegment("6"), ' ----- |      |       ----- |     ||     | ----- ', "asSegment 6");
+    is( asSegment("7"), ' -----       |      |             |      |       ', "asSegment 7");
+    is( asSegment("8"), ' ----- |     ||     | ----- |     ||     | ----- ', "asSegment 8");
+    is( asSegment("9"), ' ----- |     ||     | -----       |      |       ', "asSegment 9");
+
+    done_testing;
+}