Perl Weekly Challenge: Even Digits have a Sum!

My title is, again, word salad from the tasks, and have no musical connection. I feel like I’m losing my touch. But even so, let’s dive into Perl Weekly Challenge 258!

Task 1: Count Even Digits Number

You are given a array of positive integers, @ints.

Write a script to find out how many integers have even number of digits.

Example 1

Input: @ints = (10, 1, 111, 24, 1000)
Output: 3

There are 3 integers having even digits i.e. 10, 24 and 1000.

Example 2

Input: @ints = (111, 1, 11111)
Output: 0

Example 3

Input: @ints = (2, 8, 1024, 256)
Output: 1

Approach

I could to an iterative approach where I divide each integer by 10 repeatedly until the result is less than 1 to count the digits it has, but this time, I already know the clever way to find out how many digits there are in a number without a loop: the integer portion of log10(n) + 1.

Raku

sub evenDigitCount(@ints) {
  my $count = 0; # in case there are no even digit ints
  for @ints -> $n {
    $count++ if floor(log10($n) + 1) % 2 == 0;
  }
  return $count;
}

View the entire Raku script for this task on GitHub.

Perl

The only thing that complicates the Perl solution is that Perl doesn’t have built-in log10() or floor() functions, but we can easily import them from the standard POSIX module.

use POSIX qw( log10 floor );

sub evenDigitCount(@ints) {
  my $count = 0; # in case there are no even digit ints
  foreach my $n ( @ints ) {
    $count++ if floor(log10($n) + 1) % 2 == 0;
  }
  return $count;
}

View the entire Perl script for this task on GitHub.

Python

For once, Python is a little more like Perl than it is Raku: we have to import floor() and log10() from the math module. Again, I get to use the one-line if statement syntax I learned last week.

from math import floor, log10

def evenDigitCount(ints):
    count = 0; # in case there are no even digit ints
    for n in ints:
        if floor(log10(n) + 1) % 2 == 0: count += 1
    return count

View the entire Python script for this task on GitHub.


Task 2: Sum of Values

You are given an array of integers, @ints and an integer $k.

Write a script to find the sum of values whose index binary representation has exactly $k number of 1-bit set.

Example 1

Input: @ints = (2, 5, 9, 11, 3), $k = 1
Output: 17

Binary representation of index 0 = 0
Binary representation of index 1 = 1
Binary representation of index 2 = 10
Binary representation of index 3 = 11
Binary representation of index 4 = 100

So the indices 1, 2 and 4 have total one 1-bit sets.
Therefore the sum, $ints[1] + $ints[2] + $ints[4] = 17

Example 2

Input: @ints = (2, 5, 9, 11, 3), $k = 2
Output: 11

Example 3

Input: @ints = (2, 5, 9, 11, 3), $k = 0
Output: 2

Approach

This time I don’t have a clever approach, so I’m going to count the set bits in the number by looping through them. However, we’re going to be using this multiple times for the same number, so it makes sense to cache the results so we only wind up counting the set bits once per number.

Raku

In Raku, there’s an is cached trait that can be added to a routine:

Causes the return value of a routine to be stored, so that when subsequent calls with the same list of arguments are made, the stored value can be returned immediately instead of re-running the routine.

use experimental :cached;

sub setBitCount($i) is cached {
  my $count = 0;
  my $bit   = 1;
  while ($bit <= $i) {
    $count++ if $i +& $bit; # count if we have this bit set
    $bit +<= 1; # shift bits left, ie 10 becomes 100
  }
  return $count;
}

sub valueSum($k, @ints) {
  my $sum = 0;
  for 0 .. @ints.end -> $i {
    $sum += @ints[$i] if setBitCount($i) == $k;
  }
  return $sum;
}

View the entire Raku script for this task on GitHub.

Perl

In Perl, we do this by using the built-in Memoize module:

use Memoize;
memoize('setBitCount');

sub setBitCount($i) {
  my $count = 0;
  my $bit   = 1;
  while ($bit <= $i) {
    $count++ if $i & $bit; # count if we have this bit set
    $bit <<= 1; # shift bits left, ie 10 becomes 100
  }
  return $count;
}

sub valueSum($k, @ints) {
  my $sum = 0;
  foreach my $i ( 0 .. $#ints ) {
    $sum += $ints[$i] if setBitCount($i) == $k;
  }
  return $sum;
}

View the entire Perl script for this task on GitHub.

Python

In Python, we accomplish this using the @cache decorator in functools:

from functools import cache

@cache
def setBitCount(i):
  count = 0
  bit   = 1
  while (bit <= i):
    if i & bit: count += 1 # count if we have this bit set
    bit <<= 1 # shift bits left, ie 10 becomes 100
  return count

def valueSum(k, ints):
  sum = 0
  for i in range(len(ints)):
    if setBitCount(i) == k: sum += ints[i]
  return sum

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-258/packy-anderson

Perl Weekly Challenge: Reduced is Smaller!

No music again this week. I don’t know why, it’s just not coming to me.

Onward to Perl Weekly Challenge 257!

Task 1: Smaller than Current

You are given an array of integers, @ints.

Write a script to find out how many integers are smaller than current i.e. foreach ints[i], count ints[j] < ints[i] where i != j.

Example 1

Input: @ints = (5, 2, 1, 6)
Output: (2, 1, 0, 3)

For $ints[0] = 5, there are two integers (2,1) smaller than 5.
For $ints[1] = 2, there is one integer (1) smaller than 2.
For $ints[2] = 1, there is none integer smaller than 1.
For $ints[3] = 6, there are three integers (5,2,1) smaller than 6.

Example 2

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

Example 3

Input: @ints = (0, 1)
Output: (0, 1)

Example 4

Input: @ints = (9, 4, 9, 2)
Output: (2, 1, 2, 0)

Approach

Something tells me there’s a clever way to accomplish this, but I’m just going to plow ahead and do this as a double loop.

Raku

sub smallerThan(@ints) {
  my @counts;
  for 0 .. @ints.end -> $i {
    @counts[$i] = 0;
    for 0 .. @ints.end -> $j {
      next if $i == $j;
      @counts[$i]++ if @ints[$j] < @ints[$i];
    }
  }
  return @counts;
}

View the entire Raku script for this task on GitHub.

Perl

As usual, the Perl version is almost identical to the Raku version except for the sigils and looping.

sub smallerThan(@ints) {
  my @counts;
  foreach my $i (0 .. $#ints) {
    @counts[$i] = 0;
    foreach my $j (0 .. $#ints) {
      next if $i == $j;
      $counts[$i]++ if $ints[$j] < $ints[$i];
    }
  }
  return @counts;
}

View the entire Perl script for this task on GitHub.

Python

The biggest thing I needed to remember for Python was to append elements to the counts list, because in Python you can’t extend an array just by assigning to a previously non-existent array index. I did, however, look up that Python has one-line if statements.

def smallerThan(ints):
  counts = []
  for i in range(len(ints)):
    counts.append(0)
    for j in range(len(ints)):
      if i != j and ints[j] < ints[i]: counts[i] += 1
  return counts

View the entire Python script for this task on GitHub.


Task 2: Reduced Row Echelon

Given a matrix M, check whether the matrix is in reduced row echelon form.

A matrix must have the following properties to be in reduced row echelon form:

1. If a row does not consist entirely of zeros, then the first
   nonzero number in the row is a 1. We call this the leading 1.
2. If there are any rows that consist entirely of zeros, then
   they are grouped together at the bottom of the matrix.
3. In any two successive rows that do not consist entirely of
   zeros, the leading 1 in the lower row occurs farther to the
   right than the leading 1 in the higher row.
4. Each column that contains a leading 1 has zeros everywhere
   else in that column.

For example:

[
   [1,0,0,1],
   [0,1,0,2],
   [0,0,1,3]
]

The above matrix is in reduced row echelon form since the first nonzero number in each row is a 1, leading 1s in each successive row are farther to the right, and above and below each leading 1 there are only zeros.

For more information check out this wikipedia article.

Example 1

    Input: $M = [
                  [1, 1, 0],
                  [0, 1, 0],
                  [0, 0, 0]
                ]
    Output: 0

Example 2

    Input: $M = [
                  [0, 1,-2, 0, 1],
                  [0, 0, 0, 1, 3],
                  [0, 0, 0, 0, 0],
                  [0, 0, 0, 0, 0]
                ]
    Output: 1

