Perl Weekly Challenge: Completing a Third of an Appearance

Tonight’s musical accompaniment was Billy Joel: The 100th – Live at Madison Square Garden. Without being interrupted in the middle of Piano Man.

So, let’s hope we don’t break away to out local affiliate before the end of this week’s Perl Weekly Challenge!

Task 1: 33% Appearance

You are given an array of integers, @ints.

Write a script to find an integer in the given array that appeared 33% or more. If more than one found, return the smallest. If none found then return undef.

Example 1

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

1 appeared 1 times.
2 appeared 2 times.
3 appeared 4 times.

3 appeared 50% (>33%) in the given array.

Example 2

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

1 appeared 2 times.

1 appeared 100% (>33%) in the given array.

Example 3

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

1 appeared 1 times.
2 appeared 1 times.
3 appeared 1 times.

Since all three appeared 33.3% (>33%) in the given array.
We pick the smallest of all.

Approach

Ok, we’re counting how many times individual integers appear in an array. That sounds like a hash to me. Make a pass through the array, counting the occurrences of each integer, and when we’re done we divide by the number of elements in the array to get percentages. We could then use something like min to find the smallest.

BUT… we know before we loop through the array how many times an integer will have to appear to meet the threshold. We’re not looking for the integer that occurred the most times, only for the smallest one that occurred at least 1/3 of the time. So we pre-calculate the 1/3 value, and as we’re counting, if the count for an integer is greater than the 1/3 value and smaller than the last integer whose count was greater than the 1/3 value, we save it as the output value.

Raku

sub oneThirdAppearance(@ints) {
  my Int $smallest;
  my Rat $oneThird = @ints.elems / 3;
  my Int %seen;
  for @ints -> $i {
    if (++%seen{$i} >= $oneThird) {
      if (! $smallest.defined || $i < $smallest) {
        $smallest = $i;
      }
    }
  }
  return $smallest;
}
$ raku/ch-1.raku
Example 1:
Input: @ints = (1, 2, 3, 3, 3, 3, 4, 2)
Output: 3

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

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

View the entire Raku script for this task on GitHub.

Perl

Because an array evaluated in a scalar context returns the size of the array, all we need to determine the oneThird threshold is to fivide the array by 3:

sub oneThirdAppearance(@ints) {
  my $smallest;
  my $oneThird = @ints / 3;
  my %seen;
  foreach my $i ( @ints ) {
    if (++$seen{$i} >= $oneThird) {
      if (! defined($smallest) || $i < $smallest) {
        $smallest = $i;
      }
    }
  }
  return $smallest;
}

View the entire Perl script for this task on GitHub.

Python

As always, when I’m counting things in Python, I use the Counter type in the collections module.

from collections import Counter

def oneThirdAppearance(ints):
  smallest = None
  oneThird = len(ints) / 3
  seen = Counter()
  for i in ints:
    seen[i] += 1
    if seen[i] >= oneThird:
      if smallest is None or i < smallest:
        smallest = i
  return smallest

View the entire Python script for this task on GitHub.


Task 2: Completing Word

You are given a string, $str, containing alphanumeric characters and an array of strings (alphabetic characters only), @str.

Write a script to find the shortest completing word. If none found return empty string.

A completing word is a word that contains all the letters in the given string, ignoring space and number. If a letter appeared more than once in the given string then it must appear the same number or more in the word.

Example 1

Input: $str = 'aBc 11c'
       @str = ('accbbb', 'abc', 'abbc')
Output: 'accbbb'

The given string contains following, ignoring case and number:
a 1 times
b 1 times
c 2 times

The only string in the given array that satisfies the condition is 'accbbb'.

Example 2

Input: $str = 'Da2 abc'
       @str = ('abcm', 'baacd', 'abaadc')
Output: 'baacd'

The given string contains following, ignoring case and number:
a 2 times
b 1 times
c 1 times
d 1 times

The are 2 strings in the given array that satisfies the condition:
'baacd' and 'abaadc'.

Shortest of the two is 'baacd'

Example 3

Input: $str = 'JB 007'
       @str = ('jj', 'bb', 'bjb')
Output: 'bjb'

The given string contains following, ignoring case and number:
j 1 times
b 1 times

The only string in the given array that satisfies the condition is 'bjb'.

Approach

I’m sure there’s a clever way to accomplish this, but I’m just going to plow through a straightforward way. Counting the letters again seems like a job for a hash, and we’re going to have to generate this hash not only for $str but for each string in @str, so it seems useful to make a function for generating the hash. Then we compare the hash generated by $str against the hashes for each of the strings in @str: if there’s any letters missing, or if a letter in the string doesn’t occur at least as many times it does in the target, the string is disqualified. Finally, we only keep the shortest string that met the criteria.

Raku

Last week, reading laurent_r’s solutions for PWC 264’s task 1, I saw a couple of things what I wanted to take note of: rather than using .split('', :skip-empty) to split a string into a list of characters, he used .comb. Also, he used grep with a lower case character class to filter out just the lower case characters in the input. If we pass $str.lc.comb into the grep, we’ll just get back just the letters, regardless of case.

sub letterCounts($str) {
  my %counts;
  map { %counts{$_}++ }, (grep { / <lower> / }, $str.lc.comb);
  return %counts;
}

sub completingWord($str, @str) {
  my %target = letterCounts($str);
  my $shortest;
  CANDIDATE: for @str -> $s {
    my %candidate = letterCounts($s);
    for %target.kv -> $c, $i {
      next CANDIDATE # skip this candidate
        unless %candidate{$c}:exists # this letter exists
            && %candidate{$c} >= $i; # at least as many times
    }
    if (! $shortest.defined || $s.chars < $shortest.chars) {
      $shortest = $s;
    }
  }
  return $shortest // q{};
}
$ raku/ch-2.raku
Example 1:
Input: $str = 'aBc 11c'
       @str = ('accbbb', 'abc', 'abbc')
Output: 'accbbb'

Example 2:
Input: $str = 'Da2 abc'
       @str = ('abcm', 'baacd', 'abaadc')
Output: 'baacd'

Example 3:
Input: $str = 'JB 007'
       @str = ('jj', 'bb', 'bjb')
Output: 'bjb'

View the entire Raku script for this task on GitHub.

Perl

My first instinct was to use each %target in Perl the same way I used %target.kv, but when I tried, I discovered that I’d forgotten a big caveat of each:

The iterator used by each is attached to the hash or array, and is shared between all iteration operations applied to the same hash or array. Thus all uses of each on a single hash or array advance the same iterator location. All uses of each are also subject to having the iterator reset by any use of keys or values on the same hash or array, or by the hash (but not array) being referenced in list context. This makes each-based loops quite fragile: it is easy to arrive at such a loop with the iterator already part way through the object, or to accidentally clobber the iterator state during execution of the loop body. It’s easy enough to explicitly reset the iterator before starting a loop, but there is no way to insulate the iterator state used by a loop from the iterator state used by anything else that might execute during the loop body. To avoid these problems, use a foreach loop rather than whileeach.

When I had while ( my($c, $i) = each %target ), it would only loop through %target once, and for subsequent candidates it would skip the loop entirely.

sub letterCounts($str) {
  my %counts;
  map { $counts{$_}++ } grep { /[a-z]/ } split //, lc($str);
  return %counts;
}

sub completingWord($str, @str) {
  my %target = letterCounts($str);
  my $shortest;
  CANDIDATE: foreach my $s ( @str ) {
    my %candidate = letterCounts($s);
    foreach my $c ( keys %target ) {
      my $i = $target{$c};
      next CANDIDATE # skip this candidate
        unless exists $candidate{$c} # this letter exists
            && $candidate{$c} >= $i; # at least as many times
    }
    if (! defined($shortest) || length($s) < length($shortest)) {
      $shortest = $s;
    }
  }
  return $shortest // q{};
}

View the entire Perl script for this task on GitHub.

Python

In Python, we can make the string all lowercase with lower() and filter for just letters by using isalpha(). Because we can’t break out to an outer loop from inside an inner loop, I’m using an isCandidate boolean flag to track whether a candidate is still valid to be considered the shortest candidate.

