Week 154 challenges

3 files changed, 145 insertions, 44 deletions

diff --git a/challenge-154/peter-campbell-smith/blog.txt b/challenge-154/peter-campbell-smith/blog.txt
index 60101d8ee2..e852a12266 100644
--- a/challenge-154/peter-campbell-smith/blog.txt
+++ b/challenge-154/peter-campbell-smith/blog.txt
@@ -1 +1 @@
-https://pjcs-pwc.blogspot.com/2022/02/perming-perl-plus-padovan-primes.html
+https://pjcs-pwc.blogspot.com/2022/07/disarium-disaster-and-rank-permutations.html
diff --git a/challenge-154/peter-campbell-smith/perl/ch-1.pl b/challenge-154/peter-campbell-smith/perl/ch-1.pl
index 4b520e241d..29466b9f56 100755
--- a/challenge-154/peter-campbell-smith/perl/ch-1.pl
+++ b/challenge-154/peter-campbell-smith/perl/ch-1.pl
@@ -1,29 +1,40 @@
 #!/usr/bin/perl
 
-# Peter Campbell Smith - 2022-02-28
-# PWC 154 task 1
+# Peter Campbell Smith - 2022-07-19
+# PWC 174 task 1
 
 use v5.28;
 use strict;
+use warnings;
 use utf8;
-use Algorithm::Combinatorics qw(permutations);
+binmode(STDOUT, ':utf8');
+
+# Write a script to generate first 19 Disarium Numbers. A disarium number is an integer where the 
+# sum of each digit raised to the power of its position in the number, is equal to the number.
+
+# Blog: https://pjcs-pwc.blogspot.com/2022/07/disarium-disaster-and-rank-permutations.html
+
+my ($j, $k, $sum, $count, $digit, $s1, $s2);
+
+# loop over everything
+NUMBER: for $j (0 .. 0xffffffff) {   # 2**64
+	
+	# calculate the Disarian sum
+	$sum = 0;
+	for ($k = length($j); $k >= 1; $k --) {
+		$sum += substr($j, $k - 1, 1) ** $k;
+		next NUMBER if $sum > $j;   # too big already - give up
+	}
+	next unless $sum == $j;
+	
+	# produce Mohammad's output
+	$s1 = $s2 = '';
+	for $k (1 .. length($j)) {
+		$digit = substr($j, $k - 1, 1);
+		$s1 .= qq[($digit ** $k) + ];
+		$s2 .= ($digit ** $k) . ' + ';
+	}
+	say substr($s1, 0, -3) . ' => ' . substr($s2, 0, -3) . ' => ' . $j;
+	last if ++$count == 19;
+}
 
-# You are given possible permutations of the string 'PERL'.
-# Write a script to find any permutations missing from the list.
-
-# Blog: https://pjcs-pwc.blogspot.com/2022/02/perming-perl-plus-padovan-primes.html
-
-my ($given, $iter, $perm, $word);
-
-$given = 'PELR, PREL, PERL, PRLE, PLER, PLRE, EPRL, EPLR, ERPL,
-ERLP, ELPR, ELRP, RPEL, RPLE, REPL, RELP, RLPE, RLEP,
-LPER, LPRE, LEPR, LRPE, LREP';
-
-# get all permutations
-$iter = permutations(['P', 'E', 'R', 'L']);
-
-# print the one(s) that don't match $given
-while ($perm = $iter->next) {
-	$word = join('', @$perm);
-	say $word unless $given =~ m|$word|;
-}	
diff --git a/challenge-154/peter-campbell-smith/perl/ch-2.pl b/challenge-154/peter-campbell-smith/perl/ch-2.pl
index aeaada04b1..e470929056 100755
--- a/challenge-154/peter-campbell-smith/perl/ch-2.pl
+++ b/challenge-154/peter-campbell-smith/perl/ch-2.pl
@@ -1,36 +1,126 @@
 #!/usr/bin/perl
 
-# Peter Campbell Smith - 2022-02-28
-# PWC 154 task 2
+# Peter Campbell Smith - 2022-07-19
+# PWC 174 task 2
 
 use v5.28;
 use strict;
+use warnings;
 use utf8;
-use Math::Prime::Util 'is_prime';
-use Math::BigInt lib => 'GMP';
+binmode(STDOUT, ':utf8');
 
-# In number theory, the Padovan sequence is the sequence of integers P(n) defined by the initial values
-# P(0) = P(1) = P(2) = 1 and then followed by P(n) = P(n-2) + P(n-3).
-# Write a script to compute first 10 distinct Padovan Primes.
+# You are given a list of integers with no duplicates, e.g. [0, 1, 2].
+# Write two functions, permutation2rank() which will take the list and determine its rank 
+# (starting at 0) in the set of possible permutations arranged in lexicographic order, and 
+# rank2permutation() which will take the list and a rank number and produce just that permutation.
 
