Amicable Split with Perl 6

by Arne Sommer

Amicable Split with Perl 6

Published 9. August 2019

This is my response to the Perl Weekly Challenge #20.

I'm in Riga this week, attending PerlCon 2019. The banner image is from Kemeri Bog, which I visited on Monday.

Challenge #20.1

«Write a script to accept a string from command line and split it on change of character. For example, if the string is “ABBCDEEF”, then it should split like “A”, “BB”, “C”, “D”, “EE”, “F”.

Loop

First a straight forward approach with a loop. Or actually, two nested loops. (You may not agree on the straight forward description, though...)

File: split-change-loop
sub MAIN (Str $string, :$quote = '"') # [1]
{
  split-change($string).map({ $quote ~ $_ ~ $quote }).join(", ").say;
} # [2] ############### # [2a] ###################### # [2c] ### # [2d]

sub split-change ($string)            # [3]
{
  my @out;                            # [4]
  my @in = $string.comb;              # [5]
  my $out;                            # [7]

  while @in                           # [6]
  {
    $out = @in.shift;                 # [7]

    while @in                         # [8]
    {
      if @in[0] eq $out.substr(0,1)   # [9]
      {
        $out ~= @in.shift;            # [9]
      }
      else
      {
        @out.push($out); $out = "";   # [10]
        last;                         # [10]
      }
    }  
  }

  @out.push($out) if $out;            # [11]

  return @out;                        # [12]
}

[1] I have chosen to write a MAIN wrapper around the actual «split-change» function. It uses normal double quotes by default, but this can be overridden with the «--quote» command line option. (The challenge uses different opening and closing quotes, but I have chosen to disregard that.)

[2] «split-change» returns a list of strings,

[2b] • so we use «map» to add the quotes around the strings,

[2c] • and use «join» to join them together as a single string, comma separated,

[2d] • and finally we print the line

[3] The procedure doing the actual job.

[4] We collect the partial strings here.

[5] I have chosen to treat the input as an array of single characters.

[6] As long as there are more characters left,

[7] • get the next one. We build up the nes string in «$out»

[8] As long as there are more characters left,

[9] If the next character is the same as the last one (in «$out»), add it