from collections import Counter

def letterCounts(strVal):
  counts = Counter()
  for c in strVal.lower():
    if c.isalpha():
      counts[c] += 1
  return counts

def completingWord(targetStr, candidateStrs):
  targetCounts = letterCounts(targetStr)
  shortest = None
  for s in candidateStrs:
    candidateCounts = letterCounts(s)
    isCandidate = True
    for c, i in targetCounts.items():
      #    this letter does not exist
      if ( not c in candidateCounts
           or # occurs fewer times
           candidateCounts[c] < i): 
         isCandidate = False
    if (isCandidate and 
        (shortest is None or len(s) < len(shortest))):
      shortest = s
  return shortest

View the entire Python script for this task on GitHub.


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

Perl Weekly Challenge: I’m The Greatest Target!

The first task in this challenge started with the words “Greatest English”. When I think of “greatest” and “English”, it should be obvious that my mind immediately jumps to… Ringo Starr. It may be John Lennon’s song, but it was on Ringo’s album.

Anyway, enough Beatles blather. Onward to PWC 264!

Task 1: Greatest English Letter

You are given a string, $str, made up of only alphabetic characters [a..zA..Z].

Write a script to return the greatest english letter in the given string.

A letter is greatest if it occurs as lower and upper case. Also letter ‘b’ is greater than ‘a’ if ‘b’ appears after ‘a’ in the English alphabet.

Example 1

Input: $str = 'PeRlwEeKLy'
Output: L

There are two letters E and L that appears as lower and upper.
The letter L appears after E, so the L is the greatest english letter.

Example 2

Input: $str = 'ChaLlenge'
Output: L

Example 3

Input: $str = 'The'
Output: ''

Approach

I saw this and I figured that I could accomplish this with a single pass through the string by maintaining a hash of the characters we’d seen already, and if we’d already seen the swapped case version of the character, we could add it to a list of “greatest” characters. Once we’d gone through the string, we could just use a max function to get the greatest character in that last and return it.

Raku

I already knew how to do this in Perl—using the tr operator—and I figured there would be a corresponding way to do it in Raku. Sure enough, the Str class has a trans method. In addition, the max method on the Any class doesn’t care what type the elements are because it uses the smart cmp operator semantics to find the largest element in the List.

