Perl Weekly Challenge: Week 147
Challenge 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
leftdigit is successively removed, then all resulting numbers are primes.
I'm not sure this is the best way to go about it but it worked and quite quickly too.
my @primes;
my $n = 2;
I created an array for my truncatable primes and $n is the the number to examine for left truncatability.
It starts at 2 because we know 1 is not a prime number.
while @primes.elems < 20 {
We continue looking for these truncatable primes until we have 20 of them.
if !$n.match( /0/ ) && $n.is-prime() {
We can avoid a lot of work by only looking at numbers which are prime and don't have a 0 in them.
my $candidate = $n;
while $candidate.is-prime() {
$candidate = $candidate.substr(1,);
}
If we have such a number we can check if it is a truncatable prime by successively removing the leftmost digit. If we don't have a prime, we stop the loop.
if $candidate.chars == 0 {
@primes.push($n);
}
If the length of $candidate after we left the loop is 0, it means we had primes all the way to the end. In that
case we can add $n to our list of truncatable primes.
}
$n++;
We continue on to the next number.
}
@primes.join(q{, }).say;
And finally, print the list of primes.
Once again I had to make up for Perls' lack with the isPrime() function I've used in many previous challenges.
my @primes;
my $n = 2;
while (scalar @primes < 20) {
if ($n !~ /0/ && isPrime($n)) {
my $candidate = $n;
while (length $candidate && isPrime($candidate)) {
It seems my isPrime() will happily accept an empty string so I had to add a check that $candidate had atleast one digit.
$candidate = substr $candidate, 1;
}
if (length $candidate == 0) {
push @primes, $n;
}
}
$n++;
}
say join q{, }, @primes;
The rest of the code works the same as Raku.
In case you were wondering, the first 20 truncatable primes are 2, 3, 5, 7, 13, 17, 23, 37, 43, 47, 53, 67, 73, 83, 97, 113, 137, 167, 173, and 197.
Challenge 2:
Pentagon Numbers
Write a script to find the first pair of
Pentagon Numberswhose sum and difference are also aPentagon 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.
This one seemed it should be simple but it took a little guess work to get the answer the spec required.
sub pentagon(Int $n) {
return $n * (3 * $n - 1) / 2;
}
first I wrote a function to calculate a Pentagon number.
my %p;
Originally I made p an array to keep the ordinal of each Pentagon number as well as its' value so I made it a hash
where the P(n) is the key and n is the value.
for 1_000 .. 3_000 -> $n {
%p{pentagon($n)} = $n;
}
I started off by calculating the first 10 Pentagon numbers thinking the example in the spec had given a clue but that didnt work so I went from 1 to 100 and then 1 to 1000. When I still didn't find a correct answer I started from 1000 and increased the range in increments of 1000. Finally I got an answer between 1000 and 3000.
for %p.keys.combinations(2) -> @combo {
if (%p{@combo[0] + @combo[1]}:exists) && (%p{(@combo[0] - @combo[1]).abs}:exists) {
(%p{@combo[0]}, %p{@combo[1]})
.join(q{, })
.say;
last;
}
}
How did I find that answer? I made up a list of every combination of two values in my range. If the sum and the difference of
that combination were also keys in %p I had the answer and stopped searching. If not, I tried the next combination. If no
combination fit the bill, I knew the range was wrong and tried a different one.
The Perl version works the same way so there is little else to say about it. combinations() is yet another of the Raku workalikes
I've used in past challenges.
sub pentagon {
my ($n) = @_;
return $n * (3 * $n - 1) / 2;
}
my %p;
for my $n (1_000 .. 3_000) {
$p{pentagon($n)} = $n;
}
for my $combo (combinations([keys %p], 2)) {
if (exists $p{$combo->[0] + $combo->[1]} && exists $p{abs($combo->[0] - $combo->[1])}) {
say join q{, }, ($p{$combo->[0]}, $p{$combo->[1]});
last;
}
}
P(1020) and P(2167) (1560090 and 7042750 respectively) are the first pair of Pentagon numbers that meet the criteria in the spec.