Merge pull request #8824 from MatthiasMuth/muthm-237

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

6 files changed, 638 insertions, 115 deletions

diff --git a/challenge-237/matthias-muth/README.md b/challenge-237/matthias-muth/README.md
index ccbb3acebb..5b3c517925 100644
--- a/challenge-237/matthias-muth/README.md
+++ b/challenge-237/matthias-muth/README.md
@@ -1,150 +1,233 @@
-# Bills in Loops, and Loops in Arrays
+# Maximal Great Day!
 
-**Challenge 236 solutions in Perl by Matthias Muth**
+**Challenge 237 solutions in Perl by Matthias Muth**
 
-## Task 1: Exact Change
+## Task 1: Seize The Day
 
-> You are asked to sell juice each costs \$5. You are given an array of bills. You can only sell ONE juice to each customer but make sure you return exact change back. You only have \$5, \$10 and \$20 notes. You do not have any change in hand at first.<br/>
-> Write a script to find out if it is possible to sell to each customers with correct change.<br/>
-> <br/> 
+> Given a year, a month, a weekday of month, and a day of week (1 (Mon) .. 7 (Sun)), print the day.<br/>
+> <br/>
 > Example 1<br/>
-> Input: @bills = (5, 5, 5, 10, 20)<br/>
-> Output: true<br/>
-> From the first 3 customers, we collect three \$5 bills in order.<br/>
-> From the fourth customer, we collect a \$10 bill and give back a \$5.<br/>
-> From the fifth customer, we give a \$10 bill and a \$5 bill.<br/>
-> Since all customers got correct change, we output true.<br/>
+> Input: Year = 2024, Month = 4, Weekday of month = 3, day of week = 2<br/>
+> Output: 16<br/>
+> The 3rd Tue of Apr 2024 is the 16th<br/>
 > <br/>
 > Example 2<br/>
-> Input: @bills = (5, 5, 10, 10, 20)<br/>
-> Output: false<br/>
-> From the first two customers in order, we collect two \$5 bills.<br/>
-> For the next two customers in order, we collect a \$10 bill and give back a \$5 bill.<br/>
-> For the last customer, we can not give the change of \$15 back because we only have two \$10 bills.
-> Since not every customer received the correct change, the answer is false.<br/>
+> Input: Year = 2025, Month = 10, Weekday of month = 2, day of week = 4<br/>
+> Output: 9<br/>
+> The 2nd Thu of Oct 2025 is the 9th<br/>
 > <br/>
 > Example 3<br/>
