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

6 files changed, 313 insertions, 90 deletions

diff --git a/challenge-270/matthias-muth/README.md b/challenge-270/matthias-muth/README.md
index 6d58a3ad92..f081c83560 100644
--- a/challenge-270/matthias-muth/README.md
+++ b/challenge-270/matthias-muth/README.md
@@ -1,130 +1,247 @@
-# Perl Magic Games
+# Hidden loops. Or no loops at all.
 
-**Challenge 268 solutions in Perl by Matthias Muth**
+**Challenge 270 solutions in Perl by Matthias Muth**
 
-## Task 1: Magic Number
+For this week's first task, I did not use any loops.<br/>
+No `for`, `foreach` or `while`, or `until`.<br/>
+Am I slowly turning towards functional programming?<br/>
+Perl offers a lot of functions using 'lambda' expressions, aka 'code blocks', like `map`, `grep` or a lot of functions in `List::Util` or `List::MoreUtils`, and it is very natural to use them. This is perl, and There Is More Than One Way To DoIt.
+Actually, iterating over the elements is still done, 'but behind the scenes', so the loops are just hidden. But in my mind, this can often make the code more readable.
 
-> You are given two arrays of integers of same size, @x and @y.<br/>
-> Write a script to find the magic number that when added to each elements of one of the array gives the second array. Elements order is not important.<br/>
+For the second task I didn't use any loops at all, not even 'hidden' ones!<br/>
+I am happy to have found a solution where there is no actual need of doing any of the operations described.<br/>
+The overall result can be determined without.
+
+Read on ...
+
+## Task 1: Special Positions
+
+> You are given a m x n binary matrix.<br/>
+> Write a script to return the number of special positions in the given binary matrix.<br/>
+> A position (i, j) is called special if \$matrix[i][j] == 1 and all other elements in the row i and column j are 0.<br/>
 > <br/>
 > Example 1<br/>
-> Input: @x = (3, 7, 5)<br/>
->                @y = (9, 5, 7)<br/>
-> Output: 2<br/>
-> The magic number is 2.<br/>
-> @x = (3, 7, 5)<br/>
->    	\+ 2  2  2<br/>
-> @y = (5, 9, 7)<br/>
+> Input: \$matrix = [ [1, 0, 0],<br/>
+>                                 [0, 0, 1],<br/>
+>                                 [1, 0, 0],<br/>
+>                               ]<br/>
+> Output: 1<br/>
+> There is only special position (1, 2) as \$matrix[1][2] == 1<br/>
+> and all other elements in row 1 and column 2 are 0.<br/>
 > <br/>
 > Example 2<br/>
-> Input: @x = (1, 2, 1)<br/>
->                @y = (5, 4, 4)<br/>
-> Output: 3<br/>
-> The magic number is 3.<br/>
-> @x = (1, 2, 1)<br/>
->              \+  3  3  3<br/>
-> @y = (5, 4, 4)<br/>
-> <br/>
-> Example 3<br/>
-> Input: @x = (2)<br/>
->             @y = (5)<br/>
+> Input: \$matrix = [ [1, 0, 0],<br/>
+>                                   [0, 1, 0],<br/>
+>                                   [0, 0, 1],<br/>
+>                                 ]<br/>
 > Output: 3<br/>
+> Special positions are (0,0), (1, 1) and (2,2).<br/>
+
+As I said, there are no loops in my solution.
+That is, if you don't count the iterations done internally by `map`, `grep`, `any` and `zip` as loops.
+
+First, I extract only those rows that have exactly one non-zero element,
+using a `grep` (for the non-zero elements) within a grep (for exactly one of those):
 
-If we only could be sure that once we have a 'magic number', it will be the correct one for all the numbers in the two arrays! In that case, we would be done if we simply computed the difference of the two lowest numbers in each array!<br/>Very easy:
 ```perl
-use v5.36;
+    my @single_element_rows =
+        grep { ( scalar grep $_ != 0, $_->@* ) == 1 }
+            $matrix->@*;
+```
+Next, I flip the matrix to get column vectors.
+The `zip` function, applied to the rows of the matrix, results in a list of array-refs,
+each one containing one column's values.
+Very handy!
 
