Perl Weekly Challenge: Week 216
Challenge 1:
Registration Number
You are given a list of words and a random registration number.
Write a script to find all the words in the given list that has every letter in the given registration number.
Example 1
Input: @words = ('abc', 'abcd', 'bcd'), $reg = 'AB1 2CD'
Output: ('abcd')
The only word that matches every alphabets in the given registration number is 'abcd'.
Example 2
Input: @words = ('job', 'james', 'bjorg'), $reg = '007 JB'
Output: ('job', 'bjorg')
Example 3
Input: @words = ('crack', 'road', 'rac'), $reg = 'C7 RA2'
Output: ('crack', 'rac')
The first thing we do in Raku is make an array of valid letters from $reg. We
split it into characters with .comb(), filter out the non-alphabetic characters
with .grep(), filter out any non-unique characters with .unique() and turn everything
that remains lower-case with .map().
my @registration = $reg.comb.grep({$_ ~~ /<alpha>/}).unique.map({ $_.lc });
We will also need an array to store the results.
my @results;
Then for each word...
for @words -> $word {
...we do the same thing as we did for $reg.
my @w = $word.comb.grep({$_ ~~ /<alpha>/}).unique.map({ $_.lc });
Then we compare @registration and @w using the subset or equal operator ⊆.
If @registration is a subset of @w, the word is added to @results.
if @registration ⊆ @w {
@results.push($word);
}
}
At the end we print the results in the format suggested by the spec.
say q{(}, @results.map({"'$_'"}).join(q{, }), q{)};
This is the Perl version. It uses some auxillary functions to make up for functionality in Raku that Perl doesn't have.
my @registration = combGrepUniqueLc($reg);
my @results;
for my $word (@words) {
my @w = combGrepUniqueLc($word);
if (isSubset(\@registration, \@w)) {
push @results, $word;
}
}
say q{(}, (join q{, }, map {"'$_'"} @results), q{)};
This function replaces the .comb.grep({$_ ~~ /<alpha>/}).unique.map({ $_.lc })
code in the Raku script.
sub combGrepUniqueLc {
my ($str) = @_;
my @chars = map { lc } grep { $_ =~ /[[:alpha:]]/ } split //, $str;
my %unique;
for my $c (@chars) {
$unique{$c}++;
}
return keys %unique;
}
And this is my replacement for ⊆. I had done something like this before for a
previous challenge
and at first I tried to reuse that but it had the unfortunate characteristic of not working
with lists containing duplicates which caused me no end of bother when I tried to use it in
the second challenge this week. So I rewrote it like this and used it here as well as there.
sub isSubset {
my @subset = @{$_[0]};
my %set;
for my $c (@{$_[1]}) {
$set{$c}++;
}
for my $c (@subset) {
if (!exists $set{$c} || $set{$c} == 0) {
return undef;
}
$set{$c}--;
}
return 1;
}
With these two functions, writing a solution becomes easy.
my ($reg, @words) = @ARGV;
my @registration = combGrepUniqueLc($reg);
my @results;
for my $word (@words) {
my @w = combGrepUniqueLc($word);
if (isSubset(\@registration, \@w)) {
push @results, $word;
}
}
say q{(}, (join q{, }, map {"'$_'"} @results), q{)};
Challenge 2:
Word Stickers
You are given a list of word stickers and a target word.
Write a script to find out how many word stickers is needed to make up the given target word.
Example 1
Input: @stickers = ('perl','raku','python'), $word = 'peon'
Output: 2
We just need 2 stickers i.e. 'perl' and 'python'.
'pe' from 'perl' and
'on' from 'python' to get the target word.
Example 2
Input: @stickers = ('love','hate','angry'), $word = 'goat'
Output: 3
We need 3 stickers i.e. 'angry', 'love' and 'hate'.
'g' from 'angry'
'o' from 'love' and
'at' from 'hate' to get the target word.
Example 3
Input: @stickers = ('come','nation','delta'), $word = 'accommodation'
Output: 4
We just need 2 stickers of 'come' and one each of 'nation' & 'delta'.
'a' from 'delta'
'ccommo' from 2 stickers 'come'
'd' from the same sticker 'delta' and
'ation' from 'nation' to get the target word.
Example 4
Input: @stickers = ('come','country','delta'), $word = 'accommodation'
Output: 0
as there's no "i" in the inputs.
I'm not sure this is the best solution but it seems to work.
The first thing I checked was if all the letters in $word also occur in @stickers
using the not subset or equal operator, ⊊. If the letters of $word aren't a subset,
it is pointless to carry on. We can just print 0 and exit the script.
if $word.comb.unique ⊊ @stickers.join.comb.unique {
say 0;
exit;
}
Originally, I didn't have this line but it turns out you can't do example 3 which
requires multiple stickers of the same type without it. The problem is how do you
know in advance how many copies of which stickers do you need? It is safe to assume
that at most one copy of each for every unique letter in $word will cover it. In most
cases most of the extra copies will be wasted but I don't think you can do better.
This line uses the xx operator to add extra copies. .flat() is called at the end
because otherwise Raku will insert array references.
my @stickerList = (@stickers xx $word.comb.unique.elems).flat;
This line creates a variable of type Bag. This is Rakus' equivalent of a C++ multiset
i.e. a set that can hold multiple elements with the same value. In this case, the bag
holds the individual characters in $word.
my $chars = Bag.new($word.comb);
We also need a place to store the result.
my $result = 0;
Then from 1 to the number of stickers in the sticker list...
LOOP: for 1 .. @stickerList.elems -> $i {
...We find the combinations of that length of words in @stickerList.
for @stickerList.combinations($i) -> @combo {
We make another Bag consisting of the letters in that combination.
my $sticker = Bag.new(@combo.join.comb);
If $chars is a subset of $sticker the result is the number of words in
@combo. We are finished so we can break out of the outer loop.
if $chars ⊆ $sticker {
$result = @combo.elems;
last LOOP;
}
}
}
Lastly, we print the result.
say $result;
As is usually the case, I had to write some additional code to translate my Raku solution to Perl. Luckily,
some of it was already done. combinations() for instance is a function that I have used in many previous
weeks challenges.
isSubset() was introduced above.
combUnique() is a stripped down version of combGrepUniqueLc() from above.
sub combUnique {
my ($str) = @_;
my @chars = split //, $str;
my %unique;
for my $c (@chars) {
$unique{$c}++;
}
return keys %unique;
}
This is my version of xx.
sub xx {
my ($array, $amount) = @_;
my @result = @{$array};
for (1 .. $amount - 1) {
push @result, @{$array};
}
return @result;
}
Now the rest of the script is more or less the same as Raku.
my ($word, @stickers) = @ARGV;
unless (isSubset([combUnique($word)], [combUnique(join q{}, @stickers)])) {
say 0;
exit;
}
my @stickerList = xx(\@stickers, scalar combUnique($word));
my @chars = split //, $word;
my $result = 0;
LOOP: for my $i (1 .. scalar @stickerList) {
for my $combo (combinations(\@stickerList, $i)) {
my @sticker = split //, (join q{}, @{$combo});
if (isSubset(\@chars, \@sticker)) {
$result = scalar @{$combo};
last LOOP;
}
}
}
say $result;