Merge pull request #8511 from MatthiasMuth/muthm-228

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

6 files changed, 820 insertions, 99 deletions

diff --git a/challenge-228/matthias-muth/README.md b/challenge-228/matthias-muth/README.md
index 3cf35f627b..1705fce596 100644
--- a/challenge-228/matthias-muth/README.md
+++ b/challenge-228/matthias-muth/README.md
@@ -1,122 +1,273 @@
-# Friday XIII
-**Challenge 227 solutions in Perl by Matthias Muth**
+# Fast empty arrays, and the non-unique meaning of 'unique'
+**Challenge 228 Task 1 and 2 solutions in Perl by Matthias Muth**
 
-## Task 1: Friday 13th
+## Task 1: Unique Sum
 
-> You are given a year number in the range 1753 to 9999.<br/>
-> Write a script to find out how many dates in the year are Friday 13th, assume that the current Gregorian calendar applies.<br/>
+> You are given an array of integers.<br/>
+> Write a script to find out the sum of unique elements in the given array.<br/>
 > <br/>
-> Example<br/>
-> Input: $year = 2023<br/>
-> Output: 2<br/>
-> Since there are only 2 Friday 13th in the given year 2023 i.e. 13th Jan and 13th Oct.<br/>
-
-Looking for an easy way to get the weekday for a given date,
-the `Time::Piece` core module is an obvious choice.
-
-`Time::Piece`'s typical usage is for dealing with 'current' times,
-which are returned by the `localtime` and `gmtime` subroutines when called without parameter.
-If we want to supply a different date with them,
-we need to compute Unix epoch time value to do so.
-We will look into that later.
-
-But there is also the `Time::Piece->strptime(STRING, FORMAT)` subroutine that works as a constructor
-for `Time::Piece` objects.
-We hand in a date string like `"2023-07-13"`, and a format of `'%Y-%m-%d'`,
-and there we have our time object.
-
-So everything in one statement (but not on one line, to make it more readable!):
-- month numbers from 1 to 12,
-- use a `grep` code block to create the `Time::Piece` objects on the fly,
-and select those who return a day_of_week of 5 (Friday),
--  use `scalar` to put `grep` into a scalar context
-so it returns the number of elements found instead of the list.
+> Example 1<br/>
+> Input: @int = (2, 1, 3, 2)<br/>
+> Output: 4<br/>
+> In the given array we have 2 unique elements (1, 3).<br/>
+> <br/>
+> Example 2<br/>
+> Input: @int = (1, 1, 1, 1)<br/>
+> Output: 0<br/>
+> In the given array no unique element found.<br/>
+> <br/>
+> Example 3<br/>
+> Input: @int = (2, 1, 3, 4)<br/>
+> Output: 10<br/>
+> In the given array every element is unique.<br/>
+
+I think that the lesson that this task wants to teach us is
+that the word 'unique' has several distinct (pun intended!) meanings.<br/>
+A Wikipedia search tells us this:
+>Unique primarily refers to:<br/>
+>    * Uniqueness, a state or condition wherein something is **unlike anything else**<br/>
+>    * In mathematics and logic, a unique object is the **only object** with a certain property,
+see Uniqueness quantification<br/>
+
+(highlighting by me).
+
+Most of the times when we talk about extracting 'the unique elements' of a list
+we think Unix `sort | uniq`, and what we want to get is *every* number from the list,
+but each one only once.<br/>
+Actually this means that every number in our *resulting list* is 'unique',
+in the sense that is exists only once.
+
+But in this task, we are supposed to extract the numbers that exist only once
+already in the *input list* (and thus are 'unique' there!).
+
+So we cannot use `List::Util`'s `uniq` (or better `uniq_int`) function for this.<br/>
+But going through the list of functions in `List::MoreUtils`,
+we find the `singleton` function, which is exactly what we need.
 
+So we can make our life simple:
 ```perl
 use v5.36;
-use Time::Piece;
-sub friday_13th( $year ) {
-    return scalar grep {
-        Time::Piece->strptime( "$year-$_-13", "%Y-%m-%d" )->day_of_week == 5
-    } 1..12;
+use List::Util qw( sum );
+use List::MoreUtils qw( singleton );
+
+sub unique_sum( @int ) {
+    return sum( singleton @int ) // 0;
 }
 ```
