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

4 files changed, 368 insertions, 137 deletions

diff --git a/challenge-344/matthias-muth/README.md b/challenge-344/matthias-muth/README.md
index 174baaf98e..93ed14b2c5 100644
--- a/challenge-344/matthias-muth/README.md
+++ b/challenge-344/matthias-muth/README.md
@@ -1,228 +1,302 @@
-# The Zero Champion
+# Take it to the Limits
 
-**Challenge 343 solutions in Perl by Matthias Muth**
+**Challenge 344 solutions in Perl by Matthias Muth**
 
-## Task 1: Zero Friend
+This week, both tasks have examples that do not really cover all the task's potential input ranges.<br/>
+I tried to implement my solutions so that they also work well with some examples that test the limits and verify the solutions' scalability.  
 
-> You are given a list of numbers.<br/>
-> Find the number that is closest to zero and return its distance to zero.
+## Task 1: Array Form Compute
+
+> You are given an array of integers, @ints and an integer, \$x.<br/>
+> Write a script to add \$x to the integer in the array-form.<br/>
+> The array form of an integer is a digit-by-digit representation stored as an array, where the most significant digit is at the 0th index.
 >
 > **Example 1**
 >
 > ```text
-> Input: @nums = (4, 2, -1, 3, -2)
-> Output: 1
->
-> Values closest to 0: -1 and 2 (distance = 1 and 2)
+> Input: @ints = (1, 2, 3, 4), $x = 12
+> Output: (1, 2, 4, 6)
 > ```
 >
 > **Example 2**
 >
 > ```text
-> Input: @nums = (-5, 5, -3, 3, -1, 1)
-> Output: 1
->
-> Values closest to 0: -1 and 1 (distance = 1)
+> Input: @ints = (2, 7, 4), $x = 181
+> Output: (4, 5, 5)
 > ```
 >
 > **Example 3**
 >
 > ```text
-> Input: @ums = (7, -3, 0, 2, -8)
-> Output: 0
->
-> Values closest to 0: 0 (distance = 0)
-> Exact zero wins regardless of other close values.
+> Input: @ints = (9, 9, 9), $x = 1
+> Output: (1, 0, 0, 0)
 > ```
 >
 > **Example 4**
 >
 > ```text
-> Input: @nums = (-2, -5, -1, -8)
-> Output: 1
->
-> Values closest to 0: -1 and -2 (distance = 1 and 2)
+> Input: @ints = (1, 0, 0, 0, 0), $x = 9999
+> Output: (1, 9, 9, 9, 9)
 > ```
 >
 > **Example 5**
 >
 > ```text
-> Input: @nums = (-2, 2, -4, 4, -1, 1)
-> Output: 1
+> Input: @ints = (0), $x = 1000
+> Output: (1, 0, 0, 0)
+> ```
+
+This tasks concept is about storing numbers as arrays of single digits. This immediately made me think of possible applications in arithmetics of *arbitrarily long numbers* like `BigInt`.
+
+Bearing this in mind, I decided that my solution should also work with 'big' numbers, especially those that that exceed the typical 64-bit limit for normal scalars.
+
+As the examples in the description are all dealing with small numbers only, I added these example to my tests:
+
+> **Own Example 1**
 >
-> Values closest to 0: -1 and 1 (distance = 1)
+> ```text
+> Input: @ints = (9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9),
+>        $x = 1
+> Output: (1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 )
 > ```
 
-I think this is one of the easiest tasks I have solved so far.
+That's 20 digits of all 9s.<br/>
+If we add 1 to it, we are getting a carryover in all positions, resulting in a 1 with 20 zeros.<br/>
+$2^{64}$ is 18,446,744,073,709,551,616, a number with 20 digits, so both above numbers exceed the $2^{64}$ limit. 
 
-The number that is 'closest to zero' has the minimum absolute value.<br/>
-This translates directly into Perl:
-`map` the numbers to their `abs` values, and return their `min`.
+> **Own Example 2**
+>
+> ```text
+> Input: @ints = (1),
+>     $x = 18446744073709551615
+> Output: (1, 8, 4, 4, 6, 7, 4, 4, 0, 7, 3, 7, 0, 9, 5, 5, 1, 6, 1, 6)
+> ```
 
-With my preferred minimal boilerplate it looks like this: 
+That is $2^{64}-1$, the largest possible unsigned integer in 64-bit environments.<br/>
+If this large number is added to the simple 1 in integer arithmetic, the result must be $2^{64}$.<br/>The example is not about whether the correct result can be expressed in the array output (of course it can!). The question is whether the implementation deals correctly with input edge cases.
 