-# Blog: https://pjcs-pwc.blogspot.com/2022/02/perming-perl-plus-padovan-primes.html
+# Blog: https://pjcs-pwc.blogspot.com/2022/07/disarium-disaster-and-rank-permutations.html
 
-my (@p, $n, $string, $count);
+my (@tests, $test, $rank, $max, $perm);
 
-# as in challenge text
-$p[0] = $p[1] = $p[2] = '1';
+# permutation must be some ordering of 0 .. $n - 1
+@tests = ([1, 0, 2], [0, 2, 3, 1], [7, 3, 1, 0, 2, 6, 4, 5],
+	[7, 14, 4, 11, 6, 0, 10, 1, 2, 3, 12, 5, 8, 13, 9],
+	[1, 2, 4]);   # invalid
+	
+say qq[\nPerm to rank];	
+
+for $test (@tests) {
+	$rank = permutation2rank(@$test);
+	say qq[perm: ] . join(', ', @$test) . qq[ => rank $rank];
+}
+
+say qq[\nRank to perm];
+
+@tests = ([2, 2], [3, 3], [7, 37564], [14, 693492952393], [14, 0]);
 
-# make successive Padovan numbers
-for ($n = 3; $count <= 10; $n ++) {
-	$p[$n] = Math::BigInt->new($p[$n - 2]);
-	$p[$n]->badd($p[$n - 3]);
+for $test (@tests) {
+	($max, $rank) = @$test;
+	$perm = rank2permutation($max, $rank);
+	say qq[terms: $max, rank: $rank => perm: $perm]; 
+}
+	
+
+sub permutation2rank {
 	
-	# but is it prime?
-	if (is_prime($p[$n])) {
-		$string .= qq[$p[$n], ];
-		$count ++;
+	my (@p, $n, @fac, @ranks, $i, $rank, $this_rank, $k, $j, $digit, @seen);
+		
+	# input permutation and count no of elements
+	@p = @_;
+	$n = scalar @p;
+	
+	# calculate factorials up to $n - 1 and initialise @ranks
+	# see blog for definition of @ranks
+	$fac[0] = 1;
+	$ranks[0] = 0;
+	for $i (1 .. $n) {
+		$k = $p[$i - 1];
+		$fac[$i] = $fac[$i - 1] * $i;
+		$ranks[$i] = $i;
+		
+		# check valid perm with 1 occurrence of 0 .. $n - 1
+		return 'invalid permutation' if ($k < 0 or $k >= $n or $seen[$k]);
+		$seen[$k] = 1;
 	}
+	
+	# loop over the components of the permutation and calculate how each contributes to the rank
+	$rank = 0;
+	for $i (0 .. $n - 1) {
+		
+		# $ranks[$digit] is the contribution to the ranking of this digit given that 
+		# some digits have already been seen and can't be in this ranking position
+		$digit = $p[$i];
+		
+		# so this digit is in $ranks[$digit] block and the block occupies [$n - 1 - $i]! rows
+		$this_rank = $ranks[$digit];
+		$rank += $this_rank * $fac[$n - 1 - $i];
+
+		# now we mark this digit as having been seen, so can't occur in subsequent positions
+		$ranks[$digit] = -1;
+		
+		# and re-jig @ranks ready for the next digit (see blog)
+		$k = 0;
+		for $j (0 .. $n - 1) {
+			next if $ranks[$j] < 0;
+			$ranks[$j] = $k;
+			$k ++;
+		}		
+	}
+	return $rank;
 }
 
-# eliminate the repeated '2' and the final ', '
-say substr($string, 3, -2);	
+sub rank2permutation {
+	
+	my ($n, $rank, @fac, @ranks, @rranks, $k, $perm, $i, $j);
+	
+	($n, $rank) = @_;
+	$n ++;
+	
+	# calculate factorials up to $n - 1 and initialise @ranks
+	$fac[0] = 1;
+	$ranks[0] = 0;
+	for $i (1 .. $n - 1) {
+		$fac[$i] = $fac[$i - 1] * $i;
+		$ranks[$i] = $i;
+	}
+	
+	# loop over the components of the permutation and calculate how each contributes to the rank
+	$perm = '';
+	for $i (0 .. $n - 1) {
+		
+		# calc $j = no of blocks, and subtract those from $rank
+		$j = int($rank / $fac[$n - 1 - $i]);
+		$rank -= $j * $fac[$n - 1 - $i];
+		$perm .= qq[$ranks[$j], ];
+		$ranks[$j] = -1;
+		
+		# and re-jig @ranks ready for the next digit
+		$k = 0;
+		for $j (0 .. $n - 1) {
+			next if $ranks[$j] < 0;
+			$ranks[$k] = $ranks[$j];
+			$k ++;
+		}	
+	}
+	return substr($perm, 0, -2);
+}