-> Input: @bills = (5, 5, 5, 20)<br/>
-> Output: true<br/>
-
-My solution is based on these ideas:
-
-* We serve the customers with the smallest bills first, in order to get good change for the next ones. 
-* We keep track of our cash separately for each value, to make it easier to pay back starting with larger bills, then lower ones.
-* Whenever a customer can't be paid back his or her change it's a 'sudden death', we can return 'false' immediately. If we make it through the list, we return 'true'.
-
-And that's basically all.
-
-For sorting the customers, and for checking our cash in the right order, I define a function to sort numerically (as the default for `sort` is string comparison, which makes `"5"` larger than `"10"`):
+> Input: Year = 2026, Month = 8, Weekday of month = 5, day of week = 3<br/>
+> Output: 0<br/>
+> There isn't a 5th Wed in Aug 2026<br/>
+
+My idea for solving this task is to
+
+- get the first day of the given month,
+- check its day of week, and comparing it with the day of week we want,
+to determine how many days we need to move forward to the first such day of week,
+- then add as many weeks as needed to reach the $n$ th 'Weekday of month'.
+- Before returning the day of month of the day we found,
+make sure we haven't passed into the following month when we moved forward.
+
+For dealing with dates, I find `Time::Piece` objects much more intuitive
+than the 9-element integer list that the core functions `localtime` and `gmtime` return.
+Maybe at the time when `struct tm` was invented for early versions of Unix it was appropriate,
+but with its specification that is sometimes zero based
+(for months, 0 is January -- not really intuitive),
+sometimes one-based (days count from 1 to 31),
+and even 1900-based (years have an offset of 1900)
+it feels a bit outdated today.
+
+The only problem with `Time::Piece` is that when you want to set up an object
+with a given date and/or time, there is no constructor like
+```perl
+        Time::Piece->new( year => 2023, month => 10, day => 8 );
+```
+So we are stuck between 
+
+* using the `timegm` function from the `Time::Local` core module,<br/>
+which takes 6 parameters for time and date, with said strange offsets,
+and returns a time value in seconds,
+which we then can use to pass it into the `Time::Piece` `gmtime` constructor:
+  ```perl
+  use Time::Piece;
+  use Time::Local;
+  my $first_of_month =
+          gmtime( timegm_posix( 0,0,0, 1, $month - 1, $year - 1900 ) );
+  ```
+
+* using the `strptime` function to parse a date string (I prefer ISO format, like `"2023-10-01"`):
+  ```perl
+  my $first_of_month = Time::Piece->strptime( "$year-$month-01", "%F" );
+  ```
+  I don't like the overhead of first constructing a string,
+  and then immediately parsing it again, but it is much easier to read.
+  We also don't need to load the `Time::Local` module,
+  and we only have exactly one call per example in the task description.<br/>
+  So let's go for this one.<br/>
+  (And good that `strptime` is forgiving about not always having leading zeros, especially for the month.)
+
+Once we have a `Time::Piece` object for the first of month, it is not difficult to do the rest.<br/>
+I left the comments in the code, so I guess there's no need to repeat everything here.
 
 ```perl
-sub sort_num( @values ) {
-    return sort { $a <=> $b } @values;
+use Time::Piece;
+use Time::Seconds;
+
+sub seize_the_day( $year, $month, $weekday_of_month, $day_of_week ) {
+
+    # Set up a Time::Piece object for the first day of the month
+    # (good that strptime '%F' does not insist in leading zeros).
+    my $first_of_month = Time::Piece->strptime( "$year-$month-01", "%F" );
+
+    # The Time::Piece day_of_week method is based on 0=Sunday.
+    # We map our $day_of_week (1=Monday...7=Sunday) to that range by a '% 7'.
+    # We get to the first $day_of_week of the month by subtracting the
+    # weekday of the first of month, then adding our weekday number.
+    # If the difference is negative, another '% 7' will move it one week
+    # forward if necessary.
+    my $t = $first_of_month
+        + ( ( $day_of_week % 7 )
+            - $first_of_month->day_of_week ) % 7
+            * ONE_DAY;
+
+    # Add the number of weeks needed.
+    $t += 7 * ONE_DAY * ( $weekday_of_month - 1 );
+
+    # Make sure we still are in this month.
+    my $next_month = $first_of_month->add_months( 1 );
+    return $t->mon == $month ? $t->day_of_month : 0;
 }
 ```
 
-Then this is my solution:
+## Task 2: Maximise Greatness
 
+> You are given an array of integers.<br/>
+> Write a script to permute the give array such that you get the maximum possible greatness.<br/>
+> To determine greatness, nums[i] < perm[i] where 0 <= i < nums.length<br/>
+> <br/>
+> Example 1<br/>
+> Input: @nums = (1, 3, 5, 2, 1, 3, 1)<br/>
+> Output: 4<br/>
+> One possible permutation: (2, 5, 1, 3, 3, 1, 1) which returns 4 greatness as below:<br/>
+> nums[0] < perm[0]<br/>
+> nums[1] < perm[1]<br/>
+> nums[3] < perm[3]<br/>
+> nums[4] < perm[4]<br/>
+> <br/>
+> Example 2<br/>
+> Input: @ints = (1, 2, 3, 4)<br/>
+> Output: 3<br/>
+> One possible permutation: (2, 3, 4, 1) which returns 3 greatness as below:<br/>
+> nums[0] < perm[0]<br/>
+> nums[1] < perm[1]<br/>
+> nums[2] < perm[2]<br/>
+
+For sure we could generate all possible permutations of the numbers,
+get the score for each, and find the maximum.<br/>
+The problem is that the number of permutations rises very fast, as it is $n!$
+($n$ being the number of numbers in the array).
+Still, for the size of the example input data this probably would not matter too much. 
+
+But there is another approach that is much easier to implement than that.<br/>
+And it works -- after sorting the array -- using only one pass through the array.
+
+Let's start by sorting the numbers, highest to lowest,
+and by creating a copy of that,
+which is going to be the 'permuted' array
+(even if we will develop only exactly one permutation).
+
+For visualizing what happens, we line up the two arrays next to each other:
 ```perl
-sub exact_change( @bills ) {
-
-    # Keep a count of the bills we have, separately for each value.
-    my %cash = ();
+@nums       5   3   3   2   1   1   1
+@permuted   5   3   3   2   1   1   1
+```
+Now let's walk through the positions of the arrays, one by one.
 
