Challenge 277 Task 1 and 2 solutions in Perl by Matthias Muth

4 files changed, 108 insertions, 1 deletions

diff --git a/challenge-277/matthias-muth/README.md b/challenge-277/matthias-muth/README.md
index 10e53d1eb9..7c0dfe3387 100644
--- a/challenge-277/matthias-muth/README.md
+++ b/challenge-277/matthias-muth/README.md
@@ -1,4 +1,4 @@
-**Challenge 276 solutions in Perl by Matthias Muth**
+**Challenge 277 solutions in Perl by Matthias Muth**
 <br/>
 (no blog post this time...)
 
diff --git a/challenge-277/matthias-muth/blog.txt b/challenge-277/matthias-muth/blog.txt
new file mode 100644
index 0000000000..ce57767ee3
--- /dev/null
+++ b/challenge-277/matthias-muth/blog.txt
@@ -0,0 +1 @@
+https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-277/challenge-277/matthias-muth#readme
diff --git a/challenge-277/matthias-muth/perl/ch-1.pl b/challenge-277/matthias-muth/perl/ch-1.pl
new file mode 100755
index 0000000000..f2088ec078
--- /dev/null
+++ b/challenge-277/matthias-muth/perl/ch-1.pl
@@ -0,0 +1,63 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 277 Task 1: Count Common
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+sub count_common_1( $words1, $words2 ) {
+    my ( %frequencies_1, %frequencies_2 );
+    ++$frequencies_1{$_}
+        for $words1->@*;
+    ++$frequencies_2{$_}
+        for $words2->@*;
+    return scalar grep
+        $frequencies_1{$_} == 1 && ( $frequencies_2{$_} // 0 ) == 1,
+        keys %frequencies_1;
+}
+
+use Statistics::Frequency;
+
+sub count_common_2( $words1, $words2 ) {
+    my %frequencies_1 = Statistics::Frequency->new( $words1 )->frequencies;
+    my %frequencies_2 = Statistics::Frequency->new( $words2 )->frequencies;
+    return scalar grep
+        $frequencies_1{$_} == 1 && ( $frequencies_2{$_} // 0 ) == 1,
+        keys %frequencies_1;
+}
+
+use List::MoreUtils qw( singleton );
+use Set::Scalar;
+
+sub count_common_3( $words1, $words2 ) {
+    return Set::Scalar->new( singleton $words1->@* )
+        ->intersection( Set::Scalar->new( singleton $words2->@* ) )
+        ->size;
+}
+
+sub count_common_4( $words1, $words2 ) {
+    my $singletons_1 = Set::Scalar->new( singleton $words1->@* );
+    my $singletons_2 = Set::Scalar->new( singleton $words2->@* );
+    return $singletons_1->intersection( $singletons_2 )->size;
+}
+
+use Test2::V0 qw( -no_srand );
+
+my $sub_name = "count_common";
+for my $sub ( sort grep /^${sub_name}/, keys %:: ) {
+    note "Testing $sub:";
+
+    no strict 'refs';
+    is $sub->( ["Perl", "is", "my", "friend"], ["Perl", "and", "Raku", "are", "friend"] ), 2,
+        'Example 1: count_common( ["Perl", "is", "my", "friend"], ["Perl", "and", "Raku", "are", "friend"] ) == 2';
+    is $sub->( ["Perl", "and", "Python", "are", "very", "similar"], ["Python", "is", "top", "in", "guest", "languages"] ), 1,
+        'Example 2: count_common( ["Perl", "and", "Python", "are", "very", "similar"], ["Python", "is", "top", "in", "guest", "languages"] ) == 1';
+    is $sub->( ["Perl", "is", "imperative", "Lisp", "is", "functional"], ["Crystal", "is", "similar", "to", "Ruby"] ), 0,
+        'Example 3: count_common( ["Perl", "is", "imperative", "Lisp", "is", "functional"], ["Crystal", "is", "similar", "to", "Ruby"] ) == 0';
+}
+done_testing;
diff --git a/challenge-277/matthias-muth/perl/ch-2.pl b/challenge-277/matthias-muth/perl/ch-2.pl
new file mode 100755
index 0000000000..84fa9de192
--- /dev/null
+++ b/challenge-277/matthias-muth/perl/ch-2.pl
@@ -0,0 +1,43 @@
+#!/usr/bin/env perl
+#
+#       The Weekly Challenge - Perl & Raku
+#       (https://theweeklychallenge.org)
+#
+#       Challenge 277 Task 2: Strong Pair
+#
+#       Perl solution by Matthias Muth.
+#
+
+use v5.36;
+
+use Algorithm::Combinatorics qw( combinations );
+use List::Util qw( uniq min );
+
+sub strong_pair( @ints ) {
+    return scalar grep
+        0 < abs( $_->[0] - $_->[1] ) < min( $_->@[0,1] ),
+        combinations( [ uniq( @ints ) ], 2 );
+}
+
+sub strong_pair_2( @ints ) {
+    return scalar grep
+        $_->[0] > $_->[1] && ( $_->[0] - $_->[1] ) < $_->[1]
+            || $_->[0] < $_->[1] && ( $_->[1] - $_->[0] ) < $_->[0]
+        ? ( 1 ) : (),
+        combinations( [ uniq( @ints ) ], 2 );
+}
+
+
+use Test2::V0 qw( -no_srand );
+
+my $sub_name = "strong_pair";
+for my $sub ( sort grep /^${sub_name}/, keys %:: ) {
+    note "Testing $sub:";
+
+    no strict 'refs';
+    is $sub->( 1, 2, 3, 4, 5 ), 4,
+        'Example 1: $sub( 1, 2, 3, 4, 5 ) == 4';
+    is $sub->( 5, 7, 1, 7 ), 1,
+        'Example 2: $sub( 5, 7, 1, 7 ) == 1';
+}
+done_testing;