Merge pull request #8874 from MatthiasMuth/muthm-238

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

6 files changed, 468 insertions, 199 deletions

diff --git a/challenge-238/matthias-muth/README.md b/challenge-238/matthias-muth/README.md
index 5b3c517925..c9bb67da74 100644
--- a/challenge-238/matthias-muth/README.md
+++ b/challenge-238/matthias-muth/README.md
@@ -1,233 +1,124 @@
-# Maximal Great Day!
+# Reduced Arrays, Reduced Numbers, Reduced Code
 
-**Challenge 237 solutions in Perl by Matthias Muth**
+**Challenge 238 solutions in Perl by Matthias Muth**
 
-## Task 1: Seize The Day
+This week's challenges seem to be all about '*reducing*' things.
 
-> Given a year, a month, a weekday of month, and a day of week (1 (Mon) .. 7 (Sun)), print the day.<br/>
+My solution for Task 1 uses the `reductions` function from the `List::Util` core module.<br/>Actually this *reduces* the code to one single statement.
+
+And in Task 2 we have to *reduce* numbers to their
+'[multiplicative digital root](https://en.wikipedia.org/wiki/Multiplicative_digital_root)'
+before sorting them.<br/>My solution then also *reduces* the runtime by caching those *reduced* numbers.
+
+So here is an  *'unreduced'* description of my *'reduced*' solutions. :-)
+
+## Task 1: Running Sum
+
+> You are given an array of integers.<br/>
+> Write a script to return the running sum of the given array. The running sum can be calculated as $$sum[i] = num[0] + num[1] + …. + num[i]$$.<br/>
 > <br/>
 > Example 1<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/>
+> Input: @int = (1, 2, 3, 4, 5)<br/>
+> Output: (1, 3, 6, 10, 15)<br/>
 > <br/>
 > Example 2<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/>
+> Input: @int = (1, 1, 1, 1, 1)<br/>
+> Output: (1, 2, 3, 4, 5)<br/>
 > <br/>
 > Example 3<br/>
