THE WEEKLY CHALLENGE – PERL & RAKU #55
TASK #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:
- L=0, R=0 the result binary:
110 - L=0, R=1 the result binary:
100 - L=0, R=2 the result binary:
101 - L=1, R=1 the result binary:
000 - L=1, R=2 the result binary:
001 - L=2, R=2 the result binary:
011
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.
Method
What a strange puzzle. That’s it, had to get that out there.
In any case, the challenge is that given an array of 1s and 0s, we construct windows to map on that array within which we toggle the values, so that 1 -> 0 and 0 -> 1. After the transformation we count the 1s for the whole array and produce the parameters of those windows that maximise this value.
There are quite a few moving parts to this challenge. We need to:
- construct the window endpoints
- flip the bits within the endpoints
- count the ones
- keep track of the tally, cross-referenced to the window endpoints
- find and output the pairs that produce the largest value
To create the windows, we need two loops: one to establish the starting index, the second to determine the width, which in turn can be used to determine the ending index.
Within each inner loop, we construct a string of 0s the same length as the binary input, with 1s placed in the window. This will serve as a bitmask. We can flip any bit by XORing that bit with 1 so converting the input and the bitmask to decimal and applying xor, then stringifying back to base 2 will give us the result we need.
There’s a variety of ways we can count the ones after we first we split the string into an array. Because the data, 1 is the same as the incidence, we could for instance sum the digits, which would increment the count 1 for every 1 and add nothing for the 0s.
$sum += $_ for split //, $str;
is cute and effective. Or use List::Util::sum for the task. Or use grep and a scalar context to directly count:
$sum = grep /1/, split //, $str;
I can’t decide who’s prettier.
We need three related values to determine the output: the xor’d binary string, the count of 1s in that string and the window coordinates that created it. Two parallel hashes keyed on the binary string serve here. We extract the maximum value of the counted 1s and use this as a filter to make a list of those binary strings that produce that value. Then we can iterate over that list and lookup the window left and right indices that correspond for output.
Perl Solution
[colincrain:~/PWC]$ perl 55_1_flipper.pl 100110011
100110011 binary input
111110011 result for L=1, R=2
111001111 result for L=1, R=6
100111111 result for L=5, R=6use warnings;
use strict;
use feature ":5.26";
## ## ## ## ## MAIN:
my $bin = shift @ARGV // '100110011';
my $len = length $bin;
my $num = oct('0b' . $bin);
say "$bin binary input";
my %ones;
my %windows;
for my $start ( 0..$len-1) {
for my $span ( 1..$len-$start) {
## make bitmask
my $mask = ('0' x $start).('1' x $span).( '0' x ( $len - ($start + $span)));
## convert to decimal, xor with input number and back to binary
my $xbin = sprintf "%0" . "$len" . "b", $num ^ oct('0b' . $mask);
## hash number of 1s keyed on xor result, hash window start, end indices
## keyed on xor result
$ones{$xbin} = count_ones( $xbin );
$windows{$xbin} = [$start, $start+$span-1];
}
}
my $maxval = (sort {$a<=>$b} values %ones)[-1];
my @max = grep { $ones{$_} == $maxval } keys %ones;
say "$_ result for L=$windows{$_}->[0], R=$windows{$_}->[1]" for sort {
$windows{$a}->[0] <=> $windows{$b}->[0]
||
$windows{$a}->[1] <=> $windows{$b}->[1]
} @max;
## ## ## ## ## SUBS:
sub count_ones {
my $str = shift;
my $sum;
$sum += $_ for split //, $str;
return $sum;
}Raku Solution
Counting the 1s can be swiftly dispatched in Raku by spitting the string into characters with comb and summing the resulting array. Because the item we are counting, 1s, have the same value as their incidence, this works out nicely.
sub MAIN ( Str:D $binary = '100110011' ) {
say "$binary binary input";
my $chars = $binary.chars;
my $num = :2( $binary );
my %ones;
my %windows;
for ( 0..$chars-1) -> $start {
for ( 1..$chars-$start) -> $span {
my $mskbin = ('0' x $start) ~ ('1' x $span) ~ ( '0' x ( $chars - ($start + $span)));
my $mask = :2( $mskbin ); ## convert binary mask string to decimal number
my $xorbin = ($num +^ $mask).base(2); ## xor and convert to binary
%ones{$xorbin} = $xorbin.comb.sum; ## hash summed digits keyed on xor result
%windows{$xorbin} = [$start, $start+$span-1]; ## hash window parameters keyed on xor result
}
}
my @max = %ones.keys.grep( { %ones{$_} == %ones.values.max } );
my $sort = sub { %windows{$^a}[0] <=> %windows{$^b}[0] || %windows{$^a}[1] <=> %windows{$^b}[1] }
say "$_ result for L=%windows{$_}[0], R=%windows{$_}[1]" for @max.sort( $sort );
}
TASK #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.
Method
method: A wave sequence can be considered a special case of permutation, with the valid arrangements restricted by the greater than / less than cycle. As such it makes sense to proceed like a permutation generator, with the addition that we immediately throw out cases as they are formed when the next digit cannot fit the requirements.
The recursive function
wave_at_yourself(\@set, \@working, $waves, $direction)
takes a set of remaining possible list values, a working list under construction, an array holding references to completed wave sequences and a direction flag that toggles every recursion.
With each instantation we toggle the direction, refer to the last number placed on the working array and construct a subset of values either less than or greater than (or equal to) the previous value, as directed. For each of the possible next values in the subset, new sets are made moving the value from the possible values set to the working set and the function is called again using these. If at any time the subset has no values but we are not finished we have reached a contradiction and we return empty handed. If both the larger set and the subset each only have one value we have succesfully allocated our elements accoring to the rules and have completed a wave.
Between iterating over only the values greater or less than the previous and pruning the tree early when we cannot continue, the search space looking for valid solutions is greatly reduced as compared to a simple permutation recursion.
In permutation theory the actual values are not relevant, so a sequence of integers ( 1, 2, 3, 4, 5…) is substituted instead. So if we give a single arguant of the command line, it computes on an array of that length. Default is 5. Passing any arbitrary array of integers works as expected.
Perl Solution
[colincrain@boris:~/Code/PWC]$ perl 55_2_waves.pl
[ 2, 1, 4, 3, 5 ]
[ 2, 1, 5, 3, 4 ]
[ 3, 1, 4, 2, 5 ]
[ 3, 1, 5, 2, 4 ]
[ 3, 2, 4, 1, 5 ]
[ 3, 2, 5, 1, 4 ]
[ 4, 1, 3, 2, 5 ]
[ 4, 1, 5, 2, 3 ]
[ 4, 2, 3, 1, 5 ]
[ 4, 2, 5, 1, 3 ]
[ 4, 3, 5, 1, 2 ]
[ 5, 1, 3, 2, 4 ]
[ 5, 1, 4, 2, 3 ]
[ 5, 2, 3, 1, 4 ]
[ 5, 2, 4, 1, 3 ]
[ 5, 3, 4, 1, 2 ]use warnings;
use strict;
use feature ":5.26";
## ## ## ## ## MAIN:
my @input_array = sort {$a <=> $b} @ARGV;
my $array_length = scalar $ARGV[0] // 5;
@input_array = (1..$array_length) if scalar @ARGV < 2;
my @working;
my $waves = [];
my $direction = 0;
wave_at_yourself( \@input_array, \@working, $waves, $direction);
say '[ ', (join ', ', $_->@*), ' ]' for $waves->@*;
## ## ## ## ## SUBS:
sub wave_at_yourself {
## given a starting set, a working list and a waves set
## computes complete waves as arrays and places the arrays on the waves array
## which is maintained throughout by reference
## $direction: 1 => gt, 0 => lt
my ($setref, $workref, $waves, $direction) = @_;
my @set = $setref->@*;
## toggle direction every recursion
$direction ^= 1;
## the subset is those elements that are either greater or equal to or less
## than or equal to the previous element as selected by the direction.
## if the subset size is 0 we cannot continue and bail without adding to the
## waves array
my $prev = $workref->[-1];
my @subset = defined $prev ? grep { $direction ? $_ >= $prev : $_ <= $prev } @set : @set;
return if (scalar @subset == 0);
## if there is only one element left in both the set and the subset,
## then we have successfully made a wave.
## we push it onto the working list,
## push that array reference onto the waves array and return.
## This unique wave is complete.
if ( scalar @set == 1 && scalar @subset == 1 ) {
my @working = $workref->@*;
push @working, $set[0];
push $waves->@*, \@working;
return;
}
## iterate through the remaining elements of the set,
## creating new copy of the working list, moving the element
## from the set to the working list and recursing with these
## new lists. The waves list reference is passed through unchanged.
for my $element ( @subset ) {
my @working = $workref->@*;
push @working, $element;
my @set_minus_one = grep { $_ != $element } @set;
wave_at_yourself( \@set_minus_one, \@working, $waves, $direction );
}
}Raku Solution
In raku it might be tempting to use the .permutations routine, check and filter the results for valid sequences. However this method will require computing every single permutation first, which for longer sequences will become increasingly computationally intensive. So we won’t do that today. YMMV.
sub MAIN (*@input) {
my @set = @input.elems < 2 ?? 1..@input[0] !! @input.sort({ $^a <=> $^b });
my @working;
my @waves;
my $direction = 0;
wave_at_yourself( @set, @working, @waves, $direction);
.join(', ').say for @waves;
}
sub wave_at_yourself ( @prev_set, @prev_working, @waves, $direction is copy){
## Given a starting set, a working list, a waves set and a direction,
## computes complete waves as arrays and places the arrays on the waves array
## direction: 0 => down, 1 => up
## Toggle direction every recursion
$direction +^= 1;
## Create a new copy of the previous set
my @set = @prev_set;
## The subset is those elements that are either ≥ or ≤ the previous element
## as selected. If the subset size is 0 we cannot continue and bail without
## adding to the waves array. Not sure where I stand on using the non-ascii
## glyph options for overall readability.
my $prev = @prev_working.tail;
my @subset = $prev.defined
?? @set.grep({ $direction ?? $_ ≥ $prev !! $_ ≤ $prev })
!! @set;
return if @subset.elems == 0;
## If there is only one element left in both the set and the subset,
## then we have successfully made a wave.
## We add it to the working list,
## push that array onto the waves array and return.
## This unique wave is complete.
if ( @set.elems == 1 && @subset.elems == 1 ) {
my @working = @prev_working;
@working.append: @set;
@waves.push: @working;
return;
}
## Iterate through the remaining elements of the set, for each creating new
## copy of the working list, moving the selected element from the current
## set to the working list and recursing with these new lists.
for @subset -> $element {
my @working = @prev_working;
@working.push: $element;
my @set_minus_one = @set.grep: { $_ != $element };
wave_at_yourself( @set_minus_one, @working, @waves, $direction );
}
}
Programming Excursions in Perl and Raku 