Challenge 219 solutions in Perl by Matthias Muth

6 files changed, 444 insertions, 137 deletions

diff --git a/challenge-219/matthias-muth/README.md b/challenge-219/matthias-muth/README.md
index a8034fc57d..7ff542ce5e 100644
--- a/challenge-219/matthias-muth/README.md
+++ b/challenge-219/matthias-muth/README.md
@@ -1,168 +1,138 @@
-# Highscore!
-**Challenge 218 solutions in Perl by Matthias Muth**
+# This is Perl! We got this, no problem!
+**Challenge 219 solutions in Perl by Matthias Muth**
 
-## Task 1: Maximum Product
+This week's challenges confirm to me why I love Perl:<br/>
+Using what the language offers, the idea how to implement it transforms directly into code.<br/>
+Evrything works well together, and there is no unnecessary clutter.
 
-> You are given a list of 3 or more integers.<br/>
-> Write a script to find the 3 integers whose product is the maximum and return it.<br/>
+## Task 1: Sorted Squares
 
-If we have exactly three numbers, there's not a lot of choice.<br/>
-We return the product of the three numbers that we have got:
-```perl
-    use List::Util qw( product );
-
-    return product( @list )
-        if @list == 3;
-```
-
-We need to consider that we might have negative numbers in the list,
-and there might be situations where we cannot avoid ending up with a negative product.
-But, of course, *any* positive product is better that *any* negative one!<br/>
-So we first try to find the largest possible *positive* product using three numbers from the list.<br/>
+> You are given a list of numbers.<br/>
+> Write a script to square each number in the list and return the sorted list, increasing order.<br/>
 
-The largest positive productmy be wither of these:
-* the product of the three largest positive numbers,
-* the product of the two negatives with the highest absolute value, and the largest positive number<br/>
-(the two negatives turning the result into positive).
+This one ends up in a typical Perl one-liner.<br/>
+The subroutine's input list of numbers (`@_`) is used to square all its entries using a `map` call
+(I used the 'code block' variant here), and the resulting list is sorted,
+also using a 'code block' that compares two values numerically to determine their order in the sorted output.<br/>
+Perl's `<=>` operator comes in handy to tell whether the fist operand
+goes left (`-1`) or right (`+1`) or the two operands are equal (`0`).
 
-We cannot say in advance which of these will be better,
-because this depends on the absolute values of the positive and negative 'best' numbers,
-So, after splitting up our list into positives and negatives,
-sorted by highest to lowest absolute values,
-we compute them both (if possible), 
-and then return the better one, if at lest one of them could be produced:
+More explanation than code! :-)
 
 ```perl
-    my @pos = sort { abs( $b ) <=> abs( $a ) } grep $_ > 0, @list;
-    my @neg = sort { abs( $b ) <=> abs( $a ) } grep $_ < 0, @list;
-
-    my @positive_results = (
-        @pos >= 3              ? product( @pos[0..2] )          : (),
-        @pos >= 1 && @neg >= 2 ? product( @neg[0..1], $pos[0] ) : (),
-    );
-
-    # If we have at least one of them, we are done.
-    return max( @positive_results )
-        if @positive_results;
+sub sorted_squares {
+    return sort { $a <=> $b } map { $_ ** 2 }, @_;
+}
 ```
 