-```perl
-use v5.36;
-use List::Util qw( min );
+Now let's talk about how exactly those big numbers can cause problems.
 
-sub zero_friend( @nums ) {
-    return min( map abs, @nums );
-}
+* If we use the value in `$x` as a permanent carryover that will be spread over the digits in `@ints`, we loop over the digits, starting with the least significant one, add the current value of `$x` to that digit, 
+  then remove the last digit of the sum from `$x` and put that digit back into `@ints`, then we continue with the shortened value of `$x`.
+
+  Problem: We can get an integer overflow when we add `$x` and the digit from `@ints`.<br/>
+  The result then is unusable.
+
+* We can reduce the number range by *first* splitting off the least significant digit. Then we only have to add two numbers in the range `0` to `9`. No problem.
+
+  *Extracting* that last digit can be done using `$sum % 10`. No problem with that either.
+
+  *Removing* the last digit is typically done using `int( $sum / 10 )`.
+
+  Problem: The division by 10 internally is implemented as a floating point operation.<br/>
+  And even if Perl uses _double precision floating point_, only integers up to around $2^{53}$ can be represented with all digits in floating point.<br/>This means that if we use the standard idiom, we risk losing correct digits that we need later if  `$x` is really big.
+
+To avoid these problems, I chose an approach where splitting off digits is done only once, and it is done on the *string representation* of `$x`, something that is very easy in Perl:
+
+```perl
+    my @add_digits = split "", $x;
 ```
 
-Note that I make use of the implicit `$_` parameter of the `abs` function if no explicit parameter is given.<br/>
-The idea is that this can be read as follows:
+In fact, this extends the task to 'Adding *two* numbers in array representation'.<br/>But we will only have to deal with numbers in the range 0 to 9. Even if we add two of them we never risk any overflow.
 
->  'map the numbers to their absolute values'
+Let's talk about the implementation:
 
-as opposed to 
+Starting with a `$index` variable pointing to the least significant digit in the `@ints` array (that's the *last* element), the following is done in a loop, counting down `$index`:
 
-> 'map each number to the result of the abs function applied on it'
+* Remove the least significant digit from `@add_digits` and add it to the current `@ints` digit.
 
-as it would be for `map abs( $_ ), @nums`.<br/>The difference is very subtle, but I prefer this slightly more functional style.
+* If that digit now is greater than or equal to 10, subtract 10, and add 1 as a carryover to the now least significant `@add_digits` digit. Take caution that the `@add_digits` array could have been emptied completely in the previous step, so maybe a single new entry has to be recreated just for this carryover.  
 
-On the other hand, I use explicit parentheses for the `min` function.<br/>That's for easier reading, too, because here, we really care about the parameters as being recognized as parameters. 
+* If `@add_digits` is empty, this ends the loop.<br/>
+  All `$x` digits have been added to the existing array digits.
 
-TIMTOSTDI - There is more than one style to do it...
+* If there are digits left in `@add_digits`, but all `@ints` digits have been processed, we can end the loop, too.<br/>We will deal with any leftover digits in `@add_digits` outside the loop.
+  
+* For the result, any leftover digits in `@add_digits` need to be prepended to the `@ints` digits.<br/>We can do so by simply returning `( @add_digits, @ints)` as the result.
 
-## Task 2: Champion Team
+This is the implementation of my solution. Note that `$ints` is an arrayref representing the `@ints`.
 
-> You have n teams in a tournament. A matrix grid tells you which team is stronger between any two teams:
-> ```text
-> If grid[i][j] == 1, then team i is stronger than team j
-> If grid[i][j] == 0, then team j is stronger than team i
-> ```
-> Find the champion team - the one with most wins, or if there is no single such team, the strongest of the teams with most wins. (You may assume that there is a definite answer.)
+
+```perl
+use v5.36;
+
+sub array_form_compute( $ints, $x ) {
+    my @add_digits = split "", $x;
+    my $index = $ints->$#*;
+    while ( @add_digits && $index >= 0 ) {
+        $ints->[$index] += pop @add_digits;
+        if ( $ints->[$index] >= 10 ) {
+            $ints->[$index] -= 10;
+            @add_digits ? ( $add_digits[-1] += 1 ) : ( $add_digits[0] = 1 );
+        }
+        --$index;
+    }
+    return ( @add_digits, $ints->@* );
+}
+```
+
+## Task 2: Array Formation
+
+> You are given two list: @source and @target.<br/>
+> Write a script to see if you can build the exact @target by putting these smaller lists from @source together in some order. You cannot break apart or change the order inside any of the smaller lists in @source.
 >
 > **Example 1**
 >
 > ```text