sub greatestEnglishLetter($str) {
  my %seen;
  my @greatest;

  # find the characters that exist as both
  # upper and lower case in the string
  for $str.split('', :skip-empty) -> $c {

    # note that we've seen the character
    %seen{$c} = 1;

    # swap the case of the character
    my $C = $c.trans(
      ['a' .. 'z', 'A' .. 'Z'] => ['A' .. 'Z', 'a' .. 'z']
    );

    # if we've seen the swapped case version of the char,
    # add the uppercase version to our greatest hits
    @greatest.push: $c.uc if %seen{$C}:exists;
  }

  # if we found greatest characters,
  # return the greater of them
  if (@greatest) {
    return @greatest.max;
  }
  # otherwise, return something that
  # represents an empty result
  return q{''};
$ raku/ch-1.raku
Example 1:
Input: $str = 'PeRlwEeKLy'
Output: L

Example 2:
Input: $str = 'ChaLlenge'
Output: L

Example 3:
Input: $str = 'The'
Output: ''

View the entire Raku script for this task on GitHub.

Perl

The Perl version is a little more compact. We do need to pull in the maxstr function from List::Util, however. Note that I’m using the non-destructive /r option on the tr operator.

use List::Util qw( maxstr );

sub greatestEnglishLetter($str) {
  my %seen;
  my @greatest;

  # find the characters that exist as both
  # upper and lower case in the string
  foreach my $c ( split //, $str ) {

    # note that we've seen the character
    $seen{$c} = 1;

    # swap the case of the character
    my $C = ($c =~ tr/a-zA-Z/A-Za-z/r);

    # if we've seen the swapped case version of the char,
    # add the uppercase version to our greatest hits
    push @greatest, uc($c) if exists $seen{$C};
  }

  # if we found greatest characters,
  # return the greater of them
  if (@greatest) {
    return maxstr(@greatest);
  }
  # otherwise, return something that
  # represents an empty result
  return q{''};
}

View the entire Perl script for this task on GitHub.

Python

Because Python loves to borrow all of Perl’s useful functionality, I knew there had to be a tr equivalent somewhere… and I found it in the translate method on the Str type. There’s even a static maketrans method on the Str type that allows you to create a translation table you can pass into translate. The syntax isn’t as concise as Perl’s (or Raku’s, for that matter), but it wasn’t too bad.

# make a translation table to switch the case of
# English letters
transTable = str.maketrans(
  'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ',
  'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
)

def greatestEnglishLetter(strVar):
  seen = {}
  greatest = []

  # find the characters that exist as both
  # upper and lower case in the string
  for c in strVar:

    # note that we've seen the character
    seen[c] = 1

    # swap the case of the character
    C = c.translate(transTable)

    # if we've seen the swapped case version of the char,
    # add the uppercase version to our greatest hits
    if C in seen:
        greatest.append(c.upper())

  # if we found greatest characters,
  # return the greater of them
  if greatest:
    return max(greatest)

  # otherwise, return something that
  # represents an empty result
  return "''"

View the entire Python script for this task on GitHub.


Task 2: Target Array

You are given two arrays of integers, @source and @indices. The @indices can only contains integers 0 <= i < size of @source.

Write a script to create target array by insert at index $indices[i] the value $source[i].

Example 1

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

@source  @indices  @target
0        0         (0)
1        1         (0, 1)
2        2         (0, 1, 2)
3        2         (0, 1, 3, 2)
4        1         (0, 4, 1, 3, 2)

Example 2

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

@source  @indices  @target
1        0         (1)
2        1         (1, 2)
3        2         (1, 2, 3)
4        3         (1, 2, 3, 4)
0        0         (0, 1, 2, 3, 4)

Example 3

Input: @source  = (1)
       @indices = (0)
Output: (1)

Approach

This is just a single loop through the @indices list to build the @target list. The “trickiest” part is inserting into the @target list at arbitrary locations, not just the beginning or the end.

Raku

Fortunately, in Raku there’s an Array routine for that: splice. It’s supposed to replace elements in an array, but if you specify a zero length for the replacement, it winds up just inserting elements without removing any.

sub targetArray(@source, @indices) {
  my @target;
  my @explain;

  for 0..@indices.end -> $i {
    @target.splice(@indices[$i], 0, @source[$i]);
    @explain.push: [
      @source[$i], @indices[$i], @target.clone
    ];
  }
  return @target, @explain;
}
$ raku/ch-2.raku
Example 1:
Input: @source   = (0, 1, 2, 3, 4)
       @indicies = (0, 1, 2, 2, 1)
Output: (0, 4, 1, 3, 2)

@source @indices @target
0       0        (0)
1       1        (0, 1)
2       2        (0, 1, 2)
3       2        (0, 1, 3, 2)
4       1        (0, 4, 1, 3, 2)

Example 2:
Input: @source   = (1, 2, 3, 4, 0)
       @indicies = (0, 1, 2, 3, 0)
Output: (0, 1, 2, 3, 4)

@source @indices @target
1       0        (1)
2       1        (1, 2)
3       2        (1, 2, 3)
4       3        (1, 2, 3, 4)
0       0        (0, 1, 2, 3, 4)

Example 3:
Input: @source   = (1)
       @indicies = (0)
Output: (1)

@source @indices @target
1       0        (1)

View the entire Raku script for this task on GitHub.

Perl

For Perl the biggest change is passing around array references rather than arrays.

sub targetArray($source, $indices) {
  my @target;
  my @explain;

  foreach my $i ( 0 .. $#{$indices}) {
    splice(@target, $indices->[$i], 0, $source->[$i]);
    push @explain, [
      $source->[$i], $indices->[$i], [ @target ]
    ];
  }
  return \@target, \@explain;
}

View the entire Perl script for this task on GitHub.

Python

In Python, the method for inserting elements into lists at arbitrary locations is named, appropriately enough, insert.

def targetArray(source, indices):
  target = []
  explain = []

  for i in range(len(indices)):
    target.insert(indices[i], source[i])
    explain.append([
      source[i], indices[i], target.copy()
    ])
  return target, explain

View the entire Python script for this task on GitHub.


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

Perl Weekly Challenge: Merge the Target Index Items

For some reason, my brain conflated “index” with “reflex”, so this week’s musical theme is The Reflex by Duran Duran. Yeah, I remember when that was on the radio.

Onward to Perl Weekly Challenge 263!

Task 1: Target Index

You are given an array of integers, @ints and a target element $k.

Write a script to return the list of indices in the sorted array where the element is same as the given target element.

Example 1

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

Sorted array: (1, 2, 2, 3, 4, 5)
Target indices: (1, 2) as $ints[1] = 2 and $ints[2] = 2

Example 2

Input: @ints = (1, 2, 4, 3, 5), $k = 6
Output: ()

No element in the given array matching the given target.

Example 3

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

Sorted array: (1, 2, 2, 3, 4, 5)
Target index: (4) as $ints[4] = 4

Approach

The approach here is pretty straightforward: sort the list, then scan for entries where the value matches the target. There’s probably a clever way to do it, but it’s not coming to me, and I’ve always stressed ease of implementation and comprehension over cleverness in my solutions.

Raku

In Raku, we can use the kv routine on lists to loop over the sorted list of ints and have both the index and the value at that index.

sub targetIndex($k, @ints) {
  my @sorted = @ints.sort;
  my $explain = 'Sorted array: (' ~ @sorted.join(', ') ~ ")\n";

  my @output;
  for @sorted.kv -> $i, $v {
    next unless $v == $k;
    @output.push($i);
  }
  if (@output == 0) {
    $explain ~= 'No element in the given array matching '
             ~  'the given target.';
  }
  else {
    $explain ~= 'Target indices: (' ~ @output.join(', ')
             ~  ') as ';
    my @explain_indices = @output.map({ "\$ints[$_] = $k"});
    $explain ~= @explain_indices.join(' and ');
  }
  return $explain, @output;
}
$ raku/ch-1.raku
Example 1:
Input: @ints = (1, 5, 3, 2, 4, 2), $k = 2
Output: (1 2)

Sorted array: (1, 2, 2, 3, 4, 5)
Target indices: (1, 2) as $ints[1] = 2 and $ints[2] = 2

Example 2:
Input: @ints = (1, 2, 4, 3, 5), $k = 6
Output: ()

Sorted array: (1, 2, 3, 4, 5)
No element in the given array matching the given target.

Example 3:
Input: @ints = (5, 3, 2, 4, 2, 1), $k = 4
Output: (4)

Sorted array: (1, 2, 2, 3, 4, 5)
Target indices: (4) as $ints[4] = 4

View the entire Raku script for this task on GitHub.

Perl

In Perl, however, we just loop over the indices as $i and use $sorted[$i] to access the values at those indices.

sub targetIndex($k, @ints) {
  my @sorted = sort @ints;
  my $explain = 'Sorted array: (' . join(', ', @sorted) . ")\n";

  my @output;
  foreach my $i (0 .. $#sorted) {
    next unless $sorted[$i] == $k;
    push @output, $i;
  }
  if (@output == 0) {
    $explain .= 'No element in the given array matching '
             .  'the given target.';
  }
  else {
    $explain .= 'Target indices: (' . join(', ', @output)
             .  ') as ';
    my @explain_indices = map { "\$ints[$_] = $k"} @output;
    $explain .= join(' and ', @explain_indices);
  }
  return $explain, @output;
}

View the entire Perl script for this task on GitHub.

Python

In Python, we get to use the enumerate function I last used back in PWC251.

def comma_join(arr):
    return ', '.join(map(lambda i: str(i), arr))

def targetIndex(k, ints):
  sortedArray = sorted(ints)
  explain = f'Sorted array: ({comma_join(sortedArray)})\n'

  output = []
  for i, v in enumerate(sortedArray):
    if v == k:
      output.append(i)
  
  if len(output) == 0:
    explain += 'No element in the given array matching '
    explain += 'the given target.'
  else:
    explain += f'Target indices: ({comma_join(output)}) as '
    explain_indices = [ f'$ints[{i}] = {k}' for i in output ]
    explain += ' and '.join(
       map(lambda i: str(i), explain_indices)
    )
  return explain, output

View the entire Python script for this task on GitHub.


Task 2: Merge Items

You are given two 2-D array of positive integers, $items1 and $items2 where element is pair of (item_id, item_quantity).

Write a script to return the merged items.

Example 1

Input: $items1 = [ [1,1], [2,1], [3,2] ]
       $items2 = [ [2,2], [1,3] ]
Output: [ [1,4], [2,3], [3,2] ]

Item id (1) appears 2 times: [1,1] and [1,3]. Merged item now (1,4)
Item id (2) appears 2 times: [2,1] and [2,2]. Merged item now (2,3)
Item id (3) appears 1 time: [3,2]

Example 2

Input: $items1 = [ [1,2], [2,3], [1,3], [3,2] ]
       $items2 = [ [3,1], [1,3] ]
Output: [ [1,8], [2,3], [3,3] ]

Example 3

Input: $items1 = [ [1,1], [2,2], [3,3] ]
       $items2 = [ [2,3], [2,4] ]
Output: [ [1,1], [2,9], [3,3] ]

Approach

This feels like a wonderful thing to use a hash for: as we loop through the pairs and use the item_id as the hash key and just add item_quantity to the hash value.

Raku

sub mergeItems(@items1, @items2) {
  my %merged;
  # loop over the items and add item_quantities (element 1)
  # to the count for each item_id (element 0)
  for (slip(@items1), slip(@items2)) -> @i {
    %merged{@i[0]} += @i[1];
  }
  # re-render the hash as a 2D array
  return %merged.keys.sort.map({ [ $_, %merged{$_} ] });
}
$ raku/ch-2.raku
Example 1:
Input: $items1 = [ [1,1], [2,1], [3,2] ]
       $items2 = [ [2,2], [1,3] ]
Output: [ [1,4], [2,3], [3,2] ]

Example 2:
Input: $items1 = [ [1,2], [2,3], [1,3], [3,2] ]
       $items2 = [ [3,1], [1,3] ]
Output: [ [1,8], [2,3], [3,3] ]

Example 3:
Input: $items1 = [ [1,1], [2,2], [3,3] ]
       $items2 = [ [2,3], [2,4] ]
Output: [ [1,1], [2,9], [3,3] ]

View the entire Raku script for this task on GitHub.

Perl

sub mergeItems($items1, $items2) {
  my %merged;
  # loop over the items and add item_quantities (element 1)
  # to the count for each item_id (element 0)
  foreach my $i (@$items1, @$items2) {
    $merged{$i->[0]} += $i->[1];
  }
  # re-render the hash as a 2D array
  return [ map { [ $_, $merged{$_} ] } sort keys %merged ];
}

View the entire Perl script for this task on GitHub.

Python

As always, when I’m counting things in Python, I use the Counter type in the collections module. I also found that the chain function in itertools:

Make an iterator that returns elements from the first iterable until it is exhausted, then proceeds to the next iterable, until all of the iterables are exhausted. Used for treating consecutive sequences as a single sequence. 

def mergeItems(items1, items2):
  merged = Counter()
  # loop over the items and add item_quantities (element 1)
  # to the count for each item_id (element 0)
  for i in chain(items1, items2):
    merged[ i[0] ] += i[1]

  # re-render the hash as a 2D array
  return [ [i, v] for i, v in merged.items() ]

View the entire Python script for this task on GitHub.


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

Perl Weekly Challenge: Counting to the Max!

Tonight’s music doesn’t have anything to do with the tasks; it’s just the soundtrack while I was writing up, as my wife calls it, “my cooking blog”.

Onward to the solutions for Perl Weekly Challenge 262!

Task 1: Max Positive Negative

You are given an array of integers, @ints.

Write a script to return the maximum number of either positive or negative integers in the given array.

Example 1

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

Count of positive integers: 4
Count of negative integers: 3
Maximum of count of positive and negative integers: 4

Example 2

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

Count of positive integers: 1
Count of negative integers: 3
Maximum of count of positive and negative integers: 3

Example 3

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

Count of positive integers: 2
Count of negative integers: 0
Maximum of count of positive and negative integers: 2

Approach

Really, this is two loops over the array of integers. One to count positive ints, one to count negative ints. If I do a map of the array each time and return 1 for each int I want to count and 0 for each int I don’t want to count, I can do the counting with a sum operator.

Raku

Like last week, we use Raku’s Reduction Metaoperator with addition ([+]) for the summation, and the max routine on the Any class to pick the maximum.

sub maxPosNeg(@ints) {
  my $pos = [+] @ints.map({ $_ > 0 ?? 1 !! 0 });
  my $neg = [+] @ints.map({ $_ < 0 ?? 1 !! 0 });
  my $max = max $pos, $neg;
  return (
    $max,
    (
      "Count of positive integers: $pos",
      "Count of negative integers: $neg",
      "Maximum of count of positive and " ~
      "negative integers: $max"
    ).join("\n")
  );
}

Yes, it looks like Perl.

$ raku/ch-1.raku
Example 1:
Input: @arr = (-3, 1, 2, -1, 3, -2, 4)
Output: 4

Count of positive integers: 4
Count of negative integers: 3
Maximum of count of positive and negative integers: 4

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

Count of positive integers: 1
Count of negative integers: 3
Maximum of count of positive and negative integers: 3

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

Count of positive integers: 2
Count of negative integers: 0
Maximum of count of positive and negative integers: 2

View the entire Raku script for this task on GitHub.

Perl

In Perl, we can get max and sum from List::Util.

sub maxPosNeg(@ints) {
  my $pos = sum map { $_ > 0 ? 1 : 0 } @ints;
  my $neg = sum map { $_ < 0 ? 1 : 0 } @ints;
  my $max = max $pos, $neg;
  return (
    $max,
    join("\n",
      "Count of positive integers: $pos",
      "Count of negative integers: $neg",
      "Maximum of count of positive and " .
      "negative integers: $max"
    )
  );
}

View the entire Perl script for this task on GitHub.

Python

For Python, sum and max are built in and don’t need to be pulled in from a library.

def maxPosNeg(ints):
    pos = sum([1 for i in ints if i > 0])
    neg = sum([1 for i in ints if i < 0])
    maxCount = max(pos, neg)
    return (
      maxCount,
      "\n".join([
          f"Count of positive integers: {pos}",
          f"Count of negative integers: {neg}",
          f"Maximum of count of positive and " +
          f"negative integers: {maxCount}"
      ])
    )

View the entire Python script for this task on GitHub.


Task 2: Count Equal Divisible

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

Write a script to return the number of pairs (i, j) where

a) 0 <= i < j < size of @ints
b) ints[i] == ints[j]
c) i x j is divisible by k