-If it was not possible to return a positive result,
-we should at least try to limit our outcome to zero.<br/>
-We can return a zero result if we have at least one zero in the list,
-because no matter which other numbers we multiply it with, it still remains a zero:
-
+## Task 2: Travel Expenditure
+
+> You are given two list, @costs and @days.<br/>
+> The list @costs contains the cost of three different types of travel cards you can buy.<br/>
+> For example @costs = (5, 30, 90)<br/>
+> Index 0 element represent the cost of  1 day  travel card.<br/>
+> Index 1 element represent the cost of  7 days travel card.<br/>
+> Index 2 element represent the cost of 30 days travel card.<br/>
+> <br/>
+> The list @days contains the day number you want to travel in the year.<br/>
+> For example: @days = (1, 3, 4, 5, 6)<br/>
+> The above example means you want to travel on day 1, day 3, day 4, day 5 and day 6 of the year.<br/>
+> <br/>
+> Write a script to find the minimum travel cost.<br/>
+
+Let's take the first day that we want to travel.<br/>
+On that day, we have three options to take a travel card.
+Depending on which option we take, we
+* spend some money for buying that card,
+* can possibly use that card for some more days on which we want to travel.
+
+After the travel pass period is over, we need to decide again which of the options will be cheaper then
+for the rest of the list.
+
+So we are looking at a problem here that should be easy to solve by recursion:
+* Apply one of the three options, 
+* use the same problem solving routine to determine the 'best' solution for the rest of the input list that is not yet covered.
+
+Do this for all of the options that we have, and then take the best one.
+
+Our recursive subroutine has two parameters:<br/>
+a list of costs (which will always have three elements in this challenge),
+and a list of days to find the best combination of travel passes for:
 ```perl
-    return 0
-        if grep $_ == 0, @list;
+sub travel_expenditure {
+    my ( $costs, $days ) = @_;
+    ...
+}
 ```
+and it will return the minimum cost for travelling on the days given as parameters.
 
-If this didn't work either, we are set to return a negative result.
-
-At this point we are sure that we have at least three negative numbers,
-because we know that
-* we have at least 4 numbers in total<br/>
-  (because there are >= 3 by definition, and we checked for having exactly three already),
-* we have at most 2 positives<br/>
-  (because we ruled out having 3 positives),
-* we don't have any zeroes<br/>,
-  (we just checked).
-
-So we have at least 2 negatives.<br/>
-From that we can follow that
-* we don't even have 1 positive
-  (because we would have combined it with the two negatives for a positive result).
-
-So actually we have *only* negative numbers, and at least 4 of them.
-
-We choose the ones with the lowest absolute value, giving us the highest
-(least negative) result possible.<br/>
-To get those, we just reverse the list that we already have,
-which is equivalent to sorting then into ascending order, 
-and then take the first three entries.
+Any function that is being called recursively has to have an end criteria.<br/>
+In our case, we return from the subroutine directly if there are no days in the list.
+Of course, we then don't need to buy any travel pass at all, and the cost is zero.
 ```perl
-    return product( ( reverse @neg )[0..2] );
+    return 0
+        if @$days == 0;
 ```
-And we are done.
-
-## Task 2: Matrix Score
 
-> You are given a m x n binary matrix i.e. having only 1 and 0.<br/>
-> You are allowed to make as many moves as you want to get the highest score.<br/>
-> A move can be either toggling each value in a row or column.<br/>
-> To get the score, convert the each row binary to dec and return the sum.<br/>
+For finding the minimum cost for the options we have for the first day,
+I could have written out the three cases explicitly, because the challenge description defines
+exactly three travel passes.<br/>
+This would be easy to read and understand. I hear:  
+'Aha! Three very similar lines of code, that clearly corresponds to the three travel passes!'.
 
-So we want to get a final sum that is as high as possible.<br/>
-Then let's have a look at what makes up that sum:
+Nevertheless I decided to use `map` instead of writing out the three cases explicitly.
 
-In the binary matrix like in Example 1,
-```
-  [ 0 0 1 1 ]
-  [ 1 0 1 0 ]
-  [ 1 1 0 0 ]
-```
-we will convert the rows from binary to decimal.<br/>
-This means that every bit will be multiplied by a 2<sup>n</sup> value:
-```
-  [ 8 4 2 1 ]
-```
+This is mainly because I don't like repetitions.<br/>
+But then also because by abstracting into a loop, the solution 'scales' better:<br/>
+I want to be ready for a 365 day travel pass in the next challenge! :-) 
 
-To get as high as possible a sum, all the bits with a value of `8` should be set to `1`.
-No matter what the other bits in the same row are,
-a value of `8` is more than all the other bits can achieve together (a maximum of 7).
-
-So in the first step, we flip all rows that have a `0` in the first position:
+So we create an array with the durations of the (three ;-)) travel passes,
+to use them in whatever loop or `map` we will use:
 ```perl
-    for my $row ( grep $_->[0] == 0, @$matrix ) {
-        $row->[$_] ^= 1
-            for 0..$#$row;
-    }
+my @durations = ( 1, 7, 30 );
 ```
 
