laurent_r

These are some answers to the Week 147 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on January 16, 2022 at 24:00). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Truncatable Prime

Write a script to generate first 20 left-truncatable prime numbers in base 10.

In number theory, a left-truncatable prime is a prime number which, in a given base, contains no 0, and if the leading left digit is successively removed, then all resulting numbers are primes.

Example:

9137 is one such left-truncatable prime since 9137, 137, 37 and 7 are all prime numbers.

Truncatable Prime in Raku

We first build an infinite lazy list (@el-primes) of primes with no 0 digit. For each integer in the list, we then try to truncate the left-most digit and check whether the truncated number is prime, and so one until we get to the last digit. The process stops when 20 such primes have been generated.

my @truncatables;
my $count = 0;
my @el-primes = grep {.is-prime and not /0/}, 2..Inf;
for @el-primes -> $candidate {
    my $length = $candidate.chars;
    my $is-truncatable = True; 
    for 1..$length -> $i {
        my $truncated = substr $candidate, $length - $i;
        $is-truncatable = False, last unless $truncated.is-prime;
    }
    if $is-truncatable {
        push @truncatables, $candidate;
        $count++;
    }
    last if $count >= 20;
}
say @truncatables;

This program displays the following output:

raku ./truncatable.raku
[2 3 5 7 13 17 23 37 43 47 53 67 73 83 97 113 137 167 173 197]

Truncatable Prime in Perl

This Perl program is based on essentially the same idea as the Raku implementation, except that we build a hash of primes along the way. We need to check primality only when we meet a new number the first time: for the truncated numbers, we simply check their primality by looking up into the hash.

use strict;
use warnings;
use feature "say";
use constant MAX => 20;

my @primes = (2, 3, 5);
my %primes_h = map {$_ => 1} @primes;
my @truncatables = @primes;;
my $candidate = $primes[-1];
my $count = scalar @truncatables;;
while ($count < MAX) {
    $candidate += 2;
    my $not_prime = 0;
    next if $candidate =~ /0/;
    my $sq_cand = sqrt $candidate;
    for my $i (@primes) {
        $not_prime = 1, last unless $candidate % $i;
        last if $i > $sq_cand;
    }
    next if $not_prime;
    push @primes, $candidate;
    $primes_h{$candidate} = 1;
    # now check if truncatable prime
    my $length = length $candidate;
    my $is_truncatable = 1; 
    for my $i (1..$length) {
        my $truncated = substr $candidate, $length - $i;
        $is_truncatable = 0, last unless exists $primes_h{$truncated};
    }
    if ($is_truncatable) {
        push @truncatables, $candidate;
        $count++;
    }
}
say "@truncatables";

This program displays the following output:

$ perl  ./truncatable.pl
2 3 5 7 13 17 23 37 43 47 53 67 73 83 97 113 137 167 173 197

Truncatable Prime in Ring

I continue here my exploration of Ring, a quite recent programming language. The program below is a port to Ring of the Perl program above.

max = 20
primes = [2, 3, 5]
primes_h = []
count = len(primes)
for i = 1 to count
    primes_h[string(primes[i])] = i
next
truncatables = primes
candidate = primes[count]
while count < max
    candidate += 2
    not_prime = false
    pos = substr(string(candidate), "0")
    if pos > 0 loop ok
    sq_cand = floor(sqrt(candidate))
    for i in primes
        if candidate % i = 0
            not_prime = true
            exit
        ok
        if i > sq_cand exit ok
    next
    if not_prime loop ok
    add (primes, candidate)
    primes_h[string(candidate)] = 1
    // We've found a prime, now check if truncatable prime
    length = len(string(candidate))
    is_truncatable = true
    for i = 1 to length
        truncated = right(string(candidate), i)
        if isnull(primes_h[truncated])
            is_truncatable = false
            exit
        ok
    next
    if is_truncatable
        add(truncatables, candidate);
        count += 1
    ok

end
for val in truncatables see "" + val + " " next
see " " + nl

Output:

$ ring ./truncatable.ring
2 3 5 7 13 17 23 37 43 47 53 67 73 83 97 113 137 167 173 197

Task 2: Pentagon Numbers

Write a script to find the first pair of Pentagon Numbers whose sum and difference are also a Pentagon Number.

Pentagon numbers can be defined as P(n) = n(3n - 1)/2.

Example:

The first 10 Pentagon Numbers are: 1, 5, 12, 22, 35, 51, 70, 92, 117 and 145.

P(4) + P(7) = 22 + 70 = 92 = P(8)
but
P(4) - P(7) = |22 - 70| = 48 is not a Pentagon Number.

Pentagon Numbers in Raku

