Perl Weekly Challenge: Week 220
Challenge 1:
Common Characters
You are given a list of words.
Write a script to return the list of common characters (sorted alphabeticall) found in every word of the given list.
Example 1
Input: @words = ("Perl", "Rust", "Raku")
Output: ("r")
Example 2
Input: @words = ("love", "live", "leave")
Output: ("e", "l", "v")
Everyone loves one-liners right? Here's a one-liner in Raku that solves this challenge.
Starting from the middle and working outwards, first the command-line arguments which represent words
are split into arrays of characters with .map() and .comb(). A second .map() also converts the
characters to lower case. The [∩] operator returns the intersection of these arrays. The return type is
a Set which is a kind of hash so you need .keys() to actually get the intersecting characters out. The characters are then sorted in ascending alphabetical order with .sort() and the rest of the code is just
for printing them out nicely in the style of the examples.
say q{("}, ([∩] @*ARGS.map({ $_.comb.map({ $_.lc }) })).keys.sort.join(q{", "}), q{")}
Perl, as usual, requires more work. I had to make my own quick and dirty intersection() function which looks like this:
sub intersection {
It takes two parameters, a reference to an list of arrays and the number of arrays. I probably didn't need the second parameter as this can be calculated based on the first but I told you this is quick and dirty.
my ($arrays, $n) = @_;
Every character in each array is counted in a hash imaginatively named %count. The keys of this
hash are the characters and the values the number of times the character occurs.
my %count;
for my $arr (@{$arrays}) {
for my $char (@{$arr}) {
$count{$char}++;
}
}
If the number of occurrences is greater than $n it means the character has occurred in every set. Well, this does
coincidentally work for the examples but it easily might not. For instance the input ("aaa", "b" "c") would
falsely return "a" as the intersection. Did I mention that this is quick and dirty?
The proper way I think would have been to first find the unique characters in each separate array and then add
them to %count.
return grep { $count{$_} >= $n} keys %count;
}
Whatever the merits of intersection(), armed with it, the rest of the script works the same as the Raku version.
my @words = map { [map { lc } split //] } @ARGV;
my @common = intersection(\@words, scalar @ARGV);
say q{("}, (join q{", "}, sort @common), q{")};
Challenge 2:
Squareful
You are given an array of integers, @ints.
An array is squareful if the sum of every pair of adjacent elements is a perfect square.
Write a script to find all the permutations of the given array that are squareful.
Example 1
Input: @ints = (1, 17, 8)
Output: (1, 8, 17), (17, 8, 1)
(1, 8, 17) since 1 + 8 => 9, a perfect square and also 8 + 17 => 25 is perfect square too.
(17, 8, 1) since 17 + 8 => 25, a perfect square and also 8 + 1 => 9 is perfect square too.
Example 2
Input: @ints = (2, 2, 2)
Output: (2, 2, 2)
There is only one permutation possible.
Once I understood what the problem was actually trying to say, this became quite simple in Raku.
This is a variable which will hold our results.
my @results;
Then we find all the permutations of the input array with .permutations().
for @ints.permutations -> $perm {
At the start we are going to optimistically assume the permutation is squareful.
my $squareful = True;
Then we go through each pair of elements in the permutation...
for 1 .. @$perm.end -> $n {
...check if the square root of their total is an integer. If it is not...
if sqrt(@$perm[$n - 1] + @$perm[$n]) % 1 != 0 {
the permutation is not squareful; we can abandon ship.
$squareful = False;
last;
}
}
If it turns out to actually be squareful, the permutation is joined up into a string and
added to @results. The extra text which is concatenated is to help make the output look
like that in the example.
if $squareful {
@results.push(q{(} ~ @$perm.join(q{, }) ~ q{)});
}
}
Once we have all the results, we can print them out comma-separated. There is one small step to
take first. .permutations() doesn't distinguish between i.e. (1, 2, 3) and (3,2, 1); it will
treat them as different permutations so we may end up with duplicates in our output. (As with example 2
for instance.) So we have to add a call to .unique() to filter those duplicates out.
@results.unique.join(q{, }).say;
Translating my Raku solution to Perl had the perennial problem of missing functionality. Luckily I have
long had permute() and unique() routines from previous challenges so that wasn't a big deal.
my @results;
my @permutations;
permute { push @permutations, \@_; } @ARGV;
for my $perm (@permutations) {
Also using 1 and undef instead of the missing True and False is also trivial to change.
my $squareful = 1;
for my $n (1 .. scalar @{$perm} - 1) {
But what really gave me a hard time is that the % operator works differently in Perl. I don't
know if it is mathematically "better" or "worse" than the way Raku's version works but I was unable
to get it to provide the same functionality.
So Instead I made getting the square root of a pair of elements a separate step.
my $root = sqrt($perm->[$n - 1] + $perm->[$n]);
I used that value and ran it through the int() function. If the two numbers are unequal this means
the square root is not an integer. Again, being mathematically challenged, I don't know if there is
a simpler work around but this worked for me.
if ($root != int $root) {
$squareful = undef;
last;
}
}
if ($squareful) {
push @results, q{(} . (join q{, }, @{$perm}) . q{)};
}
}
say join q{, }, unique(@results);