Arrange Any Aligned Average (PWC 304)

Challenge 304 solutions in Perl by Matthias Muth

These are my Challenge 304 Task 1 and 2 solutions in Perl
for The Weekly Challenge.

Thank you, Mohammad Sajid Anwar for two more great challenges this week!

Task 1: Arrange Binary

You are given a list of binary digits (0 and 1) and a positive integer, \$n.
Write a script to return true if you can re-arrange the list by replacing at least \$n digits with 1 in the given list so that no two consecutive digits are 1 otherwise return false.

Example 1

Input: @digits = (1, 0, 0, 0, 1), $n = 1
Output: true
Re-arranged list: (1, 0, 1, 0, 1)

Example 2

Input: @digits = (1, 0, 0, 0, 1), $n = 2
Output: false

The task description contains the words 'replacing' and 'digits'.
The first thing that I think of when I hear 'replacing' in a Perl context is 'What's the regular expression that I can use?'. So here we go.

The array of digits is easily turned into a string of zeroes and ones by joining together the array elements:

    my $string = join "", $digits->@*;

Then, we match the places where we can put in ones instead of zeroes.
The condition for replacing a '0' by a '1' is that neither left of it nor right of it there is a '1' already.
We can translate this directly to a regular expression, using a negative lookbehind and a negative lookahead. Using the x modifier to make those more easily recognizable:

    $string =~ s/ (?<!1) 0 (?!1) /1/x

We cannot simply use the g modifier to replace all those zeroes in one go, because our substitutions are not taken into account for finding the next match. For sequences like '00000' we would end up with '11111', because every '0' in the original string fulfils the critera to be replaced by a '1'.
That means that we need to put the substitution into a while loop. Within the loop body, we decrement $n by one, because we were able to do a replacement.
So:

    while ( $string =~ s/ (?<!1) 0 (?!1) /1/x ) {
        --$n;
    }

In production software, or with longer strings, I would probably try to avoid restarting the search for the next match at the beginning of the string again and again. I would probably do so by setting pos $string to the place behind the recent successful replacement, before re-iterating.

For the challenge examples, this here works well enough already:

use v5.36;

sub arrange_binary( $digits, $n ) {
    my $string = join "", $digits->@*;
    while ( $string =~ s/ (?<!1) 0 (?!1) /1/x ) {
        --$n;
    }
    return $n <= 0;
}

If you have your own solution, you might try with these additional testcases:

use Test2::V0 qw( -no_srand );

is arrange_binary( [1, 0, 0, 0, 1], 1 ), T,
    'Example 1: arrange_binary( [1, 0, 0, 0, 1], 1 ) is true';
is arrange_binary( [1, 0, 0, 0, 1], 2 ), F,
    'Example 2: arrange_binary( [1, 0, 0, 0, 1], 2 ) is false';
is arrange_binary( [], 0 ), T,
    'Test 1: arrange_binary( [], 0 ) is true';
is arrange_binary( [], 1 ), F,
    'Test 2: arrange_binary( [], 1 ) is false';
is arrange_binary( [ 0 ], 1 ), T,
    'Test 3: arrange_binary( [ 0 ], 1 ) is true';
is arrange_binary( [ 1 ], 1 ), F,
    'Test 4: arrange_binary( [ 1 ], 1 ) is false';
is arrange_binary( [ 0 ], 2 ), F,
    'Test 5: arrange_binary( [ 0 ], 2 ) is false';
is arrange_binary( [0, 0], 1 ), T,
    'Test 6: arrange_binary( [0, 0], 1 ) is true';
is arrange_binary( [0, 0], 2 ), F,
    'Test 7: arrange_binary( [0, 0], 2 ) is false';
is arrange_binary( [0, 1], 1 ), F,
    'Test 8: arrange_binary( [0, 1], 1 ) is false';
is arrange_binary( [0, 0, 0], 2 ), T,
    'Test 9: arrange_binary( [0, 0, 0], 2 ) is true';
is arrange_binary( [1, 0, 0], 1 ), T,
    'Test 10: arrange_binary( [1, 0, 0], 1 ) is true';
is arrange_binary( [0, 1, 0], 1 ), F,
    'Test 11: arrange_binary( [0, 1, 0], 1 ) is false';
is arrange_binary( [0, 0, 1], 1 ), T,
    'Test 12: arrange_binary( [0, 0, 1], 1 ) is true';
is arrange_binary( [0, 0, 0, 0, 0, 0], 3 ), T,
    'Test 13: arrange_binary( [0, 0, 0, 0, 0], 3 ) is true';
is arrange_binary( [0, 0, 0, 0, 0, 0], 4 ), F,
    'Test 14: arrange_binary( [0, 0, 0, 0, 0], 4 ) is false';

done_testing;

Task 2: Maximum Average

You are given an array of integers, @ints and an integer, $n which is less than or equal to total elements in the given array.
Write a script to find the contiguous subarray whose length is the given integer, $n, and has the maximum average. It should return the average.

Example 1

Input: @ints = (1, 12, -5, -6, 50, 3), \$n = 4
Output: 12.75
Subarray: (12, -5, -6, 50)
Average: (12 - 5 - 6 + 50) / 4 = 12.75

Example 2

Input: @ints = (5), \$n = 1
Output: 5

So finding 'contiguous subarrays'.
Good that we know the length of each of those subarrays -- it's $n.
Which makes it easier, because we don't need to find all possible contiguous subarrays of the input arrays, but only those with that given length.
What we really do is a 'sliding window' search, taking the first $n elements of the array, then the $n elements starting with the second element, and so on.

In a loop, the first starting index for the sliding window is 0, of course.
The last index is the one that uses the last $n elements for the window.
If we have a window size of $n == 1, the last window starts at $ints->$#*. Generalizing from there, the last index for any $n is $ints->$#* - ( $n - 1 ).

To get the values in the window, we can simply use Perl's arrays slice construct. Starting at index $_, the window is @int[ $_ .. ( $_ + $n - 1 ) ].

I put this together into one statement, using map to iterate through the windows, sum to sum up each window, maxto find the largest window sum, and / $n to reduce that to the largest average.

In my environment, the array data are handed into the subroutine as an arrayref, so instead of @ints we have $ints pointing to the data.
I prefer using the 'Postfix Dereferencing Syntax' ($ints->@*[...]) for accessing the array data (and also $ints->$#* for the last index into that array), because I find it easier to read and more logical to write most of the times.

So here it is:

use v5.36;

use List::Util qw( sum max );

sub maximum_average( $ints, $n ) {
    return max(
        map sum( $ints->@[ $_ .. ( $_ + $n - 1 ) ] ),
            0 .. ( $ints->$#* - ( $n - 1 )  )
    ) / $n;
}

Thank you for the challenge!

Find the complete source code for both tasks, including tests, on Github.