-> Input: @grid = (
->                  [0, 1, 1],
->                  [0, 0, 1],
->                  [0, 0, 0],
->                )
-> Output: Team 0
->
-> [0, 1, 1] => Team 0 beats Team 1 and Team 2
-> [0, 0, 1] => Team 1 beats Team 2
-> [0, 0, 0] => Team 2 loses to all
+> Input: @source = ([2,3], [1], [4])
+>        @target = (1, 2, 3, 4)
+> Output: true
+>
+> Use in the order: [1], [2,3], [4]
 > ```
 >
 > **Example 2**
 >
 > ```text
-> Input: @grid = (
->                  [0, 1, 0, 0],
->                  [0, 0, 0, 0],
->                  [1, 1, 0, 0],
->                  [1, 1, 1, 0],
->                )
-> Output: Team 3
->
-> [0, 1, 0, 0] => Team 0 beats only Team 1
-> [0, 0, 0, 0] => Team 1 loses to all
-> [1, 1, 0, 0] => Team 2 beats Team 0 and Team 1
-> [1, 1, 1, 0] => Team 3 beats everyone
+> Input: @source = ([1,3], [2,4])
+>        @target = (1, 2, 3, 4)
+> Output: false
 > ```
 >
 > **Example 3**
 >
 > ```text
-> Input: @grid = (
->                  [0, 1, 0, 1],
->                  [0, 0, 1, 1],
->                  [1, 0, 0, 0],
->                  [0, 0, 1, 0],
->                )
-> Output: Team 0
->
-> [0, 1, 0, 1] => Team 0 beats teams 1 and 3
-> [0, 0, 1, 1] => Team 1 beats teams 2 and 3
-> [1, 0, 0, 0] => Team 2 beats team 0
-> [0, 0, 1, 0] => Team 3 beats team 2
->
-> Of the teams with 2 wins, Team 0 beats team 1.
+> Input: @source = ([9,1], [5,8], [2])
+>        @target = (5, 8, 2, 9, 1)
+> Output: true
+>
+> Use in the order: [5,8], [2], [9,1]
 > ```
 >
 > **Example 4**
 >
 > ```text
-> Input: @grid = (
->                  [0, 1, 1],
->                  [0, 0, 0],
->                  [0, 1, 0],
->                )
-> Output: Team 0
->
-> [0, 1, 1] => Team 0 beats Team 1 and Team 2
-> [0, 0, 0] => Team 1 loses to Team 2
-> [0, 1, 0] => Team 2 beats Team 1 but loses to Team 0
+> Input: @source = ([1], [3])
+>        @target = (1, 2, 3)
+> Output: false
+>
+> Missing number: 2
 > ```
 >
 > **Example 5**
 >
 > ```text