-    # Serve all the customers,
-    # making sure we accept the lowest bills first, for getting change.
-    for ( sort_num @bills ) {
+For the first position (at the left), we have the same numbers, so this is a draw, not a win.
 
-        # Accept  the customer's bill.
-        ++$cash{$_};
+We don't have any higher number that we could use to win against the original number in that position, so let's do something different:<br/>
+We assign our *lowest* number to match that original number.<br/>As we are sure to lose that fight, we kind of 'sacrifice' the lowest number in order to keep better chances for winning other numbers later on. 
 
-        # We need to give this change:
-        my $change_to_return = $_ - 5;
+In the permuted array this means that we move the all entries one to the right, starting with the current position, and we move the last entry to the current position to fill in the gap that we just opened.<br/>It is kind of a 'rotate right' of the array elements, starting at the current position.  
+```perl
+@nums      *5*  3   3   2   1   1   1
+@permuted  -5-  3   3   2   1   1   1
+             \   \   \   \   \   \  /             |
+            .-\---\---\---\---\---\-
+            V  \   \   \   \   \   \
+@permuted   1   5   3   3   2   1   1
+```
+For the next rounds, we do the same:
 
-        # Starting with the highest value available,
-        # return bills that are lower than or equal to
-        # the change we need to return.
-        for ( reverse sort_num keys %cash ) {
-            while ( $_ <= $change_to_return && $cash{$_} ) {
-                --$cash{$_};
-                $change_to_return -= $_;
-            }
-        }
+-  If the next available 'permuted' number (which is always the highest available) wins against the next original number, we leave it like that.
+-  If we can't win that position, we do a 'rotate right' from that position. 
 
-        # No success if we couldn't return the correct change.
-        return 0
-            if $change_to_return > 0;
-    }
-    # Success.
-    return 1;
-}
-```
+```perl
+@nums       5  -3-  3   2   1   1   1
+@permuted   1  *5*  3   3   2   1   1
 
-## Task 2: Array Loops
+@nums       5   3  *3*  2   1   1   1
+@permuted   1   5  -3-  3   2   1   1
+                     \   \   \   \  /             |
+                    .-\---\---\---\-
+                    V  \   \   \   \
+@permuted   1   5   1   3   3   2   1
 
-> You are given an array of unique integers.<br/>
-> Write a script to determine how many loops are in the given array.<br/>
-> To determine a loop: Start at an index and take the number at array[index] and then proceed to that index and continue this until you end up at the starting index.<br/>
-> <br/>
-> Example 1<br/>
-> Input: @ints = (4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10)<br/>
-> Output: 3<br/>
-> To determine the 1st loop, start at index 0, the number at that index is 4, proceed to index 4, the number at that index is 15, proceed to index 15 and so on until you're back at index 0.<br/>
-> Loops are as below:<br/>
-> [4 15 1 6 13 5 0]<br/>
-> [3 8 7 18 9 16 12 17 2]<br/>
-> [14 11 19 10]<br/>
-> <br/>
-> Example 2<br/>
-> Input: @ints = (0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3,18,15,19)<br/>
-> Output: 6<br/>
-> Loops are as below:<br/>
-> [0]<br/>
-> [1]<br/>
-> [13 9 14 17 18 15 5 8 2]<br/>
-> [7 11 4 6 10 16 3]<br/>
-> [12]<br/>
-> [19]<br/>
-> <br/>
-> Example 3<br/>
-> Input: @ints = (9,8,3,11,5,7,13,19,12,4,14,10,18,2,16,1,0,15,6,17)<br/>
-> Output: 1<br/>
-> Loop is as below:<br/>
-> [9 4 5 7 19 17 15 1 8 12 18 6 13 2 3 11 10 14 16 0]<br/>
+@nums       5   3   3  -2-  1   1   1
+@permuted   1   5   1  *3*  3   2   1
 