Example 3

    Input: $M = [
                  [1, 0, 0, 4],
                  [0, 1, 0, 7],
                  [0, 0, 1,-1]
                ]
    Output: 1

Example 4

    Input: $M = [
                  [0, 1,-2, 0, 1],
                  [0, 0, 0, 0, 0],
                  [0, 0, 0, 1, 3],
                  [0, 0, 0, 0, 0]
                ]
    Output: 0

Example 5

    Input: $M = [
                  [0, 1, 0],
                  [1, 0, 0],
                  [0, 0, 0]
                ]
    Output: 0

Example 6

    Input: $M = [
                  [4, 0, 0, 0],
                  [0, 1, 0, 7],
                  [0, 0, 1,-1]
                ]
    Output: 0

Approach

Again, there may be a clever way to do this, but I figure the easiest way is to just plow through the conditions. If we fail one, we can return early.

Raku

At first, I thought of adding all the values in a row using Raku’s Reduction Metaoperator to see if they were all zeroes, but then I noticed that examples 2 and 4 thwart that method, because 0+1-2+0+1=0. So I switched to a loop.

sub rowIsEntirelyZeros(@row) {
  for @row -> $n {
    next if $n == 0;
    return 0;
  }
  return 1;
}

sub rowHasLeadingOne(@row) {
  for @row -> $n {
    next if $n == 0;
    return $n == 1;
  }
}

sub leadingOnePosition(@row) {
  for 0 .. @row.end -> $i {
    next if @row[$i] == 0;
    return $i;
  }
}

sub columnHasZerosBesidesLeadingOne(@matrix, $col) {
  my $count = 0;
  for @matrix -> @row {
    next if @row[$col] == 0; # skip zeroes
    return 0 if @row[$col] != 1; # fail if not one
    $count++; # count ones
  }
  return $count == 1;
}

sub isReducedRowEchelon(@matrix) {
  my $foundAllZeroRow = 0;
  my $lastLeadingOnePos = -1; # avoid comparison with undef
  for @matrix -> @row {
    if (! rowIsEntirelyZeros(@row)) {
      # 1. If a row does not consist entirely of zeros, then
      #    the first nonzero number in the row is a 1. We call
      #    this the leading 1.
      return 0 unless rowHasLeadingOne(@row);

      # 2. If there are any rows that consist entirely of zeros,
      #    then they are grouped together at the bottom of the
      #    matrix.
      return 0 if $foundAllZeroRow;

      # 3. In any two successive rows that do not consist
      #    entirely of zeros, the leading 1 in the lower row
      #    occurs farther to the right than the leading 1 in
      #    the higher row.
      my $thisLeadingOnePos = leadingOnePosition(@row);
      return 0 if $lastLeadingOnePos > $thisLeadingOnePos;
      $lastLeadingOnePos = $thisLeadingOnePos;

      # 4. Each column that contains a leading 1 has zeros
      #    everywhere else in that column.
      return 0 unless columnHasZerosBesidesLeadingOne(
        @matrix, $thisLeadingOnePos
      );
    }
    else {
      $foundAllZeroRow = 1;
    }
  }
  return 1;
}

View the entire Raku script for this task on GitHub.

Perl

Unlike Raku, in Perl you can’t have an array parameter followed by a scalar, so I switched them to be scalars that held array references.

sub rowIsEntirelyZeros(@row) {
  foreach my $n (@row) {
    next if $n == 0;
    return 0;
  }
  return 1;
}

sub rowHasLeadingOne(@row) {
  foreach my $n (@row) {
    next if $n == 0;
    return $n == 1;
  }
}

sub leadingOnePosition(@row) {
  foreach my $i (0 .. $#row) {
    next if $row[$i] == 0;
    return $i;
  }
}

sub columnHasZerosBesidesLeadingOne($matrix, $col) {
  my $count = 0;
  foreach my $row (@$matrix) {
    next if $row->[$col] == 0; # skip zeroes
    return 0 if $row->[$col] != 1; # fail if not one
    $count++; # count ones
  }
  return $count == 1;
}

sub isReducedRowEchelon(@matrix) {
  my $foundAllZeroRow = 0;
  my $lastLeadingOnePos = -1; # avoid comparison with undef
  foreach my $row (@matrix) {
    if (! rowIsEntirelyZeros(@$row)) {
      # 1. If a row does not consist entirely of zeros, then
      #    the first nonzero number in the row is a 1. We call
      #    this the leading 1.
      return 0 unless rowHasLeadingOne(@$row);

      # 2. If there are any rows that consist entirely of zeros,
      #    then they are grouped together at the bottom of the
      #    matrix.
      return 0 if $foundAllZeroRow;

      # 3. In any two successive rows that do not consist
      #    entirely of zeros, the leading 1 in the lower row
      #    occurs farther to the right than the leading 1 in
      #    the higher row.
      my $thisLeadingOnePos = leadingOnePosition(@$row);
      return 0 if $lastLeadingOnePos > $thisLeadingOnePos;
      $lastLeadingOnePos = $thisLeadingOnePos;

      # 4. Each column that contains a leading 1 has zeros
      #    everywhere else in that column.
      return 0 unless columnHasZerosBesidesLeadingOne(
        \@matrix, $thisLeadingOnePos
      );
    }
    else {
      $foundAllZeroRow = 1;
    }
  }
  return 1;
}

View the entire Perl script for this task on GitHub.

Python

Now that I know Python has one-line if statements, it’s easy to translate the postfix if/unless statements!

def rowIsEntirelyZeros(row):
    for n in row:
        if not n == 0: return 0
    return 1

def rowHasLeadingOne(row):
    for n in row:
        if not n == 0: return n == 1

def leadingOnePosition(row):
    for i in range(len(row)):
        if not row[i] == 0: return i

def columnHasZerosBesidesLeadingOne(matrix, col):
    count = 0
    for row in matrix:
        if not row[col] == 0: # skip zeroes
            if row[col] != 1: return 0 # fail if not one
            count += 1 # count ones
    return count == 1

def isReducedRowEchelon(matrix):
    foundAllZeroRow = 0
    lastLeadingOnePos = -1 # avoid comparison with undef
    for row in matrix:
        if not rowIsEntirelyZeros(row):
            # 1. If a row does not consist entirely of zeros,
            #    then the first nonzero number in the row is
            #    a 1. We call this the leading 1.
            if not rowHasLeadingOne(row): return 0 

            # 2. If there are any rows that consist entirely
            #    of zeros, then they are grouped together at
            #    the bottom of the matrix.
            if foundAllZeroRow: return 0

            # 3. In any two successive rows that do not consist
            #    entirely of zeros, the leading 1 in the lower
            #    row occurs farther to the right than the
            #    leading 1 in the higher row.
            thisLeadingOnePos = leadingOnePosition(row)
            if lastLeadingOnePos > thisLeadingOnePos: return 0
            lastLeadingOnePos = thisLeadingOnePos

            # 4. Each column that contains a leading 1 has
            #    zeros everywhere else in that column.
            if not columnHasZerosBesidesLeadingOne(
                matrix, thisLeadingOnePos
            ): return 0
        else:
            foundAllZeroRow = 1
    return 1

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-257/packy-anderson

Perl Weekly Challenge: Merge the Maximum String Pairs

Finally, the challenge needs 9 bits for its number! Perl Weekly Challenge 0x100!

Sorry, no music this week. It’s just not coming to me…

Task 1: Maximum Pairs

You are given an array of distinct words, @words.

Write a script to find the maximum pairs in the given array. The words $words[i] and $words[j] can be a pair one is reverse of the other.

Example 1

Input: @words = ("ab", "de", "ed", "bc")
Output: 1

There is one pair in the given array: "de" and "ed"

Example 2

Input: @words = ("aa", "ba", "cd", "ed")
Output: 0

Example 3

Input: @words = ("uv", "qp", "st", "vu", "mn", "pq")
Output: 2

Approach

Ok, the easiest way to do this is to step through the array and compare each element to the reverse of the other elements. But once we’ve compared an element to all the others, we don’t have to compare it again, even if it wasn’t part of a pair. Furthermore, once we’ve found a pair, we don’t need to compare either of those elements to any others, since there can be only two elements in a pair.

Raku

Of course, I figured that reverse was how I would reverse a string in Raku. Nor according to the docs, though:

Note that reverse always refers to reversing elements of a list; to reverse the characters in a string, use flip.

