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