Merge pull request #7582 from boblied/master

Week 204 and backlog 203, 179

8 files changed, 678 insertions, 6 deletions

diff --git a/challenge-179/bob-lied/perl/ch-1.pl b/challenge-179/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..bc62051e23
--- /dev/null
+++ b/challenge-179/bob-lied/perl/ch-1.pl
@@ -0,0 +1,269 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge Week 179 Task 1 Ordinal Number Spelling
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given a positive number, $n.
+# Write a script to spell the ordinal number.
+# Examples
+#   11 => eleventh
+#   62 => sixty-second
+#   99 => ninety-ninth
+#=============================================================================
+
+use v5.36;
+
+use builtin qw/ceil floor indexed/;
+no warnings 'experimental';
+
+my @Ones = qw( zero one two three four five six seven eight nine);
+my @Oneth = qw( zeroth first second third fourth fifth sixth
+                seventh eighth ninth );
+
+my @Teen = qw(ten eleven twelve thirteen fourteen fifteen sixteen
+              seventeen eighteen nineteen);
+my @Teenth = map { "${_}th" } @Teen;
+$Teenth[2] = "twelfth";
+
+my @Tens = qw( zero ten twenty thirty forty fifty sixty seventy eighty ninety );
+my @Tenthieth = map { (my $th = $_) =~ s/y\z/ie/; "${th}th" } @Tens;
+
+my @BigName = qw(none thousand million billion trillion quatrillion quintillion
+             sextillion septillion octillion nonillion decillion );
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+say asOrdinalString($_) for @ARGV;
+
+
+# Returns pairs of 3-digit values and group names, like [321,million][456,thousand]
+sub groupThree($n)
+{
+    my @group;
+    my $numGrp = ceil(length($n) / 3);
+    for ( my $i = 0 ; $i < $numGrp ; $i++ )
+    {
+        unshift @group, [ substr($n, -3*($i+1), 3), $BigName[$i] ];
+    }
+    return \@group;
+}
+
+sub asOrdinalString($n)
+{
+    my $str;
+    my $group = groupThree($n);
+
+    # For each group of three, form an ordinal number for the least
+    # group and a cardinal number with its name for the higher groups.
+    my @parts = map {
+                    my ($val, $grpName) = $_->@*;
+                    $grpName eq 'none'
+                            ?   ordinal($val)
+                            : (cardinal($val) . " $grpName")
+                 } $group->@* ;
+
+    # Handle things like 7_000_444 and 1000 -- don't keep things
+    # like "zero thousand" or "one thousand zeroth"
+    if ( @parts > 1 )
+    {
+        @parts = grep !/zero/, @parts;
+        if ( ($n % 1000 ) == 0 )
+        {
+            # If we have a round number, we've stripped away
+            # the 'zeroth' string at the end, so we have to
+            # correct it by adding 'th' back to the end.
+            $parts[-1] .= "th";
+        }
+    }
+
+    $str = join(' ', @parts);
+    return $str;
+}
+
+# Create a string for a 3-digit number.
+sub cardinal($n)
+{
+    return "zero" if $n == 0;
+    my $ones  = $n % 10;
+    my $tens  = int($n / 10 ) % 10;
+    my $hunds = int($n / 100 ) % 10;
+
+    my $str;
+    if ( $ones != 0 )
+    {
+        $str = ( $tens == 1 ? $Teen[$ones] : $Ones[$ones] );
+    }
+    elsif ( $tens == 1 )
+    {
+        $str = ( $Tens[1] );
+    }
+    if ( $tens > 1 )
+    {
+        $str = ( $ones == 0 ? $Tens[$tens] : "$Tens[$tens]-$str" );
+    }
+    if ( $hunds != 0 )
+    {
+        $str = ( $n %100 == 0 ? "$Ones[$hunds] hundred" : "$Ones[$hunds] hundred $str" );
+    }
+    return $str;
+}
+
+# Create an ordinal string for a three-digit number.
+sub ordinal($n)
+{
+    return "zeroth" if $n == 0 ;
+
+    my $ones  = $n % 10;
+    my $tens  = int($n / 10 ) % 10;
+    my $hunds = int($n / 100 ) % 10;
+
+    my $str;
+
+    if ( $ones != 0 )
+    {
+        $str = ( $tens == 1 ? $Teenth[$ones] : $Oneth[$ones] );
+    }
+    elsif ( $tens == 1 )
+    {
+        $str = $Tenthieth[$tens];
+    }
+    if ( $tens > 1 )
+    {
+        $str = ( $ones == 0 ? $Tenthieth[$tens] : "$Tens[$tens]-$str" );
+    }
+    if ( $hunds != 0 )
+    {
+        $str = ( $n %100 == 0 ? "$Ones[$hunds] hundredth" : "$Ones[$hunds] hundred $str" );
+    }
+    return $str;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( groupThree(1),         [ [  1, "none"] ], "Grouping 1");
+    is( groupThree(321),       [ [321, "none"] ], "Grouping 321");
+    is( groupThree(4321),      [ [  4, "thousand"],[321,'none'] ], "Grouping 4321");
+    is( groupThree(7654321),   [ [7,'million'],[654, "thousand"],[321,'none'] ], "Grouping 7654321");
+    is( groupThree(1987654321),[ [  1,'billion'],
+                                 [987,'million'],
+                                 [654, "thousand"],
+                                 [321,'none'] ], "Grouping 1987654321");
+    is( groupThree(4001987654321),[ [  4,'trillion'],
+                                    ['001','billion'],
+                                    [987,'million'],
+                                    [654, "thousand"],
+                                    [321,'none'] ], "Grouping 4001987654321");
+
+
+    is( ordinal( 0), "zeroth",       "ord  0");
+    is( ordinal( 1), "first",        "ord  1");
+    is( ordinal( 2), "second",       "ord  2");
+    is( ordinal( 3), "third",        "ord  3");
+    is( ordinal( 4), "fourth",       "ord  4");
+    is( ordinal( 5), "fifth",        "ord  5");
+    is( ordinal(10), "tenth",        "ord 10");
+    is( ordinal(11), "eleventh",     "ord 11");
+    is( ordinal(12), "twelfth",      "ord 12");
+    is( ordinal(20), "twentieth",    "ord 20");
+    is( ordinal(30), "thirtieth",    "ord 30");
+    is( ordinal(40), "fortieth",     "ord 40");
+    is( ordinal(50), "fiftieth",     "ord 50");
+    is( ordinal(60), "sixtieth",     "ord 60");
+    is( ordinal(62), "sixty-second", "ord 62");
+    is( ordinal(70), "seventieth",   "ord 70");
+    is( ordinal(80), "eightieth",    "ord 80");
+    is( ordinal(90), "ninetieth",       "ord 90");
+    is( ordinal(91), "ninety-first",    "ord 91");
+    is( ordinal(92), "ninety-second",   "ord 92");
+    is( ordinal(93), "ninety-third",    "ord 93");
+    is( ordinal(94), "ninety-fourth",   "ord 94");
+    is( ordinal(95), "ninety-fifth",    "ord 95");
+    is( ordinal(96), "ninety-sixth",    "ord 96");
+    is( ordinal(97), "ninety-seventh",  "ord 97");
+    is( ordinal(98), "ninety-eighth",   "ord 98");
+    is( ordinal(99), "ninety-ninth",    "ord 99");
+    is( ordinal(100), "one hundredth",  "ord 100");
+    is( ordinal(101), "one hundred first",  "ord 101");
+    is( ordinal(111), "one hundred eleventh",  "ord 111");
+    is( ordinal(233), "two hundred thirty-third",  "ord 233");
+
+    is( cardinal( 0), "zero",       "card  0");
+    is( cardinal( 1), "one",        "card  1");
+    is( cardinal( 2), "two",       "card  2");
+    is( cardinal( 3), "three",        "card  3");
+    is( cardinal( 4), "four",       "card  4");
+    is( cardinal( 5), "five",        "card  5");
+    is( cardinal(10), "ten",     "card 10");
+    is( cardinal(11), "eleven",     "card 11");
+    is( cardinal(12), "twelve",      "card 12");
+    is( cardinal(20), "twenty",    "card 20");
+    is( cardinal(30), "thirty",    "card 30");
+    is( cardinal(40), "forty",     "card 40");
+    is( cardinal(50), "fifty",     "card 50");
+    is( cardinal(60), "sixty",     "card 60");
+    is( cardinal(62), "sixty-two", "card 62");
+    is( cardinal(70), "seventy",   "card 70");
+    is( cardinal(80), "eighty",    "card 80");
+    is( cardinal(90), "ninety",       "card 90");
+    is( cardinal(91), "ninety-one",    "card 91");
+    is( cardinal(92), "ninety-two",   "card 92");
+    is( cardinal(93), "ninety-three",    "card 93");
+    is( cardinal(94), "ninety-four",   "card 94");
+    is( cardinal(95), "ninety-five",    "card 95");
+    is( cardinal(96), "ninety-six",    "card 96");
+    is( cardinal(97), "ninety-seven",  "card 97");
+    is( cardinal(98), "ninety-eight",   "card 98");
+    is( cardinal(99), "ninety-nine",    "card 99");
+    is( cardinal(100), "one hundred",  "card 100");
+    is( cardinal(101), "one hundred one",  "card 101");
+    is( cardinal(111), "one hundred eleven",  "card 111");
+    is( cardinal(233), "two hundred thirty-three", "card 233");
+
+    is( asOrdinalString( 0), "zeroth",       "asOrdinalString  0");
+    is( asOrdinalString( 1), "first",        "asOrdinalString  1");
+    is( asOrdinalString( 2), "second",       "asOrdinalString  2");
+    is( asOrdinalString( 3), "third",        "asOrdinalString  3");
+    is( asOrdinalString( 4), "fourth",       "asOrdinalString  4");
+    is( asOrdinalString( 5), "fifth",        "asOrdinalString  5");
+    is( asOrdinalString(11), "eleventh",     "asOrdinalString 11");
+    is( asOrdinalString(12), "twelfth",      "asOrdinalString 12");
+    is( asOrdinalString(20), "twentieth",    "asOrdinalString 20");
+    is( asOrdinalString(30), "thirtieth",    "asOrdinalString 30");
+    is( asOrdinalString(40), "fortieth",     "asOrdinalString 40");
+    is( asOrdinalString(50), "fiftieth",     "asOrdinalString 50");
+    is( asOrdinalString(60), "sixtieth",     "asOrdinalString 60");
+    is( asOrdinalString(62), "sixty-second", "asOrdinalString 62");
+    is( asOrdinalString(70), "seventieth",   "asOrdinalString 70");
+    is( asOrdinalString(80), "eightieth",    "asOrdinalString 80");
+    is( asOrdinalString(90), "ninetieth",       "asOrdinalString 90");
+    is( asOrdinalString(91), "ninety-first",    "asOrdinalString 91");
+    is( asOrdinalString(92), "ninety-second",   "asOrdinalString 92");
+    is( asOrdinalString(93), "ninety-third",    "asOrdinalString 93");
+    is( asOrdinalString(94), "ninety-fourth",   "asOrdinalString 94");
+    is( asOrdinalString(95), "ninety-fifth",    "asOrdinalString 95");
+    is( asOrdinalString(96), "ninety-sixth",    "asOrdinalString 96");
+    is( asOrdinalString(97), "ninety-seventh",  "asOrdinalString 97");
+    is( asOrdinalString(98), "ninety-eighth",   "asOrdinalString 98");
+    is( asOrdinalString(99), "ninety-ninth",    "asOrdinalString 99");
+    is( asOrdinalString(100), "one hundredth",  "asOrdinalString 100");
+    is( asOrdinalString(101), "one hundred first",  "asOrdinalString 101");
+    is( asOrdinalString(111), "one hundred eleventh",  "asOrdinalString 111");
+    is( asOrdinalString(233), "two hundred thirty-third",  "asOrdinalString 233");
+    is( asOrdinalString(1002003), "one million two thousand third",  "asOrdinalString 1002003");
+    is( asOrdinalString(10000), "ten thousandth", "asordinalString 10000");
+    is( asOrdinalString(10_164_502_713),
+        "ten billion one hundred sixty-four million five hundred two thousand seven hundred thirteenth",  "asOrdinalString 1002003");
+
+
+    done_testing;
+}
+
diff --git a/challenge-179/bob-lied/perl/ch-2.pl b/challenge-179/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..168bb2c396
--- /dev/null
+++ b/challenge-179/bob-lied/perl/ch-2.pl
@@ -0,0 +1,79 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge Week 179 Task 2 Unicode Sparkline
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given a list of positive numbers, @n.
+# Write a script to print sparkline in Unicode for the given list of numbers.
+#
+# This seems to be a very brief description of the challenge from RosettaCode
+# https://rosettacode.org/wiki/Sparkline_in_unicode
+# Use the following series of Unicode characters to create a program that
+# takes a series of numbers separated by one or more whitespace or comma
+# characters and generates a sparkline-type bar graph of the values on a
+# single line of output.
+# The eight characters: '▁▂▃▄▅▆▇█' (Unicode values U+2581 through U+2588).
+# Use your program to show sparklines for the following input, here on this page:
+# 1 2 3 4 5 6 7 8 7 6 5 4 3 2 1 ▁▂▃▄▅▆▇█▇▆▅▄▃▂▁
+# 1.5, 0.5 3.5, 2.5 5.5, 4.5 7.5, 6.5 ▂▁▄▃▆▅█▇
+# (note the mix of separators in this second case)!
+# Notes
+#   A space is not part of the generated sparkline.
+#   The sparkline may be accompanied by simple statistics of the data such as
+#   its range.
+#   A suggestion emerging in later discussion (see Discussion page) is that
+#   the bounds between bins should ideally be set to yield the following
+#   results for two particular edge cases:
+#   0, 1, 19, 20 -> ▁▁██ (Aiming to use just two spark levels)
+#   0, 999, 4000, 4999, 7000, 7999 -> ▁▁▅▅██ (Aiming for three spark levels)
+#=============================================================================
+
+use v5.36;
+binmode(STDOUT, ":encoding(UTF-8)");
+
+use List::SomeUtils qw/minmax/;
+
+my @Level = ( "\N{LOWER ONE EIGHTH BLOCK}",
+              "\N{LOWER ONE QUARTER BLOCK}",
+              "\N{LOWER THREE EIGHTHS BLOCK}",
+              "\N{LOWER HALF BLOCK}",
+              "\N{LOWER FIVE EIGHTHS BLOCK}",
+              "\N{LOWER THREE QUARTERS BLOCK}",
+              "\N{LOWER SEVEN EIGHTHS BLOCK}",
+              "\N{FULL BLOCK}" );
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+say sparkLine(\@ARGV);
+
+sub sparkLine($list)
+{
+    my ($min, $max) = minmax $list->@*;
+    my $range = $max - $min+1;
+
+    my @bucket = map { int( ($_-$min) / ($range/@Level) ) } $list->@*;
+
+    my @histogram = map { $Level[$_] } @bucket;
+
+    return join("", @histogram);
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( sparkLine([1,2,3,4,5,6,7,8,7,6,5,4,3,2,1]),   "▁▂▃▄▅▆▇█▇▆▅▄▃▂▁", "Example 1");
+    is( sparkLine([1.5,0.5,3.5,2.5,5.5,4.5,7.5,6.5]), "▂▁▄▃▆▅█▇",        "Example 2");
+    is( sparkLine([0,1,19,20]),                       "▁▁██",            "Two levels");
+    is( sparkLine([0,999,4000,4999,7000,7999]),       "▁▁▅▅██",          "Three levels");
+
+    done_testing;
+}
+
diff --git a/challenge-203/bob-lied/README b/challenge-203/bob-lied/README
index a2b67fd974..b6b1a39cca 100644
--- a/challenge-203/bob-lied/README
+++ b/challenge-203/bob-lied/README
@@ -1,4 +1,4 @@
-Solutions to weekly challenge 202 by Bob Lied
+Solutions to weekly challenge 203 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-202/
-https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-202/bob-lied
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-203/
+https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-203/bob-lied
diff --git a/challenge-203/bob-lied/perl/ch-1.pl b/challenge-203/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..405b81677d
--- /dev/null
+++ b/challenge-203/bob-lied/perl/ch-1.pl
@@ -0,0 +1,83 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge Week 203 Task 1 Special Quadruplets
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given an array of integers.
+# Write a script to find out the total special quadruplets for the given array.
+# Special Quadruplets are such that satisfies the following 2 rules.
+# 1) nums[a] + nums[b] + nums[c] == nums[d]
+# 2) a < b < c < d
+# Example 1 Input: @nums = (1,2,3,6) Output: 1
+#   Since the only special quadruplets found is
+#   $nums[0] + $nums[1] + $nums[2] == $nums[3].
+# Example 2 Input: @nums = (1,1,1,3,5) Output: 4
+#   $nums[0] + $nums[1] + $nums[2] == $nums[3]
+#   $nums[0] + $nums[1] + $nums[3] == $nums[4]
+#   $nums[0] + $nums[2] + $nums[3] == $nums[4]
+#   $nums[1] + $nums[2] + $nums[3] == $nums[4]
+# Example 3 Input: @nums = (3,3,6,4,5) Output: 0
+#=============================================================================
+
+use v5.36;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+say quad(\@ARGV);
+
+sub quad($nums)
+{
+    my $howMany = 0;
+    my @quad;
+    my $end = $#{$nums};
+    for ( my $a = 0 ; $a <= $end-3 ; $a ++ )
+    {
+        for ( my $b = $a+1 ; $b <= $end-2; $b++ )
+        {
+            for ( my $c = $b + 1 ; $c <= $end-1 ; $c++ )
+            {
+                my $q = $nums->[$a] + $nums->[$b] + $nums->[$c];
+                for ( my $d = $c + 1 ; $d <= $end ; $d++ )
+                {
+                    if ( $q == $nums->[$d] )
+                    {
+                        $howMany++;
+                        push @quad, [$a, $b, $c, $d] if $Verbose;
+                    }
+                }
+            }
+        }
+    }
+    showQuad(\@quad, $nums) if $Verbose;
+    return $howMany;
+}
+
+sub showQuad($quad, $nums)
+{
+    for my $q ( $quad->@* )
+    {
+        print "nums[", join(", ", $q->@*), "]";
+        print "\t";
+        print join(", ", $nums->@[$q->@*]);
+        print "\n";
+    }
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( quad([1,2,3,6  ]), 1, "Example 1");
+    is( quad([1,1,1,3,5]), 4, "Example 2");
+    is( quad([3,3,6,4,4]), 0, "Example 3");
+
+    done_testing;
+}
+
diff --git a/challenge-203/bob-lied/perl/ch-2.pl b/challenge-203/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..e301318162
--- /dev/null
+++ b/challenge-203/bob-lied/perl/ch-2.pl
@@ -0,0 +1,79 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge Week 203 Task 2 Copy Directory
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given path to two folders, $source and $target.
+# Write a script that recursively copy the directory from $source to $target
+# except any files.
+# Example: Input: $source = '/a/b/c' and $target = '/x/y'
+# Source directory structure:
+# 
+# ├── a
+# │   └── b
+# │       └── c
+# │           ├── 1
+# │           │   └── 1.txt
+# │           ├── 2
+# │           │   └── 2.txt
+# │           ├── 3
+# │           │   └── 3.txt
+# │           ├── 4
+# │           └── 5
+# │               └── 5.txt
+# 
+# Target directory structure:
+# ├── x
+# │   └── y
+# 
+# Expected Result:
+# 
+# ├── x
+# │   └── y
+# |       ├── 1
+# │       ├── 2
+# │       ├── 3
+# │       ├── 4
+# │       └── 5 
+#
+# From a shell prompt using find and cpio;
+# ( cd $srcdir && find . -type d -print | cpio -pdumv $targetP ; )
+# where $targetP is $target relative to $srcdir
+#=============================================================================
+
+use v5.36;
+
+use File::Find;
+use File::Path qw/make_path/;
+
+use Getopt::Long;
+my $Verbose = 0;
+
+GetOptions("verbose" => \$Verbose);
+
+my ($srcdir, $target) = @ARGV;
+
+die "$srcdir is not a directory" unless -d $srcdir;
+die "$target is not an existing directory" unless -d $target;
+
+copyDir($srcdir, $target);
+
+sub copyDir($srcdir, $target)
+{
+    # Populate the @dirtree list of directories to be created.
+    # This list will be very redundant. We really only need the
+    # deepest branches of the tree, because make_path will create
+    # all the # intermediate levels.
+    #
+    # File::Find::name is the path of a directory, including $srcdir
+    my @dirtree;
+    find( sub() { -d && push @dirtree, $File::Find::name; }, $srcdir);
+
+    # Substitute target for source at the beginning of each directory.
+    # File::Path::make_path will create each directory, skipping over
+    # levels that already exist.
+    make_path( (map { s/^$srcdir/$target/; $_ } @dirtree ),
+              { verbose => $Verbose } );
+}
diff --git a/challenge-204/bob-lied/README b/challenge-204/bob-lied/README
index a2b67fd974..4294e8abc0 100644
--- a/challenge-204/bob-lied/README
+++ b/challenge-204/bob-lied/README
@@ -1,4 +1,4 @@
-Solutions to weekly challenge 202 by Bob Lied
+Solutions to weekly challenge 204 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-202/
-https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-202/bob-lied
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-204/
+https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-204/bob-lied
diff --git a/challenge-204/bob-lied/perl/ch-1.pl b/challenge-204/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..6239c85f82
--- /dev/null
+++ b/challenge-204/bob-lied/perl/ch-1.pl
@@ -0,0 +1,63 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge Week 204 Task 1 Monotonic Array
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given an array of integers.
+# Write a script to find out if the given array is Monotonic.
+# Print 1 if it is otherwise 0.
+# An array is Monotonic if it is either monotone increasing or decreasing.
+# Monotone increasing: for i <= j , nums[i] <= nums[j]
+# Monotone decreasing: for i <= j , nums[i] >= nums[j]
+# Example 1 Input: @nums = (1,2,2,3) Output: 1
+# Example 2 Input: @nums (1,3,2) Output: 0
+# Example 3 Input: @nums = (6,5,5,4) Output: 1
+#=============================================================================
+
+use v5.36;
+
+use List::Util qw/all/;
+use List::MoreUtils qw/slide/;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+sub isMonotonic($array)
+{
+    # Any list of two or less is trivially monotonic.
+    # No specification for an empty array.  Let's say it is monotonic.
+    return 1 if (not defined $array) || $#{$array} < 2;
+
+    # Apply the comparison operator to consecutive elements of array.
+    # Result is a list where each element is -1, 0, or 1
+    my @compare = slide { $a <=> $b } $array->@*;
+    my $isMono = ( all { $_ <= 0 } @compare ) || ( all { $_ >= 0 } @compare );
+    return $isMono ? 1 : 0;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( isMonotonic([         ]), 1, "Empty");
+    is( isMonotonic([ 7       ]), 1, "One element");
+    is( isMonotonic([ 7,8     ]), 1, "Two elements ascending");
+    is( isMonotonic([ 8,2     ]), 1, "Two elements descending");
+    is( isMonotonic([3,3,3,3  ]), 1, "Flat");
+    is( isMonotonic([3,4,5,3,2]), 0, "Peak");
+    is( isMonotonic([5,4,3,4,5]), 0, "Valley");
+    is( isMonotonic([5,6,5,4,5]), 0, "Square wave");
+    is( isMonotonic([5,5,6,4,5]), 0, "Sawtooth");
+    is( isMonotonic([1,2,2,3  ]), 1, "Example 1");
+    is( isMonotonic([1,3,2    ]), 0, "Example 1");
+    is( isMonotonic([6,5,5,4  ]), 1, "Example 1");
+
+    done_testing;
+}
+
diff --git a/challenge-204/bob-lied/perl/ch-2.pl b/challenge-204/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..4c7b2fa133
--- /dev/null
+++ b/challenge-204/bob-lied/perl/ch-2.pl
@@ -0,0 +1,99 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge Week 204 Task 2 Reshape Matrix
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given a matrix (m x n) and two integers (r) and (c).
+# Write a script to reshape the given matrix in form (r x c) with the
+# original value in the given matrix. If you can’t reshape print 0.
+# Example 1 Input: [ 1 2 ]
+#                  [ 3 4 ] $matrix = [ [ 1, 2 ], [ 3, 4 ] ]
+#                  $r = 1 $c = 4
+#          Output: [ 1 2 3 4 ]
+# Example 2 Input: [ 1 2 3 ]
+#                  [ 4 5 6 ] $matrix = [ [ 1, 2, 3 ] , [ 4, 5, 6 ] ]
+#                  $r = 3 $c = 2
+#          Output: [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ]
+# Example 3 Input: [ 1 2 ] $matrix = [ [ 1, 2 ] ]
+#                  $r = 3 $c = 2
+#          Output: 0
+#=============================================================================
+
+use v5.36;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+sub usage() { qq(echo -e "[1,2] \\n [3,4]" | $0 r c ) }
+
+my $Row = shift;
+my $Col = shift;
+
+die 'Usage: '. usage() unless (defined $Row && $Row > 0) && (defined $Col && $Col > 0);
+
+my $input  = readMatrix();
+my $output = reshape($input, $Row, $Col);
+showMatrix($output);
+
+sub readMatrix()
+{
+    # Assuming one line per row, square brackets on the ends
+    # and possibly separated by commas
+    my @matrix;
+    while (<>)
+    {
+        chomp;
+        next if m/^\w*$/;   # Ignore blank lines
+        s/[[\],]/ /g;       # Leave only numbers
+        push @matrix, [ split ' ' ];    # Split on white space
+    }
+    return \@matrix;
+}
+
+sub reshape($matrix, $r, $c)
+{
+    showMatrix($matrix, "Input") if $Verbose;
+
+    my $origR = scalar(@$matrix);
+    my $origC = scalar( $matrix->[0]->@* );
+
+    return 0 if ( ($origR * $origC) != ($r * $c) );
+
+    my @flat = map { $_->@*  } $matrix->@*;
+
+    my @newMatrix;
+    push @newMatrix, [ splice(@flat, 0, $c) ] for 1 .. $r;
+    showMatrix(\@newMatrix, "Output") if $Verbose;
+    return \@newMatrix;
+}
+
+sub showMatrix($m, $title = "")
+{
+    my $row = scalar(@$m);
+
+    say $title;
+    for ( my $r = 0 ; $r < $row; $r++)
+    {
+        say +(' ' x length($title)), "[ ", join(", ", $m->[$r]->@*), " ]";
+    }
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( reshape( [ [1,2] ], 3, 2 ), 0, "Example 3");
+
+    is( reshape([ [1,2], [3,4] ], 1, 4), [ [ 1,2,3,4 ] ] , "Example 1");
+
+    is( reshape( [ [1,2,3], [4,5,6] ], 3, 2) , [ [1,2],[3,4],[5,6] ], "Example 2");
+
+    done_testing;
+}
+