Merge pull request #8458 from MatthiasMuth/muthm-226

Challenge 226 solutions in Perl by Matthias Muth

6 files changed, 437 insertions, 93 deletions

diff --git a/challenge-226/matthias-muth/README.md b/challenge-226/matthias-muth/README.md
index 698cef7834..10e2b5a59d 100644
--- a/challenge-226/matthias-muth/README.md
+++ b/challenge-226/matthias-muth/README.md
@@ -1,120 +1,140 @@
-# Reduce to the max
-**Challenge 225 solutions in Perl by Matthias Muth**
+# The Zero Shuffle
+**Challenge 226 solutions in Perl by Matthias Muth**
 
-The tasks of this challenge are good ones,
-in the sense that the solutions can be short, nice, well-arranged, clear -- perly!
+## Task 1: Shuffle String
 
-However the second task took me some time to understand what really is happening
-in the task description and in the examples.
-
-But let's start with the first one:
-
-## Task 1: Max Words
-
-> You are given a list of sentences, @list.<br/>
-> A sentence is a list of words that are separated by a single space with no leading or trailing spaces.<br/>
-> Write a script to find out the maximum number of words that appear in a single sentence.<br/>
-> <br/>
+> You are given a string and an array of indices of same length as string.<br/>
+> Write a script to return the string after re-arranging the indices in the correct order.<br/>
 > Example 1<br/>
-> Input: @list = (qw/Perl and Raku belong to the same family./,<br/>
->                 qw/I love Perl./,<br/>
->                 qw/The Perl and Raku Conference./)<br/>
-> Output: 8<br/>
+> <br/>
+> Input: $string = 'lacelengh', @indices = (3,2,0,5,4,8,6,7,1)<br/>
+> Output: 'challenge'<br/>
 > <br/>
 > Example 2<br/>
-> Input: @list = (qw/The Weekly Challenge./,<br/>
->                 qw/Python is the most popular guest language./,<br/>
->                 qw/Team PWC has over 300 members./)<br/>
-> Output: 7<br/>
-
-Perl in its own realm.<br/>
-So short that it probably needs some explanations...
+> Input: $string = 'rulepark', @indices = (4,7,3,1,0,5,2,6)<br/>
+> Output: 'perlraku'<br/>
 
-We get a list of strings, each one containing one sentence.
-
-So let's split up each sentence into 'words' using `split " ", $_`,
-getting our `$_` from using `map` walking us through the list of sentences.
+It took me a moment to understand
+that the array of indices is not where the letters *come from*,
+but where the letters *go to*. <br/>
+So we could write something like this for a `$result` string:
+```perl
+    my $result = " " x $#{$indices};    # We need to initialize the full length.
+    substr( $result, $indices->[$_], 1 ) = substr( $string, $_, 1 )
+        for 0..$#{$indices};
+```
+or this for a `@result` array:
+```perl
+    my @results;
+    $results[ $indices->[$_] ] = substr( $string, $_, 1 )
+        for 0..$#{$indices};
+```
 
-The number of words in each sentence is `scalar` of the list of words that we just got.
+But of course there is more than one way to do it. :-)<br/>
+For example, we can switch from manipulating things one by one,
+and work with whole lists instead.
+Most often this results in shorter, more 'elegant' code,
+because it is less cluttered with all the details needed just to do things repeatedly.
+That's why very often this makes the code easier to understand.
 
-And `max(...)` (from `List::Util`) gets us the largest one.
+For making the letters from the string available as a list,
+we can use the common Perl idiom
+```perl
+    $string =~ /./g
+```
+or we can use the also very common (and faster) 
+```perl
+    split //, $string
+```
 
-Voilà!
+For assigning the letters to the result array,
+Perl has the wonderful array slice syntax,
+that can not only retrieve selected parts of an array or list,
+but also assign to selected elements of an array, even in random order.
+Exactly what we need!
 
+So actually we can
+assign the letters to the given indexes
+with just one assigment,
+and solve the whole task with three lines of code.<br/>
 ```perl
-use List::Util qw( max );
+use v5.36;
 
-sub max_words {
-    my ( @list ) = @_;
-    return max( map { scalar split " ", $_ } @list );
+sub shuffle_string( $string, $indices ) {
+    my @results;
+    @results[ @$indices ] = split //, $string;
+    return join "", @results;
 }
 ```
+And no loop, and no typo-prone `$#{$indices}`!
 
