Forem: Bob Lied

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.

PWC 370 Scramble On, Scramblin' Man

Bob Lied — Sun, 26 Apr 2026 13:16:46 +0000

If your girlfriend has been kidnapped by Gollum and the Evil One, and there's nothing you can do, perhaps console yourself with a small programming problem while you listen to Ramble On or Ramblin' Man'.

PWC 370 Task 2: Scramble String

The Task

You are given two strings A and B of the same length. Write a script to return true if string B is a scramble of string A otherwise return false. String B is a scramble of string A if A can be transformed into B by a single (recursive) scramble operation. A scramble operation is:

If the string consists of only one character, return the string.
Divide the string X into two non-empty parts.
Optionally, exchange the order of those parts.
Optionally, scramble each of those parts.
Concatenate the scrambled parts to return a single string.

Examples

Input: $str1 = "abc", $str2 = "acb" Output: true
- split: ["a", "bc"]
- split: ["a", ["b", "c"]]
- swap: ["a", ["c", "b"]]
- concatenate: "acb"
Input: $str1 = "abcd", $str2 = "cdba" Output: true
- split: ["ab", "cd"]
- swap: ["cd", "ab"]
- split: ["cd", ["a", "b"]]
- swap: ["cd", ["b", "a"]]
- concatenate: "cdba"
Input: $str1 = "hello", $str2 = "hiiii" Output: false
Input: $str1 = "ateer", $str2 = "eater" Output: true
Input: $str1 = "abcd", $str2 = "bdac" Output: false

The Ramblin' Scramblin' Thinkin' Part

This could go two ways: (1) generate every possible scramble of str1 and then look for str2; or (2) do a breadth-first or depth-first search for str2.

The possible number of scrambles could explode. For a length of n, there will be n-1 splits, and then the n-1 string will have n-2 splits, and so on, so we're looking at factorial complexity. Let's not generate every possible scramble unless we have to.

For a search, we'd be trying to match the front or back halves of the two strings, and then recursing on the parts that didn't match. There are finite possibilities for partial matches.

A simple swap gets us from str1 to str2:

  str1:    ---  ++++++++++
  str2:    ++++++++++  ---

