Week 277 - Commons and pairs

3 files changed, 124 insertions, 0 deletions

diff --git a/challenge-277/peter-campbell-smith/blog.txt b/challenge-277/peter-campbell-smith/blog.txt
new file mode 100644
index 0000000000..8886d905d7
--- /dev/null
+++ b/challenge-277/peter-campbell-smith/blog.txt
@@ -0,0 +1 @@
+http://ccgi.campbellsmiths.force9.co.uk/challenge/277
diff --git a/challenge-277/peter-campbell-smith/perl/ch-1.pl b/challenge-277/peter-campbell-smith/perl/ch-1.pl
new file mode 100755
index 0000000000..29f5121f02
--- /dev/null
+++ b/challenge-277/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-07-08
+use utf8;     # Week 277 - task 1 - Count common
+use warnings; # Peter Campbell Smith
+binmode STDOUT, ':utf8';
+
+count_common([qw(the fat cat sat on the mat)], [qw(the loud dog ran on the grass)]);
+count_common([qw(You are given two arrays of strings)], [qw(Write a script to return the count)]);
+count_common([qw(all good things come to an end)], [qw(end an to come things good all)]);
+count_common([qw(one three)], [qw(ONE TWO)]);
+
+sub count_common {
+	
+	my (@arrays, $j, @singles, %count, $word, $output);
+	
+	@arrays = @_;
+	$output = 0;
+	
+	# count word frequency	
+	for $j (0 .. 1) {
+		$count{$_}[$j] ++ for @{$arrays[$j]};
+	}
+	
+	# find ones that occur once in each sentence
+	for $word (keys %count) {
+		$output ++ if ($count{$word}[0] or 0) == 1 and ($count{$word}[1] or 0) == 1;
+	}
+	
+	printf(qq[\nInput:  \@words1 = '%s'\n        \@words2 = '%s'\n], 
+		join(qq[', '], @{$arrays[0]}), join(qq[', '], @{$arrays[1]}));
+	say qq[Output: $output];
+}
diff --git a/challenge-277/peter-campbell-smith/perl/ch-2.pl b/challenge-277/peter-campbell-smith/perl/ch-2.pl
new file mode 100755
index 0000000000..02990d8212
--- /dev/null
+++ b/challenge-277/peter-campbell-smith/perl/ch-2.pl
@@ -0,0 +1,88 @@
+#!/usr/bin/perl
+
+# Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge
+
+use v5.26;    # The Weekly Challenge - 2024-07-08
+use utf8;     # Week 277 - task 2 - Strong pair
+use warnings; # Peter Campbell Smith
+binmode STDOUT, ':utf8';
+
+my @ints;
+
+strong_pair(1, 2, 3, 4, 5);
+strong_pair(5, 7, 1, 7);
+push @ints, int(rand(100)) for 0 .. 20;
+strong_pair(@ints);
+
+sub strong_pair {
+	
+	my (@ints, $i, $j, $x, $y, $output, $explain, %seen, $diff);
+	
+	# method 1 - initialise
+	@ints = @_;
+	$output = 0;
+	$explain = '';
+	
+	# loop over all possible pairs
+	for $i (0 .. @ints - 2) {
+		for $j ($i + 1 .. @ints - 1) {
+			($x, $y) = ($ints[$i], $ints[$j]);
+			
+			# check conditions and record
+			next unless 0 < abs($x - $y) and abs($x - $y) < ($x < $y ? $x : $y);
+			next if $seen{qq[$x/$y]};
+			$seen{qq[$x/$y]} = 1;
+			$seen{qq[$y/$x]} = 1;
+			$output += 1;
+			$explain .= qq[($x, $y), ];
+		}
+	}
+	say '';
+	multiline("Input: \@ints = ", join(', ', @ints), 58, ',', 3);
+	multiline("Output1: $output - ", ($explain ? substr($explain, 0, -2) : '[none]'), 58, q[\),], 3);
+#	printf(qq[\nInput:  \@ints = (%s)\n], join(', ', @ints));
+#	printf(qq[Output1: %s - %s\n], $output, $explain ? substr($explain, 0, -2) : '[none]');
+	
+	# method 2 - initialise
+	$output = 0;
+	$explain = '';
+	%seen = ();
+	
+	# sort and then loop over all pairs
+	@ints = sort { $a <=> $b } @ints;
+	I: for $i (0 .. @ints - 2) {
+		J: for $j ($i + 1 .. @ints - 1) {
+			($x, $y) = ($ints[$i], $ints[$j]);
+			$diff = $y - $x;
+			next J if $diff == 0 or $seen{qq[$x/$y]};
+			
+			# because @ints is sorted, increasing $j won't help
+			next I if abs($diff) >= $x;
+			$seen{qq[$x/$y]} = 1;
+			$output += 1;
+			$explain .= qq[($x, $y), ];
+		}
+	}
+	multiline("Output2: $output - ", $explain ? substr($explain, 0, -2) : '[none]', 58, q[\),], 3);
+#	printf(qq[Output2: %s - %s\n], $output, $explain ? substr($explain, 0, -2) : '[none]');	
+}
+
+sub multiline {
+	
+	my ($prefix, $text, $width, $separator, $margin, $this_line, $intro);
+	
+	($prefix, $text, $width, $separator, $margin) = @_;
+	
+	# split long string over lines max width $width
+	$intro = $prefix;
+	while (length($intro) + length($text) > $width) {
+		$this_line = substr($text, 0, $width - length($intro));
+		$this_line =~ m|(.*$separator)|;
+		say $intro . $1;		
+		$text =	substr($text, length($1), 99999);
+		$intro = ' ' x $margin;
+		$text =~ s|^\s*||;
+	}
+	say $intro . $text if $text !~ m|^\s*$|;
+	return;
+}
\ No newline at end of file