Perl Weekly Challenge in Raku : Week 55

So it's been a few weeks, I don't know about you but I've been a bit stressed so blogging about the challenges has been a bit hard. Still I'm also lucky to be working in a job I enjoy from home. Stay safe everyone and lets take a look at this weeks challenges

Challenge 1

As is often the way my first thought on a challenge like this is to approach it with brute force and ignorance. I generally find that throwing computing power at the problem can often solve it quickly, if it doesn't I'll use my more valuable (and somewhat ageing) brainpower instead.

The first thing I decided was I'd represent my binary strings as Arrays, this is because I find bit twiddling annoying at the best of times and reserve it for instances when it's absolutely necessary. I value readability of my code and I just can't read masks and binary wibbly things all the easily.

So with that in mind here's a simple function that given an array of 1s and 0s plus a start and end index flips all the ones in between.

sub flip( @bin is copy, $l, $r ) {
    @bin[$l..$r] = @bin[$l..$r].map( { abs($_-1) } );
    @bin;
}

This makes use of a few neat things. Firstly you can assign to an array slice so we modify the slice and assign back into it. The second thing is that abs(x-1) for x=0 and x=1 returns the flipped value as abs(0-1) == abs(-1) == 1 and abs(1-1) == 0. So it makes the flipping itself nice and easy.

After that we just need to loop through all the possible values for l and r and keep track of the results with the most elements. For this we can use a stream cache, where we store the value of the most elements found and the list of all those results. For each new result if it's got more 1s than the current highest we reset the list of just have out new result and update the highest value. If it's got the same number of 1s we add it to the current list, otherwise we ignore it.

This is a useful trick when you're dealing with a stream of data and you know what you're looking but you don't know how much data you're going to have. Putting everything into a hash and iterating over that after can lead to memory issues.

Anyhow, here's the main loop.

#| Given a binary string find the start and end points
#| for flipping the bits that results in the most 1's
#| in the final string
sub MAIN( Str $bin where { m!^ <[10]>+ $! } ) {
    my @bin = $bin.comb;

    my @results;
    my $len = 0;

    for [e-mail]-1 -> $l {
        for $[e-mail]-1 -> $r {
            my @res = flip(@bin,$l,$r);
            given @res.grep(* == 1).elems {
                when * > $len {
                    $len = $_;
                    @results = [ { l => $l, r => $r, bin => @res.join("") }, ];
                }
                when $len {
                    @results.push( { l => $l, r => $r, bin => @res.join("") } );
                }
            }
        }
    }
    say "Max 1's : {$len}";
    say "{$_<l>} -> {$_<r>} : {$_<bin>}" for @results;
}

Challenge 2

So Challenge 2 is about doing a Wave Sort, which is where a list a,b,c,d,e is sorted so that a >= b <= c >= d <= e and so on. There's probably a nifty way to make a custom infix operator that can handle this using chaining but I decided to go old school (Edinburgh University AI department in the 90's to be exact) and use the Prolog like abilities of the Raku Multi Dispatch model.

First up we need a way to get the unique permutations of a list. The challenge states your list can have non unique values in and the standard permutations method treats each element as unique so for the the (1,1) will give two results (1,1),(1,1) which is not what we want.

My original version of this got all the permutations joined them with commas and put the in a set to get the unique keys and split them up. The problem with this is permutations returns a Sequnece which is evaluated lazily whilst that had to calculate all the permutations before anything could be done.

So then I came up with a nest method involving gather / take and a hash to give a sequence of values.

And then while writing this I thought, surely Raku has a unique method? And lo and behold my final unique permissions sub:

sub unique-perms ( @input ) {
    @input.permutations.unique(:as(*.join(",")));
}

This uses the :as option to specific how to change the input for === comparison and it slightly fasted then using :with(&infix:<~~>). This gives us a sequence which means our code to check each permutation and see if it's valid is simple enough and can make use of race to give us simple threading.

#| Given a list of integers return all the wave sorted lists
multi sub MAIN( *@input where { $_.elems >= 2 && $_.all ~~ Int } ) {
    .say for unique-perms( @input ).race.grep( -> @l { is-wave( 'gte', |@l ) } );
}

...

Oh yeah. What's in is-wave and where's the Prolog you talked about?

So first thing you'll note is is-wave take a staring string argument of gte (for >=) and then take the array the permutation as a set of arguments by having the | slip operator in front (I believe some language use ... to do this?)

So lets go through some possible ways this function could be called :

multi sub is-wave( 'gte', Int $a, Int $b where { $b > $a }, *@ ) {
    False 
}

So if we call it with gte, two integers ($a and $b) and some more positional arguments *@ but $b is greater then $a we return False.

There are two other simple results :

multi sub is-wave( 'gte', Int $a, Int $b where { $a >= $b } ) { 
    True 
}
multi sub is-wave( 'gte', Int $a, Int $b where { $a < $b } ) { 
    False 
}

There's two cases where we call is-wave with gte and just two arguments. In on case $a is >= $b so we return True and in the other it isn't so we return False

This leaves us with one last possibly situation. More than two arguments and $a >= $b...

multi sub is-wave( 
                   'gte', 
                   Int $a, 
                   Int $b where { $a >= $b }, 
                   $c, 
                   *@r 
                 ) { 
    True && is-wave( 'lte', $b, $c, |@r ); 
}

So here we take 3 values where $a >= $b then we recurse into is-wave but now we pass lte, $b, $c and the rest of the list @r (this may be empty).

The code for the lte options are basically the same giving use this :

multi sub is-wave( 'lte', Int $a, Int $b where { $a <= $b } )
    { True }
multi sub is-wave( 'lte', Int $a, Int $b where { $a > $b } )
    { False }
multi sub is-wave( 'gte', Int $a, Int $b where { $a >= $b } )          
    { True }
multi sub is-wave( 'gte', Int $a, Int $b where { $a < $b } )           
    { False }
multi sub is-wave( 'gte', Int $a, Int $b where { $a < $b }, *@ )       
    { False }
multi sub is-wave( 'lte', Int $a, Int $b where { $a > $b }, *@ )       
    { False }
multi sub is-wave( 'gte', Int $a, Int $b where { $a >= $b }, $c, *@r )
    { True && is-wave( 'lte', $b, $c, |@r ); }
multi sub is-wave( 'lte', Int $a, Int $b where { $a <= $b }, $c, *@r )        
    { True && is-wave( 'gte', $b, $c, |@r ); }

There's probably a more elegant way to solve the problem without my brute force "Find every possible list and filter out the right ones" way but I do love that piece of code right there for it's simple elegance and the power that multi dispatch can bring to the table.

Comments

[Elizabeth Mattijsen]

You can actually get even more declarative in some of the is-wave candidates:

multi sub is-wave( 'gte', Int $a, Int $b where { $a < $b } --> False ) { }         

This also gives the optimizer more to go on.

[Simon Proctor]

I tried a couple of other methods later. I'll maybe blog about them soon.

[James245332]

Good