From f127513fd798117c6bb340759e57d897c9dd6db1 Mon Sep 17 00:00:00 2001 From: Matthias Muth Date: Sun, 12 Oct 2025 22:02:38 +0200 Subject: Challenge 342 Task 1 and 2 solutions in Perl by Matthias Muth --- challenge-342/matthias-muth/README.md | 168 +------------------------------ challenge-342/matthias-muth/perl/ch-1.pl | 62 ++++++++++++ challenge-342/matthias-muth/perl/ch-2.pl | 51 ++++++++++ 3 files changed, 116 insertions(+), 165 deletions(-) create mode 100755 challenge-342/matthias-muth/perl/ch-1.pl create mode 100755 challenge-342/matthias-muth/perl/ch-2.pl 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.
-> 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.
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.
-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
(the `" "` special case for the `split` separator does that perfectly):
- ` my @words = split " ", $str;` -* Return the full number of words if there are no broken keys.
- ` return scalar @words`
` if ! $keys->@*;` -* Build a string with the concatenated broken key characters
(we will see in the next step what that will be used for):
- ` 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.
- ` return scalar grep ! /[$keys_concat]/i, @words;`
- (`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.
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.
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.
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).
This results in all array elements being put in, separated by space characters. Similar to using `"$keys->@*"` in double quoted strings.
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!
- 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.
I hope you agree. - -## Task 2: Reverse Prefix - -> You are given a string, \$str and a character in the given string, \$char.
-> 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!
-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:
` /^.*?$char/`
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.
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.
-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).
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** +
+(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; -- cgit