PWC 398 Six of one, half-dozen of the other

It is election week in the US, and the result is an unexpectedly huge mandate for reigning in corruption. Breathing a sigh of relief, I can amuse myself with Weekly Challenge 398. As a hopeful sun rises over the lake on this frosty November morning, the music in the backround is the Spotify playlist This is America

Task 1: Divisible average

Task Description

You are given an array of positive integers. Write a script to return the closest integer to the mean value of all even integers that are divisible by 3. If none is divisible, return 0.

• Example 1: Input: @arr = (18, 5, 7, 11)

  • Output: 18
  • 18 is the only even number and divisible by 3. Average: 18 / 1 = 18.

• Example 2: - Input: @arr = (6, 12, 18, 24, 30, 40)

  • Output: 18
  • The qualifying numbers are 6, 12, 18, 24, and 30. Average: (6 + 12 + 18 + 24 + 30) / 5 = 90 / 5 = 18

• Example 3: - Input: @arr = (3, 9, 15, 21, 27)

  • Output: 0
  • None of the elements are even. Since no elements qualify, return 0.

• Example 4: Input: @arr = (6, 12, 14, 20)

  • Output: 9
  • Average: (6 + 12) / 2 = 9.

• Example 5: Input: @arr = (6, 6, 6, 12, 12)

  • Output: 8
  • All five numbers are even and divisible by 3. Average: (6 + 6 + 6 + 12 + 12) / 5 = 8.4 => 8

Solution

Even and divisible by three implies divisible by six. Select the eligible numbers and calculate the average.

It's possible, as in example 3, that there are no eligible numbers, which would cause a divide-by-zero error. I could test for this, but I choose to use try/catch, which was added to Perl in v5.34 and graduated to non-experimental in v5.40.

Rounding numbers seems easy, but has subtleties. Rather than rediscover them, I lean on lround from the POSIX module.

sub task(@arr)
{
    use List::Util qw/sum0/;
    use POSIX qw/lround/;

    my @use = grep { $_ % 6 == 0 } @arr;

    try {
        lround( sum0(@use)/@use );
    }
    catch ( $e )
    {
        return 0;
    }
}

Task 2:String Difference

Task Description

You are given an array of equal length strings. Write a script to find the difference integer array of each word in the given array. There will be one word with a different array; return that word.

Each words[i] can be converted into a difference integer array difference[i] of length n-1 where difference[i][j] = words[i][j+1] - words[i][j]

• Example 1: Input: @words = ("ab", "bc", "cd", "zy")
  • Output: "zy"

    "ab" => [ 1 -  0] = [ 1]
    "bc" => [ 2 -  1] = [ 1]
    "cd" => [ 3 -  2] = [ 1]
    "zy" => [24 - 25] = [-1] # This one is different

• Example 2: _Input: @words = ("cba", "fed", "azy")
  • Output: "azy"

    "cba" => [ 1 - 2,  0 -  1] = [-1, -1]
    "fed" => [ 4 - 5,  3 -  4] = [-1, -1]
    "azy" => [25 - 0, 24 - 25] = [25, -1] # Different

• Example 3: Input: @words = ("pop", "ada", "beb", "cfc")
  • Output: "pop"

"pop" => [14 - 15, 15 - 14] = [-1, 1] # Different
"ada" => [3 - 0, 0 - 3] = [3, -3]
"beb" => [4 - 1, 1 - 4] = [3, -3]
"cfc" => [5 - 2, 2 - 5] = [3, -3]

• Example 4: Input: @words = ("aaaa", "zzzz", "mmmm", "aaba") Output: "aaba"

"aaaa" => [ 0 -  0,  0 -  0,  0 -  0] = [0, 0, 0]
"zzzz" => [25 - 25, 25 - 25, 25 - 25] = [0, 0, 0]
"mmmm" => [12 - 12, 12 - 12, 12 - 12] = [0, 0, 0]
"aaba" => [ 0 -  0,  1 -  0,  0 -  1] = [0, 1, -1]

• Example 5: Input: @words = ("aceg", "bdfh", "cegi", "azbz")
  • Output: "azbz"

"aceg" => [ 2 - 0, 4 -  2,  6 - 4] = [2, 2, 2]
"bdfh" => [ 3 - 1, 5 -  3,  7 - 5] = [2, 2, 2]
"cegi" => [ 4 - 2, 6 -  4,  8 - 6] = [2, 2, 2]
"azbz" => [25 - 0, 1 - 25, 25 - 1] = [25, -24, 24]

Task Analysis

The task decomposes into two parts: calculating the difference array, and finding the unique array.

The character differences can be calculated using ord. I'm going to trust that ord does the right thing with non-ASCII characters, which is generally a good bet with Perl's support of Unicode.

The obvious thing to do is to convert each string into a difference array. The less obvious thing to do is to go down the columns of the arrays. As soon as any column has a unique value, then we've found the string we want. I'm going to do the less obvious thing.

Going a character at a time will potentially save us from having to calculate every possible difference, because we can stop as soon as we find a unique value in a column. However, it will leave us with the problem of finding the unique value and its index. If the words are long but the list is short, this is probably a net win. If the words are short, but the list is long, the repeated need to count frequencies might dominate the execution. Such a conundrum.

Solution

Finding the unique index

Let's tackle that latter problem: given a list, find the element that occurs exactly once. We want to count the occurrences of each element, but we need to remember the index where the element occurred. Build a table where each element maps to pair of numbers: the frequency count, and the index where the element was seen.

sub uniqueIndex(@list)
{
    use enum qw(COUNT WHERE);
    my %freq;
    for my ($i, $w) (indexed @list)
    {
        $freq{$w}[COUNT]++;
        $freq{$w}[WHERE] = $i;
    }

    my ($u) =  grep { $freq{$_}[COUNT] == 1 } @list;
    return defined($u) ? $freq{$u}[WHERE] : undef;
}

Notes:

• use enum -- For readability, I give the pair names that are constants.
• indexed @list -- The indexed builtin lets us go through a list and have handles both to the list element and the list index. How convenient. It was introduced in Perl v5.40.
• $freq{$w}[COUNT] -- Perl's auto-vivication of hash entries and array references is really convenient here. The memory management to do this in C would be a project in itself.
• my ($u) -- After building the frequency table, grep can return an array of element names that occur exactly once if it is used in an array context. We assert array context by declaring $u in parentheses, but because $u itself is a scalar, only the first thing returned by grep is assigned to it.
• return -- What we have in $u is an element from @list, which is a key value in the %freq hash. What we want is the index, so retrieve that out of the table.
• undef -- It is possible that there is no unique value, and because I don't know how to treat that, I'm going to return an out-of-band undef value to signal that.

Finding the unique difference array

The specification says all the strings have the same length, so I'm going to assume that the appropriate defensive checks have been made so that this is indeed the case.

Within one string, the difference between two consecutive characters can be calculated by applying ord to substrings of length one. I could have split the strings into character arrays, but it seems like a lot of overhead. The use of substr is a little messier, but feels more efficient.

The overall structure is to think of the stacked words as a matrix, and iterate over the columns. As soon as a column appears with a unique value, we've found our culprit.

sub task(@words)
{
    # For each column of a stack of words
    for my $c ( 1 .. length($words[0])-1 )
    {
        # List of character differences at that position
        my @col = map { ord(substr($_, $c, 1)) - ord(substr($_, $c-1, 1)) } @words;

        if ( defined( my $where = uniqueIndex(@col)) )
        {
            return $words[$where];
        }
    }
    return undef;
}