[10] If not, push the string and get rid of the old value. The «last» statement exits the inner loop (in [8[), and the outer loop kicks in (in [6)) and reads the next character (in [7]).

[11] Save the last string, if non-empty. It is empty if we passed the program an empty string (typically "").

[12] Return the lot.

Running it:

$ perl6 split-change-loop ""

$ perl6 split-change-loop 1234567
"1", "2", "3", "4", "5", "6", "7"

$ perl6 split-change-loop 123334567777
"1", "2", "333", "4", "5", "6", "7777"

gather/take

Then a version using gather/take and substrings (instead of an array):

File: split-change-gather
sub MAIN (Str $string, :$quote = '"')
{
  split-change($string).map({ $quote ~ $_ ~ $quote }).join(", ").say;
}

sub split-change ($in)
{
  gather                                            # [1]
  {
    my $out = $in.substr(0,1);                      # [2]
    for 1 .. $in.chars -> $index                    # [3]
    {
      if $out.substr(0,1) eq $in.substr($index,1)   # [4]
      {
        $out ~= $in.substr($index,1);               # [5]
      }
      else
      {
        take $out;                                  # [6]
        $out = $in.substr($index,1);                # [7]
      }
    }
  }
}

[1] We wrap the code in «gather» to collet the values given with «take» (in [5]).

[2] The «$out» variable starts with the first character in the input string.

[3] Then we loop through the rest of the characters (in the input string), one at a time. Or rather we loop through the index (or position) of the character.

[4] If the current character (in the loop) is the same as the previuos one,

[5] • add it to the «$out» variable.

[6] If not, save the string (with «take»), and

[6] • set «$out» to the new character.

Note that we do not need to handle the end of the string as a special case, as in the loop version.

See my Perl 6 gather, I take article for more information about gather/take. They are usually used in a lazy context, but that isn't an issue here as we need all the values at once (for the output).

Running it gives the same result as before:

$ perl6 split-change-gather ""

$ perl6 split-change-gather 1234567
"1", "2", "3", "4", "5", "6", "7"

$ perl6 split-change-gather 123334567777
"1", "2", "333", "4", "5", "6", "7777"

Grammar

And finally a very compact version using a grammar:

File: split-change-grammar
grammar SPLIT                # [1]
{
  regex TOP  { <Char>+ }     # [2]
  regex Char { (.) $0* }     # [3]
}

sub MAIN (Str $string, :$quote = '"')
{
  my $result = SPLIT.parse($string); # [4]

  $result<Char>.map({ $quote ~ $_.Str ~ $quote }).join(", ").say;
  # [5] ####### # [5b] ##########################    
}

[1] We start with the grammar.

[4] We use the «parse» method on the grammar and pass the string as argument to get the show going.

[5] The must look up the result in match object by name. The «Char» rule matches several times, so is a list.

[5b] • then we apply «map» on the individual elements to add the quotes. Note the explicit «.Str» on the individual value, as it is a match object. Printing a match object adds the funny quotes as «「aaaa」», so don't do that.

Running it gives almost the same result as before:

$ perl6 split-change-grammar ""
Use of uninitialized value of type Any in string context.
Methods .^name, .perl, .gist, or .say can be used to stringify it to something
meaningful.
  in block at ./split-change-grammar line 13

$ perl6 split-change-grammar 1234567
"1", "2", "3", "4", "5", "6", "7"

$ perl6 split-change-grammar 123334567777
"1", "2", "333", "4", "5", "6", "7777"

The grammar doesn't support empty strings. The easiest way to fix this is by cheating, checking if we have any matches:

File: split-change-grammar2 (changes only)
  $result
    ?? $result<Char>.map({ $quote ~ $_.Str ~ $quote }).join(", ").say
    !! print "\n";

Now it works:

$ perl6 split-change-grammar2 ""

File Sizes

FileFile size    Saving
split-change-loop485 bytes
split-change-gather444 bytes10%
split-change-grammar 238 bytes50%
split-change-grammar2   271 bytes40%

Note that the Crash Bang line (#! /usr/bin/env perl6) is present in all the files, even if not shown in the listings, and is included in the numbers. The percentages are heavily rounded.

Here you have the whole program:

File: split-change-grammar2
grammar SPLIT
{
  regex TOP  { <Char>+ }
  regex Char { (.) $0* }
}

sub MAIN (Str $string, :$quote = '"')
{
  my $result = SPLIT.parse($string);

  $result
    ?? $result<Char>.map({ $quote ~ $_.Str ~ $quote }).join(", ").say
    !! print "\n";
}

If you want a grammar version of the familiar «split-change» procedure, here it is (with the empty string fix):

split-change-grammar3
sub MAIN (Str $string, :$quote = '"')
{
  split-change($string).map({ $quote ~ $_ ~ $quote }).join(", ").say;
}

grammar SPLIT
{
  regex TOP  { <Char>+ }
  regex Char { (.) $0* }
}

sub split-change ($in)
{
  my $result = SPLIT.parse($in) // return "";
  return $result<Char>.map({ $_.Str });
}

Challenge #18.2

«Write a script to print the smallest pair of Amicable Numbers. For more information, please checkout wikipedia page

The challenge uses the word «print» and not «compute», so this is probably an acceptable solution:

File: smallest-amicable-number-cheating
say "(220, 284)";

This smallest pair is taken from the wikipedia article.

It does feel like cheating, so I'll do it the hard way as well...

The first thing to notice is that the wiki page talkes about «proper divisors», which was part of Challenge 8.1 as well.

We can start by reusing this program from my solution, shown here without the original explanation:

File: perfect-divisors
sub MAIN ($number)
{
  say "Divisors (excluding the number itself): " ~ proper-divisors($number);
}

multi proper-divisors (2) { return (1); } 

multi proper-divisors (Int $number where $number > 2) 
{
  return (1) if $number.is-prime; 

  my @divisors = (1);
  for 2 .. ($number -1) -> $candidate 
  {
    @divisors.push: $candidate if $number %% $candidate;
  }
  return @divisors;
}

The only takeaway here is that the lowest legal input value is 2. We'll have to take care of that.

File: smallest-amicable-number
multi proper-divisors (2) { return (1); } 

multi proper-divisors (Int $number where $number > 2) 
{
  return (1) if $number.is-prime; 

  my @divisors = (1);
  for 2 .. ($number -1) -> $candidate 
  {
    @divisors.push: $candidate if $number %% $candidate;
  }
  return @divisors;
}

my @sum;                                     # [1]

for 2 .. Inf -> $current                     # [2]
{
  my $sum = proper-divisors($current).sum;   # [3]
  @sum[$current] = $sum;                     # [3]

  next if $sum == 1 || $sum >= $current;     # [4]

  my $new-sum = @sum[$sum] // next;          # [5]

  next if $new-sum == 1 || $new-sum >= $current || $sum == $new-sum;  # [6]

  if $sum == @sum[$new-sum]                  # [7]
  {
    say "(@sum[$sum], $sum)";                # [8]
    last;                                    # [9]
  }
}

[1] We keep the sum of the common divisors in this array,

[2] and add new ones incrementally until infinty.

[3] The sum for the current value, stored in the array an as a helper variable to make the lookup easier.

[4] If the sum is 1, we have a value that doesn't round trip (it is actually a prime). So we are finished with this value. We are also finished if the sum is larger than the current value, as we haven't reached that far. (We'll get back to it when we compute that number.)

[5] «$new-sum» is the sum of the common divisor for the sum of the common divisor for the current value. (If this is too confusing; see the illustration below the notes.)

[6] The same checks as in [4], but the last one is new. That one checks for a value that leads back to itself, as 6 does.

[7] If it roundtrips (we get back to the same value),

[8] • we have found an amicable number pair, print it (with the lowest value first, to mimic the wikipedia article),

[9] • and we end the program. The first one found is also the lowest.

Value   DivisorsSum
xx1, x2, x3, ...     y
yy1, y2, y3, ...z
zz1, z2, z3, ...x'
  • x is $current
  • y is $sum (or @sum[$current])
  • z is $new-sum (or @sum[@sum[$current]])
  • x' is @sum[$new-sum] (or @sum[@sum[@sum[$current]]])

If x == x', the values round trip, and we have found a match.

Running it:

$ perl6 smallest-amicable-number
(220, 284)

And that's it.