-> Input: @grid = (
->                  [0, 0, 0, 0, 0],
->                  [1, 0, 0, 0, 0],
->                  [1, 1, 0, 1, 1],
->                  [1, 1, 0, 0, 0],
->                  [1, 1, 0, 1, 0],
->                )
-> Output: Team 2
->
-> [0, 0, 0, 0, 0] => Team 0 loses to all
-> [1, 0, 0, 0, 0] => Team 1 beats only Team 0
-> [1, 1, 0, 1, 1] => Team 2 beats everyone except self
-> [1, 1, 0, 0, 0] => Team 3 loses to Team 2
-> [1, 1, 0, 1, 0] => Team 4 loses to Team 2
+> Input: @source = ([7,4,6])
+>        @target = (7, 4, 6)
+> Output: true
+>
+> Use in the order: [7, 4, 6]
 > ```
 
-A bit more tricky, this one, but it can be translated into a short sequence of transformations.<br/>
-Note that in my solution, the matrix is passed into the subroutine as an arrayref `$grid`, not as an array.
+I can easily imagine a real-life puzzle like this, containing rectangular wooden pieces, similar to dominoes, bearing numbers on them. There would also be a game board with a longer sequence of numbers arranged in squares onto which the wooden pieces would be placed.
 
-- First, calculate the 'score' for each team, by adding up the number of teams that this team beats (which is the number of '1' values in the team's `$grid` row):
+If I were to complete such a puzzle using the rules of this challenge task, I would start by checking the number on the first square of the board, and then selecting only pieces that start with that number.
 
-  `     my @scores = map sum( $_->@* ), $grid->@*;`
+To make this easier for me, I would first sort the pieces into **buckets**. Each bucket would contain only pieces with the same first number and would be labelled with that number.
 
-  The 'team number' is the index of the team's `$grid` matrix row, and also of its entry in the `@scores` array.
+After placing a piece, I would check the number on the next field to be covered, and again use only pieces from the corresponding bucket. If no match was possible at any point, I would use 'backtracking' (I can't deny my programming background!), and try a different available piece from the current or possibly from a previous bucket. 
 
-- We are supposed to find 'the team with the most wins', so let's first find the highest score of all teams:
+This would reduce my search time drastically, compared to building every possible permutation of pieces and checking each one individually to see if it matches the target sequence. 
 
-  `    my $best_score = max( @scores );`
+In Perl, the buckets can easily be implement using a hash. Each hash entry will contain an arrayref referencing the list of pieces in the bucket, while its key is the first element common to all those pieces:
 
-- Next, extract the list of all teams that have this highest score.<br/>
-  `    my @best_teams = grep { $scores[$_] == $best_score } keys @scores;`
+```perl
+    my %buckets;
+    push $buckets{$_->[0]}->@*, $_
+        for $source->@*;
+```
+
+My implementation then is based on
+
+* a recursive function `can_be_formed( $buckets, $target )`<br/>that checks whether the target sequence can be formed using the pieces in the given buckets.
+* and a helper function `array_starts_with( $try, $target )`<br/>that return `true` if the `$try` sequence matches the beginning of the `$target` sequence.
 
-  These are the 'best' teams.
+This is the helper function:
 
-- Now for the most complicated part:
+```perl
+use v5.36;
+use builtin qw( true false );
+use List::Util qw( all );
 
-  If we have more than one 'best' team, we need to find 'the strongest of the teams with most wins'. The strongest clearly is the one that would beat the others in a direct match. This means that we can run a virtual 'playoff' among the best teams to find the final winner.
+sub array_starts_with( $try, $target ) {
+    return $try->@* <= $target->@*
+        && all { $target->[$_] eq $try->[$_] } keys $try->@*;
+}
+```
 
-  We declare the first team the preliminary winner. Then, all other 'best' teams challenge the current preliminary winner, in turn. The winner of each match is the new preliminary winner. The team that survives the last match is the overall winner. (Good that we were assured that there will be a definite solution, so we don't need to consider cyclic situations!)
+The `can_be_formed` recursive function first checks whether there is a bucket at all that corresponds to the first element in `$target`. If not, there is no chance of a complete match at all.
 
-  Now maybe you see how the 'playoff' corresponds to the `reduce` function:<br/>
-  There, too, we take the first value, then apply all other values in turn, letting the code bock determine the value that will be carried over into the next iteration.
+If there is a matching bucket, its pieces are tried in turn.
 
-  So we run the best teams through `reduce`, looking up in the `$grid` matrix which is the stronger one of the two teams in each iteration.<br/>
-  The last one to survive (which is the result of the `reduce` call) is our 'strongest' winning team, and we can return it to the caller:
+If a piece matches (checked using `array_starts_with`), we create a new target containing the rest of the target sequence that remains to do after the match.
 
-  `     return "Team " . reduce { $grid->[$a][$b] ? $a : $b } @best_teams;` 
+If the new target sequence is empty, we have completed a full match, and we can return `true`.
 
-Putting this together results in a solution that makes good use of some `List::Util` functions (especially `reduce`!), and that I find surprisingly concise:
+If not, we need to try the remaining pieces against the rest of the target sequence, using a recursive call.
+
+In preparation for that call, we create a new bucket list as a copy of the one we have, only that the matching piece is removed from its corresponding bucket. For this, we first do a shallow copy for all buckets. Then the bucket with the current label is replaced by a newly created one, copying all the pieces from the original bucket except the current matching piece.
+
+If the recursive call returns true, the new target can be created from the remaining pieces in the buckets, and we can return `true`, too.<br/>If not, we continue the loop with the next piece.
+
+If the loop exits after all the available pieces have been tried without finding a full match, we return `false`.
+
+Put together, this is the recursive function:
 
 ```perl
