Solving two problems

A Regular Question

This weeks perl weekly challenge had a pretty straightforward question: take a string and split it when the characters change. That's a fairly straightforward regex issue:

perl -pE's/(.) \g1*/$& /gx'

Here we match any character (.) once. We capture this in a group. Then, we use backreferencing to match as many more copies of that group as we can. We use the s operator to then replace what we found with itself ($& is the entire match that was found) followed by a space.

Conveniently, the challenge didn't specify what 'splitting' entails, so this is technically all we need to do. However, it gives us an extra empty space at the end of the match. In order to get rid of that (the proverbial second problem introduced by regexes), we have two approaches.

The RegEx Rabbit Hole

We could tell the regex not to match if it gets to the end of the string. We would do that with a zero width negative lookahead:

(?! $)

Meaning don't match the end of the line. However, this also introduces ANOTHER problem, that now when our regex wants to match something at the end, it will backtrack if it finds more than one of a letter. Meaning if we run our one-liner on 'cc', it will split those two, because it matches the c, then tries to match as many 'c's as possible, then hits the end of the string, and backtracks to only match one c.

So to solve that, we can tell the regex engine to be possesive, that when it matches something, it won't give it back. A possesive modifier is a + after the quantifier that you have set. So now, our solution will look like this.

perl -pE's/(.) \g1*+ (?! $)/$& /gx'

Splitting Up the Issue

Alternatively, we could just use split to get rid of the extra space for us. If you don't set a limit on how many fields you want split, then split gets rid of empty trailing fields. So we'll split on the spaces that we put in, and it'll look like this now:

perl -pE'split / /, s/(.) \g1*/$& /gx'

This one has the benefit of returning a list, so it can be transplanted into some other code where you'll do more stuff with the list of consecutive letters that you've made.

Making Friends

The next challenge was to write a script to find the two smallest amicable numbers. These are pairs of numbers whose factors add up to the other number.

SInce this is a regex based post, I'll just show the regex based answer to this challenge.

In order to determine the amicability of two numbers, you need to get the sum of their proper factors. That means every number they're divisible by, except for itself. As it turns out, this is also a pretty easy regex problem. This is a variation of the famous regex for prime numbers:

sub sum_of_proper_divisors {
  #start with one, because that is always a divisor
  my $sum = 1;
  (1 x shift) =~ /^ (..+) \g1+ $ (?{ $sum += length $1 }) ./xg;
  return $sum

We first turn the number handed to the function into a string of '1's as long as the number (using the repetition operator 'x'). Then we match a regex against it, looking for a group of at least two characters in a row. We then ask the regex engine to match copies of that group until the end of the string, using a backreference, like we did in the first challenge. Then, after we match the end of the string, we use a regex code block to increment our running $sum by the length of the match. Then we tell the regex to match another character after the end of the string, which it obviously can't, so it backtracks and tries another length for the grouping in our match. It'll continue doing this, breaking down our string of 1's into equal groups, until it can no longer do so. This leaves us with the sum of the factors of our number.

sub has_amicable {
  my $start = shift;
  my $pair = sum_of_proper_divisors($start);
  #sometimes the sum of the divisors IS the number. But that's not amicable
  return 0 if $pair == $start;
  return $start == sum_of_proper_divisors $pair;

Then we make a function to check if a number has an amicable pair. It finds our potential pair by getting the sum of the divisors of the number passed in. Then it'll return falsy if the "pair" is the same number that we started with, and otherwise return whether or not the $pair's divisors sum back to our starting number.

Then we loop while incrementing our starting number, until we find a pair:

my $num;
while (1) {
  last if has_amicable(++$num);

say "$num, ${\sum_of_proper_divisors($num)} is your pair"

And finally print our 220, 284 is your pair.

Up, up and Away!

This week's perl weekly challenge was a lot of fun. First of all, challenge number 2 was a breeze. The challenge was to parse and print the components of a URL. That was easy...

use Mojo::URL;

my $url = Mojo::URL->new(shift);
say <<"ANSWER"
scheme:   ${\$url->scheme}
userinfo: ${\$url->userinfo}
host:     ${\$url->host}
port:     ${\$url->port}
path:     ${\$url->path} 
query:    ${\$url->query}
fragment: ${\$url->fragment}

To be fair, you're supposed to come up with an answer yourself, but come on, Mojolicious is fun! To print, I use an interpolating here-doc, and use a cool dereferencing trick to be able to print method calls in an interpolation.

The real interesting part was challenge number 1. I never went to school for programming, so I wasn't familiar with the concept of an Ackermann function. Looking at the problem, I immediately saw that I could easily translate the description:

A(m, n) = n + 1                  if m = 0
A(m, n) = A(m - 1, 1)            if m > 0 and n = 0
A(m, n) = A(m - 1, A(m, n - 1))  if m > 0 and n > 0

into fully functional perl6 code, making it my first perl6 script!

multi sub A( $m where 0, $n ) { $n + 1 }
multi sub A( $m, $n where 0 ) { A($m - 1, 1) }
multi sub A( $m, $n )         { A($m - 1, A($m, $n - 1)) }

sub MAIN ( Int $m, Int $n ) { say A($m, $n) }

All we needed to do was translate the constraints to the right place, and put multi sub before each function definition and BAM, we're off.


I quickly (rather slowly, actually) discovered that the ackermann function grows ridiculously fast. It only took 0.198 seconds to run the A(1,2), but trying to run something bigger, like A(4,1), took upwards of an hour and a half, I stopped waiting for it...

Which is way too long.

Fine, so let's try and solve that. The problem here is that we're making a ridiculous amount of recursive calls. Many of those calls are calculated numerous times, for example, in the expansion of A(4,1), it calls many values from the A(3) series repeatedly, which in turn call more repeated values from the A(2) series, etcetera.

This is because every time there's an expansion where $m (our first variable) is greater than 1, it expands to every value up until $n in the $m-1 series. And then does it again with the total from the calculation until it goes down an $m. And then does it again for the $m-2 series.

So the simple solution to this problem is memoization, which means storing the values that get returned in a hash, to be recovered later if the same arguments are passed to the function. That looks very simply like this.

sub A ($m, $n) { state %memoize; %memoize{$m}{$n} //= _A($m, $n) }

where we renamed our old function to _A, and replaced it with a new function, which declares a hash for itself, and then checks for and returns an already found value, or runs our inner _A function.

That takes the time from forever, down to about 8.5 seconds. Which isn't so bad at all. But let's see if we can make this thing EVEN FASTER!

It takes time to do multiple dispatch, so let's do away with that and implement it all in one function: sub _A ( $m, $n ) { return $n + 1 unless $m; return A( $m - 1, 1 ) unless $n; return A( $m - 1, A($m, $n - 1) ) }

That's basically the same idea, just using postconditionals. This takes our running time further down to 1.6 seconds, which is much nicer. Now, if you'd take that same script (with sigils properly adjusted) to perl5:

use v5.22;
use bigint;

sub A {
  my ($m, $n) = @_;
  state %memoize;
  $memoize{$m}{$n} //= _A($m, $n)

sub _A {
  my ($m, $n) = @_;
  return $n + 1 unless $m;
  return A( $m - 1, 1 ) unless $n;
  return A( $m - 1, A($m, $n - 1) )

say A( shift, shift );

You'd see that the perl5 version only runs in 6.5 seconds. Which is... surprising. The perl6 version is a good 5 times faster.

Now, part of that discrepancy is because the perl5 version is using bigint, which p6 uses by default. Why do we use bigint? Because the next part, calculating A(4,2), results in a number that's, ehm... 19,728 digits long.

By perusal of the wikipedia page, I see that there's a formula for calculating the numbers from the function:

the formula, with its many arrow

Apparently, the arrow is a hyperoperator (not the same as the perl6 type though). A hyperoperator repeats the operator one dimension below itself for a specified amount of times. The first ↑ (Knuth up arrow) means repeated multiplication, meaning 2 ↑ 3 is the same as 2 ^ 2 ^ 2. Every additional ↑ makes it that the previous operator is repeated. This means that 2 ↑↑↑ 3 is the same as 2 ↑↑ 2 ↑↑ 2, which is 2 ↑↑ (2 ↑ 2), which is 2 ↑↑ 4, which is 2 ^ 2 ^ 2 ^ 2, which is 65536.

So let's try to implement THAT, which hopefully will allow us to at least think we printed A(4,2) correctly. And in decent time.

sub arrow ( Int $base, Int $times, Int $arrows ) {
  return $base ** $times if $arrows == 1;
  ($base xx $times).reduce: { arrow($^base, $^accumulator, $arrows - 1) }

sub A ( $m, $n ) {
  return $n + 1     if $m == 0;
  return $n + 2     if $m == 1;
  return 2 * $n + 3 if $m == 2;
  arrow( 2, $n + 3, $m - 2 ) - 3

multi sub MAIN ( Int $m, Int $n ) {
  say A($m, $n)

First, we define our hyperoperator. It takes first the base, then the amount of times to apply the arrows, and then the number of arrows. We then make a list of $times bases, and then use the reduce function to repeat the same for every item on the list, just with one less arrow this time. It continues until there's only one arrow, which is simple exponentiation.

This function is based on the one I found in Math::Arrow, except I cleaned it up a little, by using twigils inside of the reduce block. These allow me to name the variables to be clearer. They pull values off of the list in alphabetical (unicode) order, so $^accumulator is the first argument, very aptly named, and $^base is the next base pulled off of the list.

Then we apply the formula from Wikipedia in our new A function, where we add some edge cases that the arrow function can't cover.

This version calculates A(4,1) in .2 seconds, and gasp A(4,2) in .5 seconds. Not bad at all. And it's still better than the p5 version, which clocks in at .6 seconds.

I tried A(4,3), but that needs to calculate 2^A(4,2), so I'm not sure if that'll ever happen.


I figured out what was wrong with my perl5 version, and here it is:

use v5.22;
use List::Util qw/reduce/;
use bigint;

sub arrow  {
  my ($base, $times, $arrows) = @_;
  return $base ** $times if $arrows == 1;
  reduce { arrow($b, $a, $arrows - 1) } ($base) x $times

sub A  {
  my ($m, $n) = @_;
  return $n + 1     if $m == 0;
  return $n + 2     if $m == 1;
  return 2 * $n + 3 if $m == 2;
  arrow( 2, $n + 3, $m - 2 ) - 3

say A(shift, shift)

The only real differences here are that perl5 doesn't have a built in reduce function, so I need to import it, and the explicit use of bigint. Also, p6 has a xx operator which repeats the left operand as a list, whereas in p5, you need to explicitly give the x operator a list to repeat.

The takeaways:

  1. I'm very stubborn. It was my goal this week to get A(4,2) to print.
  2. Perl6 can run even faster than perl5 sometimes
  3. Math can be fun, too. I finally got to understand what Knuth Up Arrows are!

Pizza Party for 100

Hi all, this is my first blog post! Yay!

Now that that's out of the way, I'd just like to go over my solution for this week's Perl weekly challenge.

The first challenge was to divide a pie between 100 people, in a manner where the first guest gets 1/100 (i.e. 1%) of the pie, and the second gets 2/100 (i.e. 2%) of what remained, etc etc. The question is, who got the biggest piece of pie.

If I were better at math, I would prove that the answer is the square root of the amount of guests, because that does seem to be the case. Since I'm not, I solved it procedurally, as follows.

We set up our guests. We allow for the user to pass in a value on the command line, to check values other than 100, but default to 100:

use v5.22; #that's my perl
my $guests = shift // 100;

Then, we define a function to slice a piece of the pie:

sub cut_a_slice_for { 
  state $pie = 1; 
  my $slice = (shift() / $guests ) * $pie; 
  $pie -= $slice; 
  return $slice 

Here we use state to declare a persistent local variable, keeping track of the size of the pie. It then cuts the slice for this guests piece. It's then called in sequence:

my $biggest = {};
for my $guest ( 1 .. $guests ) {
  my $piece = cut_a_slice_for($guest); 
  $biggest = { name => $guest, size => $piece } if $piece > $biggest->{size}

We use an anonymous hash to store the place and the size of the biggest piece seen so far, and then

say $biggest->{name}

print the answer at the end.

About Veesh

user-pic I do full-stack development with Mojolicious and Vue.