DEV Community: Matthias Muth

Arrange Any Aligned Average (PWC 304)

Matthias Muth — Sun, 19 Jan 2025 23:53:15 +0000

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.

Maximally Indexed Indices (PWC 298)

Matthias Muth — Sun, 08 Dec 2024 23:56:17 +0000

Challenge 298 solutions in Perl by Matthias Muth

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

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

Summary

Task 1: Maximal Square
Quite classical: nested loops for rows and columns, and then for the width of the possible square.
The trick here is to extend the square by stripes to the right and below until it doesn't match the criteria anymore.
Finding the maximum of all size on the fly is easy.

Task 2: Right Interval
Sorting the indices of the given intervals by their start_i values, resulting in indices of indices. Then go through the sorted array to more easily find the 'right' interval. Don't get mixed up by the level of indexation!

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

Task 1: Maximal Square

You are given an m x n binary matrix with 0 and 1 only.
Write a script to find the largest square containing only 1's and return it’s area.

Example 1

Input: @matrix = ([1, 0, 1, 0, 0],
                  [1, 0, 1, 1, 1],
                  [1, 1, 1, 1, 1],
                  [1, 0, 0, 1, 0])
Output: 4
Two maximal square found with same size marked as 'x':
[1, 0, 1, 0, 0]
[1, 0, x, x, 1]
[1, 1, x, x, 1]
[1, 0, 0, 1, 0]
[1, 0, 1, 0, 0]
[1, 0, 1, x, x]
[1, 1, 1, x, x]
[1, 0, 0, 1, 0]

Example 2

Input: @matrix = ([0, 1],
                  [1, 0])
Output: 1
Two maximal square found with same size marked as 'x':
[0, x]
[1, 0]
[0, 1]
[x, 0]

Example 3

Input: @matrix = ([0])
Output: 0

I chose a classical approach, using two nested loops for rows and columns.

At any given position, if the field is 1, we already have a matrix, of size 1.
Now we can try to extend our matrix by one column to the right and one row below. If all fields at the right edge of that extended matrix are 1, as well as all fields at its bottom edge, the extended matrix is a valid square. We repeat that until the test fails, or the extended matrix hits the border of the original grid.

For checking the right and bottom border for 'all ones', the all function from the List::Util core module comes in handy.

We update the maximum square width in each iteration, and return the squared maximum width (the size of the largest square) at the end.

Three nested loops, but quite straightforward:

use v5.36;
use List::Util qw( all max );