Example 1

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

(0, 6) => ints[0] == ints[6] and 0 x 6 is divisible by 2
(2, 3) => ints[2] == ints[3] and 2 x 3 is divisible by 2
(2, 4) => ints[2] == ints[4] and 2 x 4 is divisible by 2
(3, 4) => ints[3] == ints[4] and 3 x 4 is divisible by 2

Example 2

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

Approach

Ok, let’s look at these criteria:

0 <= i < j < size of @ints. For a 0-indexed array, it means that both i and j are indices of the array (the 0 <= and < size of @ints parts) and that i < j. Not a big deal.

ints[i] == ints[j] means the numbers at these indices are the same. So Example 2 fails this criteria because none of the numbers are the same.

i x j is divisible by k. Really, this is the big condition.

As with the last task, we’re counting.

Raku

Here I’m leaning into the Raku looking like Perl.

sub countEquDiv($k, @ints) {
  my @explain;
  my $cnt = 0;
  for 0 .. @ints.end - 1 -> $i {
    for $i + 1 .. @ints.end -> $j {
      # does ints[i] == ints[j]?
      next unless @ints[$i] == @ints[$j];
      # is i x j divisible by k?
      next unless ( ($i * $j) mod $k ) == 0;
      # count the pair and explain why
      $cnt++;
      @explain.push(
        "($i, $j) => ints[$i] == ints[$j] " ~
        "and $i x $j is divisible by $k"
      );
    }
  }
  return($cnt, @explain.join("\n"));
}
$ raku/ch-2.raku
Example 1:
Input: @arr = (3, 1, 2, 2, 2, 1, 3) and $k = 2
Output: 4

(0, 6) => ints[0] == ints[6] and 0 x 6 is divisible by 2
(2, 3) => ints[2] == ints[3] and 2 x 3 is divisible by 2
(2, 4) => ints[2] == ints[4] and 2 x 4 is divisible by 2
(3, 4) => ints[3] == ints[4] and 3 x 4 is divisible by 2

Example 2:
Input: @arr = (1, 2, 3) and $k = 1
Output: 0

View the entire Raku script for this task on GitHub.

Perl

sub countEquDiv($k, @ints) {
  my @explain;
  my $cnt = 0;
  foreach my $i ( 0 .. $#ints - 1 ) {
    foreach my $j ( $i + 1 .. $#ints ) {
      # does ints[i] == ints[j]?
      next unless $ints[$i] == $ints[$j];
      # is i x j divisible by k?
      next unless ( ($i * $j) % $k ) == 0;
      # count the pair and explain why
      $cnt++;
      push @explain,
        "($i, $j) => ints[$i] == ints[$j] " .
        "and $i x $j is divisible by $k";
    }
  }
  return($cnt, join("\n", @explain));
}

View the entire Perl script for this task on GitHub.

Python

Here I’m leaning into the Python looking like Perl. I mean, except for the lack of block delimiters and sigils, how can you NOT think this looks like perl?

def countEquDiv(k, ints):
    explain = []
    cnt = 0
    for i in range(len(ints) - 1):
        for j in range(i+1, len(ints)):
            # does ints[i] == ints[j]?
            if not ints[i] == ints[j]: break
            # is i x j divisible by k?
            if not ( (i * j) % k ) == 0: break
            # count the pair and explain why
            cnt += 1
            explain.append(
                f"({i}, {j}) => ints[{i}] == ints[{j}] " +
                f"and {i} x {j} is divisible by {k}"
            )
    return(cnt, "\n".join(explain))

View the entire Python script for this task on GitHub.


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

Perl Weekly Challenge: Two Elements, Multiplied by Digit Sum

No music this week, only solutions to Perl Weekly Challenge 261!

Task 1: Element Digit Sum

You are given an array of integers, @ints.

Write a script to evaluate the absolute difference between element and digit sum of the given array.

Example 1

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

Element Sum: 1 + 2 + 3 + 45 = 51
Digit Sum: 1 + 2 + 3 + 4 + 5 = 15
Absolute Difference: | 51 - 15 | = 36

Example 2

Input: @ints = (1,12,3)
Output: 9

Element Sum: 1 + 12 + 3 = 16
Digit Sum: 1 + 1 + 2 + 3 = 7
Absolute Difference: | 16 - 7 | = 9

Example 3

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

Element Sum: 1 + 2 + 3 + 4 = 10
Digit Sum: 1 + 2 + 3 + 4 = 10
Absolute Difference: | 10 - 10 | = 0

Example 4

Input: @ints = (236, 416, 336, 350)
Output: 1296

Approach

To me, this seems like an exercise in treating a list of numbers like integers in one case (element sum) and as a string of characters in another (digit sum).

Raku

Ok, I’ve been accused of writing my Raku like Perl, so I need to really lean into thinking in Raku, not Perl. Our solution function should accept a list, and we should probably use Raku’s Reduction Metaoperator to create our sums and our string of characters, and abs is a method on the Numeric role that numeric objects have.

