RabbitFarm
2022-01-16
Primes and Pentagonals
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate first 20 left-truncatable prime numbers in base 10.
Solution
use strict;
use warnings;
use boolean;
use constant N => 10_000;
sub sieve_atkin{
my($n) = @_;
my @primes = (2, 3, 5);
my $upper_bound = int($n * log($n) + $n * log(log($n)));
my @atkin = (false) x $upper_bound;
my @sieve = (1, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 49, 53, 59);
for my $x (1 .. sqrt($upper_bound)){
for(my $y = 1; $y <= sqrt($upper_bound); $y+=2){
my $m = (4 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (1, 13, 17, 29, 37, 41, 49, 53) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 1; $x <= sqrt($upper_bound); $x += 2){
for(my $y = 2; $y <= sqrt($upper_bound); $y += 2){
my $m = (3 * $x ** 2) + ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (7, 19, 31, 43) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
for(my $x = 2; $x <= sqrt($upper_bound); $x++){
for(my $y = $x - 1; $y >= 1; $y -= 2){
my $m = (3 * $x ** 2) - ($y ** 2);
my @remainders;
@remainders = grep {$m % 60 == $_} (11, 23, 47, 59) if $m <= $upper_bound;
$atkin[$m] = !$atkin[$m] if @remainders;
}
}
my @m;
for my $w (0 .. ($upper_bound / 60)){
for my $s (@sieve){
push @m, 60 * $w + $s;
}
}
for my $m (@m){
last if $upper_bound < ($m ** 2);
my $mm = $m ** 2;
if($atkin[$m]){
for my $m2 (@m){
my $c = $mm * $m2;
last if $c > $upper_bound;
$atkin[$c] = false;
}
}
}
map{ push @primes, $_ if $atkin[$_] } 0 .. @atkin - 1;
return @primes;
}
sub truncatable{
my($prime, $primes) = @_;
return false if $prime =~ m/0/;
my @truncatable = map { my $p = substr($prime, -1 * $_, $_); grep {$p == $_} @{$primes}} 1 .. length($prime);
return @truncatable == length($prime);
}
sub first_n_truncatable_primes{
my($n) = @_;
my @primes = sieve_atkin(N);
my @truncatable;
for my $prime (@primes){
push @truncatable, $prime if truncatable($prime, \@primes);
last if @truncatable == $n;
}
return @truncatable;
}
MAIN:{
print join(", ", first_n_truncatable_primes(20)) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
2, 3, 5, 7, 13, 17, 23, 37, 43, 47, 53, 67, 73, 83, 97, 113, 137, 167, 173, 197
Notes
First off, I am re-using the Sieve of Atkin code I wrote for a previous challenge. These challenges somewhat frequently have a prime number component so, if I get a chance, I'll compose that code into it's own module. If it weren't for the copy/paste of the Sieve of Atkin code then this solution would be very short! This sort of string manipulation is where Perl excels and the determination of whether a number is left truncatable takes only a few lines.
Part 2
Write a script to find the first pair of Pentagon Numbers whose sum and difference are also a Pentagon Number.
Solution
use strict;
use warnings;
use constant N => 10_000;
sub n_pentagon_numbers{
my($n) = @_;
my @pentagon_numbers;
my $x = 1;
my %h;
do{
my $pentagon = $x * (3 * $x - 1) / 2;
push @pentagon_numbers, $pentagon;
$h{"$pentagon"} = $x;
$x++;
}while(@pentagon_numbers < $n);
return (\@pentagon_numbers, \%h);
}
sub pairs_pentagon{
my($n) = @_;
my($pentagons, $lookup) = n_pentagon_numbers(N);
my @pairs;
for my $x (0 .. @{$pentagons} - 1){
for my $y (0 .. @{$pentagons} - 1){
unless($x == $y){
my($sum, $difference) = ($pentagons->[$x] + $pentagons->[$y], abs($pentagons->[$x] - $pentagons->[$y]));
if($lookup->{$sum} && $lookup->{$difference}){
my($s, $t) = ($x + 1, $y + 1);
push @pairs, ["P($s)", "P($t)"]
}
}
last if @pairs == $n;
}
last if @pairs == $n;
}
return @pairs;
}
sub first_pair_pentagon{
return [pairs_pentagon(1)];
}
MAIN:{
print join(", ", @{first_pair_pentagon()->[0]}) . "\n";
}
Sample Run
$ perl perl/ch-2.pl
P(1020), P(2167)
Notes
This second part of the challenge proceeds in mostly the same way as the first. We generate a large list of candidates and then search for those exhibiting the property in question. It is somewhat unexpected that the first pair of Pentagonal Numbers that have this property are so deeply located. Many times in these challenges the solution is emitted without quite as much searching!
References
posted at: 13:29 by: Adam Russell | path: /perl | permanent link to this entry
The Weekly Challenge 147 (Prolog Solutions)
The examples used here are from the weekly challenge problem statement and demonstrate the working solution.
Part 1
Write a script to generate first 20 left-truncatable prime numbers in base 10.
Solution
:-initialization(main).
left_truncatable(X):-
fd_labeling(X),
number_codes(X, C),
\+ member(48, C),
length(C, L),
findall(Truncatable, (
between(1, L, N),
length(T, N),
append(_, T, C),
number_codes(Truncatable, T),
fd_prime(Truncatable)), Truncatables),
length(Truncatables, NumberTruncatable),
L == NumberTruncatable.
first_twenty_left_truncatable(FirstTwenty):-
length(FirstTwenty, 20),
fd_domain(FirstTwenty, 1, 200),
fd_all_different(FirstTwenty),
maplist(left_truncatable, FirstTwenty),
fd_labeling(FirstTwenty).
main:-
first_twenty_left_truncatable(FirstTwenty),
write(FirstTwenty), nl,
halt.
Sample Run
$ gplc prolog/ch-1.p
$ prolog/ch-1
[2,3,5,7,13,17,23,37,43,47,53,67,73,83,97,113,137,167,173,197]
Notes
I thought quite a while on how to best approach this problem in Prolog. The code here works well. Some knowledge of the size of the left truncatable primes lets us set the upper bound of the domain pretty tightly, but at best that is a very small optimization, if we can even really claim it as such. The change which might most effect performance is to start with a pre-generated list of primes. Especially since the density of primes is much more sparse as the numbers increase the number of unnecessary checks would be greatly reduced.
Part 2
Write a script to find the first pair of Pentagon Numbers whose sum and difference are also a Pentagon Number.
Solution
n_pentagon_numbers(0, []).
n_pentagon_numbers(N, [H|T]):-
H #= N * (3 * N - 1) / 2,
Next #= N - 1,
n_pentagon_numbers(Next, T).
first_pair_pentagon(FirstPair):-
n_pentagon_numbers(10000, Pentagons),
fd_domain([X, Y, Sum, AbsoluteDifference], Pentagons),
Sum #= X + Y,
Difference #= X - Y,
((
Difference #< 0,
AbsoluteDifference #= -1 * Difference
); AbsoluteDifference #= Difference),
fd_labeling([X, Y]),
FirstPair = [X, Y].
Sample Run
$ gprolog --consult-file prolog/ch-2.p
| ?- first_pair_pentagon(FirstPair).
FirstPair = [7042750,1560090] ?
Notes
Apparently GNU Prolog does not define an absolute value function for FD vars. Perhaps because of some theoretical limitation I am unaware of? No matter, some extra code takes care of that. Frankly, the bigger issue is that in this case the use of an FD solver doesn't really help much beyond a pure Prolog one. Again, I may be unaware of what is happening under the hood, but performance wise it doesn't seem any better to constrain the domains of the variables versus an outright "generate and test".
References
posted at: 13:06 by: Adam Russell | path: /prolog | permanent link to this entry