Perl Weekly Challenge: Week 55

This week I've had very little time (despite all the coronavirus downtime) to work on the challenge so I feel the code shown below doesn't demonstrate my best. Oh well...

Challenge 1:

Flip Binary

You are given a binary number B, consisting of N binary digits 0 or 1: s0, s1, …, s(N-1).

Choose two indices L and R such that 0 ⋜ L ⋜ R < N and flip the digits s(L), s(L+1), …, s(R). By flipping, we mean change 0 to 1 and vice-versa.

For example, given the binary number 010, the possible flip pair results are listed below:

Write a script to find the indices (L,R) that results in a binary number with maximum number of 1s. If you find more than one maximal pair L,R then print all of them.

Continuing our example, note that we had three pairs (L=0, R=0), (L=0, R=2), and (L=2, R=2) that resulted in a binary number with two 1s, which was the maximum. So we would print all three pairs.

Because there is the possiblity of multiple indices having the maximum numbers of 1s, I couldn't just keep the largest as I looped through the possibilities so I decided to store them all in the hash %lengths and work out the and work out the answer at the end.

my %lengths;

Then I looped through the combinations of $l and $r.

for my $l (0 .. (length $binary) - 1) {
    for my $r (0 .. (length $binary) - 1) {

At first I thought I would flip digits in place but I eventually decided it would be simpler to work on a copy of the binary number (split into an array for easier manipulation.) 

        my @digits = split //, $binary;

If the digit is 0 it becomes 1 and if 1 it becomes 0. Simple.

        for my $i ($l .. $r) {
            $digits[$i]  = ($digits[$i] == '0') ? '1' : '0';
        }

Then we determine how many of the digits are 1s. If there are any, the $l,$r pair gets added to the %lengths hash. The key is the number of 1s. The value is an array to accomodate multiple pairs with the same number of 1s.

        my $ones = grep /1/, @digits;
        if ($ones) {
            push @{$lengths{$ones}}, [$l, $r];
        }
    }
}

Once we have processed all combinations, we can find out what was the maximial number of 1s.

my $max = (sort { $b <=> $a } keys %lengths)[0];
if ($max) {

And then print out each pair which have that number.

    for my $pair (@{$lengths{$max}}) {
        say "($pair->[0],$pair->[1])";
    }
}

(Full code on Github.)

The raku version is a pretty pedestrian port of the Perl version. I definitely feel there is scope for making it more idiomatic (using Z or .permutations maybe?) but I didn't have time to explore that.

multi sub MAIN(Str $binary where { /^ [0 || 1]+ $/ }) {
    my %lengths;

    for 0 ..^ $binary.chars -> $l {
        for 0 ..^ $binary.chars -> $r {
            my @digits = $binary.comb;
            for $l .. $r -> $i {
                @digits[$i]  = (@digits[$i] == '0') ?? '1' !! '0';
            }

            my $ones = (@digits.grep(1)).elems;
            if $ones {
                %lengths{$ones}.push([$l, $r]);
            }
        }
    }

    my $max = (%lengths.keys.sort({ $^b <=> $^a}))[0];
    if ($max) {
        for %lengths{$max}.Array -> $pair {
            say '(', $pair.join(q{,}), ')';
        }
    }
}

(Full code on Github.)

Challenge 2:

Wave Array

Any array N of non-unique, unsorted integers can be arranged into a wave-like array such that n1 ⋝ n2 ⋜ n3 ⋝ n4 ⋜ n5 and so on.

For example, given the array [1, 2, 3, 4], possible wave arrays include [2, 1, 4, 3] or [4, 1, 3, 2], since 2 ⋝ 1 ⋜ 4 ⋝ 3 and 4 ⋝ 1 ⋜ 3 ⋝ 2. This is not a complete list.

Write a script to print all possible wave arrays for an integer array N of arbitrary length.

Notes:

When considering N of any length, note that the first element is always greater than or equal to the second, and then the ⋜, ⋝, ⋜, … sequence alternates until the end of the array.

Aargh! It was only after I submitted this weeks challenges that I noticed I haven't done this task properly at all. The code below only produces one wave array instead of all possible ones.

my @numbers = sort @ARGV;
my @wave;

my $mid = (scalar @numbers) / 2;
my $end = (scalar @numbers) - 1;

for my $i (0 .. $mid - 1) {
    push @wave, $numbers[$end--];
    push @wave, $numbers[$i];
}
if (scalar @numbers % 2) {
    push @wave, $numbers[$mid];
}

say join q{,}, @wave;

(Full code on Github.)

multi sub MAIN(*@ARGS where { @*ARGS.elems }) {
    my @numbers = @*ARGS.sort;
    my @wave;

A little gotcha you can run into in Raku is that if you divide two indivisble integers / does not round down to the nearest integer but gives you a rational number. I.e. 5 / 2 in Perl would be 2 whereas it would be 2.5 in Raku. Arguably that's more correct but it is not what I was expecting. You can get the "old" behaviour in Raku by using the div operator instead. 

    my $mid = @numbers.elems div 2;
    my $end = @numbers.elems - 1;

    for 0 ..^ $mid -> $i {
        @wave.push(@numbers[$end--]);
        @wave.push(@numbers[$i]);
    }
    if @numbers.elems % 2 {
        @wave.push(@numbers[$mid]);
    }

    say join q{,}, @wave;
}

(Full code on Github.)