-use List::Util qw( min );
+Then, I determine the *indexes* of all columns that have exactly one non-zero element,
+same as above.
+```perl
+    my @columns = zip $matrix->@*;
+    my @single_element_columns_indexes =
+        grep { ( scalar grep $_ != 0, $columns[$_]->@* ) == 1 }
+            0..$#columns;
+```
+Having these, I can determine and return the count of single-element rows
+that happen to have a '1' in one of the single-element columns.
+If we find one, we are sure it will be the only one in that row,
+since we know that all rows that we look at have exactly one single non-zero element.
+```perl
+    return scalar grep {
+        my $row = $_;
+        any { $row->[$_] == 1 } @single_element_columns_indexes
+    } @single_element_rows;
+```
+So here is the complete solution (without comments, which are still there in the original code):
+```perl
+use v5.36;
 
-sub magic_number_short( $x, $y ) {
-    return min( $y->@* ) - min( $x->@* );
+use List::Util qw( any zip );
+
+sub special_positions( $matrix ) {
+    my @single_element_rows =
+        grep { ( scalar grep $_ != 0, $_->@* ) == 1 }
+            $matrix->@*;
+    my @columns = zip $matrix->@*;
+    my @single_element_columns_indexes =
+        grep { ( scalar grep $_ != 0, $columns[$_]->@* ) == 1 }
+            0..$#columns;
+    return scalar grep {
+        my $row = $_;
+        any { $row->[$_] == 1 } @single_element_columns_indexes
+    } @single_element_rows;
 }
 ```
 
-This works for all examples given, so there it is: a quite short solution for this task.
+## Task 2: Equalize Array
+
+> You are give an array of integers, @ints and two integers, \$x and \$y.<br/>
+> Write a script to execute one of the two options:<br/>
+> Level 1:<br/>
+> Pick an index i of the given array and do \$ints[i] += 1<br/>
+> Level 2:<br/>
+> Pick two different indices i,j and do \$ints[i] +=1 and \$ints[j] += 1.<br/>
+> <br/>
+> You are allowed to perform as many levels as you want to make every elements in the given array equal. There is cost attach for each level, for Level 1, the cost is \$x and \$y for Level 2.<br/>
+> In the end return the minimum cost to get the work done.<br/>
+> <br/>
+> Example 1<br/>
+> Input: @ints = (4, 1), \$x = 3 and \$y = 2<br/>
+> Output: 9<br/>
+> Level 1: i=1, so \$ints[1] += 1.<br/>
+> @ints = (4, 2)<br/>
+> Level 1: i=1, so \$ints[1] += 1.<br/>
+> @ints = (4, 3)<br/>
+> Level 1: i=1, so \$ints[1] += 1.<br/>
+> @ints = (4, 4)<br/>
+> We perforned operation Level 1, 3 times.<br/>
+> So the total cost would be 3 x \$x => 3 x 3 => 9<br/>
+> <br/>
+> Example 2<br/>
+> Input: @ints = (2, 3, 3, 3, 5), \$x = 2 and \$y = 1<br/>
+> Output: 6<br/>
+> Level 2: i=0, j=1, so \$ints[0] += 1 and \$ints[1] += 1<br/>
+> @ints = (3, 4, 3, 3, 5)<br/>
+> Level 2: i=0, j=2, so \$ints[0] += 1 and \$ints[2] += 1<br/>
+> @ints = (4, 4, 4, 3, 5)<br/>
+> Level 2: i=0, j=3, so \$ints[0] += 1 and \$ints[3] += 1<br/>
+> @ints = (5, 4, 4, 4, 5)<br/>
+> Level 2: i=1, j=2, so \$ints[1] += 1 and \$ints[2] += 1<br/>
+> @ints = (5, 5, 5, 4, 5)<br/>
+> Level 1: i=3, so \$ints[3] += 1<br/>
+> @ints = (5, 5, 5, 5, 5)<br/>
+> We perforned operation Level 1, 1 time and Level 2, 4 times.<br/>
+> So the total cost would be (1 x \$x) + (3 x \$y) => (1 x 2) + (4 x 1) => 6<br/>
+
+Now this is a task that needs a little thinking. Nice!!
 
-But we all know that life can be hard, and input data can be not what we expect.<br/>So actually we should do some checking, and only return the magic number if it's the correct difference for *all* the numbers in the two arrays. 
+The first thing I did for developing a concept for a possible solution is that I transformed the task, actually 'flipping around' what is to be done.<br/>
+I want to have an easy overview of how many operations I have to execute.
+So instead of filling the numbers up to the largest value,
+I create a 'to_do' array of numbers .
 
-So the longer solution is to sort the two arrays, and to compare all differences between corresponding pairs of numbers.
+For example, the input array ( 1, 4, 4, 4, 6 ) would result in a 'to_do' array of ( 5, 2, 2, 2, 0 ), and the '0' can be removed, so ( 5, 2, 2, 2 ).
+To visualize this:
 
