Perl Weekly Challenge: Week 303
Challenge 1:
3-digits Even
You are given a list (3 or more) of positive integers,
@ints.Write a script to return all even 3-digits integers that can be> formed using the integers in the given list.
Example 1
Input: @ints = (2, 1, 3, 0)
Output: (102, 120, 130, 132, 210, 230, 302, 310, 312, 320)
Example 2
Input: @ints = (2, 2, 8, 8, 2)
Output: (222, 228, 282, 288, 822, 828, 882)
Time for another Raku one-liner!
@*ARGS.permutations.map({ $_[0..2].join.Int }).grep({ $_.chars == 3 && $_%%2 }).unique.sort.say
The input is the command line arguments, @*ARGS. First I tried getting every combination of three arguments with
.combinations(3) but that didn't work because .combinations() only gives you unique combinations disregarding order. So instead
I used .permutations() which as the name suggests gives all permutations. The trouble is each permutation contains all the arguments while we only want combinations of three. I got around this by using .map() to get a slice of the the first three
elements. While I was at it, I also .join()ed the elements together into a string and converted that string into an integer with .Int(). If the combination began with a 0, the conversion to integer will result in a two digit number. So .grep() is used to
filter out the numbers which are three digits and even. If numbers are repeated in the input as in example 2, some combinations may
repeat. So we get rid of duplicates with .unique(). Although not strictly necessary, we .sort() the results before printing
them with .say().
The Perl version is longer because we need to add raku functions which are missing. In this case I needed, permute() and unique() which I already had from previous challenges.
my @ints = @ARGV;
my @permutations = permute @ints;
Although the rest is technically one line, I spread it out over several lines to be more readable.
The q{(}, .join(q{, }) and the q{)} at the end are merely for making the output more like that in the examples.
say q{(},
(join q{, },
For some reason sort() by itself didn't actually sort which I found surprising because the docs clearly state that "If SUBNAME or BLOCK is omitted, sorts in standard string comparison order." However I didn't
investigate further and just added a standard ascending numeric sort routine.
sort { $a <=> $b }
unique(
Perl doesn't have a %% operator so we have to do the test for evenness with the standard modulo (%) operator.
grep { length $_ == 3 && $_ % 2 == 0 }
map { int join q{}, @{$_}[0..2] }
@permutations
)
), q{)};
Challenge 2:
Delete and Earn
You are given an array of integers,
@ints.Write a script to return the maximum number of points you can earn by applying the following operation some number of times.
Pick any ints[i] and delete it to earn ints[i] points.
Afterwards, you must delete every element equal to ints[i] - 1
and every element equal to ints[i] + 1.
Example 1
Input: @ints = (3, 4, 2)
Output: 6
Delete 4 to earn 4 points, consequently, 3 is also deleted.
Finally delete 2 to earn 2 points.
Example 2
Input: @ints = (2, 2, 3, 3, 3, 4)
Output: 9
Delete a 3 to earn 3 points. All 2's and 4's are also deleted too.
Delete a 3 again to earn 3 points.
Delete a 3 once more to earn 3 points.
I had to read this a couple of times before I fully understood what needed to be done.
For e.g. example 2, we will need to know how many occurrences of a particular number are in @ints. An
easy way to do this is to convert @ints into a Bag. We call the new Bag %counts.
my %count = @ints.Bag;
Now we need to go through the unique numbers (i.e. the keys) in %count.
To determine the choice to pick to get the maximum possible points, we have to look at the current element and the one before it.
$previous keeps track of the previous number in the keys.
my $previous = 0;
$without represents the maximum points you can earn without using the current number.
my $without = 0;
$without represents the maximum points you can earn by using the current number.
my $current = 0;
For each key in %count (sorted in ascending numeric order)...
for %count.keys.sort({ $^a <=> $^b }) -> $k {
...if the current key is not consecutive to the previous one...
if $k - 1 != $previous {
...both $without and $current can be updated with the maximum of their previous values.
($without, $current) = (($without, $current).max, $k * %count{$k} + ($without, $current).max);
If the current key is consecutive, $current is updated with the sum of the current keys points and the previous $without value
whereas $withoutremains the maximum of the previous $without and $current values.
} else {
($without, $current) = (($without, $current).max, $k * %count{$k} + $without);
}
The current key becomes the previous key and the loop is run again.
$previous = $k;
}
Finally, the script returns the maximum of $without and $current, which represents the maximum points you can earn.
($without, $current).max.say;
Perl doesn't have Bags but all it is is a Hash where the keys are unique elements and the values, the number of times that element occurs. makeBag() converts a List into a suitable Hash.
sub makeBag(@array) {
my %bag;
for my $elem (@array) {
$bag{elem}++;
}
return %bag;
}
We also need to provide a max() replacement.
The rest of the script is just like the Raku version.
my @ints = @ARGV;
my %count = makeBag(@ints);
my $previous = 0;
my $without = 0;
my $current = 0;
for my $k (sort keys %count) {
if ($k - 1 != $previous) {
($without, $current) = (max($without, $current), $k * $count{$k} + max($without, $current));
} else {
($without, $current) = (max($without, $current), $k * $count{$k} + $without);
}
$previous = $k;
}
say max($without, $current);