sub elementDigitSum(@ints) {
  # [+] sums all the elements of @ints
  my $elementSum = [+] @ints;

  my $explain = 'Element Sum: '
              ~ @ints.join(' + ')
              ~ ' = ' ~ $elementSum;

  # use [~] to concatenate all the integers together
  # into a single string, then use split() to get the
  # individual digits
  my @digits   = ([~] @ints).split('', :skip-empty);
  # [+] sums all the elements of @digits
  my $digitSum = [+] @digits;

  $explain ~= "\n" ~ 'Digit Sum: '
              ~ @digits.join(' + ')
              ~ ' = ' ~ $digitSum;

  my $abs = ($elementSum - $digitSum).abs;

  $explain ~= "\nAbsolute Difference: "
           ~ "| $elementSum - $digitSum | = $abs";

  return ($abs, $explain);
}

View the entire Raku script for this task on GitHub.

$ raku/ch-1.raku
Example 1:
Input: @ints = (1, 2, 3, 45)
Output: 36

Element Sum: 1 + 2 + 3 + 45 = 51
Digit Sum: 1 + 2 + 3 + 4 + 5 = 15
Absolute Difference: | 51 - 15 | = 36

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

Element Sum: 1 + 12 + 3 = 16
Digit Sum: 1 + 1 + 2 + 3 = 7
Absolute Difference: | 16 - 7 | = 9

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

Element Sum: 1 + 2 + 3 + 4 = 10
Digit Sum: 1 + 2 + 3 + 4 = 10
Absolute Difference: | 10 - 10 | = 0

Example 4:
Input: @ints = (236, 416, 336, 350)
Output: 1296

Element Sum: 236 + 416 + 336 + 350 = 1338
Digit Sum: 2 + 3 + 6 + 4 + 1 + 6 + 3 + 3 + 6 + 3 + 5 + 0 = 42
Absolute Difference: | 1338 - 42 | = 1296

Perl

Sigh. Even though I tried to lean into making the Raku version use more Raku features, it turns out that [+] is just a built-in version of List::Util’s sum, and [~] is just a neater version of join('', @array).

use List::Util qw( sum );

sub elementDigitSum(@ints) {
  my $elementSum = sum @ints;

  my $explain = 'Element Sum: '
              . join(' + ',  @ints)
              . ' = ' . $elementSum;

  # use join() to concatenate all the integers together
  # into a single string, then use split() to get the
  # individual digits
  my @digits   = split //, join('', @ints);
  my $digitSum = sum @digits;

  $explain .= "\nDigit Sum: "
           . join(' + ',  @digits)
           . ' = ' . $digitSum;

  my $abs = abs($elementSum - $digitSum);

  $explain .= "\nAbsolute Difference: "
           . "| $elementSum - $digitSum | = $abs";

  return ($abs, $explain);
}

View the entire Perl script for this task on GitHub.

Python

I will, however, gladly cop to my Python looking like Perl, because it does. That’s because I don’t believe there’s a lot of difference between the languages. Though, when I’m writing my Python, I start with the Raku version because both Raku and Python have the same “everything is an object” edict at their heart.

def plus_join(arr):
    return ' + '.join(map(lambda i: str(i), arr))

def elementDigitSum(ints):
    elementSum = sum(ints)

    explain = f'Element Sum: {plus_join(ints)} = {elementSum}'

    # concatenate all the integers together into a single
    # string
    digitStr = ''.join([ str(i) for i in ints ])
    # loop over the individual digits
    digits = [ int(d) for d in digitStr ]
    digitSum = sum(digits)

    explain += "\n"
    explain += f'Digit Sum: {plus_join(digits)} = {digitSum}'

    absVal = abs(elementSum - digitSum)

    explain += "\n"
    explain += 'Absolute Difference: '
    explain += f'| {elementSum} - {digitSum} | = {absVal}'

    return (absVal, explain)

View the entire Python script for this task on GitHub.


Task 2: Multiply by Two

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

Write a script to do the followings:

a) Look for $start in the array @ints, if found multiply the number by 2
b) If not found stop the process otherwise repeat

In the end return the final value.

Example 1

Input: @ints = (5,3,6,1,12) and $start = 3
Output: 24

Step 1: 3 is in the array so 3 x 2 = 6
Step 2: 6 is in the array so 6 x 2 = 12
Step 3: 12 is in the array so 12 x 2 = 24

24 is not found in the array so return 24.

Example 2

Input: @ints = (1,2,4,3) and $start = 1
Output: 8

Step 1: 1 is in the array so 1 x 2 = 2
Step 2: 2 is in the array so 2 x 2 = 4
Step 3: 4 is in the array so 4 x 2 = 8

8 is not found in the array so return 8.

Example 3

Input: @ints = (5,6,7) and $start = 2
Output: 2

2 is not found in the array so return 2.

Approach

Well, this is a fairly straightforward loop, the interesting part is checking to see if $start is in the array. The boring way would be to loop over the elements of the array, but each of the languages I’m using have more interesting ways to

Raku

In Raku, we have a data type called a Set, and it has an infix (elem) operator which can be written with the unicode character ∈.

sub multiplyByTwo(@ints, $s) {
  my $start = $s; # so we can modify the value
  my $ints = Set(@ints);
  my @explain;
  my $step = 0;

  while ($start ∈ $ints) {
    $step++;
    my $old = $start;
    $start *= 2;
    @explain.push(
      "Step $step: $old is in the array so $old x 2 = $start"
    );
  }
  @explain.push(
    "$start is not in the array so return $start."
  );
  return ($start, @explain.join("\n"));
}

View the entire Raku script for this task on GitHub.

$ raku/ch-2.raku
Example 1:
Input: @ints = (5, 3, 6, 1, 12) and $start = 3
Output: 24

Step 1: 3 is in the array so 3 x 2 = 6
Step 2: 6 is in the array so 6 x 2 = 12
Step 3: 12 is in the array so 12 x 2 = 24
24 is not in the array so return 24.

Example 2:
Input: @ints = (1, 2, 4, 3) and $start = 1
Output: 8

Step 1: 1 is in the array so 1 x 2 = 2
Step 2: 2 is in the array so 2 x 2 = 4
Step 3: 4 is in the array so 4 x 2 = 8
8 is not in the array so return 8.

Example 3:
Input: @ints = (5, 6, 7) and $start = 2
Output: 2

2 is not in the array so return 2.

Perl

Perl, on the other hand, doesn’t have a Set data type, but we can easily do the same thing with a hash!

sub multiplyByTwo($start, @ints) {
  my %ints = map { $_ => 1 } @ints;
  my @explain;
  my $step = 0;

  while ( exists $ints{$start} ) {
    $step++;
    my $old = $start;
    $start *= 2;
    push @explain,
      "Step $step: $old is in the array so $old x 2 = $start";
  }
  push @explain,
    "$start is not in the array so return $start.";
  return ($start, join("\n", @explain));
}

View the entire Perl script for this task on GitHub.

Python

Python, however, does have a set datatype. In this case, because we don’t need to change the set after we create it, I’m going to use a frozenset.

def multiplyByTwo(ints, start):
    intSet = frozenset(ints)
    explain = []
    step = 0

    while start in intSet:
        step += 1
        old = start
        start *= 2
        explain.append(
          f"Step {step}: {old} is in the array " +
          f"so {old} x 2 = {start}"
        )
    explain.append(
      f"{start} is not in the array so return {start}."
    )
    return (start, "\n".join(explain))

View the entire Python script for this task on GitHub.


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

Perl Weekly Challenge: Unique Dictionary Occurrences are Rank

Rank? Take note, this is probably the only time I’m evoking Lynyrd Skynyrd.

Onward to Perl Weekly Challenge 260!

Task 1: Unique Occurrences

You are given an array of integers, @ints.

Write a script to return 1 if the number of occurrences of each value in the given array is unique or 0 otherwise.

Example 1

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

The number 1 occurred 3 times.
The number 2 occurred 2 times.
The number 3 occurred 1 time.

