Perl Weekly Challenge: Week 191
Challenge 1:
Twice Largest
You are given list of integers,
@list.Write a script to find out whether the largest item in the list is at least twice as large as each of the other items.
Example 1
Input: @list = (1,2,3,4)
Output: -1
The largest in the given list is 4. However 4 is not greater than twice of every remaining elements.
1 x 2 <= 4
2 x 2 <= 4
2 x 3 > 4
Example 2
Input: @list = (1,2,0,5)
Output: 1
The largest in the given list is 5. Also 5 is greater than twice of every remaining elements.
1 x 2 <= 5
2 x 2 <= 5
0 x 2 <= 5
Example 3
Input: @list = (2,6,3,1)
Output: 1
The largest in the given list is 6. Also 6 is greater than twice of every remaining elements.
2 x 2 <= 6
3 x 2 <= 6
1 x 2 <= 6
Example 4
Input: @list = (4,5,2,3)
Output: -1
The largest in the given list is 5. Also 5 is not greater than twice of every remaining elements.
4 x 2 > 5
2 x 2 <= 5
3 x 2 > 5
My first attempt in Raku looked like this:
Because we receive @list from the command line it is immutable. So the first thing I did was copy it to a new, mutable, sorted list.
my @sorted = @list.sort;
Then everything happens in one line. Because @sorted ia, well, sorted, we know the largest value will be the last element (@sorted[*-1]). The rest of the elements (@sorted[0 ..^ *-1]) are all doubled at once using the hyper operator (>>*>> 2)
Then using the .all() method of the list, the elements are compared with the largest value. If they are all less or equal, we print 1 otherwise we print -1.
say (@sorted[0 ..^ *-1] >>*>> 2).all <= @sorted[*-1] ?? 1 !! -1;
This worked but I had an epiphany. Because the list is sorted, I only actually need to compare the largest value to the second-largest value. If that is less than or equal to the largest, it automatically means all the other elements are less than or equal. So the code I actually submitted looks like this:
say @sorted[*-2] * 2 <= @sorted[*-1] ?? 1 !! -1;
It was a very straightforward port to Perl.
say $sorted[-2] * 2 <= $sorted[-1] ? 1 : -1;
Challenge 2:
Cute List
You are given an integer,
0 < $n <= 15.Write a script to find the number of orderings of numbers that form a cute list.
With an input @list = (1, 2, 3, .. $n) for positive integer $n, an ordering of @list is cute if for every entry, indexed with a base of 1, either
1) $list[$i] is evenly divisible by $i
or
2) $i is evenly divisible by $list[$i]
Example
Input: $n = 2
Ouput: 2
Since $n = 2, the list can be made up of two integers only i.e. 1 and 2.
Therefore we can have two list i.e. (1,2) and (2,1).
@list = (1,2) is cute since $list[1] = 1 is divisible by 1 and $list[2] = 2 is divisible by 2.
I should mention at the outset that the code I am about to show you is suboptimal. It should and does work for all the input
specified but as $n grow bigger, it gets slower. On my laptop, I only got to 10 in any decent amount of time. Unfortunately,
I ran out of time to optimize it.
The core of the script is this line:
(1 .. $n).permutations.grep({ isCute(@$_); }).elems.say;
It makes a list of consecutive integers from 1 to $n, generates a list of permutations of those integers with the .permutations
method and searches the permutations for cute lists using isCute(). The number of cute lists found is printed.
This is isCute().
sub isCute(@list) {
One requirement of this challenge is that the lists we examine should be indexed from 1 instead of the usual 0.Another variable holds the total number of cute elements we shall find.
my $i = 1;
my $cute = 0;
For each element in the list...
for @list -> $elem {
If it meets the requirements set forth in the spec, the total is incremented.
if ($i %% $elem || $elem %% $i) {
$cute++;
}
In any case, $i is incremented.
$i++;
}
If the total number of elements in the list is equal to the number of cute elements, the list is cute so we can return true or if not, false.
return @list.elems == $cute;
}
There is an easy optimization we can make.
sub isCute(@list) {
my $i = 1;
for @list -> $elem {
Instead of integer modulus (%%), we can use the regular modulus operator (%) which will be true if the condition is not
evenly divisible. If both conditions are true, it means the element was not cute which means the list itself is not cute and
there is no point in checking the rest of the elements; we can immediately return false.
if ($i % $elem && $elem % $i) {
return False;
}
$i++;
}
return True;
}
Despite this, the script is, as I mentioned, rather slow. Both Raku and (with a little help) Perl have facilities for parallel processing which would probably speed things up quite a bit on modern hardware. But if I had to hazard a guess, the place to focus on would be the permutations generating code. The number of permutations grows exponentially as $n grows larger and I'm guessing
it is not neccessary to check every single one. Perhaps some time when I am less busy, I will look into it.
For completeness's sake, here is the Perl version. It uses the permute() method I've used in previous challenges. Alas, it suffers from the same defects as the Raku version.
sub isCute {
my ($list) = @_;
my $i = 1;
for my $elem (@{$list}) {
if ($i % $elem && $elem % $i) {
return undef;
}
$i++;
}
return 1;
}
my @perms;
permute { push @perms, \@_; } (1 .. $n);
say scalar grep { isCute($_) } @perms;