Merge pull request #5505 from wlmb/challenges

Solve PWC147

5 files changed, 153 insertions, 0 deletions

diff --git a/challenge-147/wlmb/blog.txt b/challenge-147/wlmb/blog.txt
new file mode 100644
index 0000000000..0b7e8f9768
--- /dev/null
+++ b/challenge-147/wlmb/blog.txt
@@ -0,0 +1 @@
+https://wlmb.github.io/2022/01/10/PWC147/
diff --git a/challenge-147/wlmb/perl/ch-1.pl b/challenge-147/wlmb/perl/ch-1.pl
new file mode 100755
index 0000000000..1fa2fbebe8
--- /dev/null
+++ b/challenge-147/wlmb/perl/ch-1.pl
@@ -0,0 +1,41 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 147
+# Task 1: Truncatable prime
+#
+# See https://wlmb.github.io/2022/01/10/PWC147/#task-1-truncatable-prime
+use v5.12;
+use warnings;
+use PDL;
+use PDL::NiceSlice;
+use POSIX qw(); # don't import to avoid name collisions with PDL
+use Text::Wrap qw(wrap $columns $break);
+
+die "Usage: ./ch-1.pl size_of_sieve number_of_truncatable_primes [base]\n"
+    unless @ARGV>=2;
+my ($size, $wanted, $base)=@ARGV;
+$base//=10; # decimal numbers by default
+$size=$base**POSIX::ceil(log($size)/log($base)); # Force power of base;
+my $sieve=ones($size); #
+$sieve(0:1).=0; # 0 and 1 are not primes
+# find primes with Eratosthenes sieve
+$sieve($_**2:-1:$_).=0 foreach(2..sqrt($size-1));
+# Remove non-truncatable primes
+for(my $n=$base; $n<$size; $n*=$base){
+    # Reshape sieve as rectangle. The first row all log_base(n) digits
+    $sieve->reshape($n,$size/$n);
+    # Remove from the remaining rows those numbers which don't
+    # correspond to a truncatable prime in the first row
+    $sieve &= $sieve(:,0);
+    # From every tenth row remove numbers that would begin in 0 if truncated
+    $sieve(:,10:-1:10).=0 if $sieve->dim(1)>10;
+}
+$sieve->reshape($size); # return to a 1D sieve
+# The desired primes correspond to the surviving ones in the sieve
+my $truncatable_primes=$sieve->xvals->where($sieve);
+my $found=$truncatable_primes->nelem; # truncatable primes actually found
+say("Didn't find enough ($wanted) primes, please increase size of sieve"),
+    $wanted=$found
+    unless $found >= $wanted;
+$columns=62; $break=qr/\s/;
+say wrap("", "    ", "The first $wanted truncatable primes are: ",
+    join ", ", $truncatable_primes(0:$wanted-1)->list);
diff --git a/challenge-147/wlmb/perl/ch-2.pl b/challenge-147/wlmb/perl/ch-2.pl
new file mode 100755
index 0000000000..88eecdda76
--- /dev/null
+++ b/challenge-147/wlmb/perl/ch-2.pl
@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 147
+# Task 2: pentagon numbers
+#
+# See https://wlmb.github.io/2022/01/10/PWC147/#task-2-pentagon-numbers
+use v5.12;
+use warnings;
+use bigint;
+use Time::HiRes qw(time);
+
+die "Usage: ./ch-2.pl largest_index\n" unless @ARGV==1;
+my $N=shift;
+my $start=time();
+J:
+    foreach my $j(2..$N){
+        my $p=$j*(3*$j-1)/2;
+        foreach my $k(1..$j-1){
+            my $q=$k*(3*$k-1)/2;
+            say("p$j=$p\np$k=$q\np$j-p$k=", $p-$q, "=p", index_of($p-$q),
+                  "\np$j+p$k=", $p+$q, "=p", index_of($p+$q)),
+                last J if pentagonal($q+$p) && pentagonal($p-$q);
+        }
+}
+say "Time: ", time()-$start;
+sub pentagonal {
+    my $p=24*shift()+1;
+    my $s=sqrt($p);
+    return $s**2==$p && $s%6==5;
+}
+sub index_of {
+    my $p=24*shift()+1;
+    my $s=sqrt($p);
+    return ($s+1)/6;
+}
diff --git a/challenge-147/wlmb/perl/ch-2a.pl b/challenge-147/wlmb/perl/ch-2a.pl
new file mode 100755
index 0000000000..038b9630d3
--- /dev/null
+++ b/challenge-147/wlmb/perl/ch-2a.pl
@@ -0,0 +1,41 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 147
+# Task 2: pentagon numbers
+#
+# See https://wlmb.github.io/2022/01/10/PWC147/#task-2-pentagon-numbers
+use v5.12;
+use warnings;
+use Time::HiRes qw(time);
+use PDL;
+use PDL::NiceSlice;
+
+die "Usage: ./ch-2a.pl largest_index\n" unless @ARGV==1;
+my $N=shift;
+my $start=time();
+my $n=zeroes(long, $N)->xvals+1;
+my $p=$n*(3*$n-1)/2;
+my $check=pentagonal($p);
+for my $i (2..$p->nelem){
+    my $pi=$p(($i-1));
+    my $pass=which(pentagonal($pi+$p) & pentagonal($pi-$p));
+    next unless $pass->nelem;
+    my $j=$pass((0))+1;
+    my $pj=$p(($j-1));
+    my $s=$pi+$pj;
+    my $d=$pi-$pj;
+    my ($k, $l)=map {index_of($_)} ($d, $s);
+    say "p$i=$pi\np$j=$pj\np$i-p$j=$d=p$k\np$i+p$j=$s=p$l";
+    last;
+}
+say "Time: ", time()-$start;
+sub pentagonal {
+    my $p=shift;
+    my $p241=24*$p+1;
+    my $sp241=$p241->sqrt;
+    return (($p>0)&($sp241**2==$p241) & ($sp241%6==5));
+}
+sub index_of {
+    my $p=24*shift()+1;
+    my $s=sqrt($p);
+    return ($s+1)/6;
+}
diff --git a/challenge-147/wlmb/perl/ch-2b.pl b/challenge-147/wlmb/perl/ch-2b.pl
new file mode 100755
index 0000000000..c029154bc9
--- /dev/null
+++ b/challenge-147/wlmb/perl/ch-2b.pl
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 147
+# Task 2: pentagon numbers
+#
+# See https://wlmb.github.io/2022/01/10/PWC147/#task-2-pentagon-numbers
+use v5.12;
+use warnings;
+use Time::HiRes qw(time);
+use PDL;
+use PDL::NiceSlice;
+
+die "Usage: ./ch-2a.pl largest_index\n" unless @ARGV==1;
+my $N=shift;
+my $start=time();
+my $n=zeroes(long, $N)->xvals+1;
+my $p=$n*(3*$n-1)/2;
+my $check=pentagonal($p);
+my $pass=whichND(pentagonal($p+$p(*1)) & pentagonal($p-$p(*1)));
+die "No solution found. Try to increase the largest_index" unless $pass->dim(1)>0;
+my $ij=$pass(:,(0))+1;
+my ($pi, $pj)=map {$p(($_-1))} (my ($i, $j)=map {$ij(($_))} (0,1));
+my ($s, $d)=($pi+$pj, $pi-$pj);
+my ($k, $l)=map {index_of($_)} ($d, $s);
+say "p$i=$pi\np$j=$pj\np$i-p$j=$d=p$k\np$i+p$j=$s=p$l";
+say "Time: ", time()-$start;
+sub pentagonal {
+    my $p=shift;
+    my $p241=24*$p+1;
+    my $sp241=$p241->sqrt;
+    return (($p>0)&($sp241**2==$p241) & ($sp241%6==5));
+}
+sub index_of {
+    my $p=24*shift()+1;
+    my $s=sqrt($p);
+    return ($s+1)/6;
+}