Merge pull request #12833 from MatthiasMuth/muthm-342

Challenge 342 Task 1 and 2 solutions in Perl by Matthias Muth

3 files changed, 116 insertions, 165 deletions

diff --git a/challenge-342/matthias-muth/README.md b/challenge-342/matthias-muth/README.md
index 428c554463..0da0bf4f43 100644
--- a/challenge-342/matthias-muth/README.md
+++ b/challenge-342/matthias-muth/README.md
@@ -1,167 +1,5 @@
-# (Pre-)Fix what is Broken
-
-**Challenge 341 solutions in Perl by Matthias Muth**
-
-## Task 1: Broken Keyboard
-
-> You are given a string containing English letters only and also you are given broken keys.<br/>
-> Write a script to return the total words in the given sentence can be typed completely.
->
-> **Example 1**
->
-> ```text
-> Input: $str = 'Hello World', @keys = ('d')
-> Output: 1
->
-> With broken key 'd', we can only type the word 'Hello'.
-> ```
->
-> **Example 2**
->
-> ```text
-> Input: $str = 'apple banana cherry', @keys = ('a', 'e')
-> Output: 0
-> ```
->
-> **Example 3**
->
-> ```text
-> Input: $str = 'Coding is fun', @keys = ()
-> Output: 3
->
-> No keys broken.
-> ```
->
-> **Example 4**
->
-> ```text
-> Input: $str = 'The Weekly Challenge', @keys = ('a','b')
-> Output: 3
-> ```
->
-> **Example 5**
->
-> ```text
-> Input: $str = 'Perl and Python', @keys = ('p')
-> Output: 1
-> ```
-
-Perl's regular expressions help to find a concise solution for this task.<br/>But the main goal for me this time isn't shortness, it's readability.
-
-This could have been my short solution:
-
-```perl
-sub broken_keyboard_short_and_ugly( $str, $keys ) {
-    scalar grep ! $keys->@* || ! /[$keys->@*]/i, split " ", $str;
-}
-```
-
-(Assuming `use v5.36` or whatever you prefer for having  `strict`, `warnings`, and `feature signatures`.)
-
-Don't worry, there's no need to dive into it to see what it does. I will explain later for those who are curious.
-
-Here is my 'real' solution.<br/>
-This one is much clearer, I hope:
-
-```perl
-use v5.36;
-
-sub broken_keyboard( $str, $keys ) {
-    my @words = split " ", $str;
-    return scalar @words
-        if ! $keys->@*;
-    my $keys_concat = join "", $keys->@*;
-    return scalar grep ! /[$keys_concat]/i, @words;
-}
-```
-
-The concept is the same, only that this code can almost be read as its own description in English:
-
-* 
-  Split up the input string into words, using any amount of whitespace as separator<br/>(the `" "` special case for the `split` separator does that perfectly):<br/>
-  `    my @words = split " ", $str;`
-* Return the full number of words if there are no broken keys.<br/>
-  `    return scalar @words`<br/>`         if ! $keys->@*;`
-* Build a string with the concatenated broken key characters<br/>(we will see in the next step what that will be used for):<br/>
-  `     my $keys_concat = join "", $keys->@*;`
-* Return the count of words that do not(!) match a regular expression with a bracketed character class containing all broken keys, ignoring upper or lower case.<br/>
-  `    return scalar grep ! /[$keys_concat]/i, @words;`<br/>
-   (`grep` in scalar context returns the number of hits instead of the hits themselves.)
-
-There are chances that even I will understand what I wrote when I stumble over this code in a year or so...
-
-But just for the curious, here is what the 'short' version does.<br/>Basically the same thing just mapped into one single statement, but with a fews pitfalls:
-
-* For keeping the code short, the `grep` condition contains both cases of having broken keys or not.<br/>It is assumed that any word is a hit if there are no keys (`! $keys->@*`) or -- if there are -- the word does not match the regular expression containing the character class with the list of broken keys.<br/>Clearly, there is a runtime punishment for this. The check whether we have any broken keys is repeated for every word.
-* Watch out: In the regular expression, the *array* is interpolated into the character class (not a string, as in the other solution).<br/>This results in all array elements being put in, separated by space characters. Similar to using `"$keys->@*"` in double quoted strings.<br/>But that means that our character class also contains space characters. So actually we are not only looking for broken keys in the words, but also for space characters!<br/>
-  Good that we know there cannot be any...
-
-So to understand the code fully, the reader also has to understand these specialties. Any changes to the code can be surprising...
-
-This is why I didn't use my shortest solution for this task.<br/>I hope you agree.
-
-## Task 2: Reverse Prefix
-
-> You are given a string, \$str and a character in the given string, \$char.<br/>
-> Write a script to reverse the prefix upto the first occurrence of the given \$char in the given string \$str and return the new string.
->
-> **Example 1**
->
-> ```text
-> Input: $str = "programming", $char = "g"
-> Output: "gorpmming"
->
-> Reverse of prefix "prog" is "gorp".
-> ```
->
-> **Example 2**
->
-> ```text
-> Input: $str = "hello", $char = "h"
-> Output: "hello"
-> ```
->
-> **Example 3**
->
-> ```text
-> Input: $str = "abcdefghij", $char = "h"
-> Output: "hgfedcbaj"
-> ```
->
-> **Example 4**
->
-> ```text
-> Input: $str = "reverse", $char = "s"
-> Output: "srevere"
-> ```
->
-> **Example 5**
->
-> ```text
-> Input: $str = "perl", $char = "r"
-> Output: "repl"
-> ```
-
-Now this is the task where I fully promote a short solution!<br/>
-A single regular expression substitution is all that is needed:
-
-```perl
-use v5.36;
-
-sub reverse_prefix( $str, $char ) {
-    return $str =~ s<^.*?$char>{ reverse $& }er;
-}
-```
-
-Explanation?
-
-Everything from the beginning of the string up to and including the first `$char` character is matched:<br/>`     /^.*?$char/`<br/>The 'everything' match is 'non-greedy' (`.*?`), so that it stops when the first `$char` is found.
-
-The replacement for the prefix is generated with `reverse $&`. That's why the substitution part is an evaluated expression (code), using the `/e` flag.<br/>It's a habit of mine to put the code part into curly brackets when I use the `/e` flag, to make it more visible.<br/>
-I then use a pair of angle brackets for the first part.
-
-The `/r` flag returns the resulting string (instead of the number of matches found).<br/>That's the subroutine's return value, and that's all.
-
- This is Perl. Not everything short is bad! 
+**Challenge 342 solutions in Perl by Matthias Muth**
+<br/>
+(sorry, no blog post this time...)
 
 **Thank you for the challenge!**