-use v5.36;
-use List::Util qw( sum max reduce );
+sub can_be_formed( $buckets, $target ) {
+    my $bucket_label = $target->[0];
+    return false
+        if ! exists $buckets->{$bucket_label};
+    for ( keys $buckets->{$bucket_label}->@* ) {
+        my $try = $buckets->{$bucket_label}[$_];
+        next unless array_starts_with( $try, $target );
+
+        # We have a match.
+        my $new_target = [ $target->@[ $try->$#* + 1 .. $target->$#* ] ];
+        
+        # Maybe even a full match.
+        return true
+            if $new_target->@* == 0;
+
+        my %new_buckets = $buckets->%*;
+        $new_buckets{$bucket_label} = [
+            $buckets->{$bucket_label}->@[
+                0 .. $_ - 1,
+                $_ + 1 .. $buckets->{$bucket_label}->$#*,
+            ]
+        ];
+
+        # Recursive call for matching the rest.
+        return true
+            if can_be_formed( \%new_buckets, $new_target );
+    }
+    return false;
+}
+```
+
+The main subroutine only creates the initial bucket list (as shown above already), and then returns the result of the first level call to `can_be_formed`. 
 
-sub champion_team( $grid ) {
-    my @scores = map sum( $_->@* ), $grid->@*;
-    my $best_score = max( @scores );
-    my @best_teams = grep { $scores[$_] == $best_score } keys @scores;
-    return "Team " . reduce { $grid->[$a][$b] ? $a : $b } @best_teams;
+```perl
+sub array_formation( $source, $target ) {
+    my %buckets;
+    push $buckets{$_->[0]}->@*, $_
+        for $source->@*;
+    return can_be_formed( \%buckets, $target );
 }
 ```
 
+For proving the efficiency of this approach, I added an own test case that consists of 12 pieces, with only one number in each piece, to form a 12 number target sequence.
+
+> **Own Example 1**
+>
+> ```text
+> Input: @source = ([1], [2], [3], [4], [5], [6], [7], [8], [9], [10], [11], [12])
+>        @target = (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
+> Output: true
+> ```
+
+If all possible permutations of the source pieces are tried, there are up to more than 479 million of them that possibly need to be checked.<br/>
+By contrast, my solution requires a total of 12 calls.<br/>I am OK with that.
+
 #### **Thank you for the challenge!**
diff --git a/challenge-344/matthias-muth/blog.txt b/challenge-344/matthias-muth/blog.txt
new file mode 100644
index 0000000000..4bba30aae6
--- /dev/null
+++ b/challenge-344/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-344/challenge-344/matthias-muth#readme
diff --git a/challenge-344/matthias-muth/perl/ch-1.pl b/challenge-344/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..b947c64866
--- /dev/null
+++ b/challenge-344/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,62 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 344 Task 1: Array Form Compute
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+sub array_form_compute( $ints, $x ) {
+
+    # Split $x into its digits.
+    my @add_digits = split "", $x;
+
+    # Start with the last digit in the array.
+    my $index = $ints->$#*;
+    while ( @add_digits && $index >= 0 ) {
+        # Add the last digit of @add_digits to the current array digit,
+        # removing it from @add_digits at the same time.
+        $ints->[$index] += pop @add_digits;
+
+        # Check and correct a carryover from the sum of the two digits.
+        # Recreate an entry in @add_digits for that carryover if needed
+        # (if @add_digits is empty).
+        if ( $ints->[$index] >= 10 ) {
+            $ints->[$index] -= 10;
+            @add_digits ? ( $add_digits[-1] += 1 ) : ( $add_digits[0] = 1 );
+        }
+
+        --$index;
+    }
+
+    # If there still are any digits left in $add_digits, they are prepended to
+    # the existing array digits.
+    return ( @add_digits, $ints->@* );
+}
+
+use Test2::V0 qw( -no_srand );
+
+is [ array_form_compute( [1 .. 4], 12 ) ], [ 1, 2, 4, 6 ],
+    'Example 1: array_form_compute( [1 .. 4], 12 ) == (1, 2, 4, 6)';
+is [ array_form_compute( [2, 7, 4], 181 ) ], [ 4, 5, 5 ],
+    'Example 2: array_form_compute( [2, 7, 4], 181 ) == (4, 5, 5)';
+is [ array_form_compute( [9, 9, 9], 1 ) ], [ 1, 0, 0, 0 ],
+    'Example 3: array_form_compute( [9, 9, 9], 1 ) == (1, 0, 0, 0)';
+is [ array_form_compute( [1, 0, 0, 0, 0], 9999 ) ], [ 1, 9, 9, 9, 9 ],
+    'Example 4: array_form_compute( [1, 0, 0, 0, 0], 9999 ) == (1, 9, 9, 9, 9)';
+is [ array_form_compute( [0], 1000 ) ], [ 1, 0, 0, 0 ],
+    'Example 5: array_form_compute( [0], 1000 ) == (1, 0, 0, 0)';
+
+is [ array_form_compute( [ ( 9 ) x 20 ], 1 ) ],
+    [ 1, ( 0 ) x 20 ],
+    "Own Example 1: twenty digits of all nines plus 1";
+
+is [ array_form_compute( [ 1 ], ~0 ) ],
+    [ split "", "18446744073709551616" ],
+    "Own Example 2: ( 1 ) plus 2^64-1";
+
+done_testing;
diff --git a/challenge-344/matthias-muth/perl/ch-2.pl b/challenge-344/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..1a7364f6ef
--- /dev/null
+++ b/challenge-344/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,94 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 344 Task 2: Array Formation
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+use builtin qw( true false );
+
+use List::Util qw( all );
+
+sub array_starts_with( $try, $target ) {
+    return $try->@* <= $target->@*
+        && all { $target->[$_] eq $try->[$_] } keys $try->@*;
+}
+
+# The available source sequences are distributed into buckets.
+# Each bucket contains all source sequences that have the same first element.
+# That first element is used as the 'label' of the bucket.
+# For example, if the target is ( 5, 8, 2, 9, 1 ), obviously the first source
+# sequence that matches needs to have a 5 as the first element.
+# We therefore only need to consider the source sequences in the bucket
+# labeled '5'.
+sub can_be_formed( $buckets, $target ) {
+    my $bucket_label = $target->[0];
+
+    # Check whether there are matching pieces to try.
+    return false
+        if ! exists $buckets->{$bucket_label};
+
+    # Try the pieces in the bucket in turn.
+    for ( keys $buckets->{$bucket_label}->@* ) {
+        my $try = $buckets->{$bucket_label}[$_];
+
+        next unless array_starts_with( $try, $target );
+
+        # We have a match. Let's see what remains to do.
+        my $new_target = [ $target->@[ $try->$#* + 1 .. $target->$#* ] ];
+
+        # We found a complete match if the target is fully covered.
+        return true
+            if $new_target->@* == 0;
+
+        # There still is something left to do.
+        # Build a new bucket list without the source sequence that we
+        # just used.
+        # All other buckets can be copied as shallow copies.
+        # The current bucket needs to be recreated with a copy of all
+        # source sequences except the current one.
+        my %new_buckets = $buckets->%*;
+        $new_buckets{$bucket_label} = [
+            $buckets->{$bucket_label}->@[
+                0 .. $_ - 1,
+                $_ + 1 .. $buckets->{$bucket_label}->$#*,
+            ]
+        ];
+
+        # Recursive call for matching the rest.
+        return true
+            if can_be_formed( \%new_buckets, $new_target );
+    }
+    return false;
+}
+
+sub array_formation( $source, $target ) {
+    my %buckets;
+    push $buckets{$_->[0]}->@*, $_
+        for $source->@*;
+    return can_be_formed( \%buckets, $target );
+}
+
+use Test2::V0 qw( -no_srand );
+
+is array_formation( [[2, 3], [1], [4]], [1 .. 4] ), T,
+    'Example 1: array_formation( [[2, 3], [1], [4]], [1 .. 4] ) is true';
+is array_formation( [[1, 3], [2, 4]], [1 .. 4] ), F,
+    'Example 2: array_formation( [[1, 3], [2, 4]], [1 .. 4] ) is false';
+is array_formation( [[9, 1], [5, 8], [2]], [5, 8, 2, 9, 1] ), T,
+    'Example 3: array_formation( [[9, 1], [5, 8], [2]], [5, 8, 2, 9, 1] ) is true';
+is array_formation( [[1], [3]], [1, 2, 3] ), F,
+    'Example 4: array_formation( [[1], [3]], [1, 2, 3] ) is false';
+is array_formation( [[7, 4, 6]], [7, 4, 6] ), T,
+    'Example 5: array_formation( [[7, 4, 6]], [7, 4, 6] ) is true';
+
+is array_formation(
+    [ [1], [2], [3], [4], [5], [6], [7], [8], [9], [10], [11], [12] ],
+    [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 ] ), T,
+    'Own Example 1: 1 to 12';
+
+done_testing;