Merge pull request #7483 from boblied/master

Backlog weeks 182,184,185

9 files changed, 528 insertions, 6 deletions

diff --git a/challenge-182/bob-lied/README b/challenge-182/bob-lied/README
index c231e3a589..6fb1b537d5 100644
--- a/challenge-182/bob-lied/README
+++ b/challenge-182/bob-lied/README
@@ -1,3 +1,3 @@
-Solutions to weekly challenge 138 by Bob Lied
+Solutions to weekly challenge 182 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-138/
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-182/
diff --git a/challenge-182/bob-lied/perl/ch-1.pl b/challenge-182/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..425f8dcebc
--- /dev/null
+++ b/challenge-182/bob-lied/perl/ch-1.pl
@@ -0,0 +1,62 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge Week 182 Task 1 Max Index
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given a list of integers.
+# Write a script to find the index of the first biggest number in the list.
+# Example 1: Input: @n = (5, 2, 9, 1, 7, 6)
+#           Output: 2 (as 3rd element in the list is the biggest number)
+# Example 2: Input: @n = (4, 2, 3, 1, 5, 0)
+#           Output: 4 (as 5th element in the list is the biggest number)
+#=============================================================================
+
+use v5.36;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+use Scalar::Util qw/looks_like_number/;
+
+my @list = grep { looks_like_number($_) }  @ARGV;
+
+my $mi = maxIndex(@list);
+print "maxIndex(@list) = " if $Verbose;
+print $mi;
+print " (list[$mi]=$list[$mi])" if $Verbose;
+print "\n";
+
+sub maxIndex(@list)
+{
+    my $max = $list[0];
+    my $indexOfMax = 0;
+    for ( my $i = 1; $i < @list ; $i++ )
+    {
+        if ( $list[$i] > $max )
+        {
+            $max = $list[$i];
+            $indexOfMax = $i
+        }
+    }
+    return $indexOfMax;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( maxIndex(5,2,9,1,7,6), 2, "Example 1");
+    is( maxIndex(4,2,3,1,5,0), 4, "Example 1");
+    is( maxIndex(9,2,5,1,7,6), 0, "At 0");
+    is( maxIndex(6,2,5,1,7,9), 5, "At end");
+    is( maxIndex(7,7,7,7,7,7), 0, "Multiple");
+
+    done_testing;
+}
+
diff --git a/challenge-182/bob-lied/perl/ch-2.pl b/challenge-182/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..fe2549009c
--- /dev/null
+++ b/challenge-182/bob-lied/perl/ch-2.pl
@@ -0,0 +1,133 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge Week 182 Task 2 Common Path
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# Given a list of absolute Linux file paths, determine the deepest path
+# to the directory that contains all of them.
+# Example Input: /a/b/c/1/x.pl
+#                /a/b/c/d/e/2/x.pl
+#                /a/b/c/d/3/x.pl
+#                /a/b/c/4/x.pl
+#                /a/b/c/d/5/x.pl
+#         Ouput: /a/b/c
+#
+# We are going to infer that "absolute" means that the paths are
+# always full paths, starting from "/". That implies that "/" will
+# always be common to all the paths.
+#=============================================================================
+
+use v5.36;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+# Allow a file name as an argument, or read standard input.
+my $fh = *STDIN;
+if ( @ARGV )
+{
+    open($fh, '<', $ARGV[0]) || die "can't open $ARGV[0], $!";
+}
+
+say commonPath( parseInput($fh) );
+
+# Open a string as a file handle, to allow testing without depending
+# on extra files.
+sub parseInputFromString($s)
+{
+    open(my $fh, "<", \$s) || die "open input string failed, $!";
+    return parseInput($fh);
+}
+
+# Read the list of inputs and return an array of path segments,
+# Example:
+#   /a/b/d      [ [ 'a', 'b', 'd' ],
+#   /a/b/f        [ 'a', 'b', 'f' ] ]
+sub parseInput($fh)
+{
+    # String input has some extra white space around it.
+    # Opportunity to use a v5.36 feature.
+    use builtin qw/trim/; no warnings 'experimental::builtin';
+
+    my @pathList = ();  # Don't trip over undef
+    while ( <$fh> )
+    {
+        push @pathList, [ split '/', trim($_) ];
+    }
+    return \@pathList;
+}
+
+sub commonPath($pathList)
+{
+    use List::Util qw/all min/;
+
+    return '' if scalar(@$pathList) == 0;
+
+    my $depth = 0;
+
+    # We only have to go as deep as the shortest path.
+    my $maxDepth = (min map { scalar(@$_) } $pathList->@* );
+
+    # We go deeper as long as all paths are the same at this depth.
+    # The map takes a vertical column slice out of the pathList array.
+    $depth++ while ( $depth < $maxDepth &&
+                     all { $_ eq $pathList->[0][$depth] }
+                        map { $_->[$depth] } $pathList->@* );
+
+    return "/".join("/", $pathList->[0]->@[1..$depth-1]);
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    my @TestCase = (
+        { in => '/a/b/c/1/x.pl
+                 /a/b/c/d/e/2/x.pl
+                 /a/b/c/d/3/x.pl
+                 /a/b/c/4/x.pl
+                 /a/b/c/d/5/x.pl ',
+          out => '/a/b/c',
+          desc => "Example"
+        },
+        { in => '/a/b/c
+                 /b/c/d
+                 /d/e/f ',
+          out => '/',
+          desc => "Root only"
+        },
+        { in => '/a/b
+                 /a/b',
+          out => '/a/b',
+          desc => 'Identical'
+        },
+        { in => '/a a/b/c
+                 /a a/b c/d',
+          out => '/a a',
+          desc => 'White space'
+        },
+        { in => '/a/b/c',
+          out => '/a/b/c',
+          desc => "Singleton"
+        },
+        { in => '',
+          out => '',
+          desc => "Empty list"
+        },
+    );
+
+    for my $t ( 0 .. $#TestCase )
+    {
+        my $test = $TestCase[$t];
+        is( commonPath( parseInputFromString($test->{in}) ), $test->{out}, $test->{desc} );
+    }
+
+    done_testing;
+}
+
diff --git a/challenge-184/bob-lied/README b/challenge-184/bob-lied/README
index c231e3a589..4dbe332297 100644
--- a/challenge-184/bob-lied/README
+++ b/challenge-184/bob-lied/README
@@ -1,3 +1,3 @@
-Solutions to weekly challenge 138 by Bob Lied
+Solutions to weekly challenge 184 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-138/
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-184/
diff --git a/challenge-184/bob-lied/perl/ch-1.pl b/challenge-184/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..5aa155e8a8
--- /dev/null
+++ b/challenge-184/bob-lied/perl/ch-1.pl
@@ -0,0 +1,94 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge Week 184 Task 1 Sequence Number
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given list of strings in the format aa9999 i.e. first 2 characters
+# can be anything 'a-z' followed by 4 digits '0-9'.
+# Write a script to replace the first two characters with sequence starting
+# with '00', '01', '02' etc.
+# Example 1 Input: @list = ('ab1234', 'cd5678', 'ef1342')
+#          Output:         ('001234', '015678', '021342')
+# Example 2 Input: @list =  'pq1122', 'rs3334')
+#          Output:         ('001122', '013334')
+#=============================================================================
+
+use v5.36;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+my $format = qr/[a-z]{2}\d{4}/;
+
+for ( @ARGV )
+{
+    warn "Expect format aa9999, got $_" unless m/$format/;
+}
+
+say showArray( seqNum( grep /$format/, @ARGV ) );
+
+sub showArray(@array)
+{
+    return '()' unless @array;
+    return "('" . join("', '", @array) . "')";
+}
+
+sub seqNum(@list)
+{
+    # There's quite a lot of subtle Perl going on in one line here.
+    #
+    # Within the map, The return value of s/// is the number of
+    # substitutions,  not the string. To get a list of substituted
+    # strings, we need to return it explicitly.
+    #
+    # If we do the substitution to the $_ variable in the map, then we are
+    # modifying the original list.  If we want to keep the original list
+    # intact, we need to copy to a temporary variable and return that. The
+    # copy is done 'en passant' to be able to use the s/// operator in the
+    # same assignment statement; the idiom is: (my $copy=$orig) =~ s///.
+    #
+    # s///e evaluates the second part of s/// as Perl code and uses the
+    # result to substitue for what matched in the first part.
+    # Here we are using /e to incorporate the sequence number increment as a
+    # side effect of formatting the number before replacement in the string.
+    #
+    # $seq is post-incremented, so that the counter starts at 0.
+    #
+    # Increment the $seq variable, using sprintf(%02d) to get a two-digit
+    # number with leading zero.  If it overflows past 99, wrap around to 00.
+    my $seq = 0;
+    return map { (my $n = $_) =~ s/^../sprintf("%02d", $seq++ % 100)/e; $n } @list;
+    # return map { $_ =~ s/^../sprintf("%02d", $seq++ % 100)/e; $_ } @list;
+
+    # Alternative in two steps, remove the prefix and insert the sequence
+    # Does not modify the original list.
+    # return map { sprintf("%02d$_", ($seq++ % 100)) } map { substr($_, 2) } @list;
+
+    # Using Perl to write C. This modifies the original list.
+    # for ( my $i = 0 ; $i <= $#list ; $i++ )
+    # {
+    #     my $seq = sprintf("%02d", $i%100);
+    #     $list[$i] = $seq . substr($list[$i], 2);
+    # }
+    # return @list;
+}
+
+
+sub runTest
+{
+    use Test2::V0;
+
+    my @output;
+    @output = seqNum('ab1234', 'cd5678', 'ef1342');
+    is( \@output,  [ '001234', '015678', '021342' ], "Example 1");
+    @output = seqNum('pq1122', 'rs3334');
+    is( \@output,  [ '001122', '013334' ],           "Example 2");
+
+    done_testing;
+}
diff --git a/challenge-184/bob-lied/perl/ch-2.pl b/challenge-184/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..bccc237400
--- /dev/null
+++ b/challenge-184/bob-lied/perl/ch-2.pl
@@ -0,0 +1,106 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge Week 184 Task 2 Split Array
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given list of strings containing 0-9 and a-z separated by space only.
+# Write a script to split the data into two arrays, one for integers and one
+# for alphabets only.
+# Example 1 Input: @list = ( 'a 1 2 b 0', '3 c 4 d')
+#          Output: [[1,2,0], [3,4]] and [['a','b'], ['c','d']]
+# Example 2 Input: @list = ( '1 2', 'p q r', 's 3', '4 5 t')
+#          Output: [[1,2], [3], [4,5]] and [['p','q','r'], ['s'], ['t']]
+#=============================================================================
+
+use v5.36;
+
+use constant NUMBER => 0;
+use constant LETTER => 1;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+# Use this module to show output of nested array references.
+# Doesn't exactly match the spec because it quotes numbers
+# and has no white space.
+use Data::Dumper;
+$Data::Dumper::Indent = 0;
+$Data::Dumper::Terse = 1;
+
+my $numLet = splitArray(@ARGV);
+say Dumper($numLet->[NUMBER]), ' and ', Dumper($numLet->[LETTER]);
+
+# Input is an array of strings.
+sub splitArray(@array)
+{
+    # Split each string into an array of digits and letters.
+    # Use _splitList to turn each string in the array into a pair of lists.
+    # The result is an array of pairs, where each pair contains two
+    # array references, [NUMBER] for numbers and [LETTER] for letters.
+    my @nlListPair = map { _splitList( split(' ', $_) ) } @array;
+
+    # This array will be our result.
+    my @numberLetter = ( [], [] );
+
+    for my $p ( @nlListPair )
+    {
+        # Notice that Example 2 implies that an empty list should be removed
+        # from the output. [1,2] has no letters and [p q r] has no numbers,
+        # but there are no corresponding empty lists in the output.
+        for my $type ( NUMBER, LETTER )
+        {
+            my $list = $p->[$type];
+            push @{$numberLetter[$type]}, $list if scalar(@$list);
+        }
+    }
+    return \@numberLetter;
+}
+
+# Given a list of digits and letters, partition the list into
+# an array of numbers and an array of letters.  Returns a reference
+# to a pair of arrays where the first element is a list of numbers
+# and the second element is a list of letters.
+# Example: ('a', 1, 'x', 3) ==> [ [1,3], ['a','x'] ]
+sub _splitList(@list)
+{
+    my @numberLetter = ( [], [] );
+
+    for ( @list )
+    {
+        my $which = (m/\d/ ? NUMBER : LETTER);
+        push @{$numberLetter[$which]}, $_;
+    }
+
+    return \@numberLetter;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( _splitList( qw(a 1 2 b 0) ), [[1,2,0], ['a','b'    ]], 'Split a 1 2 b 0');
+    is( _splitList( qw(3 c 4 d  ) ), [[3,4  ], ['c','d'    ]], 'Split 3 c 4 d');
+    is( _splitList( qw(1 2      ) ), [[1,2  ], [           ]], 'Split 1 2');
+    is( _splitList( qw(p q r    ) ), [[     ], ['p','q','r']], 'Split p q r');
+    is( _splitList( qw(s 3      ) ), [[3    ], ['s'        ]], 'Split s 3');
+    is( _splitList( qw(4 5 t    ) ), [[4,5  ], ['t'        ]], 'Split 3 c 4 d');
+
+    is( splitArray( 'a 1 2 b 0', '3 c 4 d' ),
+                    [ [[1,2,0], [3,4]], [['a','b'], ['c','d']] ], 'Example 1');
+    is( splitArray( '1 2', 'p q r', 's 3', '4 5 t' ),
+                    [ [[1,2], [3], [4,5]], [['p','q','r'], ['s'], ['t']] ], 'Example 2');
+
+    is( splitArray( '1 2', '3 4', '5 6' ),
+                    [ [[1,2], [3,4], [5,6]], [] ], 'No letters');
+    is( splitArray( 'a b', 'c d' ),
+                    [ [] , [['a','b'], ['c','d']] ], 'No numbers');
+
+    done_testing;
+}
+
diff --git a/challenge-185/bob-lied/README b/challenge-185/bob-lied/README
index c231e3a589..1767a6db3c 100644
--- a/challenge-185/bob-lied/README
+++ b/challenge-185/bob-lied/README
@@ -1,3 +1,3 @@
-Solutions to weekly challenge 138 by Bob Lied
+Solutions to weekly challenge 185 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-138/
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-185/
diff --git a/challenge-185/bob-lied/perl/ch-1.pl b/challenge-185/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..949ef39993
--- /dev/null
+++ b/challenge-185/bob-lied/perl/ch-1.pl
@@ -0,0 +1,51 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge Week 185 Task 1 Mac Address
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given MAC address in the form i.e. hhhh.hhhh.hhhh.
+# Write a script to convert the address in the form hh:hh:hh:hh:hh:hh.
+# Example 1 Input:  1ac2.34f0.b1c2 Output: 1a:c2:34:f0:b1:c2
+# Example 2 Input:  abc1.20f1.345a Output: ab:c1:20:f1:34:5a
+#=============================================================================
+
+use v5.36;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+for ( @ARGV )
+{
+    if ( ! m/[[:xdigit:]]{4}\.[[:xdigit:]]{4}\.[[:xdigit:]]{4}/ )
+    {
+        warn "Format error in '$_', use xxxx.yyyy.zzzz where x, y and z are hex digits";
+        next;
+    }
+    say macAddr($_);
+}
+
+sub macAddr($m)
+{
+    # Match pairs of hex digits and return all of them as an array,
+    # Map any uppercase characters to lowercase
+    # then join the pairs with a colon
+    return join ":", map { lc } ($m =~ m/([[:xdigit:]]{2})/g) ;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( macAddr("1ac2.34f0.b1c2"), "1a:c2:34:f0:b1:c2", "Example 1");
+    is( macAddr("abc1.20f1.345a"), "ab:c1:20:f1:34:5a", "Example 2");
+    is( macAddr("ABC1.20F1.345A"), "ab:c1:20:f1:34:5a", "Uppercase");
+
+    done_testing;
+}
+
diff --git a/challenge-185/bob-lied/perl/ch-2.pl b/challenge-185/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..47199dfb05
--- /dev/null
+++ b/challenge-185/bob-lied/perl/ch-2.pl
@@ -0,0 +1,76 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge Week 185 Task 2 Mask Code
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given a list of codes in many random format.
+# Write a script to mask first four characters (a-z,0-9) and keep the rest
+# as it is.
+# Example 1
+#   Input: @list = ('ab-cde-123', '123.abc.420', '3abc-0010.xy')
+#  Output: ('xx-xxe-123', 'xxx.xbc.420', 'xxxx-0010.xy')
+# Example 2
+#   Input: @list = ('1234567.a', 'a-1234-bc', 'a.b.c.d.e.f')
+#  Output: ('xxxx567.a', 'x-xxx4-bc', 'x.x.x.x.e.f')
+#=============================================================================
+
+use v5.36;
+
+use constant MAXREPLACE => 4;
+my $TOREPLACE = qr([a-z0-9]);
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+if ( @ARGV )
+{
+    say "(", join(', ', maskCode(@ARGV) ), ")";
+}
+else
+{
+    my @list;
+    @list = ('ab-cde-123', '123.abc.420', '3abc-0010.xy');
+    say "(", join(', ', maskCode(@list) ), ")";
+    @list = ('1234567.a', 'a-1234-bc', 'a.b.c.d.e.f');
+    say "(", join(', ', maskCode(@list) ), ")";
+}
+
+sub maskCode(@list) { map { _mask($_, 4) } @list }
+
+sub _mask($s, $max=MAXREPLACE)
+{
+    my $t = $s;
+    # Use /g to loop over matches, setting pos each time
+    while ( $s =~ m/$TOREPLACE/g && $max-- )
+    {
+        # This would reset pos for $s, so operate on t instead
+        substr($t, pos($s)-1, 1) = 'x';
+        say " AFTER: '$s' pos=", pos($s), "'$t'" if $Verbose;
+    }
+    return $t;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( _mask('ab-cde-123'   ), 'xx-xxe-123',   "Example 1-a");
+    is( _mask('123.abc.420'  ), 'xxx.xbc.420',  "Example 1-b");
+    is( _mask('3abc-0010.xy' ), 'xxxx-0010.xy', "Example 1-c");
+    is( _mask('1234567.a'    ), 'xxxx567.a',    "Example 2-a");
+    is( _mask('a-1234-bc'    ), 'x-xxx4-bc',    "Example 2-b");
+    is( _mask('a.b.c.d.e.f'  ), 'x.x.x.x.e.f',  "Example 2-c");
+    is( _mask('GHI1234MNO'   ), 'GHIxxxxMNO',   "Middle");
+    is( _mask('a12--'        ), 'xxx--',        "Less than 4");
+    is( _mask(''             ), '',             "Empty string");
+    is( _mask('.....'        ), '.....',        "None");
+
+    done_testing;
+}
+