-In the second step, we go through all columns but the first one,
-and flip all those that have less `1`s that `0`s.<br/>
-This maximizes the sum of values that we get from each column.
-```perl
-    my $n_columns = scalar @{$matrix->[0]};
-    for my $c ( 1 .. $n_columns - 1 ) {
-        # Sum up that column's value from every row.
-        my $column_sum = sum( map $_->[$c], @$matrix );
-        if ( $column_sum < $n_columns / 2 ) {
-            # Flip that column in every row.
-            $_->[$c] ^= 1
-                for @$matrix;
-        }
-    }
-```
+Then we can 'map' the travel pass numbers (0,1,2) to the respective costs,
+determined by the cost for the travel pass itself and the cost for the remaining days that are not covered,
+determined by the recursive call. 
 
-This should give us a good matrix.
+For the list of remaining days, we `grep` those days that are later than the current travel pass's duration,
+put them into an anonymous array, and use that as the parameter.
 
-Now we need to return the sum of all rows converted from binary to decimal.<br/>
-It requires a little thinking how to do this nicely, without doing all the for-loops
-and all the multiplication with the 2<sup>n</sup> values, but everything is already there in perl!
+Here is the only glitch:<br/>
+The `$_` loop variable in the `map` is the number of the travel pass that we currently try.
+Within the `grep`, however, `$_` goes through the list of days.
+So if we want to use the current travel pass's duration within the `grep`condition,
+we can't use `$durations[$_]` there.
+We have to store the duration in a `my $duration` variable before,
+and use that one within the grep condition.
 
-My solution for the conversion of one row is this one:<br/>
-Looking for a `pack` format that makes the conversion easy,
-I choose the 'b32' format to get 4 bytes of data from a maximum of 32 column values.<br/>
-This format uses the least significant bit first, and assumes `0` bits when it runs out of values.
-This is good, because we don't need do anything to fill up our data to any word boundaries.<br/>
-We just need to `reverse` our bit array to have the least significant value first,
-and to turn it into a string `0` or `1` characters for each bit value, before passing it to `pack`.
+As the overall
+result, we return the minimum of the list of costs returned from the `map` call,
+using the `min` function from `List::Util` that we include outside of the function.
 
-The resulting `pack` output byte-string matches this description:
-> An unsigned long (32-bit) in "VAX" (little-endian) order.
+So here is the full implementation: 
 
-which means that we can `unpack` it into a numerical value using `unpack`'s `V` format.<br/>
-So my function to turn a list of binary values into a decimal value is this:
 ```perl
-sub binary_list_to_integer {
-    return unpack( "V", pack( "b32", join( "", reverse @_ ) ) );
+use List::Util qw( min );
+
+my @durations = ( 1, 7, 30 );
+
+sub travel_expenditure {
+    my ( $costs, $days ) = @_;
+    return 0
+        if @$days == 0;
+    return min(
+        map {
+            my $duration = $durations[$_];
+            $costs->[$_]
+                + travel_expenditure( $costs,
+                    [ grep $_ >= $days->[0] + $duration, @$days ] );
+        } 0..$#{$costs}
+    );
 }
 ```
 
-And using that function we return the 'matrix score' end result like this:
-```perl
-    return sum( map binary_list_to_integer( @$_ ), @$matrix );
-```
+This was fun!
 
