DEV Community: Bob Lied

PWC 397: Reflection

Bob Lied — Sat, 31 Oct 2026 00:19:19 +0000

October ends with a plaintive little offering from the weekly challenge. It asks us to consider the negative and liminal space just beyond the surface -- to search for what is missing; to create an order that is mysteriously irrational yet trivially banal; to contemplate what it is we yearn for. Listen to Wishing You Were Here.

Task 1: Absent Smallest Positive

The task

You are given an array of integers. Write a script to return the smallest absent positive integer such that it is strictly greater than the average of all elements in the given array.

Example 1

Input: @arr = (1, 2, 4, 5, 6)
Output: 7
- Average: (1 + 2 + 4 + 5 + 6) / 5 = 3.6
- We need the smallest positive integer absent from nums that is strictly greater than 3.6. The positive integers greater than 3.6 are 4, 5, 6, ...
- The smallest missing one is 7.

Example 2

Input: @arr = (-5, -2, -1, 3)
Output: 1
- The average is -1.25. There is a gap in the array between -1 and 3. The smallest positive integer in the gap is 1.

Example 3

Input: @arr = (1, 2, 3)
Output: 4
- The average is 2. The array ends at 3. The smallest positive integer missing from the array is 4.

Example 4

Input: @arr = (2, 3, 7, 8)
Output: 6
- The average is 5. 6 is greater and missing.

Example 5

Input: @arr = (1, 1, 1, 10)
Output:_ 4
- The average is 3.25, 4 is the smallest absent integer.

The wheels turn

Clearly we need to first make one pass over the array to find the average.
A negative average promotes to 0, because we only want to look at numbers that are positive.
We can ignore all numbers less than the average.
Although the examples all have numbers in ascending order, we shouldn't assume that.
It sure is going to be easier to find gaps if the array is sorted.

So, let's try finding the average; filtering the array; sorting; and walking up the array to find gaps.

Some code

sub task(@arr)
{
    if    ( @arr == 0 ) { return 1 }
    elsif ( @arr == 1 ) { return $arr[0] > 0 ? ($arr[0] + 1) : 1 };
    use List::Util qw/sum0/;

    my $start = sum0(@arr) / @arr;
    $start = 0 if $start < 0;

    @arr = ( sort { $a <=> $b } grep { $_ > $start } @arr );

    my $beg = floor($start);
    while ( defined(my $end = shift @arr) )
    {
        return $beg+1 if ( $end - $beg > 1 );
    } 
    continue { $beg = $end }

    return $beg+1;
}

Notes:

We can begin by dispensing with the edge cases of empty and singleton arrays, where the answer is obvious.
Next we want the average. The average is going to be a lower bound, so I'm naming it $start.
The while loop is going to consider the intervals between consecutive values of the array, named as $beg and $end. We will destroy @arr by lopping off the leading value each time through the loop.
- If the difference is not 1, then there is a gap, and we can take the value after $beg.
- I'm going to be cute here and use the obscure continue block of the while to reset $beg. This is completely gratuitous, but it does call out the boundary of the interval in a kind of readable way.
- If there are no gaps in the array, then we finish the loop and need to return something bigger than the last element. The while loop finished by assigning $beg to the last element that was shifted, and then failing to shift again. So at the end of the loop, $beg is the last element of the array, and $end is undefined.

Task 2: Binary Reflection

The task

You are given an array of integer. Write a script to sort the given array in ascending order based on the binary reflection of each element. If two different numbers have the same binary reflection, the smaller original number should appear first.

Example 1

Input:_ @arr = (3, 6, 12)
Output: (3, 6, 12)

    Decimal 3  = Binary   11 <|> 11   = Decimal 3
    Decimal 6  = Binary  110 <|> 011  = Decimal 3
    Decimal 12 = Binary 1100 <|> 0011 = Decimal 3

All three elements have the same binary reflection (3). Since they tie, they are sorted by their original values in ascending order: (3, 6, 12).

Example 2

Input: @arr = (1, 2, 4, 8)
Output: (1, 2, 4, 8)

Decimal 1 = Binary    1 <|> 1 = Decimal 1
Decimal 2 = Binary   10 <|> 01 = Decimal 1
Decimal 4 = Binary  100 <|> 001 = Decimal 1
Decimal 8 = Binary 1000 <|> 0001 = Decimal 1

All elements reflect to 1. Tie-breaking by original value yields (1, 2, 4, 8).

Example 3

Input: @arr = (7, 8, 9, 10)
Output: (8, 10, 7, 9)

Decimal 8  = Binary 1000 <|> 0001 = Decimal 1
Decimal 9  = Binary 1001 <|> 1001 = Decimal 9
Decimal 10 = Binary 1010 <|> 0101 = Decimal 5
Decimal 7  = Binary  111 <|> 111  = Decimal 7

Sorting by reflection values (1, 5, 7, 9) gives original elements (8, 10, 7, 9).

Example 4

Input: @arr = (5, 9, 15, 17)
Output: (5, 9, 15, 17)

Decimal 5  = Binary   101 <|> 101   = Decimal 5
Decimal 9  = Binary  1001 <|> 1001  = Decimal 9
Decimal 15 = Binary  1111 <|> 1111  = Decimal 15
Decimal 17 = Binary 10001 <|> 10001 = Decimal 17

All numbers are binary palindromes, so their reflections match their original decimal values (5, 9, 15, 17), leaving the array order unchanged.

Example 5

Input: @arr = (11, 13, 14, 19)
Output: (14, 13, 11, 19)

Decimal 11 = Binary  1011 <|> 1101  = Decimal 13
Decimal 13 = Binary  1101 <|> 1011  = Decimal 11
Decimal 14 = Binary  1110 <|> 0111  = Decimal 7
Decimal 19 = Binary 10011 <|> 11001 = Decimal 25

Sorted by reflection values (7, 11, 13, 25) yields (14, 13, 11, 19).

The hard part, thinking

There are two parts: determining binary reflection values, and sorting.

Inside you there are two wolves. The first wolf learned to program in C, and sees this as a bit-twiddling exercise. The other wolf programs in Perl, and sees this as an obvious case of reversing a string. Which wolf wins? The lazy one, of course.

For sorting, we want the reflected values at hand, so this is going to be a variation on the Schwartzian transform. Augment each number in the array with a pair -- the original number, and its binary reflection. Sort the array of pairs, then take the original number out of each pair.

The code please, maestro

First, a little function to do binary reflection. This seems like it would be a good candidate for Memoize to cache values of repeated calls. I include that in the code snippet here, but my performance tests showed negligible improvement. This seems to be one of those cases where the overhead of memo-ization isn't justified by the relatively trivial body of the function.

To get a binary representation, I'm using sprintf with a binary format string, %b. Then I want to reverse the string and turn it back into an integer. Old bit-twiddlers like me know that the function that does that is oct(), but it requires a 0b prefix to recognize binary strings. Rather than perform another string append operation, I just snuck b0 into the end of the format, which becomes 0b on reversal.

use Memoize;
memoize('reflect');
sub reflect($n)
{
    return oct( reverse sprintf("%bb0", $n) );
}

For sorting, I want to augment the input array with reflection information.

There are two ways to go: I can set up an auxiliary lookup table and enter all the reflected values there. Then sort the array by referencing the table:

my %mirror = map { $_ => reflect($_) } $arr->@*;
return [ sort { $mirror{$a} <=> $mirror{$b} || $a <=> $b } $arr->@* ];

Or I can tag each of the original values with its reflected value. In practical terms, I turn each of the original integers into a pair of numbers.

map { [ $_, reflect($_) ] } $arr->@*

Then, the sort indexes the pair for comparison

sort { $a->[1] <=> $b->[1] || $a->[0] <=> $b->[0] }

However that yields an array of pairs, so that needs to be manipulated again to extract only the first member of each pair:

[ map { $_->[0] } ... ]

In idiomatic form, this is written in a single statement as a map/sort/map:

    [ map { $_->[0] }
        sort { $a->[1] <=> $b->[1] || $a->[0] <=> $b->[0] }
            map { [ $_, reflect($_) ] } $arr->@*
    ]

Between the two possibilities, the tradeoff is that the lookup hash has overhead for each access, but can potentially have fewer entries. The array approach has quick indexed access, but doubles the space required.

A benchmark shows that, at least in my environment, using the transform with pair arrays is about 15% faster.

PWC 396: Finishing Order, Trionic Array

Bob Lied — Sat, 24 Oct 2026 14:30:17 +0000

It's a lovely Saturday morning in Wisconsin, and I feel like writing a few words about Weekly Challenge 396, which I finished earlier this week.

Task 1: Finishing Order

You are given two arrays of integers, @order and @friends. The @order array (size n) contains every integer from 1 to n exactly once. The @friends array contains ID sorted in strictly increasing order. Write a script to return the array containing IDs in finishing order.

Example 1:
- Input: @order = (3, 1, 4, 2, 5) @friends = (1, 2, 4)
- Output: (1, 4, 2)
  - ID 1 finished 2nd, ID 4 finished 3rd, ID 2 finished 4th.
