Perl Weekly Challenge: Common, but Unequal, Triplet Characters

Ok, trying to be creative with my title for this week’s Perl Weekly Challenge 234 blog title is probably a miss. But it’s the effort that counts!


Task 1: Common Characters

You are given an array of words made up of alphabetic characters only.
Write a script to return all alphabetic characters that show up in all words including duplicates.

Example 1

Input: @words = ("java", "javascript", "julia")
Output: ("j", "a")

Example 2

Input: @words = ("bella", "label", "roller")
Output: ("e", "l", "l")

Example 3

Input: @words = ("cool", "lock", "cook")
Output: ("c", "o")

So, looking at this problem, I see that in addition to preserving duplicated characters, the sample output (I’m glad Mohammed fixed the typo “Ouput” that’s been persistent in the past few weeks) is preserving the order of the characters based on the first word in the input list.

Since I’m looking for a new coding gig, I’ve been taking some coding tests, and one of the strategies the preparations for coding tests encourages is to look for patterns in the data once you’ve done an initial pass over it. One of the things I notice in this task is that it feels like a combination of the two tasks from last the challenge. We’re splitting the words into characters, and we’re counting the frequency of those characters. Any character that has a frequency of 1 or greater in each word occurs once, any character that has a frequency of 2 or greater in each word occurs twice, and so on.

This will get us the frequencies of the characters for each word:

sub charFrequency {
  my $word = shift;
  my %freq;
  foreach my $c ( split //, $word ) {
    $freq{$c}++;
  }
  return \%freq; # return a hash REFERENCE
}

Then we need to find the common characters:

sub commonCharacters {
  my @words = @_;
  my @freq = map { charFrequency($_) } @words;
  # grab the character frequency map for the first word
  my $first = shift @freq;
  # now check the characters in the first word against
  # the characters in all the subsequent words
  foreach my $subsequent ( @freq ) {
    foreach my $c ( keys %$first ) {
      if (! exists $subsequent->{$c}) {
        # this character isn't in subsequent words,
        # so let's remove it from the frequency map
        # of the first word
        delete $first->{$c};
      }
      else {
        # the character IS in subsequent words,
        # so let's set the frequency count to be
        # the minimum count found in those words
        $first->{$c} = min($first->{$c}, $subsequent->{$c});
      }
    }
  }
}

But that’s not enough to satisfy the problem: we need to output the characters in the order they appear in the first word. So let’s add to this function:

sub commonCharacters {
  ...
  # now we generate a list of characters in the order they
  # appear in the first word
  my @output;
  # once again, loop over the characters in the first word
  foreach my $c ( split //, $words[0] ) {
    next unless exists $first->{$c};
    if ($first->{$c} > 1) {
      # there's more than one occurence, so let's decrement
      # the count for the next time through the loop
      $first->{$c}--;
    }
    else {
      # there is only one occurence left, so remove the
      # character
      delete $first->{$c};
    }
    push @output, $c;
  }
  return @output;
}

Which, as an entire script, looks like this:

#!/usr/bin/env perl

use v5.38;

use List::Util qw( min );

sub charFrequency {
  my $word = shift;
  my %freq;
  foreach my $c ( split //, $word ) {
    $freq{$c}++;
  }
  return \%freq; # return a hash REFERENCE
}

sub commonCharacters {
  my @words = @_;
  my @freq = map { charFrequency($_) } @words;
  # grab the character frequency map for the first word
  my $first = shift @freq;
  # now check the characters in the first word against
  # the characters in all the subsequent words
  foreach my $subsequent ( @freq ) {
    foreach my $c ( keys %$first ) {
      if (! exists $subsequent->{$c}) {
        # this character isn't in subsequent words,
        # so let's remove it from the frequency map
        # of the first word
        delete $first->{$c};
      }
      else {
        # the character IS in subsequent words,
        # so let's set the frequency count to be
        # the minimum count found in those words
        $first->{$c} = min($first->{$c}, $subsequent->{$c});
      }
    }
  }

  # now we generate a list of characters in the order they
  # appear in the first word
  my @output;
  # once again, loop over the characters in the first word
  foreach my $c ( split //, $words[0] ) {
    next unless exists $first->{$c};
    if ($first->{$c} > 1) {
      # there's more than one occurence, so let's decrement
      # the count for the next time through the loop
      $first->{$c}--;
    }
    else {
      # there is only one occurence left, so remove the
      # character
      delete $first->{$c};
    }
    push @output, $c;
  }
  return @output;
}

sub solution {
  my @words = @_;
  say 'Input: @words = ("' . join('", "', @words) . '")';
  my @output = commonCharacters(@words);
  say 'Output: ("' . join('", "', @output) . '")';
}

say "Example 1:";
solution("java", "javascript", "julia");

say "\nExample 2:";
solution("bella", "label", "roller");

say "\nExample 3:";
solution("cool", "lock", "cook");

Things to note in the Raku solution:

  • When splitting a string into its component characters, make sure you add the :skip-empty parameter, otherwise you’ll get leading and trailing empty character entries.
  • Deleting elements from a hash isn’t a method call, it’s a Subscript Adverb, :delete.
  • Similarly, testing for the existence of an element is the Subscript Adverb :exists.
  • If you try to use the construction ! $hash{$key}:exists, you get the error Precedence issue with ! and :exists, perhaps you meant :!exists?
#!/usr/bin/env raku

use v6;

sub charFrequency(Str $word) {
  my %freq;
  for $word.split('', :skip-empty) -> $c {
    %freq{$c}++;
  }
  return %freq;
}

sub commonCharacters(*@words where ($_.all ~~ Str)) {
  my @freq = @words.map({ charFrequency($_) });
  # grab the character frequency map for the first word
  my $first = shift @freq;
  # now check the characters in the first word against
  # the characters in all the subsequent words
  for @freq -> $subsequent {
    for $first.keys() -> $c {
      if ($subsequent{$c}:!exists) {
        # this character isn't in subsequent words,
        # so let's remove it from the frequency map
        # of the first word
        $first{$c}:delete;
      }
      else {
        # the character IS in subsequent words,
        # so let's set the frequency count to be
        # the minimum count found in those words
        $first{$c} = min($first{$c}, $subsequent{$c});
      }
    }
  }

  # now we generate a list of characters in the order they
  # appear in the first word
  my @output;
  # once again, loop over the characters in the first word
  for @words[0].split('', :skip-empty) -> $c  {
    next unless $first{$c}:exists;
    if ($first{$c} > 1) {
      # there's more than one occurence, so let's decrement
      # the count for the next time through the loop
      $first{$c}--;
    }
    else {
      # there is only one occurence left, so remove the
      # character
      $first{$c}:delete;
    }
    push @output, $c;
  }
  return @output;
}

sub solution {
  my @words = @_;
  say 'Input: @words = ("' ~ @words.join('", "') ~ '")';
  my @output = commonCharacters(@words);
  say 'Output: ("' ~ @output.join('", "') ~ '")';
}

say "Example 1:";
solution("java", "javascript", "julia");

say "\nExample 2:";
solution("bella", "label", "roller");

say "\nExample 3:";
solution("cool", "lock", "cook");

Things to note in the Python solution:

  • You don’t shift elements off the beginning of an array, you pop the 0th element.
  • You don’t push elements onto the end of an array, you append them
  • There’s a Counter type in the collections module that lets you essentially autovivify elements in a dictionary by adding to them
  • In both Perl and Raku, the keys function/method for a hash returned a list that we were then able to iterate over, so we could remove elements from the hash while we were looping over it. Not so in Python: RuntimeError: dictionary changed size during iteration. This is easily handled by making a copy of the dictionary and looping over that.
#!/usr/bin/env python

from collections import Counter

def charFrequency(word):
    # https://docs.python.org/3/library/collections.html#counter-objects
    freq = Counter()
    for c in word:
        freq[c] += 1
    return freq

def commonCharacters(words):
    # get the character freqencies for each word
    freq = list(map(charFrequency, words))

    # grab the character frequency map for the first word
    first = freq.pop(0)

    # make a copy of the dictionary since we'll
    # be modifying it in the loop
    first_orig = dict(first)

    # now check the characters in the first word against
    # the characters in all the subsequent words
    for subsequent in freq:
        for c in first_orig:
            if c not in subsequent:
                # this character isn't in subsequent words,
                # so let's remove it from the frequency map
                # of the first word
                first.pop(c)
            else:
                # the character IS in subsequent words,
                # so let's set the frequency count to be
                # the minimum count found in those words
                first[c] = min(first[c], subsequent[c])

    # now we generate a list of characters in the order they
    # appear in the first word
    output = []
    # once again, loop over the characters in the first word
    for c in words[0]:
        if c not in first:
            continue
        if first[c] > 1:
            first[c] -= 1
        else:
            first.pop(c)
        output.append(c)
    return output

def solution(words):
    quoted = '"' + '", "'.join(words) + '"'
    print(f'Input: @words = ({quoted})')
    output = commonCharacters(words)
    quoted = '"' + '", "'.join(output) + '"'
    print(f'Output: ({quoted})')

print("Example 1:")
solution(["java", "javascript", "julia"])

print("\nExample 2:")
solution(["bella", "label", "roller"])

print("\nExample 3:")
solution(["cool", "lock", "cook"])

But this does go towards demonstrating something I’ve been saying for years: Python isn’t all that different than Perl. It just makes some different decisions and tries to cut down on TMTOWTDI as much as possible.


Task 2: Unequal Triplets

You are given an array of positive integers.

Write a script to find the number of triplets (i, j, k) that satisfies num[i] != num[j], num[j] != num[k] and num[k] != num[i].

Example 1

Input: @ints = (4, 4, 2, 4, 3)
Ouput: 3

(0, 2, 4) because 4 != 2 != 3
(1, 2, 4) because 4 != 2 != 3
(2, 3, 4) because 2 != 4 != 3

Example 2

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

Example 3

Input: @ints = (4, 7, 1, 10, 7, 4, 1, 1)
Output: 28

triplets of 1, 4, 7  = 3x2×2 = 12 combinations
triplets of 1, 4, 10 = 3×2×1 = 6  combinations
triplets of 4, 7, 10 = 2×2×1 = 4  combinations
triplets of 1, 7, 10 = 3x2x1 = 6 combinations

I think this time I’m going to break from my tradition of spitting out the exact explanatory text and just generate something that looks like the first example.

The meat of this solution is just a triple-nested loop:

sub findTriplets {
  my @ints = @_;
  my @solutions;
  foreach my $i ( 0 .. $#ints - 2 ) {
    foreach my $j ( $i+1 .. $#ints - 1 ) {
      foreach my $k ( $j+1 .. $#ints ) {
        if ($ints[$i] != $ints[$j] &&
            $ints[$j] != $ints[$k] &&
            $ints[$i] != $ints[$k]) {
          push @solutions, [$i, $j, $k];
        }
      }
    }
  }
  return @solutions;
}

The rest of the code is just formatting the results:

#!/usr/bin/env perl

use v5.38;

sub findTriplets {
  my @ints = @_;
  my @solutions;
  foreach my $i ( 0 .. $#ints - 2 ) {
    foreach my $j ( $i+1 .. $#ints - 1 ) {
      foreach my $k ( $j+1 .. $#ints ) {
        if ($ints[$i] != $ints[$j] &&
            $ints[$j] != $ints[$k] &&
            $ints[$i] != $ints[$k]) {
          push @solutions, [$i, $j, $k];
        }
      }
    }
  }
  return @solutions;
}

sub solution {
  my @ints = @_;
  say 'Input: @ints = (' . join(', ', @ints) . ')';
  my @solutions = findTriplets(@ints);
  say 'Output: ' . scalar(@solutions);
  say "" if @solutions;
  foreach my $triplet ( @solutions ) {
    my($i, $j, $k) = @$triplet;
    say "($i, $j, $k) because "
      . "$ints[$i] != $ints[$j] != $ints[$k]";
  }
}

say "Example 1:";
solution(4, 4, 2, 4, 3);

say "\nExample 2:";
solution(1, 1, 1, 1, 1);

say "\nExample 3:";
solution(4, 7, 1, 10, 7, 4, 1, 1);

And the output from the third example looks like this:

Example 3:
Input: @ints = (4, 7, 1, 10, 7, 4, 1, 1)
Output: 28

(0, 1, 2) because 4 != 7 != 1
(0, 1, 3) because 4 != 7 != 10
(0, 1, 6) because 4 != 7 != 1
(0, 1, 7) because 4 != 7 != 1
(0, 2, 3) because 4 != 1 != 10
(0, 2, 4) because 4 != 1 != 7
(0, 3, 4) because 4 != 10 != 7
(0, 3, 6) because 4 != 10 != 1
(0, 3, 7) because 4 != 10 != 1
(0, 4, 6) because 4 != 7 != 1
(0, 4, 7) because 4 != 7 != 1
(1, 2, 3) because 7 != 1 != 10
(1, 2, 5) because 7 != 1 != 4
(1, 3, 5) because 7 != 10 != 4
(1, 3, 6) because 7 != 10 != 1
(1, 3, 7) because 7 != 10 != 1
(1, 5, 6) because 7 != 4 != 1
(1, 5, 7) because 7 != 4 != 1
(2, 3, 4) because 1 != 10 != 7
(2, 3, 5) because 1 != 10 != 4
(2, 4, 5) because 1 != 7 != 4
(3, 4, 5) because 10 != 7 != 4
(3, 4, 6) because 10 != 7 != 1
(3, 4, 7) because 10 != 7 != 1
(3, 5, 6) because 10 != 4 != 1
(3, 5, 7) because 10 != 4 != 1
(4, 5, 6) because 7 != 4 != 1
(4, 5, 7) because 7 != 4 != 1

