Perl Weekly Challenge: Week 265
Challenge 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.
Like last week, no one-liners this week but we can manage a two-liner thanks to Raku's extensive and compact standard library and variety of operators.
Also like last week, .classify() does a lot of work for us. A hash called %count is created. Its' keys are numbers found in
@ints and values are the occurrences of each number.
@ints.classify( { $_}, :into(my %count));
Then we sort the keys of %count in ascending numeric order with .keys() and .sort() and, using .grep() find the ones whose number of occurrences is greater than 33%. In case there is more than one such number, .first() will give us the smallest one.
The final answer is then printed with .say(). If no number in the input was greater than 33%, Nil will be printed.
%count.keys.sort.grep({ %count{$_}.elems / @ints.elems > 0.33 }).first.say;
In Perl we don't have .classify() so instead we use a for loop to add keys and values to %count. One fortunate side effect
of this is that we can just store the number of times a number occurres rather than the occurrences themselves which is all we really need.
my %count;
for my $i (@ints) {
$count{$i}++;
}
And therefore we do not need the Perl equivalent of .elems() for the values of each key of %count in this line. In the event
no number in the input is greater than 33%, the word undef is printed out.
say ((grep { $count{$_} / scalar @ints > 0.33 } sort { $a <=> $b} keys %count)[0] // 'undef');
Challenge 2:
Completing Word
You are given a string,
$strcontaining alphnumeric characters and 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'.
The input consists of one word $str and several other words @str. Such a naming convention is an accident waiting to happen in
production code but we'll ignore that for now. The first step is to convert $str into an array of letters. The spec says we can ignore digits, white space and the case of letters. So first we use .lc() to convert all the letters in the string to lower case.
(We could have also used .uc() to convert them all to upper case; doesn't matter.) Then after splitting the string into a list of individual characters with .comb(), we extract only the letters with .grep().
my @letters = $str.lc.comb.grep({ $_ ~~ <a> .. <z> });
What the spec calls completing words are ons for which @letters is a subset. Luckily, Raku has excellent support for set operations. We can search for subsets in @str using .grep() but first we must convert @letters and the letters in each element of @str (split with .comb()) into Rakus' Set type. Actually not just the occurence of a character but the frequency with which it appears is important and Set doesn't store frequency. But the related Bag type does. Once we have two Bags the ⊆ operator
will return true if the former is a subset or equal to the latter. We .sort() the completed words we have found in order of length, shortest first, using .chars() and print the .first() (i.e. shortest) value with .say().
@str.grep({ @letters.Bag ⊆ $_.comb.Bag }).sort({ $^a.chars <=> $^b.chars }).first.say;
Perl is lacking Bags and set operators so we have to provide our own.
The first function I wrote is called makeBag(). It takes an array by reference and converts it into a hash whose keys are the
number of unique elements in the array and whose values are the number of times that element occurred.
sub makeBag {
my ($array) = @_;
my %bag;
for my $c (@{$array}) {
$bag{$c}++;
}
return %bag;
}
isSubset() replaces the ⊆ operator. It takes two hashes of a type returned by makeBag() by reference and compares them.
If all the keys in the first hash also occur in the second hash and all the values of those keys in the first hash are less than or
equal to the corresponding values in the second, 1 is returned. If either condition is not met, undef is returned. Perl will treat
these as true or false respectively.
sub isSubset {
my ($a, $b) = @_;
for my $k (keys %{$a}) {
unless (exists $b->{$k}) {
return undef;
}
if ($a->{$k} > $b->{$k}) {
return undef;
}
}
return 1;
}
Now we can follow the same algorithm as the Raku version.
my ($str, @str) = @ARGV;
my %letters = makeBag([grep { $_ =~ /[a-z]/ } split //, lc $str]);
One modification we do have to make is to store the completed words we have found in an intermediate array as the kind of method chaining used in the Raku version proved to be rather unwieldy in Perl.
my @completed;
foreach my $word (@str) {
my %wordBag = makeBag([split //, $word]);
if (isSubset(\%letters, \%wordBag)) {
push @completed, $word;
}
}
say ((sort { length $a <=> length $b } @completed)[0]);