-To detect a loop, we follow the 'path' of numbers, using each number as the next index, until we find the index that we started with.
+@nums       5   3   3   2  -1-  1   1
+@permuted   1   5   1   3  *3*  2   1
 
-We use a `@visited` array to mark each number on the path, to avoid running into another loop that we already detected.
+@nums       5   3   3   2   1  -1-  1
+@permuted   1   5   1   3   3  *2*  1
 
-For each index that we visit, we check whether the number at that index points does not point outside the array (using `exists`, which is shorter than checking against the array bounds).<br/>
-None of the examples has any of these, but it's always better to be on the safe side in case we use other test input.
+@nums       5   3   3   2   1   1  *1*
+@permuted   1   5   1   3   3   2  -1-
 
-So we loop through the array, trying every number as a possible first number of a loop if it was not yet visited before, either as a part of another loop or as a part of a non-loop sequence that we already tried.
+Final result:
+@permuted  -1- *5* -1- *3* *3* *2* -1-
+```
 
-In this simple version we only count the loops, we don't store them for display.<br/>So that should be all:
+The code for this solution is quite straightforward:
 
 ```perl
-sub array_loops( @ints ) {
-    my $n_loops = 0;
-    my @visited = ();
-
-    for my $start_index ( 0..$#ints ) {
-        next if $visited[$start_index];
-
-        my $i = $ints[$start_index];
-        while ( exists( $ints[$i] )
-            && ! $visited[$ints[$i]]
-            && $i != $start_index )
-        {
-            $visited[$i] = 1;
-            $i = $ints[$i];
+sub maximise_greatness( @nums ) {
+    # Sort the numbers, highest first.
+    @nums = sort { $b <=> $a } @nums;
+
+    # Our 'permuted' array starts out the same, highest values first.
+    my @permuted = @nums;
+
+    # Now we compare the corresponding numbers one by one.
+    # If the current 'attacker' value is greater than the number, that's great!
+    # (pun intended!) and we can leave the attacker in that position.
+    # If instead the 'attacker' is less or equal than the number, we have no
+    # chance of finding a better one (remember the available values are
+    # sorted highest first).
+    # We therefore move the *lowest* attacker value into that position,
+    # 'waisting it' on the number that we could not win.
+    # This keeps our best chances of winning other numbers.
+    # We also move all the rest of the permuted to the right by one position.
+    # The current attacker will then have another chance with the next number.
+
+    my $greatness = 0;
+    for ( 0..$#nums ) {
+        if ( $permuted[$_] > $nums[$_] ) {
+            ++$greatness;
+        }
+        else {
+            # Move the last element to the current position,
+            # shifting the rest to the right.
+            splice @permuted, $_, 0, pop @permuted;
         }
-
-        ++$n_loops
-            if $i == $start_index;
     }
-    return $n_loops;
+    return $greatness;
 }
 ```
 
+A solution that scales well like this makes a maximal great day!
+
 #### **Thank you for the challenge!**
diff --git a/challenge-237/matthias-muth/blog.txt b/challenge-237/matthias-muth/blog.txt
new file mode 100644
index 0000000000..cbc5a785a3
--- /dev/null
+++ b/challenge-237/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-237/challenge-237/matthias-muth#readme
diff --git a/challenge-237/matthias-muth/perl/TestExtractor.pm b/challenge-237/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..6c4e8d9b07
--- /dev/null
+++ b/challenge-237/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,257 @@
+#
+#       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 vprint vsay pp np carp croak );
+
+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 Carp;
+use Test2::V0 qw( -no_srand );
+no warnings 'experimental::signatures';
+
+our ( $verbose, %options );
+sub vprint { print @_ if $verbose };
+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*
+	    ^Out?put: \s* ( .*? ) \s*? (?=(?: ^$ | ^\S | \Z ))
+	/xmsg )
+    {
+	my ( $test, $input, $output) = ( $1, $2, $3 );
+	# vsay pp $test, $input, $output;
+
+	push @tests, { TEST => $test };
+
+	# Check whether the Input: part contains any variable sigils.
+	# If not, we try to convert '<Sequence of Words> = ...'
+	# into '$sequence_of_words = ...'.
+	# This is for specification like
+	# Input: Year = 2024, Month = 4, Weekday of month = 3, day of week = 2
+	unless ( $input =~ /[\$\@]\w+/ ) {
+	    $input =~ s{(\w+?(?: \w+?)*?)(\s*=)}{
+		my ( $var_name, $equals ) = ( $1, $2 );
+		'$' . lc ( $var_name =~ s/ /_/gr ) . $equals;
+	    }eg;
+	    # vsay "changed \$input to '$input'";
+	}
+
+	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, 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} ? "( $_ )" : $_ );
+        };
+    }
+
+    unless ( @tests ) {
+	# Try an alternative description format:
+	# <input...> => <output...>
+	my $n_examples = 0;
+	while ( $task_text =~ /^( .*? ) \s* => \s* ( .* )$/xmg ) {
+	    # vsay pp @{^CAPTURE};
+	    push @tests, {
+	        TEST => "Example " . ++$n_examples,
+		INPUT => [ split " ", $1 ],
+		OUTPUT => [ $2 ],
+		VARIABLE_NAMES => [ '@input' ],
+	    }
+	}
+    }
+
+    # 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-237/matthias-muth/perl/ch-1.pl b/challenge-237/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..f5bb34b36e
--- /dev/null
+++ b/challenge-237/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,65 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 237 Task 1: Seize The Day
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.20;
+use strict;
+use warnings;
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+use lib '.';
+use TestExtractor;
+
+use Time::Piece;
+use Time::Seconds;
+
+my @ordinals = qw( zeroth first second third fourth fifth sixth );
+
+sub seize_the_day( $year, $month, $weekday_of_month, $day_of_week ) {
+
+    # my $first_of_month =
+	# gmtime( timegm_posix( 0,0,0, 1, $month - 1, $year - 1900 ) );
+    # vsay $first_of_month->strftime( "%F is a %A" );
+
+    # Set up a Time::Piece object for the first day of the month.
+    # (Good that strptime does not insist in leading zeros!)
+    my $first_of_month = Time::Piece->strptime( "$year-$month-1", "%F" );
+    vsay $first_of_month->strftime( "%F is a %A" );
+
+    # The Time::Piece day_of_week method is based on 0=Sunday.
+    # We map our $day_of_week (1=Monday...7=Sunday) to that range by a '% 7'.
+    my $t = $first_of_month
+	+ ( ( $day_of_week % 7 )
+	    - $first_of_month->day_of_week ) % 7
+	    * ONE_DAY;
+    $month = sprintf "%02d", $month;
+    vsay $t->strftime( "first %A of $year-$month: %A %F" );
+
+    # Add the number of weeks needed.
+    $t += 7 * ONE_DAY * ( $weekday_of_month - 1 );
+
+    vsay $ordinals[$weekday_of_month] // "${weekday_of_month}th",
+	$t->strftime( " %A of $year-$month: %A %F" );
+
+    # Check whether we are in the next month already.
+    my $next_month = $first_of_month->add_months( 1 );
+
+    return $t->mon == $month ? $t->day_of_month : 0;
+}
+
+run_tests;
+
+__DATA__
+Test 1: December 2023
+Input: Year = 2023, Month = 12, Weekday of month = 3, day of week = 2
+Output: 19
+Test 2: October 2023
+Input: Year = 2023, Month = 10, Weekday of month = 1, day of week = 2
+Output: 3
diff --git a/challenge-237/matthias-muth/perl/ch-2.pl b/challenge-237/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..29d9ebed2c
--- /dev/null
+++ b/challenge-237/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,55 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 237 Task 2: Maximise Greatness
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.20;
+use strict;
+use warnings;
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+use lib '.';
+use TestExtractor;
+
+sub maximise_greatness( @nums ) {
+    # Sort the numbers, highest first.
+    @nums = sort { $b <=> $a } @nums;
+
+    # Our 'permuted' array starts out the same, highest values first.
+    my @permuted = @nums;
+
+    # Now we compare the corresponding numbers one by one.
+    # If the current 'attacker' value is greater than the number, that's great!
+    # (pun intended!) and we can leave the attacker in that position.
+    # If instead the 'attacker' is less or equal than the number, we have no
+    # chance of finding a better one (remember the available values are
+    # sorted highest first).
+    # We therefore move the *lowest* attacker value into that position,
+    # 'waisting it' on the number that we could not win.
+    # This keeps our best chances of winning other numbers.
+    # We also move all the rest of the permuted to the right by one position.
+    # The current attacker will then have another chance with the next number.
+
+    my $greatness = 0;
+    for ( 0..$#nums ) {
+        if ( $permuted[$_] > $nums[$_] ) {
+	    ++$greatness;
+	}
+	else {
+	    # Move the last element to the current position,
+	    # shifting the rest to the right.
+	    splice @permuted, $_, 0, pop @permuted;
+	}
+    }
+    vsay "permuted: ", join " ", @permuted;
+    vsay "nums:      ", join " ", @nums;
+    return $greatness;
+}
+
+run_tests;
diff --git a/challenge-237/matthias-muth/perl/challenge-237.txt b/challenge-237/matthias-muth/perl/challenge-237.txt
new file mode 100644
index 0000000000..efdb2b8963
--- /dev/null
+++ b/challenge-237/matthias-muth/perl/challenge-237.txt
@@ -0,0 +1,62 @@
+The Weekly Challenge - 237
+Monday, Oct 2, 2023
+
+
+Task 1: Seize The Day
+Submitted by: Mark Anderson
+
+Given a year, a month, a weekday of month, and a day of week (1 (Mon) .. 7 (Sun)), print the day.
+
+Example 1
+
+Input: Year = 2024, Month = 4, Weekday of month = 3, day of week = 2
+Output: 16
+
+The 3rd Tue of Apr 2024 is the 16th
+
+Example 2
+
+Input: Year = 2025, Month = 10, Weekday of month = 2, day of week = 4
+Output: 9
+
+The 2nd Thu of Oct 2025 is the 9th
+
+Example 3
+
+Input: Year = 2026, Month = 8, Weekday of month = 5, day of week = 3
+Output: 0
+
+There isn't a 5th Wed in Aug 2026
+
+
+Task 2: Maximise Greatness
+Submitted by: Mohammad S Anwar
+
+You are given an array of integers.
+Write a script to permute the give array such that you get the maximum possible greatness.
+
+To determine greatness, nums[i] < perm[i] where 0 <= i < nums.length
+
+Example 1
+
+Input: @nums = (1, 3, 5, 2, 1, 3, 1)
+Output: 4
+
+One possible permutation: (2, 5, 1, 3, 3, 1, 1) which returns 4 greatness as below:
+nums[0] < perm[0]
+nums[1] < perm[1]
+nums[3] < perm[3]
+nums[4] < perm[4]
+
+Example 2
+
+Input: @ints = (1, 2, 3, 4)
+Output: 3
+
+One possible permutation: (2, 3, 4, 1) which returns 3 greatness as below:
+nums[0] < perm[0]
+nums[1] < perm[1]
+nums[2] < perm[2]
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 8th October 2023.