Things to note in the Raku solution:

  • Because .elems returns the number of elements in the array, we need to subtract an additional 1 to get the index of the last value.
#!/usr/bin/env raku

use v6;

sub findTriplets(@ints where ($_.all ~~ Int)) {
  my @solutions;
  for 0 .. @ints.elems - 3 -> $i {
    for $i + 1 .. @ints.elems - 2 -> $j {
      for $j + 1 .. @ints.elems - 1 -> $k {
        if (@ints[$i] != @ints[$j] &&
            @ints[$j] != @ints[$k] &&
            @ints[$i] != @ints[$k]) {
          push @solutions, [$i, $j, $k];
        }
      }
    }
  }
  return @solutions;
}

sub solution {
  my @ints = @_;
  say 'Input: @ints = (' ~ @ints.join(', ') ~ ')';
  my @solutions = findTriplets(@ints);
  say 'Output: ' ~ @solutions.elems;
  say "" if @solutions;
  for @solutions -> @triplet {
    my ($i, $j, $k) = @triplet;
    say "($i, $j, $k) because "
      ~ "@ints[$i] != @ints[$j] != @ints[$k]";
  }
}

say "Example 1:";
solution(4, 4, 2, 4, 3);

say "\nExample 2:";
solution(1, 1, 1, 1, 1);

say "\nExample 3:";
solution(4, 7, 1, 10, 7, 4, 1, 1);

Things to note in the Python solution:

  • The Python equivalent of x .. y is range(x, y)
  • You can’t just .join() a list of integers. You need to call .join() on the string you want to join them with, and convert each of the integers into strings:
    ", ".join([ str(i) for i in ints ])
    (though last week, I did it like this; ', '.join(map(lambda i: str(i), ints)))
  • Interpolating values in strings got a lot easier in Python 3.6 with the addition of f-strings.
#!/usr/bin/env python

def findTriplets(ints):
    solutions = []
    for i in range(0, len(ints) - 3 ):
        for j in range(i + 1, len(ints) - 2):
            for k in range(j + 1, len(ints) - 1):
                if (ints[i] != ints[j] and
                    ints[j] != ints[k] and
                    ints[i] != ints[k]):
                    solutions.append([i, j, k])
    return solutions

def solution(ints):
    intlist = ", ".join([ str(i) for i in ints ])
    print(f'Input: @ints = ({intlist})')
    solutions = findTriplets(ints)
    print(f'Output: {len(solutions)}')
    if solutions:
        print("")
        for triplet in solutions:
            i, j, k = triplet
            print(
                f"({i}, {j}, {k}) because " +
                f"{ints[i]} != {ints[j]} != {ints[k]}"
            )

print("Example 1:")
solution([4, 4, 2, 4, 3])

print("\nExample 2:")
solution([1, 1, 1, 1, 1])

print("\nExample 3:")
solution([4, 7, 1, 10, 7, 4, 1, 1])

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

Perl Weekly Challenge: What’s the Frequency, Kenneth?

There was no Perl Weekly Challenge last week so we jump from 231 to 233!

Both tasks this week deal with accepting lists of items and then manipulating those lists.


Task 1: Similar Words

You are given an array of words made up of alphabets only.

Write a script to find the number of pairs of similar words. Two words are similar if they consist of the same characters.

Example 1

Input: @words = ("aba", "aabb", "abcd", "bac", "aabc")
Output: 2

Pair 1: similar words ("aba", "aabb")
Pair 2: similar words ("bac", "aabc")

Example 2

Input: @words = ("aabb", "ab", "ba")
Output: 3

Pair 1: similar words ("aabb", "ab")
Pair 2: similar words ("aabb", "ba")
Pair 3: similar words ("ab", "ba")

Example 3

Input: @words = ("nba", "cba", "dba")
Output: 0

So what we’re looking for is a way to break down words into a sorted set of the characters that occur in that word so we can use that list to compare whether the words use only the same characters:

sub charsInWord {
    my $word = shift;
    # split the word into characters, then map those characters
    # to a hash
    my %charset = map { $_ => 1 } split //, $word;
    # return the set of characters as a string, sorted
    return join q{}, sort keys %charset;
}

We can then use those character set strings as the keys to a hash. By storing each word in an array referenced in a hash by the character set for that word:

my %similar;
foreach my $word ( @words ) {
  my $charset = charsInWord($word);
  push @{ $similar{$charset} }, $word;
}

Now, you might wonder why I’m not checking to see if $similar{$charset} exists already or has an array reference before just pushing a value there. It’s all through the magic of a feature of Perl called autovivification. When we attempt to access the hash %similar using the key $charset, if that key doesn’t exist, Perl will automatically create it and make it undefined. Similarly, when we try to push a value onto an array reference in a variable that is currently undefined, Perl creates an array reference and populates the variable with it. So when %similar is empty and I say
push @{ $similar{$charset} }, $word; the entry in %similar for $charset winds up containing a reference to an array with one entry: $word.

Autovivification can cause problems in your code, because undefined values in a hash can get autovivified just by referencing their keys, so if I’m ever testing to see if something is defined, I always check to see if the key exists in the array using exists rather than just testing the value of $hash{$key}. However, in this case, I’m putting values into a hash or into an array reference, so if they don’t already exist, I want to create them. If Perl didn’t have autovivification, I’d have to do this:

# if this is the first time we've seen this charset,
# create an empty arrayref to store the word in
$similar{$charset} = [] if ! exists $similar{$charset};

# append the word to the list for this charset
push @{ $similar{$charset} }, $word;

The next bit of the problem that I noticed on carefully reading the examples is it doesn’t just want a list of words using the same character set: it wants pairs of words using the same character set. So we need to take our list of words using the same character set and present it as pairs.

A little thought produced the algorithm for this. Given the list of words A, B, C, D, the list can be broken down into pairs by taking the first word off the list (A), pairing it with each of the remaining words (AB, AC, AD), then repeating the process with the shortened list (B, C, D) until we ran out of words (BC, BD, CD). This is easily done in Perl with a pair of loops:

my @pairs;
while ( scalar(@list) >= 2 ) {
  my $first = shift @list; # remove the first element
  foreach my $second ( @list ) {
    push @pairs, [ $first, $second ];
  }
}

And that pretty much does all the heavy lifting for this problem. The rest is presentation:

#!/usr/bin/env perl
  
use v5.38;

sub charsInWord {
  my $word = shift;
  # split the word into characters, then map those
  # characters to a hash so we only have unique ones
  my %charset = map { $_ => 1 } split //, $word;
  # return the set of characters as a string, sorted
  return join q{}, sort keys %charset;
}

sub findSimilarWordPairs {
  my @words = @_;

  # get the set of characters in each word,
  # store each word in an array reference under
  # the hash key for its character set
  my %similar;
  foreach my $word ( @words ) {
    my $charset = charsInWord($word);
    # if $similar{$charset} is undefined when we
    # try to use it as an array reference to store
    # a value, Perl will "autovivify" a reference
    # to an empty array
    push @{ $similar{$charset} }, $word;
  }

  # filter out character sets that only have one word
  my @multiples = grep {
    # only allow letter sets
    # that have more than one word
    scalar( @{ $similar{$_} } ) > 1
  } keys %similar;

  # make pairs by looping over the list
  # of letter sets that had multiple entries
  my @pairs;
  foreach my $charset ( @multiples ) {
    my @list = @{ $similar{$charset} };

    while ( scalar(@list) >= 2 ) {
      # remove the first word from the list of words
      my $first = shift @list;
      # pair it with each of the remaining words
      foreach my $second ( @list ) {
        push @pairs, [ $first, $second ];
      }
    }
  }
  return @pairs;
}

sub solution {
  my @words = @_;
  say 'Input: @words = ("' . join('", "', @words) . '")';

  my @pairs = findSimilarWordPairs(@words);

  say 'Output: ' . scalar(@pairs);
  my $count = 0;
  foreach my $pair ( @pairs ) {
    say "" if $count == 0;
    say 'Pair ' . ++$count . ': similar words ("'
      . join('", "', @$pair) . '")';
  }
}

say "Example 1:";
solution("aba", "aabb", "abcd", "bac", "aabc");

say "";
say "Example 2:";
solution("aabb", "ab", "ba");

say "";
say "Example 3:";
solution("nba", "cba", "dba");

In the Raku version, some of the language features allowed me to make some different choices:

sub charsInWord(Str $word) {
  # split the word into characters, then use the Raku
  # array method unique to have each character appear once.
  return $word.split('').unique.sort.join;
}

Raku having a .unique method on the array class (really, the Any class) meant I didn’t need to use a hash to get only the unique characters. Autovivification works much the same, however:

my %similar;
for @words -> $word {
  my $charset = charsInWord($word);
  %similar{$charset}.push($word);
}

But then I ran into a problem when I was trying to make the pairs. I wanted to make a copy of the list of similar words so I could modify it, but when I had the assignment my @list = %similar{$charset}, what I got wasn’t what I expected: instead of the elements of the list pointed to by %similar{$charset} being assigned to @list, I got the list itself assigned as the first element of @list. I needed a way to say “return the elements in this list” instead of “return this list”. Unfortunately, the method that feels right for this, .elems, just returns the count of elements, not the elements themselves. I wound up using the .splice method to return a list of all the elements in the array.

So here’s the Raku version:

#!/usr/bin/env raku
  
use v6;

sub charsInWord(Str $word) {
  # split the word into characters, then use the Raku
  # array method unique to have each character appear once.
  return $word.split('').unique.sort.join;
}

sub findSimilarWordPairs(*@words where ($_.all ~~ Str)) {
  my %similar;
  for @words -> $word {
    my $charset = charsInWord($word);
    %similar{$charset}.push($word);
  }

  # filter out character sets that only have one word
  my @multiples = %similar.keys.grep: {
    %similar{$_}.elems > 1
  };

  # make pairs by looping over the list
  # of letter sets that had multiple entries
  my @pairs;
  for @multiples -> $charset {
    # if we assign @list = %similar{$charset}, we get
    # an array with a single element, an array object.
    # By using .splice, I can get all the elements in 
    # the array object assigned to @list
    my @list = %similar{$charset}.splice(0, *);

    while ( @list.elems >= 2 ) {
      # remove the first word from the list of words
      my $first = @list.shift;
      # pair it with each of the remaining words
      for @list -> $second {
        @pairs.push([ $first, $second ]);
      }
    }
  }
  return @pairs;
}

sub solution {
  my @words = @_;
  say 'Input: @words = ("' ~ @words.join('", "') ~ '")';

  my @pairs = findSimilarWordPairs(@words);

  say 'Output: ' ~ @pairs.elems;
  my $count = 0;
  for @pairs -> $pair {
    say "" if $count == 0;
    say 'Pair ' ~ ++$count ~ ': similar words ("'
      ~ $pair.join('", "') ~ '")';
  }
}

say "Example 1:";
solution("aba", "aabb", "abcd", "bac", "aabc");

say "";
say "Example 2:";
solution("aabb", "ab", "ba");

say "";
say "Example 3:";
solution("nba", "cba", "dba");

Task 2: Frequency Sort

You are given an array of integers.

Write a script to sort the given array in increasing order based on the frequency of the values. If multiple values have the same frequency then sort them in decreasing order.

Example 1

Input: @ints = (1,1,2,2,2,3)
Ouput: (3,1,1,2,2,2)

'3' has a frequency of 1
'1' has a frequency of 2
'2' has a frequency of 3

Example 2

Input: @ints = (2,3,1,3,2)
Ouput: (1,3,3,2,2)

'2' and '3' both have a frequency of 2, so they are sorted in decreasing order.

Example 3

Input: @ints = (-1,1,-6,4,5,-6,1,4,1)
Ouput: (5,-1,4,4,-6,-6,1,1,1)

Ok, the lack of explanatory English text at the end of Example 3 and the lack '1' has a frequency of 1 of at the end of Example 2 makes me believe that Mohammad isn’t expecting that text to be part of the output. I’m including it anyway. 😉

This is the simpler of the two problems. First, we just need to count up how often we see each integer:

my %counts;
foreach my $int ( @ints ) {
  $counts{$int}++;
}

Easy-peasy. Then, much like with the last task, we use a hash of arrays to group together integers that have the same frequency:

my %frequency;
foreach my $int ( keys %counts ) {
  push @{ $frequency{ $counts{$int} } }, $int;
}

Then, putting those integers back into an output array in the proper order:

my @output;
foreach my $freq ( sort keys %frequency ) {
  # get each integer for this frequency in descending order
  foreach my $int ( reverse sort @{ $frequency{$freq} } ) {
    # we need to put the integer on the list $freq times
    foreach ( 1 .. $freq ) {
      push @output, $int;
    }
  }
}

Once I add in all the stuff to print the English output after the required array output, and the boilerplate to echo the input, we get this:

#!/usr/bin/env perl
  
