Perl Weekly Challenge: Week 83

Challenge 1:

Words Length

You are given a string $S with 3 or more words.

Write a script to find the length of the string except the first and last words ignoring whitespace.

Example 1:

Input: $S = "The Weekly Challenge"

Output: 6

Example 2:

Input: $S = "The purpose of our lives is to be happy"

Output: 23

Thanks to the power of regular expressions, we can solve this as a one-liner. Here is the Perl version split up so it is easier to read.

We receive the array as the array of command line arguments so the first thing to do is join them back up again into a string.

$_ = join q{ }, @ARGV;

Then, using a regular expression, we extract from it everything except the first and last words and adjacent white space. The captured text then has all whitespace removed from it. Initially I did this as two separate regexps but I felt I should be able to combine them into one. After some experimentation, I came up with this:

s/ \A .+? \s+ (.+) \s+ .+? \z / $1 =~ s{\s}{}gr; /emsx;

The /e flag to the substitution operator allows us to run Perl code in the second half. I also always add the /m, /s, and /x flags so we can make the regular expression slightly easier to read. We take the text captured in the first half (stored as $1) and apply the second regexp to it which globally (/g) removes whitespace. One problem is that capture group labels such as $1 are immutable so we would not normally be able to do substitutions on them but the /r flag makes it possible. Another thing to note is that for the second regexp, I use the custom delimeters { } as it would be more confusing to read with extra /'s everywhere.

Finally, we count the length of the resulting string and print it.

say length;

(Full code on Github.)

I thought the Raku version would be even shorter because Raku is in general more concise than Perl but it actually came out almost the same length.

$_ = @*ARGS.join(q{ }); s/^ .+? \s+ (.+) \s+ .+? $/$0.subst(/\s/, q{}, :g)/; .chars.say;

(Full code on Github.)

Challenge 2:

Flip Array

You are given an array @A of positive numbers.

Write a script to flip the sign of some members of the given array so that the sum of the all members is minimum non-negative.

Given an array of positive elements, you have to flip the sign of some of its elements such that the resultant sum of the elements of array should be minimum non-negative(as close to zero as possible). Return the minimum no. of elements whose sign needs to be flipped such that the resultant sum is minimum non-negative.

Example 1:

Input: @A = (3, 10, 8)

Output: 1

EXPLANATION

Flipping the sign of just one element 10 gives the result 1 i.e. (3) + (-10) + (8) = 1

Example 2:

Input: @A = (12, 2, 10)

Output: 1

EXPLANATION

Flipping the sign of just one element 12 gives the result 0 i.e. (-12) + (2) + (10) = 0

This is my Raku solution.

I'm not sure if there is a better algorithm but what I did was to get every combination of indices of @A. (Raku lists have a handy builtin method for this.) This can range from the index of one element to the indices of the entire array.

For each of these combinations, I flipped the sign of the corresponding elements of @A. (Actually a copy called @a because @A is immutable.) Then I totaled up the values of @a. I kept a running total of the minimum non-negative value found so far and if the current value was smaller than it, it became the new minimum value. The current value of @a also gets saved into @result. After all the combinations have been processed, @result should contain the, well, result. We grep it for elements with negative elements, count them and print the answer.

sub MAIN(*@A) {
    my $min = ∞;
    my @result;

    for (0 ..^ @A.elems).combinations -> @combo {
        my @a = @A;

        for @combo -> $i {
            @a[$i] = -@a[$i];
        }

        my $total = [+] @a;

        if $total < $min && $total >= 0 {
            $min = $total;
            @result = @a;
        }
    }

    @result.grep({ $_ < 0; }).elems.say;
}

(Full code on Github.)

This is the Perl version.

my @A = @ARGV;
my $min = 'inf';
my @result;

Perl doesn't have .combinations but I had developed a workalike for Perl way back in challenge 38. The only problem is that it only generates combinations of a set length. So as an additional step I had to call it on a map() on the range 1 .. number of elements to get all the combinations.

my @allCombinations =
    map { combinations([0 .. scalar @A - 1], $_); } 1 .. scalar @A;

for my $combo (@allCombinations) {
    my @a = @A;

    for my $i (@{$combo}) {
        $a[$i] = -$a[$i];
    }

Perl also doesn't have [+]. Once again I used map() to work around this.

    my $total;
    map { $total += $_; } @a;

    if ($total < $min && $total >= 0) {
        $min = $total;
        @result = @a;
    }
}

say scalar grep { $_ < 0; } @result;

(Full code on Github.)