sub maximumPairs(@words) {
  my $count = 0;
  while (@words) {
    # the the first word off the list
    my $first = @words.shift;
    # now compare to the rest of the words in the list
    for 0 .. @words.end -> $i {
      my $second = @words[$i];
      if ($first eq $second.flip) {
        # we found a pair
        $count++;
        # remove @words[$i] from the list
        @words.splice($i, 1);
        # we don't need to compare any more words to $first
        last;
      }
    }
  }
  return $count;
}

View the entire Raku script for this task on GitHub.

Perl

But in Perl, I get to use the familiar reverse.

sub maximumPairs(@words) {
  my $count = 0;
  while (@words) {
    # the the first word off the list
    my $first = shift @words;
    # now compare to the rest of the words in the list
    for my $i (0 .. $#words) {
      my $second = $words[$i];
      if ($first eq reverse $second) {
        # we found a pair
        $count++;
        # remove @words[$i] from the list
        splice(@words, $i, 1);
        # we don't need to compare any more words to $first
        last;
      }
    }
  }
  return $count;
}

View the entire Perl script for this task on GitHub.

Python

I remembered that Python’s pop not only worked on the end of a list, but could also remove an element anywhere in the list (pop[0] is the equivalent of shift in other languages, but pop[i] is effectively splice(i, 1)), but I had to look up how to reverse a string, and I came across this nice idiomatic use of Python’s extended slice syntax. The syntax is [start:stop:step]; because we don’t specify a start and a stop, we operate on the entire string, and by specifying a step of -1, we step backwards through the string. We could also have used ''.join(reversed(s)), but from what I read, that’s actually slower than the string slice.

I still find it odd that Python doesn’t have an increment (++) operator.

def maximumPairs(words):
    count = 0
    while words:
        # the the first word off the list
        first = words.pop(0)
        # now compare to the rest of the words in the list
        for i in range(len(words)):
            second = words[i]
            if first == second[::-1]:
                # we found a pair
                count += 1
                # remove words[i] from the list
                words.pop(i)
                # we don't need to compare
                # any more words to first
                break
    return count

View the entire Python script for this task on GitHub.


Task 2: Merge Strings

You are given two strings, $str1 and $str2.

Write a script to merge the given strings by adding in alternative order starting with the first string. If a string is longer than the other then append the remaining at the end.

Example 1

Input: $str1 = "abcd", $str2 = "1234"
Output: "a1b2c3d4"

Example 2

Input: $str1 = "abc", $str2 = "12345"
Output: "a1b2c345"

Approach

Really, my approach to the first task is informing my approach to this one, because in that task I was pulling elements off a list. This time, if I break the strings into arrays and shift off the characters in alternation, I’ll get the result I’m looking for.

Raku

Note I’m using arrays being evaluated in scalar context in multiple places, where they work effectively like booleans: if @array has elements in it, it evaluates true.

sub mergeStrings($str1, $str2) {
  my @chars1 = $str1.split('', :skip-empty);
  my @chars2 = $str2.split('', :skip-empty);
  my $result;
  while (@chars1 || @chars2) {
    $result ~= @chars1.shift if @chars1;
    $result ~= @chars2.shift if @chars2;
  }
  return $result;
}

View the entire Raku script for this task on GitHub.

Perl

Besides the change in split and shift syntax and the concatenation character changing from ~ to ., the Perl version is exactly the same as the Raku version.

