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

(Full code on Github.)

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

(Full code on Github.)

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) ={ ($_.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{)};

(Full code on Github.)

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}) {

    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;

        join q{, },
            sort { $a <=> $b } 
                intersection($array1, $array2),
                intersection($array2, $array3),
                intersection($array1, $array3)

(Full code on Github.)