-To compute those differences, I use the `zip` function (from `List::Util`) to join the two sorted arrays. This results in a list of references to two-element arrays, each containing one number from the first and one number from the second array. I then use `map` to turn the two numbers from each entry into their difference.
+<img src="https://github.com/MatthiasMuth/perlweeklychallenge-club/blob/muthm-270/challenge-270/matthias-muth/images/Screenshot%202024-05-26%20171318.png" />
 
-Once we have all differences, we can check whether all of them are the same as the first one (using `all`, also from `List::Util`), and if so, return this as our 'magic' number. If they are not all the same, we return `undef`, kind of 'extending the specification' because we are not told what should happen in that case.
+So what used to be increments towards the highest number in the array are now decrements towards zero.
+This makes computations and checking less complex.
 
-We also should deal with the edge case of empty input arrays, and also make sure that the two input arrays have the same number of elements. So we prepend a small input check, for not running into any 'undefined value' warnings in those cases.
+Now it's time to make some observations:
 
-I think the result still looks quite reasonable:
+- Doing one Level 2 two element decrements are only better than doing two Level 1 single decrement if its cost \$y is less than 2 times the Level 1 cost \$x.<br/>That means that if \$x is less than half of \$y, we can simply sum up all 'to_do' numbers , multiply it by $x, and this will be the best possible result:
 
-```perl
-use v5.36;
+  	cost = sum( to_do ) * $x1
 
-sub magic_number( $x, $y ) {
-    @$x && ( @$x == @$y )
-        or return undef;
-    my @diffs = map $_->[1] - $_->[0],
-        zip [ sort { $a <=> $b } $x->@* ],
-            [ sort { $a <=> $b } $y->@* ];
-    return
-        ( all { $_ == $diffs[0] } @diffs[1..$#diffs] )
-        ? $diffs[0]
-        : undef;
-}
-```
+- If we do Level 2 decrements, we need to be careful about where we do them. We might end up having a single column of elements to remove, where we will then only be able to use more costly Level 1 single removals.<br/>
+  So do we risk running into a full fledged optimization problem?
 
-## Task 2: Number Game
+Actually no, because we can distinguish two cases, which only depend on the largest number in the 'to_do' array, and determine the final result with just one formula for each of them:
 
-> You are given an array of integers, @ints, with even number of elements.<br/>
-> Write a script to create a new array made up of elements of the given array. Pick the two smallest integers and add it to new array in decreasing order i.e. high to low. Keep doing until the given array is empty.<br/>
-> <br/>
-> Example 1<br/>
-> Input: @ints = (2, 5, 3, 4)<br/>
-> Output: (3, 2, 5, 4)<br/>
-> Round 1: we picked (2, 3) and push it to the new array (3, 2)<br/>
-> Round 2: we picked the remaining (4, 5) and push it to the new array (5, 4)<br/>
-> <br/>
-> Example 2<br/>
-> Input: @ints = (9, 4, 1, 3, 6, 4, 6, 1)<br/>
-> Output: (1, 1, 4, 3, 6, 4, 9, 6)<br/>
-> <br/>
-> Example 3<br/>
-> Input: @ints = (1, 2, 2, 3)<br/>
-> Output: (2, 1, 3, 2)<br/>
+1. <u>The largest number is larger than all other numbers combined.</u>
+
+    An example:
+
+    <img src="https://github.com/MatthiasMuth/perlweeklychallenge-club/blob/muthm-270/challenge-270/matthias-muth/images/Screenshot%202024-05-26%20174520.png" />
+
+    The largest number here is 6, and all other numbers together sum up to 4 (shaded in light green).<br/>
+    If we do Level 2 decrements that always decrement one from the largest number (shaded in light blue)
+    and one from one of the other numbers (no matter which one),
+    we remove all the elements shaded in light blue as well as those shaded in light green, and end up with some remaining elements in the largest number (shaded in light red). <br/>These remaining elements  have to be removed with more costly Level 1 decrements, there's no way to avoid that.
 
-This is one of the tasks where a bit of thinking about what really happens helps to find a nice and easy solution:
+    But we can compute the total cost in this situation:
 
-The instructions basically suggest to use a loop, where inside the loop we find the two smallest numbers in the array,
-remove them from the input array
-and add them -- in reversed order -- into the output array.
+    	cost = sum( other_numbers ) * $y + ( largest_number - sum( other_numbers) ) * $x
 
-I don't like searching within a loop body.<br/>
-Even if we might not run into a purely quadratic big O complexity just by searching
-(because we shorten the array after each iteration),
-destroying the input array just for that reason is not really elegant,
-and even if it takes only split-micro-seconds,
-I don't like wasting computing power for something like that.
+    We do not actually need to do all the operations for knowing that!
 
