My solutions to week 147

3 files changed, 199 insertions, 0 deletions

diff --git a/challenge-147/peter-campbell-smith/blog.txt b/challenge-147/peter-campbell-smith/blog.txt
new file mode 100644
index 0000000000..78e76441f9
--- /dev/null
+++ b/challenge-147/peter-campbell-smith/blog.txt
@@ -0,0 +1 @@
+https://pjcs-pwc.blogspot.com/2022/01/chop-off-their-heads-and-conquer.html
diff --git a/challenge-147/peter-campbell-smith/perl/ch-1.pl b/challenge-147/peter-campbell-smith/perl/ch-1.pl
new file mode 100755
index 0000000000..0a3901fe78
--- /dev/null
+++ b/challenge-147/peter-campbell-smith/perl/ch-1.pl
@@ -0,0 +1,70 @@
+#!/usr/bin/perl
+
+# Peter Campbell Smith - 2022-01-10
+# PWC 147 task 1
+
+use v5.28;
+use warnings;
+use strict;
+
+# 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.
+
+# Note that the last digit cannot be 2, 4, 5, 6, 8, 0 as no primes end with those
+# and cannot be 9 as when all the preceding digits are removed, 9 is not prime,
+# so the last digit can only be 1, 3 or 7.
+
+# The definition above speaks of 'all resulting numbers' so I am ruling out
+# single-digit prime numbers as they have no 'resulting numbers' when the
+# leftmost digit is removed.
+
+my ($seeking, $prime_index, $from, $to, $test, $this, @not_a_prime, $string, $count,
+	$start, $factor, $multiple, $secs);
+
+# initialise
+$seeking = 20;   # how many to find
+$count = 0;      # how many found
+
+# find primes in ranges of 1000
+$secs = time;
+for ($from = 1; ; $from += 1000) {
+	$to = $from + 999;
+
+	# loop over all the possible factors, ie primes < sqrt($to)
+	for $factor (2 .. int(sqrt($to))) {
+		next if defined $not_a_prime[$factor];   # already known as not a prime
+		
+		# mark all the multiples of $factor as non-primes (sieve of Eratosthenes)
+		$start = int($from / $factor);           # multiples less than $start have already been done
+		$start = 2 if $start < 2;
+		for ($multiple = $start; $factor * $multiple <= $to; $multiple ++) {
+			$not_a_prime[$factor * $multiple] = 1;
+		}
+	}
+	
+	# now test the primes in this range for left-truncatability
+	TEST: for $test ($from .. $to) {
+		
+		# remove ineligibles - not prime, is a single digit, contains 0 or ends in 9
+		next if (defined $not_a_prime[$test] or $test =~ m|0| or $test =~ m|9$| or $test < 11);
+			
+		# test for left-truncatability and construct string showing proof
+		$this = $test;
+		$string = qq[$this];
+		
+		# remove successive left digits and test the residue for primeness
+		while ($this =~ s|\d(\d+)|$1|) {   
+			next TEST if $not_a_prime[$this];
+			$string .= qq[ > $this];			
+		}
+		
+		# an answer!
+		say $string;
+		if (++ $count >= $seeking) {
+			say '' . (time - $secs) . qq[ seconds\n];
+			exit;
+		}
+	}
+}
diff --git a/challenge-147/peter-campbell-smith/perl/ch-2.pl b/challenge-147/peter-campbell-smith/perl/ch-2.pl
new file mode 100755
index 0000000000..e10b24053a
--- /dev/null
+++ b/challenge-147/peter-campbell-smith/perl/ch-2.pl
@@ -0,0 +1,128 @@
+#!/usr/bin/perl
+
+# Peter Campbell Smith - 2022-01-10
+# PWC 147 task 2
+
+use v5.28;
+use warnings;
+use strict;
+
+# 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.
+
+my $seeking = 1;
+# first_method();   # see blog - it works but is slow
+second_method();    # this is better
+
+#---
+
+sub first_method {
+
+	# first method 
+	my ($found, $n, $pentagon, %p, @f, $m, $diff, %queue, $sum, $mm, $nn, $sum2, $start);
+
+	$start = time;
+	$found = 0;
+
+	for ($n = 1; ; $n ++) {
+		
+		# generate pentagon numbers sequentially
+		$pentagon = $n * (3 * $n - 1) / 2;
+		$p{$pentagon} = $n;     # so for any $j <= $n, $j is a pentagon number if $p{$j}
+		$f[$n] = $pentagon;     # and the $jth pentagon number is $f[$j]
+		next if $n == 1;
+		
+		# check the difference between this pentagon number ($n) and all smaller ones ($m)
+		for $m (1 .. $n - 1)	{
+			$diff = $pentagon - $f[$m];
+			next unless $p{$diff};   # difference is not a pentagon number
+			
+			# the difference is pentagonal; the sum will be more than $pentagon so put it in a queue to be checked later
+			$queue{sprintf('%012d', $f[$m] + $pentagon)} = [$m, $n];   # zero padded key so they sort numerically
+			
+			# test per wikipedia
+			$sum = $f[$m] + $pentagon;
+		}
+		
+		# is $pentagon in the queue of possible answers?
+		for $sum (sort keys %queue) {
+			($mm, $nn) = @{$queue{$sum}};
+			
+			# this queued number is the sum of 2 pentagons which differ by a pentagon, so ... an answer!
+			if ($sum == $pentagon) {   # the queued sum is the pentagon we've just found
+				$diff = $f[$nn] - $f[$mm];
+				$sum2 = $sum + 0;   # get rid of zero padding
+				say qq[First method: ];
+				say qq[Pentagon no $mm is $f[$mm]];
+				say qq[Pentagon no $nn is $f[$nn]];
+				say qq[Their sum is $sum2 which is pentagon number $n];
+				say qq[Their difference is $diff which is pentagon number $p{$diff}];
+				
+				if (++ $found == $seeking) {  # we've achieved the goal
+					say '' . (time - $start) . qq[ seconds\n];
+					return;
+				}
+				delete $queue{$sum};
+				
+			# this queued sum of 2 pentagon numbers is less than the one we just found, 
+			# so it isn't a pentagon number, so take it out of the queue
+			} elsif ($sum < $pentagon) {
+				delete $queue{$sum};
+				
+			# else it's still larger than the pentagon we just found, so leave it in the queue	
+			} else {
+				last;   # and any others are larger still so we con;t need to look at them yet
+			}
+		}
+	}
+}
+
+sub second_method {
+	
+	my ($found, $n, $i, $s, $m, $diff, $sum, %p, @f, $start);
+	
+	$found = 0;
+	$start = time;
+
+	for ($n = 1; ; $n ++) {
+		
+		# find pentagon numbers sequentially 
+		next unless ($i = is_pentagonal($n));   # so $n is the $i'th pentagon
+
+		# so $n is pentagonal
+		$f[$i] = $n;        # and the $i'th pentagon number is $f[$i]
+		$p{$n} = $i;        # if n is a pentagon, it is the $p{$n}'th one
+		next if $n == 1;
+		
+		# check the difference and sum of this pentagon number ($n) and all smaller ones ($m)
+		for $m (1 .. $i - 1)	{
+			$diff = $n - $f[$m]; 
+			$sum = $n + $f[$m];
+			
+			# difference is not a pentagon number
+			next unless $p{$diff};
+			next unless $s = is_pentagonal($sum);   # sum is not a pentagon number
+			
+			# result!
+			say qq[Second method: ];
+			say qq[Pentagon no $i is $n];
+			say qq[Pentagon no $m is $f[$m]];
+			say qq[Their sum is $sum which is pentagon number $s];			
+			say qq[Their difference is $diff which is pentagon number $p{$diff}];
+			if (++ $found == $seeking) {
+				say '' . (time - $start) . qq[ secs\n];
+				return;
+			}
+		}
+	}
+}
+
+sub is_pentagonal {
+	
+	# per Wikipedia
+	
+	my $test = (sqrt(24 * $_[0] + 1) + 1) / 6;
+	my $test1 = $test - int($test + 1e-19);
+	return (abs($test1) <= 1e-19) ? $test : 0;
+}
+