We’ve decided to use the built-in combinations method to generate the pairs of pentagon numbers. Note that we cannot use an infinite list of pentagon numbers because the combinations routine cannot operate on an infinite list. So I just tried various increasing values for the $max variable until I obtained a result satisfying the criteria. Note that I use a %penta hash to store the pentagon values, so the verifying whether and sum and the difference values are pentagon number is just a matter of a fast hash lookup.

my $max = 4000;
my @pentanums = map { (3 * $_² - $_)/2 }, 1..$max;
my %penta = map {@pentanums[$_] => $_+1}, 0..$max-1;
for @pentanums.combinations(2) -> $comb {
    next unless %penta{$comb.sum}:exists;
    next unless %penta{$comb[1]-$comb[0]}:exists;
    say $comb, " = Pentagon numbers N° %penta{$comb[0]} and %penta{$comb[1]}";
    say "Sum is ", $comb.sum, " (Pentagon number ", %penta{$comb.sum}, ")";
    say "Difference is ", $comb[1]-$comb[0], " (Pentagon number ", %penta{$comb[1]-$comb[0]}, ")";
    last;
}
say now - INIT now, " seconds";

This script displays the following output:

raku ./pentanums.raku
(1560090 7042750) = Pentagon numbers N° 1020 and 2167
Sum is 8602840 (Pentagon number 2395)
Difference is 5482660 (Pentagon number 1912)
101.7166579 seconds

This program is relatively slow (101 seconds execution time). I found that using two nested loops (as in the Perl program below) rather than the combinations routine make the program at least 20 times faster (only a few seconds). So it seems that the combinations routine is quite slow. This is a bit unfortunate as combinations is really useful and makes the code simpler and cleaner. I still prefer to present this version, but if you need better performance, then use two nested loops as in the Perl implementation below.

Pentagon Numbers in Perl

This is essentially the same idea as the Raku program above. However, as mentioned above, we don’t have combinations routine in Perl, so we use two nested loops to generate all the combinations. The advantage is that this runs much faster.

use strict;
use warnings;
use feature "say";
use constant MAX => 4000;

my @pentanums = map { $_ * (3 * $_ - 1)/2 } 1..MAX;
my %penta_h = map {$pentanums[$_] => $_+1 } 0..MAX-1;
# say Dumper \%penta_h;

OUTER: for my $i (0..MAX-1) {
    for my $j ($i+1..MAX-1) {
        my $sum = $pentanums[$i] + $pentanums[$j];
        next unless exists $penta_h{$sum};
        my $diff = $pentanums[$j] - $pentanums[$i];
        next unless exists $penta_h{$diff};
        say "First pair of pentagon numbers is $pentanums[$i] (rank ", $i+1, ") and $pentanums[$j] (rank ", $j+1, ")";
        say "Sum is $sum (rank $penta_h{$sum}) and difference is $diff (rank $penta_h{$diff})";
        last OUTER;
    }
}

This program displays the following output:

$ time perl  ./pentanums.pl
First pair of pentagon numbers is 1560090 (rank 1020) and 7042750 (rank 2167)
Sum is 8602840 (rank 2395) and difference is 5482660 (rank 1912)

real    0m2,043s
user    0m1,703s
sys     0m0,108s

Pentagon Numbers in Ring

Again a port to Ring of the Perl implementation:

max = 3000
pentanums = []
for i = 1 to max 
    add (pentanums,  i * (3 * i - 1) / 2)
next
// see pentanums + nl
penta_h = []
for i = 1 to max
    penta_h[ string(pentanums[i])] = i
next
for i = 1 to max
    for j = i+1 to max
        diff = pentanums[j] - pentanums[i]
        diff_s = string(diff)
        if isnull(penta_h[diff_s]) loop ok
        sum = pentanums[i] + pentanums[j]
        sum_s = string(sum)
        if isnull(penta_h[sum_s]) loop ok
        see "" + diff + " " + sum + " " + pentanums[i] + " " + pentanums[j] + nl
    next
next

Output:

$ ring ./pentanums.ring
5482660 8602840 1560090 7042750

Pentagon Numbers in Julia

max = 4000
pentanums = map((x) -> Int(x * (3 * x -1)/2), 1:max)
penta_h = Dict(map((x) -> Int(x * (3 * x -1)/2) => x, 1:max))
for i in 1:4000-1
    for j in (i + 1):4000-1
        sum = pentanums[i] + pentanums[j]
        if (haskey(penta_h, Int(sum)) == 0)
            continue
        end
        diff = pentanums[i] - pentanums[j]
        # if (haskey(penta_h, Int(diff)) == 0)
        #    continue
        # end
        println(i, " ", j, " ", pentanums[i], " ", pentanums[j], " ", sum)
    end
end

Output:

$ julia pentanums.jl
Indices 1020 and 2167 ; Pentanums: 1560090 7042750; Sum: 8602840; Diff: 5482660
1020 2167

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on January 23, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.