Merge pull request #12175 from MatthiasMuth/muthm-325

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

4 files changed, 156 insertions, 225 deletions

diff --git a/challenge-325/matthias-muth/README.md b/challenge-325/matthias-muth/README.md
index e662bafcee..75d3c14653 100644
--- a/challenge-325/matthias-muth/README.md
+++ b/challenge-325/matthias-muth/README.md
@@ -1,283 +1,149 @@
-# Reduce and Reduce, and Reduce!
+# Consecutive, but Maybe Not Final
 
-**Challenge 324 solutions in Perl by Matthias Muth**
+**Challenge 325 solutions in Perl by Matthias Muth**
 
-## Task 1: 2D Array
+## Task 1: Consecutive One
 
-> You are given an array of integers and two integers \$r and \$c.<br/>
-> Write a script to create two dimension array having \$r rows and \$c columns using the given array.
+> You are given a binary array containing only 0 or/and 1.<br/>
+> Write a script to find out the maximum consecutive 1 in the given array.
 >
 > **Example 1**
 >
 > ```text
-> Input: @ints = (1, 2, 3, 4), $r = 2, $c = 2
-> Output: ([1, 2], [3, 4])
+> Input: @binary = (0, 1, 1, 0, 1, 1, 1)
+> Output: 3
 >```
 > 
 >**Example 2**
 > 
 >```text
-> Input: @ints = (1, 2, 3), $r = 1, $c = 3
-> Output: ([1, 2, 3])
+> Input: @binary = (0, 0, 0, 0)
+> Output: 0
 > ```
 >
 > **Example 3**
 >
 > ```text
->Input: @ints = (1, 2, 3, 4), $r = 4, $c = 1
-> Output: ([1], [2], [3], [4])
+>Input: @binary = (1, 0, 1, 0, 1, 1)
+> Output: 2
 > ```
 
-We have to walk through the input array steps of size `$c`,
-copying row after row to an output array.<br/>
+For this task, first thing I do is to walk through the array and assign to each element the number of `1`s that have been seen since the last `0`. Like this:
 
-I started with a solution that is easy to implement.
-Then I tried to **reduce the code**
-(with the intention to keep it easy to understand),
-and to **reduce the runtime**. 
-
-My first solution uses the `natatime` function from `List::MoreUtils`,
-which is built for just that:
-walking through an array or a list
-and extracting multiple entries in every iteration (hence the name, '$n$ at a time') .
-The function creates an iterator, which we then use in a loop.<br/>
-Quite simple:
-
-```perl
-use v5.36;
-use List::MoreUtils qw( natatime );
-
-sub two_d_array_natatime( $ints, $r, $c ) {
-    my @matrix;
-    my $iterator = natatime $c, $ints->@*;
-    while ( my @row = $iterator->() ) {
-        push @matrix, [ @row ];
-    }
-    return @matrix;
-}
+```text
+@binary:        0       1       1       0       1       1       1
+                |       |       |       |       |       |       |
+# of ones:      0       1       2       0       1       2       3
 ```
 
-Then I started to think:<br/>
-Calling the iterator function might be quite an overhead
-over just keeping an index ourselves
-and locating and returning a number of elements.
-We still can use Perl's nice array slice operator
-to extract a whole row of elements 'at a time'.
+To do that, I need to carry over the current number of `1`s from position to position. This makes it a perfect use case for the `reductions` function (from `List::Util`). In its code block, the `$a` variable is the result for the previous element, and `$b` is the current element. That makes this type of 'conditional counting' very easy:
 
-If we loop over the row indexes using `$_`,
-each row's data start at index `$_ * $c`,
-and it will end just before the next row,
-which is at `( $_ + 1 ) * $c - 1` .<br/>
-We also can use `map` instead of a `for` loop and `push`,
-effectively eliminating the need of a result variable.
-The row indexes run from `0` to `$r - 1 `.
+ ```perl
+     reductions { $b ? ++$a : 0 } @binary
+ ```
 
-That looks like this:
+Now it's very simple to find the maximum number of consecutive `1`s: just apply the `max` function on the result.
+
+Which makes this tasks solution a very nice and simple one-line-of-code function:  
 
 ```perl
