Perl Weekly Challenge: Week 248

Challenge 1:

Shortest Distance

You are given a string and a character in the given string.

Write a script to return an array of integers of size same as length of the given string such that:

distance[i] is the distance from index i to the closest occurence of
the given character in the given string.

The distance between two indices i and j is abs(i - j).
Example 1
Input: $str = "loveleetcode", $char = "e"
Output: (3,2,1,0,1,0,0,1,2,2,1,0)

The character 'e' appears at indices 3, 5, 6, and 11 (0-indexed).
The closest occurrence of 'e' for index 0 is at index 3, so the distance is abs(0 - 3) = 3.
The closest occurrence of 'e' for index 1 is at index 3, so the distance is abs(1 - 3) = 2.
For index 4, there is a tie between the 'e' at index 3 and the 'e' at index 5,
but the distance is still the same: abs(4 - 3) == abs(4 - 5) = 1.
The closest occurrence of 'e' for index 8 is at index 6, so the distance is abs(8 - 6) = 2.
Example 2
Input: $str = "aaab", $char = "b"
Output: (3,2,1,0)

Solving this problem requires a variant of nearest neighbor search.

First the string has be split up into individual characters with .comb().

my @chars = $str.comb;

.keys() gives us all the indices of the elements of @chars. We .grep() through them looking for ones whose element equals $letter. This list is stored in @j.

my @j = @chars.keys.grep({ @chars[$_] eq $letter });

This and the third and fourth lines are only for outputing the results in the format used in the examples.

say q{(},

The core of the script is in this next line.

Once again we use .keys() to get all the indices of @chars. Then using .map() we replace each one with the distance to the nearest $letter via another .map()which subtracts each value of @j from the index (dealing with potentially negative numbers with .abs()) and returns the smallest. $_ from the outer .mao() has to be assigned to a variable to prevent collision with the $_ of the inner .map().

    @chars.keys.map({ my $i = $_; @j.map({ abs($i - $_) }).min; })
    .join(q{,}),
    q{)};

(Full code on Github.)

For Perl, we have to provide our own min() function but other than that the code works the same as in Raku.

my @chars = split //, $str;
my @j = grep { $chars[$_] eq $letter } keys @chars;
say q{(},
    (join q{,}, map { my $i = $_; min(map { abs($i - $_) } @j); } keys @chars),
    q{)};

(Full code on Github.)

Although the algorithm used here is good enough for the small quantities in the examples, it should be noted that it will become more and more inefficient the more $letters in $str. At that point you would have to use space partitioning to keep the number of "neighbors" manageable.

Challenge 2:

Submatrix Sum

You are given a NxM matrix A of integers.

Write a script to construct a (N-1)x(M-1) matrix B having elements that are the sum over the 2x2 submatrices of A,

b[i,k] = a[i,k] + a[i,k+1] + a[i+1,k] + a[i+1,k+1]
Example 1

Input: $a = [ [1, 2, 3, 4], [5, 6, 7, 8], [9, 10, 11, 12] ]

Output: $b = [ [14, 18, 22], [30, 34, 38] ]

Example 2

Input: $a = [ [1, 0, 0, 0], [0, 1, 0, 0], [0, 0, 1, 0], [0, 0, 0, 1] ]

Output: $b = [ [2, 1, 0], [1, 2, 1], [0, 1, 2] ]

The input data is taken from the command-line as a series of arguments where each argument is a row and eeach column in that row is separated by spaces. So e.g. example 2 would look like this: "1 0 0 0" "0 1 0 0" "0 0 1 0" "0 0 0 1". The line below converts this into a 2d array. 

my @a = @args.map({ [ $_.words.map({ .Int }) ] });

Another array is assigned for the output.

my @b;

Then we traverse @a by row, stopping at the row before the last (and setting up a variable to contain the submatrix sums for that row) ...

for 0 .. @a.elems - 2 -> $row {
    my @c;

...and by column, stopping before the last column. for 0 .. @a[$row].elems - 2 -> $col {

We collect four elements at a time. These will be the current element, the one after it, the one below it on the next row, and the element next to that. These are summed together and added to @c.

        @c.push( [+] (@a[$row;$col], @a[$row;$col + 1],
            @a[$row + 1; $col], @a[$row + 1; $col + 1]) );
    }

After a row of submatrices has been collected, @c is appended to @b.

    @b.push(@c);
}

Finally, @b is printed out in the format of the example output.

say "[\n",
    @b.map({ (q{  [ }, @$_.join(q{, }), " ]").join }).join(",\n"),
    "\n]\n";

(Full code on Github.)

And this is the Perl version; a straightforward translation of the Raku code with no surprises.

my @a = map { [ map { 0 + $_} split /\s+/ ] } @ARGV;
my @b;

for my $row (0 .. scalar @a - 2) {
    my @c;
    for my $col (0 .. scalar @{$a[$row]} - 2) {
        my $sum = $a[$row][$col] + $a[$row][$col + 1] +
            $a[$row + 1][$col] + $a[$row + 1][$col + 1];
        push @c, $sum;
    }
    push @b,\@c;
} 

say "[\n",
    (join ",\n", (map { join q{}, (q{  [ }, (join(q{, }, @{$_})), " ]") } @b)),
    "\n]\n";

(Full code on Github.)