Perl Weekly Challenge: Week 47
Challenge 1:
Roman Calculator
Write a script that accepts two roman numbers and operation. It should then perform the operation on the givenn Roman numbers and print the result.
For example,
perl ch-1.pl V + VIIt should print
XI
At first I was going to chicken out and just use my existing code from Challenge 10 to convert the roman numerals to Hindu-Arabic, do the calculation and convert them back but I did some fascinating research into how Romans actually did arithmetic. In particular this blog gave an algorithm that was easy to understand and implement. I did run into problems along the way and as a result I missed the deadline for the challenge but I had a lot of fun nevertheless.
Addition is easy. I implemented it in Perl like this:
say normalize(reorder(unprefix($num1) . unprefix($num2)));
A peculiar feature of Roman numerals is that instead of being laid out strictly by
place, some of them are prefixed. For example 8 is VIII but 9 isn't VIIII it's IX.
So the unprefix() function converts these prefixes to suffixes.
sub unprefix {
my ($num) = @_;
my @from = qw/ CM CD XC XL IX IV /;
my @to = qw/ DCCCC CCCC LXXXX XXXX VIIII IIII /;
for my $i (0 .. scalar @from - 1) {
$num =~ s/$from[$i]/$to[$i]/g;
}
return $num;
}
Then both numbers are concatenated to each other.
The digits in resulting string are then sorted by size.
sub reorder {
my ($num) = @_;
my %order = (
'M' => 0, 'D' => 1, 'C' => 2, 'L' => 3, 'X' => 4, 'V' => 5, 'I' => 6
);
return join q{}, sort { $order{$a} <=> $order{$b} } split //, $num;
}
The last step is to turn the string back into a proper Roman number with the right characters and prefixes in the right place etc.
sub normalize {
my ($num) = @_;
my @from = qw/ IIIII IIII VV VIV XXXXX XXXX LL LXL CCCCC CCCC DD DCD /;
my @to = qw/ V IV X IX L XL C XC D CD M CM /;
for my $i (0 .. scalar @from - 1) {
$num =~ s/$from[$i]/$to[$i]/g;
}
return $num;
}
...and that's it for addition. Subtraction is more complicated.
The first step as with addition, is to unprefix() the operands.
my $un1 = unprefix($num1);
my $un2 = unprefix($num2);
Then as long as the second number has digits, we have to:
- remove common substrings from the two numbers.
- For the largest digit in the second number (i.e. the first one), take the first digit in the first number that is larger, and expand it.
I expressed this with the following loop:
while (length $un2) {
($un1, $un2) = expandLargest(removeCommon($un1, $un2));
}
To remove substrings first we need to generate them all. The appropriately named
substrings() function does that.
sub substrings {
my ($num) = @_;
my %substrings;
for my $i (0 .. (length $num) - 1) {
for my $j (1 .. (length $num) - $i) {
my $ss = substr($num, $i, $j);
$substrings{$ss}++;
}
}
return sort { length $b <=> length $a } keys %substrings;
}
One error I initially made was to not sort the list of substrings by length. This led to subtle errors where a shorter sequence than possible got matched.
In the removeCommon() function we take the list of substrings of the first number
and if a substring is present in both numbers it is removed from both.
sub removeCommon {
my ($num1, $num2) = @_;
for my $ss (substrings($num1)) {
if ($num1 =~ /$ss/ && $num2 =~ /$ss/) {
$num1 =~ s/$ss//;
$num2 =~ s/$ss//;
}
}
return ($num1, $num2);
}
I made another mistake here. In my first attempt, I only checked if the substring is present in the second number as it is already part of the first number. But I failed to account for the fact that each time a substring is matched, the size of the strings changes and the substring may not be valid anymore.
Step 2, expanding the largest digit was the most difficult bit for me to wrap my head around.
sub expandLargest {
my ($num1, $num2) = @_;
my %order = (
'M' => 0, 'D' => 1, 'C' => 2, 'L' => 3, 'X' => 4, 'V' => 5, 'I' => 6
);
It would seem to be easier to define @reverseOrder as keys @order but keys
does not guarantee any particular order.
my @reverseOrder = qw/ M D C L X V I /;
my %expansion = (
'M' => 'DCCCCC', 'D' => 'CCCCC', 'C' => 'LXXXXX', 'L' => 'XXXXX',
'X' => 'VIIIII', 'V' => 'IIIII', 'I' => q{}
);
$first might be empty if the digits of the second number have been exhausted in
which case we can skip the rest of the function.
my $first = substr($num2, 0, 1);
if ($first) {
my $i = ($first eq 'M') ? 0 : $order{$first} - 1;
This is yet another place where I hit a problem. Take the sum M - I. The next largest unit after I is V but V does not exist in the first number (i.e M). What should be done in this circumstance is to keep trying the next larger unit until one that does match is found and that's what this while loop does.
while ($i >= 0 && $num1 !~ /$reverseOrder[$i]/) {
$i--;
}
$num1 =~ s/$reverseOrder[$i]/$expansion{$reverseOrder[$i]}/;
}
Because the expansion may have caused $num1s digits to get out of order, it is
run through reorder() before being returned.
return (reorder($num1), $num2);
}
Finally, after there are no more digits left in the second number, the result is
normalize()ed as with addition and printed out.
say normalize($un1);
After all this I didn't dare attempt multiplication or division!
The Raku version is similar minus the usual small syntactic differences so I'm not going
to reproduce the whole thing here. But there are a few noteworthy details. Take some code
from the unprefix() function for example.
A function or method parameter is immutable by default. So if you wanted to change it, you would have to make a copy and change that.
sub unprefix(Str $num) { my $unprefixed = $num;
In perl I did s/$from[$i]/$to[$i]/g;. Regex susbstitution works the same in Raku
(except g and other flags go after the s) but you run into problems with array elements
because the subscript is interpreted as part of the regex. The simply way to get
around this is to use a strings .subst() method instead like this:
$unprefixed = $unprefixed.subst(@from[$i], @to[$i], :g);
But you have to remember to assign it back to the string variable if you actually want the substitution to occur. Embarrassingly, I forgot this at first.
I like to nest functions so that the output of one becomes the input of another.
removeCommon() returns an array with two elements. largestOrder() wants two
separate arguments so it raises an error when given only one array. Perl would
automagically "flatten" the array in this context but Raku doesn't unless you put
th | operator before removeCommon().
($un1, $un2) = largestOrder(|removeCommon($un1, $un2));
Now it does the right thing.
Challenge 2:
Gapful Number
Write a script to print first 20 Gapful Numbers greater than or equal to 100. Please check out the page for more information about Gapful Numbers.
After all the excitement of the previous task, this one was easy. Here is the Perl solution.
my @gapfuls;
my $number = 100;
while (scalar @gapfuls != 20) {
my @digits = split //, $number;
my $divisor = join q{}, ($digits[0], $digits[-1]);
if ($number % $divisor == 0) {
push @gapfuls, $number;
}
$number++;
}
say join ', ', @gapfuls;
And this is Raku.
(gather {
for (100 .. ∞) -> $number {
my @digits = $number.comb;
if $number %% (@digits[0], @digits[*-1]).join(q{}) {
take $number;
}
}
})[0 .. 19].join(', ').say;