Perl Weekly Challenge: Week 384
Challenge 1:
Base N
You are given a number and a base integer.
Write a script to convert the given number in the given base integer.
Example 1
Input: $num = 42, $base = 2
Output: 101010
Example 2
Input: $num = 15642094, $base = 16
Output: EEADEE
Example 3
Input: $num = 493, $base = 8
Output: 755
Example 4
Input: $num = 2228519, $base = 36
Output: 1BRJB
Base 36 uses numbers 0-9 and letters A-Z.
Example 5
Input: $num = 123456789, $base = 64
Output: 7MyqL
Base 64 (using 0-9, A-Z, a-z, and extra symbols like + and /)
Given that Raku has methods for converting numbers to different bases, this should be the simplest one-line solution ever.
@*ARGS[0].Int.base(@*ARGS[1]).say
(Assuming $num and $base are from the first two command-line arguments.)
This works for examples 1-4 but 5 is a problem because $base is 64 and the
.base() method only converts bases from 2-36. So we will have to create our
own version which can deal with higher bases. Now .base() is a method of the
Int class in the Raku standard library. Would I wondered if it is possible to
extend .base() in some way to add the extra support? This led me down an interesting rabbit hole and the answer is yes you can!
The key is to use Rakus' Metaobject Protocol.
The ^lookup() method (Metaobject methods start with a ^) on a class looks up
a method and if it exists, returns Routine object that defines it. .wrap() in that object allows us to create a wrapper for that method. This wrapper can be any callable but I've chosen to use a lambda.
Int.^lookup('base').wrap(-> |args {
For convenience and readability, we convert the arguments passed to the lambda as named string variables.
my ($number, $base) = args».Str;
We define a variable to hold the return value.
my $return;
My extended .base() will only deal with bases from 2 upto 64. So we check
this and if the $base is out of range, we throw an exception.
if $base !~~ 2 .. 64 {
die "base $base is out of range";
}
If the base is 36 or less...
if $base <= 36 {
...we can fall back to Ints original .base() method. This is done via the
callsame function.
$return = callsame;
If the $number is 0 it's going to stay 0 in any base so in that case our return
value is just that.
} elsif $number == 0 {
$return = '0';
For all other cases, we have to do the conversion. The code I am using for this is actually from the Perl solution to challenge 2 in PWC 379 with a few changes.
} else {
For example the previous code only output digits for a maximum base of 36. Here I've extended it to base 64.
my @digits = ([0 ..9], ['A' .. 'Z'], ['a' .. 'z'], ['+', '/']).flat;
We restrict @digits to only the ones needed for $base.
@digits = @digits[0 ..^ $base];
An array holds the result.
my @result;
While $number is greater 0...
while $number > 0 {
...using the modulo operator % we find the remainder when dividing $number by $base. This will give the value of the lowest place digit.
my $digit = ($number % $base).Int;
The digit is used as a key into @digits and the value is added to the beginning of the @result.
@result.unshift(@digits[$digit]);
The digit is removed from $number and the loop continues.
$number = ($number / $base).Int;
}
Finally, we .join() the @result back together into a single string and assign
it to $return.
$return = @result.join(q{});
}
Whatever the outcome was, we return it.
$return;
});
Now we can use our one line solution again and this time it will work for all the examples.
$num.base($base).say;
This is the Perl version. The main difference is that we handle all of the conversions instead of falling back to existing code.
sub toBase($number, $base) {
if ($base < 2 || $base > 64) {
die "base $base is out of range\n";
}
my @digits = (0 .. 9, 'A' .. 'Z', 'a' .. 'z', '+', '/')[0 .. $base - 1];
my @result;
if ($number == 0) {
return 0;
}
while ($number > 0) {
my $digit = int($number % $base);
unshift @result, $digits[$digit];
$number = int($number / $base);
}
return join q{}, @result;
}
say toBase($number, $base);
Challenge 2:
Special Binary Substrings
You are given a binary string.
Write a script to return all non-empty substrings (distinct) that have the same number of 0’s and 1’s, and all the 0’s and all the 1’s in these substrings are grouped consecutively.
Example 1
Input: $binary = "0101"
Output: ("01", "10", "01")
Example 2
Input: $binary = "000111"
Output: ("000111", "0011", "01")
Example 3
Input: $binary = "000011"
Output: ("0011", "01")
Example 4
Input: $binary = "10011100"
Output: ("10", "0011", "01", "1100", "10")
Example 5
Input: $binary = "00000"
Output: ()
The solution is quite straightforward.
First we define an array to hold the results.
my @results;
In a double loop we get every substring of more than 1 character length. (Although the spec wants us to look at all non-empty substrings, the smallest successful match will have one 1 and one 0 for a length of 2.)
for 0 ..^ $binary.chars -> $i {
for 1 .. $binary.chars - $i -> $j {
my $substring = $binary.substr($i, $j);
If the substring consists of only a run of 0's followed by a run of 1's or vice-versa,
and the teo runs are of equal length, we have a match so we add it to @results.
if ($substring.match(/^ (0+) (1+) $/) || $substring.match(/^ (1+) (0+) $/))
&& $/[0].Str.chars == $/[1].Str.chars {
@results.push($substring);
}
}
}
When we have all the matches, we print them out in the style of the spec.
say q{(}, @results.map({ "\"$_\"" }).join(q{, }) , q{)};
The Perl version is almost an exact translation.
my @results;
for my $i (0 .. (length $binary) - 1) {
for my $j (1 .. (length $binary) - $i) {
my $substring = substr $binary, $i, $j;
if (($substring =~ /^(0+)(1+)$/ || $substring =~ /^(1+)(0+)$/) &&
length $1 == length $2) {
push @results, $substring;
}
}
}
say q{(}, (join q{, }, map{ "\"$_\"" } @results) , q{)};