sub mergeStrings($str1, $str2) {
  my @chars1 = split(//, $str1);
  my @chars2 = split(//, $str2);
  my $result;
  while (@chars1 || @chars2) {
    $result .= shift(@chars1) if @chars1;
    $result .= shift(@chars2) if @chars2;
  }
  return $result;
}

View the entire Perl script for this task on GitHub.

Python

The nice thing in Python is you can convert a string into a list of characters with list(s).

def mergeStrings(str1, str2):
    chars1 = list(str1)
    chars2 = list(str2)
    result = ''
    while chars1 or chars2:
        if chars1:
            result += chars1.pop(0)
        if chars2:
            result += chars2.pop(0)
    return result

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-256/packy-anderson

Perl Weekly Challenge: Odd Char Seems to be the Most Frequent Word

As usual, the title and the musical theme is pretty much word salad from the two problem titles. Tonight, the musical accompaniment is Diana Krall’s cover of Elton John’s Sorry Seems to be the Hardest Word.

So, onward to Perl Weekly Challenge 0xFF… er, 255!

Task 1: Odd Character

You are given two strings, $s and $t. The string $t is generated using the shuffled characters of the string $s with an additional character.

Write a script to find the additional character in the string $t..

Example 1

Input: $s = "Perl" $t = "Preel"
Output: "e"

Example 2

Input: $s = "Weekly" $t = "Weeakly"
Output: "a"

Example 3

Input: $s = "Box" $t = "Boxy"
Output: "y"

Approach

Ok, this is essentially a problem of finding the difference between two sets of characters. One of the thoughts I had was to just plow through the second string comparing characters with the first string, but the problem specifies the second string is “generated using the shuffled characters” of the first, so we need to assume the characters will be in a different order (even though in the examples only one is).

So I figure what I’ll do is this: count each of the characters using a hash. Then when I go through the second string, I’ll check to see if the count for that character exists; if it doesn’t, we’ve found the added character. If it does, we decrement the count for that character and remove it from the hash if the count is now 0, and then move on to the next character. Of course, because the first string is shuffled to create the second string, but both are presented in title case, we want to lower case the characters before we process them.

Raku

Once again, I needed to remind myself that Raku is not Perl. I remembered that I couldn’t test for the existence of entries in a hash with exists and remove entries from a hash with delete the same way I could in Perl; fortunately, I only had to go back to my work on PWC 242 to find the Subscript Adverb :exists and my work on PWC 237 for the Subscript Adverb :delete.

sub oddChar($s, $t) {
  # count the characters in $s
  my %count;
  for $s.lc.split('', :skip-empty) -> $c {
    %count{$c}++;
  }
  # find the character in $t that's been added to $s
  for $t.lc.split('', :skip-empty) -> $c {
    if ( %count{$c}:!exists ) {
      # we found the added character!
      return $c
    }
    %count{$c}--;
    %count{$c}:delete if %count{$c} == 0;
  }
  die "No odd character found!";
}

View the entire Raku script for this task on GitHub.

Perl

But when I went from Raku to Perl, it felt like Raku really was Perl, because other than flipping for to foreach, reformatting the split and lc usage, changing the sigils when accessing hash elements, and changing exists and delete from adverbs to built-in functions, everything else remained the same.

sub oddChar($s, $t) {
  # count the characters in $s
  my %count;
  foreach my $c ( split(//, lc($s)) ) {
    $count{$c}++;
  }
  # find the character in $t that's been added to $s
  foreach my $c ( split(//, lc($t)) ) {
    if ( ! exists $count{$c} ) {
      # we found the added character!
      return $c
    }
    $count{$c}--;
    delete $count{$c} if $count{$c} == 0;
  }
  die "No odd character found!";
}

View the entire Perl script for this task on GitHub.

Python

The Python solution is made easier by being able to just loop over the characters in a string without having to split them up. As I did back in PWC 234, PWC 247, and PWC 249, I’m using Python’s  Counter type in the collections module that lets you autovivify elements in a dictionary by adding to them.

import sys
from collections import Counter

def oddChar(s, t):
    # count the characters in s
    count = Counter()
    for c in s.lower():
        count[c] += 1

    # find the character in t that's been added to s
    for c in t.lower():
        if c not in count:
            # we found the added character!
            return c
        count[c] -= 1
        if count[c] == 0:
            del count[c]

    sys.exit("No odd character found!")

View the entire Python script for this task on GitHub.

In none of the examples do we not find the odd character, but I felt it necessary to throw some kind of exception if we got to the end of oddChar() without having returned anything.


Task 2: Most Frequent Word

You are given a paragraph $p and a banned word $w.

Write a script to return the most frequent word that is not banned.

Example 1

Input: $p = "Joe hit a ball, the hit ball flew far after it was hit."
       $w = "hit"
Output: "ball"

The banned word "hit" occurs 3 times.
The other word "ball" occurs 2 times.

Example 2

Input: $p = "Perl and Raku belong to the same family. Perl is the most popular language in the weekly challenge."
       $w = "the"
Output: "Perl"

The banned word "the" occurs 3 times.
The other word "Perl" occurs 2 times.

Approach

Once again, this challenge is all about counting, and once again, I’m going to use a hash/dictionary.

Raku

While writing this, I noticed that I wasn’t getting the same count in the first example as the sample output, and I realized because it was counting “hit.” separately from “hit”.

Example 1:
Input: $p = "Joe hit a ball, the hit ball flew far after it was hit."
       $w = "hit"
Output: "hit."

The banned word "hit" occurs 2 times.
The other word "hit." occurs 1 time.

So I decided that I needed to remove punctuation from the paragraph before splitting it into words.

The other challenging part was remembering how Raku regexes did substitutions and negated character classes.

sub frequentWord($p, $w) {
  # assign the value to a container so we can modify it
  my $paragraph = $p;

  # first, remove punctuation from the paragraph
  # (but we'll leave apostrophes for contractions)
  $paragraph ~~ s:i:g/<-[a..z'\s]>//;

  # count the words in $paragraph
  my %count;
  for $paragraph.lc.split(' ', :skip-empty) -> $pw {
    %count{$pw}++;
  }

  # generate the output about the banned word
  my $bannedCount = %count{$w} // 0;
  my $output = qq/The banned word "$w" occurs $bannedCount /;
  $output ~= ($bannedCount == 1) ?? 'time' !! 'times';
  $output ~= ".\n";

  # delete the banned word from the word count
  %count{$w}:delete;

  # now find the most frequent word left and report on that
  my @sorted = %count.keys.sort: {
    # sort by count
    %count{$^b} <=> %count{$^a}
  };
  my $freqWord  = @sorted[0];
  my $freqCount = %count{$freqWord};

  $output ~= qq/The other word "$freqWord" /;
  $output ~= qq/occurs $freqCount /;
  $output ~= ($freqCount == 1) ?? 'time.' !! 'times.';

  return $freqWord, $output;
}
Example 1:
Input: $p = "Joe hit a ball, the hit ball flew far after it was hit."
       $w = "hit"
Output: "ball"

The banned word "hit" occurs 3 times.
The other word "ball" occurs 2 times.

View the entire Raku script for this task on GitHub.

Perl

The Perl version was easier, because I’m very familiar with Perl regexes and I didn’t have to worry about reassigning the $p parameter to something I could write to.

sub frequentWord($p, $w) {
  # first, remove punctuation from the paragraph
  # (but we'll leave apostrophes for contractions)
  $p =~ s/[^a-z'\s]//ig;

  # count the words in $paragraph
  my %count;
  foreach my $pw ( split(/\s+/, lc($p)) ) {
    $count{$pw}++;
  }

  # generate the output about the banned word
  my $bannedCount = $count{$w} // 0;
  my $output = qq/The banned word "$w" occurs $bannedCount /;
  $output .= ($bannedCount == 1) ? 'time' : 'times';
  $output .= ".\n";

  # delete the banned word from the word count
  delete $count{$w};

  # now find the most frequent word left and report on that
  my @sorted = sort {
    # sort by count
    $count{$b} <=> $count{$a}
  } keys %count;
  my $freqWord  = $sorted[0];
  my $freqCount = $count{$freqWord};

  $output .= qq/The other word "$freqWord" /;
  $output .= qq/occurs $freqCount /;
  $output .= ($freqCount == 1) ? 'time.' : 'times.';

  return $freqWord, $output;
}

View the entire Perl script for this task on GitHub.

Python

And, just like I did back in PWC 247 and PWC 253, I’d like to point out that Python’s Decorate-Sort-Undecorate idiom is really just a Schwartzian Transformation.

import re
from collections import Counter

def frequentWord(p, w):
    # first, remove punctuation from the paragraph
    # (but we'll leave apostrophes for contractions)
    p = re.sub(r'[^a-z\'\s]', '', p.lower())

    # count the words in $paragraph
    count = Counter()
    for pw in p.split():
        count[pw] += 1

    # generate the output about the banned word
    bannedCount = count[w] if w in count else 0
    output = f'The banned word "{w}" occurs {bannedCount} ';
    output += 'time' if bannedCount == 1 else 'times'
    output += ".\n"

    # delete the banned word from the word count
    del count[w]

    # now find the most frequent word left and report on that
    decorated = [ ( count[w], w ) for w in count.keys() ]
    sorted_tuples = sorted(
        decorated,
        # the - before the first element sorts descending
        key=lambda k: -k[0]
    )
    freqWord = sorted_tuples[0][1]
    freqCount = count[freqWord]

    output +=  f'The other word "{freqWord}" '
    output += f'occurs {freqCount} '
    output += 'time.' if freqCount == 1 else 'times.'

    return (freqWord, output)

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-255/packy-anderson

Perl Weekly Challenge: Reverse Vowels by the Power of Three

This week’s musical theme: Power of Two by the Indigo Girls. Listen to the song one-and-a-half times and you’ll have the power of three, right?

Onward to Perl Weekly Challenge 254!

Task 1: Three Power

You are given a positive integer, $n.

Write a script to return true if the given integer is a power of three otherwise return false.

Example 1

Input: $n = 27
Output: true

27 = 3 ^ 3

Example 2

Input: $n = 0
Output: true

0 = 0 ^ 3

Example 3

Input: $n = 6
Output: false

Approach

Was it really three weeks ago that I last used recursion? Huh. Anyway, I’m going to have a function that takes two parameters, $n and a number to raise to the power of three, $pow. Initially, I call it with $pow = 0. If $n == $pow ^ 3, we return true. If $n < $pow ^ 3, we return false (because the number is larger than the last power of three, but smaller than this one). Otherwise, we return the value returned by calling the function again with $pow + 1. Eventually, we’ll match one of the first two conditions and return either true or false.

Raku

By using a default value for the second parameter, I can call isAPowerOfThree($n) to begin with, and let the recursive calls pass the numbers that get raised to the power of three.

sub isAPowerOfThree($n, $pow = 0) {
  if ($n == $pow ** 3) {
    return 'true';
  }
  elsif ($n < $pow ** 3) {
    return 'false';
  }
  return isAPowerOfThree($n, $pow + 1);
}

View the entire Raku script for this task on GitHub.

Perl

Since Perl’s function signatures (the default since Perl 5.36) allow for default values the same way Raku does, we don’t have to change anything except the string concatenation operator in my solution() function (shown in the full solution). But if I wanted to be compatible back to Perl 5.10, I could write it this way.

sub isAPowerOfThree {
  my $n   = shift;
  my $pow = shift() // 0;

  if ($n == $pow ** 3) {
    return 'true';
  }
  elsif ($n < $pow ** 3) {
    return 'false';
  }
  return isAPowerOfThree($n, $pow + 1);
}

View the entire Perl script for this task on GitHub.

Python

For Python, I didn’t have to adjust the logic at all, only the syntax.

def isAPowerOfThree(n, pow = 0):
    if n == pow ** 3:
        return 'true'
    elif n < pow ** 3:
        return 'false'
    return isAPowerOfThree(n, pow + 1)

View the entire Python script for this task on GitHub.


Task 2: Reverse Vowels

You are given a string, $s.

Write a script to reverse all the vowels (a, e, i, o, u) in the given string.

Example 1

Input: $s = "Raku"
Output: "Ruka"

Example 2

Input: $s = "Perl"
Output: "Perl"

Example 3

Input: $s = "Julia"
Output: "Jaliu"

Example 4

Input: $s = "Uiua"
Output: "Auiu"

Approach

Ah, this one requires a bit more thought. We want to extract the vowels from the string into a list, but maintain the positions of the vowels in the string. We then reverse the list and put the vowels back into the string. One thing to note: the output string is title-cased.

Raku

I realized that I didn’t need to remove the vowels from the string, so I could use the vowels themselves as the placeholders.

sub reverseVowels($s) {
  # split string into letters
  my @letters = $s.split('', :skip-empty);

  # find the vowels
  my @vowels = @letters.grep({ /:i<[aeiou]>/ });

  # replace each vowel in reverse order, converting
  # any uppercase letters to lowercase
  for 0 .. @letters.end -> $i {
    if (@letters[$i] ~~ /:i<[aeiou]>/) {
      @letters[$i] = @vowels.pop.lc;
    }
  }

  # rejoin the array as a string, title casing it
  return tc(@letters.join(''));
}

View the entire Raku script for this task on GitHub.

Perl

sub reverseVowels($s) {
  # split string into letters
  my @letters = split(//, $s);

  # find the vowels
  my @vowels = grep { /[aeiou]/i } @letters;

  # replace each vowel in reverse order, converting
  # any uppercase letters to lowercase
  foreach my $i ( 0 .. $#letters) {
    if ($letters[$i] =~ /[aeiou]/i) {
      $letters[$i] = lc(pop @vowels);
    }
  }

  # rejoin the array as a string, title casing it
  return ucfirst(join('', @letters));
}

View the entire Perl script for this task on GitHub.

Python

import re

is_vowel = re.compile('[aeiou]', re.IGNORECASE)

def reverseVowels(s):
    # split string into letters
    letters = list(s)

    # find the vowels
    vowels = [ v for v in letters if is_vowel.match(v) ]

    # replace each vowel in reverse order, converting
    # any uppercase letters to lowercase
    for i in range(len(s)):
        if is_vowel.match(letters[i]):
            letters[i] = vowels.pop(-1)

    # rejoin the array as a string, title casing it
    return ''.join(letters).title()

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-254/packy-anderson

Perl Weekly Challenge: The Weakest Split

I don’t know, this week there’s no lyrics that the problems are inspiring. The closest I can get is Shout by The Isley Brothers, so let’s go with that…

Let’s dive into Perl Weekly Challenge 253!

Task 1: Split Strings

You are given an array of strings and a character separator.

Write a script to return all words separated by the given character excluding empty string.

Example 1

Input: @words = ("one.two.three","four.five","six")
       $separator = "."
Output: "one","two","three","four","five","six"

Example 2

Input: @words = ("$perl$$", "$$raku$")
       $separator = "$"
Output: "perl","raku"

Approach

This is fairly straightforward: split strings on the separator, filter out empty strings.

Raku

The :skip-empty named parameter handles filtering out the empty strings.

sub splitOnSeparator(@words, $separator) {
  my @output;
  for @words -> $str {
    @output.append( $str.split($separator, :skip-empty) );
  }
  return @output;
}

View the entire Raku script for this task on GitHub.

Perl

In Perl, we need to use the quotemeta function (or \Q within the regular expression, like I did) to escape any metacharacters in the separator (which both . and $ are). And because the split doesn’t have a parameter to skip empty results, we have to filter them out by grepping out strings that have match a regular expression anchored at the beginning and end with no characters in-between.

sub splitOnSeparator($separator, @words) {
  my @output;
  foreach my $str ( @words ) {
    push @output, grep { !/^$/ } split(/\Q$separator/, $str);
  }
  return @output;
}

View the entire Perl script for this task on GitHub.

Python

I keep forgetting about Python’s extend method on lists.

def splitOnSeparator(words, separator):
    output = []
    for str in words:
        output.extend(
            list(filter(lambda w: w>"", str.split(separator)))
        )
    return output

View the entire Python script for this task on GitHub.


Task 2: Weakest Row

You are given an m x n binary matrix i.e. only 0 and 1 where 1 always appear before 0.

A row i is weaker than a row j if one of the following is true:

a) The number of 1s in row i is less than the number of 1s in row j.
b) Both rows have the same number of 1 and i < j.

Write a script to return the order of rows from weakest to strongest.

Example 1

Input: $matrix = [
                   [1, 1, 0, 0, 0],
                   [1, 1, 1, 1, 0],
                   [1, 0, 0, 0, 0],
                   [1, 1, 0, 0, 0],
                   [1, 1, 1, 1, 1]
                 ]
Output: (2, 0, 3, 1, 4)

The number of 1s in each row is:
- Row 0: 2
- Row 1: 4
- Row 2: 1
- Row 3: 2
- Row 4: 5

Example 2

Input: $matrix = [
                   [1, 0, 0, 0],
                   [1, 1, 1, 1],
                   [1, 0, 0, 0],
                   [1, 0, 0, 0]
                 ]
Output: (0, 2, 3, 1)

The number of 1s in each row is:
- Row 0: 1
- Row 1: 4
- Row 2: 1
- Row 3: 1

Approach

This feels like a map then sort: loop over the matrix, counting the 1s in each row (though, because it’s defined to be just 1s and 0s, we can just sum the row). Then do a sort of the indices based on that count. In fact, we’ve done a sort like this before, in the Most Frequent Letter Pair task for PWC 247.

Raku

I’m borrowing my matrix printing code from PWC 248. Once again, I have to shout out to the Raku List method .end.

sub weakestRows(@matrix) {
  my @oneCount = @matrix.map({ $_.sum });
  my @weakest = (0 .. @oneCount.end).sort: {
    # sort by count first
    @oneCount[$^a] <=> @oneCount[$^b]
    ||
    # then by index order
    $^a <=> $^b
  };

  return @weakest;
}

View the entire Raku script for this task on GitHub.

Perl

Just the usual Raku-to-Perl changes.

use List::Util qw( sum );

sub weakestRows(@matrix) {
  my @oneCount = map { sum(@$_) } @matrix;
  my @weakest = sort {
    # sort by count first
    $oneCount[$a] <=> $oneCount[$b]
    ||
    # then by index order
    $a cmp $b
  } (0 .. $#oneCount);

  return @weakest;
}

View the entire Perl script for this task on GitHub.

Python

And, just like I did back in PWC 247, I’d like to point out that Python’s Decorate-Sort-Undecorate idiom is really just a Schwartzian Transformation.

def weakestRows(matrix):
    oneCount = [ sum(row) for row in matrix ]
    # sort the rows by their oneCount values
    # use the Decorate-Sort-Undecorate idiom
    # to convert the dict into a list
    # https://docs.python.org/3/howto/sorting.html#decorate-sort-undecorate
    decorated = [
        (oneCount[i], i) for i in range(len(oneCount))
    ]
    sorted_tuples = sorted(
        decorated,
        # the - before the first element sorts descending
        key=lambda k: (k[0], k[1])
    )
    weakest = [ t[1] for t in sorted_tuples ]
    return weakest

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-253/packy-anderson

Perl Weekly Challenge: Sum Enchanted Evening

Sum enchanted evening… you’ll see a special number
You’ll see a special number, and you’ll sum its squares.
And somehow you know, you know even then,
That somehow you’re working on Perl Weekly Challenge 252!

Task 1: Special Numbers

You are given an array of integers, @ints.

Write a script to find the sum of the squares of all special elements of the given array.

An element $int[i] of @ints is called special if i divides n, i.e. n % i == 0.
Where n is the length of the given array. Also the array is 1-indexed for the task.

Example 1

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

There are exactly 3 special elements in the given array:
$ints[1] since 1 divides 4,
$ints[2] since 2 divides 4, and
$ints[4] since 4 divides 4.

Hence, the sum of the squares of all special elements of given array:
1 * 1 + 2 * 2 + 4 * 4 = 21.

Example 2

Input: @ints = (2, 7, 1, 19, 18, 3)
Output: 63

There are exactly 4 special elements in the given array:
$ints[1] since 1 divides 6,
$ints[2] since 2 divides 6,
$ints[3] since 3 divides 6, and
$ints[6] since 6 divides 6.

Hence, the sum of the squares of all special elements of given array:
2 * 2 + 7 * 7 + 1 * 1 + 3 * 3 = 63

Approach

Well, if you’ve been following me, you know I’m going to break this up into smaller functions. I’m also borrowing code I wrote for Perl Weekly Challenge 229.

Raku

sub specialElementIndices($n) {
  return (1 .. $n).grep({ $n % $_ == 0 });
}

# code borrowed from my code for PWC 229
sub english_list ( *@list ) {
  # given a list, join it in a way that makes sense
  # to english speakers
  my $last = @list.pop(); # last element in array
  if (@list == 0) {
    # using an array in a scalar context returns
    # the number of elements in the array

    # there was only one element in the list
    return $last;
  }
  my $joined = @list.join(qq{,\n});
  if (@list > 1) {
    # if there's more than element, add an Oxford comma
    $joined ~= q{,};
  }
  return "$joined and\n$last";
}

sub specialNumberSquareSum(@ints) {
  my $n = @ints.elems;

  # find the list of indices for "special" numbers
  my @specialIndices = specialElementIndices($n);
  my $count = @specialIndices.elems;
  my @explain_list = @specialIndices.map({
    "\$ints[$_] since $_ divides $n"
  });
  my $explain = "There are exactly $count special elements "
    ~ "in the given array:\n" ~ english_list(@explain_list);

  # find the special numbers themselves
  my @special = @specialIndices.map({ @ints[$_ - 1] });

  # find the sum of the squares
  my $sum = @special.map({ $_ ** 2 }).sum;

  $explain ~= "\nHence, the sum of the squares of all special "
    ~ "elements of given array:\n"
    ~ @special.map({ "$_ * $_" }).join(' + ')
    ~ " = " ~ $sum;

  return (
    $sum,
    $explain
  );
}

View the entire Raku script for this task on GitHub.

Perl

Nothing really changes in the Perl implementation except the normal syntax changes from Raku to Perl…

use List::Util qw( sum );

sub specialElementIndices($n) {
  return grep { $n % $_ == 0 } 1 .. $n;
}

sub english_list ( @list ) {
  # given a list, join it in a way that makes sense
  # to english speakers
  my $last = pop @list; # last element in array
  if (@list == 0) {
    # using an array in a scalar context returns
    # the number of elements in the array

    # there was only one element in the list
    return $last;
  }
  my $joined = join qq{,\n}, @list;
  if (@list > 1) {
    # if there's more than element, add an Oxford comma
    $joined .= q{,};
  }
  return "$joined and\n$last";
}

sub specialNumberSquareSum(@ints) {
  # in scalar context, an array evaluates to the number
  # of elements in the array
  my $n = @ints;

  # find the list of indices for "special" numbers
  my @specialIndices = specialElementIndices($n);
  my $count = @specialIndices;
  my @explain_list = map {
    "\$ints[$_] since $_ divides $n"
  } @specialIndices;
  my $explain = "There are exactly $count special elements "
    . "in the given array:\n" . english_list(@explain_list);

  # find the special numbers themselves
  my @special = map { $ints[$_ - 1] } @specialIndices;

  # find the sum of the squares
  my $sum = sum( map { $_ ** 2 } @special);

  $explain .= "\nHence, the sum of the squares of all special "
    . "elements of given array:\n"
    . join(' + ', map { "$_ * $_" } @special)
    . " = " . $sum;

  return (
    $sum,
    $explain
  );
}

View the entire Perl script for this task on GitHub.

Python

Mostly what tripped me up going from Raku to Python was the lack of sigils meaning I couldn’t give variables the same names as built-in functions.

def specialElementIndices(n):
    return list( filter(lambda x: n % x == 0, range(1, n+1)) )

def english_list (strlist):
    # given a list, join it in a way that makes sense
    # to english speakers
    last = strlist.pop(-1) # last element in array
    if (len(strlist) == 0):
        # using an array in a scalar context returns
        # the number of elements in the array

        # there was only one element in the list
        return last

    joined = ',\n'.join(strlist)
    if (len(strlist) > 1):
        # if there's more than element, add an Oxford comma
        joined += ','

    return f'{joined} and\n{last}'

def specialNumberSquareSum(ints):
    n = len(ints)

    # find the list of indices for "special" numbers
    specialIndices = specialElementIndices(n)
    count = len(specialIndices)
    explain_list = [
        f"$ints[{x}] since {x} divides {n}"
        for x in specialIndices
    ] 
    explain = (
        "There are exactly $count special elements " +
        "in the given array:\n" + english_list(explain_list)
    )

    # find the special numbers themselves
    special = [ ints[x - 1] for x in specialIndices ]

    # find the sum of the squares
    sumval = sum([ x ** 2 for x in special ])

    explain += '\nHence, the sum of the squares of all special '
    explain += 'elements of given array:\n'
    explain += ' + '.join(map(lambda x: f'{x} * {x}', special))
    explain += f' = {sumval}'

    return (
        sumval,
        explain
    )

View the entire Python script for this task on GitHub.


Task 2: Unique Sum Zero

You are given an integer, $n.

Write a script to find an array containing $n unique integers such that they add up to zero.

Example 1

Input: $n = 5
Output: (-7, -1, 1, 3, 4)

Two other possible solutions could be as below:
(-5, -1, 1, 2, 3) and (-3, -1, 2, -2, 4).

Example 2

Input: $n = 3
Output: (-1, 0, 1)

Example 3

Input: $n = 1
Output: (0)

Approach

This one is a little more challenging. Looking at the examples, I can see that when $n is 1, the array has to be ( 0 ). When $n is 3, the array needs to be ( -x, 0, x ) where x is some positive integer. We can extrapolate that when $n is 2, array needs to be ( -x, x ) where x is some positive integer. As $n gets larger, the number of possible arrays gets larger: the example output arrays have the form ( -(x+y), -z, z, x, y ) and ( -x, -y, z, -z, x+y ).

Rather than generate permutations of $n unique integers and check them to see if they sum to 0, I think I’m going to take the approach of generating a list I know will sum to 0 ahead of time:

  • If $n is odd, push 0 onto the list and decrement $n by one
  • set $x to 1
  • if $n is still greater than 0, push -$x and $x onto the list, then decrement $n by two and increment $x by one
  • repeat the last step until $n is equal to 0

With this algorithm, my output winds up being:

Example 1:
Input: $n = 5
Output: (-2, -1, 0, 1, 2)

Example 2:
Input: $n = 3
Output: (-1, 0, 1)

Example 3:
Input: $n = 1
Output: (0)

But for $n = 2, the output would be (-1, 1), and for $n = 4, the output would be
(-2, -1, 1, 2).

Raku

Because subroutine parameters are read-only (and you can mark them read-write with is rw only if what’s being passed into them is a writable object, not a numeric constant, I’m copying the value from the parameter to a working variable.

sub uniqueSumZero($input) {
  my $n = $input;
  my @list;
  my $x = 1;
  while ($n > 0) {
    if ($n % 2 == 1) { # $n is odd
      @list.push(0);
      $n -= 1;
    }
    else { # $n is even
      @list.append($x * -1, $x);
      $x += 1;
      $n -= 2;
    }
  }
  return @list.sort;
}

View the entire Raku script for this task on GitHub.

Perl

Perl, however, doesn’t have the problem with the subroutine parameter being read-only, so I can modify $n to my heart’s content.

sub uniqueSumZero($n) {
  my @list;
  my $x = 1;
  while ($n > 0) {
    if ($n % 2 == 1) { # $n is odd
      push @list, 0;
      $n--;
    }
    else { # $n is even
      push @list, $x * -1, $x;
      $x++;
      $n -= 2;
    }
  }
  return sort { $a <=> $b } @list;
}

View the entire Perl script for this task on GitHub.

Python

def uniqueSumZero(n):
    zero_sum_list = []
    x = 1
    while n > 0:
        if (n % 2 == 1): # n is odd
            zero_sum_list.append(0)
            n -= 1
        else: # n is even
            zero_sum_list.append(x * -1)
            zero_sum_list.append(x)
            x += 1
            n -= 2
    zero_sum_list.sort()
    return zero_sum_list

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-252/packy-anderson

Perl Weekly Challenge: Luck Concatenate Numbers Tonight!

Tonight’s musical mood: Luck Be A Lady!

Onward to Perl Weekly Challenge 251!


Task 1: Concatenation Value

You are given an array of integers, @ints.

Write a script to find the concatenation value of the given array.

The concatenation of two numbers is the number formed by concatenating their numerals.

For example, the concatenation of 10, 21 is 1021.
The concatenation value of @ints is initially equal to 0.
Perform this operation until @ints becomes empty:

If there exists more than one number in @ints, pick the first element and last element in @ints respectively and add the value of their concatenation to the concatenation value of @ints, then delete the first and last element from @ints.

If one element exists, add its value to the concatenation value of @ints, then delete it.

Example 1

Input: @ints = (6, 12, 25, 1)
Output: 1286

1st operation: concatenation of 6 and 1 is 61
2nd operation: concatenation of 12 and 25 is 1225

Concatenation Value => 61 + 1225 => 1286

Example 2

Input: @ints = (10, 7, 31, 5, 2, 2)
Output: 489

1st operation: concatenation of 10 and 2 is 102
2nd operation: concatenation of 7 and 2 is 72
3rd operation: concatenation of 31 and 5 is 315

Concatenation Value => 102 + 72 + 315 => 489

Example 3

Input: @ints = (1, 2, 10)
Output: 112

1st operation: concatenation of 1 and 10 is 110
2nd operation: only element left is 2

Concatenation Value => 110 + 2 => 112

Approach

I know there’s an iterative approach that’s probably more efficient, but when I saw the definition of how to do calculate the concatenation value of an array of integers, my brain flew back to being a 15-year-old learning how to program, and discovering the wonders of… recursion.

Edit: It occurs to me that seeing Niklaus Wirth’ obituary probably also inspired me, because part and parcel of my discovering recursion when I was 15 was learning Pascal, my favorite programming language before Perl (also the second or third (I don’t remember if it was BASIC, Pascal, then COBOL, or BASIC, COBOL, then Pascal)).

Raku

sub concatenationValue(@ints) {
  return 0        if @ints.elems == 0; # no elements
  return @ints[0] if @ints.elems == 1; # one element

  my $first = @ints.shift; # first element
  my $last  = @ints.pop;   # last element
  my $concat = "$first$last".Int; # concatenate and convert

  return $concat + concatenationValue(@ints);
}

View the entire Raku script for this task on GitHub.

Perl

Once again I got to trot out the “adding 0 to a string to make it clear I’m converting it into a numeric value” trick, and I also got to show how evaluating an array in scalar context (the @ints == 0 and @ints == 1) yields the number of elements in the array.

sub concatenationValue(@ints) {
  return 0        if @ints == 0; # no elements
  return $ints[0] if @ints == 1; # one element

  my $first = shift @ints; # first element
  my $last  = pop @ints;   # last element
  my $concat = "$first$last"+0; # concatenate and convert

  return $concat + concatenationValue(@ints);
}

View the entire Perl script for this task on GitHub.

Python

The only thing to point out here is Python’s pop method, which removes the element at the position specified by the parameter. If the parameter is omitted, it removes and returns the last value in the array, but since I had to specify position 0 to get the first element, I figured it was symmetrical to specify -1 to explicitly get the last value.

def concatenationValue(ints):
    if len(ints) == 0: # no elements
        return 0
    if len(ints) == 1: # one element
        return ints[0]

    first = ints.pop(0);  # first element
    last  = ints.pop(-1); # last element
    concat = int(f"{first}{last}") # concatenate and convert

    return concat + concatenationValue(ints)

View the entire Python script for this task on GitHub.


Task 2: Lucky Numbers

You are given a m x n matrix of distinct numbers.

Write a script to return the lucky number, if there is one, or -1 if not.

A lucky number is an element of the matrix such that it is
the minimum element in its row and maximum in its column.

Example 1

Input: $matrix = [ [ 3,  7,  8],
                   [ 9, 11, 13],
                   [15, 16, 17] ];
Output: 15

15 is the only lucky number since it is the minimum in its row
and the maximum in its column.

Example 2

Input: $matrix = [ [ 1, 10,  4,  2],
                   [ 9,  3,  8,  7],
                   [15, 16, 17, 12] ];
Output: 12

Example 3

Input: $matrix = [ [7 ,8],
                   [1 ,2] ];
Output: 7

Approach

Since the definition of the problem states that the numbers are distinct (the same number will not appear twice in the matrix), we can break this down into two problems: find the minimum elements in each row, and find the maximum elements in each column. If a value appears in both lists, we have our lucky number.

Getting the minimum in each row is easy, but getting the max in each column is a little more work; what I’m going to do is rotate the matrix so the rows are now columns and the columns are now rows, and just take the max value from what are now rows in the matrix.

Raku

sub maxCols(@matrix) {
  my @rotated; # rotate cols to rows
  for @matrix -> @row {
    for @row.kv -> $k, $v {
      @rotated[$k].push($v);
    }
  }
  # return the max of the now rows!
  return @rotated.map({ $_.max() });
}

sub luckyNumber(@matrix) {
  my @minRows = @matrix.map({ $_.min() });
  my @maxCols = maxCols(@matrix);
  return ( @minRows (&) @maxCols ) // -1;
}

View the entire Raku script for this task on GitHub.

Perl

Perl doesn’t have built-in min, max, or intersection operators, so we need to pull them in from the CPAN modules Array::Utils and List::Util (though List::Util is in the core).

use Array::Utils qw( intersect );
use List::Util qw( min max );

sub maxCols(@matrix) {
  my @rotated; # rotate cols to rows
  foreach my $row ( @matrix ) {
    foreach my $k ( 0 .. $#{$row} ) {
      my $v = $row->[$k];
      push @{$rotated[$k]}, $v;
    }
  }
  # return the max of the now rows!
  return map { max( @$_ ) } @rotated;
}

sub luckyNumber(@matrix) {
  my @minRows = map { min( @$_ ) } @matrix;
  my @maxCols = maxCols(@matrix);
  # intersect() returns an array, so get the first element
  return (intersect( @minRows, @maxCols ))[0] // -1;

View the entire Perl script for this task on GitHub.

Python

For my Python solution, I was able to do it entirely using built-in functions.

def maxCols(matrix):
    # initialize rotated with empty row for each column
    rotated = [ [] for col in matrix[0] ]
    for row in matrix:
        for k, v in enumerate(row):
            rotated[k].append(v)
    # return the max of the now rows!
    return [ max(row) for row in rotated ]

def luckyNumber(matrix):
    mRows = [ min(row) for row in matrix ]
    mCols = maxCols(matrix)
    intersection = list( set(mRows) & set(mCols) )
    if intersection:
        return intersection[0]
    else:
        return -1

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-251/packy-anderson

Two-Hundred Fifty Perl Weekly Challenges! Two-Hundred Fifty problems so clear…

Yeah, I’m trying to get back to music for the theme of the post, and for some reason the number 250 made me think of a song from Rent

If PWC runs for 525,600 weeks, that will be over ten thousand years. I can dream that we’re still using Perl or Raku that long. Anyway, onward to Perl Weekly Challenge 250!


Task 1: Smallest Index

You are given an array of integers, @ints.

Write a script to find the smallest index i such that i mod 10 == $ints[i] otherwise return -1.

Example 1

Input: @ints = (0, 1, 2)
Output: 0

i=0: 0 mod 10 = 0 == $ints[0].
i=1: 1 mod 10 = 1 == $ints[1].
i=2: 2 mod 10 = 2 == $ints[2].
All indices have i mod 10 == $ints[i], so we return the smallest index 0.

Example 2

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

i=0: 0 mod 10 = 0 != $ints[0].
i=1: 1 mod 10 = 1 != $ints[1].
i=2: 2 mod 10 = 2 == $ints[2].
i=3: 3 mod 10 = 3 != $ints[3].
2 is the only index which has i mod 10 == $ints[i].

Example 3

Input: @ints = (1, 2, 3, 4, 5, 6, 7, 8, 9, 0)
Output: -1
Explanation: No index satisfies i mod 10 == $ints[i].

Approach

When I was thinking about this problem, I found myself asking “Why are we doing i mod 10? So the list can’t be more than 10 elements long?” No, I realized: so the elements are only single digits. Take a look at example 3: if we line them up so we can see what the indices are next to the values, we can see that none of the values match the indices.

ints[0] = 1
ints[1] = 2
ints[2] = 3
ints[3] = 4
ints[4] = 5
ints[5] = 6
ints[6] = 7
ints[7] = 8
ints[8] = 9
ints[9] = 0

But what if we inserted another value before the end? What if the end looked like this?

ints[8]  = 9
ints[9]  = 8
ints[10] = 0

Suddenly, we’d have i mod 10 == 0, which would be the value of the final element. This also makes the comparison slightly more interesting than “find the minimal value for i where i = ints[i]“.

Initially, I was leaning towards using a map to generate all the possible cases where i = ints[i] and then use min to get the smallest one, but a voice in my head said “You’re looping over all the values anyway… just find the first one and exit when you find it. It’s faster.”

Raku

sub smallestIndex(@ints) {
  for 0 .. @ints.end -> $i {
    return $i if ($i mod 10) == @ints[$i];
  }
  return -1;
}

View the entire Raku script for this task on GitHub.

Perl

Again, the Perl version is almost identical to the Raku version: the modulo operator is % instead of mod, the for loop is structured differently, and we have to use $ as the sigil to access individual array elements.

sub smallestIndex(@ints) {
  foreach my $i ( 0 .. $#ints ) {
    return $i if ($i % 10) == $ints[$i];
  }
  return -1;
}

View the entire Perl script for this task on GitHub.

Python

As always, I need to remind myself that a) Python’s range function goes up to but does not include the largest value, and b) if you only pass a single value, the range starts at 0. So range(4) returns the range 0, 1, 2, 3.

def smallestIndex(ints):
    for i in range(len(ints)):
        if (i % 10) == ints[i]:
            return i
    return -1

View the entire Python script for this task on GitHub.


Task 2: Alphanumeric String Value

You are given an array of alphanumeric strings.

Write a script to return the maximum value of alphanumeric string in the given array.

The value of alphanumeric string can be defined as

a) The numeric representation of the string in base 10 if it is made up of digits only.
b) otherwise the length of the string

Example 1

Input: @alphanumstr = ("perl", "2", "000", "python", "r4ku")
Output: 6

"perl" consists of letters only so the value is 4.
"2" is digits only so the value is 2.
"000" is digits only so the value is 0.
"python" consists of letters so the value is 6.
"r4ku" consists of letters and digits so the value is 4.

Example 2

Input: @alphanumstr = ("001", "1", "000", "0001")
Output: 1

Approach

This could probably be done in a single loop, but I want to make things clearer and easier to read, so I’m breaking it out into two parts: a function that, given a string, returns its value according to the criteria above, and then a map that calls that function for each string in an array to generate an array of string values, and we can use max to find the largest value. See? I got to use my map!

Raku

sub alphanumValue($str) {
  if ($str ~~ /^\d+$/) {
    return Int($str);
  }
  return $str.chars;
}

sub maxAlphanumValue(@alphanumstr) {
  my @values = @alphanumstr.map({ alphanumValue($_) });
  return @values.max;
}

View the entire Raku script for this task on GitHub.

Perl

Perl doesn’t have a max function built in, so I’m using the one everybody uses in List::Util. Also, I’m using the old trick of adding 0 to a string to convert it explicitly into a numeric value.

use List::Util qw( max );

sub alphanumValue($str) {
  if ($str =~ /^\d+$/) {
    return $str + 0;
  }
  return length($str);
}

sub maxAlphanumValue(@alphanumstr) {
  my @values = map { alphanumValue($_) } @alphanumstr;
  return max(@values);
}

View the entire Perl script for this task on GitHub.

Python

For the Python solution, I’m pre-compiling the regular expression once outside the alphanumValue function. I could have done that in Raku or Perl for a minor performance gain, but I’m doing it here because the cleanest way to do the match is to compile the regex to an re object and then call .match() on that object with the string. Since we needed to compile it separately from the match call, it made sense to put that compile outside the function so it’s only done once. In Raku and Perl, the compiling takes place automagically, so doing it separately doesn’t look as clean.

import re

is_numeric = re.compile('^\d+$')

def alphanumValue(strval):
    if (is_numeric.match(strval)):
        return int(strval)
    return len(strval)

def maxAlphanumValue(alphanumstr):
    values = [ alphanumValue(x) for x in alphanumstr ]
    return max(values)

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-250/packy-anderson

Perl Weekly Challenge: Stringy DI and Paired Equals

I dunno. I saw “DI string” and thought of Lady Di. It’s Christmas. I’m full of yummy Christmas food and not firing on all cylinders.

Onward to Perl Weekly Challenge 249!

Task 1: Equal Pairs

You are given an array of integers with even number of elements.

Write a script to divide the given array into equal pairs such that:

a) Each element belongs to exactly one pair.
b) The elements present in a pair are equal.

Example 1

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

There are 6 elements in @ints.
They should be divided into 6 / 2 = 3 pairs.
@ints is divided into the pairs (2, 2), (3, 3), and (2, 2) satisfying all the conditions.

Example 2

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

There is no way to divide @ints 2 pairs such that the pairs satisfy every condition.

Approach

Ok, this reminds me of PWC 237’s Task 2, where we wound up counting the integers in our input list and subtracting them from that count instead of pulling them off a list. In this case, I think a similar approach would work: loop over the input list and count up how many of each integer we have. If we don’t have an even number of each integer, we can fail immediately because we can’t satisfy condition b. Then we pull integers off the count by twos.

Raku

sub equalPairs(@ints) {
  my @pairs;
  my %num_count;
  # count how many of each int we have
  for @ints -> $num {
    %num_count{$num}++;
  }
  # first, make sure we have even numbers of each integer
  for %num_count.kv -> $k, $v {
    next if $v % 2 == 0; # it's even, we can make pairs
    return @pairs; # we have an odd number, can't make pairs
  }
  # now make pairs from those integers
  for %num_count.kv -> $k, $v {
    my $count = $v; # the values $k, $v are read-only
    while ($count > 0) {
      @pairs.push( [$k, $k] );
      $count -= 2;
    }
  }
  return @pairs;
}

View the entire Raku script for this task on GitHub.

Perl

sub equalPairs(@ints) {
  my @pairs;
  my %num_count;
  # count how many of each int we have
  foreach my $num ( @ints ) {
    $num_count{$num}++;
  }
  # first, make sure we have even numbers of each integer
  foreach my $k ( keys %num_count ) {
    my $v = $num_count{$k};
    next if $v % 2 == 0; # it's even, we can make pairs
    return @pairs; # we have an odd number, can't make pairs
  }
  # now make pairs from those integers
  foreach my $k ( keys %num_count ) {
    my $count = $num_count{$k};
    while ($count > 0) {
      push @pairs, [$k, $k];
      $count -= 2;
    }
  }
  return @pairs;
}

View the entire Perl script for this task on GitHub.

Python

from collections import Counter

def equalPairs(nums):
    pairs = []
    num_count = Counter()
    # count how many of each int we have
    for num in nums:
        num_count[num] += 1

    # first, make sure we have even numbers of each integer
    for k, v in dict(num_count).items():
        if v % 2 == 0: # it's even, we can make pairs
            continue
        else:
            return pairs # we have an odd number, no pairs

    # now make pairs from those integers
    for k, v in dict(num_count).items():
        count = v # the values k, v are read-only
        while count > 0:
            pairs.append( [k, k] )
            count -= 2

    return pairs

View the entire Python script for this task on GitHub.


Task 2: DI String Match

You are given a string s, consisting of only the characters "D" and "I".

Find a permutation of the integers [0 .. length(s)] such that for each character s[i] in the string:

s[i] == 'I' ⇒ perm[i] < perm[i + 1]
s[i] == 'D' ⇒ perm[i] > perm[i + 1]

Example 1

Input: $str = "IDID"
Output: (0, 4, 1, 3, 2)

Example 2

Input: $str = "III"
Output: (0, 1, 2, 3)

Example 3

Input: $str = "DDI"
Output: (3, 2, 0, 1)

Approach

Again, this reminds me of PWC 237’s Task 2, this time because we sorted the integers so we could pull maximum and minimum integers off a list. In this case, the range 0 .. length(s) is sorted already, but we would take a similar approach to building the output permutation list: if the letter is D, we pull the maximum number off the end of the list, guaranteeing that it will be greater than anything that could come after it. If the letter is I, we pull the minimum number off the beginning of the list, guaranteeing that it will be less than anything that could come after it.

Raku

sub diStringMatch($str) {
  my @permutation;
  # first, generate the list of integers
  # we're making permutations of
  my @nums = 0 .. $str.chars;
  # now let's generate our permutation
  for $str.split('', :skip-empty) -> $c {
    if ($c eq 'D') {
      # take the largest number available
      @permutation.push( @nums.pop() );
    }
    else {
      # take the smallest number available
      @permutation.push( @nums.shift() );
    }
  }
  # add last remaining number
  @permutation.push( @nums[0] );

  return @permutation;
}

View the entire Raku script for this task on GitHub.

Perl

sub diStringMatch($str) {
  my @permutation;
  # first, generate the list of integers
  # we're making permutations of
  my @nums = 0 .. length($str);
  # now let's generate our permutation
  foreach my $c ( split(//, $str) ) {
    if ($c eq 'D') {
      # take the largest number available
      push @permutation, pop(@nums);
    }
    else {
      # take the smallest number available
      push @permutation, shift(@nums);
    }
  }
  # add last remaining number
  push @permutation, $nums[0];

  return @permutation;
}

View the entire Perl script for this task on GitHub.

Python

def diStringMatch(str):
    permutation = []
    # first, generate the list of integers
    # we're making permutations of
    nums = list(range(len(str)+1))
    # now let's generate our permutation
    for c in str:
        if c == 'D':
            # take the largest number available
            permutation.append( nums.pop(-1) )
        else:
            # take the smallest number available
            permutation.append( nums.pop(0) )
    # add last remaining number
    permutation.append( nums[0] )

    return permutation

View the entire Python script for this task on GitHub.


Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-249/packy-anderson