-**Thank you for the challenge!**
-  
+#### **Thank you for the challenge!**
diff --git a/challenge-219/matthias-muth/blog.txt b/challenge-219/matthias-muth/blog.txt
new file mode 100644
index 0000000000..1eaa31fe0f
--- /dev/null
+++ b/challenge-219/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-219/challenge-219/matthias-muth#readme
diff --git a/challenge-219/matthias-muth/perl/TestExtractor.pm b/challenge-219/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..dce3669930
--- /dev/null
+++ b/challenge-219/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,215 @@
+#!/usr/bin/env perl
+#
+#       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 );
+
+use Data::Dump qw( pp );
+use Getopt::Long;
+use Cwd qw( abs_path );
+use File::Basename;
+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 ) . " ) == "
+	    . pp( @{$_->{OUTPUT}} );
+	    # . pp(
+		# @{$_->{OUTPUT}} == 1 && ref $_->{OUTPUT}[0] eq 'ARRAY' && 
+		# ? @{$_->{OUTPUT}}
+		# : $_->{OUTPUT} );
+
+	my $name = "$_->{TEST}";
+	$name .= ": $diag"
+	    if $_->{TEST} =~ /^(Test|Example)\s+\d+$/;
+	$diag = "test: $diag";
+
+	my @output = $sub->( @input_params );
+	    
+	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} ? "( $_ )" : $_ );
+        };
+    }
+    return @tests;
+}
+
+1;
diff --git a/challenge-219/matthias-muth/perl/ch-1.pl b/challenge-219/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..4d243b0b0b
--- /dev/null
+++ b/challenge-219/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 219 Task 1: Sorted Squares
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use lib '.';
+use TestExtractor;
+
+sub sorted_squares {
+    return sort { $a <=> $b } map { $_ ** 2 } @_;
+}
+
+run_tests;
diff --git a/challenge-219/matthias-muth/perl/ch-2.pl b/challenge-219/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..7b3234b92d
--- /dev/null
+++ b/challenge-219/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 219 Task 2: Travel Expenditure
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( min );
+
+my @durations = ( 1, 7, 30 );
+
+sub travel_expenditure {
+    my ( $costs, $days ) = @_;
+    return 0
+        if @$days == 0;
+    return min(
+        map {
+	    my $duration = $durations[$_];
+	    $costs->[$_]
+		+ travel_expenditure( $costs,
+		    [ grep $_ >= $days->[0] + $duration, @$days ] );
+	} 0..$#{$costs}
+    );
+}
+
+run_tests;
diff --git a/challenge-219/matthias-muth/perl/challenge-219.txt b/challenge-219/matthias-muth/perl/challenge-219.txt
new file mode 100644
index 0000000000..158764bca9
--- /dev/null
+++ b/challenge-219/matthias-muth/perl/challenge-219.txt
@@ -0,0 +1,63 @@
+The Weekly Challenge - 219
+Monday, May 29, 2023
+
+
+Task 1: Sorted Squares
+Submitted by: Mohammad S Anwar
+
+You are given a list of numbers.
+Write a script to square each number in the list and return the sorted list, increasing order.
+Example 1
+
+Input: @list = (-2, -1, 0, 3, 4)
+Output: (0, 1, 4, 9, 16)
+
+Example 2
+
+Input: @list = (5, -4, -1, 3, 6)
+Output: (1, 9, 16, 25, 36)
+
+
+Task 2: Travel Expenditure
+Submitted by: Mohammad S Anwar
+
+You are given two list, @costs and @days.
+The list @costs contains the cost of three different types of travel cards you can buy.
+For example @costs = (5, 30, 90)
+Index 0 element represent the cost of  1 day  travel card.
+Index 1 element represent the cost of  7 days travel card.
+Index 2 element represent the cost of 30 days travel card.
+
+The list @days contains the day number you want to travel in the year.
+For example: @days = (1, 3, 4, 5, 6)
+The above example means you want to travel on day 1, day 3, day 4, day 5 and day 6 of the year.
+
+Write a script to find the minimum travel cost.
+Example 1:
+
+Input: @costs = (2, 7, 25)
+       @days  = (1, 5, 6, 7, 9, 15)
+Output: 11
+
+On day 1, we buy a one day pass for 2 which would cover the day 1.
+On day 5, we buy seven days pass for 7 which would cover days 5 - 9.
+On day 15, we buy a one day pass for 2 which would cover the day 15.
+
+So the total cost is 2 + 7 + 2 => 11.
+
+Example 2:
+
+Input: @costs = (2, 7, 25)
+       @days  = (1, 2, 3, 5, 7, 10, 11, 12, 14, 20, 30, 31)
+Output: 20
+
+On day 1, we buy a seven days pass for 7 which would cover days 1 - 7.
+On day 10, we buy a seven days pass for 7 which would cover days 10 - 14.
+On day 20, we buy a one day pass for 2 which would cover day 20.
+On day 30, we buy a one day pass for 2 which would cover day 30.
+On day 31, we buy a one day pass for 2 which would cover day 31.
+
+So the total cost is 7 + 7 + 2 + 2 + 2 => 20.
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 4th June 2023.