Merge pull request #10899 from pjcs00/wk288

Week 288 - Nearness and contiguity

3 files changed, 138 insertions, 0 deletions

diff --git a/challenge-288/peter-campbell-smith/blog.txt b/challenge-288/peter-campbell-smith/blog.txt
new file mode 100644
index 0000000000..baffd36814
--- /dev/null
+++ b/challenge-288/peter-campbell-smith/blog.txt
@@ -0,0 +1 @@
+http://ccgi.campbellsmiths.force9.co.uk/challenge/288
diff --git a/challenge-288/peter-campbell-smith/perl/ch-1.pl b/challenge-288/peter-campbell-smith/perl/ch-1.pl
new file mode 100755
index 0000000000..4bb47c837c
--- /dev/null
+++ b/challenge-288/peter-campbell-smith/perl/ch-1.pl
@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+
+# Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge
+
+use v5.26;    # The Weekly Challenge - 2024-09-23
+use utf8;     # Week 288 - task 1 - Closest palindrome
+use warnings; # Peter Campbell Smith
+binmode STDOUT, ':utf8';
+
+closest_palindrome(5);
+closest_palindrome(123);
+closest_palindrome(1001);
+closest_palindrome(1400);
+closest_palindrome(987654321);
+closest_palindrome(int(rand(10000000000)));
+
+sub closest_palindrome {
+	
+	my ($less, $more, $j, $test);
+	
+	# start counting at $str ± 1
+	$less = $_[0] - 1;
+	$more = $less + 2;
+	
+	# loop outwards from $str
+	for $j (1 .. $less) {
+		$test = reverse($less);
+		last if $test eq $less --;
+		$test = reverse($more);
+		last if $test eq $more ++;
+	}
+	
+	say qq[\nInput:  \$str = '$_[0]'];
+	say qq[Output:        '$test'];
+}
diff --git a/challenge-288/peter-campbell-smith/perl/ch-2.pl b/challenge-288/peter-campbell-smith/perl/ch-2.pl
new file mode 100755
index 0000000000..9d17cdbb3f
--- /dev/null
+++ b/challenge-288/peter-campbell-smith/perl/ch-2.pl
@@ -0,0 +1,102 @@
+#!/usr/bin/perl
+
+# Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge
+
+use v5.26;    # The Weekly Challenge - 2024-09-23
+use utf8;     # Week 288 - task 2 - Contiguous block
+use warnings; # Peter Campbell Smith
+binmode STDOUT, ':utf8';
+
+my ($matrix, $last_x, $last_y, @count, $number, $symbol);
+
+contiguous_block(
+[['x', 'x', 'x', 'x', 'o'],
+ ['x', 'o', 'o', 'o', 'o'],
+ ['x', 'o', 'o', 'o', 'o'],
+ ['x', 'x', 'x', 'o', 'o']]);
+ 
+contiguous_block(
+[['x', 'x', 'x', 'x', 'x', 'x'],
+ ['x', 'o', 'o', 'o', 'o', 'o'],
+ ['x', 'x', 'x', 'x', 'x', 'x'],
+ ['o', 'o', 'o', 'o', 'o', 'x'],
+ ['o', 'x', 'x', 'x', 'o', 'x'],
+ ['x', 'o', 'o', 'o', 'o', 'x'],
+ ['x', 'x', 'x', 'x', 'x', 'x']]); 
+
+sub contiguous_block {
+	
+	my ($x, $y, $most, $block, $j);
+	
+	$matrix = shift;
+	print_matrix(qq[Input: ], $matrix);
+	$last_x = @$matrix - 1;
+	$last_y = @{$matrix->[0]} - 1;
+	$number = 0;
+	@count = ();
+	
+	# loop over cells
+	for $x (0 .. $last_x) {
+		for $y (0 .. $last_y) {
+
+			# if cell contains a number, skip it
+			next if $matrix->[$x]->[$y] =~ m|^\d+$|;
+			$symbol = $matrix->[$x]->[$y];
+			
+			# else number it
+			$matrix->[$x]->[$y] = ++ $number;
+			$count[$number] ++;
+			
+			# and number all its unnumbered neighbours recursively
+			number_neighbours($x, $y);
+		}
+	}
+	
+	# find largest
+	$most = 0;
+	for $j (1 .. @count - 1) {
+		if ($count[$j] > $most) {
+			$most = $count[$j];
+			$block = $j;
+		}
+	}
+	say qq[\nOutput: largest block size is $most (block $block)];	
+	print_matrix(qq[Blocks:], $matrix);
+	say qq[-----];
+}
+
+sub number_neighbours {
+	
+	my ($x, $y, $xx, $yy, $neighbour);
+	
+	($x, $y) = @_;
+	
+	# cells above, below, left and right of $x, $y
+	for $neighbour (1 .. 4) {
+		if    ($neighbour == 1) {$xx = $x - 1; $yy = $y    }
+		elsif ($neighbour == 2) {$xx = $x;     $yy = $y + 1}
+		elsif ($neighbour == 3) {$xx = $x;     $yy = $y - 1}
+		elsif ($neighbour == 4) {$xx = $x + 1; $yy = $y    }
+		next if ($xx < 0 or $xx > $last_x or $yy < 0 or $yy > $last_y);
+		
+		# number them the same if they are not already numbered
+		if ($matrix->[$xx]->[$yy] eq $symbol) {
+			$matrix->[$xx]->[$yy] = $number;
+			$count[$number] ++;
+			number_neighbours($xx, $yy);
+		}
+	}
+}
+
+sub print_matrix {
+	
+	my ($legend, $matrix, $j);
+
+	# format matrix
+	($legend, $matrix) = @_;
+	say '';
+	for $j (0 .. @$matrix - 1) {
+		say qq{$legend [} . join(', ', @{$matrix->[$j]}) . qq(]);
+		$legend = ' ' x length($legend);
+	}
+}