Example 2:
- _Input: @order = (5, 4, 3, 2, 1) @friends = (1, 3, 5)
- Output: (5, 3, 1)
  - ID 5 finished 1st, ID 3 finished 3rd, ID 1 finished 5th.
Example 3:
- Input: @order = (2, 4, 1, 3) @friends = (1, 2, 3, 4)
- Output: (2, 4, 1, 3)
  - ID 2 finished 1st, ID 4 finished 2nd, ID 1 finished 3rd, ID 3 finished 4th.
Example 4:
- Input: @order = (4, 1, 3, 2) @friends = (3)
- Output: (3)
Example 5:
- Input: @order = (1, 3, 2, 6, 5, 4) @friends = (1, 2, 3)
- Output: (1, 3, 2)
  - ID 1 finished 1st, ID 3 finished 2nd, ID 2 finished 3rd.

Analysis

Using small numbers as the participants' identifiers makes this a little more confusing than it needs to be. If we modify it to use strings for participants and friends, it's a little clearer. Example 1 might then look like

@order = (carol, alice, dave, bob, ed)
@friends = (alice, bob, dave)
Output: (alice, dave, bob)

Then it's a litte easier to see that this task amounts to extracting the @friends subset from @order, in the order that they appear.

The @order array is not good for looking up participants; it maps the finishing place to the participant and requires some kind of search. It would be convenient if we had a table that went the other way, from participant to place. If we had a hash table that maps friends to their finishing place, then we could use that to sort the friends array.

Synthesis

sub task($order, $friends)
{
    my $i = 0;
    my %place = map { $_ => $i++ } $order->@*;

    return [ sort { $place{$a} <=> $place{$b} } $friends->@* ];
}

Notes:

The map statement inverts the @order array and gives us a hash to look up participants. The task has helpfully specified that there are no duplicates, so the 1-to-1 mapping can safely be inverted.
Now we can sort @friends by their finish order.
Wrapping the result of the sort in square brackets creates an array reference. I prefer to return references because it avoids data copies.

Task 2: Trionic Array

You are given an array of integers. Write a script to return true if the given array is trionic; otherwise return false. An array is trionic if there exist indices 0 < p < q < n−1 such that arr[0..p] is strictly increasing, arr[p..q] is strictly decreasing, and arr[q..n−1] is strictly increasing.

Example 1:
- Input: @arr = (1, 3, 5, 4, 2, 6, 8)
- Output:true
Example 2:
- Input: @arr = (1, 4, 4, 2, 1, 3, 5)
- Output: false
Example 3:
- Input: @arr = (2, 10, 3, 1, 9)
- Output: true
Example 4:
- Input: @arr = (1, 2, 3, 4, 3, 2, 1)
- Output: false
Example 5:
- Input: @arr = (1, 3, 6, 4, 2, 7, 8, 4)
- Output: false

Analysis

In more intuitive terms, "trionic" seems to mean the array ascends to a peak, comes back down to a valley, and finishes by ascending again. The examples give us some explanatory data, like what to do with repeated values.

One thing we can note is that the array must have a minimum of four elements to form a peak and a valley.

The simplest thing that could work is to scan the array for peaks and valleys and check that there is exactly one of each. So let's do that.

Synthesis

