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

4 files changed, 278 insertions, 143 deletions

diff --git a/challenge-323/matthias-muth/README.md b/challenge-323/matthias-muth/README.md
index 15f9b167f8..fd768ecbc4 100644
--- a/challenge-323/matthias-muth/README.md
+++ b/challenge-323/matthias-muth/README.md
@@ -1,198 +1,223 @@
-# Ranking Code, Ranking Numbers
+# Decrement Your Tax Amount.
 
-**Challenge 322 solutions in Perl by Matthias Muth**
+**Challenge 323 solutions in Perl by Matthias Muth**
 
-## Task 1: String Format
+## Task 1: Increment Decrement
 
-> You are given a string and a positive integer.<br/>
-> Write a script to format the string, removing any dashes, in groups of size given by the integer. The first group can be smaller than the integer but should have at least one character. Groups should be separated by dashes.
->
+> You are given a list of operations.<br/>
+> Write a script to return the final value after performing the given operations in order. The initial value is always 0.<br/>
+> ```text
+> Possible Operations:
+> ++x or x++: increment by 1
+> --x or x--: decrement by 1
+>```
+> 
 > **Example 1**
 >
 > ```text
-> Input: $str = "ABC-D-E-F", $i = 3
-> Output: "ABC-DEF"
+> Input: @operations = ("--x", "x++", "x++")
+> Output: 1
+>
+> Operation "--x" =>  0 - 1 => -1
+> Operation "x++" => -1 + 1 =>  0
+> Operation "x++" =>  0 + 1 =>  1
 >```
 > 
 >**Example 2**
 > 
 >```text
-> Input: $str = "A-BC-D-E", $i = 2
-> Output: "A-BC-DE"
+> Input: @operations = ("x++", "++x", "x++")
+> Output: 3
 > ```
 >
 > **Example 3**
 >
 > ```text
->Input: $str = "-A-B-CD-E", $i = 4
-> Output: "A-BCDE"
+>Input: @operations = ("x++", "++x", "--x", "x--")
+> Output: 0
+> 
+> Operation "x++" => 0 + 1 => 1
+>Operation "++x" => 1 + 1 => 2
+> Operation "--x" => 2 - 1 => 1
+> Operation "x--" => 1 - 1 => 0
 > ```
 
-The first thing to observe is that the `'-'` dash signs in the input strings have absolutely nothing to do with the end result, so we best get rid of them first. Like this:
 