All occurrences are unique, therefore the output is 1.

Example 2

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

Example 3

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

Approach

This immediately says hashes to me: a hash to count the number of times each integer occurs, and another hash to track whether a particular integer count occurs more than once.

Raku

sub uniqueOccurrences(@ints) {
  my %counts;
  for @ints -> $i {
    # count how many time each int occurs
    %counts{$i}++;
  }
  my %seen;
  for %counts.kv -> $i, $c {
    # if we've seen this count before, return 0
    return 0 if %seen{$c}:exists;
    %seen{$c} = $i;
  }
  # each count was unique
  return 1;
}
$ raku/ch-1.raku
Example 1:
Input: @ints = (1, 2, 2, 1, 1, 3)
Output: 1

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

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

View the entire Raku script for this task on GitHub.

Perl

The big change from Raku to Perl is going from for %counts.kv -> $i, $c to while ( my($i, $c) = each %counts ):

sub uniqueOccurrences(@ints) {
  my %counts;
  foreach my $i ( @ints ) {
    # count how many time each int occurs
    $counts{$i}++;
  }
  my %seen;
  while ( my($i, $c) = each %counts ) {
    # if we've seen this count before, return 0
    return 0 if exists $seen{$c};
    $seen{$c} = $i;
  }
  # each count was unique
  return 1;
}

View the entire Perl script for this task on GitHub.

Python

As always, when I’m counting things in Python, I use the Counter type in the collections module.

from collections import Counter

def uniqueOccurrences(ints):
  counts = Counter()
  for i in ints:
    # count how many time each int occurs
    counts[i] += 1
  seen = {}
  for i, c in counts.items():
    # if we've seen this count before, return 0
    if c in seen: return 0 
    seen[c] = i
  # each count was unique
  return 1

View the entire Python script for this task on GitHub.


Task 2: Dictionary Rank

You are given a word, $word.

Write a script to compute the dictionary rank of the given word.

Example 1

Input: $word = 'CAT'
Output: 3

All possible combinations of the letters:
CAT, CTA, ATC, TCA, ACT, TAC

Arrange them in alphabetical order:
ACT, ATC, CAT, CTA, TAC, TCA

CAT is the 3rd in the list.
Therefore the dictionary rank of CAT is 3.

Example 2

Input: $word = 'GOOGLE'
Output: 88

Example 3

Input: $word = 'SECRET'
Output: 255

Approach

This feels akin to the first task: operate on the list (of characters, this time) to produce another list, and the analyze the second list in some way. Here, we’re breaking a string into characters, producing all the permutations of those characters as new strings, then sorting them and seeing how far down the sorted list the original string appears.

Raku

In Raku, there’s a permutations method on the List type to do the heavy lifting:

sub dictionaryRank($word) {
  # split the string into an array of characters
  my @letters = $word.split('', :skip-empty);

  # find the permutations of the letters
  my @perms;
  for @letters.permutations -> @l {
    @perms.append(@l.join(''));
  }

  # find where in the sorted list of 
  # permutations the word is
  my $rank = 1;
  for @perms.unique.sort -> $p {
    return $rank if $p eq $word;
    $rank++;
  }
}
$ raku/ch-2.raku | less
Example 1:
Input: $word = 'CAT'
Output: 3

Example 2:
Input: $word = 'GOOGLE'
Output: 349

Example 3:
Input: $word = 'SECRET'
Output: 509

But wait! GOOGLE and SECRET are supposed to be 88 and 255, not 349 and 509. What gives? Let’s look at what @perms.sort looks like by adding say @perms.sort.raku; right after we build the array…

Example 2:
Input: $word = 'GOOGLE'
("EGGLOO", "EGGLOO", "EGGLOO", "EGGLOO", "EGGOLO", "EGGOLO",
 "EGGOLO", "EGGOLO", "EGGOOL", "EGGOOL", "EGGOOL", "EGGOOL",
 "EGLGOO", "EGLGOO", "EGLGOO", "EGLGOO", "EGLOGO", "EGLOGO",
 "EGLOGO", "EGLOGO", "EGLOOG", "EGLOOG", "EGLOOG", "EGLOOG",
 "EGOGLO", "EGOGLO", "EGOGLO", "EGOGLO", "EGOGOL", "EGOGOL",
...

Oh! I see what’s happening! It wants all the unique combinations! Fortunately, Raku has a unique method for just that.

sub dictionaryRank($word) {
  # split the string into an array of characters
  my @letters = $word.split('', :skip-empty);

  # find the permutations of the letters
  my @perms;
  for @letters.permutations -> @l {
    @perms.append(@l.join(''));
  }

  # find where in the sorted list of 
  # UNIQUE permutations the word is
  my $rank = 1;
  for @perms.unique.sort -> $p {
    return $rank if $p eq $word;
    $rank++;
  }
}
$ raku/ch-2.raku | less
Example 1:
Input: $word = 'CAT'
Output: 3

Example 2:
Input: $word = 'GOOGLE'
Output: 88

Example 3:
Input: $word = 'SECRET'
Output: 255

View the entire Raku script for this task on GitHub.

Perl

Perl, however, doesn’t have the same built-in features, so we need to rely on CPAN modules. For uniqueness, I’m using uniq from List::Util, and for permutations, I’m using  Algorithm::Combinatorics’ permutations function, like I did back in PWC 244.

use Algorithm::Combinatorics qw( permutations );
use List::Util qw( uniq );

sub dictionaryRank($word) {
  # split the string into an array of characters
  my @letters = split //, $word;

  # find the permutations of the letters
  my @perms;
  foreach my $l ( permutations(\@letters) ) {
    push @perms, join('', @$l);
  }

  # find where in the sorted list of 
  # UNIQUE permutations the word is
  my $rank = 1;
  foreach my $p ( sort { $a cmp $b } uniq @perms ) {
    return $rank if $p eq $word;
    $rank++;
  }
}

View the entire Perl script for this task on GitHub.

Python

Again, like I did in PWC 244, I’m using itertools, but this time it’s the permutations function.

def dictionaryRank(word):
  # we don't need to split the string, because
  # permutations() will accept a string as a parameter
  #
  # set() produces a set of unique elements
  #
  # sorted() returns a sorted list
  perms = sorted(
    set([ ''.join(l) for l in permutations(word) ])
  )
  rank = 1
  for p in perms:
    if p == word: return rank
    rank += 1

View the entire Python script for this task on GitHub.


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

Perl Weekly Challenge: Ba-a-nking Day! Ba-a-nking Day! That’s all I really wanted to say…

Oh, I’m weary from waiting
In Washington, D.C.
I’m coming to see my congressman
But he’s avoiding me
Weary from waiting down in Washington, D.C.

Oh, Congresswoman
Won’t you tell that congressman
I’ve waited such a long time
I’ve about waited all I can…

La plus ça change, plus c’est la même chose. But this week, things are not the same with Perl Weekly Challenge 259!

Task 1: Banking Day Offset

You are given a start date and offset counter. Optionally you also get bank holiday date list.

Given a number (of days) and a start date, return the number (of days) adjusted to take into account non-banking days. In other words: convert a banking day offset to a calendar day offset.

Non-banking days are:

a) Weekends
b) Bank holidays

Example 1

Input: $start_date = '2018-06-28', $offset = 3, $bank_holidays = ['2018-07-03']
Output: '2018-07-04'

Thursday bumped to Wednesday (3 day offset, with Monday a bank holiday)

Example 2

Input: $start_date = '2018-06-28', $offset = 3
Output: '2018-07-03'

Approach

We’re back to date manipulation, which were the crux of PWC 227 and 237, so we’re probably going to be using date manipulation modules…

Raku

In Raku, the manipulation we need is built in, so we only need Tom Browder’s Date::Names module for getting the day-of-the-week names I use in my explanation.

use Date::Names;