+We make sure that we return a zero instead of `undef`
+when `singleton` returns an empty list
+and `sum` has nothing to sum up.
+
+If you don't want to install `List::MoreUtils` from CPAN,
+here is the more 'classical' solution
+(still using `sum` from the `List::Util`core module):
 
-Now maybe `strptime` is not the fastest solution, 
-and we could use `timegm` from `Time::Local` to create our dates
-without the need of parsing a string with a format.
-But using `strptime` like above looks much clearer to me than
-converting month numbers from 1..12 to 0..11 and years to be offsets from 1900,
-which would be necessary if we used `timegm`:
 ```perl
 use v5.36;
-use Time::Local;
-use Time::Piece;
-sub friday_13th( $year ) {
-    return scalar grep {
-        gmtime( timegm( 0, 0, 0, 13, $_ - 1, $year - 1900 ) )->day_of_week == 5
-     } 1..12;
+use List::Util qw( sum );
+
+sub unique_sum_core_only( @int ) {
+    my %frequencies;
+    $frequencies{$_}++
+        for @int;
+    return sum(
+        grep { $frequencies{$_} == 1 } keys %frequencies
+    ) // 0;
 }
 ```
-It's also that we would be jumping between domains
-(`localtime`/`gmtime` needing that 6-element list, returning an epoch time value,
-then we create a Time::Piece object from that),
-which does not really make it obvious what is going on.<br/>
-I prefer the first version! :-)
 
-## Task 2: Roman Maths
+## Task 2: Empty Array
 
-> Write a script to handle a 2-term arithmetic operation expressed in Roman numeral.<br/>
+> You are given an array of integers in which all elements are unique.<br/>
+> Write a script to perform the following operations until the array is empty and return the total count of operations.<br/>
+> &nbsp;&nbsp;&nbsp;&nbsp;If the first element is the smallest then remove it otherwise move it to the end.<br/>
 > <br/>