The head or tail of str1 matches the corresponding head or tail of str2, requiring us to recurse on the shorter string that didn't yet match.

   str1:   ===  [??????????]    ||    [???]   ==========
            |     scramble           scramble      |
            |         |                 |          |
   str2:   ===  [.*#.*#.*#.]    ||    [.*#]   ==========

The head or tail of str1 matches the back or front of str2. Similar to the case above, except that a swap is required before we recurse.

   str1:  ===  [??????????]   ||   [???] =========
                     /               \
             scramble                 scramble
               /                              \
   str2:  [.*#.*#.*#.]  ===   ||   ========= [.*#]

A Bold Strategy, Cotton. Let's see if that works out for him.

After an embarrassing amount of trial and error (you might say I was scrambling), my solution converged on this longer-than-usual recursive function.

sub isScramble($str1, $str2, $depth = "")
{
    state %remember;
    %remember = () if $depth eq "";

    my $key = ":$str1:$str2:";
    if ( exists $remember{$key} )
    {
        $logger->debug("${depth}CACHED $key = ", ($remember{$key} ? "true":"false"));
        return $remember{$key}
    }

    my $len = length($str1);
    return ( $remember{$key} = false) if $len != length($str2);
    return ( $remember{$key} =  true) if $str1 eq $str2;

    for ( 1 .. $len-1 )
    {
        # $_ is the length of the left substring (head), $len-$_ is length of right (tail)
        my (  $head,   $tail) = ( substr($str1, 0, $_), substr($str1, $_) );
        my ($s2head, $s2tail) = ( substr($str2, 0, $_), substr($str2, $_) );

        my $s2front = substr($str2, 0, $len-$_);   # length of $tail, on left side
        my $s2back  = substr($str2, -$_);          # length of $head, on right side

        $logger->debug("${depth}Compare [$head/$tail] <> s2head/$s2tail] ($s2front/$s2back)");

        if ( "$tail$head" eq $str2 )
        {
            $logger->debug("${depth}FOUND $str2");
            return $remember{$key} = true;
        }
        elsif ( $head eq $s2head )
        {
            $logger->debug("${depth}HH, compare $tail <> $s2tail");
            return true if $remember{$key} = isScramble($tail, $s2tail, "  $depth");
        }
        elsif ( $head eq $s2back )
        {
            $logger->debug("${depth}HB, compare $tail <> s2front");
            return true if $remember{$key} = isScramble($tail, $s2front, "  $depth");
        }
        elsif ( $tail eq $s2tail )
        {
            $logger->debug("${depth}TT, compare $head <> s2head");
            return true if $remember{$key} = isScramble($head, $s2head, "  $depth");
        }
        elsif ( $tail eq $s2front )
        {
            $logger->debug("${depth}TF, compare $head <> s2back");
            return true if $remember{$key} = isScramble($head, $s2back, "  $depth");
        }
        else
        {
            $logger->debug("${depth}No pairs, recurse with $head<>$s2head and $tail<>$s2tail");
            return $remember{$key} = true if ( 
                   ( isScramble($head, $s2head, "  $depth")
                  && isScramble($tail, $s2tail, "  $depth") )
                || ( isScramble($head, $s2back, "  $depth")
                  && isScramble($tail, $s2front, "  $depth") ) );
        }
    }

    $logger->debug("${depth}NOT FOUND $key = false (caching)");
    return $remember{$key} = false;
}

Notes:

The function starts out with setting up a cache for partial results. During development, I added this near the end of the process, but it shows up at the top of the function, so let's discuss it.
- Recursive search algorithms usually benefit from caching known results. Our worst case is that str1 can't be scrambled into str2, in which case we'll end up doing the whole exponential tree of possibilities. I expect caching partial results would pay off.
- The %remember hash is my cache, and it's a state variable so that it persists across recursive calls. But that means it also persists across invocations for different test cases, so it could yield wrong answers unless I initialize it at the top level of the recursion.
- The cache is filled by using in-line assignment every time a result is returned, which is kind of cutely readable, I think.
- Should I have used Memoize? Maybe. But that caches values based on the arguments passed to the function, and one of my arguments is the depth to which I've recursed. That means cache misses depending on how I got down the search tree, so I opted for do-it-yourself memo-ization.
The function begins by dispensing with the easy cases: having a result in the cache, matching strings, and strings of the wrong length.
Then, for each division of str1, let's have at hand the substrings that we might be dealing with from both str1 and str2. There's a little tour-de-force of substr uses here, splitting the strings at a midpoint, and using negative offsets.
Most of the body of the function is testing which pairs match up, if any, and doing the appropriate recursion of what remains.
The last case, where neither the head nor the tail of str1 has a matching complement in str2, requires us to recurse on both pieces, and in either order.
I used logging liberally, because the function is only obvious in hindsight and took me longer than I'd like to admit. The $depth argument is mostly a convenience for indenting the log statements appropriately -- notice that it gets longer by two spaces at each recursion. My setup for logging uses Log::Log4perl in easy mode. It's part of my boilerplate for PWC solutions and looks like this:

use Getopt::Long;
my $Verbose = false;
my $DoTest  = false;

GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
my $logger;
{
    use Log::Log4perl qw(:easy);
    Log::Log4perl->easy_init({ level => ($Verbose ? $DEBUG : $INFO ),
            layout => "%d{HH:mm:ss.SSS} %p{1} %m%n" });
    $logger = Log::Log4perl->get_logger();
}

PWC 367 Overlapping Oddities

Bob Lied — Sun, 05 Apr 2026 14:15:46 +0000

Task 1, Maximum Odd Binary

It's the week of the Artemis 2 mission to the moon, and we have a problem about odd numbers. I'd call that a Space Oddity.

Task Description

You are given a binary string that has at least one ‘1’.

Write a script to rearrange the bits in such a way that the resulting binary number is the maximum odd binary number and return the resulting binary string. The resulting string can have leading zeros.

Example 1: Input: $str = "1011", Output: "1101"
Example 2: Input: $str = "100", Output: "001"
Example 3: Input: $str = "111000", Output: "110001"
Example 4: Input: $str = "0101",Output: "1001"
Example 5: Input: $str = "1111", Output: "1111"

Task Cogitation

To be as large as possible, a binary number must have all its 1s in the most-significant bits. To be odd, the least significant bit must be a one. So, what has to happen is that all the 1s shift to the left, one shifts to the right, and all the zeroes form a space between them.

I see three possible solutions:

Sort: sort the bits so that the 1s are on the left, the 0s on the right, and then rotate a 1 into the right-most position.
Split: make a pass over the bits, creating a pile of 1s and a pile of 0s. Form the required output string from the piles.
Count: There's no need to move the bits around. Count how many 1s there are. Conjure a string of 1s, and a string of 0s.

Task Implementation

Solution 1: Sorting

sub mobSort($str)
{
    my @bits = sort { $b cmp $a } split(//, $str);
    push @bits, shift @bits;
    return join("", @bits);
}

Notes:

Sort in descending order to put 1s on the left
Rotate by taking the bit on the left and pushing it onto the right.

Solution 2: Splitting

sub mobSplit($str)
{
    my @bit = ( "", "" );
    $bit[$_] .= $_ for split //, $str;

    substr($bit[1], -1, 0, $bit[0]);
    return $bit[1];
}

Notes:

I want a group of 0s and a group of 1s. That's an array of size two, conveniently indexed by [0] and [1].
For each 0 or 1, append to its string.
To form the output, use the four-argument form of substr, which replaces a substring. In the string of 1s, insert the string of 0s just before the zero-length string in front of the last bit.

Solution 3: Counting

sub mobCount($str)
{
    my $n = length($str);
    my $zero = ($str =~ tr/0/0/);

    return ("1" x ($n-$zero-1)) . ("0" x $zero) . ("1");
}

Notes:

The output will be the same length as the input.
The number of zeroes can be counted by the Perl FAQ idiom of using the tr/// operator -- it returns the number of substitutions.
Now we know how any 1s and 0s we need, so replicate them appropriately.

Task Benchmark

It's too trivial a problem to be concerned about performance, but let's benchmark it anyway.

               Rate   sorting splitting  counting
sorting    128205/s        --      -28%      -95%
splitting  178571/s       39%        --      -93%
counting  2500000/s     1850%     1300%        --

I'm not surprised that sorting is slowest (it's an O(n_log_n) algorithm). I am a little surprised how much faster counting is.

Task 2, Conflict Events

Task Description

You are given two events' start and end time.

Write a script to find out if there is a conflict between the two events. A conflict happens when two events have some non-empty intersection.

Example 1:
- Input: @event1 = ("10:00", "12:00") @event2 = ("11:00", "13:00")
- Output: true
- Both events overlap from "11:00" to "12:00".
Example 2:
- Input: @event1 = ("09:00", "10:30") @event2 = ("10:30", "12:00")
- Output: false
- Event1 ends exactly at 10:30 when Event2 starts. Since the problem defines intersection as non-empty, exact boundaries touching is not a conflict.
Example 3:
- Input: @event1 = ("14:00", "15:30") @event2 = ("14:30", "16:00")
- Output: true
- Both events overlap from 14:30 to 15:30.
Example 4:
- Input: @event1 = ("08:00", "09:00") @event2 = ("09:01", "10:00")
- Output: false
- There is a 1-minute gap from "09:00" to "09:01".
Example 5:
- Input: @event1 = ("23:30", "00:30") @event2 = ("00:00", "01:00")
- Output: true
- They overlap from "00:00" to "00:30".

Task Cogitation

The string form of time is annoying to work with. The first thing to do is to convert the time to a minute of the day. As we learned last week, there are 1440 minutes in a day. And as we learned long ago, there are 525,600 minutes in a year, but that's not relevant. Stay focused.

Once we have the times converted, then we have a problem in detecting overlapping ranges. I know how to do that. The examples highlight the edge cases.

Example 5 throws a curve: the ranges can cross midnight. There will be math involving modulo operators.

I'm going to break this down into small pieces.

Task Solution

What I'm going for is: does the range of event 1 overlap with the range of event 2? That means I need a function to see if ranges overlap, which means I need a function to convert times to ranges, which means I need functions to convert time strings to numbers. Let's pop that stack.

Subtask: Time conversion

Very straightforward. I'm assuming times have been validated and are in the specified format.

sub toMinute($hhmm)
{
    my ($h, $m) = split(":", $hhmm);
    my $minute = $m + 60 * $h;
    return $minute;
}

Subtask: Event range

Here's where we isolate the problem of spanning midnight. We figure out how long the event is, using a 24-hour clock modulo operation. Then, replace the beginning of the range by subtracting the duration from the end. That means we might get a negative number for the beginning, but that's okay -- it represents a time before midnight.

sub toRange($minBeg, $minEnd)
{
    my $duration = ($minEnd - $minBeg) % 1440;
    return [ $minEnd - $duration, $minEnd ];
}

Subtask: Range overlap

Given two ranges, whether they overlap depends on where their edges line up.

I like use enum as a way to introduce a little readability. It's a very efficent module, and quite flexible.

sub isOverlap($range1, $range2)
{
    use enum qw( BEG=0 END=1 );
    return $range1->[END] > $range2->[BEG]
        && $range1->[BEG] < $range2->[END];
}

Composition of the solution

sub isConflict($event1, $event2)
{
    return isOverlap(toRange( map { toMinute($_) } $event1->@* ),
                     toRange( map { toMinute($_) } $event2->@* ) );
}

Given all the pieces, the solution falls into place.

map { toMinute() " -- convert the time strings into pairs of numbers that we can do arithmetic with.
toRange( map {} ) - convert pairs of points in time into ranges that might span midnight.
isOverlap(...) - the answer is the result of checking for range overlap.

PWC 366, Task 2, Valid Times

Bob Lied — Fri, 27 Mar 2026 14:31:07 +0000

PWC 366 Task 2, Valid Times

Here we are at another Weekly Challenge, ticking away the moments that make up a dull day. Fritter and waste the hours in an off-hand way. Kicking around on a piece of ground in your home town, waiting for someone or something to show you the way. Here's a way.

The Requirements Phase

You are given a time in the form ‘HH:MM’. The earliest possible time is ‘00:00’ and the latest possible time is ‘23:59’. In the string time, the digits represented by the ‘?’ symbol are unknown, and must be replaced with a digit from 0 to 9. Write a script to return the count of different ways we can make it a valid time.

Example 1: Input: $time = "?2:34", Output: 3
- 02:34, 12:34, 22:34
Example 2: Input: $time = "?4:?0", Output: 12
- Combinations of hours 04 and 14, with minutes 00, 10, 20, 30, 40, 50
Example 3: Input: $time = "??:??", Output: 1440
Example 4: Input: $time = "?3:45", Output: 3
- 03:45, 13:45, 23:45
Example 5: Input: $time = "2?:15", Output: 4
- 20:15, 21:15, 22:15, 23:15

The Design Phase

My first thought is that it would be fun to make some kind of iterator or generator that replaces each ? with its valid possibilities. My second thought is, "Nah, that seems like a lot of work." And since the cardinal virtue of Perl programming is laziness, I moved on to something simpler.

There are 24 valid hours and 60 valid minutes. The total valid combinations is the cross-product of the two. Let's go with that.

The Implementation Phase

sub validTime($time)
{
    state @hour   = '00' .. '23';
    state @minute = '00' .. '59';

    my ($h, $m) = map { s/\?/./gr } split(/:/, $time);

    return (grep /$h/, @hour) * (grep /$m/, @minute);
}

Notes:

state variables -- These reference lists only need to be set up once, and only in the scope of this function. That's what state does.
'00' .. '23' -- The .. sequence operator has the nice feature that if you want leading zeroes, you get them. Looking at you, bash.
split(/:/, $time) -- Divide the input into its components. As in so many weekly challenge tasks, I'm assuming that the input has already been sanitized and is showing up here in a valid form.
map { ... } -- Do something to both the hours and the minutes.
s/\?/./gr -- The something is to replace ? with . so that it becomes a regular expression. The ? is a meta-character, so it needs to be quoted. Adding the r flag yields the modified string; otherwise s///g would yield the number of substitutions, which is not useful in this context.
my ($h, $m) = ... -- Declaring and initializing two variables from a list of two things.
(grep /$h/, @hour) -- Select a list of the valid hours that can match the $h pattern. This is in a scalar context (numerical multiplication), so the scalar value will result -- the number of matches. Similarly for minutes.
We only need the count, so multiply the two. We could have generated the list of valid times by using the hours and minutes returned from grep in array context, but (I believe I already mentioned this), lazy.

The Delivery Phase

And there you have it. You run and you run to catch up with the sun, but it's sinking, and racing around to come up behind you again. The sun is the same in a relative way, but you're older, shorter of breath, and one day closer to death. But at least you solved weekly challenge 366.

PWC 366 Count Prefixes: Could We Start Again, Please

Bob Lied — Fri, 27 Mar 2026 13:37:30 +0000

PCW 366, Task 1, Count Prefix

So many prefixes, starting from the beginning over and over. It reminds me of "Could We Start Again, Please?" from Jesus Christ, Superstar.

The Task

You are given an array of words and a string (contains only lowercase English letters). Write a script to return the number of words in the given array that are a prefix of the given string.

Example 1:
- Input: @array = ("a", "ap", "app", "apple", "banana"), $str = "apple"
- Output: 4
Example 2:
- Input: @array = ("cat", "dog", "fish"), $str = "bird"
- Output: 0
Example 3:
- Input: @array = ("hello", "he", "hell", "heaven", "he"), $str = "hello"
- Output: 4
Example 4:
- Input: @array = ("", "code", "coding", "cod"), $str = "coding"
- Output: 3
Example 5:
- Input: @array = ("p", "pr", "pro", "prog", "progr", "progra", "program"), $str = "program"
- Output: 7

An Obvious Solution Using a Regular Expression

The first thing that springs to mind is to do a pattern match of each string in @array against the string.

sub countPrefix($str, $array)
{
    scalar grep { $str =~ m/^$_/ } $array->@*;
}

Notes:

Because of the way Perl passes array arguments, I've chosen to invert the order and pass the scalar string first. Then, I further chose to pass an array reference instead of a copy of the array, for premature optimization.
grep returns different things depending on whether it's in scalar context or array context. I want the scalar value always (the count of the number of matches).

A Less-obvious Solution Using a Regular Expression

Another way to approach the problem is to look at it from the point of view of the string. What are all the possible prefixes? Then see if any of the @array values is in that set of alternatives. The programming task in this solution is to build a regular expression that matches every possible prefix.

sub onerex($str, $array)
{
    my $regex =  join('|', map { substr($str, 0, $_) } 0 .. length($str));

    return scalar grep /^(?:$regex)$/, $array->@*;
}

Notes:

0 .. length(str) -- generates the sequence of possible prefix lengths, including the empty string (one of the given examples implies that an empty string should be considered a valid prefix).
map { substr($str, 0, $_) } -- For each length, extract the prefix of that length, giving an array of increasingly longer strings.
join('|', ...) -- Combine the strings into a set of alternatives that can be used in a regular expression.
$array->@* -- Post-fix notation for de-referencing the array. I like it; Perl classic would probably use @$array.
/^(...)$/ -- The potential prefixes must be anchored at the start and end to exactly match one of the alternatives in $regex.
/^(?:...)/ -- We need the parentheses for grouping, but we don't need to extract the pattern match. The ?: assertion does that; it saves the overhead of extracting the match and then ignoring it.

A Solution Using String Compare

All of the strings involved in this task are constants; there's no meta-characters or repetitions that require a regular expression. It could be done with string compares, and that would probably be more efficient. Let's find out.

sub precmp($str, $array)
{
    scalar grep { substr($str, 0, length($_)) eq $_ } $array->@*;
}

Notes:

Implicitly loop over @array. For each possible prefix, extract the same length of string from the front of $str and see if they match exactly.

Benchmark

Let's see how the solutions compare. I'll make up a string of modest length, and an array with a lot of words. For the purpose of the benchmark, I don't really care how many prefixes are found.

sub runBenchmark($repeat)
{
    use Benchmark qw/cmpthese/;

    my $str = "abcdefghijklmnopqrstuvwxy";
  my $array = [ qw(lorem ipsum dolor sit amet consectetur adipiscing elit e tiam elit neque venenatis ut dolor consectetur iaculis venenatis arcu in in terdum mauris eget neque venenatis dapibus sed finibus varius sapien quis mal esuada fusce libero augue vulputate sit amet faucibus at feugiat at l ectus maecenas vehicula sem metus nullam lobortis massa et est vulputate f acilisis in tempus arcu metus vitae aliquam nibh sodales ac sed vitae era t nec nisl laoreet fringilla aliquam et lobortis purus ut a tristique nisi nec molest ie arcu duis mattis ultrices nisl eget consectetur donec ac lo rem non augue bibendum tincidunt interdum quis velit in gravida metus vitae) ];


    cmpthese($repeat, {
            regex  => sub { countPrefix($str, $array) },
            substr => sub { precmp($str, $array) },
            onerex => sub { onerex($str, $array) },
        });
}

And now for the unveil:

           Rate  regex onerex substr
regex    8636/s     --   -73%   -95%
onerex  31447/s   264%     --   -83%
substr 185185/s  2044%   489%     --

The solution with simple string compares wins by blowout. This is not surprising to me. The overhead of setting up regular expressions and doing their evaluation is mostly unnecessary for this task, and the string compares are highly optimized operations in Perl.

PWC 362 Echo Chamber

Bob Lied — Thu, 26 Feb 2026 15:34:51 +0000

The musical accompaniment must obviously be Pink Floyd's Echoes.

The Task

You are given a string containing lowercase letters.

Write a script to transform the string based on the index position of each character (starting from 0). For each character at position i, repeat it i + 1 times.

Example 1
- Input: "abca"
- Output: "abbcccaaaa"
Index 0: "a" -> repeated 1 time -> "a"
Index 1: "b" -> repeated 2 times -> "bb"
Index 2: "c" -> repeated 3 times -> "ccc"
Index 3: "a" -> repeated 4 times -> "aaaa"

The Thoughts, Both Profound and Superficial

A string transformation problem, an ideal domain for Perl. There are at least three approaches I can see.

Treat it as a regular expression problem, substituting each character for n copies of itself. It wouldn't be Perl if at least one of the more-than-one-way-do-its didn't have more punctuation than letters.
Treat it as a list problem. Separate the string into a list of characters and map each list element into n copies of itself.
Treat it as a string generation problem. Build a new string out of bits of the original.

In any case, the linchpin is going to be the repetition operator, x.

The Solutions

A Regular Expression Substition

sub echoRE($str)
{
    use English;
    return $str =~ s/(.)/$1 x $LAST_MATCH_END[1]/ger;
}

Several features of Perl regular expressions come into play.

We need to do some math in the substitution to replicate the characters. To put executable code into the substitution, we use the /e flag.
We need the index of the character we're replacing. Perl regular expressions have many useful side effects that are available in special variables. When using a capture group, the indexes of the beginning and end of the matching text are available in the @- and @+ special array variables.
The default result of a s///g global substitution is the number of replacements made, which can be useful in some contexts, but not this one. The /r flag changes the behavior so that it results in the modified string instead.
I'm conceding a tiny bit to readability. use English lets me use $LAST_MATCH_END in place of $+.

Here's the breakdown of willing the regular expression into existence:

s///gr -- It's going to be a global substituion (every character), and we want the result.
s/(.)//gr -- Capture every character, no matter what it is.
s/(.)/$1 x .../gre -- Replicate the captured character the appropriate number of times. Add the e flag to execute this expression.
s/(.)/$1 x $+[1]/gre -- After a visit to the Perl references (just to spite AI, I used an actual book of genuine paper), we find that the offset of the captured character is in the @- and @+ special variables. Using @+ (end of the match) instead of @- takes care of the index+1 annoyance.
As evidenced by the step above, I can't remember the special variables, so I add use English to get the name LAST_MATCH_END.

A List Solution

sub echoMap($str)
{
    return join "", map { substr($str, $_-1, 1) x $_} 1 .. length($str)
}

This solution turns each character into a longer string of repeated characters. It maps indexes into a corresponding string of the correct length.

A String-building solution

sub echoStr($str)
{
    my $result = "";
    for my ($i, $c) ( indexed split(//, $str) )
    {
        $result .= ($c x ($i+1));
    }
    return $result;
}

A variation on the list processing, this one builds a string with repeated concatenation. Instead of building a list with map and then join-ing it into a result, this one goes straight to the string.

split gives me the individual characters as a list. It's more efficient than repeated calls to substr.

Since we need both the character and its index, I relied on my favorite variation of the for loop using indexed to conveniently give me variable names.

The Comparison

As always, I'm curious about the relative efficiency of the solutions. Here's a benchmark result:

           Rate    regex  mapjoin splitstr
regex    2365/s       --     -43%     -57%
mapjoin  4118/s      74%       --     -25%
splitstr 5469/s     131%      33%       --

I'm a little surprised that regular expressions didn't fare better. I hypothesize that the addition of executable code in the substitution is a significant cost.

I'm not surprised that string building won. Iterating over lists and manipulating strings are a core strength of Perl, and those operations have no doubt been optimized to heck over the decades.

PWC 360 Pertaining to a subtlety of sorting

Bob Lied — Wed, 11 Feb 2026 17:05:44 +0000

It's been a while since I commented on a Weekly Challenge solution, but here we are at week 360. Such a useful number. So divisible, so circular. It deserves twenty minutes.

Task 2: Word Sorter

The task

You are given a sentence. Write a script to order words in the given
sentence alphabetically but keep the words themselves unchanged.

# Example 1 Input: $str = "The quick brown fox"
#           Output: "brown fox quick The"
# Example 2 Input: $str = "Hello    World!   How   are you?"
#           Output: "are Hello How World! you?"
# Example 3 Input: $str = "Hello"
#           Output: "Hello"
# Example 4 Input: $str = "Hello, World! How are you?"
#           Output: "are Hello, How World! you?"
# Example 5 Input: $str = "I have 2 apples and 3 bananas!"
#           Output: "2 3 and apples bananas! have I"

The thoughts

This should be quite simple: split the words, sort them, put them back together. The sort should be case-insensitive.

join " ", sort { lc($a) cmp lc($b) } split(" ", $str);

Creeping doubt #1

Is converting to lowercase with lc the right way to do case-insenstive compares? Not really. Perl has the fc -- fold-case -- function to take care of subtleties in Unicode. We won't see those in simple ASCII text, but for the full rabbit hole, start with the documentation of fc.

Creeping doubt #2

Doing the case conversion inside the sort means that we will invoke that every time there's a string comparison, which will be quite redundant. We could (probably?) speed it up by pre-calculating the conversions once.

The solution

sub sorter($str)
{
    return join " ",
        map { $_->[0] }
        sort { $a->[1] cmp $b->[1] }
        map { [$_, fc($_)] }
        split(" ", $str);
}

This solution uses the idiom of Schwartzian transformation. Every word gets turned into a pair of [original_word, case_folded_word]. That array of pairs gets sorted, and then we select the original words out of the sorted pairs. This is best read bottom-up.

split(" ", $str) -- turns the string into an array of words, where words are loosely defined by being white-space separated.
map { [$_, fc($_)] } -- every word turns into a pair: the original, and its case-folded variation. The result is a list of array references.
sort { $a->[1] cmp $b->[1] } -- sort by the case-folded versions. The result is still a list of array references.
map { $_->[0] } -- select the original word from each pair
join " " -- Return a single string, where the words are separated by one space.

Does it blend?

A quick benchmark shows that it is indeed faster to pre-calculate the case folding. This example used a text string of about 60 words.

           Rate oneline  pre_lc
oneline 32258/s      --    -45%
pre_lc  58140/s     80%      --

My intuition says that when the strings are much shorter, the overhead of the transform might not offset the gains in the sort, but as is so often true, my intuition is crap. This is the result for a string of five words:

oneline  470588/s      --    -59%
pre_lc  1142857/s    143%      --

PWC 353 To each (array) his own

Bob Lied — Mon, 22 Dec 2025 15:12:56 +0000

This week's challenges were early and on the easy side, which was appreciated as the holidays loom. The musical interlude this week ignores the challenge tasks in favor of seasonal light jazz; I have Spotify playing "Winter's Songs: A Windham Hill Christmas."

Task 1: Max Words

The Task

You are given an array of sentences. Write a script to return the maximum number of words that appear in a single sentence.

Example 1:
- Input: @sentences = ("Hello world", "This is a test", "Perl is great")
- Output: 4

The Solution

An easy one -- an early Xmas gift? Split each sentence into words and count them, then take the maximum. Completely ignoring all the complexities of punctuation and internationalization, it's a one-liner:

sub maxWords(@sentence)
{
    use List::Util qw/max/;
    return max map { scalar(split(" ", $_)) } @sentence;
}

The only thing mildly tricky here is transforming the list of words into a count. Inside the body of the map block, we're in array context, so split will return a list. Coercing it with scalar gives the count.

Task 2: Validate Coupon

The Task

You are given three arrays, @codes, @names and @status. Write a script to validate codes in the given array. A code is valid when the following conditions are true:

codes[i] is non-empty and consists only of alphanumeric characters (a-z, A-Z, 0-9) and underscores (_).
names[i] is one of the following four categories: "electronics", "grocery", "pharmacy", "restaurant".
status[i] is true.

Return an array of booleans indicating validity: output[i] is true if and only if codes[i], names[i] and status[i] are all valid.

Example 1:
- Input:
  - @codes = ("A123", "B_456", "C789", "D@1", "E123")
  - @names = ("electronics", "restaurant", "electronics", "pharmacy", "grocery")
  - @status = ("true", "false", "true", "true", "true")
- Output: (true, false, true, false, true)

Thoughts

The volume of text for this one was daunting at first glance, but it turns out to be mostly example data and actually quite easy.

The validation is straight-forward. @codes is a regular expression match; @names is a keyword lookup from a dictionary table (hash); and @status is just a string compare.

We'll be operating on parallel arrays. I see two ways of doing it. First, we could use a variable to loop over the indexes. That's going to yield code with a lot of array subscripts. Or second, we could use each_array from List::More::Utils to do the indexing for us. I'm curious which is more efficient.

To the code-sleigh, Rudolph!

Loop with `indexed`

sub valid($code, $name, $status)
{
    state %ValidName = ( electronics => true, grocery => true,
                         pharmacy => true, restaurant => true );
    my @valid = (true) x $code->@*;

    for my ($i, $c) ( indexed $code->@* )
    {
        $valid[$i] &&= ( $code->[$i] !~ m/[^a-zA-Z0-9_]/ );
        $valid[$i] &&= ( exists $ValidName{$name->[$i]} );
        $valid[$i] &&= $status->[$i] eq "true";
    }
    return \@valid;
}

Notes:

Passing multiple arrays as subroutine parameters implies using references. We could use traditional prototype attributes to make it possible to pass arrays, but let's not.
state %ValidName -- These are valid keywords for the @names input array. Using state makes this a static table, initialized only the first time the subroutine is entered.
@valid -- Our output array, same size as the input array. Assume they're all valid and turn elements false if any check fails.
indexed -- My favorite recent Perl improvement. Returns both the index and the value from an array during a for loop.
valid->[$i] &&= ... -- Any failing test will turn the value to false.
$code->[$i] !~ m/[^a-zA-Z0-9_]/ -- The code has to consist entirely of valid characters, or conversely, it must not match (!~) anything that contains a character other than those. Later I went back to look up exactly what \w and \W mean in Perl regular expressions and realized that I could have used that instead of the character classes.
exists $ValidName{...} -- Use exists explicitly to return a boolean value. A simple lookup that fails would return undef, and will make the result of the expression undef instead of false. Although undef is treated as false in many contexts, it failed the unit test.
return \@valid -- Return a reference. This is convenient for the is() function from the Test2::V0 unit testing framework, and returning a reference also improves performance by avoiding an array copy.

Loop with array iterator

sub validEach($code, $name, $status)
{
    state %ValidName = ( electronics => true, grocery => true,
                         pharmacy => true, restaurant => true );
    my @valid;

    use List::MoreUtils qw/each_arrayref/;
    my $ea = each_arrayref($code, $name, $status);
    while ( my ($c, $n, $s) = $ea->() )
    {
        push @valid, ( $c !~ m/[^a-zA-Z0-9_]/ )
                  && ( exists $ValidName{$n}    )
                  && ( $s eq "true"             );
    }
    return \@valid;
}

Notes:

This is basically the same function, except that the explicit indexing has been replaced by an iterator.
each_arrayref -- There's an each_array function, but since we have array references, this one is convenient.
my $ea = ... -- Creates an iterator over the three arrays.
ea->() -- Call the iterator. ea is the equivalent of a function pointer, and this is function dereference syntax.
while ( my ($c, $n, $s) = ea->() ) -- Each call to the iterator returns a tuple of the next element from each of the $code, $name, and $status arrays.
push @valid, ... -- The same three checks as before, but building the list instead of modifying it, because we don't have an index in hand.

Performance check

I think the iterator version is a little cleaner, because it eliminates the clutter of repeated array subscripts. But I was curious how it compared in efficiency, so I set up a quick benchmark using the examples.

It turns out that the explicit indexing is about twice as efficient as the each_arrayref iterator. Still gonna use it, though.

$ perl ch-2.pl -b 100000
             Rate iterator forindex
iterator  72464/s       --     -47%
forindex 136986/s      89%       --

To do the benchmarking, I set up the examples as an array of test cases, and used Benchmark::cmpthese to do a lot of iterations.

sub runBenchmark($repeat)
{
    use Benchmark qw/cmpthese/;

    cmpthese($repeat, {
            forindex => sub {
                for ( @case )
                {
                    valid($_->{codes}, $_->{names}, $_->{status});
                }
            },
            iterator => sub {
                for ( @case )
                {
                    validEach($_->{codes}, $_->{names}, $_->{status});
                }
            },
        });
}

And the input data looks like this:

my @case = (
    { id     => 'Example 1',
      codes  => [ 'A123',        'B_456',      'C789',        'D@1',      'E123' ],
      names  => [ 'electronics', 'restaurant', 'electronics', 'pharmacy', 'grocery' ],
      status => [ 'true',        'false',      'true',        'true',     'true' ],
      expect => [ true, false, true, false, true ],
    },
    { id     => 'Example 2',
      codes  => [ 'Z_9',      'AB_12',       'G01',     'X99',         'test' ],
      names  => [ 'pharmacy', 'electronics', 'grocery', 'electronics', 'unknown' ],
      status => [ 'true',     'true',        'false',   'true',        'true' ],
      expect => [ true, true, false, true, false ],
    },
    { id     => 'Example 3',
      codes  => [ '_123',       '123',         '',            'Coupon_A', 'Alpha' ],
      names  => [ 'restaurant', 'electronics', 'electronics', 'pharmacy', 'grocery' ],
      status => [ 'true',       'true',        'false',       'true',     'true' ],
      expect => [ true, true, false, true, true ],
    },
    { id     => 'Example 4',
      codes  => [ 'ITEM_1',      'ITEM_2',      'ITEM_3',  'ITEM_4' ],
      names  => [ 'electronics', 'electronics', 'grocery', 'grocery' ],
      status => [ 'true',        'true',        'true',    'true' ],
      expect => [ true, true, true, true ],
    },
    { id     => 'Example 5',
      codes  => [ 'CAFE_X',     'ELEC_100',    'FOOD_1',  'DRUG_A',   'ELEC_99' ],
      names  => [ 'restaurant', 'electronics', 'grocery', 'pharmacy', 'electronics' ],
      status => [ 'true',       'true',        'true',    'true',     'false' ],
      expect => [ true, true, true, true, false ],
    },
);

PWC 352 Five is the one-liest number

Bob Lied — Fri, 19 Dec 2025 22:27:21 +0000

Task 1: Match String

The Task

You are given an array of strings. Write a script to return all strings that are a substring of another word in the given array in the order they occur.

Example 1:
- Input: @words = ("cat", "cats", "dog", "dogcat", "dogcat", "rat", "ratcatdogcat")
- Output: ("cat", "dog", "dogcat", "rat")

The Deep Thoughts

Example 1 implies a couple of constraints. A complete match counts as a substring. Words may be repeated in the input. Repeated words are not duplicated in the output. The output order must match the input order. Noted.

For each word, we'll need to take it out of the list, check for substrings, and then put it back for the next round. A relatively simple way of doing that would be to shift it off the front of the list, do what needs to be done, and then return it by pushing it onto the back.

I don't see much of a way of getting around the idea that every word must be compared to every other word, so we're looking at an O(n²) performance algorithm.

One possibility for reducing the operation count might be to compare a pair of words both ways. If I have $w1 and $w2 in hand, I can check both directions for substring-i-ness. That way, instead of having to loop over the entire NxN matrix, we would only have to loop over the upper or lower triangle of the matrix. It's fewer looping operations, but still the same number of string comparisons. But it would mean more complexity in keeping track of what's been checked, so, meh.

The Code

sub matchString(@words)
{
    use List::Util qw/any/;
    my %seen;
    my @match;
    for ( 1 .. @words )
    {
        my $w = shift @words;
        push @match, $w if ( ! $seen{$w}++ && any { index($_, $w) >= 0  } @words );
        push @words, $w;
    }
    return \@match;
}

Notes:

Use a hash (%seen) to eliminate duplicates, and coincidentally optimize a little by not searching multiple times.
The main loop is once per word, so simply count. Normally, I would prefer something obviously tied to the array (like for (@words)), but since I'm changing the array within the loop, I don't want to have to think too hard about whether the iterator remains valid after removing and adding an element.
index is a cheaper operation than a regular expression match. Benchmarking bears this out -- it's about three times more efficient in my environment and test data.
List::Util::any stops as soon as something works, so it's cheaper than grep, which would evaluate the entire list every time.

Task 2: Binary Prefix

The Task

You are given an array, @nums, where each element is either 0 or 1.

Define xi as the number formed by taking the first i+1 bits of @nums (from $nums[0] to $nums[i]) and interpreting them as a binary number, with $nums[0] being the most significant bit.

For example: If @nums = (1, 0, 1), then:
x0 = 1 (binary 1)
x1 = 2 (binary 10)
x2 = 5 (binary 101)

For each i, check whether xi is divisible by 5.

Write a script to return an array @answer where $answer[i] is true if xi is divisible by 5, otherwise false.

Example 1:
- Input: @nums = (0,1,1,0,0,1,0,1,1,1)
- Output: (true, false, false, false, false, true, true, false, false, false)

Binary numbers formed (decimal values):

         0:   0  (false)
        01:   1  (false)
       011:   3  (false)
      0110:   6  (false)
     01100:  12  (false)
    011001:  25  ( true)
   0110010:  50  ( true)
  01100101: 101  (false)
 011001011: 203  (false)
0110010111: 407  (false)

The Deep Thoughts

Weird flex, but OK.

This puts me in mind of bit-twiddling with C code, but bit-twiddling in Perl is equally possible. The other alternative is probably to build strings and do binary number conversions by prefixing with '0b'.

I kind of want to do a list-based solution, using map to convert each 0 or 1 to a true or false, but I think that would be obfuscating a pretty simple loop.

The Code

sub bpre(@nums)
{
    my @isFive;
    my $b = 0;

    while ( defined(my $bit = shift @nums) )
    {
        $b = ($b << 1) | $bit;
        push @isFive, ( $b % 5 == 0 );
    }
    return \@isFive;
}

Notes:

Destroy the input by shifting a 1 or 0 off the left until the list is gone.
Do bit operations to form a new number.
Build an answer array consisting of boolean values.

Musical Interlude

The solution to task 1 reminds me of Katy Perry's Hot N Cold -- "You're yes, then you're no. You're in, then you're out."

And for Task 2, Mambo Number 5 is oddly appropriate. "Take one step left and one step right, One to the front and one to the side. Clap your hands once and clap your hands twice, And if it looks like this, then you're doin' it right."

PWC 350 Good Substring / Shuffle Pairs

Bob Lied — Wed, 03 Dec 2025 02:48:23 +0000

Musical Interlude

The movie version of Wicked is in theaters right now, so I am reminded of the song For Good -- but I'm gonna link to the Broadway version, because I'm classy like that. It's relevant to programming in Perl because "I don't know if I've been changed for the better, but I have been changed for good." For part two, Lido Shuffle by Boz Scaggs.

Task 1: Good Substrings

The Task

You are given a string. Write a script to return the number of good substrings of length three in the given string. A string is good if there are no repeated characters.

Example 1: Input $str = "abcaefg", Output: 5
- Good substrings of length 3: abc, bca, cae, aef and efg
Example 2: Input: $str = "xyzzabc", Output: 3
Example 3: Input: $str = "aababc", Output: 1
Example 4: Input: $str = "qwerty", Output: 4
Example 5: Input: $str = "zzzaaa", Output: 0

The Think-y Part

There's probably a regular expression for this, but I'm not going to find it. Do the simplest thing that works: take three characters at a time and see if they're different.

The Code-y Part

sub goodSubstring($str)
{
    my $good = 0;
    my @s = split(//, $str);
    for ( 0 .. $#s - 2 )
    {
        my ($first, $second, $third) = @s[$_, $_+1, $_+2];
        $good++ if ( $first ne $second && $first ne $third && $second ne $third );
    }
    return $good;
}

Notes:

Start by turning the string into a list of characters. It could be done with substr, but that would be untidy.
@s[$_, $_+1, $_+2] -- With a nod to readability, I'll extract three consecutive characters with an array slice. It occurs to me that I'll always have two of the next three characters in hand at the bottom of the loop, so doing a complete splice every time could probably be optimized, but I declare it "good" enough.
Since there's exactly three characters in play, check for uniqueness in the most obvious way.

Task 2:Shuffle Pairs

The Task

If two integers A <= B have the same digits but in different orders, we say that they belong to the same shuffle pair if and only if there is an integer k such that A = B * k. k is called the witness of the pair. For example, 1359 and 9513 belong to the same shuffle pair, because 1359 * 7 = 9513.

Interestingly, some integers belong to several different shuffle pairs. For example, 123876 forms one shuffle pair with 371628, and another with 867132, as 123876 * 3 = 371628, and 123876 * 7 = 867132.

Write a function that for a given $from, $to, and $count returns the number of integers $i in the range $from <= $i <= $to that belong to at least $count different shuffle pairs.

Example 1:
- Input: $from = 1, $to = 1000, $count = 1
- Output: 0
- There are no shuffle pairs with elements less than 1000.
Example 2:
- Input: $from = 1500, $to = 2500, $count = 1
- Output: 3
- There are 3 integers between 1500 and 2500 that belong to shuffle pairs.
  - 1782, the other element is 7128 (witness 4)
  - 2178, the other element is 8712 (witness 4)
  - 2475, the other element is 7425 (witness 3)
Example 3:
- Input: $from = 1_000_000, $to = 1_500_000, $count = 5
- Output: 2
- There are 2 integers in the given range that belong to 5 different shuffle pairs.
  - 1428570 pairs with 2857140, 4285710, 5714280, 7142850, and 8571420
  - 1429857 pairs with 2859714, 4289571, 5719428, 7149285, and 8579142
Example 4:
- Input: $from = 13_427_000, $to = 14_100_000, $count = 2
- Output: 11
- 6 integers in the given range belong to 3 different shuffle pairs,
- 5 integers belong to 2 different ones.
Example 5:
- Input: $from = 1030, $to = 1130, $count = 1
- Output: 2
- There are 2 integers between 1020 and 1120 that belong to at least one shuffle pair:
  - 1035, the other element is 3105 (witness k = 3)
  - 1089, the other element is 9801 (witness k = 9)

Deliberations

It takes a minute to digest this one.

I first wondered if there's some algebraic number theory trick that would cut the search space way down, but that made my head hurt, so I moved to doing what computers do best: grinding through a lot of possibilities.

A bad first thought was to try all combinations of the digits, but that's going to die an excruciating slow death on the crucifix of combinatorics, not to mention that we'd be completely wasting our time on all but a few combinations.

A better thought is to look only at the multiples of a given number. There are at most 8 multiples of a number in play: the 10th would add a digit, and therefore can't possibly be a reordering. Examples 3 and 4 have a lot of numbers to grind through, but how long can it take, really? It's one banana, Michael; how much could it cost, ten dollars?

How will I decide that a number is a re-ordering? I think I'll reduce each number to a canonical form where the digits are sorted, then use string compare to see if a multiple has the same canonical form.

To the bat-editor, Robin!

First, a little function to turn a number into a canonical form with its digits in sorted order. Turn the number into a list of digits, sort, and then join the digits back into a string.

sub canonical($n)
{
    join("", sort split(//, $n));
}

Now the main course. I'll want to examine every number in the range $from to $to, inclusive. For each number, I'll want to examine its multiples to see if they have the same digits. I need to count the ones that work so that I can check that there are at least $count of them.

sub shufflePair($from, $to, $count)
{
    my $answer = 0;

    for my $n ( $from .. $to )
    {
        my $base = canonical($n);
        my $max = (9 x length($n))+0;
        my $pair = 0;
        for ( 2 .. 9 )
        {
            my $multiple = $n * $_;

            next if $multiple > $max
                 || index($base, substr($multiple,  0, 1)) < 0
                 || index($base, substr($multiple, -1, 1)) < 0;

            if ( canonical($multiple) eq $base )
            {
                $pair++;
            }
        }
        $answer++ if $pair >= $count;
    }
    return $answer;
}

Notes:

my $base = canonical($n) -- hang on to this for comparison.
my $max = (9 x length($n))+0; -- An optimization. The maximum number we need to be concerned with is one that has the same number of digits, but is all 9s. For example, if $n is 480, then we are dealing with 3-digit numbers, so the largest possible is 999. That's less than 480*3=1440, so we don't have to examine any of the multiples beyond 480*2.
for ( 2..9 ) -- These are the only multiples of $n that could possibly have the same number of digits.
next if ... -- Besides the check on $max, we can make cheap checks on a single digit. If the first or last digit isn't one of the possible digits, we can avoid the overhead of canonical(), which isn't horrendous, but it does involve allocating lists and a sort.
canonical($multiple) eq $base -- This string compare is where we decide if we have a shuffle pair.
$answer++ if $pair >= $count -- We increment the answer if this number has at least $count shuffle pairs.

This solution takes a few seconds to run the examples. My optimizations to bail early in many cases cut the run time approximately in half (from about 8 seconds to about 4.5).

PWC 349 More complex than it has to be

Bob Lied — Wed, 26 Nov 2025 03:32:52 +0000

PWC 349 Task 2: Meeting Point

Musical Interlude

We're going deep cut from the classic Blood on the Tracks album by Bob Dylan, Meet Me in the Morning

The Task

You are given an instruction string made up of U (up), D (down), L (left) and R (right). Write a script to return true if following the instructions, you meet (0,0) at any point along the sequence.

Example 1:
- Input: $path = "ULD"
- Output: false
- U -> (0,1), L -> (-1,1), D -> (-1, 0)
Example 2:
- Input: $path = "ULDR"
- Output: true
- U -> (0,1), L -> (-1,1), D -> (-1, 0), R -> (0,0)
Example 5:
- Input: $path = "RRUULLDDRRUU"
- Output: true
- RRUULLDD -> (0,0), RRUU -> (2,2)

The Deliberation

The first thought is emulate the movement on the grid and see if we end up at (0,0).

A clever thought arises: to end up back where we began, every Up must be matched with a Down, and every Right must be matched with a Left. So all we really have to do is count moves, right?

But Example 5 throws a wrench. The path makes a big square and passes through (0,0), but doesn't end there. I guess I really do need to check every move in the path.

Second clever thought (this one might be worth keeping): moving around a grid can be like moving in the complex plane. A horizontal move is along the real axis, and a vertical move is along the imaginary axis. If we think of the location as a complex number, then a move is an increment of either the real or the imaginary part.

The Code

Nice try, no cigar

Let's dispense with what didn't work, because it looked good until we hit Example 5.

sub meet($path)
{
    my @m = map { scalar(()= $path =~ m/$_/g) } qw(U D L R);
    return $m[0] == $m[1]  && $m[2] == $m[3];
}

Notes:

We'll try to count the number of each direction and see if Ups cancel Downs and Rights cancel Lefts.
my @m = map {...} qw(U D L R) -- for each move, map to the number of occurrences of that move in $path
$path =~ m/$_/g -- $_ is one of (U,D,L,R). The regular expression match with a g flag can return a list of all the occurrences of that letter in $path.
scalar(()= ...) -- assigning the match to an empty list will create an array context, so that m// will yield a list. Then taking the scalar of that will give a count. This is a variant of the =()= Saturn secret operator
Now it only remains to check if the numbers align.

Moving on to something that works

sub meetComplex($path)
{
    use Math::Complex;

    state $origin = (0 + 0*i);
    state %move = ( R => (1 + 0*i), L => (-1 +  0*i),
                    U => (0 + 1*i), D => ( 0 + -1*i), );

    my $place = $origin;
    for ( split(//, uc $path) )
    {
        $place += $move{$_};
        return true if $place == $origin;
    }
    return false;
}

Notes:

use Math::Complex -- Yes, Perl does complex arithmetic.
state $origin = (0 + 0*i) -- Set up a "constant" for the origin. state makes a variable that is initialized only the first time the function is entered, and limits the scope to the function. Math::Complex makes it possible to write complex constants in a natural way.
state %move -- Set up "constants" for movements. Moving Right and Left affects the real part of the complex number; moving Up and Down affects the imaginary part.
for ( split(...) ) -- Take the path apart to process each move. I threw in an uc to make sure we would only have uppercase input.
$place += $move{$_} -- For each move, change $place in the complex plane. Math::Complex overloads operators as expected.
return true if $place == $origin -- Complex numbers can be compared, of course.
If we didn't find (0,0), then the answer is false.

PWC 348 String Alike, Convert Time

Bob Lied — Wed, 19 Nov 2025 03:18:12 +0000

PWC 348 Task 1: String Alike

The Task

You are given a string of even length. Write a script to find out whether the given string can be split into two halves of equal lengths, each with the same non-zero number of vowels.

Example 1:
- Input: $str = "textbook" text | book (1, 2)
- Output: false
Example 2:
- Input: $str = "book" bo | ok (1, 1)
- Output: true
Example 3:
- Input: $str = "AbCdEfGh" AbCd | EfGh (1, 1)
- Output: true
Example 4:
- Input: $str = "rhythmmyth" rhyth | mmyth (0, 0)
- Output: false
Example 5:
- Input: $str = "UmpireeAudio" Umpire | eAudio (3, 5)
- Output: false

Thoughts

Two steps are required: dividing the string in half, and counting vowels in each half. Let's do the obvious thing with substr to get the halves, and we can exploit the quirks of tr to count.

The examples give us a couple of important test cases: the string can contain uppercase and lowercase; and the string might not have any vowels at all. Also notice that vowels are strictly "aeiou" -- "y" is not counted as a vowel.

Code

sub strAlike($str)
{
    $str = lc($str);
    my $mid = length($str) / 2;
    my @count = map { $_ =~ tr/aeiou// }
                        substr($str, 0, $mid), substr($str, $mid);
    return $count[0] == $count[1] && $count[0] > 0;
}

Notes:

lc($str) -- eliminate uppercase letters
$mid = ... -- assuming even length given, as specified
substr($str, 0, mid) -- the left half
substr($str, $mid) -- the right half (third argument not needed). The two substr calls result in a list of two strings, which we will pass to ...
@count = map { } -- count vowels in each substring and assign into an array of vowel counts
$_ =~ tr/aeiou// -- Ah, tr. A quirk of tr is that it returns a count of replacements made. Replace all the vowels of interest, and there's our count. Another quirk of tr is that the first argument is not a regular expression, so there are no brackets for character class here. Note the literal use of aeiou. Yet another quirk of tr is that there is no variable interpolation, so it would be awkward to try to parameterize this.
return ... -- The description specifies non-zero counts, so the extra condition is needed to make Example 4 work.

PWC 348 Task 2: Convert Time

The Task

You are given two strings, $source and $target, containing time in 24-hour time form. Write a script to convert the source into target by performing one of the following operations:

Add 1 minute
Add 5 minutes
Add 15 minutes
Add 60 minutes

Find the total operations needed to get to the target.

Example 1:
- Input: $source = "02:30" $target = "02:45"
- Output: 1 (Add 15 minutes)
Example 2:
- Input: $source = "11:55" $target = "12:15"
- Output: 2 (Add 15 minutes, Add 5 minutes)
Example 3:
- Input: $source = "09:00" $target = "13:00"
- Output: 4 (Add 60 minutes four times)
Example 4:
- Input: $source = "23:45" $target = "00:30"
- Output: 3 (Add 15 minutes three times)
Example 5:
- Input: $source = "14:20" $target = "15:25"
- Output: 2 (Add 60 minutes, Add 5 minutes)

Thoughts

This is a variation on the problem of making change from a set of coins, or finding the combination of stamps to pay postage.

We need to find the difference in minutes from $source to $target. Example 4 shows that we might have to cross midnight.

I could take the hours and minutes apart and do the math. But I think I'd rather use well-tested modules, so I'll use Time::Piece to parse the times and find the difference.

The operation count will be taking the biggest number of chunks possible, so in reverse order: 60, 15, 5, 1.

Code

sub convert($source, $target)
{
    use Time::Piece;

    my $s = Time::Piece->strptime($source, "%H:%M");
    my $t = Time::Piece->strptime($target, "%H:%M");
    my $min = ($t - $s)->minutes;
    if ( $min <  0 ) { $min += 24*60; }

    my $count = 0;
    for my $period ( 60, 15, 5, 1 )
    {
        $count += int($min / $period);
        $min %= $period;
    }
    return $count;
}

Notes:

strptime() -- parse the time strings and create a Time::Piece object. Without any day information, this will be a time on January 1, 1970, but we don't care.
($t-$s)->minutes -- Time::Piece objects can be subtracted to get a duration. That duration is actually a Time::Seconds object, which has a method that returns the duration in minutes.
if ( $min < 0 ) -- This covers the case where $target is after midnight. We'll add 24 hours of minutes to wrap it around back to positive.
The rest is math. Reduce by hours, then quarter-hours, then 5-minute blocks. Since the last block is 1 minute, this will always eventually terminate.

Forem: Bob Lied

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

Relax, I'll Need Some Information First

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

I Do Believe It's Working, Good

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

That'll Keep You Going Through the Show

Come On, It's Time To Go

I Have Become Comfortably Numb

PWC 370 Scramble On, Scramblin' Man

The Task

The Ramblin' Scramblin' Thinkin' Part

A Bold Strategy, Cotton. Let's see if that works out for him.

PWC 367 Overlapping Oddities

Task Description

Task Cogitation

Task Implementation

Solution 1: Sorting

Solution 2: Splitting

Solution 3: Counting

Task Benchmark

Task Description

Task Cogitation

Task Solution

Subtask: Time conversion

Subtask: Event range

Subtask: Range overlap

Composition of the solution

PWC 366, Task 2, Valid Times

The Requirements Phase

The Design Phase

The Implementation Phase

The Delivery Phase

PWC 366 Count Prefixes: Could We Start Again, Please

The Task

An Obvious Solution Using a Regular Expression

A Less-obvious Solution Using a Regular Expression

A Solution Using String Compare

Benchmark

PWC 362 Echo Chamber

The Task

The Thoughts, Both Profound and Superficial

The Solutions

A Regular Expression Substition

A List Solution

A String-building solution

The Comparison

PWC 360 Pertaining to a subtlety of sorting

The task

The thoughts

Creeping doubt #1

Creeping doubt #2

The solution

Does it blend?

PWC 353 To each (array) his own

The Task

The Solution

The Task

Thoughts

To the code-sleigh, Rudolph!

Loop with indexed

Loop with array iterator

Performance check

PWC 352 Five is the one-liest number

The Task

The Deep Thoughts

The Code

The Task

The Deep Thoughts

The Code

Musical Interlude

PWC 350 Good Substring / Shuffle Pairs

Musical Interlude

The Task

The Think-y Part

The Code-y Part

The Task

Deliberations

To the bat-editor, Robin!

PWC 349 More complex than it has to be

Loop with `indexed`