-The good thing is that we can achieve the same result
-by simply sorting the array numerically (with a typical complexity of $`O(n\log n)`$),
-and then flipping each pair of adjacent numbers
-(in one simple additional pass).<br/>
-Ah, much better ;-)
+2. <u>The largest number is not larger than all other numbers combined.</u>
 
-We even can do this 'on the fly',
-feeding the `sort` output into the `pairs` function (from `List::Util`),
-which splits the numbers into small two-element arrays,
-and then flipping the two numbers using `reverse` on each of those mini-arrays, using a `map` code block.
+   In this case, my algorithm to decrease all numbers to zero would be:
 
-Looks 'perlish' to me, and hey, another one-liner! Who would have guessed!   
+   * Repeatedly determine the largest and the second largest number<br/>and
+     decrement those using a Level 2 decrement,<br/>
+     until there is only one number with a value of '1' left, or no non-zero number at all. 
+   * If there is one number left, use a Level 1 single decrement to reduce it to zero, too. 
+   
+   I could not 'scientifically prove' that this algorithm works
+   for all constellation of numbers
+   (under the precondition for the largest number not to exceed the sum of the rest!),
+   but I did not find any constellation where it doesn't work.<br/>
+   I would be very interested if anyone found a counter-example!
+
+   But *if* the assumption is correct, again we can determine the total cost without actually doing the work!<br/>We do `int( sum( to_do ) / 2 )` Level 2 operations.<br/>
+   If the sum is odd, we have to add one Level 1 operation for the last single element.   
+   
+   So the cost is
+   
+    	cost = int( sum( to_do ) / 2 ) * $y + ( sum( to_do ) % 2 ) * $x
+
+Combining the three cases, the complete solution is much shorter than my description. Here, I left the comments in:
 
 ```perl
 use v5.36;
 
-use List::Util qw( pairs );
-
-sub number_game( @ints ) {
-    return map { reverse $_->@* } pairs sort { $a <=> $b } @ints;
+use List::Util qw( max sum );
+
+sub distribute_elements( $ints, $x, $y ) {
+    # Flip things around, creating an array of what we need to
+    # bring down to zero instead of moving everything up to the largest number.
+    # 
+    my $max = max( $ints->@* );
+    my @to_do = grep $_ != 0, map $max - $_, $ints->@*;
+    my $sum_to_do = sum( @to_do );
+
+    # If it is more costly to decrement two numbers using level 2 decrements
+    # than two times a level 1 decrement, we do everything with level 1.
+    return $sum_to_do * $x
+        if 2 * $x <= $y;
+
+    # If the largest number is greater than everything else together
+    # (without the largest number itself), we can do level 2 decrements
+    # to decrease the largest number and any one of the other numbers
+    # until there are no others anymore.
+    # What is left of the largest number after that, we need to remove using
+    # level 1 single decrements.
+    # As we know everything in advance, we can compute the total cost even
+    # without actually doing the operations.
+    my $largest = max( @to_do );
+    my $rest = $sum_to_do - $largest;
+    return $rest * $y + ( $largest - $rest ) * $x
+        if $largest > $rest;
+
+    # Here, we know that we have enough points in the other numbers to completely
+    # remove the largest one. I *ASSUME* that in this case, we *ALWAYS* can
+    # repeatedly decrement the largest and second largest of the remaining
+    # number, down to having nothing at all any more, or at most one single
+    # leftover 1.
+    # Using this assumption, we can again compute the cost without
+    # really looping through the decrements.
+    return int( $sum_to_do / 2 ) * $y + ( $sum_to_do % 2 ) * $x;
 }
 ```
 
+And loops? Not needed!
+
 #### **Thank you for the challenge!**
 
