Perl Weekly Challenge 147: Truncatable Primes and Pentagon Numbers

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.

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
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
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

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-\$comb}:exists;
say \$comb, " = Pentagon numbers N° %penta{\$comb} and %penta{\$comb}";
say "Sum is ", \$comb.sum, " (Pentagon number ", %penta{\$comb.sum}, ")";
say "Difference is ", \$comb-\$comb, " (Pentagon number ", %penta{\$comb-\$comb}, ")";
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]
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. I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.