-> Example<br/>
-> IV + V     => IX<br/>
-> M - I      => CMXCIX<br/>
-> X / II     => V<br/>
-> XI * VI    => LXVI<br/>
-> VII ** III => CCCXLIII<br/>
-> V - V      => nulla (they knew about zero but didn't have a symbol)<br/>
-> V / II     => non potest (they didn't do fractions)<br/>
-> MMM + M    => non potest (they only went up to 3999)<br/>
-> V - X      => non potest (they didn't do negative numbers)<br/>
-
-I'm sure it's an interesting exercise to convert Roman numerals to arabic (common) numbers
-and vice versa, but here, I am not going to reinvent the wheel.<br/>
-The `Roman` module from CPAN is my friend in this case.
-
-The more interesting aspect is how to implement the arithmetic operations
-in a more elegant way than a nested if-then-else statement.
-
-I chose a hash lookup to return an anonymous subroutine that implements
-the respective operation.
-
-The rest looks quite self-explanatory to me.<br/>
-Or is it only in my eyes???
+> Example 1<br/>
+> Input: @int = (3, 4, 2)<br/>
+> Ouput: 5<br/>
+> Operation 1: move 3 to the end: (4, 2, 3)<br/>
+> Operation 2: move 4 to the end: (2, 3, 4)<br/>
+> Operation 3: remove element 2: (3, 4)<br/>
+> Operation 4: remove element 3: (4)<br/>
+> Operation 5: remove element 4: ()<br/>
+> <br/>
+> Example 2<br/>
+> Input: @int = (1, 2, 3)<br/>
+> Ouput: 3<br/>
+> Operation 1: remove element 1: (2, 3)<br/>
+> Operation 2: remove element 2: (3)<br/>
+> Operation 3: remove element 3: ()<br/>
+
+Let's start with a literal implementation of the algorithm that is described.<br/>
+We count the operations in `$n_ops`.<br/>
+In a loop, we either shift the first element away, or we push it to the end.
 
 ```perl
 use v5.36;
-use Roman;
-
-my %ops = (
-    '+'  => sub { $_[0] + $_[1] },
-    '-'  => sub { $_[0] - $_[1] },
-    '*'  => sub { $_[0] * $_[1] },
-    '/'  => sub { $_[0] / $_[1] },
-    '**' => sub { $_[0] ** $_[1] },
-);
-
-sub roman_maths( @input ) {
-    my $result = $ops{$input[1]}->( arabic( $input[0] ), arabic( $input[2] ) );
-    return
-        $result == 0
-            ? "nulla (they knew about zero but didn't have a symbol)" :
-        $result != int( $result )
-            ? "non potest (they didn't do fractions)" :
-        $result > 3999
-            ? "non potest (they only went up to 3999)" :
-        $result < 0
-            ? "non potest (they didn't do negative numbers)" :
-        Roman( $result );
+use List::Util qw( min );
+
+sub empty_array_1( @int ) {
+    my $n_ops = 0;
+    while ( @int ) {
+        $n_ops++;
+        if ( $int[0] == min @int ) {
+            shift @int;
+        }
+        else {
+            push @int, shift @int;
+        }
+    }
+    return $n_ops;
 }
 ```
 
+Looking closer at what is happening,
+I find that all numbers from the start of the list up to the list's lowest number
+are moved to the end, one by one, before then that lowest number is removed.<br/>
+So why don't we do this in one single operation?
+
+To do so, we need to find the index of the lowest number:
+```perl
+        my $min = $int[0];
+        my $index = 0;
+        for ( 1..$#int ) {
+            if ( $int[$_] < $min ) {
+                $index = $_;
+                $min = $int[$_];
+            }
+        }
+```
+Actually, finding the index of a given element in the array is something that has been
+invented and optimized before.
+So let's use this version, which is much easier on the eyes
+(sorry, I mean 'more readable and therefore more easily maintainable'):
+```perl
+        my $min = min @int;
+        my $index = first_index { $_ == $min } @int;
+```
+Any of these two will work nicely.
+
+But in fact, I don't like that we compute the minimum of the array again and again,
+within each iteration of the loop.
+And actually, the order in which elements are removed is from the lowest to the highest,
+no matter how many operations it takes.
+Which means that we can create a sorted copy of the array once,
+and then process the 'lowest' numbers in that order.<br/>
+Like this:
+```perl
+    my @sorted = sort { $a <=> $b } @int;
+    for my $current_smallest ( @sorted ) {
+        my $index = first_index { $_ == $current_smallest } @int;
+        ...
+    }
+```
+
+Now for moving the numbers in one step, we recreate the array,
+from the numbers *right* of the smallest number,
+and putting everything that was *left* of the smallest number behind.
+We just need to be cautious about the edge case of having
+*no* numbers to the left,
+because `$index == 0` results in `$index - 1 == -1`,
+which 'wraps around' in a most unwanted way.
+```perl
+        @int = (
+            @int[ $index + 1 .. $#int ],
+            $index > 0  ? @int[ 0 .. $index - 1 ] : (),
+        );
+```
+
+Maybe the next step is a bit of overdoing it,
+but I think it is still worth it.<br/>
+The idea is to not recreate the array,
+but to use a combination of `splice` and `push`
+to modify the existing array.<br/>
+The wanted effect is to use Perl's internal optimizations
+for array operations, and to avoid copying the whole array
+over and over again within each iteration.
+
+So let's do it like that:
+```perl
+        # Move all numbers left of the smallest one to the end, in one step,
+        # 'splicing' them away at the front and re-adding (push) them at the
+        # end.
+        # We only need to do that if there actually *are* any numbers left of
+        # the smallest number.
+        push @int, splice @int, 0, $index, ()
+            if $index > 0;
+```
+After that, the smallest number is in the first position (always!),
+and can be `shift`ed away.
+```perl
+        # Remove the smallest number, which is at the front now.
+        shift @int;
+```
+
+This is the whole function now (leaving comments in the code).
+```
+use v5.36;
+use List::Util qw( min );
+use List::MoreUtils qw( first_index );
+
+sub empty_array_5( @int ) {
+    my $n_ops = 0;
+
+    # Sort the numbers, to get the order in which we will remove them,
+    # Then walk through the numbers, starting with the lowest one.
+    my @sorted = sort { $a <=> $b } @int;
+    for my $current_smallest ( @sorted ) {
+        # Find the position of our smallest number in the array.
+        my $index = first_index { $_ == $current_smallest } @int;
+
+        # Move all numbers left of the smallest one to the end, in one step,
+        # 'splicing' them away at the front and re-adding (push) them at the
+        # end.
+        # We only need to do this if there actually *are* any numbers left of
+        # the smallest number.
+        push @int, splice @int, 0, $index, ()
+            if $index > 0;
+
+        # Remove the smallest number, which is at the front now.
+        shift @int;
+
+        # What we did was worth '$index' single move operations, plus one
+        # delete operation.
+        $n_ops += $index + 1;
+    }
+    return $n_ops;
+}
+```
+
+For the small examples that we have, I probably really over-optimized my solution.
+But I ran a little benchmark, comparing the first version and the last one:
+```
+Benchmark using 10 values:
+                  Rate empty_array_5 empty_array_1
+empty_array_5  74734/s            --          -61%
+empty_array_1 192152/s          157%            --
+
+Benchmark using 50 values:
+                Rate empty_array_1 empty_array_5
+empty_array_1 3792/s            --          -25%
+empty_array_5 5046/s           33%            --
+
+Benchmark using 100 values:
+                Rate empty_array_1 empty_array_5
+empty_array_1  323/s            --          -84%
+empty_array_5 1973/s          511%            --
+
+Benchmark using 1000 values:
+                s/iter empty_array_1 empty_array_5
+empty_array_1     2.14            --          -99%
+empty_array_5 3.14e-02         6717%            --
+```
+
+It turns out that for all challenge examples, the simple first version is more efficient!
+This is probably due to the startup cost for sorting the array.<br/>
+At around 50 elements, the 'optimized' version starts being faster.
+And for a 1000 elements array, the simple version needs more than 2 seconds for one run on my laptop,
+while the optimized version does it in 31.4 milliseconds.<br/>
+More than 600 times faster!
+
+It gives me a good feeling to have a PWC solution that scales so well! :-D
+
 #### **Thank you for the challenge!**
diff --git a/challenge-228/matthias-muth/blog.txt b/challenge-228/matthias-muth/blog.txt
new file mode 100644
index 0000000000..88ff1bd463
--- /dev/null
+++ b/challenge-228/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-228/challenge-228/matthias-muth#readme

diff --git a/challenge-228/matthias-muth/perl/TestExtractor.pm b/challenge-228/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..412e2b7c1b
--- /dev/null
+++ b/challenge-228/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,243 @@
+#
+#       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 is );
+
+use Data::Dump qw( pp );
+use Getopt::Long;
+use Cwd qw( abs_path );
+use File::Basename;
+use List::Util qw( any );
+use Test2::V0;
+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 };
+
+	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} ? "( $_ )" : $_ );
+        };
+    }
+
+    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-228/matthias-muth/perl/ch-1.pl b/challenge-228/matthias-muth/perl/ch-1.pl
new file mode 100644
index 0000000000..16648ce9d8
--- /dev/null
+++ b/challenge-228/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 228 Task 1: Unique Sum
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( sum );
+use List::MoreUtils qw( singleton );
+
+sub unique_sum( @int ) {
+    return sum( singleton @int ) // 0;
+}
+
+sub unique_sum_core_only( @int ) {
+    my %frequencies;
+    $frequencies{$_}++
+        for @int;
+    return sum(
+        grep { $frequencies{$_} == 1 } keys %frequencies
+    ) // 0;
+}
+
+run_tests;
diff --git a/challenge-228/matthias-muth/perl/ch-2.pl b/challenge-228/matthias-muth/perl/ch-2.pl
new file mode 100644
index 0000000000..eb22430032
--- /dev/null
+++ b/challenge-228/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,232 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 228 Task 2: Empty Array
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use lib '.';
+BEGIN { $ENV{T2_RAND_SEED} = 228; }
+use TestExtractor;
+
+use List::Util qw( min );
+
+sub empty_array_1( @int ) {
+    # $verbose && print say "empty_array( @int )";
+    my $n_ops = 0;
+    while ( @int ) {
+        $n_ops++;
+        # $verbose && print print "Operation $n_ops: ";
+        if ( $int[0] == min @int ) {
+            # $verbose && print print "remove element $int[0]";
+            shift @int;
+        }
+        else {
+            # $verbose && print print "move $int[0] to the end";
+            push @int, shift @int;
+        }
+        # $verbose && print say ": ( ", join( ", ", @int ), " )";
+    }
+    return $n_ops;
+}
+
+sub empty_array_2( @int ) {
+    # $verbose && print say "empty_array( @int )";
+    my $n_ops = 0;
+    while ( @int ) {
+        $n_ops++;
+        # $verbose && print print "Operation $n_ops: ";
+        my $min = min @int;
+        # Remove the first element (we need to do this in any case).
+        my $first = shift @int;
+        # Add the (former) first element to the end if it is not the minimum.
+        if ( $first != $min ) {
+            push @int, $first;
+            # $verbose && print print "move $first to the end";
+        }
+        else {
+            # $verbose && print print "remove element $first";
+        }
+        # $verbose && print say " ( @int )";
+    }
+    return $n_ops;
+}
+
+sub empty_array_3a( @int ) {
+    # $verbose && print say "empty_array( @int )";
+    my $n_ops = 0;
+    while ( @int ) {
+        # Find the index of the lowest number.
+        my $min = $int[0];
+        my $index = 0;
+        for ( 1..$#int ) {
+            if ( $int[$_] < $min ) {
+                $index = $_;
+                $min = $int[$_];
+            }
+        }
+
+        # Reorder the array,
+        # moving all numbers left of the smallest number to the end in one step,
+        # also deleting (that is: not copying) the smallest number.
+        @int = (
+            @int[ $index + 1 .. $#int ],
+            $index > 0 ? @int[ 0 .. $index - 1 ] : (),
+        );
+
+        # This is worth '$index' single moving operations, plus one delete operation.
+        $n_ops += $index + 1;
+    }
+    return $n_ops;
+}
+
+use List::MoreUtils qw( first_index );
+
+sub empty_array_3b( @int ) {
+    # $verbose && print say "empty_array( @int )";
+    my $n_ops = 0;
+    while ( @int ) {
+        # Find the index of the lowest number.
+        my $min = min @int;
+        my $index = first_index { $_ == $min } @int;
+
+        # Reorder the array,
+        # moving all numbers left of the smallest number to the end in one step,
+        # also deleting (that is: not copying) the smallest number.
+        @int = (
+            @int[ $index + 1 .. $#int ],
+            $index > 0 ? @int[ 0 .. $index - 1 ] : (),
+        );
+
+        # This is worth '$index' single moving operations, plus one delete operation.
+        $n_ops += $index + 1;
+    }
+    return $n_ops;
+}
+
+sub empty_array_4( @int ) {
+    # $verbose && print say "empty_array( @int )";
+
+    # Walk through the numbers starting with the lowest one.
+    my $n_ops = 0;
+    my @sorted = sort { $a <=> $b } @int;
+    for my $current_lowest ( @sorted ) {
+        # Find the index of the current lowest number.
+        my $index = first_index { $_ == $current_lowest } @int;
+
+        # Reorder the array,
+        # starting with all numbers right of the smallest number,
+        # and putting everything that was left of the smallest number behind.
+        @int = (
+            @int[ $index + 1 .. $#int ],
+            $index > 0 ? @int[ 0 .. $index - 1 ] : (),
+        );
+        # $verbose && print say ": ( ", join( ", ", @int ), " )";
+
+        # This is worth '$index' single moving operations, plus one delete
+        # operation.
+        # $verbose && print print "Operation $n_ops: move elements up to #$index,",
+        #     " remove element $current_lowest";
+        $n_ops += $index + 1;
+    }
+    return $n_ops;
+}
+
+sub empty_array_5( @int ) {
+    # $verbose && print say "empty_array( @int )";
+
+    my $n_ops = 0;
+
+    # Sort the numbers, to get the order in which we will remove them,
+    # Then walk through the numbers, starting with the lowest one.
+    my @sorted = sort { $a <=> $b } @int;
+    for my $current_smallest ( @sorted ) {
+        # Find the position of our smallest number in the array.
+        my $index = first_index { $_ == $current_smallest } @int;
+
+        # $verbose && print print "Operation $n_ops: move elements up to #$index,",
+        #     " remove element $current_smallest";
+
+        # Move all numbers left of the smallest one to the end, in one step,
+        # 'splicing' them away at the front and re-adding (push) them at the
+        # end.
+        # We only need to do that if there actually *are* any numbers left of
+        # the smallest number.
+        push @int, splice @int, 0, $index, ()
+            if $index > 0;
+
+        # Remove the smallest number, which is at the front now.
+        shift @int;
+
+        # What we did was worth '$index' single move operations, plus one
+        # delete operation.
+        $n_ops += $index + 1;
+
+        # $verbose && print say ": ( ", join( ", ", @int ), " )";
+    }
+    return $n_ops;
+}
+
+sub empty_array( @int ) {
+    # $verbose = 1;
+    my @results = empty_array_1( @int );
+    is [ empty_array_2( @int ) ], \@results, "empty_array_2 results are the same";
+    is [ empty_array_3a( @int ) ], \@results, "empty_array_3a results are the same";
+    is [ empty_array_3b( @int ) ], \@results, "empty_array_3b results are the same";
+    is [ empty_array_4( @int ) ], \@results, "empty_array_4 results are the same";
+    is [ empty_array_5( @int ) ], \@results, "empty_array_5 results are the same";
+    return @results;
+}
+
+# run_tests;
+# exit 0;
+
+use Benchmark qw( :all :hireswallclock );
+
+sub random_list( $n ) {
+    my @a = 1..$n;
+    my @b = ();
+    while( @a ) {
+        push @b, splice @a, int(rand(@a)), 1, ()
+    };
+    return @b;
+}
+
+my @input = (
+    47,12,38,26,25,31,41,37,1,6,10,23,22,32,17,48,43,2,27,13,19,30,35,29,40,
+    11,5,18,36,33,15,46,50,28,14,45,4,21,8,42,20,16,7,39,9,24,34,49,44,3,
+);
+
+$| = 1;
+$verbose = 0;
+
+for ( 10, 50, 100, 1000 ) {
+    say "Benchmark using $_ values:";
+    my @input = random_list( $_ );
+    cmpthese( $_ > 100 ? -10 : -3, {
+        'empty_array_1' => sub { empty_array_1( @input ) },
+        # 'empty_array_2' => sub { empty_array_2( @input ) },
+        # 'empty_array_3a' => sub { empty_array_3a( @input ) },
+        # 'empty_array_3b' => sub { empty_array_3b( @input ) },
+        # 'empty_array_4' => sub { empty_array_4( @input ) },
+        'empty_array_5' => sub { empty_array_5( @input ) },
+    } );
+    say "";
+}
+
+1;
+
+__DATA__
+Test 1: Test with 10 values
+Input: @int = ( 47, 12, 38, 26, 25, 31, 41, 37, 1, 6 )
+Output: 28
+
+Test 2: Test with 50 values
+Input: @int = (47,12,38,26,25,31,41,37,1,6,10,23,22,32,17,48,43,2,27,13,19,30,35,29,40,11,5,18,36,33,15,46,50,28,14,45,4,21,8,42,20,16,7,39,9,24,34,49,44,3)
+Output: 702
+
diff --git a/challenge-228/matthias-muth/perl/challenge-228.txt b/challenge-228/matthias-muth/perl/challenge-228.txt
new file mode 100644
index 0000000000..09de3bd250
--- /dev/null
+++ b/challenge-228/matthias-muth/perl/challenge-228.txt
@@ -0,0 +1,62 @@
+The Weekly Challenge - 228

+Monday, Jul 31, 2023

+

+

+Task 1: Unique Sum

+Submitted by: Mohammad S Anwar

+

+You are given an array of integers.

+Write a script to find out the sum of unique elements in the given array.

+Example 1

+

+Input: @int = (2, 1, 3, 2)

+Output: 4

+

+In the given array we have 2 unique elements (1, 3).

+

+Example 2

+

+Input: @int = (1, 1, 1, 1)

+Output: 0

+

+In the given array no unique element found.

+

+Example 3

+

+Input: @int = (2, 1, 3, 4)

+Output: 10

+

+In the given array every element is unique.

+

+

+Task 2: Empty Array

+Submitted by: Mohammad S Anwar

+

+You are given an array of integers in which all elements are unique.

+Write a script to perform the following operations until the array is empty and return the total count of operations.

+

+If the first element is the smallest then remove it otherwise move it to the end.

+

+

+Example 1

+

+Input: @int = (3, 4, 2)

+Ouput: 5

+

+Operation 1: move 3 to the end: (4, 2, 3)

+Operation 2: move 4 to the end: (2, 3, 4)

+Operation 3: remove element 2: (3, 4)

+Operation 4: remove element 3: (4)

+Operation 5: remove element 4: ()

+

+Example 2

+

+Input: @int = (1, 2, 3)

+Ouput: 3

+

+Operation 1: remove element 1: (2, 3)

+Operation 2: remove element 2: (3)

+Operation 3: remove element 3: ()

+

+

+Last date to submit the solution 23:59 (UK Time) Sunday 6th August 2023.