sub maximal_square( $matrix ) {
    my ( $last_r, $last_c ) = ( $matrix->$#*, $matrix->[0]->$#* );
    my $max = 0;
    for my $r ( 0..$last_r ) {
        for my $c ( 0..$last_c ) {
            next
                if $matrix->[$r][$c] != 1;
            my $w = 1;
            while ( $r + $w <= $last_r
                && $c + $w <= $last_c
                && ( all { $matrix->[ $r + $_ ][ $c + $w ] } 0 .. $w )
                && ( all { $matrix->[ $r + $w ][ $c + $_ ] } 0 .. $w - 1 ) )
            {
                ++$w;
            }
            $max = $w
                if $w > $max;
        }
    }
    return $max * $max;
}

Task 2: Right Interval

You are given an array of @intervals, where \$intervals[i] = [starti, endi] and each starti is unique.
The right interval for an interval i is an interval j such that startj >= endi and startj is minimized. Please note that i may equal j.
Write a script to return an array of right interval indices for each interval i. If no right interval exists for interval i, then put -1 at index i.

Example 1
Input: @intervals = ([3,4], [2,3], [1,2])
Output: (-1, 0, 1)
There is no right interval for [3,4].
The right interval for [2,3] is [3,4] since start0 = 3 is the smallest start that is >= end1 = 3.
The right interval for [1,2] is [2,3] since start1 = 2 is the smallest start that is >= end2 = 2.
Example 2
Input: @intervals = ([1,4], [2,3], [3,4])
Output: (-1, 2, -1)
There is no right interval for [1,4] and [3,4].
The right interval for [2,3] is [3,4] since start2 = 3 is the smallest start that is >= end1 = 3.
Example 3
Input: @intervals = ([1,2])
Output: (-1)
There is only one interval in the collection, so it outputs -1.
Example 4
Input: @intervals = ([1,4], [2, 2], [3, 4])
Output: (-1, 1, -1)

I want to find the interval to the right of each interval that meets a given criteria, but the intervals in the input data are ordered randomly. So best is to sort the intervals first, using their start_i values.

In the sorted array, we only store the indices into the original array, because we will need the original index for building up the results to return:

    my @sorted_indices =
    sort { $intervals->[$a][0] <=> $intervals->[$b][0] }
        keys $intervals->@*;

I use the keys ARRAY standard Perl function instead of 0..$#ARRAY for getting the list of all indices of ARRAY. This is shorter, easier to type, and less prone to typing errors. It has been available since Perl 5.12 (so since the year 2010!).

The indices of the sorted array point to the indices of the original array. We have indexed the indices! (Hence the title of this blog.)

We can then find the 'right' interval for each original interval by getting the first entry in the sorted array that points to an interval that meets the criteria of having a start_i value equal to or greater that the end_i value of the current interval:

    return map {
        my $end_i = $_->[1];
        ( first { $intervals->[$_][0] >= $end_i } @sorted_indices ) // -1;
    } $intervals->@*;

That works, and is a good enough solution for the test data.

But as usual, I try to not repeat doing things that aren't necessary. You may call it 'runtime optimization', but I think that if it is algorithmically unnecessary, it's a waste of resources, and not a good solution.

What bothers me is this:
Each time we want a 'right' interval for an original interval, we go through the sorted array from the beginning again.

Looking for a way to avoid this, we could walk through the sorted array instead of the original array. Then we can start searching at the current interval instead of the beginning of the array. And typically the search will return one of the first few intervals that are to the right of the current interval (skipping only those that start inside our current interval, and thus are not 'right' intervals).

The downside is that we get the results in a seemingly random order. But we have the original index, so we can put each result into a @result array at the correct place, and just return that array in the end.

That solution then looks like this:

sub right_interval( $intervals ) {
    my @sorted_indices =
        sort { $intervals->[$a][0] <=> $intervals->[$b][0] }
            keys $intervals->@*;

    my @results;
    for my $si_i ( 0..$#sorted_indices ) {
        my $i = $sorted_indices[$si_i];
        my $end_i = $intervals->[$i][1];
        $results[$i] =
            ( first { $intervals->[$_][0] >= $end_i }
                @sorted_indices[ $si_i .. $#sorted_indices ] )
                // -1;
    }
    return @results;
}

Feeling good about not heating the CPU too much, by indexing indices!

Thank you for the challenge!

Ups and Downs, Beginnings and Ends (PWC 297)

Matthias Muth — Sun, 01 Dec 2024 06:41:09 +0000

Challenge 297 solutions in Perl by Matthias Muth

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

Summary

Task 1: Contiguous Array
The trick is to use ups and downs (+1 and -1) instead of binary (1, 0), and add up those numbers. The sum will be the same before and after each subarray with an equal number of the two values, because they will inhibit each other.
Then find the longest stretch between positions having the same sum value.
One pass through the array only, $O (n)$ .

Task 2: Semi-Ordered Permutation
Determine the positions of '1' and 'n' (the largest number). The number of moves needed is their distance from the left and right end of the array, respectively. Minus one if the '1' was at the right of the 'n' originally.
Not actually doing the moves!
One pass, again, for finding the positions, even with an early loop exit ( $O (n)$ , too).
Then a simple formula.

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

Task 1: Contiguous Array

You are given an array of binary numbers, @binary.
Write a script to return the maximum length of a contiguous subarray with an equal number of 0 and 1.

Example 1
Input: @binary = (1, 0)
Output: 2
(1, 0) is the longest contiguous subarray with an equal number of 0 and 1.
Example 2
Input: @binary = (0, 1, 0)
Output: 2
(1, 0) or (0, 1) is the longest contiguous subarray with an equal number of 0 and 1.
Example 3*
Input: @binary = (0, 0, 0, 0, 0)
Output: 0
Example 4
Input: @binary = (0, 1, 0, 0, 1, 0)
Output: 4

I'm using a trick for making it easier to detect subarrays with an equal number of the two values:
I translate binary 1 and 0 into values +1 and -1, or 'ups and downs'.

Then, for any contiguous subarray with an equal number of +1 and -1,
the sum of its values will be zero.

Now, I built a cumulated sum, walking through the array.
Whenever a cumulated sum value occurs twice,
there is a subarray with an equal number of ups and
downs in between, and its length is the difference between the indexes where
the sum values occurred.

For the the program, I therefore mark the index of the
first occurrence of each sum value in a hash lookup as I walk through the array.
Then I remember the maximum of the length values while iterating.

use v5.36;

sub contiguous_array( @binary ) {
    my $max_length = 0;

    my $sum = 0;
    # The sum value of zero appears *before* the first number.
    my %first_appearance = ( 0 => -1 );

    for my $index ( keys @binary ) {
        # Add -1 or +1 to the running sum.
        $sum += $binary[$index] == 0 ? -1 : +1;
        $first_appearance{$sum} //= $index;
        my $length = $index - $first_appearance{$sum};
        $max_length = $length
            if $length > $max_length;
    }
    return $max_length;
}

Glad to have found a solution that needs only one loop over the array,
without repeated counting of subarrays.
$O (n)$ rules!

Task 2: Semi-Ordered Permutation

You are given permutation of \$n integers, @ints.
Write a script to find the minimum number of swaps needed to make the @ints a semi-ordered permutation.
A permutation is a sequence of integers from 1 to n of length n containing each number exactly once.
A permutation is called semi-ordered if the first number is 1 and the last number equals n.
You are ONLY allowed to pick adjacent elements and swap them.

Example 1
Input: @ints = (2, 1, 4, 3)
Output: 2
Swap 2 <=> 1 => (1, 2, 4, 3)
Swap 4 <=> 3 => (1, 2, 3, 4)
Example 2
Input: @ints = (2, 4, 1, 3)
Output: 3
Swap 4 <=> 1 => (2, 1, 4, 3)
Swap 2 <=> 1 => (1, 2, 4, 3)
Swap 4 <=> 3 => (1, 2, 3, 4)
Example 3
Input: @ints = (1, 3, 2, 4, 5)
Output: 0
Already a semi-ordered permutation.

There's no need for actually doing all the swaps to move the numbers!
It's enough to find the positions of '1' and 'n' (the largest number).
I chose not to use two calls to find (from List::Util) for that, but to keep it simple, in a single loop. I exit the loop early once both positions are known.

The number of moves needed than can be computed with a simple formula, adding.
the distance of the '1' from the left end of the array (which is its position, actually) and the distance of the 'n' from its right end.

If we find the '1' to the right of the 'n', that saves us one swap, because as they pass each other, that single swap will move them both in their respective desired direction.

Actually, the main exercise here is finding nice variable names...

use v5.36;

sub semi_ordered_permutation( @ints ) {
    my $n = scalar @ints;
    my ( $one_index, $n_index );
    for my $index ( keys @ints ) {
        $one_index = $index if $ints[$index] == 1;
        $n_index   = $index if $ints[$index] == $n;
        last if defined $one_index && defined $n_index;
    }
    my $moves_for_one = $one_index;
    my $moves_for_n   = ( $n - 1 ) - $n_index;
    return $moves_for_one + $moves_for_n
        - ( $one_index > $n_index ? 1 : 0 );
}

Here, again, it's looping over the array only once, even exiting the loop early.
So $O (n)$ again!

Thank you for the challenge!

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

The Run-Length of Matchsticks (PWC 296)

Matthias Muth — Sun, 24 Nov 2024 22:28:02 +0000

Challenge 296 solutions in Perl by Matthias Muth

These are my Challenge 296 Task 1 and 2 solutions in Perl
for The Weekly Challenge - Perl and Raku.

Summary

Task 1: String Compression
Detecting runs of same characters? Regular expression!
Replacing it by its run-length encoding? In the same statement!
Reversing the compression as a BONUS? Even simpler!

Task 2: Matchstick Square
A short solution based on a CPAN module works well for the examples and is short, but it doesn't really scale for larger sets of matchsticks.
In my own implementation, a 'target sum' iterator selects groups of matchsticks that have the needed length of one side of the square, leaving the rest of matchsticks for two more calls for the second and third side.
Blindingly fast, even for larger sets (try with 15, 20 or 25 matchsticks, for example!).

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

Task 1: String Compression

You are given a string of alphabetic characters, $chars.
Write a script to compress the string with run-length encoding, as shown in the examples.
A compressed unit can be either a single character or a count followed by a character.
BONUS: Write a decompression function.

Example 1
Input: \$chars = "abbc"
Output: "a2bc"
Example 2
Input: \$chars = "aaabccc"
Output: "3ab3c"
Example 3
Input: \$chars = "abcc"
Output: "ab2c"

This is an easy task for Perl's built-in regular expressions:

We capture any character as our first character of the run. Then we use a backreference to that captured first character to accept only the same character again, 1 or more times.

For replacing that sequence of characters by their run-length-encoded form, we use a s/PATTERN/REPLACEMENT/ substitution.
We add three options:

/e
causes the REPLACEMENT to be evaluated as an expression. In our case, this will be a string with the run-length-encoded form of the matched sequence.
/g
for doing a global substitution, for all sequences we can find.
/r
to return the result string instead of the number of substitutions done.

All of that is just one statement:

use v5.36;

sub string_compression( $chars ) {
    return $chars =~ s/(.)\g1+/ length( $& ) . $1 /egr;
}

The BONUS implementation is even easier, because we don't need any backreferences. We simply capture an integer number and the (non-number) character that follows it, and replace it by the character repeated times. The Perl x operator is probably the easiest and best way to do that:

sub string_uncompress( $chars ) {
    return $chars =~ s/(\d+)(\D)/ $2 x $1 /egr;
}

Task 2: Matchstick Square

You are given an array of integers, @ints.
Write a script to find if it is possible to make one square using the sticks as in the given array @ints where $ints[ì] is the length of ith stick.

Example 1
Input: @ints = (1, 2, 2, 2, 1)
Output: true
Top: $ints[1] = 2
Bottom: $ints[2] = 2
Left: $ints[3] = 2
Right: $ints[0] and $ints[4] = 2
Example 2
Input: @ints = (2, 2, 2, 4)
Output: false
Example 3
Input: @ints = (2, 2, 2, 2, 4)
Output: false
Example 4
Input: @ints = (3, 4, 1, 4, 3, 1)
Output: true

The simple solution reaches the limits too soon

My first, simple solution uses the CPAN Algorithm::Combinatorics module. It contains a partitions function, which generates all possible subsets of a given set of numbers (our matchsticks). It can be parameterized to return exactly four subsets (for the four sides of our square).

use v5.36;
use builtin qw( true false );
use List::Util qw( sum all );
use Algorithm::Combinatorics qw( partitions );

sub matchstick_square_AC( @ints ) {
    my $total = sum( @ints );
    return false
        unless $total % 4 == 0;
    my $side_length = $total / 4;
    for my $p ( partitions( \@ints, 4 ) ) {
        my @sums = map sum( $_->@* ), $p->@*;
        return true
            if all { $_ == $side_length } @sums;
    }
    return false;
}

This works for the examples, and the solution is short.

But generating all possible sets, we have to throw most of them away because already the first one doesn't give us the needed side length of the square.
For bigger numbers of matchsticks, the memory for keeping all the partitions gets really high.
For 15 matchsticks, on my server the process runs out of memory already.

The partitions function can also return an iterator (when used in scalar context), so that we don't need the memory to store all possible partitions at the same time.
For the same number of matchsticks, the memory footprint then stays low, but the run time is at around four minutes already.

This is an easy solution, but it doesn't make my programmer's heart happy.

My own 'target sum' iterator

I therefore did a second solution, based on these thoughts:

The sum of the matchstick lengths has to be divisible by 4. If not, it will be impossible to distribute them to four equal sides.
The length of one side then is that sum divided by four.
For the first side of the square, we select groups of matchsticks that have the correct length for that side. This is much less complex than finding all combinations of four groups that all have the correct length. It removes a lot of useless tries much earlier.
For the second and third side, we do the same, based on the matchsticks remaining from the previous step.
For the fourth side, the remaining matchsticks automatically sum up to the right length.

So this solution is based on finding groups of numbers that sum up exactly to a given target number (our side length).

We can implement a function to do that any way we want. I will be using a simple tree traversal algorithm.

My implementation will be an iterator, in order to avoid memory problems for storing all the combinations (even there will be much less combinations than in the previous solution!).

The skeleton of that function and its usage can look like this:

sub get_exactly( $target_sum, $ints ) {
    # Setup the closure data.
    ...;
    # Return the iterator function.
    return sub() {
        ...;
        return ( $used, $rest );    # array_refs
    }
}

my $side_length = sum( $ints->@* );
my $iterator = get_exactly( $side_length, $ints );
while ( my ( $used, $rest ) = $iterator->() ) {
    # Here, the sum of the numbers in $used->@* equal $side_length,
    # and $rest->@* are the remaining (unused) numbers.
    ...;
}

That makes this main function possible for solving the task:

use v5.36;
use builtin qw( true false );
use List::Util qw( sum );

sub matchstick_square( @ints ) {

    # The total sum of the matchstick lengths must be divisible by 4.
    my $total_sum = sum( @ints );
    if ( $total_sum % 4 != 0 ) {
        vsay "total sum( $total ) is not divisible by 4";
        return false;
    }
    my $side_length = $total_sum / 4;

    # Get a combination for the first side of the square.
    my $iterator_1 = get_exactly( $side_length, \@ints, );
    while ( my ( $used_1, $rest_1 ) = $iterator_1->() ) {
        # We got a combination for the first side.
        # Use the remaining matchsticks to get a combination
        # for the second side.
        my $iterator_2 = get_exactly( $side_length, $rest_1 );
        while ( my ( $used_2, $rest_2 ) = $iterator_2->() ) {
            # ... and the same for the third side.
            my $iterator_3 = get_exactly( $side_length, $rest_2 );
            while ( my ( $used_3, $rest_3 ) = $iterator_3->() ) {
                # Here, we have found combinations for three sides.
                # The remaining matchsticks automatically sum up to
                # the correct length of the fourth side.
                return true;
            }
        }
    }
    # No combination found.
    return false;
}

Now it still remains to implement the get_exactly iterator.

As I said before, I am using a tree traversal algorithm. In fact, it is a 'breadth first search' (BFS). It is based on a queue of possible continuations, that are processed within a loop until the queue runs empty. Every entry in the queue carries some context data, to be able to process that queue entry when it its turn. The context consists of:

    ( $used, $sum, $rest, $next_index )

In the loop, if the end condition is met ($sum == $target_sum), we return that combination (the $used and $rest array_refs).
If not, we loop through the remaining numbers in the array that $rest references, starting from the number at $next_index (to not repeat number that we have already tried). We add a candidate combination to the queue that includes that number, by creating a new context for it. If a number would exceed the target sum, we just skip it.

That means that all candidate combination in the queue are either smaller than or exactly equal to the target sum.

So here it is:

sub get_exactly( $target_sum, $ints ) {
    # Initialize the closure data for the iterator
    # ( $used, $sum, $rest, $next_index ).
    my @queue = ( [ [], 0, $ints, 0 ] );

    # Return the iterator function.
    return sub() {
        # Check whether we have reached the end before.
        return ()
            unless @queue;

        # Find the next matching combination.
        while ( @queue ) {
            my ( $used, $sum, $rest, $next_index ) = ( shift @queue )->@*;
            # dsay ":queue", pp ( $used, $sum, $rest, $start_index );

            # Check the success criteria and return if it is met.
            return ( $used, $rest )
                if $sum == $target_sum;

            # If not, add more candidates.
            for my $index ( $next_index .. $rest->$#* ) {
                my $value = $rest->[$index];
                my $new_used = [ $used->@*, $value ];
                my $new_sum = $sum + $value;
                my $new_rest = [
                    $rest->@[ 0 .. $index - 1 ],
                    $rest->@[ $index + 1 .. $rest->$#* ],
                ];
                push @queue, [ $new_used, $new_sum, $new_rest, $index ]
                    if $new_sum <= $target_sum;
            }
        }
        # End of the list.
        return ();
    };
}

For testing, I create random lists of 15 or 20 or 25 numbers (choosing quite big numbers, so that they don't combine well, and there will be no solution).

The first solution worked for around 4 minutes for a set of 15 matchsticks. I didn't try more then.

My 'target sum' solution does that in less than 0.1 seconds!
It takes less than 3 seconds for a set of 20, and less than 5 seconds for 25.

Now that makes me happier...!

Thank you for the challenge!

Find the complete source code for both tasks, including tests and alternative solution implementations, on GitHub.

Jump, but Don't Break the Game (PWC 295)

Matthias Muth — Sun, 17 Nov 2024 22:28:51 +0000

These are my solutions in Perl
for Challenge 295 Tasks 1 and 2 of The Weekly Challenge - Perl and Raku.

Summary

Task 1: Word Break.
A simple regular expression, built from the word list, delivers the solution. Very short, very nice.

Task 2: Jump Game
Implementing an unspectacular 'breadth first search' (BFS) algorithm.

Task 1: Word Break

You are given a string, $str, and list of words, @words.

Write a script to return true or false whether the given string can be segmented into a space separated sequnce of one or more words from the given list.

Example 1
Input: $str = 'weeklychallenge', @words = ("challenge", "weekly")
Output: true
Example 2
Input: $str = "perlrakuperl", @words = ("raku", "perl")
Output: true
Example 3
Input: $str = "sonsanddaughters", @words = ("sons", "sand", "daughters")
Output: false

We need to recognize words from the input word list in the string, making sure that after each recognized word, another word from the list begins.

That means we are checking whether the string is a sequence of one or more words from the list.
Wait a second...! Checking 'one or more' occurrences of something in a string?
What could be easier than using a regular expression for that?
The 'one or more' part directly translates to a + quantifier.

And the pattern? We form it as a list of alternatives, using the '|' character do separate the choices.

Then, we only have to match the string against our pattern:

use v5.36;

sub word_break( $str, $words ) {
    my $pattern = join "|", $words->@*;
    return $str =~ /^($pattern)+$/;
}

That was an easy one.

Task 2: Jump Game

You are given an array of integers, @ints.

Write a script to find the minimum number of jumps to reach the last element.
$ints[$i] represents the maximum length of a forward jump from the index $i.
In case last element is unreachable then return -1.

Example 1
Input: @ints = (2, 3, 1, 1, 4)
Output: 2
Jump 1 step from index 0 then 3 steps from index 1 to the last element.
Example 2
Input: @ints = (2, 3, 0, 4)
Output: 2
Example 3
Input: @ints = (2, 0, 0, 4)
Output: -1

Now this one requires some 'real programming'(tm).

First, let's get clear about the game mechanics. The description says:

$ints[$i] represents the maximum length of a forward jump from the index $i.

If we take $ints[$i] == 3 as an example, that means that we can choose to jump to $i+1, $i+2 or $i+3 in that move.
For each of those, the next move continues with the number that we find there.

Trying all possible combinations from the first entry in the list is like building a tree of possible paths. The root node is $int[0]. From there, there is one outgoing branch for every possible jump from there.

To find the 'shortest path' to the last entry, we need to find the shortest path in that tree that leads to a node with the index value of the last entry.

Finding the shortest path in a tree is typically done using a 'breadth first search' (or 'BFS') algorithm. All of the nodes on the same level ('breadth') are checked before any nodes on higher levels. So if one fulfils the end condition (here: it's the index of the last entry in the list), it's garanteed that there are no shorter paths.

A BFS algorithm is not difficult to set up:
We use a queue for the nodes to check.
For the queue entries, we use two-element anonymous arrays, containing the index value, and the length of the path that was needed to reach that node. That makes it easy to return the correct result once we find the shortest path.

We initialize our queue with the index of the first number in the list (which is 0, of course), and the number of jumps needed to get there (0, too!).
This represents the starting point of our tree.

Then we loop over the entries in the queue.
For each entry, we check whether it meets the end condition, and return the path length if it does. Done.

If we haven't reached the last entry yet, we add the next level of possible moves to the queue, making sure we don't add jumps that end beyond the end of the list.
The path length for these new queue entries is one higher than the one that we have so far.

If the queue runs empty, there is no possible path that reaches the last entry. We return the -1 as we should in that case.

use v5.36;

sub jump_game( @ints ) {
    my ( $index, $n_jumps ) = ( 0, 0 );
    my @queue = ( [ $index, $n_jumps ] );
    while ( @queue ) {
        my ( $index, $n_jumps ) = ( shift @queue )->@*;
        return $n_jumps
            if $index == $#ints;
        push @queue,
            map [ $_, $n_jumps + 1 ],
                grep $index <= $#ints,
                    reverse $index + 1 .. $index + $ints[$index];
    }
    return -1;
}

This BFS does not need a 'visited' structure to avoid running into circles. As we only move forward in the list, we don't need to fear running into that problem at all.

I have also created a solution using the Algorithm::Functional::BFS module from CPAN. It hides all the mechanics of the BFS algorithm and uses a functional approach: there are code blocks handed in to the search function, for checking whether a node meets the the end criteria, and for getting the list of successor nodes for a node. These are the only two variable parts of the algorithm.

In fact I found that the code is not significantly shorter when I use that module, because we need to supply the code blocks as parameters, and also set some parameters. So I am quite ok with having written it myself.

Thank you for the challenge!

Find the complete source code for both tasks, including tests and alternative solution implementations, on Github.

Consecutive Sequences of Permutations, Anyone? (PWC 294)

Matthias Muth — Sun, 10 Nov 2024 23:29:25 +0000

Challenge 294 solutions in Perl by Matthias Muth

These are my Challenge 294 Task 1 and 2 solutions in Perl
for The Weekly Challenge - Perl and Raku.

Summary

Task 1: Consecutive Sequences
$O (n)$ solution using a small data structure and a lookup hash to keep track of 'streaks' (consecutive sequences) and to merge them with new numbers as they are processed.

Task 2: Next Permutation
Working 'locally' to flip numbers to get the next permutation, without the need to create all permutations first.

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

Task 1: Consecutive Sequence

You are given an unsorted array of integers, @ints.
Write a script to return the length of the longest consecutive elements sequence. Return -1 if none found. The algorithm must runs in O(n) time.

Example 1
Input: @ints = (10, 4, 20, 1, 3, 2)
Output: 4
The longest consecutive sequence (1, 2, 3, 4).
The length of the sequence is 4.

Example 2
Input: @ints = (0, 6, 1, 8, 5, 2, 4, 3, 0, 7)
Output: 9

Example 3
Input: @ints = (10, 30, 20)
Output: -1

Oh. Big Oh. $O (n)$ !

This restriction means that the simplest solution, sorting the array and then walking through the ordered numbers, is not allowed. That's because sort has an $O(n \log{} n)$ time complexity.

So what we are allowed to do for $O (n)$ is to walk through the array. As long as we don't use another loop within a loop, we can even walk through the array several times. This only means that the runtime spent for each number is slightly higher, but this still scales linearly with rising $n$ . Actually $O (2 n)$ is the same as $O (n)$ .

In fact I do walk through the data twice! I use uniq on the input data, as a first pass (Example 2 contains a 0 twice!). I do this to make sure that double entries do not disturb the detection of sequences.

Let's call a 'consecutive sequence' a 'streak' for short.
We need to build up the 'streaks' as we encounter the numbers, one by one.
The data structure I use for representing a streak is a simple hash:

    $streak = { FROM => $a, TO => $b };

When a new number is encountered, I try to merge that number with any streak that already exists at the number's immediate left or immediate right.

For knowing whether those neighboring streaks already exists , I keep a lookup hash, %streaks. For every streak I create, I put a reference to the streak's data structure into that lookup hash, one with its starting number as the key, and one with its ending number. Thus, to access the left and right neighboring streaks for any new number $n, I only need to check $streaks{ $n - 1 } and $streaks{ $n + 1 }.. And once I have those, I know their 'other ends': the left streak's starting number, and the right streak's ending number. I then can create a new streak that covers them all, the left streak, the new number, and the right streak (if they exist, that is).

What is left to do then is to update the lookup table. I delete any references to the left and right streaks that will not be needed anymore, and I store references to the merged streak in the lookup hash at its starting and ending numbers.

For returning the length of the longest streak in the end, I check whether the new one is longer than what we already have, and update accordingly.

I have left the comments inside the code to make it easier to follow:

use v5.36;
use List::Util qw( uniq );

sub consecutive_sequence_using_hash( @ints ) {
    my $max_streak_length = -1;
    my %streaks;
    for my $n ( uniq @ints ) {
        # Create a new streak from this number,
        # possibly merged with any existing adjacent streaks
        # to the left or to the right.
        my ( $left, $right ) =
            ( $streaks{ $n - 1 }, $streaks{ $n + 1 } );
        my ( $from, $to ) = (
            $left ? $left->{FROM} : $n,
            $right ? $right->{TO} : $n,
        );
        my $streak = { FROM => $from, TO => $to };

        # Update the lookup entries:
        # Remove any entries that are *inside* the merged streak,
        # and add or update entries at the streak borders.
        delete $streaks{ $left->{TO} }
            if $left;
        delete $streaks{ $right->{FROM} }
            if $right;
        $streaks{$from} = $streaks{$to} = $streak;

        # Update the maximum length if this is a streak
        # (not just a single number) and it's longer than what we have.
        $max_streak_length = $to - $from + 1
            if $to > $from && $to - $from + 1 > $max_streak_length;
    }
    return $max_streak_length;
}

No loops inside!
I think this is proper $O (n)$ solution.

Task 2: Next Permutation

You are given an array of integers, @ints.
Write a script to find out the next permutation of the given array.
The next permutation of an array of integers is the next lexicographically greater permutation of its integer.

Example 1
Input: @ints = (1, 2, 3)
Output: (1, 3, 2)
Permutations of (1, 2, 3) arranged lexicographically:
(1, 2, 3)
(1, 3, 2)
(2, 1, 3)
(2, 3, 1)
(3, 1, 2)
(3, 2, 1)

Example 2
Input: @ints = (2, 1, 3)
Output: (2, 3, 1)

Example 3
Input: @ints = (3, 1, 2)
Output: (3, 2, 1)

A simple, but compute-intensive solution would be to create all permutations of the numbers involved, then sort them ('lexicographically'), then find the entry that corresponds to the permutation that is given, and then return the next one.
Actually I don't like this approach too much, because in my experience, anything that has to do with permutations or combinations has a tendency to use a lot of time , or a lot of memory, or both, very fast.

Let's find a solution that works 'locally'!

In order to modify an existing permutation to the next higher one, we need to find the number with the lowest significance that can be increased.
That means that we start at the right end (least significant), and find the first number that is lower than its right neighbor. All numbers at the right of that are ordered, highest first, so they can't be 'incremented'.

What if we didn't find any number that is lower than its right neighbor?
In that case, all numbers are ordered, highest first. This must be the last permutation possible. Which means that the next permutation will restart from the beginning of the cycle of all permutations.
In the first permutation, the numbers are ordered lowest first. To get there, we can just reverse that highest permutation sequence of numbers, and we can return that as the result.

If that's not the case, and we do have found a number that can be 'incremented', we need to find the next higher number to replace this number with.
We only look in the right part of the permutation, because using any number from further left would change the order more than we want.
We are looking for the lowest possible number that still is higher than our number.

Once we have found that replacement number, we exchange the two numbers.
We then have 'increased' our number by the next possible higher value of all permutations of the right part. At the same time, we have decreased the replacement number to the next possible lower number. So the ordering of the right part thus still is 'highest to lowest'. As we need the 'first' permutation of the right part, we can just reverse this.

That's it! We have found the lowest possible increment.

Again, I have left the comments in the code for easier following.

use v5.36;

sub next_permutation( @ints ) {
    return @ints
        if @ints <= 1;

    # Starting from the end, find the first number
    # that is lower than the one following it.
    my $index = $#ints;
    while( $index > 0 && $ints[ --$index ] gt $ints[ $index + 1 ] ) {
        # Everything is in the loop condition.
    }

    # No lower number found?
    # Then we are at the end of the permutations.
    return reverse @ints
        if $index == 0;

    my $value = $ints[$index];

    # Find the next highest value within the right part,
    # for using it to replace the current value.
    # (Remember that maybe not all values in the right part are higher!)
    # It has to be higher than the one to substitute, but the
    # lowest possible one.
    my ( $index_2, $replacement ) = ( $index + 1, $ints[ $index + 1 ] );
    for ( $index_2 + 1 .. $#ints ) {
        ( $index_2, $replacement ) = ( $_, $ints[$_] )
            if $value lt $ints[$_] lt $replacement;
    }

    # Swap the two numbers.
    @ints[ $index, $index_2 ] = @ints[ $index_2, $index ];

    # We know that the right side is sorted, highest first.
    # to have it sorted lowest first, we just need to reverse it.
    @ints[ $index + 1 .. $#ints ] =
        reverse @ints[ $index + 1 .. $#ints ];

    return @ints;
}

If we run this several times in a row, we will get a 'consecutive sequence of permutations'.
How nice for the title of this blog, combining the two tasks!

Thank you for the challenge!

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

Domino Frequencies and the Vectorized Boomerang (PWC 293)

Matthias Muth — Thu, 31 Oct 2024 23:12:18 +0000

Challenge 293 solutions in Perl by Matthias Muth

Summary

Similar Dominos:
Two lines of code to compute frequencies of Domino value combinations
and then to sum them up.

Boomerang:
Thank you for helping me to get a refresher in vector geometry!
It only needs two formulas and one comparison for checking whether the input points form a 'boomerang', using integer arithmetics only (no divisions, no square roots).

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

Task 1: Similar Dominos

You are given a list of dominos, @dominos.
Write a script to return the number of dominos that are similar to any other domino.
$dominos[i] = [a, b] and $dominos[j] = [c, d] are same if either (a = c and b = d) or (a = d and b = c).

Example 1
Input: @dominos = ([1, 3], [3, 1], [2, 4], [6, 8])
Output: 2
Similar Dominos: $dominos[0], $dominos[1]

Example 2
Input: @dominos = ([1, 2], [2, 1], [1, 1], [1, 2], [2, 2])
Output: 3
Similar Dominos: $dominos[0], $dominos[1], $dominos[3]

My thinking process:

For counting the number of similar dominos, we can first count for each distinct value combination how often it exists, and then sum up the numbers of those that exist more than once.
Counting how often each value combination exists is the same as getting their frequencies. That's something we've done quite often before. In Perl typically a hash is used, with the domino combination as the key, and the frequency as the value. Today, I will let List::MoreUtils do the job of creating the frequency hash. Less typing ;-).
To use the two numbers on a domino as a key, we have to combine them into a string. Let's join the two numbers with a separator (like '-') in between them.
A combination and its inverse (like [3, 1] and [1, 3]) should be considered as being equal. They need to be mapped to the same key. To get that, it's easiest to just sort the two numbers (even if there are only two of them) before turning them into a key string. Both dominos [3, 1] and [1, 3] will then be counted using "1-3" as the key.
The type of sort (numerical or lexical, ascending or descending) does not matter at all, it is only important that the result is the same if the input is in reversed order. The default lexical sort will therefore do nicely.
Once we have the frequencies, we add them up, but we exclude those having a frequency of 1. (The frequencies are in the values of the frequency hash.)

My solution then is this little program:

use v5.36;
use List::MoreUtils qw( frequency );
use List::Util qw( sum );

sub similar_dominos( $dominos ) {
    my %frequencies = frequency( map { join "-", sort $_->@* } $dominos->@* );
    return sum( grep $_ > 1, values %frequencies );
}

(use v5.36; is short for getting subroutine signatures and automatic strict and warnings.)

I love how Perl makes this easy.

Task 2: Boomerang

You are given an array of points, (x, y).
Write a script to find out if the given points are a boomerang.
A boomerang is a set of three points that are all distinct and not in a straight line.

Example 1
Input: @points = ( [1, 1], [2, 3], [3,2] )
Output: true

Example 2
Input: @points = ( [1, 1], [2, 2], [3, 3] )
Output: false

Example 3
Input: @points = ( [1, 1], [1, 2], [2, 3] )
Output: true

Example 4
Input: @points = ( [1, 1], [1, 2], [1, 3] )

Output: false

Example 5
Input: @points = ( [1, 1], [2, 1], [3, 1] )
Output: false

Example 6
Input: @points = ( [0, 0], [2, 3], [4, 5] )
Output: true

We have the three input points
$pi=(xiyi)∣i∈1…3\qquad \qquad p_i = \begin{pmatrix} x_i \\ y_i \end{pmatrix} |_{ i \in { 1 \dots 3 } }$
My idea to solve this task is based on the two vectors that we get
when we connect these points:
$\qquad \qquad \mathbf{v} = \begin{pmatrix} x_2 - x_1 \\ y_2 - y_1 \end{pmatrix} \qquad \mathbf{w} = \begin{pmatrix} x_3 - x_2 \\ y_3 - y_2 \end{pmatrix}$

For a 'boomerang', we then need to check whether the two vectors have the same direction.

The reason why I'm using this 'vector' approach is that I hope to avoid any condition checking that would be necessary for the other possible approach: comparing the slope of the line segments defined by the points. As the points can have the same $x$ -coordinate (like in Example 4), I would have to deal with possibly infinite slopes (vertical lines). And in any case with floating point numbers, which I always try to avoid if possible.
Maybe my worries are exaggerated, but I also found it nice to get a little refresher in vector geometry!

So going with the two vectors:
I have re-learned (after around 50 years!) something about the dot product (or scalar product) of vectors.
In the Wikipedia article about the dot product, it says that if two vectors are codirectional, their dot product is equal to the product of their magnitudes.
That sounds complicated, but let's see what that means when we break it down.

The 'dot product' is a scalar number, and for our two vectors
$\qquad \qquad \mathbf{v} = \begin{pmatrix} x_v \\ y_v \end{pmatrix} \qquad \mathbf{w} = \begin{pmatrix} x_w \\ y_w \end{pmatrix}$
it is simply computed like this:
$\qquad \qquad \mathbf{v} \cdot \mathbf{w} = x_v x_w + y_v y_w$

The 'product of the magnitudes' of the two vectors is
$\qquad \qquad \| \mathbf{v} \| \, \| \mathbf{w} \| = \sqrt{ x_v^2 + y_v^2} \cdot \sqrt{x_w^2 + y_w^2} = \sqrt{ (x_v^2 + y_v^2) \, (x_w^2 + y_w^2)}$
The 'magnitude' of a vector is its length, and you recognize the Pythagorean theorem in the two-dimensional case here.

For doing the 'boomerang check', we need to check whether those two are equal:
$\qquad \qquad x_v x_w + y_v y_w = \sqrt{ (x_v^2 + y_v^2) \, (x_w^2 + y_w^2)}$

To avoid floating point operations, and especially something as complicated as computing a square root, we use a trick and square both sides:
$\qquad \qquad ( x_v x_w + y_v y_w ) ^2 = (x_v^2 + y_v^2) \, (x_w^2 + y_w^2)$
Only integer arithmetics, not even a division in this one!

Squaring both sides also has another positive (pun intended!) effect:
If the two vectors have the same direction, but a different orientation
(one is a negative multiple of the other), their dot product is negative. Squaring both sides of the equation eliminates the negative sign, which is what we actually want.

Now we have something that we can turn into code:

use v5.36;

sub boomerang( $points ) {
    # Create vectors connecting the points.
    my $v = [ $points->[1][0] - $points->[0][0],
              $points->[1][1] - $points->[0][1] ];
    my $w = [ $points->[2][0] - $points->[1][0],
              $points->[2][1] - $points->[1][1] ];

    # Compute the dot product
    # and the *square* of the product of the magnitudes
    # (by not taking the square root).
    my $dot_product = $v->[0] * $w->[0] + $v->[1] * $w->[1];
    my $mag_product_squared =
        ( $v->[0] ** 2 + $v->[1] ** 2 )
            * ( $w->[0] ** 2 + $w->[1] ** 2 );

    # Compare the two.
    return $dot_product ** 2 != $mag_product_squared;
}

I added some more tests for corner cases, like two of the three points being identical, or even all three of them.

ok 1 - Example 1: boomerang( [[1, 1], [2, 3], [3, 2]] ) is true
ok 2 - Example 2: boomerang( [[1, 1], [2, 2], [3, 3]] ) is false
ok 3 - Example 3: boomerang( [[1, 1], [1, 2], [2, 3]] ) is true
ok 4 - Example 4: boomerang( [[1, 1], [1, 2], [1, 3]] ) is false
ok 5 - Example 5: boomerang( [[1, 1], [2, 1], [3, 1]] ) is false
ok 6 - Example 6: boomerang( [[0, 0], [2, 3], [4, 5]] ) is true
ok 7 - Extra 1: boomerang( [[1, 1], [2, 1], [1, 1]] ) is false (points 1 and 3 identical)
ok 8 - Extra 2: boomerang( [[1, 1], [1, 1], [2, 1]] ) is false (points 1 and 2 identical)
ok 9 - Extra 3: boomerang( [[1, 1], [2, 1], [2, 1]] ) is false (points 2 and 3 identical)
ok 10 - Extra 4: boomerang( [[1, 1], [1, 1], [1, 1]] ) is false (all points identical)
1..10

Glad all the tests run successfully!

Maybe next time dealing with vectors, I should try PDL!
There's always something new to learn!

Thank you for the challenge!

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