-```perl
-    $str =~ s/-//g;
-```
-
-Now we have a string that consists of non-dash characters only.<br/>
-
-For putting dashes back in at the right spots, we need to split up that string into chunks of `$i` characters.<br/>
-The only chunk that can have less than `$i` characters is at the start of the string.
-
-I tried several approaches:
-
-- Using a regular expression to "chip away" chunks of at most `$i` characters at the end of the string, in a loop.<br/>Then `join` them together with dashes, in reverse order:
-
-  ```perl
-      my @chunks;
-      while ( $str =~ s/(.{1,$i})$// ) {
-          push @chunks, $1;
-      }
-      return join "-", reverse @chunks;
-  ```
-
-  I call this a 'destructive' solution, because the string in `$str` is modified, and completely destroyed in the end.
-
-  I ran a lot of benchmarks for my several solutions (it's so easy with `use Benchmark` and `cmpthese`!).<br/>This solution, on my server, ran a maximum of 18,963 executions/s (using a string of 102 characters) .
-
-- Maybe it's faster when it's 'non-destructive', and using the `/g` global flag instead of a restarting the regular expression in a loop.<br/>
-  For working left to right, and still producing the chunks in the same order, I simply reversed the string first. Each chunk will be a reversed string then, and as the chunks have to be reversed anyway, we can just reverse the complete result in the end.<br/>
-  Like this:
-  
-  ```perl
-      $str = reverse $str =~ s/-//gr;
-      my @chunks;
-      push @chunks, $&
-          while $str =~ /.{1,$i}/g;
-      return scalar reverse join "-", @chunks;
-  ```
-  
-  Ok, quite a bit better: 28,183 executions/s. Roughly 50% more.
-
-* But what if we don't use regular expressions, but just extract the chunks using `substr`?<br/>The first solution using a regex above translates to this, using a `$index` variable as a pointer into the string.
-
-  ```perl
-      my ( @chunks, $index );
-      for ( $index = length( $str ) - $i; $index >= 0; $index -= $i ) {
-          push @chunks, substr $str, $index, $i;
-      }
-      if ( $index > -$i ) {
-          push @chunks, substr $str, 0, length( $str ) % $i;
-      }
-      return join "-", reverse @chunks;
-  ```
-
-  The loop catches *all* chunks of size `$i`. We then need to check whether there is any smaller chunk left at the end, which looks a bit complicated, and clumsy, calculating the number of characters in the last chunk, between `1` and `$i` (inclusively).
-
-  But we are at 102,037 execution/s!
-
-At this point, we can only expect very small benefits when we try to optimize further.<br/>
-But maybe we can do some 'cosmetic' changes:
-
-* To avoid that clumsy check at the end, we can make sure that there is at least one character left in the string at the end of the loop. That's easily done by just changing the `$index >= 0` condition to `$index > 0`.  Then we don't need the condition anymore, because we will always have a last chunk outside the loop.
-
-  ```perl
-      my ( @chunks, $index );
-      for ( $index = length( $str ) - $i; $index > 0; $index -= $i ) {
-          push @chunks, substr $str, $index, $i;
-      }
-      push @chunks, substr( $str, 0, ( length( $str ) - 1 ) % $i + 1 );
-      return join "-", reverse @chunks;
-  ```
-
-  A minimal gain of speed even: 103,186 executions/s (I ran *a lot* of benchmarks to get reliable maximum numbers).
-
-* Some changes to do 'micro-optimizations'. But actually they reduce the code, too, and can make things more clear:
-
-  * Use a `while` loop instead of the `for` loop. The effect is that the `$index` variable keeps its last value upon exiting the loop, and we can use the last value to determine the size of the last chunk.
-
-  * Having only one statement left inside the loop, we can flip around the loop (syntactically speaking, using a `while`  'statement modifier' instead of a `while` loop).
-  
-  * Start with the `$index` one chunk size too high, and 'inline' the decrementing (also adapt the end condition).<br/>
-    This leaves the size of the last chunk in `$index`, which is very convenient: it eliminates the length calculation.
-    
-  * We don't need to `push` the last chunk onto the chunk stack, we can use it directly in the return statement. 
-  
-  ```perl
-      my @chunks;
-      my $index = length( $str );
-      push @chunks, substr $str, $index -= $i, $i
-          while $index > $i;
-      return join "-", reverse @chunks, substr( $str, 0, $index )
-  ```
-  
-
-With all of these, we reach an amazing speed of 106,803 executions/s.<br/>
-I think it was worth it to go through several iterations of the code.
-
-This is my "best" solution:
+I simplify the task specification by saying that
+'anything containing `++`' increments the result value,
+and 'anything containing `--`' decrements the result value.
+Using regular expressions, of course,
+and a combination of `sum0` and `map`,
+this makes my solution even shorter:  
 
 ```perl
 use v5.36;
 
-sub string_format( $str, $i ) {
-    $str =~ s/-//g;
-    my @chunks;
-    my $index = length( $str );
-    push @chunks, substr $str, $index -= $i, $i
-        while $index > $i;
-    return join "-", reverse @chunks, substr( $str, 0, $index );
+use List::Util qw( sum0 );
+
+sub increment_decrement( @operations ) {
+    return sum0( map /\Q++/ ? +1 : /--/ ? -1 : 0, @operations );
 }
 ```
+`sum0` returns a value of `0` when there are no values to sum up at all,
+which should be the correct behaviour for our little solution
+when the list of operations is empty.
 
+The `\Q` in the `/\Q++/` pattern serves to quote everything
+from that point onward,
+which removes the special meaning of the `+` signs
+within the regular expression, and makes it nicer to read.
 
+And that's it! 
 
-## Task 2: Rank Array
+## Task 2: Tax Amount
 
-> You are given an array of integers.<br/>
-> Write a script to return an array of the ranks of each element: the lowest value has rank 1, next lowest rank 2, etc. If two elements are the same then they share the same rank.
+> You are given an income amount and tax brackets.<br/>
+> Write a script to calculate the total tax amount.
 >
 > **Example 1**
 >
 > ```text
-> Input: @ints = (55, 22, 44, 33)
-> Output: (4, 1, 3, 2)
-> ```
+> Input: $income = 10, @tax = ([3, 50], [7, 10], [12,25])
+> Output: 2.65
 >
-> **Example 2**
+> 1st tax bracket upto  3, tax is 50%.
+> 2nd tax bracket upto  7, tax is 10%.
+> 3rd tax bracket upto 12, tax is 25%.
 >
-> ```text
-> Input: @ints = (10, 10, 10)
-> Output: (1, 1, 1)
-> ```
+> Total Tax => (3 * 50/100) + (4 * 10/100) + (3 * 25/100)
+>           => 1.50 + 0.40 + 0.75
+>           => 2.65
+>```
+> 
+>**Example 2**
+> 
+>```text
+> Input: $income = 2, @tax = ([1, 0], [4, 25], [5,50])
+> Output: 0.25
+> 
+>Total Tax => (1 * 0/100) + (1 * 25/100)
+>        => 0 + 0.25
+>           => 0.25
+>    ```
 >
 > **Example 3**
 >
 > ```text
-> Input: @ints = (5, 1, 1, 4, 3)
-> Output: (4, 1, 1, 3, 2)
+>Input: $income = 0, @tax = ([2, 50])
+> Output: 0
 > ```
 
-In sports events, when two or more participants share the same result, there are different strategies for handling these ties. Most often, the ['1224' standard competition ranking system ](https://en.wikipedia.org/wiki/Ranking#Standard_competition_ranking_(%221224%22_ranking)) is used. If two participants share the same result, their ranking is the same,  and the next rank after them is not assigned.
+I think my solution this week is less 'elegant' than I would wish for.<br/>
+What I hope, though, is that it is still readable and comprehensible
+even without a lot of comments.<br/>
+I put in some effort to choose good variable names,
+and to avoid overloaded or too long statements.
+
+So let's calculate taxes!
+
+We loop over the tax brackets in order,
+and cumulate the partial amounts from each bracket in a variable `$tax_amount`.
 
-From the examples I understand that in this task, another ranking system is used: the ['1223', or 'dense' ranking system](https://en.wikipedia.org/wiki/Ranking#Dense_ranking_(%221223%22_ranking)). If there are equal results, they share the same rank, but the next result in the order is assigned the next rank, without gaps.<br/>
-This makes the task easier, I think.
+In each iteration, we need to decide what part of the income
+falls into the current bracket.
+We always need the lower limit of the bracket for this,
+which happens to be the upper limit of the previous bracket.
+So we use a variable `$prev_bracket`
+to transport that limit from iteration to iteration.<br/>
+Both variables are initialized to zero:
 
-After removing all double entries (using `uniq` from `List::Util`), we sort the numbers.<br/>
-The index of each element in the sorted array then corresponds to the rank of that element. We just need to add 1 to the index, because the rank is 1-based.
+```perl
+    my ( $tax_amount, $prev_bracket ) = ( 0, 0 );
+```
+
+Within the loop, if the bracket's lower limit
+(which we have in `$prev_bracket`) is higher than the income,
+we are done, and we can exit the loop right away.<br/>
+If not, we assign the two values of the current tax bracket to variables,
+to be clear about what they mean:
+
+```perl
+    for ( $tax->@* ) {
+        last if $income <= $prev_bracket;
+        my ( $bracket, $percentage ) = $_->@*;
+```
 
-We can build a rank lookup from that, of course using a hash.
+Now we can determine the amount that will be taxed
+using the current bracket and percentage.<br/>
+If the income is higher than the bracket's upper limit,
+the complete bracket interval is taxed,
+from the lower limit all the way up to the upper limit.<br/>
+If the income is lower than the upper limit,
+we only tax the amount up to there.<br/>
+To make it easy,
+we first determine the amount up to which we apply the tax:
 
-The last step is to map every number of the input array to its rank, using that lookup hash.
+```perl
+        my $bracketed_amount = $income < $bracket ? $income : $bracket;
+```
+
+Based on that, we can add the partial tax amount to the cumulated sum:
+
+```perl
+        $tax_amount += ( $bracketed_amount - $prev_bracket ) * $percentage;
+```
+
+In fact, we should divide by 100 to get the correct amount.
+But we will postpone that division
+until all the partial amounts have been summed up.
+
+At the end of the loop definition,
+we store the bracket limit for the next round:
+
+```perl
+        $prev_bracket = $bracket;
+    }
+```
+
+Once the loop is done, we return the cumulated tax amount,
+not forgetting the division by 100:
+
+```perl
+    return $tax_amount / 100;
+```
 
-So this is all:
+This concludes the solution:
 
 ```perl
 use v5.36;
-use List::Util qw( uniq );
 
-sub rank_array( @ints ) {
-    my @uniq_sorted = sort { $a <=> $b } uniq @ints;
-    my %ranks = map { ( $uniq_sorted[$_] => $_ + 1 ) } 0..$#uniq_sorted; 
-    return map $ranks{$_}, @ints;
+sub tax_amount( $income, $tax ) {
+    my ( $tax_amount, $prev_bracket ) = ( 0, 0 );
+    for ( $tax->@* ) {
+        last if $income <= $prev_bracket;
+        my ( $bracket, $percentage ) = $_->@*;
+        my $bracketed_amount = $income < $bracket ? $income : $bracket;
+        $tax_amount += ( $bracketed_amount - $prev_bracket ) * $percentage;
+        $prev_bracket = $bracket;
+    }
+    return $tax_amount / 100;
 }
 ```
 
-No fighting for performance this time. ;-)
+In the real world, I would probably consider
+doing correct rounding of the result.<br/>
+But correct rounding in financial applications? That is a Pandora's Box ...
+
+I would probably also wonder what happens
+when the income is higher than the last bracket.<br/>
+Can we specify an upper limit of 'infinity'?
+
+I think that 'in the real world',
+the tax brackets would not be defined like
+'*up to this amount*, this percentage is applied',
+but like like
+'*from this amount onward*, this percentage is applied'.
+The first bracket would always start from zero,
+and the last bracket would be valid for any income
+that is larger than that bracket's limit,
+no matter how high the income is.
+
+But hey! Nice challenge! 
 
 #### **Thank you for the challenge!**
diff --git a/challenge-323/matthias-muth/blog.txt b/challenge-323/matthias-muth/blog.txt
new file mode 100644
index 0000000000..edd75fd89d
--- /dev/null
+++ b/challenge-323/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-323/challenge-323/matthias-muth#readme
diff --git a/challenge-323/matthias-muth/perl/ch-1.pl b/challenge-323/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..5ad9b55c57
--- /dev/null
+++ b/challenge-323/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,28 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 323 Task 1: Increment Decrement
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use List::Util qw( sum0 );
+
+sub increment_decrement( @operations ) {
+    return sum0( map /\Q++/ ? +1 : /--/ ? -1 : 0, @operations );
+}
+
+use Test2::V0 qw( -no_srand );
+
+is increment_decrement( "--x", "x++", "x++" ), 1,
+    'Example 1: increment_decrement( "--x", "x++", "x++" ) == 1';
+is increment_decrement( "x++", "++x", "x++" ), 3,
+    'Example 2: increment_decrement( "x++", "++x", "x++" ) == 3';
+is increment_decrement( "x++", "++x", "--x", "x--" ), 0,
+    'Example 3: increment_decrement( "x++", "++x", "--x", "x--" ) == 0';
+
+done_testing;
diff --git a/challenge-323/matthias-muth/perl/ch-2.pl b/challenge-323/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..63b78247ec
--- /dev/null
+++ b/challenge-323/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,81 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 323 Task 2: Tax Amount
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use Dsay;
+
+use List::Util qw( sum0 min reductions );
+
+sub tax_amount( $income, $tax ) {
+    my ( $tax_amount, $prev_bracket ) = ( 0, 0 );
+    for ( $tax->@* ) {
+	my ( $bracket, $percentage ) = $_->@*;
+	last if $income <= $prev_bracket;
+	my $bracketed_amount = $income < $bracket ? $income : $bracket;
+	$tax_amount += ( $bracketed_amount - $prev_bracket ) * $percentage;
+	$prev_bracket = $bracket;
+    }
+    return $tax_amount / 100;
+}
+
+sub tax_amount( $income, $tax ) {
+    my @brackets =
+	reductions { [ $a->[1], $b->[0], $b->[1] ] }
+	    [ 0, 0, 0 ], $tax->@*;
+    return sum0(
+	map {
+	    my ( $bracket_from, $bracket_to, $percentage ) = $_->@*;
+	    $income > $bracket_from
+	    ? $income < $bracket_to
+		? ( $income     - $bracket_from ) * $percentage
+		: ( $bracket_to - $bracket_from ) * $percentage
+	    : 0;
+	} @brackets
+    ) / 100;
+}
+
+sub tax_amount( $income, $tax ) {
+    my @brackets_from = ( 0, map( $_->[0], $tax->@* ) );
+    my $tax_amount = 0;
+    for ( keys $tax->@* ) {
+	my ( $bracket_from, $bracket_to, $percentage ) =
+	    ( $brackets_from[$_], $tax->[$_]->@* );
+	last if $income <= $bracket_from;
+	$tax_amount +=
+	    $income < $bracket_to
+	    ? ( $income     - $bracket_from ) * $percentage
+	    : ( $bracket_to - $bracket_from ) * $percentage;
+    }
+    return $tax_amount / 100;
+}
+
+sub tax_amount( $income, $tax ) {
+    my ( $tax_amount, $prev_bracket ) = ( 0, 0 );
+    for ( $tax->@* ) {
+	last if $income <= $prev_bracket;
+	my ( $bracket, $percentage ) = $_->@*;
+	my $bracketed_amount = $income < $bracket ? $income : $bracket;
+	$tax_amount += ( $bracketed_amount - $prev_bracket ) * $percentage;
+	$prev_bracket = $bracket;
+    }
+    return $tax_amount / 100;
+}
+
+use Test2::V0 qw( -no_srand );
+
+is tax_amount( 10, [[3, 50], [7, 10], [12, 25]] ), 2.65,
+    'Example 1: tax_amount( 10, [[3, 50], [7, 10], [12, 25]] ) == 2.65';
+is tax_amount( 2, [[1, 0], [4, 25], [5, 50]] ), 0.25,
+    'Example 2: tax_amount( 2, [[1, 0], [4, 25], [5, 50]] ) == 0.25';
+is tax_amount( 0, [[2, 50]] ), 0,
+    'Example 3: tax_amount( 0, [[2, 50]] ) == 0';
+
+done_testing;