Perl Weekly Challenge: Week 229
Challenge 1:
Lexicographic Order
You are given an array of strings.
Write a script to delete element which is not lexicographically sorted (forwards or backwards) and return the count of deletions.
Example 1
Input: @str = ("abc", "bce", "cae")
Output: 1
In the given array "cae" is the only element which is not lexicographically sorted.
Example 2
Input: @str = ("yxz", "cba", "mon")
Output: 2
In the given array "yxz" and "mon" are not lexicographically sorted.
The solution is a one-liner in Raku. We take the command-line arguments and search them non-lexicographically sorted elements
with .grep(). First we split each element into individual characters with .comb(), lexicographically .sort() them and
.join() them back up again assigning the result to the variable $x. (Why $x? Why not.) Then we check that neither the element itself or its reverse (produced with .flip()) is equal to $x. We count the number of such elements with .elems() and
print the result with .say().
@*ARGS.grep({my $x=$_.comb.sort.join;$_ ne $x && $_.flip ne $x}).elems.say
Don't worry about the mention of deletions in the spec. Deletion isn't actually necessary to produce the output.
Suprisingly, Perl can do it with only three additional characters. It's a lot less readable though IMHO.
say scalar grep{my $x=join q{},sort split //;$_ ne $x && reverse ne $x}@ARGV
Challenge 2:
Two Out of Three
You are given three array of integers.
Write a script to return all the elements that are present in at least 2 out of 3 given arrays.
Example 1
Input: @array1 = (1, 1, 2, 4)
@array2 = (2, 4)
@array3 = (4)
Ouput: (2, 4)
Example 2
Input: @array1 = (4, 1)
@array2 = (2, 4)
@array3 = (1, 2)
Ouput: (1, 2, 4)
The first problem I faced in solving this one was how to get the input into the script. The format I decided upon was to
have each argument be a string containg a list of numbers separated by spaces. So e.g. for example 1 "1 1 2 4" "2 4" "4"
The line below parses such a format and assigns the results into three arrays imaginativly named @array1, @array2and @array3.
my ($array1, $array2, $array3) = @args.map({ ($_.split(q{ })) });
Now using the ∩ operator we can find the intersections of each pair of arrays. Because we know we will only have three
arrays, we can hard code the combinations. Once we haave done this, we can combine the three Sets of intersections with the
∪ or union operator. The result is also a Set so we need .keys() to get the actual numbers out. The rest of the line is
only for presenting the output in the same form as in the examples.
say q{(}, ([∪] (@$array1 ∩ @$array2, @$array2 ∩ @$array3, @$array1 ∩ @$array3)).keys.sort.join(q{, }), q{)};
For Perl we need to fill in some gaps in functionality. perlfaq4 gives code for
calculating unions and intersections and I adapted that for the union() and intersection() functions below.
union() takes three array references as parameters and adds their elements to a hash. The keys are the elements and the values the number of times they appeared across three arrays. This function only returns the keys which has the side of effect of removing
duplicates. That's not strictly speaking a union from the mathematical point of view but it is good enough for the examples.
sub union {
my %count;
my ($arr1, $arr2, $arr3) = @_;
foreach my $elem (@{$arr1}, @{$arr2}, @{$arr3}) { $count{$elem}++ };
return keys %count;
}
intersection() takes two array references as parameters. Each of these arrays must consist of unique elements only.
sub intersection {
my ($arr1, $arr2) = @_;
my %count;
foreach my $elem (unique($arr1), unique($arr2)) { $count{$elem}++ };
return [ grep { $_ if $count{$_} > 1 } keys %count ];
}
So we process each array through a function called unique().
sub unique {
my ($arr) = @_;
my %unique;
for my $elem (@{$arr}) {
$unique{$elem}++;
}
return keys %unique;
}
Again this is not the proper mathematical definition of an intersection but it is good enough for our purposes.
Armed with these functions, we can translate the Raku MAIN() function, albeit somewhat more verbosely, like this:
my ($array1, $array2, $array3) = map { [split / /] } @ARGV;
say
q{(},
(
join q{, },
(
sort { $a <=> $b }
union(
intersection($array1, $array2),
intersection($array2, $array3),
intersection($array1, $array3)
)
)
),
q{)};