sub bankingDayOffset($start, $offset, @holidays) {
  my $date = Date.new($start); # convert string to Date
  my $off  = $offset;
  my $cnt  = 0;

  # convert holidays to Date objects
  @holidays = map { Date.new($_) }, @holidays;

  # instantiate a Date::Names object
  my $dn = Date::Names.new;

  my @explain;
  my $this_day = $dn.dow($date.day-of-week);
  while ($off) {
    $date++;
    my $next_day = $dn.dow($date.day-of-week);
    if (
      $date.day-of-week == 6 || # it's a Saturday
      $date.day-of-week == 7    # it's a Sunday
    ) { 
      @explain.push:
        "$next_day skipped because it's a weekend";
    }
    elsif ($date == @holidays.any) { # it's a Holiday
      @explain.push:
        "$next_day skipped because it's a holiday";
    }
    else {
      $off--; $cnt++;
      @explain.push:
        "$this_day bumped to $next_day (offset $cnt)";
      $this_day = $next_day;
    }
  }
  return $date.gist, @explain.join("\n");
}
$ raku/ch-1.raku
Example 1:
Input: $start_date = '2018-06-28', $offset = 3,
       $bank_holidays = ['2018-07-03']
Output: '2018-07-04'

Thursday bumped to Friday (offset 1)
Saturday skipped because it's a weekend
Sunday skipped because it's a weekend
Friday bumped to Monday (offset 2)
Tuesday skipped because it's a holiday
Monday bumped to Wednesday (offset 3)

Example 2:
Input: $start_date = '2018-06-28', $offset = 3
Output: '2018-07-03'

Thursday bumped to Friday (offset 1)
Saturday skipped because it's a weekend
Sunday skipped because it's a weekend
Friday bumped to Monday (offset 2)
Monday bumped to Tuesday (offset 3)

Example 3:
Input: $start_date = '2023-12-29', $offset = 5,
       $bank_holidays = ['2024-01-01']
Output: '2024-01-08'

Saturday skipped because it's a weekend
Sunday skipped because it's a weekend
Monday skipped because it's a holiday
Friday bumped to Tuesday (offset 1)
Tuesday bumped to Wednesday (offset 2)
Wednesday bumped to Thursday (offset 3)
Thursday bumped to Friday (offset 4)
Saturday skipped because it's a weekend
Sunday skipped because it's a weekend
Friday bumped to Monday (offset 5)

View the entire Raku script for this task on GitHub.

Perl

As usual, we don’t have to adjust the approach for converting from Raku to Perl, only the particulars. Perl doesn’t have a built-in module for Date manipulation, but Time::Piece and Time::Seconds are in the core modules, and Time::Piece has a method for generating the name of the day of the week. any we get from List::Util.

use List::Util qw( any );
use Time::Piece;
use Time::Seconds qw( ONE_DAY );

sub bankingDayOffset($start, $offset, @holidays) {
  # convert string to Date
  my $date = Time::Piece->strptime($start, "%Y-%m-%d")
                        ->truncate(to => 'day');
  my $cnt  = 0;

  # convert holidays to Date objects
  @holidays = map {
    Time::Piece->strptime($_, "%Y-%m-%d")
               ->truncate(to => 'day')
  } @holidays;

  my @explain;
  my $this_day = $date->fullday;
  while ($offset) {
    $date += ONE_DAY; # add 1 day
    my $next_day = $date->fullday;
    if (
      $date->wday == 7 || # it's a Saturday
      $date->wday == 1    # it's a Sunday
    ) { 
      push @explain,
        "$next_day skipped because it's a weekend";
    }
    elsif (any { $date == $_ } @holidays) { # it's a Holiday
      push @explain,
        "$next_day skipped because it's a holiday";
    }
    else {
      $offset--; $cnt++;
      push @explain,
        "$this_day bumped to $next_day (offset $cnt)";
      $this_day = $next_day;
    }
  }
  return $date->strftime('%F'), join("\n", @explain);
}

View the entire Perl script for this task on GitHub.

Python

Again, I’m using Python’s really robust datetime module.

from datetime import date, timedelta

def bankingDayOffset(start, offset, holidays):
  d = date.fromisoformat(start) # convert string to Date
  cnt = 0

  # convert holidays to Date objects
  holidays = [ date.fromisoformat(h) for h in holidays ]

  explain = []
  this_day = d.strftime('%A')
  while offset:
    d += timedelta(days = 1) # add 1 day
    next_day = d.strftime('%A')
    if (
      d.isoweekday() == 6 or # it's a Saturday
      d.isoweekday() == 7    # it's a Sunday
    ): 
      explain.append(
        f"{next_day} skipped because it's a weekend"
      )
    elif any([d == h for h in holidays]): # it's a Holiday
      explain.append(
        f"{next_day} skipped because it's a holiday"
      )
    else:
      offset -= 1
      cnt += 1
      explain.append(
        f"{next_day} bumped to {next_day} (offset {cnt})"
      )
      this_day = next_day
  return d.strftime('%F'), "\n".join(explain)

View the entire Python script for this task on GitHub.


Task 2: Line Parser

You are given a line like below:

{%  id   field1="value1"    field2="value2"  field3=42 %}

Where

a) "id" can be \w+.
b) There can be 0  or more field-value pairs.
c) The name of the fields are \w+.
b) The values are either number in which case we don't need
   double quotes or string in which case we need double quotes
   around them.

The line parser should return structure like below:

{
       name => id,
       fields => {
           field1 => value1,
           field2 => value2,
           field3 => value3,
       }
}

It should be able to parse the following edge cases too:

{%  youtube title="Title \"quoted\" done" %}

and

{%  youtube title="Title with escaped backslash \\" %}

BONUS: Extend it to be able to handle multiline tags:

{% id  filed1="value1" ... %}
LINES
{% endid %}

You should expect the following structure from your line parser:

{
       name => id,
       fields => {
           field1 => value1,
           field2 => value2,
           field3 => value3,
       }
       text => LINES
}

Approach

Wow! This seems like a pretty big task for a PWC, but I’m up for it.

Raku

It seems pretty obvious to me that, in Raku at least, the tool for this job is a grammar. I’ve never actually written a Raku grammar before, so I went through the grammar tutorial.

The really tricky part was allowing for strings that contained escaped quotes and escaped backslashes. Finally, after a lot of confusion, I stopped trying to keep the data I was parsing in the program file itself, since I couldn’t be certain that "Title with escaped backslash \\" was indeed an escaped backslash and not being interpreted by Raku as escaping the quote. You can look at my input files here.