diff --git a/challenge-270/matthias-muth/blog.txt b/challenge-270/matthias-muth/blog.txt
new file mode 100644
index 0000000000..adc1f94a4e
--- /dev/null
+++ b/challenge-270/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-270/challenge-270/matthias-muth#readme
diff --git a/challenge-270/matthias-muth/images/Screenshot 2024-05-26 171318.png b/challenge-270/matthias-muth/images/Screenshot 2024-05-26 171318.png
new file mode 100644
index 0000000000..7288b6eb16
--- /dev/null
+++ b/challenge-270/matthias-muth/images/Screenshot 2024-05-26 171318.png
diff --git a/challenge-270/matthias-muth/images/Screenshot 2024-05-26 174520.png b/challenge-270/matthias-muth/images/Screenshot 2024-05-26 174520.png
new file mode 100644
index 0000000000..ef5a34b79f
--- /dev/null
+++ b/challenge-270/matthias-muth/images/Screenshot 2024-05-26 174520.png
diff --git a/challenge-270/matthias-muth/perl/ch-1.pl b/challenge-270/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..bf87d03db7
--- /dev/null
+++ b/challenge-270/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,44 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 270 Task 1: Special Positions
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use List::Util qw( any zip );
+
+sub special_positions( $matrix ) {
+    # Extract only those rows that have exactly one non-zero element.
+    my @single_element_rows =
+        grep { ( scalar grep $_ != 0, $_->@* ) == 1 }
+            $matrix->@*;
+    # Determine the indexes of all columns that have exactly one
+    # non-zero element, after flipping the matrix to get column
+    # vectors.
+    my @columns = zip $matrix->@*;
+    my @single_element_columns_indexes =
+        grep { ( scalar grep $_ != 0, $columns[$_]->@* ) == 1 }
+            0..$#columns;
+    # Return the count of those rows where we find a '1' in one of the
+    # single-element columns. If we find one, we are sure it will be
+    # the only one, since the rows that we look at all have one single
+    # element only.
+    return scalar grep {
+        my $row = $_;
+        any { $row->[$_] == 1 } @single_element_columns_indexes
+    } @single_element_rows;
+}
+
+use Test2::V0 qw( -no_srand );
+is special_positions( [[0, 0, 0], [0, 0, 0], [0, 0, 0]] ), 0,
+    'Test 1: special_positions( [[0, 0, 0], [0, 0, 0], [0, 0, 0]] ) == 0';
+is special_positions( [[1, 0, 0], [0, 0, 1], [1, 0, 0]] ), 1,
+    'Example 1: special_positions( [[1, 0, 0], [0, 0, 1], [1, 0, 0]] ) == 1';
+is special_positions( [[1, 0, 0], [0, 1, 0], [0, 0, 1]] ), 3,
+    'Example 2: special_positions( [[1, 0, 0], [0, 1, 0], [0, 0, 1]] ) == 3';
+done_testing;
diff --git a/challenge-270/matthias-muth/perl/ch-2.pl b/challenge-270/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..1bfb9e897e
--- /dev/null
+++ b/challenge-270/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,61 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 270 Task 2: Distribute Elements
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use List::Util qw( max sum );
+
+sub distribute_elements( $ints, $x, $y ) {
+    # Flip things around, creating an array of what we need to
+    # bring down to zero instead of moving everything up to the largest number.
+    #
+    my $max = max( $ints->@* );
+    my @to_do = grep $_ != 0, map $max - $_, $ints->@*;
+    my $sum_to_do = sum( @to_do );
+
+    # If it is more costly to decrement two numbers using level 2 decrements
+    # than two times a level 1 decrement, we do everything with level 1.
+    return $sum_to_do * $x
+        if 2 * $x <= $y;
+
+    # If the largest number is greater than everything else together
+    # (without the largest number itself), we can do level 2 decrements
+    # to decrease the largest number and any one of the other numbers
+    # until there are no others anymore.
+    # What is left of the largest number after that, we need to remove using
+    # level 1 single decrements.
+    # As we know everything in advance, we can compute the total cost even
+    # without actually doing the operations.
+    my $largest = max( @to_do );
+    my $rest = $sum_to_do - $largest;
+    return $rest * $y + ( $largest - $rest ) * $x
+        if $largest > $rest;
+
+    # Here, we know that we have enough points in the other numbers to completely
+    # remove the largest one. I *ASSUME* that in this case, we *ALWAYS* can
+    # repeatedly decrement the largest and second largest of the remaining
+    # number, down to having nothing at all any more, or at most one single
+    # leftover 1.
+    # Using this assumption, we can again compute the cost without
+    # really looping through the decrements.
+    return int( $sum_to_do / 2 ) * $y + ( $sum_to_do % 2 ) * $x;
+}
+
+use Test2::V0 qw( -no_srand );
+is distribute_elements( [5, 4, 1], 100, 1 ), 301,
+    'Test 1: distribute_elements( [5, 4, 1], 100, 1 ) == 301';
+is distribute_elements( [4, 1], 3, 2 ), 9,
+    'Example 1: distribute_elements( [4, 1], 3, 2 ) == 9';
+is distribute_elements( [2, 3, 3, 3, 5], 2, 1 ), 6,
+    'Example 2: distribute_elements( [2, 3, 3, 3, 5], 2, 1 ) == 6';
+is distribute_elements( [ 1, 4, 4, 4, 6 ], 100, 1 ), 105,
+    'Test 2: distribute_elements( [ 1, 4, 4, 4, 6 ], 100, 1 ) == 105';
+
+done_testing;