-> 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
+> Input: @int = (0, -1, 1, 2)<br/>
+> Output: (0, -1, 0, 2)<br/>
+
+A 'running sum' is a good example for what the `reduce`function and its close relative `reductions` can do.<br/>
+
+From the `List::Util` [docs](https://perldoc.perl.org/List::Util#reduce):
+
+>```perl
+>$result = reduce { BLOCK } @list
+>```
+>Reduces `@list` by calling `BLOCK` in a scalar context multiple times, setting `$a` and `$b` each time. The first call will be with `$a` and `$b` set to the first two elements of the list, subsequent calls will be done by setting `$a` to the result of the previous call and `$b` to the next element in the list.<br/>Returns the result of the last call to the `BLOCK`. [...]
+>
+>```perl
+>@results = reductions { BLOCK } @list
+>```
+>
+>Similar to `reduce` except that it also returns the intermediate values along with the final result.<br/>The returned list will begin with the initial value for `$a`, followed by each return value from the block in order. The final value of the result will be identical to what the `reduce` function would have returned given the same block and list.
+
+The `sum` function is nothing but a specialization of `reduce`, and it can be implemented like this:
 ```perl
-        Time::Piece->new( year => 2023, month => 10, day => 8 );
+sub sum( @list ) {
+    return reduce { $a + $b } @list;
+}
 ```
-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.
+So we can use `reduce` for summing up the list elements from the first to the last.<br/>
+And if we use `reductions` instead, we also get all the intermediate results, which are exactly the
 
-```perl
-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;
+> $$    num[i] = num[0] + num[1] + …. + num[i]$$
+
+that we need to return as the result:
+
+```perl 
+use List::Util qw( reductions );
+sub running_sum( @int ) {
+    return reductions { $a + $b } @int;
 }
 ```
 
-## Task 2: Maximise Greatness
+This is almost *less* than a one-liner! :-)
 
-> 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/>
+## Task 2: Persistence Sort
+
+> You are given an array of positive integers.<br/>
+> Write a script to sort the given array in increasing order with respect to the count of steps required to obtain a single-digit number by multiplying its digits recursively for each array element. If any two numbers have the same count of steps, then print the smaller number first.<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/>
+> Input: @int = (15, 99, 1, 34)<br/>
+> Output: (1, 15, 34, 99)<br/>
+> 15 => 1 x 5 => 5 (1 step)<br/>
+> 99 => 9 x 9 => 81 => 8 x 1 => 8 (2 steps)<br/>
+> 1  => 0 step<br/>
+> 34 => 3 x 4 => 12 => 1 x 2 => 2 (2 steps)<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
-@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.
+> Input: @int = (50, 25, 33, 22)<br/>
+> Output: (22, 33, 50, 25)<br/>
+> 50 => 5 x 0 => 0 (1 step)<br/>
+> 25 => 2 x 5 => 10 => 1 x 0 => 0 (2 steps)<br/>
+> 33 => 3 x 3 => 6 (1 step)<br/>
+> 22 => 2 x 2 => 4 (1 step)<br/>
 
-For the first position (at the left), we have the same numbers, so this is a draw, not a win.
+So we need the number of steps needed for reducing each number to its single digit '[multiplicative digital root](https://en.wikipedia.org/wiki/Multiplicative_digital_root)'. Let's create a function for computing that. It contains a counter and a loop that reduces the number as long the result has more than one digit. 
 
-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. 
+For doing the actual reduction, I use `split` to separate the digits of the number, and `product` from the `List::Util` core module to multiply them with each other. Perl makes it easy to change between strings and numbers without effort.
 
-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
+use List::Util qw( product );
+sub steps_needed( $n ) {
+    my $n_steps = 0;
+    while ( $n > 9 ) {
+        ++$n_steps;
+        $n = product( split "", $n );
+    }
+    return $n_steps;
+}
 ```
-For the next rounds, we do the same:
-
--  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. 
-
-```perl
-@nums       5  -3-  3   2   1   1   1
-@permuted   1  *5*  3   3   2   1   1
 
-@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
+Next, I use a hash for storing the number of steps for each number in the list.<br/>
+I use a hash, not an array, because we don't know how big the numbers in the original list can get.<br/>
+This hash will then be used in sorting the list.
 
-@nums       5   3   3  -2-  1   1   1
-@permuted   1   5   1  *3*  3   2   1
+Perl's `sort` makes it easy to implement more complicated sorting criteria or combinations of criteria as in this case. The code block that is passed to sort compares the number of steps first, and next the numbers themselves in case that the former are equal.
 
-@nums       5   3   3   2  -1-  1   1
-@permuted   1   5   1   3  *3*  2   1
-
-@nums       5   3   3   2   1  -1-  1
-@permuted   1   5   1   3   3  *2*  1
-
-@nums       5   3   3   2   1   1  *1*
-@permuted   1   5   1   3   3   2  -1-
-
-Final result:
-@permuted  -1- *5* -1- *3* *3* *2* -1-
-```
-
-The code for this solution is quite straightforward:
+The result of the `sort` can directly be returned as the result.
 
 ```perl
-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;
-        }
-    }
-    return $greatness;
+sub persistence_sort( @int ) {
+     my %steps = map { ( $_, steps_needed( $_ ) ) } @int;
+     return sort { $steps{$a} <=> $steps{$b} || $a <=> $b } @int;
 }
 ```
 
-A solution that scales well like this makes a maximal great day!
+Actually, I appreciate how much I learned about how functional programming concepts can *reduce* the code while doing these challenges in Perl!
+
+#### Thank you for the challenge!
 
-#### **Thank you for the challenge!**
diff --git a/challenge-238/matthias-muth/blog.txt b/challenge-238/matthias-muth/blog.txt
new file mode 100644
index 0000000000..9cd6715d1d
--- /dev/null
+++ b/challenge-238/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-238/challenge-238/matthias-muth#readme
diff --git a/challenge-238/matthias-muth/perl/TestExtractor.pm b/challenge-238/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..092e0539cc
--- /dev/null
+++ b/challenge-238/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,258 @@
+#
+#       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 );
+use Carp;
+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-238/matthias-muth/perl/ch-1.pl b/challenge-238/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..5c54888045
--- /dev/null
+++ b/challenge-238/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 238 Task 1: Running Sum
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.20;
+use strict;
+use warnings;
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( reduce reductions );
+
+sub sum( @int ) {
+    return reduce { $a + $b } @int;
+}
+
+sub running_sum( @int ) {
+    # return reductions { $a + $b } @int;
+    return map sum( @int[0..$_] ), 0..$#int;
+}
+
+run_tests;
diff --git a/challenge-238/matthias-muth/perl/ch-2.pl b/challenge-238/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..c53f930633
--- /dev/null
+++ b/challenge-238/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 238 Task 2: Persistence Sort
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.20;
+use strict;
+use warnings;
+use feature 'signatures';
+no warnings 'experimental::signatures';
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( product );
+
+sub steps_needed( $n ) {
+    my $n_steps = 0;
+    while ( $n > 9 ) {
+	++$n_steps;
+	$n = product( split "", $n );
+    }
+    return $n_steps;
+}
+
+sub persistence_sort( @int ) {
+    my %steps = map { ( $_, scalar steps_needed( $_ ) ) } @int;
+    return sort { $steps{$a} <=> $steps{$b} || $a <=> $b } @int;
+}
+
+run_tests;
diff --git a/challenge-238/matthias-muth/perl/challenge-238.txt b/challenge-238/matthias-muth/perl/challenge-238.txt
new file mode 100644
index 0000000000..046771336e
--- /dev/null
+++ b/challenge-238/matthias-muth/perl/challenge-238.txt
@@ -0,0 +1,52 @@
+The Weekly Challenge - 238
+Monday, Oct 9, 2023
+
+
+Task 1: Running Sum
+Submitted by: Mohammad S Anwar
+
+You are given an array of integers.
+Write a script to return the running sum of the given array. The running sum can be calculated as sum[i] = num[0] + num[1] + …. + num[i].
+Example 1
+
+Input: @int = (1, 2, 3, 4, 5)
+Output: (1, 3, 6, 10, 15)
+
+Example 2
+
+Input: @int = (1, 1, 1, 1, 1)
+Output: (1, 2, 3, 4, 5)
+
+Example 3
+
+Input: @int = (0, -1, 1, 2)
+Output: (0, -1, 0, 2)
+
+
+Task 2: Persistence Sort
+Submitted by: Mohammad S Anwar
+
+You are given an array of positive integers.
+Write a script to sort the given array in increasing order with respect to the count of steps required to obtain a single-digit number by multiplying its digits recursively for each array element. If any two numbers have the same count of steps, then print the smaller number first.
+Example 1
+
+Input: @int = (15, 99, 1, 34)
+Output: (1, 15, 34, 99)
+
+15 => 1 x 5 => 5 (1 step)
+99 => 9 x 9 => 81 => 8 x 1 => 8 (2 steps)
+1  => 0 step
+34 => 3 x 4 => 12 => 1 x 2 => 2 (2 steps)
+
+Example 2
+
+Input: @int = (50, 25, 33, 22)
+Output: (22, 33, 50, 25)
+
+50 => 5 x 0 => 0 (1 step)
+25 => 2 x 5 => 10 => 1 x 0 => 0 (2 steps)
+33 => 3 x 3 => 9 (1 step)
+22 => 2 x 2 => 4 (1 step)
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 15th October 2023.