-## Task 2: Left Right Sum Diff
-
-> You are given an array of integers, @ints.<br/>
-> Write a script to return left right sum diff array as shown below:<br/>
-> @ints = (a, b, c, d, e)<br/>
-> @left  = (0, a, (a+b), (a+b+c))<br/>
-> @right = ((c+d+e), (d+e), e, 0)<br/>
-> @left_right_sum_diff = ( | 0 - (c+d+e) |,<br/>
->                          | a - (d+e)   |,<br/>
->                          | (a+b) - e   |,<br/>
->                          | (a+b+c) - 0 | )<br/>
+## Task 2: Zero Array
+
+> You are given an array of non-negative integers, @ints.<br/>
+> Write a script to return the minimum number of operations to make every element equal zero.<br/>
+> In each operation, you are required to pick a positive number less than or equal to the smallest element in the array, then subtract that from each positive element in the array.<br/>
 > <br/>
 > Example 1:<br/>
-> Input: @ints = (10, 4, 8, 3)<br/>
-> Output: (15, 1, 11, 22)<br/>
-> @left  = (0, 10, 14, 22)<br/>
-> @right = (15, 11, 3, 0)<br/>
-> @left_right_sum_diff = ( |0-15|, |10-11|, |14-3|, |22-0|)<br/>
->                      = (15, 1, 11, 22)<br/>
+> Input: @ints = (1, 5, 0, 3, 5)<br/>
+> Output: 3<br/>
+> operation 1: pick 1 => (0, 4, 0, 2, 4)<br/>
+> operation 2: pick 2 => (0, 2, 0, 0, 2)<br/>
+> operation 3: pick 2 => (0, 0, 0, 0, 0)<br/>
 > <br/>
 > Example 2:<br/>
-> Input: @ints = (1)<br/>
-> Output: (0)<br/>
-> @left  = (0)<br/>
-> @right = (0)<br/>
-> @left_right_sum_diff = ( |0-0| ) = (0)<br/>
+> Input: @ints = (0)<br/>
+> Output: 0<br/>
 > <br/>
 > Example 3:<br/>
-> Input: @ints = (1, 2, 3, 4, 5)<br/>
-> Output: (14, 11, 6, 1, 19)<br/>
-> @left  = (0, 1, 3, 6, 10)<br/>
-> @right = (14, 12, 9, 5, 0)<br/>
-> @left_right_sum_diff = ( |0-14|, |1-12|, |3-9|, |6-5|, |10-0|)<br/>
->                      = (14, 11, 6, 1, 10)<br/>
-
-Maybe I don't fully understand the definition,
-but for me, there seems to be a little inconsistency between the definition and the examples.
-In the definiton we have 5 elements as input, but only 4 elements in the left and right sums,
-whereas all the examples are explained using arrays of left and right sums
-that have the same number of elements as the input array.<br/>
-I decided in favor of the examples. :-)
-
-For this task, I completely avoided writing any for loops,
-and based my solution on list-processing functions:
-* `reductions` from `List::Util` does the summing up of the 'left' sum,
-starting with a 0 and going through all input elements except the last one (to get the correct number of elements),
-* `reductions` from `List::Util` also does the summing up of the 'right' sum,
-starting with a 0 and going through the input elements *in reverse order*,
-leaving out the first element, and then doing another `reverse` to have the 0 at the end of the list,
-* `pairwise` from the `List::MoreUtils` module from CPAN then builds the list of differences
-between corresponding elements of the 'left' and 'right' arrays.
- 
-So actually the task can be solved using three lines of actual code:
+> Input: @ints = (2, 1, 4, 0, 3)<br/>
+> Output: 4<br/>
+> operation 1: pick 1 => (1, 0, 3, 0, 2)<br/>
+> operation 2: pick 1 => (0, 0, 2, 0, 1)<br/>
+> operation 3: pick 1 => (0, 0, 1, 0, 0)<br/>
+> operation 4: pick 1 => (0, 0, 0, 0, 0)<br/>
+
+This task can be made a lot easier by a 'transformation'.<br/>
+We transform the task itself. :-)
+
+I tried to visualize what actually happens when we do the subtractions
+that are described in the text.<br/>
+I imagined all the numbers in a coordinate system.
+The *x* axis corresponds to the indices,
+and the *y* coordinate for each number is the number itself.<br/>
+Like this, for Example 1:
+```
+@ints:              1  5  0  3  5
+                    |  |  |  |  | 
+  5 ................|. 5 .|..|. 5 .........
+  4                 |     |  |
+  3 ................|.....|. 3 ............
+  2                 |     |
+  1 ............... 1 ....|................
+  0 _____________________ 0 _______________
+index:              0  1  2  3  4
+```
+Everytime we do the subtraction to all positive numbers, we kind of 'cut away'
+a horizontal slice of the diagram.<br/>
+Of course, we get the minimum number of operations
+when we cut only where there are numbers (at the dotted lines), not in between.
 