grammar Parser {
  rule TOP { [ <line> | <text> ] }

  rule line { '{%' <id> [ <field-value> ]* '%}' }

  # negative lookbehind and negative lookahead
  rule text { <!after 「{%」 > <-[ \n ]>+ <!before 「%}」 >}

  token id    { \w+ }
  token field { \w+ }

  token number { \d+ [ \. \d+ ]? }

  token quoted-string { '"' <string> '"' }
  token string {
    [
      <-[ " ]> # any character not a quote
      |
      「\\」     # an escaped backslash
      |
      \\\"     # an escaped quote
    ]*
    }
  
  rule field-value { <field> '=' [<number> | <quoted-string>] }
}

sub MAIN($file) {
  my %data;
  my @ids;
  my $in_id = '';
  for $file.IO.lines -> $line {
    # parse this line of the file
    my $p = Parser.parse($line);

    # is there a line with {% ... %} ?
    if ($p<line>) {
      my $id = $p<line><id>.Str;
      # is the id the end of a block?
      if (my $c = ($id ~~ / end(\w+) /)) { # capture after end
        if (%data{$c[0]}:exists) { # it is!
          $id = $c[0]; 
          $in_id = ''; # clear the id we're processing
          if (%data{$id}{'text'}) {
            # if there's text, remove the final "newline"
            %data{$id}{'text'} ~~ s/\\n$//;
          }
          next; # skip to next line of file
        }
      }
      @ids.push($id); # keep list of ids in order
      $in_id = $id; # keep track of the current id for text
      # initialize base data for this id
      %data{$id} = { name => $id };
      # if we have fields...
      if ($p<line><field-value>) {
        # loop over them and store them in the data
        for $p<line><field-value> -> $fv {
          my $field = $fv<field>;
          my $value = $fv<number> ?? $fv<number> 
                   !! $fv<quoted-string><string>;
          %data{$id}{'fields'}{$field} = $value;
        }
      }
    }
    # if we have non-{% ... %} lines and we have an ID
    elsif ($p<text> && $in_id) {
      # append a "newline" to the end
      %data{$in_id}{'text'} ~= $p<text> ~ "\\n";
    }
  }

  # dump the data
  for @ids -> $id {
    my %group = %data{$id};
    say "\{";
    say "  name => %group{'name'},";
    say "  fields => \{";
    for %group{'fields'}.keys.sort -> $k {
      say "    $k => %group{'fields'}{$k},";
    }
    say "  }";
    say "  text => %group{'text'}" if %group{'text'};
    say "\}";
  }
}

And here’s my output:

$ raku/ch-2.raku data/parser-1.txt
{
  name => id,
  fields => {
    field1 => value1,
    field2 => value2,
    field3 => 42,
  }
}

$ raku/ch-2.raku data/parser-2.txt
{
  name => youtube,
  fields => {
    title => Title \"quoted\" done,
  }
}

$ raku/ch-2.raku data/parser-3.txt
{
  name => youtube,
  fields => {
    title => Title with escaped backslash \\,
  }
}

$ raku/ch-2.raku data/parser-4.txt
{
  name => id,
  fields => {
    filed1 => value1,
  }
  text => LINES
}

$ raku/ch-2.raku data/parser-5.txt
{
  name => id,
  fields => {
    filed1 => value1,
  }
  text => LINES\nLINES\nLINES
}
{
  name => foo,
  fields => {
    foonum => 3,
  }
  text => FOO\nBAR\nBAZ
}

View the entire Raku script for this task on GitHub.

Perl

It’s after the submission deadline, but I finally got around to implementing the parser in Perl:

use v5.38;

my $ID     = qr/ (?<ID> \w+) /x;
my $FIELD  = qr/ (?<FIELD> \w+) /x;
my $NUMBER = qr/ (?<NUMBER> \d+ [ \. \d+ ]? ) /x;
my $STRING = qr/ (?<STRING> ([^"] | \\ | \\\" )+ ) /x;

my $QUOTED_STRING = qr/ (?<QUOTED_STRING> " $STRING " ) /x;
my $FIELD_VALUE = qr/ $FIELD \s* = \s* ( $NUMBER | $QUOTED_STRING ) \s* /x;
my $FIELD_VALUES = qr/ (?<FIELD_VALUES> (?: $FIELD_VALUE \s* )* ) /x;

# negative lookbehind and negative lookahead
my $TEXT = qr/ (?<TEXT> (?<! {% ) .+ (?! %} ) ) /x;
my $LINE = qr/ (?<LINE> \{% \s* $ID \s* $FIELD_VALUES \s* %\} ) /x;

my $TOP  = qr/^ (?: $LINE | $TEXT ) $/x;

my $file = shift @ARGV;
open my $fh, '<', $file;

my %data;
my @ids;
my $in_id;

while (my $line = <$fh>) {
  $line =~ /$TOP/;

  # is there a line with {% ... %} ?
  if ($+{LINE}) {
    my $id = $+{ID};
    # is the id the end of a block?
    if ($id =~ /^ end(\w+) $/x) { # capture after end
      if (exists $data{$1}) { # it is!
        $id = $1; 
        undef $in_id; # clear the id we're processing
        if ($data{$id}{'text'}) {
          # if there's text, remove the final "newline"
          $data{$id}{'text'} =~ s/\\n$//;
        }
        next; # skip to next line of file
      }
    }
    push @ids, $id; # keep list of ids in order
    $in_id = $id; # keep track of the current id for text
    # initialize base data for this id
    $data{$id} = { name => $id };
    # if we have fields...
    my $field_values = $+{FIELD_VALUES};
    # loop over field values and store them in the data
    while ($field_values =~ /$FIELD_VALUE/g) {
      my $value = $+{STRING} ? $+{STRING} : $+{NUMBER};
      if ($+{NUMBER}) {
        $value =~ s/\s+$//; # we're picking up trailing spaces
      }
      $data{$id}->{'fields'}->{ $+{FIELD} } = $value;
    }

  }
  # if we have non-{% ... %} lines and we have an ID
  elsif ($+{TEXT} && $in_id) {
    # append a "newline" to the end
    $data{$in_id}{'text'} .= $+{TEXT} . "\\n";
  }
}

use Data::Dumper::Concise;
foreach my $id (@ids) {
  print Dumper($data{$id});
}
$ perl/ch-2.pl data/parser-1.txt
{
  fields => {
    field1 => "value1",
    field2 => "value2",
    field3 => 42,
  },
  name => "id",
}

$ perl/ch-2.pl data/parser-2.txt
{
  fields => {
    title => "Title \\",
  },
  name => "youtube",
}

$ perl/ch-2.pl data/parser-3.txt
{
  fields => {
    title => "Title with escaped backslash \\\\",
  },
  name => "youtube",
}

$ perl/ch-2.pl data/parser-4.txt
{
  fields => {
    filed1 => "value1",
  },
  name => "id",
  text => "LINES",
}

$ perl/ch-2.pl data/parser-5.txt
{
  fields => {
    filed1 => "value1",
  },
  name => "id",
  text => "LINES\\nLINES\\nLINES",
}
{
  fields => {
    foonum => 3,
  },
  name => "foo",
  text => "FOO\\nBAR\\nBAZ",
}

View the entire Perl script for this task on GitHub.


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

Perl Weekly Challenge: Even Digits have a Sum!

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

Task 1: Count Even Digits Number

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

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

Example 1

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

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

Example 2

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

Example 3

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

Approach

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

Raku

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

View the entire Raku script for this task on GitHub.

Perl

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

use POSIX qw( log10 floor );

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

View the entire Perl script for this task on GitHub.

Python

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

from math import floor, log10

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

View the entire Python script for this task on GitHub.


Task 2: Sum of Values

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

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

Example 1

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

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

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

Example 2

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

Example 3

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

Approach

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

Raku

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

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

use experimental :cached;

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

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

View the entire Raku script for this task on GitHub.

Perl

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

use Memoize;
memoize('setBitCount');

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

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

View the entire Perl script for this task on GitHub.

Python

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

from functools import cache

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

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

View the entire Python script for this task on GitHub.


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

Perl Weekly Challenge: Reduced is Smaller!

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

Onward to Perl Weekly Challenge 257!

Task 1: Smaller than Current

You are given an array of integers, @ints.

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

Example 1

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

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

Example 2

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

Example 3

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

Example 4

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

Approach

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

Raku

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

View the entire Raku script for this task on GitHub.

Perl

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

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

View the entire Perl script for this task on GitHub.

Python

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

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

View the entire Python script for this task on GitHub.


Task 2: Reduced Row Echelon

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

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

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

For example:

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

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

For more information check out this wikipedia article.

Example 1

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

Example 2

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

Example 3

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

Example 4

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

Example 5

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

Example 6

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

Approach

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

Raku

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

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

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

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

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

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

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

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

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

View the entire Raku script for this task on GitHub.

Perl

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

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

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

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

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

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

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

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

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

View the entire Perl script for this task on GitHub.

Python

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

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

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

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

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

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

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

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

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

View the entire Python script for this task on GitHub.


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

Perl Weekly Challenge: Merge the Maximum String Pairs

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

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

Task 1: Maximum Pairs

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

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

Example 1

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

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

Example 2

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

Example 3

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

Approach

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

Raku

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

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

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

View the entire Raku script for this task on GitHub.

Perl

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

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

View the entire Perl script for this task on GitHub.

Python

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

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

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

View the entire Python script for this task on GitHub.


Task 2: Merge Strings

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

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

Example 1

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

Example 2

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

Approach

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

Raku

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

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

View the entire Raku script for this task on GitHub.

Perl

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

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

View the entire Perl script for this task on GitHub.

Python

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

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

View the entire Python script for this task on GitHub.


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