diff --git a/challenge-342/matthias-muth/perl/ch-1.pl b/challenge-342/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..09883384c5
--- /dev/null
+++ b/challenge-342/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,62 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 342 Task 1: Balance String
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+use List::Util qw( mesh );
+
+# Equal number of letters and digits:
+#     start with the digits,
+#     because any digit sorts alphabetically lower than any letter.
+# One letter less than digits:
+#     start with the digits,
+#     append an empty string to letters to have an equal number of entries
+#     for `mesh`.
+# One digit less than letters
+#     the digits have to be 'inside' the letters,
+#     we can add an empty string before the digits,
+#     then we can still start with digits.
+
+sub balance_string_1( $str ) {
+    my @letters = sort $str =~ /[a-z]/g;
+    my @digits = sort $str =~ /\d/g;
+    return ""
+        unless abs( @digits - @letters ) <= 1;
+    return join "", mesh(
+        @digits < @letters ? [ "", @digits ]  : \@digits,
+        @digits > @letters ? [ @letters, "" ] : \@letters );
+}
+
+sub balance_string( $str ) {
+    my @letters = sort $str =~ /[a-z]/g;
+    my @digits  = sort $str =~ /\d/g;
+    return join "",
+        @letters == @digits
+            ? mesh \@digits, \@letters
+        : @digits == @letters + 1
+            ? ( shift @digits, mesh \@letters, \@digits )
+        : @letters == @digits + 1
+            ? ( shift @letters, mesh \@digits, \@letters )
+        : ();
+}
+
+use Test2::V0 qw( -no_srand );
+
+is balance_string( "a0b1c2" ), "0a1b2c",
+    'Example 1: balance_string( "a0b1c2" ) == "0a1b2c"';
+is balance_string( "abc12" ), "a1b2c",
+    'Example 2: balance_string( "abc12" ) == "a1b2c"';
+is balance_string( "0a2b1c3" ), "0a1b2c3",
+    'Example 3: balance_string( "0a2b1c3" ) == "0a1b2c3"';
+is balance_string( "1a23" ), "",
+    'Example 4: balance_string( "1a23" ) == ""';
+is balance_string( "ab123" ), "1a2b3",
+    'Example 5: balance_string( "ab123" ) == "1a2b3"';
+
+done_testing;
diff --git a/challenge-342/matthias-muth/perl/ch-2.pl b/challenge-342/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..86ff6ba9a9
--- /dev/null
+++ b/challenge-342/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,51 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 342 Task 2: Max Score
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use List::Util qw( reductions max );
+
+sub max_score( $str ) {
+    my @digits = split "", $str;
+    my @n_ones = reductions { $a + $b } @digits;
+    my $total_n_ones = $n_ones[-1];
+    my @scores = map {
+        ( $_ + 1 - $n_ones[$_] )                # Number of zeroes up to here
+            + ( $total_n_ones - $n_ones[$_] )   # Number of ones to the right
+    } keys @digits;
+    $scores[-1] = 0;
+    return max( @scores );
+}
+
+use Test2::V0 qw( -no_srand );
+
+is max_score( "00" ), 1,
+    'Test 1: max_score( "00" ) == 1';
+is max_score( "10" ), 0,
+    'Test 2: max_score( "10" ) == 0';
+is max_score( "01" ), 2,
+    'Test 3: max_score( "01" ) == 2';
+is max_score( "11" ), 1,
+    'Test 4: max_score( "11" ) == 1';
+is max_score( "1111" ), 3,
+    'Test 5: max_score( "1111" ) == 3';
+
+is max_score( "0011" ), 4,
+    'Example 1: max_score( "0011" ) == 4';
+is max_score( "0000" ), 3,
+    'Example 2: max_score( "0000" ) == 3';
+is max_score( 1111 ), 3,
+    'Example 3: max_score( 1111 ) == 3';
+is max_score( "0101" ), 3,
+    'Example 4: max_score( "0101" ) == 3';
+is max_score( "011101" ), 5,
+    'Example 5: max_score( "011101" ) == 5';
+
+done_testing;