-```perl
-use feature 'signatures';
-no warnings 'experimental::signatures';
+In the diagram we see that we need to cut once for each unique number in the array,
+and we don't need to cut on the zero line, even if there may be numbers that are zero.
+
+So actually, as we only need to return the *number* of operations needed,
+and don't need to really execute them, our job is much easier:<br/>
+
+> You are given an array of non-negative integers, @ints.<br/>
+> Find the number of unique, non-zero numbers in the input array.<br/>
 
-use List::Util qw( reductions );
-use List::MoreUtils qw( pairwise );
+Oh! How easy!
+
+```perl
+use v5.36;
+use List::Util qw( uniq );
 
-sub left_right_sum_diff( @ints ) {
-    my @left  = reductions { $a + $b } 0, @ints[ 0 .. $#ints - 1 ];
-    my @right = reverse reductions { $a + $b } 0, reverse @ints[ 1 .. $#ints ];
-    return pairwise { abs( $a - $b ) } @left, @right
+sub zero_array( @ints ) {
+    return scalar uniq grep $_ != 0, @ints;
 }
 ```
 
diff --git a/challenge-226/matthias-muth/blog.txt b/challenge-226/matthias-muth/blog.txt
new file mode 100644
index 0000000000..cf8a1bb86d
--- /dev/null
+++ b/challenge-226/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-226/challenge-226/matthias-muth#readme
diff --git a/challenge-226/matthias-muth/perl/TestExtractor.pm b/challenge-226/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..4d6fa53893
--- /dev/null
+++ b/challenge-226/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,226 @@
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       The Test Data Extraction Machine (tm).
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+package TestExtractor;
+use Exporter 'import';
+our @EXPORT = qw( run_tests $verbose %options vsay pp np );
+
+use Data::Dump qw( pp );
+use Data::Printer;
+use Getopt::Long;
+use Cwd qw( abs_path );
+use File::Basename;
+use List::Util qw( any );
+use Test2::V0;
+no warnings 'experimental::signatures';
+
+our ( $verbose, %options );
+sub vsay { say @_ if $verbose };
+
+sub run_tests {
+
+    $| = 1;
+
+    GetOptions(
+        "v|verbose!" => \$verbose,
+    ) or do { say "usage!"; exit 2 };
+
+    my $dir = dirname abs_path $0;
+    my ( $challenge, $task ) =
+        abs_path( $0 ) =~ m{challenge-(\d+) .* (\d+)[^[/\\]*$}x;
+    unless ( $challenge && $task ) {
+        say STDERR "ERROR: ",
+            "Cannot determine challenge number or task number. Exiting.";
+        exit 1;
+    }
+
+    my $local_tests;
+    ( undef, $local_tests ) = read_task( *::DATA )
+	if fileno *::DATA;
+
+    my ( $task_title, $task_description ) =
+        read_task( "$dir/challenge-${challenge}.txt", $task );
+	# vsay $task_title;
+
+    my @tests = (
+        $local_tests      ? extract_tests( $local_tests )      : (),
+	$task_description ? extract_tests( $task_description ) : (),
+    );
+    # vsay pp( @tests );
+
+    ( my $sub_name = lc $task_title ) =~ s/\W+/_/g;
+    my $sub = \&{"::$sub_name"};
+
+    do {
+        my @input_params =
+	    @{$_->{INPUT}} == 1
+	    ? ( ref $_->{INPUT}[0] eq 'ARRAY'
+		&& ! grep( ref $_, @{$_->{INPUT}[0]} ) )
+		? @{$_->{INPUT}[0]}
+		: $_->{INPUT}[0]
+	    : @{$_->{INPUT}};
+	my $expected = $_->{OUTPUT};
+	my $diag =
+	    "$sub_name( " . pp( @input_params ) . " ) "
+	    . ( ( @$expected == 1 && $expected->[0] =~ /^(?:(true)|false)/ )
+	        ? "is $expected->[0]"
+		: ( "== " . pp( @{$_->{OUTPUT}} ) ) );
+
+	my $name = "$_->{TEST}";
+	$name .= ": $diag"
+	    if $_->{TEST} =~ /^(Test|Example)\s+\d+$/;
+	$diag = "test: $diag";
+
+	my @output = $sub->( @input_params );
+
+	if ( @$expected == 1 && $expected->[0] =~ /^(?:(true)|false)/ ) {
+	    ok $1 ? $output[0] : ! $output[0], $name, $diag // ();
+	}
+	else {
+	    is \@output, $expected, $name, $diag // ();
+	}
+
+        vsay "";
+
+    } for @tests;
+
+    done_testing;
+}
+
+sub read_task( $fd_or_filename, $wanted_task = undef ) {
+
+    my $fd;
+    if ( ref \$fd_or_filename eq 'SCALAR' ) {
+        open $fd, "<", $fd_or_filename
+            or die "ERROR: cannot open '$fd_or_filename': $!\n";
+    }
+    else {
+        # non-SCALARs, like __DATA__ GLOB.
+        $fd = $fd_or_filename;
+    }
+
+    my ( $task, $task_title, $task_text ) = ( -1, undef );
+    while ( <$fd> ) {
+        /^Task (\d+):\s*(.*?)\s*$/ and do {
+            $task = $1;
+            $task_title = $2
+                if $wanted_task && $task == $wanted_task;
+            next;
+        };
+
+        next
+            if $wanted_task && $task != $wanted_task;
+
+	$task_text .= $_;
+    }
+
+    return $task_title, $task_text;
+}
+
+sub extract_tests( $task_text ) {
+    # vsay "extract_tests( ", pp( $task_text ), " )";
+
+    # These regular expressions are used for extracting input or output
+    # test data.
+    my $var_name      = qr/ [\@\$]\w+ /x;
+    my $literal       = qr/ ".*?" | '.*?' | [+-]?\d+ | undef /x;
+    my $bracketed     = qr/ \[ [^\[]*? \] /xs;
+    my $parenthesized = qr/ \( [^\[]*? \) /xs;
+    my $entry         = qr/ $literal | $bracketed | $parenthesized /x;
+    my $list          = qr/ $entry (?: \s*,\s* $entry )* \s*,? /xs;
+
+    # The combination of what we expect as input or output data.
+    # Capture unparenthesized lists for special handling.
+    my $data_re = qr/ (?<lit>      $literal )
+		    | (?<br_list>     \[ \s* (?:$list)? \s* \] )
+		    | (?<par_list>    \( \s* (?:$list)? \s* \) )
+		    | (?<no_paren> $list ) /x;
+
+    my @tests;
+    while ( $task_text =~
+	/^((?:Example|Test).*?)\s*:?\s*$ .*?
+	    ^Input: \s* ( .*? ) \s*
+	    ^Output: \s* ( .*? ) \s*? (?=(?: ^$ | ^\S | \Z ))
+	/xmsg )
+    {
+	my ( $test, $input, $output) = ( $1, $2, $3 );
+
+	push @tests, { TEST => $test };
+
+	for ( $input, $output ) {
+	    # To avoid misinterpretations of '@' or '$' when the data is
+	    # 'eval'ed, we turn all double quotes into single quotes.
+	    s/\"/'/g;
+
+	    # We convert 'barewords' into quoted strings.
+	    # We search for these patterns, but we just skip them without
+	    # changing them:
+	    #  * 'Input:', 'Output:' at the beginning of the string,
+	    #  * quoted strings,
+	    #  * variable names having a $ or @ sigil.
+	    # After we are sure it's none of those, we also check unquoted
+	    # 'barewords' (here: combinations of letters, digits or underscores,
+	    # starting with a letter) and enclose them in single quotes.
+	    my $bareword = qr/ \b (?!undef) [a-z_][a-z0-9_]* \b /ix;
+	    while ( / ^Input: | ^Output: | '.*?' | [\$\@]$bareword
+		    | ( $bareword ) /xg )
+	    {
+		if ( $1 ) {
+		    my $p = pos();
+		    substr $_, $p - length( $1 ), length( $1 ), "'$1'";
+		    pos = $p + 2;
+		}
+	    }
+
+	    # As all arrays will be stored as array references, so we just
+	    # convert parentheses (...) to angle brackets [...].
+	    # s/\(/\[/g;
+	    # s/\)/\]/g;
+
+	    # Add missing commas between literals.
+	    while ( s/($literal)\s+($literal)/$1, $2/ ) {}
+	}
+
+	while ( $input =~ / ($var_name) \s* = \s* ($data_re) /xg ) {
+	    push @{$tests[-1]{VARIABLE_NAMES}}, $1;
+	    push @{$tests[-1]{INPUT}},
+		eval( ( $+{no_paren} || $+{par_list} ) ? "[ $2 ]" : $2 );
+        };
+
+	while ( $output =~ /^\s* ($data_re) $/xg ) {
+	    local $_ = $1;
+	    # vsay "\$_: <$_>";
+	    # Special case:  (1,2),(3,4),(5,6)
+	    # should become: [1,2],[3,4],[5,6] ]
+	    if ( $+{no_paren} && /$parenthesized/ ) {
+		# vsay "found special case <$_>";
+		s/\(/\[/g;
+		s/\)/\]/g;
+	    }
+	    push @{$tests[-1]{OUTPUT}},
+		eval( $+{no_paren} ? "( $_ )" : $_ );
+        };
+    }
+
+    # Use array refs for all OUTPUT lists if at least one of tests does.
+    if ( any { ref $_->{OUTPUT}[0] } @tests ) {
+	$_->{OUTPUT} = [ $_->{OUTPUT} ]
+	    for grep { ! ref $_->{OUTPUT}[0] } @tests;
+    }
+
+    return @tests;
+}
+
+1;
diff --git a/challenge-226/matthias-muth/perl/ch-1.pl b/challenge-226/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..07c6e772d0
--- /dev/null
+++ b/challenge-226/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 226 Task 1: Shuffle String
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use lib '.';
+use TestExtractor;
+
+sub shuffle_string( $string, $indices ) {
+    my @results;
+    @results[ @$indices ] = split //, $string;
+    return join "", @results;
+}
+
+run_tests;
diff --git a/challenge-226/matthias-muth/perl/ch-2.pl b/challenge-226/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..36e5549ea1
--- /dev/null
+++ b/challenge-226/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 226 Task 2: Zero Array
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( uniq );
+
+sub zero_array( @ints ) {
+    return scalar uniq grep $_ != 0, @ints;
+}
+
+run_tests;
diff --git a/challenge-226/matthias-muth/perl/challenge-226.txt b/challenge-226/matthias-muth/perl/challenge-226.txt
new file mode 100644
index 0000000000..06e5b4f860
--- /dev/null
+++ b/challenge-226/matthias-muth/perl/challenge-226.txt
@@ -0,0 +1,53 @@
+The Weekly Challenge - 226
+Monday, Jul 17, 2023
+
+
+Task 1: Shuffle String
+Submitted by: Mohammad S Anwar
+
+You are given a string and an array of indices of same length as string.
+Write a script to return the string after re-arranging the indices in the correct order.
+Example 1
+
+Input: $string = 'lacelengh', @indices = (3,2,0,5,4,8,6,7,1)
+Output: 'challenge'
+
+Example 2
+
+Input: $string = 'rulepark', @indices = (4,7,3,1,0,5,2,6)
+Output: 'perlraku'
+
+
+Task 2: Zero Array
+Submitted by: Mohammad S Anwar
+
+You are given an array of non-negative integers, @ints.
+Write a script to return the minimum number of operations to make every element equal zero.
+In each operation, you are required to pick a positive number less than or equal to the smallest element in the array, then subtract that from each positive element in the array.
+
+Example 1:
+
+Input: @ints = (1, 5, 0, 3, 5)
+Output: 3
+
+operation 1: pick 1 => (0, 4, 0, 2, 4)
+operation 2: pick 2 => (0, 2, 0, 0, 2)
+operation 3: pick 2 => (0, 0, 0, 0, 0)
+
+Example 2:
+
+Input: @ints = (0)
+Output: 0
+
+Example 3:
+
+Input: @ints = (2, 1, 4, 0, 3)
+Output: 4
+
+operation 1: pick 1 => (1, 0, 3, 0, 2)
+operation 2: pick 1 => (0, 0, 2, 0, 1)
+operation 3: pick 1 => (0, 0, 1, 0, 0)
+operation 4: pick 1 => (0, 0, 0, 0, 0)
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 23rd July 2023.