use v5.38;

use Lingua::EN::Inflexion qw( wordlist );

sub solution {
  my @ints = @_;
  say 'Input: @ints = (' . join(', ', @ints) . ')';

  # count how often each integer occurs
  my %counts;
  foreach my $int ( @ints ) {
    $counts{$int}++;
  }

  # now create a hash of arrays listing which integers
  # occur at what frequencies
  my %frequency;
  foreach my $int ( keys %counts ) {
    push @{ $frequency{ $counts{$int} } }, $int;
  }

  my @output;
  my $text;
  foreach my $freq ( sort keys %frequency ) {
    my @list = @{ $frequency{$freq} };
    # get each integer for this frequency in descending order
    foreach my $int ( reverse sort @list ) {
      # we need to put the integer on the list $freq times
      foreach ( 1 .. $freq ) {
        push @output, $int;
      }
    }
    # now let's do the English description of the output.
    # have the integers in ascending order in the text,
    # and wrap them in quotes
    @list = map { "'$_'" } sort @list;
    if (@list == 1) {
      $text .= $list[0] . " has a frequency of $freq\n";
    }
    else {
      $text .= wordlist(@list);
      if (@list == 2) {
        $text .= ' both';
      }
      $text .= " have a frequency of $freq, "
            .  "so they are sorted in decreasing order\n";
    }
  }

  say "Output: (" . join(', ', @output) . ")";
  say "\n$text";
}

say "Example 1:";
solution(1,1,2,2,2,3);

say "";
say "Example 2:";
solution(2,3,1,3,2);

say "";
say "Example 3:";
solution(-1,1,-6,4,5,-6,1,4,1);

Producing the output

$ perl/ch-2.pl
Example 1:
Input: @ints = (1, 1, 2, 2, 2, 3)
Output: (3, 1, 1, 2, 2, 2)

'3' has a frequency of 1
'1' has a frequency of 2
'2' has a frequency of 3


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

'1' has a frequency of 1
'2' and '3' both have a frequency of 2, so they are sorted in decreasing order


Example 3:
Input: @ints = (-1, 1, -6, 4, 5, -6, 1, 4, 1)
Output: (5, -1, 4, 4, -6, -6, 1, 1, 1)

'-1' and '5' both have a frequency of 1, so they are sorted in decreasing order
'-6' and '4' both have a frequency of 2, so they are sorted in decreasing order
'1' has a frequency of 3

The Raku version didn’t change very much:

#!/usr/bin/env raku
  
use v6;

use Lingua::Conjunction;

sub solution (*@ints where {$_.all ~~ Int}) {
  say 'Input: @ints = (' ~ @ints.join(', ') ~ ')';

  # count how often each integer occurs
  my %counts;
  for @ints -> $int {
    %counts{$int}++;
  }

  # now create a hash of arrays listing which integers
  # occur at what frequencies
  my %frequency;
  for %counts.keys -> $int {
    %frequency{ %counts{$int} }.push($int);
  }

  my @output;
  my $text;
  for %frequency.keys.sort -> $freq {
    my @list = %frequency{$freq}.splice(0, *);
    # get each integer for this frequency in descending order
    for @list.sort.reverse -> $int {
      # we need to put the integer on the list $freq times
      @output.append($int xx $freq);
    }
    # now let's do the English description of the output.
    # have the integers in ascending order in the text,
    # and wrap them in quotes
    @list = @list.sort.map: { "'$_'" };
    if (@list.elems == 1) {
      $text ~= @list[0] ~ " has a frequency of $freq\n";
    }
    else {
      $text ~= conjunction @list;
      if (@list.elems == 2) {
        $text ~= ' both';
      }
      $text ~= " have a frequency of $freq, "
            ~  "so they are sorted in decreasing order\n";
    }
  }

  say "Output: (" ~ @output.join(', ') ~ ")";
  say "\n$text";
}

say "Example 1:";
solution(1,1,2,2,2,3);

say "";
say "Example 2:";
solution(2,3,1,3,2);

say "";
say "Example 3:";
solution(-1,1,-6,4,5,-6,1,4,1);

It does, however use the really cool xx operator that does sort of what x does, except for arrays instead of strings. If you execute say 'a' x 5; in Raku (or in Perl), you’ll get the output aaaaa. But if you execute say 'a' xx 5; in Raku, you’ll get (a a a a a).

Also, if I use .push() to put the elements into @output, I’d wind up pushing the arrays themselves into @output and get output like this:
Output: (3, 1 1, 2 2 2)

By using .append(), I was able to append the individual integers to @output and wind up with output like this:
Output: (3, 1, 1, 2, 2, 2)


I’ve also decided that I’m going to start adding more solutions in what the challenge calls “Guest Languages”… namely, anything that isn’t Perl or Raku. This week, I’m adding solutions in another language I know: Python. I want to pick up more languages so I’m more employable, and as I learn them I’ll be adding them to this exercise.


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

Perl Weekly Challenge: Min/Maxing your Senior Citizens

Another week, another Perl Weekly Challenge!

Task 1: Min Max

Submitted by: Mohammad S Anwar

You are given an array of distinct integers.

Write a script to find all elements that is neither minimum nor maximum. Return -1 if you can’t.

Example 1

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

The minimum is 1 and maximum is 4 in the given array. So (3, 2) is neither min nor max.

Example 2

Input: @ints = (3, 1)
Output: -1

Example 3

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

The minimum is 1 and maximum is 3 in the given array. So 2 is neither min nor max.

I’m taking some liberties with this one; it says to return -1 if there aren’t elements in the input array that are neither the minimum or the maximum. I’d prefer to return an empty list, but OK, I’ll do as it asks. But because the requested output cites both the minimum and maximum value, I figure the function I write should return those as well.

Which means returning multiple values from the function and unpacking them into individual variables, which Perl does very well. I whipped up this function to do the work being requested:

sub neither_min_nor_max {
  my $min = min @_; # find the minimum value
  my $max = max @_; # find the maximum value

  # grep preserves the order of the array, it just
  # passes along the elements that meet the criteria
  my @neither = grep { $_ != $min && $_ != $max } @_;
  if (@neither) {
    # if we have elements, pass them back in an array reference
    return ($min, $max, \@neither);
  }
  else {
    # otherwise, pass back the requested -1
    return ($min, $max, -1);
  }
}

And calling that function and getting back three different values is easy-peasy:

my ($min, $max, $neither) = neither_min_nor_max(@ints);

Really, the rest of the code is presentation: making the output look like Mohammad asked for in stating the problem. However, I decided I didn’t want to present a single value by itself like he did in example 3: I wanted it to still have parenthesis so you could see that it was a value in an array.

#!/usr/bin/env perl
 
use v5.38;

use Lingua::EN::Inflexion qw( verb );
use List::Util qw( min max );

sub array_join {
  return '(' . join(', ', @_) . ')';
}

sub neither_min_nor_max {
  my $min = min @_; # find the minimum value
  my $max = max @_; # find the maximum value

  # grep preserves the order of the array, it just
  # passes along the elements that meet the criteria
  my @neither = grep { $_ != $min && $_ != $max } @_;
  if (@neither) {
    # if we have elements, pass them back in an array reference
    return ($min, $max, \@neither);
  }
  else {
    # otherwise, pass back the requested -1
    return ($min, $max, -1);
  }
}

sub solution {
  my @ints = @_;
  say 'Input: @ints = ' . array_join(@ints);

  my ($min, $max, $neither) = neither_min_nor_max(@ints);

  print 'Output: ';
  if ( ref($neither) eq 'ARRAY' ) {
    # if we were passed back an array reference,
    # print it like an array
    say array_join(@$neither);

    # inflect the verb!
    my $is = @$neither == 1
           ? verb('is')->singular(3)
           : verb('is')->plural(3);

    print "The minimum is $min and maximum is $max "
        . "in the given array. ";
    say "So " . array_join(@$neither)
      . " $is neither min nor max.";
  }
  else {
    # otherwise, print the value unadorned
    say $neither;
  }
}

say "Example 1:";
solution(3, 2, 1, 4);

say "";

say "Example 2:";
solution(3, 1);

say "";

say "Example 3:";
solution(2, 1, 3);

The Raku version:

#!/usr/bin/env raku
 
use v6;

sub neither_min_nor_max (*@ints where {$_.all ~~ Int}) {
  my $min = @ints.min; # find the minimum value
  my $max = @ints.max; # find the maximum value

  # grep preserves the order of the array, it just
  # passes along the elements that meet the criteria
  my @neither = @ints.grep({ $_ != $min && $_ != $max });
  if (@neither) {
    # if we have elements, pass them back in an array reference
    return $min, $max, @neither;
  }
  else {
    # otherwise, pass back the requested -1
    return $min, $max, -1;
  }
}

sub solution (*@ints where {$_.all ~~ Int}) {
  say 'Input: @ints = (' ~ @ints.join(', ') ~ ')';

  my ($min, $max, $neither) = neither_min_nor_max(@ints);

  print 'Output: ';
  if ( $neither ~~ Array ) {
    # if we were passed back an array reference,
    # print it like an array
    say '(' ~ $neither.join(', ') ~ ')';

    # inflect the verb!
    my $is = @$neither == 1 ?? 'is' !! 'are';

    print "The minimum is $min and maximum is $max "
        ~ "in the given array. ";
    say "So (" ~ $neither.join(', ')
      ~ ") $is neither min nor max.";
  }
  else {
    # otherwise, print the value unadorned
    say $neither;
  }
}

say "Example 1:";
solution(3, 2, 1, 4);

say "";

say "Example 2:";
solution(3, 1);

say "";

say "Example 3:";
solution(2, 1, 3);

Task 2: Senior Citizens

Submitted by: Mohammad S Anwar

You are given a list of passenger details in the form “9999999999A1122”, where 9 denotes the phone number, A the sex, 1 the age and 2 the seat number.

Write a script to return the count of all senior citizens (age >= 60).

Example 1

Input: @list = ("7868190130M7522","5303914400F9211","9273338290F4010")
Output: 2

The age of the passengers in the given list are 75, 92 and 40.
So we have only 2 senior citizens.

Example 2

Input: @list = ("1313579440F2036","2921522980M5644")
Output: 0

Now, I believe based on the first example, the second example should print the following after the 0 count: “The age of the passengers in the given list are 20 and 56. So we have 0 senior citizens.”

Looking at the meaty part of the problem (parsing the passenger details into their respective fields), there’s a few ways to do this. You could use the substr function:

sub passenger_details {
  my $data = shift;
  my $phone = substr($data, 0, 10);
  my $sex   = substr($data, 10, 1);
  my $age   = substr($data, 11, 2);
  my $seat  = substr($data, 13, 2);
  return ($phone, $sex, $age, $seat);
}

Or you could extract the data using regular expressions:

sub passenger_details {
  my $data = shift;
  my($phone, $sex, $age, $seat) = $data
    =~ /\A(\d{10})(\w)(\d{2})(\d{2})\z/;
  return ($phone, $sex, $age, $seat);
}

But my mind went back to a really old function I used to use a lot back in the mid-aughts when my job was processing a lot of fixed-format text data: unpack.

sub passenger_details {
  my $data = shift;
  my($phone, $sex, $age, $seat) = unpack "A10A1A2A2", $data;
  return ($phone, $sex, $age, $seat);
}

Because the data is all ASCII data, we just need the A format specifier followed by the length of the data we’re extracting. It’s a really great way to extract fixed-width data. In fact, looking at perlpacktut, it looks like the other options of substr and regular expressions are covered as well.

Combining this with the Lingua::EN::Inflexion tricks I discovered last week, we get:

#!/usr/bin/env perl
 
use v5.38;

use Lingua::EN::Inflexion qw( inflect wordlist );

sub quoted_array {
  return '("' . join('", "', @_) . '")';
}

sub passenger_details {
  my $data = shift;
  my($phone, $sex, $age, $seat) = unpack "A10A1A2A2", $data;
  return ($phone, $sex, $age, $seat);
}

sub ages_only {
  return map {
    my($phone, $sex, $age, $seat) = passenger_details($_);
    $age
  } @_;
}

sub count_senior_citizens {
  my @seniors = grep { $_ >= 60} @_;
  return scalar(@seniors);
}

sub solution {
  my @list = @_;
  say 'Input: ' . quoted_array(@list);
  my @ages  = ages_only(@list);
  my $count = scalar(@ages);
  my $senior_count = count_senior_citizens(@ages);

  say "Output: $senior_count";
  say "";
  my $wordlist = wordlist(@ages);
  say inflect "<#d:$count>The <N:age> of the <N:passenger> "
            . "in the given list <V:is> $wordlist.";
  say inflect "So we have <#n:$senior_count> "
            . "senior <N:citizen>.";
}

say "Example 1:";
solution("7868190130M7522","5303914400F9211","9273338290F4010");

say "";

say "Example 2:";
solution("1313579440F2036","2921522980M5644");

say "";

say "Example 3:";
solution("5188675309F6002");

Yes, I added a third example to show what we get when there’s only one senior citizen.

Unfortunately, unpack in Raku is only available as an experimental method on the Blob (binary large object) role, so we’ll need to use another way to extract the fields from the fixed-width data. Let’s use regular expressions with named captures:

sub passenger_details (Str $data) {
  $data ~~ /^ $<phone>=(\d ** 10) $<sex>=(\w ** 1) 
              $<age>=(\d ** 2) $<seat>=(\d ** 2) $/;
  return (~$<phone>, ~$<sex>, ~$<age>, ~$<seat>);
}

I love how in Raku, all the regular expressions allow whitespace without having to specify extra qualifiers (like /x in Perl).

Anyway, this yields the following script in Raku:

#!/usr/bin/env raku
 
use v6;

use Lingua::Conjunction;
use Lingua::EN::Numbers;

sub quoted_list ( *@list ) {
  # given a list, quote the elements and join them with commas
  my @quoted = @list.map: { qq{"$_"} };
  return @quoted.join(q{, });
}

sub passenger_details (Str $data) {
  $data ~~ /^ $<phone>=(\d ** 10) $<sex>=(\w ** 1) 
              $<age>=(\d ** 2) $<seat>=(\d ** 2) $/;
  return (~$<phone>, ~$<sex>, ~$<age>, ~$<seat>);
}

sub ages_only (*@list where {$_.all ~~ Str}) {
  return @list.map: {
    my ($phone, $sex, $age, $seat) = passenger_details($_);    
    $age.Int;
  }
}

sub count_senior_citizens (*@list where {$_.all ~~ Int}) {
  my @seniors = @list.grep: { $_ >= 60};
  return @seniors.elems;
}

sub solution (*@list where {$_.all ~~ Str}) {
  say 'Input: @list = (' ~ quoted_list(@list) ~ ')';
  my @ages  = ages_only(@list);
  my $count = @ages.elems;
  my $senior_count = count_senior_citizens(@ages);

  say "Output: $senior_count";
  say "";

  my $str = "The age[|s] of the passenger[|s] "
          ~ "in the given list [is|are] |list|.";
  say conjunction @ages, :$str;
  my $no       = $senior_count == 0 ?? 'no' !! $senior_count.Str;
  my $citizens = $senior_count == 1 ?? 'citizen' !! 'citizens';
  say "So we have $no senior $citizens.";
}

say "Example 1:";
solution("7868190130M7522","5303914400F9211","9273338290F4010");

say "";

say "Example 2:";
solution("1313579440F2036","2921522980M5644");

say "";

say "Example 3:";
solution("5188675309F6002");

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

Perl Weekly Challenge: Not the Stated Problem

Another week, another Perl Weekly Challenge!

This week, I was looking at the challenges and the second one jumped out at me, and not for the challenge it was purporting to state… for the way it asked to present the results.

Task 2: Count Words

You are given an array of words made up of alphabetic characters and a prefix.

Write a script to return the count of words that starts with the given prefix.

Example 1

Input: @words  = ("pay", "attention", "practice", "attend")
       $prefix = "at"
Ouput: 2

Two words "attention" and "attend" starts with the given prefix "at".

Example 2

Input: @words  = ("janet", "julia", "java", "javascript")
       $prefix = "ja"
Ouput: 3

Three words "janet", "java" and "javascripr" starts with the given prefix "ja".

I was looking at the challenge, and the task itself is nothing special: does a given word start withe a given string. That’s easy: $word =~ /^$string/. What caught my eye was that the output asked to then present the count of words in English. This seemed to be a great opportunity to showcase Lingua::EN::Numbers and Lingua::En::Inflect!

The first one is simple: the module provides a function num2en, which converts a number (such as 123) into English text (“one hundred and twenty-three”). The second one is more fun: it provides plural inflections, “a”/”an” selection for English words, and manipulation of numbers as words. One thing that jumped out at me in the example was that the word “start” was improperly inflected: a single word starts, multiple words start. But that’s the kind of thing this module handles for you.

Then I took a look at the documentation for Lingua::En::Inflect to remind myself how it worked and I discovered something: the author, Damian Conway had put the module in “maintenance mode” and suggested people use Lingua::EN::Inflexion instead. That module not only had a cleaner way to inflect verbs and nouns, but it also had a function for rendering numbers as English text. Bonus! One module for all my needs. It also had a function to do something I’d written myself in the past: taking a list of items and sticking “and” between the last two items.

So here’s the script I wound up with:

#!/usr/bin/env perl

use v5.38;

use Lingua::EN::Inflexion qw( inflect wordlist );

sub quoted_list {
  # given a list, quote the elements and join them with commas
  my @quoted = map { qq{"$_"} } @_;
  return join q{, }, @quoted;
}