sub task(@arr)
{
    return false if @arr < 4
                 || $arr[0]  >= $arr[1]
                 || $arr[-2] >= $arr[-1];

    my ($peak, $valley) = (0, 0);
    for my $i ( 1 .. $#arr-1 )
    {
        $peak++   if $arr[$i-1] < $arr[$i] && $arr[$i] > $arr[$i+1];
        $valley++ if $arr[$i-1] > $arr[$i] && $arr[$i] < $arr[$i+1];
    }
    return $peak == 1 && $valley == 1;
}

Notes:

We start by eliminating some easy cases. As noted, there must be at least four elements. Also, it must start and end with an ascending pair.
The meat of the function is to check each point to see if it's an inflection. Our for loop indexes inside the ends of the array, so that when we add or subtract 1 from $i we are guaranteed to still be within the bounds of the array.
I don't see any cleverness that avoids making a pass through the array and checking the slope. There might be other ways to encode that information -- ascending as 1, descending as -1; or 'U' and 'D' as strings -- and therefore finding peaks and valleys could be done as array reductions or regular expression matches. But I'm not seeing that as more efficient or clearer, so let's not.
There might be an optimization to leave the loop early as soon as $peak or $valley exceeds 1, but the test for the condition at every point might cost as more in execution than simply finishing the loop. It would depend on the data. If the arrays were typically long and irregular so that very few of them are trionic, it might be worth it.

PWC 393 Triangles and Primes

Bob Lied — Fri, 02 Oct 2026 03:46:25 +0000

A couple of quick mathematical tasks for this week's challenges.

Task 1: Pythagoras Multiplied

Task Description

You are given a positive integer n. Find the number of all positive integer triplets (a,b,c) so that a² + b² = c² and a, b, and c are integers <= n.

Example 1: n=20 --> 12
- (3,4,5),(4,3,5),(5,12,13),(6,8,10),(8,6,10),(8,15,17),(9,12,15),(12,5,13),(12,9,15),(12,16,20),(15,8,17),(16,12,20)
Example 2: n=7 --> 2
Example 3: n=1 --> 0
Example 4: n=15 --> 8
Example 5: n=30 --> 22

Task Discussion

We notice from Example 1 that order matters: (3,4,5) is counted as distinct from (4,3,5).

We know from the geometry of right triangles that there are no integer solutions where a=b (an equilateral right triangle has hypotenuse sqrt(2)*a), so all valid triples will have a≠b≠c.

I'm going to start by using brute force, and then thinking about optimizing. For every c from 1 to n, there is a target hypotenuse c². Check every pair of a and b from 1 to n.

First optimization: the first possible triple is (3,4,5), so there's no need to check for c less than 5.

Second optimization: if (a,b,c) works, then so does (b,a,c). No need to check every combination of a and b, just the distinct pairs.

Third optimization: no need to iterate every value of a from 1 to n.

The minimum value of a is 3, because we know that the first valid triple is (3,4,5).
We know that as a increases, b must decrease, so that the maximum value of a implies the minimum value of b.
b will iterate over values greater than a, so the minimum that b can ever be is 4.
We know that a = sqrt(c² - b²), so the upper bound on a can be floor(sqrt(c² - 16)).

Fourth optimization: no need to iterate every value of b either. The values of b will start from a+1, and increment until the sum exceeds c². We know that b = sqrt(c² - a²), so that can be the bound for any given c and a.

Task Solution

sub task($n)
{
    my $count = 0;

    for my $c ( 5 .. $n )
    {
        for my $a ( 3 .. floor(sqrt( $c*$c - 16 )) )
        {
            for my $b ( $a+1 .. floor(sqrt($c*$c - $a*$a)) )
            {
                if ( $a*$a + $b*$b == $c*$c )
                {
                    # If a,b works, then so does b,a
                    $count += 2;
                }
            }
        }
    }
    return $count;
}

Task 2: Prime Step

Task Description

You are given a string with English alphabetic characters only. What is the absolute difference of the sum of the ASCII values of the characters in the string to the nearest prime number?

Example 1: Input: $str = "hello" Output: 9
- The ordinal values of "hello" are [104,101,108,108,111], summing up to 532. The nearest prime number to 532 is 523, resulting in an absolute difference of 9.
Example 2: Input: $str = "football" Output: 2
- Starting with the values [102,111,111,116,98,97,108,108] and the sum 841. We find 839 as the nearest prime number, so the difference is 2.
Example 3: Input: $str = "a" Output: 0
- The value of "a" is 97, which is a prime number.
Example 4: Input: $str = "challenge" Output: 2
- The ordinal values of "challenge" are [99, 104, 97, 108, 108, 101, 110, 103, 101], which sum up to 931. The nearest prime number to 931 is 929, so the difference is 2.
Example 5: Input: $str = "perl" Output: 2
- The ordinal values of "perl" are [112, 101, 114, 108], summing up to 435. Nearest prime is 433, so the difference is 2.

Task Discussion

There are several little sub-problems in this task, but all of them have solutions in Perl libraries. Notably, finding the nearest prime efficiently is probably an interesting problem in number theory and computation, but I'm not going to solve it as a side quest.

Task Solution

sub task($str)
{
    use List::Util qw/sum0 min/;
    use Math::Prime::Util qw/is_prime prev_prime next_prime/;

    my $s = sum0 map { ord($_) } split //, $str;

    if ( is_prime($s) )
    {
        return 0;
    }
    else
    {
        my $p = prev_prime($s);
        my $n = next_prime($s);
        return min( $s-$p, $n-$s );
    }
}

The Perl knowledge required is:

An ord() function exists that gives the ASCII value of English letters.
Library functions exist to sum a list and find the minimum of a list.
A CPAN module exists for finding prime numbers.

The possibly confusing line that does most of the work evaluates from right to left

my $s = sum0 map { ord($_) } split //, $str;

split //, $str -- change string into an array of individual characters
map { ord($_) } -- transform each character into its ASCII value
sum0 -- add the ordinal values, returning zero if the list is empty

The rest is calls to subroutines in Math::Prime::Util.

PWC 391 Median Boxes

Bob Lied — Thu, 17 Sep 2026 22:00:08 +0000

The first task asks us to combine sorted arrays and find the median, and the second asks us to combine boxes by stacking them inside each other. I feel the urge to merge.

Task 1: Array Median

The median is the middle point in a sorted list. Our musical selection should a couple of songs titled 'The Middle', one by Jimmy Eat World (warning, the video features a lot of people in underwear, probably NSFW), and the other by Zedd, Maren Morris, and Grey.

Task Description

You are given two sorted arrays. Write a script to merge the two given sorted arrays and return the median of the merged array.

Example 1: Input: @arr1 = (2), @arr2 = (4) Output: 3.0
Example 2: Input: @arr1 = (1,2,3), @arr2 = (7,8,9,10) Output: 7.0
Example 3: Input: @arr1 = (), @arr2 = (10,20,30,40) Output: 25.0
Example 4: Input: @arr1 = (100), @arr2 = (1,2,3,4,5,6,7) Output: 4.5
Example 5: Input: @arr1 = (1,2,2), @arr2 = (2,2,3) Output: 2.0

Task Solution

The obvious thing to do here is to sort the two arrays together and index into the middle of the combined array.

sub task1($arr1, $arr2)
{
    my @all = sort { $a <=> $b } $arr1->@*, $arr2->@*;
    if ( @all >= 1 )
    {
        if ( @all % 2 ) # Odd number of elements
        {
            return $all[ floor(@all/2) ];
        }
        else # Even number of elements
        {
            my $mid = @all / 2;
            return ($all[$mid] + $all[$mid-1]) / 2;
        }
    }
    else # No elements, two empty lists were given
    {
        return undef;
    }
}

Another obvious thing to do is to use any of several modules that do statistics. Here are three possibilities. Each of them follows the pattern of loading the data into the module, and then invoking a median function on the loaded data.

sub task2($arr1, $arr2)
{
    return undef unless @$arr1 || @$arr2;
    use Statistics::Basic::Median;
    return 0+ Statistics::Basic::Median->new( sort { $arr1->@*, $arr2->@* );
}

sub task3($arr1, $arr2)
{
    return undef unless @$arr1 || @$arr2;
    use Statistics::Descriptive;
    my $stat = Statistics::Descriptive::Full->new;
    $stat->add_data( $arr1->@*, $arr2->@* );
    return $stat->median;
}

sub task4($arr1, $arr2)
{
    return undef unless @$arr1 || @$arr2;
    use PDL;
    my $data = pdl ( $arr1->@*, $arr2->@* );
    return median($data);
}

All of these solutions have quite a bit of overhead because they require sorting the data. We are given that the arrays are already sorted individually, so there's a much more efficient solution: merge the arrays in one pass. And because we only want the midpoint, we don't even have to merge completely -- we can stop after we've reached the midpoint.

sub task($arr1, $arr2)
{
    return undef unless @$arr1 || @$arr2;

    # Make copies of arr1 and arr2 because we're going to destroy them
    my @a1 = $arr1->@*;
    my @a2 = $arr2->@*;

    my $length = @a1 + @a2;
    my $mid = floor($length / 2);
    my $isOdd = $length % 2;

    my @merged;

    while ( @a1 && @a2 && @merged <= $mid )
    {
        push @merged, ( $a1[0] < $a2[0] ? shift(@a1) : shift(@a2) );
    }

    # At this point, if we haven't merged enough elements to reach
    # the midpoint, then we've exhausted either a1 or a2. Add enough
    # elements to reach the midpoint.
    if ( @merged <= $mid )
    {
        my $toMidPoint = $mid - @merged;
        if   ( @a1 ) { push @merged, @a1[0 .. $toMidPoint] }
        else         { push @merged, @a2[0 .. $toMidPoint] }
    }

    return $isOdd ? $merged[$mid] : ( ($merged[$mid] + $merged[$mid-1]) / 2);
}

Task Comparison

Are any of these significantly more efficient? Here's a benchmark result for the median of two 100-element arrays:

          Rate descr merge basic   diy
descr  38567/s    --  -49%  -54%  -83%
merge  75269/s   95%    --  -10%  -66%
basic  83832/s  117%   11%    --  -62%
diy   222222/s  476%  195%  165%    --

Although I would have thought the merge would be quite good, the fastest solution appears to be the do-it-yourself sort. This is probably because, even though it starts with a sort, the underlying algorithm is merge sort. Because the individual arrays are already sorted, the merge sort will converge quickly, and in optimized compiled code instead of interpreted Perl.

Task 2: Arrange Boxes

Task Description

You are given an array of box dimensions. Write a script to determine the maximum number of these boxes that can fit inside each other in a single stack. For a box to fit inside another, it must be smaller in both dimensions.

Example 1:
- Input: @boxes = ([1, 3], [3, 5], [6, 8], [2, 4])
- Output: 4
- Sort by width ascending: ([1, 3], [2, 4], [3, 5], [6, 8])
- Extract heights: [3, 4, 5, 8]
- [1, 3] -> [2, 4] -> [3, 5] -> [6, 8]
Example 2:
- Input: @boxes = ([4, 5], [4, 6], [6, 7], [2, 3], [4, 3])
- Output: 3
- Sort by width ascending: ([2, 3], [4, 6], [4, 5], [4, 3], [6, 7])
- Extract heights: (3, 6, 5, 3, 7)
- [2, 3] -> [4, 5] -> [6, 7]
Example 3:
- Input: @boxes = ([5, 5], [5, 5], [5, 5])
- Output: 1
- Sort by width ascending: ([5, 5], [5, 5], [5, 5])
- Extract heights: (5, 5, 5)
- [5, 5]
Example 4:
- Input: @boxes = ([2, 100], [3, 200], [4, 300], [5, 50], [5, 400])
- Output: 4
- Sort by width ascending: ([2, 100], [3, 200], [4, 300], [5, 400], [5, 50])
- Extract heights: (100, 200, 300, 400, 50)
- [2, 100] -> [3, 200] -> [4, 300] -> [5, 400]
Example 5:
- Input: @boxes = ([10, 20], [15, 10], [20, 30], [12, 18], [16, 25])
- Output: 3
- Sort by width ascending: ([10, 20], [12, 18], [15, 10], [16, 25], [20, 30])
- Extract heights: (20, 18, 10, 25, 30)
- [15, 10] -> [16, 25] -> [20, 30]

Task Solution

The examples hint very strongly that sorting by width and height could solve the problem, and indeed, for the examples, it does. I can't convince myself that my stacks won't be thwarted by long skinny boxes that sort into an inconvenient position. So I'm going to treat it as another search problem.

The task doesn't mention the possibilities of rotating boxes, nor of putting small boxes side-by-side in bigger boxes. So I'm not going to consider those possibilities.

Side Quest: A Box Class

I'm going to develop a small class around boxes, instead of depending on the convention of indexes 0 and 1 for width and height. It will add some readability to whether one box can be contained in another.

use feature 'class'; no warnings "experimental::class";

class Box {
    field $w : param(width)  :reader;
    field $h : param(height) :reader;

    method show() { "[$w x $h]" }
    use overload '""' => sub { $_[0]->show() };

    method canHold($other)
    {
        return $other->w < $w && $other->h < $h;
    }

}

Notes:

I'm using Perl 5.44, so the class feature is available, but experimental. I don't want to see those warnings, thanks anyway.
The constructor will get height and width parameters, and the :reader attribute will create accessors.
For convenience in debugging, I want to be able to print a Box object easily. Overloading the string ("") operator will make a textual representation of the object whenever I interpolate a Box object reference in a string.
The most important method I need is to test whether one Box can contain another.

The Main Quest

Similar to last week, there'll be queue of possibilities to look at, and we'll try to extend each stack as far as we can.

I'll work from the outside in, starting with the biggest containers, and considering all the rest that might fit inside.

sub task(@boxes)
{
    return 0 unless @boxes;

    # Turn given size pairs into Box objects.
    my @box = map { Box->new(width => $_->[0], height => $_->[1]) } @boxes;

    my $biggest = 1;

    # Set up a todo list, where each item contains
    # the stack so far, and the possible boxes that
    # could still fit inside. To begin, any box can
    # potentially be the biggest container.
    my @todo = ();
    for my $b ( @box )
    {
        my $stack     = [ $b ]; # The outside container
        # Choose boxes that could fit inside
        my $available = [ grep { $b->canHold($_) } @box ];
        push @todo, [ $stack, $available ];
    }

    # Process the todo list, FIFO breadth-first
    while ( my $x = shift @todo )
    {
        my ($stack, $available) = $x->@*;

        $biggest = @$stack if ( @$stack > $biggest );

        # We can stop working on this stack if there
        # aren't enough boxes to improve on biggest
        next if ( @$available == 0 || @$stack + @$available) <= $biggest;

        for my $nextSmallerBox ( $available->@* )
        {
            push @todo, [ [ $stack->@*, $nextSmallerBox ],
                        [ grep { $nextSmallerBox->canHold($_) } $available->@* ],
                        ];
        }
    }
    return $biggest;
}

PWC 390 Weird Ways to Wrangle Words

Bob Lied — Wed, 09 Sep 2026 15:06:01 +0000

Episode 390 of The Weekly Challenge brings us a couple of tasks that turned out to be less code than I first thought. Let's put on some mood music and have a look. How about Sarah McLachlan's 1997 album, Surfacing, where the first song is titled "Building a Mystery" -- appropriate for a task about decoding.

Task 1: Decode String

Task Description

You are given an encoded string. Write a script to return the decoded string of the given encoded string. The encoding rule is: K[encoded_string], where the encoded_string inside the square brackets is repeated exactly K > 0 times.

Example 1:
- Input: $str = "2[3[a]]"
- Output: "aaaaaa"
- 3[a] => aaa
- 2[3[a]] => aaa aaa
Example 2:
- Input: $str = "10[a]"
- Output: "aaaaaaaaaa"
Example 3:
- Input: $str = "a2[b]c3[d]e"
- Output: "abbcddde"
Example 4:
- Input: $str = "2[a2[b]c]"
- Output: "abbcabbc"
Example 5:
- Input: $str = "1[a]2[b3[c]]"
- Output: "abcccbccc"

Task Analysis

At first glance, this looked like it was going to involve parsing balanced sets of nested brackets, which would mean some kind of stack structure, or maybe a simple recursive descent parser. It might be an opportunity to apply Perl modules that help with extracting balanced bracket groups; Text::Balanced for example.

However, backing off the keyboard for a moment, I noticed that there is a fundamental unit in the encoding. To repeat a constant string, the form is N[s]. This means to repeat the string s for N times. Perl has a replication operator, $s x $N, which also means to repeat a string $s for $N times.

A textual transformation can turn a fundamental group into a bit of equivalent Perl code. Execute the bit of code and that string is decoded.

# "3[a]" ==> eval { 'a' x 3 } ==> 'aaa'
s/ (\d+) \[ ( [^[\]]+) \] /$2 x $1/xeg

Some regular expression deep cuts here:

/x -- this flag allows me to add some white space into the regular expression for readability. You are free to judge just how much readability was accomplished.
(\d+) -- captures a group of digits as $1.
\[ and \[ -- the brackets would be meta-characters, so they need to be escaped to match literally.
[^[\]]+ -- matches any character that is not a bracket. This will be captured into $2. Note that I can't just move forward over everything that's not a ']' -- it would fail for strings like Example 1 ("2[3[a]]"), because it would match "3[a" after the "2[".
/e - this flag executes the code in the substitution.

When this substitution is applied, it eliminates a level of brackets. If we keep doing that until there are no brackets left, then we will have decoded the entire string. The task reduces to a one-liner.

sub task($str)
{
    while ( $str =~ s/ (\d+) \[ ( [^[\]]+ ) \] /$2 x $1/gxe ) { }
    return $str;
}

Task 2: Order Characters

Task Description

You are given a string $s (containing only alphabetic characters) and an integer $k > 0. Write a script to choose one of the first $k letters of the given string and append it at the end of the string. You keep doing this until you have lexicographically smallest string and return the string.

Example 1:
- Input: $str = "dbca", $k = 1
- Output: "adbc"
  - Move 1: "bcad"
  - Move 2: "cadb"
  - Move 3: "adbc"
Example 2:
- Input: $str = "geeks", $k = 2
- Output: "eegks"
  - First 2 letters: "g", "e"
  - Move 1: "gekse" (move second letter "e")
  - Move 2: "gksee" (move second letter "e")
  - Move 3: "kseeg" (move first letter "g")
  - Move 4: "seegk" (move first letter "k")
  - Move 5: "eegks" (move first letter "s")
Example 3:
- Input: $str = "cbaed", $k = 3
- Output: "abcde"
  - First 3 letters: "c", "b", "a"
  - Move 1: "cbeda" (move "a")
  - Move 2: "cedab" (move "b")
  - Move 3: "edabc" (move "c")
  - Move 4: "eabcd" (move "d")
  - Move 5: "abcde" (move "e")
Example 4:
- Input: $str = "fedcba", $k = 4
- Output: "abcdef"
  - First 4 letters: "f", "e", "d", "c"
  - Move 1: "fdcbae" (move "e")
  - Move 2: "dcbaef" (move "f")
  - Move 3: "dcbefa" (move "a")
  - Move 4: "dcefab" (move "b")
  - Move 5: "defabc" (move "c")
  - Move 6: "efabcd" (move "d")
  - Move 7: "fabcde" (move "e")
  - Move 8: "abcdef" (move "f")
Example 5:
- Input: $str = "perl", $k = 1
- Output: "erlp"
Example 6:
- Input: $str = "oloolooo", $k = 1
- Output: "looloooo"
Example 7:
- Input: $str = "oloooolo", $k = 1
- Output: "looloooo"

Task Analysis

At first glance, the randomness of choosing one of $k positions seems to make this a difficult problem. However, what we really have here is a search problem over all possible moves. Which, OK, still potentially a hard problem.

From the start word, we have $k new words that could be generated, and from each of those, $k more. Clearly this could blow up if $k is more than a small integer, but I don't see any way to take shortcuts, so exhaustive search it is.

Searches are often presented or taught as recursive algorithms, but recursion is really just a way of hiding a stack. Searching requires two data structures: a stack or queue to hold the possibilities we haven't checked yet, and a lookup table to record things we have checked, so we don't get stuck in a loop.

Side Quest

I'll want a convenient way to transform a word. Given a value of $k, it should return the string with the k'th letter moved to the end of the string. I'm going to do it by combining the substring before k, the substring after k, and then k.

sub move($s, $k)
{
    substr($s, 0, $k-1) . substr($s, $k) . substr($s, $k-1, 1);
}

That feels like a lot of string operations. If we wanted to be too clever by half (and who doesn't), we could go into the fine print of the substr function and read about the optional fourth argument, which replaces a piece of the string and returns what was there before. Armed with that dangerous piece of knowledge, we could write magic that erases letter k and makes it reappear at the end.

sub move($s, $k) { $s .= substr($s, $k-1, 1, ''); }

The search is on

For the search itself, I'll prime the pump by putting the first set of moves onto the stack, then processing the stack until it's empty. As we take a word off the stack, we'll ignore it if it's a word we've already processed. Otherwise, check if it's the best yet, and then generate a new set of $k moves for the stack.

sub task($str, $k)
{
    die "k out of range" if $k < 1 || $k > length($str);
    my $best = 'z' x length($str);

    my %seen;
    my @stack;

    push @stack, map { move($str, $_) } 1 .. $k;

    while ( my $word = pop @stack )
    {
        next if $seen{$word};
        $seen{$word} = true;

        $best = $word if $word lt $best;

        push @stack, map { move($word, $_) } 1 .. $k;
    }
    return $best;
}

Notes:

We can push multiple items onto the end of an array in one statement. Instead of a for loop, I'm using map to make a list of the $k moves.
Lexicographic comparison uses the lt operator instead of <.
I'm using pop to process the stack, which makes it a depth-first search. If I used shift, it would be a breadth-first search (and the stack would act like a queue). Since we have to look at every possible word, it doesn't much matter which we use.

But wait, there's more

This solution doesn't record the set of moves that got to the result. If I needed that, the stack would contain records of two things: the word to be processed, and a reference to a list of words. The initial stack for Example 3 would look like:

( ["baedc", ["cbaed"] ],    # move("cbaed", 1)
  ["caedb", ["cbaed"] ],    # move("cbaed", 2)
  ["cbeda", ["cbaed"] ], )  # move("cbaed", 3)

Processing the stack would involve unpacking this structure, and growing the list of words that got us here.

while ( pop @stack )
{
    my $word = $_->[0];
    my $howWeGotHere = $_->[1];
    next if $seen{$word};
    $seen{$word} = true;
    push @$howWeGotHere, $word;

To get this information out of the function, we would need to remember not only the best word, but also the path that reached it. We would then return either a pair of values in a list, or return multiple values. Returning multiple values stumbles into the swamp of array versus scalar context, so I prefer to return a single reference to a pair of things.

my $best = 'z' x length($str);
my $bestPath = [ $str ];
[ . . . ]
    if ( $word lt $best ) {
        $best = $word;
        $bestPath = [ $howWeGotHere->@* ];
    }
[ . . . ]
return [$best, $bestPath];

PWC 388 Dyck Words: I Refuse to Indulge in the Obvious Jokes

Bob Lied — Sun, 30 Aug 2026 23:00:20 +0000

As soon as I saw the title of this week's challenge, I had to run to Google. As a person with a German surname that is sometimes mispronounced for sophomoric humor, I did not want to fall into that trap. Sure enough, that name is pronounced "deek", so let's restrain ourselves, shall we?

On the other hand, as a person with the emotional maturity of a fourteen-year-old, I am well aware of the Letterkenny Dycks. So, take a moment and I'll meet you back here.

Now that we have that out of our system, let's begin.

Task 1:: Dyck Words

A Dyck Word of order n is a string of length 2n consisting of n ‘U’ (Up) characters and n ‘D’ (Down) characters such that no initial prefix of the string contains more ‘D’s than ‘U’s.

Write a script to return a list of all valid Dyck words of length 2n, sorted in lexicographical (alphabetical) order.

Example 1: _Input: $n = 1
- Output: ("UD")
Example 2: Input: $n = 2
- Output: ("UDUD","UUDD")
Example 3: Input: $n = 3
- Output: ("UDUDUD", "UDUUDD", "UUDDUD", "UUDUDD", "UUUDDD")
Example 4: Input: $n = 0
- Output: ("")
Example 5: Input: $n = 4
- Output: ("UDUDUDUD", "UDUDUUDD", "UDUUDDUD", "UDUUDUDD", "UDUUUDDD", "UUDDUDUD", "UUDDUUDD", "UUDUDDUD", "UUDUDUDD", "UUDUUDDD","UUUDDDUD", "UUUDDUDD", "UUUDUDDD", "UUUUDDDD")

Discussion

This pattern can be visualized as walking along a grid, starting at (0,0), staying entirely inside the wedge between 0° and 45°, and ending back on the x axis. If you replace 'U' and 'D' with '(' and ')', it represents strings with balanced parentheses.

Generating these strings is going to be some kind of recursive algorithm. While checking on the pronunciation of "Dyck", I stumbled on a CPAN module, Math::DyckWords, that implements these strings. Peeking at the source code, sure enough there's a recursive algorithm. Just like AI, I'm going to train myself by scanning a public web site, regurgitating something similar, taking credit for it, and skimming over the ethical implications.

Implementation

Working top-down, I'm going to assume that there's a function that can return a list of appropriate strings. I'll handle the special case of 0, and turn the list into the sorted set that the problem specifies. Because of the way the recursion works, and because we've chosen to use the letters U and D, it turns out that the list comes back in reverse alphabetical order, so we can avoid sorting.

sub task($n)
{
    my $result = $n ? generateDyck($n) : [""];
    return [ reverse $result->@* ];
}

On to the meat of the problem. My recursive function will have a signature that reflects how deep into the string we've come.

sub generateDyck($n, $dyck=[], $word='U', $nU=1, $nD=0, $depth=1)
{
  [ . . . ]
}

I'm making generous use of default values for parameters. The first call from task() is just generateDyck($n), so all the rest of the parameters will get their values from the signature. The list of words will accumulate in the $dyck array. The word we're currently working on is in $word. Our first character is always a 'U', and the counts reflect that. The $depth parameter is the depth of the recursion; it's not really necessary but helps in debugging.

To build the string, we add a letter at a time, preferring 'U' first. The number of D's can never get ahead of the number of U's. Eventually we return the reference to the list of words; the return value is only really used at the top-level call.

    # We have space to add both a U and a D
    if ( $nU < $n && $nD < $n && $nU > $nD )
    {
        # U goes before D
        generateDyck( $n, $dyck, $word . 'U', $nU + 1, $nD     , $depth++ );
        generateDyck( $n, $dyck, $word . 'D', $nU,     $nD + 1 , $depth++ );
    }

    # We have space, but a U must be next
    if ( ( $nU < $n && $nD < $n && $nU == $nD ) ||
         ( $nU < $n && $nD == $n ) )
    {
        generateDyck( $n, $dyck, $word . 'U', $nU + 1, $nD , $depth++ );
    }

    if ( $nU == $n )
    {
        # We have all the Us, must add enough D to balance.
        if ( $nD < $n  )
        {
            my $need = $n - $nD;
            generateDyck( $n, $dyck, $word . ('D' x $need), $nU, $nD + $need , $depth++ );
        }
        else # $nD == $n
        {
            # We have n of each, so save a complete word.
            push @$dyck, $word;
        }
    }
    return $dyck;

PWC 386 All Your Base Are Belong to Rational Numbers

Bob Lied — Fri, 14 Aug 2026 16:41:36 +0000

We have a couple of math problems for this week's challenge tasks. Let's set the mood with Paul Simon's song, "When Numbers Get Serious", from the under-rated 1983 album, Hearts and Bones.

Task 1: Reverse Base

Task Description

You are given a string representing a number, and an integer specifying the base of that representation.

Write a function to convert this string to an integer. (For bases greater than 10, use characters A-Z, a-z, + and / in that order.)

Example 1 Input: $num = "101010", $base = 2 Output: 42
Example 2 Input: $num = "EEADEE", $base = 16 Output: 15642094
Example 3 Input: $num = "755", $base = 8 Output: 493
Example 4 Input: $num = "1BRJB", $base = 36 Output: 2228519
Example 5 Input: $num = "7MyqL", $base = 64 Output: 123456789

Observations

This is the inverse of last week's problem. We need a table that looks up the values of the symbols, and a loop that multiplies each digit to its exponent place in the number.

Implementation

sub task($num, $base)
{
    state %VALUE = do { my $v = 0; map { $_ => $v++ } ( '0'..'9', 'A'..'Z', 'a'..'z', '+', '/'); };

    my $n = 0;
    my $place = 1;
    while ( (my $d = substr($num, -1, 1, '') ) ne '' )
    {
        $n += $place * $VALUE{$d};
        $place *= $base;
    }
    return $n;
}

Notes:

The %VALUE hash is created once (use of state variable).
The do statement lets me localize the index variable, $v.
We loop by taking the last character from $str each time. There are a couple of trivial variations:
- We could split the string into individual characters and pop characters
- We could reverse the string and loop forwards instead.

Task 2: Rational Numbers

Task Description

You are given two strings representing non-negative rational numbers. Write a script to return true if the two given rational numbers are same otherwise false.

Example 1:
- Input: $rat1 = "0.(12)" $rat2 = "0.(121)"
- Output: false
- Expansion of "0.(12)" = 0.12121212...
- Expansion of "0.(121)" = 0.121121121...
Example 2:
- Input: $rat1 = "0.1(23)" $rat2 = "0.12(32)"
- Output: true
- Expansion of "0.1(23)" = 0.1232323...
- Expansion of "0.12(32)" = 0.12323232...
Example 3"
- Input: $rat1 = "0.1(234)" $rat2 = "0.12(342)"
- Output: true
Example 4:
- Input: $rat1 = "12.99(99)" $rat2 = "13."
- Output: true
Example 5:
- Input: $rat1 = "0.(123)" $rat2 = "0.1(231)"
- Output: true

Observations

There's a temptation to do something with string manipulation to see if $rat1 can be converted to $rat2, but Example 4 trips that up. What this requires is to think back to middle-school math and recall how to convert a repeating decimal to the form of a rational number with a numerator and denominator.

If we convert both rat1 and rat2 into the form of rational numbers we can compare them.

So how do we convert decimal representation to a rational number? The trick is to multiply the number by enough powers of 10 so that all the fixed parts are left of the decimal, and the repeating part starts at the decimal. Then subtract away the repeating decimals to leave a simple division.

For example, let's take example 4, 12.(99). Let s=12.(99). Then, 100s = 1299.(99).

   100s = 1299.9999...
   -  s =   12.9999...
   -------------------
    99s = 1287.0

    s = 1287/99 = 13/1

In general, we'll have to identify the fixed and repeating parts, then use their lengths to set up multipliers to shift the decimal point.

Perl has modules for doing arithmetic with rational numbers. The most convenient is bigrat. It has some nice properties. First, it's a core module, so it's always present without an external dependency. Second, it reduces fractions to their lowest-common-denominator form (e.g., 1/2 compares equal to 2/4), so we don't have to worry about that. And, third, it overloads the common arithmetic operators, including == comparison.

Implementation

If we assume we can create a rational number from the odd representation given as input (let's defer that assumption into a function called asRational()), then the main task is simple:

use bigrat;
sub task($rat1, $rat2)
{
    my $r1 = asRational($rat1);
    my $r2 = asRational($rat2);
    return $r1 == $r2;
}

So the remaining problem is to write asRational(). It needs to extract the fixed and repeating parts, which can be done with a regular expression. Then it needs to figure out the multipliers needed, based on the lengths of the strings.

sub asRational($rat)
{
    my ($whole, $fixed, $repeat) = $rat =~ m/
            (\d*)       # Capture whole number part before decimal
            \.          # Decimal point always present
            (\d*)?      # Capture optional fixed digits
            (?:\(       # Group the part in parentheses
            (\d+)       # Capture repeating digits
            \))?        # Close parentheses group, repeat is optional
            /x;
    $fixed ||= 0;
    $repeat ||= 0;

    # Multiplier to move fixed to right of decimal point.
    my $multFixed  = ( $fixed  ? 10 ** length($fixed)      : 1 );

    # Multiplier to move repeat to right of decimal point, minus 1
    my $multRepeat = ( $repeat ? 10 ** length($repeat) - 1 : 1 );

    # Move all digits right of decimal point. Example: 1.2(34) --> 1234.
    my $numerator   = ($whole * $multFixed + $fixed) * $multRepeat + $repeat;

    my $denominator = $multFixed * $multRepeat;

    # Returns a BigRat object, not math. Handles reducing fractions.
    return $numerator / $denominator;
}

Notes:

Both the fixed and repeat parts are optional. If they're not picked up by the regular expression match, set them to zero so that they disappear in the later arithmetic (as opposed to causing exception for using an undefined value).
Similarly, for the multipliers, use 1 if not present, otherwise the '0' would be a string of length 1 and cause the multiplier to be 10.
The rest is math, except that the / opertor is overridden by the bigrat module. It no longer does division; it constructs a Math::BigRat object representing a rational number with a numerator and a denominator.

PWC 382 Replace Question Marks

Bob Lied — Wed, 15 Jul 2026 17:00:51 +0000

Task 2: Replace Question Mark

You are given a string that contains only 0, 1 and ? characters.

Write a script to generate all possible combinations when replacing the question marks with a zero or one.

Example 1: Input: $str = "01??0"
Output: ("01000", "01010", "01100", "01110")

Cogitation

The "?" reminds me of shell file name expansion. In bash and similar shells, a question mark acts as a wild card, and there is also the expansion that a group in braces expands to all combinations of the things in braces. For example,

$ echo "a{01}b"
a0b a1b

Perl can do the same trick with the glob function, performing the expansion into a list:

say $_ for glob("a{0,1}b");

So a one-liner solution converts every '?' into the string "{0,1}" and then applies glob.

perl -wE 'say join " ", glob($ARGV[0] =~ s/\?/{0,1}/gr )' "a?c"
a0ca1c

More fun would be to process the substitution. Create a queue of possible strings, starting with the given string. Take the string from the head of the queue and replace it with two new strings that have a "0" and "1" in place of the question mark; put those strings at the end of the queue. If there are no question marks, then that's a final string that's part of the solution.

Implementation

sub task($str)
{
    my @replaced;

    my @queue = ( $str );
    while ( defined(my $s = shift @queue) )
    {
        if ( index($s, '?') >= 0 )
        {
            push @queue, ($s =~ s/\?/0/r), ($s =~ s/\?/1/r);
        }
        else
        {
            push @replaced, $s;
        }
    }

    return \@replaced;
}

Notes:

I like to use index instead of regular expression match when I can, because it's (probably) more efficient.
Multiple things can be pushed onto a list in one statement.

PWC 382 Hamiltonian Cycle

Bob Lied — Wed, 15 Jul 2026 02:08:26 +0000

It would be so easy to say that the musical selection for this week's challenges is the Hamilton soundtrack, but what came to mind is that these are search problems, so I'm reaching back fifty years to Chicago and "(I've Been) Searchin' So Long".

Task 1: Hamiltonian Cycles

You are given a target number. Write a script to arrange all the whole numbers from 1 up to the given target number into a circle so that every pair of side-by-side numbers adds up to a perfect square. Please make sure, the last number and the first must also add up to a square.

Example: for n=32, a cycle would be: 1, 8, 28, 21, 4, 32, 17, 19, 30, 6, 3, 13, 12, 24, 25, 11, 5, 31, 18, 7, 29, 20, 16, 9, 27, 22, 14, 2, 23, 26, 10, 15

Cogitation

Imagine that the numbers 1 through n are nodes in a graph. There's an edge from one node to another if their sum is a square (1 can go to 8 or 3 or 15, for example). The problem is to visit each node once in this graph, and end up back at the start node -- a Hamiltonian cycle. This is related to the traveling salesman problem, and is in the same NP-complete category of being potentially very difficult to solve in the general case.

Instead of explicitly building a representation of this graph, I took the approach of a breadth-first search. Let's start with 1 (any starting point will do, since it's a cycle), and queue up all the subsequent numbers that would work (1,3, 1,8, 1,15, 1,24). Then, from the remaining numbers, let's branch out to the next possibilities (1,3,6, 1,3,12, 1,3,21, 1,8,7, etc.), and continue evaluating each growing sequence until it either gets back to the start or runs out of square sums.

Implementation

The first thing I need to know is which square numbers are in play. The largest sum we can form is n+(n-1), so I want a list of squares that are less than 2n-1.

state @Square = map { $_*$_ } 2 .. floor(sqrt(2*$n - 1));

My breadth-first search is going to build up a queue of possible sequences, and the remaining available numbers excluding what's in the sequence. The seed sequence is [1], with the numbers from 2 to n available.

my @queue = ( [ [1], [ 2 .. $n] ] );

@queue is a list of pairs; each member of the pair is a list.

Now, while there are things in the queue, we want to try to extend each sequence with a number that adds up to a square. The basic structure of the loop will look like

    my @cycle;  # There can be more than one
    while ( @queue )
    {
        my ($sequence, $available) = shift(@queue)->@*;
        if ( @$available == 0 ) {
            # Used up all the numbers, is it a cycle?
        }
        else {
            my $j = $sequence->[-1]; # End of the sequence
            # Extend the sequence if possible, or drop it
        }
    }
    return \@cycle;

If we have a sequence that uses up all the numbers, we need to verify that it completes a cycle by adding the first and last numbers. If so, we can save the sequence as a possible return value. If not, oh well, we wasted time and we go on the next possibility in the queue.

        if ( @$available == 0 )
        {
            if ( any { $_ == $sequence->[0] + $sequence->[-1] } @Square )
            {
                push @cycle, $sequence;
            }
            else { next; }
        }

The first and last elements of the sequence are from indexes 0 and -1. I use List::Util::any to check if that sum exists in @Square, the short list of possible squares that we set up at the beginning.

The other possibility is that we can try to extend the sequence. Given the last number from the sequence (call it $j), we need to add a number to it to reach a square. The possibilities are all squares from @Square that are greater then $j. If those numbers are available, move the number from the $available list to the $sequence list, and then add that to the end of the queue.

my $j = $sequence->[-1];
for my $sq ( grep { $_ > $j } @Square )
{
    my $diff = $sq - $j;
    if ( (my $which = first_index { $_ == $diff } $available->@*) >= 0 )
    {
        my @avail = $available->@[0..$which-1, $which+1 .. $available->$#*];
        push @queue, [ [ $sequence->@*, $diff ], [ @avail ] ];
    }
}

Notes:

The end of the list is right there at index [-1].
The only possible squares we might form are ones that are bigger then $j and in the @Square list we helpfully formed earlier, so let's only consider that short list.
I'm using List::MoreUtils::first_index to look up the number I need. It's a linear search but in a short list, so possible inefficiency doesn't bother me much.
Having the index makes it possible to reduce my new available list by using an array slice to select the ranges before and after the element we want to delete.
We can now push our new, longer sequence and our new, shorter available list to the end of the queue for consideration later.

Okay, finally all in one piece, this is what I have:

sub task($n)
{
    use List::AllUtils qw/any first_index/;
    # All the squares that might be sums of the available numbers.
    state @Square = map { $_*$_ } 2 .. floor(sqrt(2*$n - 1));

    my @queue = ( [ [1], [ 2 .. $n] ] );

    my @cycle = ();
    while ( @queue )
    {
        my ($sequence, $available) = shift(@queue)->@*;
        if ( @$available == 0 )
        {
            if ( any { $_ == $sequence->[0] + $sequence->[-1] } @Square )
            {
                push @cycle, $sequence;
            }
            else { next; }
        }

        my $j = $sequence->[-1];
        for my $sq ( grep { $_ > $j } @Square )
        {
            my $diff = $sq - $j;
            if ( (my $which = first_index { $_ == $diff } $available->@*) >= 0 )
            {
                my @avail = $available->@[0..$which-1, $which+1 .. $available->$#*];
                push @queue, [ [ $sequence->@*, $diff ], [ @avail ] ];
            }
        }
    }
    return \@cycle;
}

Surprise

So, with all the pieces in place, I run the program and the answer doesn't match the example. It turns out that there are multiple possible Hamiltonian cycles (2 for n=32, 22 for n=34, and 115 for n=35).

PWC 376 Doubled Words

Bob Lied — Thu, 04 Jun 2026 14:18:08 +0000

There are two things that every Perl developer knows:

Parsing HTML with regular expressions is a bad idea.
My situation is unique and exceptional, such that parsing HTML with regular expressions is ingenious and optimal.

Let's see the task. I think you know where this is going.

Task 2: Double Words

You are given a string (which may contain embedded newlines) which is taken from a page on a website. The string will not contain brackets [].

Write a script that will find doubled words (such as “this this”) and highlight (wrap in brackets) each doubled word.

The script should:

Work across lines, even finding situations where a word at the end of one line is repeated at the beginning of the next.
Find doubled words despite capitalization differences, such as with 'The the...', as well as allow differing amounts of whitespace (spaces, tabs, newlines, and the like) to lie between the words.
Find doubled words even when separated by HTML tags. For example, to make a word bold: '...it is very very important...'.
Only show lines containing doubled words.

Adapted from Mastering Regular Expressions, Third Edition, by Jeffrey E. F. Friedl

Example 1
- Input: $str = "you're given the job of checking the pages on a\nweb server for doubled words (such as 'this this'), a common problem\nwith documents subject to heavy editing."
- Output: "web server for doubled words (such as '[this] [this]'), a common problem"
Example 2
- Input: $str = "Find doubled words despite capitalization differences, such as with 'The\nthe...', as well as allow differing amounts of whitespace (spaces,\ntabs, newlines, and the like) to lie between the words."
- Output: "Find doubled words despite capitalization differences, such as with '[The]\n[the]...', as well as allow differing amounts of whitespace (spaces,"
Example 3
- Input: $str = "to make a word bold: '...it is very very important...'."
- Output: "to make a word bold: '...it is [very] [very] important...'."
Example 4
- Input: $str = "Perl officially stands for Practical Extraction and Report Language, except when it doesn't."
- Output: ""
Example 5
- Input: $str = "There's more than one one way to do it.\nEasy things should be easy and hard things should be possible."
- Output: "There's more than [one] [one] way to do it."

So it begins

The reference to Mastering Regular Expressions seems like a pretty strong hint. Back when I was doing HTML and XML processing, I always favored using a module to parse tagged text (XML::Twig was a particular favorite), but let's take the hint.

A sort of obvious thing to do here is to split the string into words, but it's going to be annoying because of the possibility of HTML tags. And once we break the string up, we'll lose the space and tags that we need to retain for the requested output.

"The string will not contain brackets" is an odd thing to say. But it turns out to be useful, because we only want to print output lines that do contain brackets, so this little clause is actually doing us a favor.

An outline

Let's assume that we can conjure up a regular expression to use with split to extract the words; let's call it $sepRE. We can then compare consecutive pairs of words to find duplication. That solves half the problem, but loses the context in the original string. We need to reproduce the original text, plus highlighting brackets, including all the stuff between words.

Because we have weird habits, we have (more than once) read through all the documentation of split, and so we know that there is a variation in which the function can return both the desired substrings and the separators. To wit, if we enclose the regular expression in parentheses, split will return all the pieces of the string, alternating between separators and substrings. The first piece we need looks like:

my @word = split( /($sepRE)/, $str);

Now the words will be in either the even or odd elements of @word, depending on whether the string started with a separator. We can check for duplicates by skipping along in pairs.

# Take every other word. Skip over a leading separator.
my ($first, $second) = ( $word[0] =~ m/$sepRE/ )
                     ? (1,3) : (0, 2);

while ( $second <= $#word)
{
    my (@w) = ( $word[$first], $word[$second]);

    if ( $w[0] eq $w[1] )
    {
        $word[$first]  =~ s/($w[0])/[$1]/;
        $word[$second] =~ s/($w[1])/[$1]/;
    }
    $first += 2; $second += 2;
}

That marks up the duplicate words, but only in the @word array. We need to face the problem of getting the desired output. To get there, put the @word array back into a single string, and then grep for the lines that contain our newly-inserted brackets.

# Reassemble the string, now with some words possibly bracketed
my $highlighted = join("", @word);

# Output includes only lines where we inserted brackets
return join "\n",
            grep /[\[\]]/, 
                 split(/\n/, $highlighted);

A few minor details

Case insensitivity. In our check for duplicates, we need to ignore case differences, so let's compare the lowercase versions of the words: if ( lc($w[0]) eq lc($w[1]) )
Punctuation. As shown in Example 2, punctuation surrounding the words should be ignored. Let's whip up a quick function to trim leading and trailing punctuation (the [:punct:] character class is handy for this), and use it before we compare

sub trimPunct($word)
{
    $word =~ s/^[[:punct:]]+//;
    $word =~ s/[[:punct:]]+$//;
    return $word
}
. . .
my (@w) = ( trimPunct($word[$first]),
            trimPunct($word[$second]));

About that regular expression

Time to take care of that regular expression that acts as the word separator. With some experimentation (the regex101 web site is good for that), we arrived at this:

 state $sepRE = 
qr/ \s*     # Possible white space followed by
  (?:       # ( a group of a tag and more white space
   <[^>]*>  #  ... an HTML tag
   \s*      #  ... optional space
  )+        # ) there can be multiple tags
  | \s+     # Or just white space
/x;

Not too bad. Didn't even require look-around assertions. Some notes:

state $sepRE = qr/.../ -- This is a constant regular expression, so we can use state to only evaluate it once.
qr//x -- The x flag allows us to add formatting and comments to the expression
(?:...) -- We want to group, but we don't need the overhead of capturing, so (?:) is a non-capturing group.
complicated | \s+ -- Why is the complicated part first? Because the alternatives are evaluated left to right. If \s+ eats up the white space, the expression matches and wouldn't proceed to trying tags.

Okay, here's the whole thing.

sub task($str)
{
    state $sepRE = qr/ \s*     # Possible white space followed by
                     (?:       # ( a group of a tag and more white space
                      <[^>]*>  #  ... an HTML tag
                      \s*      #  ... optional space
                     )+        # ) There can be multiple tags
                     | \s+     # Or just white space
                   /x;

    # Using () in RE includes separators in the array
    my @word = split( /($sepRE)/, $str);

    # Take every other word. Skip over a leading separator.
    my ($first, $second) = ( $word[0] =~ m/$sepRE/ ) ? (1,3) : (0, 2);

    while ( $second <= $#word)
    {
        my (@w) = ( trimPunct($word[$first]), trimPunct($word[$second]));

        if ( lc($w[0]) eq lc($w[1]) )
        {
            $word[$first]  =~ s/($w[0])/[$1]/;
            $word[$second] =~ s/($w[1])/[$1]/;
        }
        $first += 2; $second += 2;
    }

    # Reassemble the string, now with some words possibly bracketed
    my $highlighted = join("", @word);

    # Output includes only lines where we inserted brackets
    return join"\n", grep /[\[\]]/, split(/\n/, $highlighted);
}

And the music for this week's challenge was Double Vision by Foreigner.

PWC 373 Task 2: Let's Dance to List Division

Bob Lied — Wed, 13 May 2026 23:22:28 +0000

The task title reminded me of the song Let's Dance to Joy Division. Oddly applicable lyrics for a blog about programming: "But I worked something out last night that changed this little boy's brain, a small piece of advice that took 22 years in the make, and I will break it for you now. Please learn from my mistakes." And who doesn't love a wombat?

Task Description

You are given a list and a non-negative integer, $n. Write a script to divide the given list into $n equal parts. Return -1 if $n is more than the size of the list.

Example 1

Input: @list = ( 1,2,3,4,5), $n = 2
Output: ((1,2,3), (4,5))

5 / 2 = 2 remainder 1. The extra element goes into the first chunk.

Example 2

Input: @list = (1,2,3,4,5,6), $n = 3
Output: ((1,2), (3,4), (5,6))

6 / 3 = 2 remainder 0.

Example 3

Input: @list = (1,2,3), $n = 2
Output: ((1,2), (3))

Example 4

Input: @list = (1,2,3,4,5,6,7,8,9,10), $n = 5
Output: ((1,2), (3,4), (5,6), (7,8), (9,10))

Example 5

Input: @list = (1,2,3), $n = 4
Output: -1

Example 6

Input: @list = (72,57,89,55,36,84,10,95,99,35), $n = 7;
Output: ((72,57), (89,55), (36,84), (10), (95), (99), (35))

Elaboration

There's some simple modulo division here, and then a decision about what to do if it doesn't divide evenly into $n chunks. We could put the remainder into a chunk of its own, ignore the remainder, or we could distribute the leftovers in some way that feels balanced -- here, the specification implies that the bigger divisions should go at the front of the list.

Handling an invalid input (where $n is too big) by returning -1 instead of an array is a code smell. Having a function that returns different types of things is awkward to handle and error-prone. It would be more consistent to either throw an exception, or return an out-of-range value of the same type, such as an empty array or a null reference. But that wanker Kevin with his six months of Javascript experience got promoted to project manager for some reason <cough/>nepotism<cough> and that's the requirement we have.

This task has six examples, and usually we're given five. Is there some significance to this? Example 6 doesn't seem to add any new information beyond what we've already been given. But then we notice that the numbers could be ASCII characters, spelling "H9Y7$T?_c#". I'm pretty sure this is Kevin's password. Watch your back, Kevin.

To the CodeMobile, Robin!

sub listDivision($list, $n)
{
    my $size = @$list;
    return -1 if $n > $size;

    my $chunk = floor($size / $n);
    my $extra = $size % $n;
    my @answer;

    while ( $extra-- ) { push @answer, [ splice(@$list, 0, $chunk + 1) ]; }
    while ( @$list   ) { push @answer, [ splice(@$list, 0, $chunk    ) ]; }
    return \@answer;
}

The input parameters are an array and a number, which forces us to confront the way that Perl passes arguments as a flat list. Here, I've chosen to pass an array reference for $list instead of an array, which accomplishes two things: it removes the flat list problem to make it obvious which parameter is $n, and it's more efficient than passing a copy of the array. I could have also passed the parameters in the other order, but "project manager" Kevin said according to ChatGPT and Claude it had to be in this order, so yeah, that's that then.

Time to be serious. We dispense with the special case of returning -1 (more on that later). Then we calculate the quantities involved, and set up an array for producing the answer, initially empty.

The answer has two segments: a head part where there might be one extra element, and the tail part where the segments are of the calculated chunk size. One while loop ticks off the extra-sized chunks, and the second while loop completes the division.

To grab a group of contiguous elements from a list, the splice function seems like the obvious thing to do. Each splice is surrounded with [] so that the chunks are treated as array references. An alternative would have been to take an array slice, but that would introduce index variables for the range being sliced, which looks and feels more complicated and error-prone.

splice reduces the size of the list every time it's called, so the second while loop can use the size of $list as its condition. However, we are destroying $list as we go, so the calling function needs to be aware that the array it passed in is no longer valid. If it were important to keep the original list, a copy would need to be made either from the caller, or near the beginning of listDivision().

Let's think a moment about how to use this function. When it's called it could return either an array of arrays (references actually), or it could return a scalar -1. Here's how I wanted to write the script to use this function, using -n as a command-line option to get that parameter:

use GetOpt::Long;
my $N = 1;
GetOptions("n:i" => \$N);
my $div = listDivision([@ARGV], $N);
say showAofA($div);

where showAofA() is a function that formats the array of arrays into a parenthesized list of comma-separated lists, as in the examples.

However, $div isn't always a reference; sometimes it's a scalar -1. That throws up an ugly error about trying to use a scalar value as a reference. The way to check what's behind a variable in Perl is to use the ref function. It will give a string identifying the variable type, or, for a scalar, it will give an empty string. In perl, an empty string counts as false. So, to satisfy the requirement, the script needs to test whether ref($div) is empty:

say ( ref($div) ? showAofA($div) : $div );

What I probably should have done is change listDivision so that it consistently returns an array reference, but for the invalid case, throws an error. Variations on try/catch have been available as modules in Perl for decades, but it finally (see what I did there?) became official in version 5.38. That simplifies the usage of the function (if you consider try/catch simpler, which some consider a debatable topic).

try          { say showAofA( listDivision([@ARGV], $N) ); }
catch ( $e ) { say "-1" }

To make the function throw an exception, we only need to change the early return from the function into a die:

sub listDivision($list, $n)
{
    my $size = @$list;
    die "N out of range (must be <= $size)" if $n > $size;
    # [ ... ]

That's cleaner, but it slightly complicates the unit testing, because now we have to test for exceptions. The incantation is:

sub runTest
{
    use Test2::V0;
    use Test2::Tools::Exception;
    # [Test cases that should work
    is( listDivision([1,2,3], 1), [[1,2,3]], "One chunk");
    # [ ... ]
    # Test things that throw exceptions
    like ( dies { listDivision( [1,2,3], 4) }, qr/out of range/);

The dies function returns the exception string that results from trying to execute a code block, and like does a pattern match against the expected exception.

And finally, to tidy up a loose end, here's the showAofA() function.

sub showAofA($ref)
{
    return '('. join(',', map { '('.join(',', $_->@*).')' } $ref->@*) .')';
}

Let's take a bunch of punctuation out of that so that we can see the structure:

return ( join( map { join } ) ref )

$ref is a reference to an array of references; hence, $ref->@* is de-referencing it to yield a list of array references.

Each of those array references is then transformed by map. Inside the map {} block, $_ refers to one of the inner arrays, so we de-reference that ($_->@*) to get a list of numbers, which we will join into a comma-separated string. Wrap that with a pair of parentheses, and out of the map comes the inner lists formatted as needed.

Now each of the inner lists is a string. The outer join inserts commas to make it a list of lists, and finally we wrap the whole thing in parentheses to complete the string.

PWC 371 Subset Equilibrium (Just nod if you can hear me)

Bob Lied — Tue, 28 Apr 2026 13:02:35 +0000

Another explosive weekly challenge. And by explosive I mean exponential complexity. Let's see what we've got. First I'll adjust the background music for equilibrium ... Comfortably Numb

Relax, I'll Need Some Information First

You are given an array of numbers. Write a script to find all subsets where the sum of elements equals the sum of their indices.

# Example 1 Input: @nums = (2, 1, 4, 3)
#.          Output: (2, 1), (1, 4), (4, 3), (2, 3)
#   Subset 1: (2, 1) Values: 2 + 1 = 3 Positions: 1 + 2 = 3
#   Subset 2: (1, 4) Values: 1 + 4 = 5 Positions: 2 + 3 = 5
#   Subset 3: (4, 3) Values: 4 + 3 = 7 Positions: 3 + 4 = 7
#   Subset 4: (2, 3) Values: 2 + 3 = 5 Positions: 1 + 4 = 5
#
# Example 2 Input: @nums = (3, 0, 3, 0)
#           Output: (3, 0), (3, 0, 3)
#   Subset 1: (3, 0) Values: 3 + 0 = 3 Positions: 1 + 2 = 3
#   Subset 2: (3, 0, 3) Values: 3 + 0 + 3 = 6 Positions: 1 + 2 + 3 = 6
#
# Example 3 Input: @nums = (5, 1, 1, 1)
#           Output: (5, 1, 1)
#   Subset 1: (5, 1, 1) Values: 5 + 1 + 1 = 7 Positions: 1 + 2 + 4 = 7
#
# Example 4 Input: @nums = (3, -1, 4, 2)
#           Output: (3, 2), (3, -1, 4)
#   Subset 1: (3, 2) Values: 3 + 2 = 5 Positions: 1 + 4 = 5
#   Subset 2: (3, -1, 4) Values: 3 + (-1) + 4 = 6 Positions: 1 + 2 + 3 = 6
#
# Example 5 Input: @nums = (10, 20, 30, 40)
#           Output: ()

Just the Basic Facts, Can You Show Me Where It Hurts?

Perusing the examples, I see that there are a couple of unstated requirements. From example 1, the improper subset (1,2,3,4) should work, but it's not in the given output, so apparently that should be excluded. And in example two, the subset (3) should work, but it's not in the output, so apparently subsets have to have at least two members.

I don't see any way of doing this other than generating all possible subsets and checking if they work. My approach is going to be to number the positions, and generate all possible subsets of the positions. Extracting members from the given list will be done with a hash slice. There's going to be a little annoyance that the task numbers positions starting from 1, while Perl array indexing is based from 0.

For a set of n members, there are 2ⁿ-1 possible subsets. I know that a way to generate subsets is to count from 1 to 2ⁿ-1 and check which bits are 1s in the binary representation. I know how to generate all possible subsets, but do I want to? Because I also know that there are CPAN modules that do this, and I have Algorithm::Combinatorics hanging around from previous problems, with its convenient subsets function, so let's use that.

I Do Believe It's Working, Good

sub sseq(@nums)
{
    use Algorithm::Combinatorics qw/subsets/;
    use List::Util qw/sum0/;
    my @result;

    my $s = subsets( [0 .. $#nums] );
    while ( my $position = $s->next() )
    {
        my $size = scalar(@$position);
        # Only proper subsets of size 2 or more
        next if $size == scalar(@nums) || $size < 2;

        # Subsets are indexed at zero, but positions at 1, so compensate in sum
        my $sumPosition = $size + sum0  @$position;

        my $sumNumbers = sum0 @nums[ @$position ];

        if ( $sumNumbers == $sumPosition )
        {
            push @result, [@nums[@$position]]
        }
    }
    return \@result;
}

Your Lips Move, But I Can't Hear What You're Saying

Explanatory notes:

use Algorithm::Combinatorics qw/subsets/ -- This function creates an iterator to generate consecutive subsets from a given list of members. We're going to pass it a list of positions, from 0 to the last index of @nums.
use List::Util qw/sum0/ -- sum0 handles empty lists by returning zero instead of an error, as sum does. That shouldn't come up in this particular function, but I generally use sum0 as my default, because I invariably get a warning from sum about an empty array and end up changing it anyway.
my $size = scalar(@$position) -- the size of the position array comes up repeatedly, so let's get a handle on it.
my @sumPosition = $size + sum0(...) -- The sum we're looking for is based on using positions numbered from 1, but we have them numbered from 0. We need to add 1 to each of the positions, which is the same as adding the number of positions.
my @sumNumbers = sum0 @nums[ @$position ] -- Here's why I wanted positions to be indexed from zero: so that they could be used in a hash slice to extract the corresponding numbers.
push @result, [@nums[@$position]] -- the result of this function is going to be a reference to an array of arrays (it's array reference turtles all the way down). Once again, the hash slice, now encased in [] to create an array reference.

That'll Keep You Going Through the Show

This function answers the question, but it leaves two things undone.

First, the order of the lists is unspecified. There's no apparent reason for the order in the examples, and I quickly found out that the subsets iterator doesn't return subsets in the same order as the examples.

To create unit tests, I want to check that arrays contain the same members, but order doesn't matter. In the Test2 suite, this can be accomplished by putting the expected elements into a bag data structure.

sub runTest
{
    use Test2::V0;
    use Test2::Tools::Compare qw/bag item/;
    my $check;

    $check = bag { item [1,4]; item [2,1]; item [2,3]; item [4,3]; end(); };
    is( sseq(2,1,4,3), $check, "Example 1");
[...]

Our bags are checked, so ...

Come On, It's Time To Go

Second, to display the output, we have to unwrap the array references and render them as formatted strings.

say join ", ", map { "(" . join(", ", $_->@*) . ")" } sseq(@ARGV)->@*;

What's going on here?

sseq(@ARGV)->@* -- Call our function, using the command line arguments, and dereference it (which yields an array of array references).
map { ... } -- Transform each of the array references
"(" . join(", ", $_->@*) . ")" -- $_ is a reference to an array, so $_->@* is the list of elements in the array. Make it a comma-separated string, encased in parentheses.
say join ", ", ... -- output each of those parenthesized strings, separated by commas

I Have Become Comfortably Numb

Equilibrium achieved.