Merge pull request #8338 from MatthiasMuth/muthm-224

Challenge 224 solutions in Perl by Matthias Muth

6 files changed, 607 insertions, 130 deletions

diff --git a/challenge-224/matthias-muth/README.md b/challenge-224/matthias-muth/README.md
index 7bb3fda7ac..83e1917ebf 100644
--- a/challenge-224/matthias-muth/README.md
+++ b/challenge-224/matthias-muth/README.md
@@ -1,152 +1,248 @@
-# Sieves and Coins
-**Challenge 223 solutions in Perl by Matthias Muth**
+# Addictive additive
+**Challenge 224 solutions in Perl by Matthias Muth**
 
-## Task 1: Count Primes
+## Task 1: Special Notes
 
-> You are given a positive integer, $n.<br/>
-> Write a script to find the total count of primes less than or equal to the given integer.<br/>
-
-This looks very straightforward: get an array of prime numbers and return its length.<br/>
-The only question is how to get the prime numbers between 2 and *n*.
-
-If the number *n* is not too high, the '[Sieve of Eratosthenes](https://en.wikipedia.org/wiki/Sieve_of_Eratosthenes)'
-is a fairly simple and easy to implement algorithm to find prime numbers up to a limit *n*.<br/>
-Its advantage is that it does not need any divisions,
-and it has a runtime complexity of *O*( *n* log log *n* ),
-which probably makes it faster than using a prime factorization for each candidate number.
-
-Only if `n` gets larger it can run into memory issues.
-But we are talking about *very* large numbers here,
-since we are only limited by the RAM available for running our program,
-and the RAM usage rises linearly with *n*
-(one integer for each added number checked,
-which might even be reduced to one *bit* per number).<br/>
-So let's not worry too much about it,
-also knowing that the challenge examples are up to *n* = 20 only.
+> You are given two strings, $source and $target.<br/>
+> Write a script to find out if using the characters (only once) from source, a target string can be created.<br/>
+> <br/>
+> Example 1<br/>
+> Input: $source = "abc"<br/>
+>        $target = "xyz"<br/>
+> Output: false<br/>
+> <br/>
+> Example 2<br/>
+> Input: $source = "scriptinglanguage"<br/>
+>        $target = "perl"<br/>
+> Output: true<br/>
+> <br/>
+> Example 3<br/>
+> Input: $source = "aabbcc"<br/>
+>        $target = "abc"<br/>
+> Output: true<br/>
+
+Again, I let the magical Perl regex engine do the work for me.<br/>
+The idea is the same as in my solution to Challenge 221 Task 1 'Good Strings'
+([read here](https://github.com/MatthiasMuth/perlweeklychallenge-club/muthm-221/challenge-221/matthias-muth/README.md)).<br/>
+
+What seems to be a bit counterintuitive at first,
+is that we match the `$source` (all the possible letters) against the `$target` word,
+not vice versa!
+
+We need to sort the `$source` characters first.<br/>
+Then we to turn the `$target` characters into a regular expression.
+This regular expression will match those characters from `$source`
+that are contained in the `$target` word.
+All other characters from `$source` that are not needed
+will be matched by `.*` patterns and ignored.
+
+To illustrate this, here is how Example 2 is solved using a pattern match:
+```
+special_notes( 'scriptinglanguage', 'perl' )
+    ordered source: 'aacegggiilnnprstu'
+    target pattern: qr/^.*e.*l.*p.*r.*$/
+    pattern match:  'aacegggiilnnprstu' =~ /^.*e.*l.*p.*r.*$/
+```
 
-The big advantage for us is that it computes and returns
-the whole set of prime numbers up to *n*.
-All that is left to do is to count them!
+What is left for us is to prepare the sorted source and the pattern.<br/>
+Not a big deal:
+```perl
+    my $ordered_chars = join "", sort split '', $source;
+    my $pattern = '^.*' . join( '.*', sort split '', $target ) . '.*$';
+```
 
-So here we go:
+So all in all it's actually only three lines of code,
+to which I added some debugging output
+(`vsay` is a subroutine that does the same as `say`
+if the global variable `$verbose` is set;
+it can be set using the `-v` option in my environment).<br/>
+Here is the whole thing:
 
 ```perl
-use strict;
-use warnings;
-use feature 'say';
-use feature 'signatures';
-no warnings 'experimental::signatures';
-
-use lib '.';
-use TestExtractor;
-
-use List::Util qw( first );
-
-sub eratosthenes( $n ) {
-    my @non_primes;
-    my $sqrt = sqrt( $n );
-    my $i = 2;
-    while ( $i <= $sqrt ) {
-        say "trying $i:";
-        for ( my $j = 2 * $i; $j <= $n; $j += $i ) {
-            say "    mark $j as non-prime";
-            $non_primes[$j] = 1;
-        }
-        $i = first { ! $non_primes[$_] } $i + 1 .. $n;
-        say "    next \$i to try: $i";
-    }
-    say "    $i is larger than sqrt( $n ) ($sqrt)";
-    say "returning ( ", join( " ", grep { ! $non_primes[$_] } 2..$n ), " )";
-    return grep { ! $non_primes[$_] } 2..$n;
-}
+sub special_notes {
+    my ( $source, $target ) = @_;
+    vsay "special_notes( '$source', '$target' )";
 
-eratosthenes( 20 );
-```
+    my $ordered_source = join "", sort split '', $source;
+    vsay "    ordered source: '$ordered_source'";
 
-which prints
-```
-$ ch-1.pl
-trying 2:
-    mark 4 as non-prime
-    mark 6 as non-prime
-    mark 8 as non-prime
-    mark 10 as non-prime
-    mark 12 as non-prime
-    mark 14 as non-prime
-    mark 16 as non-prime
-    mark 18 as non-prime
-    mark 20 as non-prime
-    next $i to try: 3
-trying 3:
-    mark 6 as non-prime
-    mark 9 as non-prime
-    mark 12 as non-prime
-    mark 15 as non-prime
-    mark 18 as non-prime
-    next $i to try: 5
-    5 is larger than sqrt( 20 ) (4.47213595499958)
-returning ( 2 3 5 7 11 13 17 19 )
-```
+    my $pattern = '^.*' . join( '.*', sort split '', $target ) . '.*$';
+    vsay "    target pattern: qr/$pattern/";
 
-Then the actual solution to the task is this little function:
-```perl
-sub count_primes( $n ) {
-    return scalar eratosthenes( $n );
+    vsay "    pattern match:  '$ordered_source' =~ /$pattern/";
+    return $ordered_source =~ /${pattern}/ // 0;
 }
 ```
 
-## Task 2: Box Coins
+## Task 2: Additive Number
 
-> You are given an array representing box coins, @box.<br/>
-> Write a script to collect the maximum coins until you took out all boxes.
-> If we pick box[i] then we collect the coins $box[i-1] * $box[i] * $box[i+1].
-> If $box[i+1] or $box[i-1] is out of bound then treat it as 1 coin.<br/>
+> You are given a string containing digits 0-9 only.<br/>
+> Write a script to find out if the given string is additive number. An additive number is a string whose digits can form an additive sequence.<br/>
+> A valid additive sequence should contain at least 3 numbers. Except the first 2 numbers, each subsequent number in the sequence must be the sum of the preceding two.<br/>
 > <br/>
 > Example 1:<br/>
-> Input: @box = (3, 1, 5, 8)<br/>
-> Output: 167<br/>
-> Step 1: pick box [i=1] and collected coins 3 * 1 * 5 => 15.  Boxes available (3, 5, 8).<br/>
-> Step 2: pick box [i=1] and collected coins 3 * 5 * 8 => 120. Boxes available (3, 8).<br/>
-> Step 3: pick box [i=0] and collected coins 1 * 3 * 8 => 24.  Boxes available (8).<br/>
-> Step 4: pick box [i=0] and collected coins 1 * 8 * 1 => 8.   No more box available.<br/>
+> Input: $string = "112358"<br/>
+> Output: true<br/>
+> The additive sequence can be created using the given string digits: 1,1,2,3,5,8<br/>
+> 1 + 1 => 2<br/>
+> 1 + 2 => 3<br/>
+> 2 + 3 => 5<br/>
+> 3 + 5 => 8<br/>
 > <br/>
 > Example 2:<br/>
-> Input: @box = (1, 5)<br/>
-> Output: 10<br/>
-> Step 1: pick box [i=0] and collected coins 1 * 1 * 5 => 5. Boxes available (5).<br/>
-> Step 2: pick box [i=0] and collected coins 1 * 5 * 1 => 5. No more box available.<br/>
-
-We need to find out with which box to start.
-It is the one that delivers the highest sum from taking this coin
-*and* from finding the highest number possible from taking the rest of the coins in the right order.
-
-A typical scenario for a recursive solution!
-
-The stop condition is met when there is ony one coin.
-Then it's obvious which one to take.
-
-If there is more than one coin, we use a `map` call
-to compute the maximum achievable value for all coins,
-just as described:
-multiply the coin with its neighbors (if they exist),
-and do the recursive call for all coins but the current one.<br/>
-
-And of course we return the maximum of this list.
-
+> Input: $string = "12345"<br/>
+> Output: false<br/>
+> No additive sequence can be created using the given string digits.<br/>
+> <br/>
+> Example 3:<br/>
+> Input: $string = "199100199"<br/>
+> Output: true<br/>
+> The additive sequence can be created using the given string digits: 1,99,100,199<br/>
+>  1 +  99 => 100<br/>
+> 99 + 100 => 199<br/>
+
+In this task, we need to choose the first two numbers of the sequence.<br/>
+Depending on that choice, we will find a continuation of the sequence
+in the remaining string, or we won't.
+
+So how do we choose the first two numbers?<br/>
+We start with the first number having one digit, then two digits, and so on.<br/>
+With each first number chosen, we then choose the second number,
+again first using one digit, then two digits and so on. 
+
+The maximum number of digits to use for the first and then the second number
+is what took me longest to think about.<br/>
+For the first number, it is relatively clear that
+* we need to leave at least on digit for the second number,
+* the sum will have at least the same number of digits that the first number has.
+
+So if *len* is the length of the whole string, we can split it up between
+the length of the first number *len1*, the minimum length of the second number *1*,
+and the minimum length of the sum, which is also *len1*:<br/>
+&nbsp;&nbsp; *len1* + 1 + *len1* <= *len* <br/>
+which makes<br/>
+&nbsp;&nbsp; *len1* <= ( *len* - 1 ) / 2.
+    
+For the length of the second number, *len2*, things are less obvious.<br/>
+We can assume that the sum always has *at least* as many digits as the longer one
+of the first and second number.<br>
+&nbsp;&nbsp; *len1* + *len2* + max( *len1*, *len2* ) <= *len* <br/>
+which is the same as<br/>
+&nbsp;&nbsp; <*len1* + *len2* + *len1* <= *len* **and** *len1* + *len2* + *len2* <= *len* <br/>
+which transforms to<br/>
+&nbsp;&nbsp; *len2* <= *len* - 2 * *len1* **and** *len2* <= ( *len* - *len1* ) / 2<br/>
+which means for *len2*:<br/>
+&nbsp;&nbsp; *len2* <= min( *len* - 2 * *len1*, ( *len* - *len1* ) / 2 ).
+
+We choose the lengths of the first and second number using two nested loops.<br/>
+Inside the loop body we extract these numbers,
+and we check whether the rest of the string starts with the sum of the two.<br/>
+We use a regular expression for this,
+at the same time removing that sum from the rest string if it matched.<br/>
+We do the checking and removing sums in a loop until we don't find a match
+or the string is completely used.
+
+We can return from the subroutine onece we find a complete match.
+But for demonstration, when `$verbose` is set, we continue going through
+the rest ofcombinations, creating some nice output to see that
+everything works nicely.
+
+This is the whole subroutine:
 ```perl
-sub box_coins {
-    my ( @box ) = @_;
-
-    return $box[0]
-        if @box == 1;
-
-    return max( map {
-        ( $box[$_]
-            * ( $_ > 0     ? $box[ $_ - 1 ] : 1 )
-            * ( $_ < $#box ? $box[ $_ + 1 ] : 1 ) )
-        + box_coins( @box[ 0 .. $_ - 1, $_ + 1 .. $#box ] );
-    } 0..$#box );
+sub additive_number {
+    my ( $string ) = @_;
+    vsay "additive_number( '$string' )";
+
+    my $len = length $string;
+    my $is_additive_number = 0;
+    for my $len1 ( 1 .. int( ( $len - 1 ) / 2 ) ) {
+        vsay "    len1: $len1, trying len2 1 .. min( ",
+            $len - 2 * $len1, ", ",
+            int( ( $len - $len1 ) / 2 ), " )";
+        for my $len2 (
+            1 .. min( $len - 2 * $len1, int( ( $len - $len1 ) / 2 ) ) )
+        {
+            my $n1 = substr $string, 0, $len1;
+            my $n2 = substr $string, $len1, $len2;
+            my $rest = substr $string, $len1 + $len2;
+            vsay "        trying $n1 and $n2, leaving '$rest'";
+            while ( $rest ne "" ) {
+                my $sum = $n1 + $n2;
+                $rest =~ s/^$sum// or do {
+                    vsay "            no match for sum $sum";
+                    last;
+                };
+                vsay "            sum $sum found";
+                ( $n1, $n2 ) = ( $n2, $sum );
+            }
+            if ( $rest eq "" ) {
+                return 1
+                    unless $verbose;
+                vsay "            SUCCESS!";
+                $is_additive_number = 1;
+            }
+        }
+    }
+    return $is_additive_number;
 }
 ```
 
+With *$verbose* set, it produces this output for the examples:
+```
+additive_number( '112358' )
+    len1: 1, trying len2 1 .. min( 4, 2 )
+        trying 1 and 1, leaving '2358'
+            sum 2 found
+            sum 3 found
+            sum 5 found
+            sum 8 found
+            SUCCESS!
+        trying 1 and 12, leaving '358'
+            no match for sum 13
+    len1: 2, trying len2 1 .. min( 2, 2 )
+        trying 11 and 2, leaving '358'
+            no match for sum 13
+        trying 11 and 23, leaving '58'
+            no match for sum 34
+additive_number( '12345' )
+    len1: 1, trying len2 1 .. min( 3, 2 )
+        trying 1 and 2, leaving '345'
+            sum 3 found
+            no match for sum 5
+        trying 1 and 23, leaving '45'
+            no match for sum 24
+    len1: 2, trying len2 1 .. min( 1, 1 )
+        trying 12 and 3, leaving '45'
+            no match for sum 15
+additive_number( '199100199' )
+    len1: 1, trying len2 1 .. min( 7, 4 )
+        trying 1 and 9, leaving '9100199'
+            no match for sum 10
+        trying 1 and 99, leaving '100199'
+            sum 100 found
+            sum 199 found
+            SUCCESS!
+        trying 1 and 991, leaving '00199'
+            no match for sum 992
+        trying 1 and 9910, leaving '0199'
+            no match for sum 9911
+    len1: 2, trying len2 1 .. min( 5, 3 )
+        trying 19 and 9, leaving '100199'
+            no match for sum 28
+        trying 19 and 91, leaving '00199'
+            no match for sum 110
+        trying 19 and 910, leaving '0199'
+            no match for sum 929
+    len1: 3, trying len2 1 .. min( 3, 3 )
+        trying 199 and 1, leaving '00199'
+            no match for sum 200
+        trying 199 and 10, leaving '0199'
+            no match for sum 209
+        trying 199 and 100, leaving '199'
+            no match for sum 299
+    len1: 4, trying len2 1 .. min( 1, 2 )
+        trying 1991 and 0, leaving '0199'
+            no match for sum 1991
+```
+
 #### **Thank you for the challenge!**
diff --git a/challenge-224/matthias-muth/blog.txt b/challenge-224/matthias-muth/blog.txt
new file mode 100644
index 0000000000..4a7d0d38c2
--- /dev/null
+++ b/challenge-224/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-224/challenge-224/matthias-muth#readme
diff --git a/challenge-224/matthias-muth/perl/TestExtractor.pm b/challenge-224/matthias-muth/perl/TestExtractor.pm
new file mode 100644
index 0000000000..6f368d9b5d
--- /dev/null
+++ b/challenge-224/matthias-muth/perl/TestExtractor.pm
@@ -0,0 +1,227 @@
+#
+#       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 List::Util qw( any );
+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 ) . " ) "
+	    . ( ( @$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)/
+	    && defined $output[0] )
+	{
+	    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*
+	    ^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} ? "( $_ )" : $_ );
+        };
+    }
+
+    # 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-224/matthias-muth/perl/ch-1.pl b/challenge-224/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..a082fe91f7
--- /dev/null
+++ b/challenge-224/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 224 Task 1: Special Notes
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use lib '.';
+use TestExtractor;
+
+sub special_notes {
+    my ( $source, $target ) = @_;
+    vsay "special_notes( '$source', '$target' )";
+
+    my $ordered_source = join "", sort split '', $source;
+    vsay "    ordered source: '$ordered_source'";
+
+    my $pattern = '^.*' . join( '.*', sort split '', $target ) . '.*$';
+    vsay "    target pattern: qr/$pattern/";
+
+    vsay "    pattern match:  '$ordered_source' =~ /$pattern/";
+    return $ordered_source =~ /${pattern}/ // 0;
+}
+
+run_tests;
diff --git a/challenge-224/matthias-muth/perl/ch-2.pl b/challenge-224/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..86be046268
--- /dev/null
+++ b/challenge-224/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,57 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 224 Task 2: Additive Number
+#
+#       Perl solution by Matthias Muth.
+#
+
+use strict;
+use warnings;
+use feature 'say';
+
+use lib '.';
+use TestExtractor;
+
+use List::Util qw( min );
+
+sub additive_number {
+    my ( $string ) = @_;
+    vsay "additive_number( '$string' )";
+
+    my $len = length $string;
+    my $is_additive_number = 0;
+    for my $len1 ( 1 .. int( ( $len - 1 ) / 2 ) ) {
+	vsay "    len1: $len1, trying len2 1 .. min( ",
+	    $len - 2 * $len1, ", ",
+	    int( ( $len - $len1 ) / 2 ), " )";
+	for my $len2 (
+	    1 .. min( $len - 2 * $len1, int( ( $len - $len1 ) / 2 ) ) )
+	{
+	    my $n1 = substr $string, 0, $len1;
+	    my $n2 = substr $string, $len1, $len2;
+	    my $rest = substr $string, $len1 + $len2;
+	    vsay "        trying $n1 and $n2, leaving '$rest'";
+	    while ( $rest ne "" ) {
+		my $sum = $n1 + $n2;
+		$rest =~ s/^$sum// or do {
+		    vsay "            no match for sum $sum";
+		    last;
+		};
+		vsay "            sum $sum found";
+		( $n1, $n2 ) = ( $n2, $sum );
+	    }
+	    if ( $rest eq "" ) {
+		return 1
+		    unless $verbose;
+		vsay "            SUCCESS!";
+		$is_additive_number = 1;
+	    }
+	}
+    }
+    return $is_additive_number;
+}
+
+run_tests;
diff --git a/challenge-224/matthias-muth/perl/challenge-224.txt b/challenge-224/matthias-muth/perl/challenge-224.txt
new file mode 100644
index 0000000000..48cffa88e9
--- /dev/null
+++ b/challenge-224/matthias-muth/perl/challenge-224.txt
@@ -0,0 +1,64 @@
+The Weekly Challenge - 224
+Monday, Jul 3, 2023
+
+
+Task 1: Special Notes
+Submitted by: Mohammad S Anwar
+
+You are given two strings, $source and $target.
+Write a script to find out if using the characters (only once) from source, a target string can be created.
+Example 1
+
+Input: $source = "abc"
+       $target = "xyz"
+Output: false
+
+Example 2
+
+Input: $source = "scriptinglanguage"
+       $target = "perl"
+Output: true
+
+Example 3
+
+Input: $source = "aabbcc"
+       $target = "abc"
+Output: true
+
+
+Task 2: Additive Number
+Submitted by: Mohammad S Anwar
+
+You are given a string containing digits 0-9 only.
+Write a script to find out if the given string is additive number. An additive number is a string whose digits can form an additive sequence.
+A valid additive sequence should contain at least 3 numbers. Except the first 2 numbers, each subsequent number in the sequence must be the sum of the preceding two.
+
+Example 1:
+
+Input: $string = "112358"
+Output: true
+
+The additive sequence can be created using the given string digits: 1,1,2,3,5,8
+1 + 1 => 2
+1 + 2 => 3
+2 + 3 => 5
+3 + 5 => 8
+
+Example 2:
+
+Input: $string = "12345"
+Output: false
+
+No additive sequence can be created using the given string digits.
+
+Example 3:
+
+Input: $string = "199100199"
+Output: true
+
+The additive sequence can be created using the given string digits: 1,99,100,199
+ 1 +  99 => 100
+99 + 100 => 199
+
+
+Last date to submit the solution 23:59 (UK Time) Sunday 9th July 2023.