sub solution {
  my $prefix = shift;
  my @words  = @_;
  say qq{Input: \@words  = (} . quoted_list(@words) . q{)};
  say qq{       \$prefix = "$prefix"};

  my @matched;
  foreach my $word ( @words ) {
    # "next unless" is a perl idiom
    next unless $word =~ /^$prefix/;
    push @matched, $word;
  }
  my $count = scalar(@matched);
  say "Ouput: $count";
  say "";

  # put the list of words into an English list using "and"
  my $wordlist = wordlist( map { qq{"$_"} } @matched );

  # let's inflect the words 'word' and 'start'
  say ucfirst inflect qq{<#w:$count> <N:word> $wordlist "
    . "<V:start> with the given prefix "$prefix".};
}

say "Example 1:";
solution("at", "pay", "attention", "practice", "attend");

say "";

say "Example 2:";
solution("ja", "janet", "julia", "java", "javascript");

And my output looked like this;

$ perl/ch-2.pl
Example 1:
Input: @words  = ("pay", "attention", "practice", "attend")
       $prefix = "at"
Output: 2

Two words "attention" and "attend" start with the given prefix "at".

Example 2:
Input: @words  = ("janet", "julia", "java", "javascript")
       $prefix = "ja"
Output: 3

Three words "janet", "java", and "javascript" start with the given prefix "ja".

The Raku version wound up, as always, mostly the same:

#!/usr/bin/env raku

use v6;

use Lingua::Conjunction;
use Lingua::EN::Numbers;

sub quoted_list ( *@list ) {
  # given a list, quote the elements and join them with commas
  my @quoted = @list.map: { qq{"$_"} };
  return @quoted.join(q{, });
}

sub solution (Str $prefix, *@words where {$_.all ~~ Str}) {
  say qq{Input: \@words  = (} ~ quoted_list(@words) ~ q{)};
  say qq{       \$prefix = "$prefix"};

  my @matched;
  for @words -> $word {
    # "next unless" is a raku idiom, too
    next unless $word ~~ /^$prefix/;
    push @matched, $word;
  }
  my $count = @matched.elems;
  say "Output: $count";
  say "";

  # the examples show the word count in English as well, so
  # let's use the Lingua::EN::Numbers module
  my $count_en = tclc cardinal($count);

  # also, let's inflect the words 'word' and 'start'
  #
  # The documentation for Lingua::Conjunction says "You can use 
  # special sequence [|] (e.g. octop[us|i]) where string to the
  # left of the | will be used when the list contains just one
  # item and the string to the right will be used otherwise."
  # but there's a bug where it uses the left when there is one
  # OR TWO items.
  #
  # I've fixed it and created a pull request
  # https://github.com/raku-community-modules/Lingua-Conjunction/pull/2
  my $str = qq{$count_en word[|s] |list| start[s|] }
          ~ qq{with the given prefix "$prefix".};
  my @quoted = @matched.map: { qq{"$_"} };
  say conjunction @quoted, :$str;
}

say "Example 1:";
solution("at", "pay", "attention", "practice", "attend");

say "";

say "Example 2:";
solution("ja", "janet", "julia", "java", "javascript");

I’ve started putting types into the parameter signatures on my functions, and there wasn’t a module to do noun/verb inflection automatically, but there was a module that made providing those inflections easier, and happily enough, it was a module to render the list with “and”. Getting to fix a bug in that module was just a bonus!


Task 1: Separate Digits

You are given an array of positive integers.

Write a script to separate the given array into single digits.

Example 1

Input: @ints = (1, 34, 5, 6)
Output: (1, 3, 4, 5, 6)

Example 2

Input: @ints = (1, 24, 51, 60)
Output: (1, 2, 4, 5, 1, 6, 0)

This one was easy: getting the digits from an integer just means a little modulo division. $int % 10 gets you the ones place digit, and int( $int / 10 ) shifts every digit down a place. Loop over those and you get your digits.

What I wound up with for each integer was an array of digits. I wanted each of those digits in a master array of digits separately. I could have looped over the digits and pushed them onto my master array individually:

foreach my $digit ( @digits_of_int ) {
  push @digits_in_array, $digit;
}

But I knew there was a way to do it in a single command, and looking around, I figured out splice was my friend here:

splice @digits_in_array, scalar(@digits_in_array), 0, @digits_of_int;

The first parameter is the array we’re putting things into, the second parameter is the position of the array we’re putting them, the third is how many elements we’re replacing in the target array, and the last is the array of elements being spliced into the array. The tricky bit is the starting position: that’s going to be the length of the target array. On the first pass, the length will be zero, so we’ll insert elements into at the 0 position. Every other time, the length will point to the position in the array right after the last element (remember, Perl arrays start at 0).

So here’s the final script:

#!/usr/bin/env perl

use v5.38;

sub display_array {
  return "(" . join(q{, }, @_) . ")";
}

sub solution {
  my @ints = @_;
  say "Input: \@ints = " . display_array(@ints);
  # the description says that the array is positive integers,
  # so let's treat them as integers and divide them
  my @digits_in_array;
  foreach my $int ( @ints ) {
    my @digits_of_int;
    while ( $int > 0 ) {
      # first get the ones place digit
      my $ones_place = $int % 10;
      # push it onto the BEGINNING of @digits_of_int
      unshift @digits_of_int, $ones_place;
      # divide the number by 10, discarding the fraction
      $int = int( $int / 10 );
    }
    # push the elements from @digits_of_int onto the end
    # of @digits_in_array
    splice @digits_in_array, scalar(@digits_in_array), 0, @digits_of_int;
  }
  say "Output: " . display_array(@digits_in_array);
}

say "Example 1:";
solution(1, 34, 5, 6);

say "";

say "Example 2:";
solution(1, 24, 51, 60);

Translating this into Raku had a hiccup, however: When I started with this

sub solution (*@ints where {$_.all ~~ Int}) {
  say "Input: \@ints = " ~ display_array(@ints);
  # the description says that the array is positive integers,
  # so let's treat them as integers and divide them
  my @digits_in_array;
  for @ints -> $int {
    my @digits_of_int;
    while ( $int > 0 ) {
      # first get the ones place digit
      my $ones_place = $int % 10;
      # push it onto the BEGINNING of @digits_of_int
      unshift @digits_of_int, $ones_place;
      # divide the number by 10, discarding the fraction
      $int = ($int / 10).truncate;
    }
    # append the elements from @digits_of_int onto the end
    # of @digits_in_array
    @digits_in_array.append: @digits_of_int;
  }
  say "Output: " ~ display_array(@digits_in_array);
}

I got the following:

$ raku/ch-1.raku
Example 1:
Input: @ints = (1, 34, 5, 6)
Parameter '$int' expects a writable container (variable) as an
argument, but got '1' (Int) as a value without a container.
  in sub solution at raku/ch-1.raku line 14
  in block <unit> at raku/ch-1.raku line 32

Ahhh! Everything in Raku is an object, and I was passing immutable numbers into my array. That was an easy enough fix:

  for @ints -> $value {
    my $int = Int.new($value);

I just took the immutable value and used it to create a mutable Int object. And voilá, we’re done.

#!/usr/bin/env raku

use v6;

sub display_array (@array) {
  return "(" ~ @array.join(q{, }) ~ ")";
}

sub solution (*@ints where {$_.all ~~ Int}) {
  say "Input: \@ints = " ~ display_array(@ints);
  # the description says that the array is positive integers,
  # so let's treat them as integers and divide them
  my @digits_in_array;
  for @ints -> $value {
    my $int = Int.new($value);
    my @digits_of_int;
    while ( $int > 0 ) {
      # first get the ones place digit
      my $ones_place = $int % 10;
      # push it onto the BEGINNING of @digits_of_int
      unshift @digits_of_int, $ones_place;
      # divide the number by 10, discarding the fraction
      $int = ($int / 10).truncate;
    }
    # append the elements from @digits_of_int onto the end
    # of @digits_in_array
    @digits_in_array.append: @digits_of_int;
  }
  say "Output: " ~ display_array(@digits_in_array);
}

say "Example 1:";
solution(1, 34, 5, 6);

say "";

say "Example 2:";
solution(1, 24, 51, 60);

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

Perl Weekly Challenge: Two out of Three Ain’t Lexicographically Bad

Another week, time for another Weekly Perl Challenge!

Task 1: Lexicographic Order

You are given an array of strings.

Write a script to delete element which is not lexicographically sorted (forwards or backwards) and return the count of deletions.

Example 1

Input: @str = ("abc", "bce", "cae")
Output: 1

In the given array "cae" is the only element which is not lexicographically sorted.

Example 2

Input: @str = ("yxz", "cba", "mon")
Output: 2

In the given array "yxz" and "mon" are not lexicographically sorted.

I had to look up when “Lexicographic Order” was on the off chance that it wasn’t what I thought it was. Essentially, it means it’s sorted alphabetically. That was pretty obvious from the examples, so I just dove in:

#!/usr/bin/env perl

use v5.38;

sub quoted_list {
  # given a list, quote the elements and join them with commas
  my @quoted = map { qq{"$_"} } @_;
  return join q{, }, @quoted;
}

sub quoted_english_list {
  # given a list, quote the elements and join them 
  # in a way that makes sense to english speakers
  my @quoted = map { qq{"$_"} } @_;
  my $last = pop @quoted; # last element in array
  if (@quoted == 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 q{, }, @quoted;
  if (@quoted > 1) {
    # if there's more than element, add an Oxford comma
    $joined .= q{,};
  }
  return "$joined and $last";
}

sub is_lexically_sorted {
  my $input = shift @_;

  # get the characters in the input string
  my @characters = split //, $input;

  # generate a string of the characters sorted ascending
  # (with case folding)
  my $forwards  = join q{}, sort {
    fc($a) cmp fc($b)
  } @characters;

  # generate a string of the characters sorted descending
  # (with case folding)
  my $backwards = join q{}, sort {
    fc($b) cmp fc($a)
  } @characters;

  # if the input string is matches either sorted string,
  # then return true
  return( $input eq $forwards || $input eq $backwards );
}

sub solution {
  my @str = @_;
  say "Input: \@str = (" . quoted_list(@str) . ")";

  my @not_lexically_sorted = grep {
    ! is_lexically_sorted($_)
  } @str;

  say "Output: " . scalar(@not_lexically_sorted);
  say "";

  if (@not_lexically_sorted == 0) {
    say "In the given array all elements are"
      . " lexicographically sorted.";
  }
  elsif (@not_lexically_sorted == 1) {
    say "In the given array "
      . quoted_list(@not_lexically_sorted)
      . " is the only element which is not"
      . " lexicographically sorted.";
  }
  else {
    say "In the given array "
      . quoted_english_list(@not_lexically_sorted)
      . " are not lexicographically sorted.";
  }
}

say "Example 1:";
solution("abc", "bce", "cae");

say "";

say "Example 2:";
solution("yxz", "cba", "mon");

I added a bunch of extra subroutines to make the code more readable: quoted_list and quoted_english_list let me just say how I want to display the list, rather than repeating the code every time I want to display it. And the is_lexically_sorted function make the grep that I’m using to determine which array elements aren’t lexicographically sorted more readable as well. Whether it’s Perl or not, sometimes it’s just good coding practice to pull out pieces of your code that represent a concept and make them their own function, even if they’re only being used in only one place, because it just makes the code conceptually easier to understand.

The Raku version

#!/usr/bin/env raku

use v6;

sub quoted_list ( *@list ) {
  # given a list, quote the elements and join them with commas
  my @quoted = @list.map: { qq{"$_"} };
  return @quoted.join(q{, });
}

sub quoted_english_list ( *@list ) {
  # given a list, quote the elements and join them 
  # in a way that makes sense to english speakers
  my @quoted = @list.map: { qq{"$_"} };
  my $last = @quoted.pop(); # last element in array
  if (@quoted == 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 q{, }, @quoted;
  if (@quoted > 1) {
    # if there's more than element, add an Oxford comma
    $joined ~= q{,};
  }
  return "$joined and $last";
}

sub is_lexically_sorted ($input) {
  # get the characters in the input string
  # putting $input in quotes casts it as a Str
  my @characters = "$input".split("", :skip-empty);

  # sort the characters ascending
  my @forwards  = @characters.sort: { $^a.fc cmp $^b.fc };

  # sort the characters descending
  my @backwards = @characters.sort: { $^b.fc cmp $^a.fc };

  # if the input string is matches either sorted string,
  # then return true
  return( $input eq @forwards.join("")
          ||
          $input eq @backwards.join("") );
}

sub solution (*@str) {
  say "Input: \@str = (" ~ quoted_list(@str) ~ ")";

  my @not_lexically_sorted = @str.grep({
    !is_lexically_sorted($_)
  });

  say "Output: " ~ @not_lexically_sorted.elems;
  say "";

  if (@not_lexically_sorted.elems == 0) {
    say "In the given array all elements are"
      ~ " lexicographically sorted.";
  }
  elsif (@not_lexically_sorted.elems == 1) {
    say "In the given array "
      ~ quoted_list(@not_lexically_sorted)
      ~ " is the only element which is not"
      ~ " lexicographically sorted.";
  }
  else {
    say "In the given array "
      ~ quoted_english_list(@not_lexically_sorted)
      ~ " are not lexicographically sorted.";
  }
}

say "Example 1:";
solution("abc", "bce", "cae");

say "";

say "Example 2:";
solution("yxz", "cba", "mon");

This is mostly like the Perl solution above, but I decided to play around a little with slurpy parameters in my function signatures.

Task 2: Two out of Three

You are given three array of integers.

Write a script to return all the elements that are present in at least 2 out of 3 given arrays.

Example 1

Input: @array1 = (1, 1, 2, 4)
       @array2 = (2, 4)
       @array3 = (4)
Ouput: (2, 4)

Example 2

Input: @array1 = (4, 1)
       @array2 = (2, 4)
       @array3 = (1, 2)
Ouput: (1, 2, 4)

Perl version:

#!/usr/bin/env perl

use v5.38;

# function to return unique elements in array
use List::Util qw( uniq );

sub display_array {
  return "(" . join(q{, }, @_) . ")";
}

sub solution {
  my @arrays = @_;
  say "Input: \@array1 = " . display_array( @{ $arrays[0] } );
  say "       \@array2 = " . display_array( @{ $arrays[1] } );
  say "       \@array3 = " . display_array( @{ $arrays[2] } );

  # Return all the elements that are present in at least 2 out
  # of 3 given arrays.  In the sample input, there are arrays 
  # where there elements appear multiple times in a given
  # array, so we want to examine only UNIQUE elements
  my @unique;
  foreach my $arrayref ( @arrays ) {
    push @unique, [ uniq @$arrayref ];
  }

  # now that we have arrays of only unique elements, let's find
  # elements that occur in more than one array using a hash
  my %occurrences;
  foreach my $arrayref ( @unique ) {
    foreach my $element ( @$arrayref ) {
      $occurrences{$element}++;
    }
  }

  say "Output: " . display_array(
    sort # sort the resulting array of elements numerically
    grep {
      # only include elements that were counted more than once
      $occurrences{$_} > 1;
    } keys %occurrences
  );
}

say "Example 1:";
solution(
  [1, 1, 2, 4],
  [2, 4],
  [4]
);

say "";

say "Example 2:";
solution(
  [4, 1],
  [2, 4],
  [1, 2]
);

Raku version

#!/usr/bin/env raku

use v6;

sub display_array (@array) {
  return "(" ~ @array.join(q{, }) ~ ")";
}

sub solution (@array1, @array2, @array3) {
  say "Input: \@array1 = " ~ display_array(@array1);
  say "       \@array2 = " ~ display_array(@array2);
  say "       \@array3 = " ~ display_array(@array3);

  # Return all the elements that are present in at least 2 out
  # of 3 given arrays.  In the sample input, there are arrays
  # where there elements appear multiple times in a given
  # array, so we want to examine only UNIQUE elements, then
  # find elements that occur in more than one array using
  # a hash
  my %occurrences;
  for ( @array1.unique,
        @array2.unique,
        @array3.unique ).flat -> $element {
    %occurrences{$element}++;
  }

  say "Output: " ~ display_array(
    # only include elements that were counted more than once
    %occurrences.keys().grep: { %occurrences{$_} > 1 } 
  ).sort; # sort the resulting array of elements numerically
}

say "Example 1:";
solution(
  (1, 1, 2, 4),
  (2, 4),
  (4,)
);

say "";

say "Example 2:";
solution(
  (4, 1),
  (2, 4),
  (1, 2)
);

I want to point out my discovering the .flat method for Arrays.

Note that in the Perl version, I’m passing around array references to keep the three lists, separate, but in Raku, I’m able to make the three different parameters full-on arrays. Also, in Perl I had to pull in a function from a core module to get a list of unique elements in an array, but in Raku, the .unique method is provide on the base class Any.


Here’s my solutions in GitHub: https://github.com/manwar/perlweeklychallenge-club/tree/master/challenge-229/packy-anderson

Perl Weekly Challenge: Unique Sums and Empty Arrays

Another week, time for another Perl Weekly Challenge!

Task 1: Unique Sum

You are given an array of integers.

Write a script to find out the sum of unique elements in the given array.

Example 1

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

In the given array we have 2 unique elements (1, 3).

Example 2

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

In the given array no unique element found.

Example 3

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

In the given array every element is unique.

The examples make what this challenge is looking for pretty clear. We find the unique elements in the array, and sum those up. I immediately thought of using a hash to accomplish the task:

# find the unique elements
my %unique;
foreach my $int ( @ints ) {
  $unique{$int}++;
}

# make a list of ONLY the unique ints
my @unique_ints = grep { $unique{$_} == 1 } @ints;

It’s a common use-case in Perl to use a hash to count how many times something occurs, whether it’s to only do something once or to actually count up occurrences.

I guess I could have populated the %unique hash via a map, but I wanted to keep what the code was doing obvious, and sometimes I think using a map just to execute code in the code block and not to return an array/hash can be confusing.

map { $unique{$_}++ } @ints;

The other thing I knew I wanted to do was show off some List::Util functions

use List::Util qw( sum );

# sum the unique elements
my $sum = sum(@unique_ints) // 0;

Sure, it would be easy enough to say

my $sum = 0;
foreach my $int ( @unique_ints ) {
  $sum += $int;
}

But sum makes it is a lot shorter. So here’s the entire script…

#!/usr/bin/env perl

use v5.38;

use List::Util qw( sum );

# just accept the list of integers on the command line
my @ints = @ARGV;

# find the unique elements
my %unique;
foreach my $int ( @ints ) {
  $unique{$int}++;
}

# make a list of ONLY the unique ints
my @unique_ints = grep { $unique{$_} == 1 } @ints;

# sum the unique elements
my $sum = sum(@unique_ints) // 0;

# produce the output
say "Input: \@int = (" . join(', ', @ints) . ")";
say "Output: $sum";
say "";

print "In the given array ";
if ( scalar(@unique_ints) == scalar(@ints) ) {
  say "every element is unique.";
}
elsif ( scalar(@unique_ints) == 0 ) {
  say "no unique element found.";
}
else {
  say "we have " . scalar(@unique_ints) . " unique elements ("
    . join(', ', @unique_ints) . ").";
}

As always, I started with my Perl script and made changes to make it valid Raku:

#!/usr/bin/env raku

use v6;

# just accept the list of integers on the command line
my @ints = @*ARGS;

# find the unique elements
my %unique;
for @ints -> $int {
  %unique{$int}++;
}

# make a list of ONLY the unique ints
my @unique_ints = grep { %unique{$_} == 1 }, @ints;

# sum the unique elements
my $sum = [+] @unique_ints;

# produce the output
say "Input: \@int = (" ~ @ints.join(', ') ~ ")";
say "Output: $sum";
say "";

print "In the given array ";
if ( @unique_ints.elems == @ints.elems ) {
  say "every element is unique.";
}
elsif ( @unique_ints.elems == 0 ) {
  say "no unique element found.";
}
else {
  say "we have " ~ @unique_ints.elems ~ " unique elements ("
    ~ @unique_ints.join(', ') ~ ").";
}

Now, the big decision I had to make was how to do the sum. I picked showing off Raku’s Reduction Metaoperator: [ ]. When you put an operator between square brackets and put that in front of a Raku Positional (like an Array), it turns the Positional into a single value by applying the operator to the first two elements, and then applying the operator to the result and the next element, and so on until the Positional has run out of elements. You can multiply all the elements of a Positional using [*], you can concatenate all the elements of a Positional using [~], There’s even a max infix operator that given two operands will return the larger of the two, and this can be applied to a Positional to find the largest value using [max].

But I could have used the .sum routine provided by Raku’s List class (which Arrays are a subclass of):

my $sum = @unique_ints.sum;

Task 2: Empty Array

You are given an array of integers in which all elements are unique.

Write a script to perform the following operations until the array is empty and return the total count of operations.

If the first element is the smallest then remove it otherwise move it to the end.

Example 1

Input: @int = (3, 4, 2)
Output: 5

Operation 1: move 3 to the end: (4, 2, 3)
Operation 2: move 4 to the end: (2, 3, 4)
Operation 3: remove element 2: (3, 4)
Operation 4: remove element 3: (4)
Operation 5: remove element 4: ()

Example 2

Input: @int = (1, 2, 3)
Output: 3

Operation 1: remove element 1: (2, 3)
Operation 2: remove element 2: (3)
Operation 3: remove element 3: ()

This time, the List::Util function I wanted to use was min:

#!/usr/bin/env perl

use v5.38;

use List::Util qw( min );

# just accept the list of integers on the command line
my @ints = @ARGV;

my @operations;
my $count = 1;
while ( scalar(@ints) > 0 ) {
  my $min = min @ints;

  # in either case, we're removing the first element from the list
  my $first = shift @ints;

  if ($min == $first) {
    # the first element is the minimum, discard it
    push @operations, "Operation $count: "
                    . "remove element $min: ("
                    . join(',', @ints) . ")";
  }
  else {
    # the first element is NOT the minimum, add it to the end
    push @ints, $first;
    push @operations, "Operation $count: "
                    . "move $first to the end: ("
                    . join(',', @ints) . ")";
  }
  $count++;
}

# produce the output
# let's use @ARGV again, since we modify @ints as we go along
say "Input: \@int = (" . join(', ', @ARGV) . ")";
say "Output: " . scalar(@operations);
say "";
say join "\n", @operations;

This also does an excellent job of showing off array operations: shift to remove the first element of an array, and push to append an element to the end of an array (though, I will admit I really like the way PHP allows you to append to the end of an array: $ints[] = $first).

At first, I was using $ints[0] to examine the first element in the array and then using shift to remove it and discard the value if the first element was the minimum value, and if it wasn’t, using shift to remove the first value and save itm like this:

if ($min == $ints[0]) {
  shift @ints;
  push @operations, ...;
}
else {
  my $first = shift @ints;
  push @operations, ...;
}

But then I realized that I was shift-ing the value off @ints in either case, and it would just be cleaner to do it before the comparison so I could use $first instead of $ints[0].

The Raku version is nothing fancy this time:

#!/usr/bin/env raku

use v6;

# just accept the list of integers on the command line
my @ints = @*ARGS;

my @operations;
my $count = 1;
while ( @ints.elems > 0 ) {
  my $min = @ints.min;

  # in either case, we're removing the first element
  # from the list
  my $first = @ints.shift;

  if ($min == $first) {
    # the first element is the minimum, discard it
    push @operations, "Operation $count: "
                    ~ "remove element $min: ("
                    ~ @ints.join(', ') ~ ")";
  }
  else {
    # the first element is NOT the minimum, add it to the end
    push @ints, $first;
    push @operations, "Operation $count: "
                    ~ "move $first to the end: ("
                    ~ @ints.join(', ') ~ ")";
  }
  $count++;
}

# produce the output
# let's use @ARGV again, since we modofy @ints as we go along
say "Input: \@int = (" ~ @*ARGS.join(', ') ~ ")";
say "Output: " ~ @operations.elems;
say "";
say join "\n", @operations;

Perl Weekly Challenge #227

This week’s challenge brought two new tasks: Friday the 13th & Roman Maths.

Task 1: Friday 13th

You are given a year number in the range 1753 to 9999.

Write a script to find out how many dates in the year are Friday 13th, assume that the current Gregorian calendar applies.

Example

Input: $year = 2023
Output: 2

Since there are only 2 Friday 13th in the given year 2023 i.e. 13th Jan and 13th Oct.

This was going to be easy, because I knew there were date manipulation modules in the core distribution: Time::Piece and Time::Seconds. I figured I wanted to start at the first of the year, add one day in a loop until I found the first Friday, and then skip from one Friday to the next by adding seven days, using the wday property of a Time::Piece object to check whether or not the date was the 13th. Yes, instantiating the first day of the year would have been easier using the DateTime module, but I wanted to use only core modules if they did what I needed (and, really how much more complex is Time::Piece->strptime("$year-01-01", "%Y-%m-%d")->truncate(to => 'day'); versus DateTime->new(year => $year, month => 1, day => 1)->truncate(to => 'day');).

#!/usr/bin/env perl
use v5.38;

# let's use the core modules for date manipulation
use Time::Piece;
use Time::Seconds qw( ONE_DAY );

# get the year from the command line
my $year = shift @ARGV
  or die "usage: $0 year\n";

# do bounds checking as specified in the problem
if ($year < 1753 || $year > 9999) {
  die "Only years between 1753 to 9999 are allowed ($year is out of range)\n";
}

# create an object for Jan 01 of the given year
my $t = Time::Piece->strptime("$year-01-01", "%Y-%m-%d")
                   ->truncate(to => 'day');

# find the first friday
# in Time::Piece->wday, 1 = Sunday, 6 = Friday
while ( $t->wday != 6) {
  $t += ONE_DAY; # add 1 day
}

# now keep adding 7 days to the date until the year changes,
# noting how many times the day of the month is 13
my $thirteen_count = 0;
while ( $t->year == $year ) {
  $thirteen_count++ if $t->mday == 13;
  $t += ONE_DAY * 7;
}

say "Input: \$year = $year";
say "Output: $thirteen_count";

Doing this problem in Raku wound up being even easier, because in Raku, Date objects are a native part of the language, and incrementing a Date object increases the value by one day. Even instantiating a Date object was easier, because I didn’t need to parse a date format or specify an array with 0-indexed months or years with 1900 subtracted from them, I was able to specify a year, month, day in my new() call:

#!/usr/bin/env raku

sub MAIN($year) {
  # do bounds checking as specified in the problem
  if ($year < 1753 || $year > 9999) {
    say "Only years between 1753 to 9999 are allowed ($year is out of range)";
    exit 1;
  }

  # create an object for Jan 01 of the given year
  my $t = Date.new($year, 1, 1);

  # find the first friday
  # in Date.day-of-week, 0 = Sunday, 5 = Friday
  while ( $t.day-of-week != 5) {
    $t++; # add 1 day
  }

  # now keep adding 7 days to the date until the year changes,
  # noting how many times the day of the month is 13
  my $thirteen_count = 0;
  while ( $t.year == $year ) {
    $thirteen_count++ if $t.day == 13;
    $t += 7;
  }

  say "Input: \$year = $year";
  say "Output: $thirteen_count";
}

Task 2: Roman Maths

Write a script to handle a 2-term arithmetic operation expressed in Roman numeral.

Example

IV + V     => IX
M - I      => CMXCIX
X / II     => V
XI * VI    => LXVI
VII ** III => CCCXLIII
V - V      => nulla (they knew about zero but didn't have a symbol)
V / II     => non potest (they didn't do fractions)
MMM + M    => non potest (they only went up to 3999)
V - X      => non potest (they didn't do negative numbers)

Now, I’m not going to get into how Roman numerals did have ways of expressing fractions or numbers larger that 3,999, because that’s not part of the challenge. Remember, I want to showcase how easy it is to solve problems in Perl & Raku. And I knew just the module to use: Roman. Unfortunately, none of the modules for manipulating Roman numerals are in the core Perl distribution, so I had to use cpanm to install it: $ cpanm Roman (I could have used $ cpan install Roman instead, but I like the cpanm tool).

#!/usr/bin/env perl
use v5.38;

use Roman; # there's a module for handling Roman Numerals!

sub do_arithmetic {
  my $line = shift;
  # split the inout line into the three parts:
  # the two operands and the infix operator
  my($operand1r, $operator, $operand2r) = split /\s+/, $line;
  unless (defined $operand1r &&
          defined $operator  &&
          defined $operand2r) {
    say q{Lines must be of the form "operand1 operator operand2"};
    say q{where both operands are valid roman numerals and the};
    say q{operator is one of the following:  +  -  *  /  **};
    return;
  }

  my($operand1a, $operand2a);

  # check that the first operand is a roman numeral
  if (isroman($operand1r)) {
    # it is a roman numeral, convert it
    $operand1a = arabic($operand1r);
  }
  else {
    say "'$operand1r' is not a roman numberal!";
    return;
  }

  # check that the second operand is a roman numeral
  if (isroman($operand2r)) {
    # it is a roman numeral, convert it
    $operand2a = arabic($operand2r);
  }
  else {
    say "'$operand2r' is not a roman numberal!";
    return;
  }

  # calculate the results
  my $result;
  if ($operator eq '+') {
    $result = $operand1a + $operand2a;
  }
  elsif ($operator eq '-') {
    $result = $operand1a - $operand2a;
  }
  elsif ($operator eq '*') {
    $result = $operand1a * $operand2a;
  }
  elsif ($operator eq '/') {
    $result = $operand1a / $operand2a;
  }
  elsif ($operator eq '**') {
    $result = $operand1a ** $operand2a;
  }
  else {
    die "Unknown operator '$operator'; valid operators are + - * / **\n";
  }

  # handle all the special output cases
  if ($result == 0) {
    say "$operand1r $operator $operand2r => nulla "
      . "(they knew about zero but didn't have a symbol)";
  }
  elsif (int($result) != $result) {
    say "$operand1r $operator $operand2r => non potest "
      . "(they didn't do fractions)";
  }
  elsif ($result > 3999) {
    say "$operand1r $operator $operand2r => non potest "
      . "(they only went up to 3999)";
  }
  elsif ($result < 0) {
    say "$operand1r $operator $operand2r => non potest "
      . "(they didn't do negative numbers)";
  }
  else {
    say "$operand1r $operator $operand2r => " . uc roman($result);
  }
}

# while we have input on STDIN, process the calculations
while (my $line = <>) {
  chomp $line;
  do_arithmetic($line);
}

At first, I whipped it up as a command-line tool that accepted the two operands and the operator on the command line, but I realized it wouldn’t be easy to produce output as close to the sample as possible doing things this way, so I modified it to read the operations from STDIN. This also allowed me to add a file that could be used by both my Perl and Raku solutions to make the input standardized.

I also wanted to do some extra checking: not just the stuff between lines 53-72 to handle the special cases called out in the example; I wanted to check for invalid Roman numerals and for input that didn’t have two operands separated by an operator. Lines 22-40 do the check using the isroman() function provided by the Roman module, and lines 49-51 make sure that we generate an error if we’re not passed one of the five operators specified in the requirements.

The Raku version of this proved slightly more challenging, because the Math::Roman module available for Raku didn’t have a function corresponding to Perl’s Roman module’s isroman() function. So I had to make one:

#!/usr/bin/env raku
use Math::Roman; # it's v0.0.1, but usable

sub isroman ( $var ) {
  # Math::Roman doesn't have a test to see if a string is
  # a Roman numeral, but it does throw an exception if it
  # cannot convert it
  my $result;
  try {
    CATCH {
      default {
        return False;
      }
    }
    $result = Math::Roman.new: $var;
  }
  # Math::Roman also doesn't respect the maximum of 3999
  if ($result.as-arabic > 3999) {
    return False;
  }

  return True;
}

sub do_arithmetic (Str $line) {
  # split the inout line into the three parts:
  # the two operands and the infix operator
  my ($operand1, $operator, $operand2) = $line.split(/\s+/);

  unless (defined $operand1 &&
          defined $operator  &&
          defined $operand2) {
    say q{Lines must be of the form "operand1 operator operand2"};
    say q{where both operands are valid roman numerals and the};
    say q{operator is one of the following:  +  -  *  /  **};
    return;
  }

  # check that the first operand is a roman numeral
  if (isroman($operand1)) {
    # it is a roman numeral, convert it
    $operand1 = Math::Roman.new: $operand1;
  }
  else {
    say "'$operand1' is not a roman numberal!";
    return;
  }

  # check that the second operand is a roman numeral
  if (isroman($operand2)) {
    # it is a roman numeral, convert it
    $operand2 = Math::Roman.new: $operand2;
  }
  else {
    say "'$operand2' is not a roman numberal!";
    return;
  }

  # # calculate the results
  my $result;
  if ($operator eq '+')     {
    $result = $operand1.as-arabic + $operand2.as-arabic;
  }
  elsif ($operator eq '-')  {
    $result = $operand1.as-arabic - $operand2.as-arabic;
  }
  elsif ($operator eq '*')  {
    $result = $operand1.as-arabic * $operand2.as-arabic;
  }
  elsif ($operator eq '/')  {
    $result = $operand1.as-arabic / $operand2.as-arabic;
  }
  elsif ($operator eq '**') {
    $result = $operand1.as-arabic ** $operand2.as-arabic;
  }
  else {
    die "Unknown operator '$operator'; valid operators are + - * / **\n";
  }

  # handle all the special output cases
  if ($result == 0) {
    say "$operand1 $operator $operand2 => nulla "
      ~ "(they knew about zero but didn't have a symbol)";
  }
  elsif ($result.truncate != $result) {
    say "$operand1 $operator $operand2 => non potest "
      ~ "(they didn't do fractions)";
  }
  elsif ($result > 3999) {
    say "$operand1 $operator $operand2 => non potest "
      ~ "(they only went up to 3999)";
  }
  elsif ($result < 0) {
    say "$operand1 $operator $operand2 => non potest "
      ~ "(they didn't do negative numbers)";
  }
  else {
    $result = Math::Roman.new: value => $result.Int;
    say "$operand1 $operator $operand2 => $result";
  }
}

# while we have input on STDIN, process the calculations
for $*IN.lines -> $line {
  do_arithmetic($line);
}

Perl Weekly Challenge #226

I went to the Perl and Raku Conference in Toronto, ON, two weeks ago. I went because I really wanted to reconnect with the Perl community that I’d fallen out of touch with while I was working at a job where Perl was actively ridiculed.

While I was there, I was talking to one of the people giving talks, Bruce Gray. He suggested that one of the best ways to reconnect would be to do the weekly challenge.

I’d seen the challenge being talked about in emails I subscribed to, but I hadn’t given it much thought. But I wanted to reconnect, keep my Perl chops up to date, and generally start participating in the community again. So when I got the email for Challenge #226, I thought about it a bit. What I realized was that the challenge wasn’t just a way for people to showcase their Perl skills; it was a way for the community to showcase how easy Perl and Raku were to use. So I decided that was the approach I was going to take: not try to be clever, but try to show how easy this language I love is to solve problems.

Task 1: Shuffle String

Here’s the description provided in the challenge:

You are given a string and an array of indices of same length as string.
Write a script to return the string after re-arranging the indices in the correct order.

Example 1

Input: $string = 'lacelengh', @indices = (3,2,0,5,4,8,6,7,1)
Output: 'challenge'

Example 2

Input: $string = 'rulepark', @indices = (4,7,3,1,0,5,2,6)
Output: 'perlraku'

I won’t lie, it took me a little while to understand what it wanted me to do. Finally, I realized that the @indicies array was showing me where in the output string the character from the input string should be moved to: the first character in the input string should be moved to the 3rd position in the output, the second character to the 2nd position, the third to the 0th position and so on. Once I grokked that requirement, the Perl implementation came easily:

#!/usr/bin/env perl
use v5.36;

sub shuffle_string {
  my($string, $indices) = @_;
  my @chars = split //, $string; # split input string into characters
  my @result;
  foreach my $index ( @$indices ) {
    my $char  = shift @chars;     # get the next character
    $result[$index] = $char;      # put the character at that index in the result
  }
  say "Input: \$string = '$string', \@indices = (" . join(',', @$indices) . ")";
  say "Output: '" . join(q{}, @result) . "'";
}

say "Task 1: Shuffle String";
say "\nExample 1";
shuffle_string('lacelengh', [3,2,0,5,4,8,6,7,1]);
say "\nExample 2";
shuffle_string('rulepark', [4,7,3,1,0,5,2,6]);

Note how Perl makes handling the parts of the problem easy: splitting a string into its component characters is easy, recombining them back into a string is easy, passing the data around is easy.

Now, I don’t have a lot of experience with Raku; but I want to get better at it, so that’s why I’m doing the challenges in Raku as well. Unfortunately, for the moment my Raku solutions will look a lot like my Perl solutions:

#!/usr/bin/env raku

sub shuffle_string ($string, @indices) {
  my @chars = $string.split("", :skip-empty);
  my @result;
  for @indices -> $index {
    my $char = shift @chars;   # get the next character
    @result[$index] = $char;   # put the character at that index in the result
  }
  say "Input: \$string = '$string', \@indices = (" ~ @indices.join(',') ~ ")";
  say "Output: '" ~ @result.join('') ~ "'";
}

say "Task 1: Shuffle String";
say "\nExample 1";
shuffle_string('lacelengh', (3,2,0,5,4,8,6,7,1));
say "\nExample 2";
shuffle_string('rulepark', (4,7,3,1,0,5,2,6));

Task 2: Zero Array

You are given an array of non-negative integers, @ints.

Write a script to return the minimum number of operations to make every element equal zero.

In each operation, you are required to pick a positive number less than or equal to the smallest element in the array, then subtract that from each positive element in the array.

Example 1:

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

operation 1: pick 1 => (0, 4, 0, 2, 4)
operation 2: pick 2 => (0, 2, 0, 0, 2)
operation 3: pick 2 => (0, 0, 0, 0, 0)

Example 2:

Input: @ints = (0)
Output: 0

Example 3:

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

operation 1: pick 1 => (1, 0, 3, 0, 2)
operation 2: pick 1 => (0, 0, 2, 0, 1)
operation 3: pick 1 => (0, 0, 1, 0, 0)
operation 4: pick 1 => (0, 0, 0, 0, 0)

This one I found a lot easier to understand for some reason.

#!/usr/bin/env perl
use v5.36;

use List::Util qw( min );

sub min_positive {
  my @ints = grep { $_ > 0 } @_; # only consider positive numbers
  return min @ints; # find smallest, undef if empty list
}

sub zero_array {
  my @ints = @_;
  say "Input: \@ints = (" . join(', ', @ints) . ")";
  my @operations;
  while ( my $min = min_positive(@ints) ) {
    my $op_num = scalar(@operations) + 1;
    foreach my $int ( @ints ) {
      $int -= $min if $int > 0;
    }
    push @operations, "operation $op_num: pick $min => (" . join(', ', @ints) . ")";
  }
  say "Output: " . scalar(@operations);
  if (@operations) {
    say "";
    say join "\n", @operations;
  }
}

say "Task 2: Zero Array";
say "\nExample 1";
zero_array(1, 5, 0, 3, 5);

say "\nExample 2";
zero_array(0);

say "\nExample 3";
zero_array(2, 1, 4, 0, 3);

This one I’d like to pull apart a bit more. Picking “a positive number less than or equal to the smallest element in the array” sounded a lot like the min function found in the List::Util module, but that gives us the minimum value, not the minimum non-zero value, so I needed to filter the values equal to zero out of the array first. Initially, I did it like this:

min grep { $_ > 0 } @ints

but then I realized I needed to do that as part of the conditional to a loop, and I decided it would be a lot more readable if I pulled it out into it’s own function. Remember, I’m trying to express how easy things are in Perl, so I want to make my solutions completely readable and understandable to people who have never used Perl before.

I wanted the output to look exactly like the text in the examples, so I made the minimal extra effort to build an array of operations and put a bit of formatting into that so I could just dump the operations when I’d found out how many operations were necessary.

Again, my Raku solution looks like my Perl solution with a few syntax tweaks:

#!/usr/bin/env raku

sub min_positive (@ints) {
  my @positive = @ints.grep({ $_ > 0 }); # only consider positive numbers
  return unless @positive.elems;         # return early if no positive nums
  return @positive.reduce(&min);         # find smallest
}

sub zero_array (@ints) {
  say "Input: \@ints = (" ~ @ints.join(', ') ~ ")";
  my @operations;
  while ( my $min = min_positive(@ints) ) {
    my $op_num = @operations.elems + 1;
    for @ints <-> $int {
      $int -= $min if $int > 0;
    }
    @operations.push("operation $op_num: pick $min => (" ~ @ints.join(', ') ~ ")");
  }
  say "Output: " ~ @operations.elems;
  if (@operations) {
    say "";
    say @operations.join("\n");
  }
}

say "Task 2: Zero Array";
say "\nExample 1";
zero_array([1, 5, 0, 3, 5]);

say "\nExample 2";
zero_array([0]);

say "\nExample 3";
zero_array([2, 1, 4, 0, 3]);

If you really want a good example of how Raku can be used to solve this problem, take a look at Bruce Gray’s solution.

And that’s it. I’ve already coded my solutions for Challenge #227, and I’ll be blogging about them soon.

Preview of my next post…

My next project in the “whittling wood”?  Figuring out why XML::RSS::LibXML parses these tags without any problem:

[code language=”xml”]
<itunes:category text="News &amp; Politics"/>
<itunes:image href="http://media.npr.org/images/podcasts/2013/primary/hourly_news_summary-c464279737c989a5fbf3049bc229152af3c36b9d.png?s=1400"/>
[/code]

and produces this internal data structure:

[code language=”perl”]
category => bless( {
_attributes => [
"text"
],
_content => "",
text => "News & Politics"
}, ‘XML::RSS::LibXML::MagicElement’ ),
image => bless( {
_attributes => [
"href"
],
_content => "",
href => "http://media.npr.org/images/podcasts/2013/primary/hourly_news_summary-c464279737c989a5fbf3049bc229152af3c36b9d.png?s=1400"
}, ‘XML::RSS::LibXML::MagicElement’ ),
[/code]

But then doesn’t have these tags anywhere in the re-rendered XML when it spits it back out again. I know it has to do with the fact that these tags have no content (there’s no opening and closing tag, there’s just the one tag closed with a />), but I don’t know why XML::RSS isn’t properly rendering it when it converts the data structure back to XML.

The easy work-around would be to just do some string matching, recognize these tags in the original XML, copy them and re-insert them into the rendered XML afterwards.

The more difficult fix is to figure out what’s wrong with XML::RSS and try to fix it myself.

Guess which road I’m taking?

But what if I’ve still got an itch?

Ok, I wanted to write a follow-up post about my little program and the changes that I needed to make to it about a day later, but I found myself writing more and more code, and not having any time to actually write about writing the code. My wife, Kay, has dubbed it “my whittling wood”. So, let’s run down things that started to bother me about my creation…

The first thing that bothered me was when I was walking out of my office the first night. I checked my podcast app, and I didn’t have the 7PM news podcast yet, and it was 7:15PM already. I knew immediately what happened: NPR had been late updating the feed, and my cron job had run at 7:12 and missed it. So I thought about how to fix that problem (I managed to get the 7PM news podcast at 8:12 because NPR was late with the 8PM episode as well, so I was able to pick up the 7PM episode on that run).

I immediately dismissed the idea of running the script multiple times an hour. It didn’t feel clean to me. What I decided I needed to do was check to see if the episode I was looking at this time was different than the episode I was looking at the last time the script ran–I would need a new table to track this–and, if it was the same episode, sleep for a minute or two and try again, and continue retrying until I either got a new episode or I decided I’d waited long enough (20 attempts seemed to be a good cutoff number).

Of course, I also decided I wanted to be able to check up on what was happening, so I needed to write a log file. If I was going to be able to see this log file when I wasn’t home, however, I’d have to copy it up to my web server along with the RSS feed XML.

And this brings me to where I was when I wrote my first post. I already had more code in the script, but I blogged about the first draft, wanting to come back to this second draft with a followup blog post.

And that’s when things got crazy.

We had a big filming day coming up for PacKay Productions that weekend, and I had a lot of work to do, some of which I’d already done and blogged about. After the filming was done, I needed to prep for Halloween.  And even with the changes I’d made to this script, things were going wrong with my setup.

One of the things I did wrong was setting up my wrapper shell script to run the perl program.  I’m not really adept at Bourne shell scripting, and I always leave things out. Then, last Thursday night, I was idly wondering how easy it would be to correct the other major annoyance I have with the NPR Hourly News Summary: the inconsistency of the sound levels.

Sometimes, the news summary is recorded at a good level, and I’m able to hear everything just fine.  Other times, the levels are set so low that even with my player’s volume cranked all the way up and my headphones pressed into my ears, I find it impossible to hear what’s being said over the sounds of the street in New York City.

So, of course, I started looking to see if somebody else had already solved my problem.  I ran across this post in the ask ubuntu StackExchange forums, audacitywhich outlined two solutions: Audacity, an open source visual sound editor I was already intimately familiar with, and SoX, which was billed as “the Swiss Army knife of sound processing programs”.

SoX: the Swiss Army knife of sound processing programs

SoX

SoX is a command line tool for processing audio files, and the more I read about it, the more I liked it.  Normalizing an audio file used to be a two-step process in SoX: running a command once in an analysis mode to get the maximum volume of the file, and a second time to boost that volume to the maximum possible without distortion. However, with version 14.3 of SoX, its developers made all of that possible in one single command:

sox --norm infile outfile

I briefly pondered cloning SoX’s git repository and building from source, but I realized that chances were slight that I was going to be making changes to SoX; I just wanted it as a command line tool.  So I turned to one of the most wonderful things you can have on your Mac: Homebrew.

Homebrew is a package manager for OS X that’s all git and ruby under the hood, and it has a beer theme! It installs software in a “Cellar”. It doesn’t have packages, it has “bottles.  It even uses the beer emoji: ????

Installing new software with Homebrew is painfully easy:

brew install sox

Once I got SoX installed, modifying my code to used it was dead easy.

Finally, I decided to tackle the big thing that I wasn’t doing in the program itself: copying files up to the webserver. At first I looked at Net::Scp, but for some reason I couldn’t get it to work (it kept telling me that my remote directory didn’t exist).  So I switched over to Net::OpenSSH, and I was able to get the copy working.

I also cleaned up the code a lot, and added a ton of comments.  I want this code to be able to document itself, so it’s really obvious what I’m doing and why. Some would say that once a program is working, it’s done.  But when I’m writing code for myself, it’s not done until I’ve commented the heck out of it, because I know myself: a year later, I’m going to come back to this code and think “What was I smoking when I wrote this?”

I doubt I’ll think that when I come back to this code.

[code language=”perl”]
#!/Users/packy/perl5/perlbrew/perls/perl-5.22.0/bin/perl -w

use DBI;
use Data::Dumper::Concise;
use DateTime;
use DateTime::Format::Mail;
use LWP::Simple;
use Net::OpenSSH;
use URI;
use XML::RSS;
use strict;

use feature qw( say state );

# define all the things!
use constant {
URL => ‘http://www.npr.org/rss/podcast.php?id=500005’,
TITLE_ADD => ‘ (filtered by packy)’,
TITLE_MAX => 40, # characters
SLEEP_FOR => 120, # seconds (2 minutes)
MAX_RETRIES => 10,
KEEP_DAYS => 7,

REMOTE_HOST => ‘www.dardan.com’,
REMOTE_USER => ‘dardanco’,
REMOTE_DIR => ‘www/packy/’,

MEDIA_URL => ‘https://packy.dardan.com/npr’,

TZ => ‘America/New_York’,
LOGFILE => ‘/tmp/npr-news.txt’,
XMLFILE => ‘/tmp/npr-news.xml’,
IN_DIR => ‘/tmp/incoming’,
OUT_DIR => ‘/tmp/outgoing’,
DATAFILE => ‘/Users/packy/data/filter-npr-news.db’,

SOX_BINARY => ‘/usr/local/bin/sox’,
};

# list of times we want – different times on weekends
my @keywords = is_weekday() ? qw( 7AM 8AM 12PM 6PM 7PM )
: qw( 7AM 12PM 7PM );

my $dbh = get_dbh(); # used in a couple places, best to be global

my $rss; # these two vars are only used in the main code block,
my $items; # but can’t be scoped to the foreach loop

# since, for cosmetic reasons, we’re starting the count at 1, we need
# to loop up to MAX_RETRIES + 1; otherwise, we’ll only have the first
# attempt and then (MAX_RETRIES – 1). If I’d called the constant
# MAX_ATTEMPTS then it would make sense to start at zero…
foreach my $retry (1 .. MAX_RETRIES + 1) {

# get the RSS
write_log("Fetching " . URL);
my $content = get(URL);

# parse the RSS using a subclass of XML::RSS
$rss = XML::RSS::NPR->new();
$rss->parse($content);
write_log("Parsed XML");

$items = $rss->_get_items;

# if a new show was published in the feed, we don’t need to wait
# in a loop for a new one
last unless same_show_as_last_time( $items );

# we don’t want the script to wait forever – if no new episode
# appears after a maximum number of retries, give up and generate
# the feed with the episodes we have
if ($retry > MAX_RETRIES) {
write_log("MAX_RETRIES (".MAX_RETRIES.") exceeded");
last;
}

# for debugging purposes, I want to be able to not have the script
# sleep, and the choices were add command line switch processing
# or check an environment variable. This was the simpler option.
if ($ENV{NPR_NOSLEEP}) {
last;
}

# log the fact that we’re sleeping so we can observe what the
# script is doing while it’s running
write_log("Sleeping for ".SLEEP_FOR." seconds…");

# since I usually want to listen to these podcasts when I’m away
# from my desktop computer, copy the log file up to the webserver
# so I can check on it remotely. this way, if it’s spending an
# inordinate amount of time waiting for a new episode, I can see
# that from my phone’s browser…
push_log_to_remotehost();

# actually sleep
sleep SLEEP_FOR;

# and note which number retry this is
write_log("Trying RSS feed again (retry #$retry)");
}

# test to see if the new item matches our inclusion criteria, and then
# fill the item list with items we’ve cached in our database
get_items_from_database( $items );

# make new RSS feed devoid of the original items… ok, ITEM
$rss->clear_items;

foreach my $item ( @$items ) {
$rss->add_item(%$item);
}

re_title($rss);

write_log("Writing RSS XML to " . XMLFILE);
open my $fh, ‘>’, XMLFILE;
say {$fh} $rss->as_string;
close $fh;
push_xml_to_remotehost();

#################################### subs ####################################

sub get_items_from_database {
my $items = shift;

# build the regex for matching desired episodes from keywords
my $re = join "|", @keywords;
$re = qr/\b(?:$re)\b/i;

my $insert = $dbh->prepare("INSERT INTO shows (pubdate, item) ".
" VALUES (?, ?)");

my $exists_in_db = $dbh->prepare("SELECT COUNT(*) FROM shows ".
" WHERE pubdate = ?");

# I know the feed only has the one item in it, but it SHOULD have
# more, so let’s go through the motions of checking each item

foreach my $item (@$items) {

# pawn off the specifics of how we get the information to a sub
my ($epoch, $title) = item_info($item);

# again, for debugging purposes, I wanted to be able to not
# have the script skip the current item, and the choices were
# add command line switch processing or check an environment
# variable. This was the simpler option.

if ($title !~ /$re/ &amp;&amp; ! $ENV{NPR_NOSKIP}) {
write_log("’$title’ doesn’t match $re; skipping");
next;
}

# check to see if we already have it in the DB
$exists_in_db->execute($epoch);
my ($exists) = $exists_in_db->fetchrow;

if ($exists > 0) {
write_log("’$title’ already in database; skipping");
next;
}

# the NPR news podcast is notoriously bad at normalizing the
# volume of its broadcasts; some are easy to hear and some are
# so quiet it’s impossible to ehar them when listening on a
# city street, so, let’s normalize them to a maximum volume

normalize_audio($item);

write_log("Adding ‘$title’ to database");

# it’s easier to store the data in the episode cache table as
# a perl representation of the parsed data than it is to
# serialize it back into XML and then re-parse it when we need
# it again.
$insert->execute($epoch, Dumper($item));
}

# go through the database and dump episodes that are older than
# our retention period. Since we’re using epoch time (seconds
# since some date, usually midnight 1970-01-01) as the key to our
# episode cache table, it’s really easy to determine which
# episodes are too old

my $now = DateTime->now();
my $too_old = $now->epoch – (KEEP_DAYS * 24 * 60 * 60);
$dbh->do("DELETE FROM shows WHERE pubdate < $too_old");

# now let’s fetch the episodes from the episode cache table in
# oldest-first order. Again, since we’re keyed on the episode’s
# publish date in epoch time, we can do this with a simple numeric
# sort.
my $query = $dbh->prepare("SELECT * FROM shows ORDER BY pubdate");
$query->execute();

@$items = ();
while ( my($pubdate, $item) = $query->fetchrow ) {

# just blindly evaluating text is a potential security problem,
# but I know all these entries came from me writing dumper-ed code,
# so I feel safe in doing so…
my $evaled = eval $item;

push @$items, $evaled;

# log which episodes we’re putting into the feed
my ($epoch, $title) = item_info($evaled);
write_log("Fetched ‘$title’ from database; adding to feed");
}
}

sub same_show_as_last_time {
my $items = shift;

# so we know when the feed is late in publishing a new item,
# we have a table that stores the publication date of the last
# episode we saw. It also stores the title of the episode so
# we can log which episode it was.

my $get_last_show = $dbh->prepare("SELECT * FROM last_show");

# get the information for the current episode
my ($epoch, $title) = item_info($items->[0]);

# fetch the last epsiode from the DB
$get_last_show->execute;
my ($last_time, $last_title) = $get_last_show->fetchrow;

# save the episode we just fetched for next time
my $update = $dbh->prepare("UPDATE last_show SET pubdate = ?, title = ? ".
" WHERE pubdate = ?");
$update->execute($epoch, $title, $last_time);

# now compare the current episode with the one we got from the DB
my $is_same = ($last_time == $epoch);

if ($is_same) {
write_log("RSS feed has not updated since ‘$last_title’ was published");
}

return $is_same;
}

#################################### audio ####################################

sub filename_from_uri {
my $uri = shift;

# abstract out the complexities of fetching the filename from a
# URI so the code will read easier; in this case, we’re
# instantiating a new URI class object and calling path_segments()
# to get the segments of the path, and then returning the last
# element, which is going to be the filename.

return( ( URI->new($uri)->path_segments )[-1] );
}

sub normalize_audio {
my $item = shift;
my $uri = item_url($item);
my $file = filename_from_uri($uri);

# perl idiom for "if directory doesn’t exist, make it"
-d IN_DIR or mkdir IN_DIR;
-d OUT_DIR or mkdir OUT_DIR;

# construct fill pathnames to the file we’re downloading and
# then normalizing to
my $infile = join ‘/’, IN_DIR, $file;
my $outfile = join ‘/’, OUT_DIR, $file;

# fetch the MP3 file using LWP::Simple
my $code = getstore($uri, $infile);
write_log("Fetched ‘$uri’ to $infile; RESULT $code");
return unless $code == 200;

# if, for some reason, we don’t have the program to normalize audio,
# crash with a message complaining about it being missing
-x SOX_BINARY
or die "no executable at " . SOX_BINARY;

# call SoX to normalize the audio
write_log("Normalizing $infile to $outfile");
system join(q{ }, SOX_BINARY, ‘–norm’, $infile, $outfile);

# the feed doesn’t publish an item length in bytes, but it really
# ought to, so let’s get the size of the MP3 file.
my $size = -s $outfile || 0;

# re-write the bits of the item we’re changing
item_url($item, join ‘/’, MEDIA_URL, $file);
item_length($item, $size);

# send the normalized MP3 file up to the webserver
push_media_to_remotehost($outfile);

# clean up after ourselves
unlink $infile;
unlink $outfile;
}

#################################### db ####################################

sub get_dbh {
my $file = DATAFILE;

# check to see if the datafile exists BEFORE we connect to it
my $exists = -f $file;

my $dbh = DBI->connect(
"dbi:SQLite:dbname=$file",
"",
"",
{ RaiseError => 1}
) or die $DBI::errstr;

# if the datafile didn’t exist before we connected to it, let’s set up
# the schema we’re using
unless ($exists) {
$dbh->do("CREATE TABLE shows (pubdate INTEGER PRIMARY KEY, item TEXT)");
$dbh->do("CREATE INDEX shows_idx ON shows (pubdate);");
$dbh->do("CREATE TABLE last_show (pubdate INTEGER PRIMARY KEY, ".
" title TEXT)");
}

return $dbh;
}

#################################### time ####################################

sub now {
# set the time zone in the DateTime object, so we get non-UTC time
return DateTime->now( time_zone => TZ );
}

sub is_weekday {
# makes our code easier to read
return now()->day_of_week < 6;
}

################################### copying ###################################

sub push_to_remotehost {
my ($from, $to) = @_;

my $connect = join ‘@’, REMOTE_USER, REMOTE_HOST;

state $ssh = Net::OpenSSH->new($connect);

write_log("Copying $from to $connect:$to");

if ( $ssh->scp_put($from, $to) ) {
write_log("Copy success");
}
else {
write_log("COPY ERROR: ". $ssh->error);
}
}

# helper functions to make the code easier to read

sub push_xml_to_remotehost {
push_to_remotehost(XMLFILE, REMOTE_DIR);
}

sub push_log_to_remotehost {
push_to_remotehost(LOGFILE, REMOTE_DIR);
}

sub push_media_to_remotehost {
my $from = shift;
push_to_remotehost($from, REMOTE_DIR . ‘npr/’);
}

################################### logging ###################################

sub write_log {
# I’m opening and closing the logfile every time I write to it so
# it’s easier for external processes to monitor the progress of
# this script
open my $logfile, ‘>>’, LOGFILE;

my $now = now();
my $ts = $now->ymd . q{ } . $now->hms . q{ };

# I don’t write multiple lines yet, but I might want to!
foreach my $line ( @_ ) {
say {$logfile} $ts . $line;
}

close $logfile;
}

BEGIN {
unlink LOGFILE; # write a new log each time we run
write_log(‘Started run’); # log that the run has started

# register a DIE handler that will write whatever message I die() with
# to our logfile so I can see it in the logs
$SIG{__DIE__} = sub {
my $err = shift;
write_log(‘FATAL: ‘.$err);
# if we die(), after this runs, the END block will be executed!
};
}

END {
# when the program finishes, log that
write_log(‘Finished run’);

# and, so I can see these logs remotely, push them up to the webserver
push_log_to_remotehost();
}

##################################### XML #####################################

sub re_title {
my $rss = shift;

# append some text to the channel’s title so I can differentiate
# this feed from the original feed in my podcast app

my $existing_title = $rss->channel(‘title’);
my $add_len = length(TITLE_ADD);

if (length($existing_title) + $add_len > TITLE_MAX) {
$existing_title = substr($existing_title, 0, TITLE_MAX – $add_len – 1);
}

$rss->channel(‘title’ => $existing_title . TITLE_ADD);
}

sub item_info {
state $mail = DateTime::Format::Mail->new; # only initialized once!

my $item = shift;
my $title = fix_whitespace($item->{title});
my $dt = $mail->parse_datetime($item->{pubDate});
my $epoch = $dt->epoch;
return $epoch, $title;
}

sub fix_whitespace {
my $string = shift;

# multiple whitespace compressed to a single space
$string =~ s{\s+}{ };

# remove leading and trailing spaces
$string =~ s{^\s+}{}; $string =~ s{\s+$}{};

return $string;
}

# let’s define some pseudo-accessors (since these are unblessed
# hashes, not objects) that will make our code easier to read

sub enclosure_pseudo_accessor {
my $hash = shift;
my $key = shift;
if (@_) {
$hash->{enclosure}->{$key} = shift;
}
return $hash->{enclosure}->{$key};
}

sub item_url {
my $hash = shift;
enclosure_pseudo_accessor($hash, ‘url’, @_);
}

sub item_length {
my $hash = shift;
enclosure_pseudo_accessor($hash, ‘length’, @_);
}

# since XML::RSS doesn’t provide a method to clear out the items in an
# already-parsed feed, I’m creating a subclass to provide that
# functionality rather than just executing code that manipulates the
# internal data structure of the object in my main program

package XML::RSS::NPR;
use base qw( XML::RSS );

sub clear_items {
my $self = shift;
$self->{num_items} = 0;
$self->{items} = [];
}

# since we’re creating a subclass, we can override the default XML
# modules that are used to be the ones we need – no calling
# add_module() from our main program!

sub _get_default_modules {
return {
‘http://www.npr.org/rss/’ => ‘npr’,
‘http://api.npr.org/nprml’ => ‘nprml’,
‘http://www.itunes.com/dtds/podcast-1.0.dtd’ => ‘itunes’,
‘http://purl.org/rss/1.0/modules/content/’ => ‘content’,
‘http://purl.org/dc/elements/1.1/’ => ‘dc’,
};
}

__END__
[/code]

Read it on GitHub: filter-npr-news