-sub two_d_array_map( $ints, $r, $c ) {
-    return map [ $ints->@[ $_ * $c .. ( $_  + 1 ) * $c - 1 ] ], 0 .. $r - 1;
+sub consecutive_one( @binary ) {
+    return max( reductions { $b ? ++$a : 0 } @binary );
 }
 ```
 
-This **reduces our code** a lot,
-and I think it has not turned into anything unreadable.
-
-At the same time, as very often, this also **reduces the runtime**
-by avoiding several overheads.<br/>
-I have run some small benchmarks,
-for matrix sizes of 2x2, 4x4, 10x10, 100x100, and even 1000x1000:
-
-```text
-array size: 2 x 2
-              Rate natatime      map
-natatime  635496/s       --     -47%
-map      1205315/s      90%       --
-array size: 4 x 4
-             Rate natatime      map
-natatime 395930/s       --     -37%
-map      631484/s      59%       --
-array size: 10 x 10
-             Rate natatime      map
-natatime 127245/s       --     -32%
-map      188504/s      48%       --
-array size: 100 x 100
-           Rate natatime      map
-natatime 2045/s       --     -39%
-map      3329/s      63%       --
-array size: 1000 x 1000
-           Rate natatime      map
-natatime 21.0/s       --     -43%
-map      37.0/s      76%       --
-```
-
-It shows that our Perlish home-brewed one-line-of-code solution
-beats `natatime` at any array size.<br/>
-I find it interesting that for medium sizes, the two solutions approach each other with respect to performance, but then with larger sizes, `map` performs better again.<br/>
-I cannot really explain this effect. 
-I would have guessed that for bigger matrices, most time is spent for really copying the data, so the way of controlling it becomes less important in general.
-
-A quite simple task, yet a lot to learn.  
+## Task 2: Final Price
 
-
-
-## Task 2: Total XOR
-
-> You are given an array of integers.<br/>
-> Write a script to return the sum of total XOR for every subset of given array.
+> You are given an array of item prices.<br/>
+> Write a script to find out the final price of each items in the given array.<br/>
+> There is a special discount scheme going on. If there’s an item with a lower or equal price later in the list, you get a discount equal to that later price (the first one you find in order).
 >
 > **Example 1**
 >
 > ```text
-> Input: @ints = (1, 3)
-> Output: 6
+> Input: @prices = (8, 4, 6, 2, 3)
+> Output: (4, 2, 4, 2, 3)
+>
+> Item 0:
+> The item price is 8.
+> The first time that has price <= current item price is 4.
+> Final price = 8 - 4 => 4
 >
-> Subset [1],    total XOR = 1
-> Subset [3],    total XOR = 3
-> Subset [1, 3], total XOR => 1 XOR 3 => 2
+> Item 1:
+> The item price is 4.
+> The first time that has price <= current item price is 2.
+> Final price = 4 - 2 => 2
 >
-> Sum of total XOR => 1 + 3 + 2 => 6
+> Item 2:
+> The item price is 6.
+> The first time that has price <= current item price is 2.
+> Final price = 6 - 2 => 4
+>
+> Item 3:
+> The item price is 2.
+> No item has price <= current item price, no discount.
+> Final price = 2
+>
+> Item 4:
+> The item price is 3.
+> Since it is the last item, so no discount.
+> Final price = 3
 >```
 > 
 >**Example 2**
 > 
 >```text
-> Input: @ints = (5, 1, 6)
-> Output: 28
-> 
->Subset [5],       total XOR = 5
-> Subset [1],       total XOR = 1
-> Subset [6],       total XOR = 6
-> Subset [5, 1],    total XOR => 5 XOR 1 => 4
-> Subset [5, 6],    total XOR => 5 XOR 6 => 3
-> Subset [1, 6],    total XOR => 1 XOR 6 => 7
-> Subset [5, 1, 6], total XOR => 5 XOR 1 XOR 6 => 2
-> 
->Sum of total XOR => 5 + 1 + 6 + 4 + 3 + 7 + 2 => 28
+> Input: @prices = (1, 2, 3, 4, 5)
+> Output: (1, 2, 3, 4, 5)
 > ```
 >
 > **Example 3**
 >
 > ```text
->Input: @ints = (3, 4, 5, 6, 7, 8)
-> Output: 480
+>Input: @prices = (7, 1, 1, 5)
+> Output: (6, 0, 1, 5)
+> 
+> Item 0:
+>The item price is 7.
+> The first time that has price <= current item price is 1.
+> Final price = 7 - 1 => 6
+> 
+> Item 1:
+>The item price is 1.
+> The first time that has price <= current item price is 1.
+> Final price = 1 - 1 => 0
+> 
+> Item 2:
+>The item price is 1.
+> No item has price <= current item price, so no discount.
+> Final price = 1
+> 
+> Item 3:
+>The item price is 5.
+> Since it is the last item, so no discount.
+> Final price = 5
 > ```
 
-There are these things we need to implement:
-
-* get all possible subsets of the input data,
-* compute the XOR sum of each subset,
-* sum up and return the XOR sums.
+My solution for this task is short , and simple enough, but I don't really like it.<br/>
+I couldn't come up with a way to avoid the 'almost quadratic' behavior of walking through the whole rest of the list to find a discount for *every* entry in the list, that's why I am not really happy.
 
-For the first part, getting all subsets of a given set of elements,
-it is easiest to use an existing and well tested piece of software from CPAN.
-I used the `subsets` function from `Algorithm::Combinatorics`
-for my first solution.
-It returns an iterator that delivers the next subset with every call,
-with the empty subset being the last.
-The empty subset can then be used as an end criteria for the loop.
+But this is what I have:
 
-Simple as this:
+I use `map` to map the item prices from the `@prices` array to the final prices to be returned. The final price is the item price minus a possible discount, and for getting that discount, I use `first` to walk through the rest of the array to find the next item price that is lower than or equal to the current one.
 
 ```perl
 use v5.36;
-use Algorithm::Combinatorics qw( subsets );
-
-sub total_xor( @ints ) {
-    my $sum = 0;
-    my $iterator = subsets( \@ints );
-    while ( my $subset = $iterator->next ) {
-        $sum += ...;	# Add XOR sum of the current subset.
-    }
-    return $sum;
+use List::Util qw( first );
+
+sub final_price( @prices ) {
+    return map {
+        my $price = $prices[$_];
+        my $discount = first { $_ <= $price } @prices[ $_ + 1 .. $#prices ];
+        $price - ( $discount // 0 );
+    } keys @prices;
 }
 ```
 
-**Reduce to the XOR sum** 
-
-But how do we compute the XOR sum of a list of numbers?
-
-Traditional thinking would use a loop for this.<br/>
-But let's think a bit more 'functional' today.<br/>
-The **`reduce`** function is the perfect choice
-for walking through a list and building up a final result
-by combining elements one by one.<br/>
-Its code block combines the current partial result
-(in the `$a` special variable) with the next element (in `$b`).
-In the end, all the elements will have been combined.
-
-We start with a `0` as the first element,
-to not get an `undef` result for the empty subset.<br/>
-Our implementation of an 'XOR sum' function is simply this:
-
-```perl
-    reduce { $a ^ $b } 0, @elements
-```
-
-So here is the complete (first) solution:
-
-```perl
-use v5.36;
-use Algorithm::Combinatorics qw( subsets );
-use List::Util qw( reduce );
-
-sub total_xor( @ints ) {
-    my $sum = 0;
-    my $iterator = subsets( \@ints );
-    while ( my $subset = $iterator->next ) {
-        $sum += reduce { $a ^ $b } 0, $subset->@*;
-    }
-    return $sum;
-}
-```
-
-**BONUS: Roll your own subset iterator:**
-
-I was wondering how difficult it would be to implement the `subsets` iterator myself.<br/>Actually it isn't!
-
-The theory behind creating all possible subsets is this:
-
-Every possible subset of a set with $n$ elements is determined
-by which of the elements are contained or not.<br/>
-If we use one bit $b_i$ to represent whether element $i$ is contained or not,
-the bits form a number between $0$ (for the empty set) and $2^n - 1$
-(all bits set, all elements contained in that subset, which is the set itself).<br/>
-We can enumerate the subsets using that number, calling it a 'subset id'<br/>
-The overall number of possible subsets is $2^n$.
-
-For the creation of our iterator,
-we initialize a `$subset_id` variable with $2^n$.<br/>
-I know, that's one too high,
-but it's actually easier to pre-decrement this variable within the iterator:<br/>
-This way, we can at the same time determine whether we have
-reached the end of the possible subsets, return `undef` if so,
-and continue to directly return the result if not.<br/>
-If the `$subset_id` already is zero upon entry,
-we have returned the last subset (the empty one) in the previous call.
-We then set the `$subset_id` to `undef`,
-and return that value from this and all following calls to this iterator.
-
-If we are still good, we determine the elements of the subset,
-based on the bits set or not set in `$subset_id`.<br/>
-This is done by `map`ping the element indexes to a one-bit
-shifted into the corresponding position,
-and doing a bitwise And with the subset_id.
-If the bit is set,
-we include the element into the anonymous array that will be returned. 
-
-So, here is my bonus subset iterator. 
-
-```perl
-sub subset_iterator( $ints ) {
-    my $subset_id = 1 << $ints->@*;
-    return sub() {
-        return defined ( $subset_id ? --$subset_id : undef )
-            && [ map $subset_id & 1 << $_ ? $ints->[$_] : (), keys $ints->@* ];
-    };
-}
-```
-
-Just make sure that your set doesn't contain more than 63 elements... ;-)
-
+As I said, simple enough, but I guess there must be a better algorithmic solution ...
 
 #### **Thank you for the challenge!**
diff --git a/challenge-325/matthias-muth/blog.txt b/challenge-325/matthias-muth/blog.txt
new file mode 100644
index 0000000000..e39fb41d09
--- /dev/null
+++ b/challenge-325/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-325/challenge-325/matthias-muth#readme
diff --git a/challenge-325/matthias-muth/perl/ch-1.pl b/challenge-325/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..6f99db920d
--- /dev/null
+++ b/challenge-325/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,30 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 325 Task 1: Consecutive One
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use Dsay;
+
+use List::Util qw( reductions max );
+
+sub consecutive_one( @binary ) {
+    return max( reductions { $b ? ++$a : 0 } @binary );
+}
+
+use Test2::V0 qw( -no_srand );
+
+is consecutive_one( 0, 1, 1, 0, 1, 1, 1 ), 3,
+    'Example 1: consecutive_one( 0, 1, 1, 0, 1, 1, 1 ) == 3';
+is consecutive_one( 0, 0, 0, 0 ), 0,
+    'Example 2: consecutive_one( 0, 0, 0, 0 ) == 0';
+is consecutive_one( 1, 0, 1, 0, 1, 1 ), 2,
+    'Example 3: consecutive_one( 1, 0, 1, 0, 1, 1 ) == 2';
+
+done_testing;
diff --git a/challenge-325/matthias-muth/perl/ch-2.pl b/challenge-325/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..8f11a3b58d
--- /dev/null
+++ b/challenge-325/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 325 Task 2: Final Price
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use List::Util qw( first );
+
+sub final_price( @prices ) {
+    return map {
+        my $price = $prices[$_];
+        my $discount = first { $_ <= $price } @prices[ $_ + 1 .. $#prices ];
+        $price - ( $discount // 0 );
+    } keys @prices;
+}
+
+use Test2::V0 qw( -no_srand );
+
+is [ final_price( 8, 4, 6, 2, 3 ) ], [ 4, 2, 4, 2, 3 ],
+    'Example 1: final_price( 8, 4, 6, 2, 3 ) == (4, 2, 4, 2, 3)';
+is [ final_price( 1, 2, 3, 4, 5 ) ], [ 1, 2, 3, 4, 5 ],
+    'Example 2: final_price( 1, 2, 3, 4, 5 ) == (1 .. 5)';
+is [ final_price( 7, 1, 1, 5 ) ], [ 6, 0, 1, 5 ],
+    'Example 3: final_price( 7, 1, 1, 5 ) == (6, 0, 1, 5)';
+is [ final_price( 3, 4, 7, 5, 8, 2 ) ], [ 1, 2, 2, 3, 6, 2 ],
+    'Test 1: final_price( 3, 4, 7, 5, 8, 2 ) == (1, 2, 2, 3, 6, 2)';
+
+done_testing;