w247 - Task 1 & 2

2 files changed, 131 insertions, 0 deletions

diff --git a/challenge-247/perlboy1967/perl/ch1.pl b/challenge-247/perlboy1967/perl/ch1.pl
new file mode 100755
index 0000000000..d41ed73cd6
--- /dev/null
+++ b/challenge-247/perlboy1967/perl/ch1.pl
@@ -0,0 +1,82 @@
+#!/bin/perl
+
+=pod
+
+The Weekly Challenge - 247
+- https://theweeklychallenge.org/blog/perl-weekly-challenge-247
+
+Author: Niels 'PerlBoy' van Dijke
+
+Task 1: Secret Santa
+Submitted by: Andreas Voegele
+
+Secret Santa is a Christmas tradition in which members of a group are randomly
+assigned a person to whom they give a gift.
+
+You are given a list of names. Write a script that tries to team persons from
+different families.
+
+=cut
+
+use v5.32;
+use common::sense;
+use feature qw(signatures);
+
+use Test2::V0 -srand => 247;
+
+use List::Util qw(shuffle);
+
+sub nameSort {
+  my @a = split(/\s+/,$a);
+  my @b = split(/\s+/,$b);
+  return $a[1] cmp $b[1] || $a[0] cmp $b[0];
+}
+
+sub secretSanta(@names1) {
+  my @names2 = shuffle @names1;
+  my @assignments;
+
+  while (my $name1 = shift(@names1)) {
+    my ($lastname1) = $name1 =~ m#(\S+)$#;
+    if ($#names2 > 1) {
+      while ($names2[0] =~ m#(\S+)$# and $lastname1 eq $1) {
+        push(@names2,shift @names2);
+      }
+    }
+    push(@assignments,sprintf("%s -> %s",$name1,shift @names2));
+  }     
+
+  [sort nameSort @assignments]; 
+}
+
+is(secretSanta(
+     'Mr. Wall',
+     'Mrs. Wall',
+     'Mr. Anwar',
+     'Mrs. Anwar',
+     'Mr. Conway',
+     'Mr. Cross',
+   ), 
+   [
+     'Mr. Anwar -> Mr. Cross',
+     'Mrs. Anwar -> Mrs. Wall',
+     'Mr. Conway -> Mr. Wall',
+     'Mr. Cross -> Mrs. Anwar',
+     'Mr. Wall -> Mr. Conway',
+     'Mrs. Wall -> Mr. Anwar', 
+   ]
+);
+
+is(secretSanta(
+     'Mr. Wall',
+     'Mrs. Wall',
+     'Mr. Anwar',
+   ),
+   [
+    'Mr. Anwar -> Mrs. Wall',
+    'Mr. Wall -> Mr. Anwar',
+    'Mrs. Wall -> Mr. Wall', 
+   ]
+);
+
+done_testing;
diff --git a/challenge-247/perlboy1967/perl/ch2.pl b/challenge-247/perlboy1967/perl/ch2.pl
new file mode 100755
index 0000000000..62f9106db7
--- /dev/null
+++ b/challenge-247/perlboy1967/perl/ch2.pl
@@ -0,0 +1,49 @@
+#!/bin/perl
+
+=pod
+
+The Weekly Challenge - 247
+- https://theweeklychallenge.org/blog/perl-weekly-challenge-247
+
+Author: Niels 'PerlBoy' van Dijke
+
+Task 2: Most Frequent Letter Pair
+Submitted by: Jorg Sommrey
+
+You are given a string S of lower case letters 'a'..'z'.
+
+Write a script that finds the pair of consecutive letters in S that appears most frequently.
+If there is more than one such pair, chose the one that is the lexicographically first.
+
+=cut
+
+use v5.32;
+use common::sense;
+use feature qw(signatures);
+
+use Test2::V0;
+
+use List::Util qw(uniq max);
+use Algorithm::Combinatorics qw(variations);
+
+sub mostFrequentLetterPair($string) {
+  my @chars = uniq sort split //, $string;
+  my $l = length $string;
+
+  my %count;
+
+  for my $p (variations(\@chars,2)) {
+    next if $$p[0] eq $$p[1];
+    my $c2 = $$p[0].$$p[1];
+    $count{$c2} = ($l - length ($string =~ s/$c2//gr))/2;
+  }
+
+  my $m = max(values %count);
+
+  return (sort grep { $count{$_} == $m } keys %count)[0];
+}
+
+is(mostFrequentLetterPair('abcdbca'),'bc');
+is(mostFrequentLetterPair('cdeabeabfcdfabgcd'),'ab');
+
+done_testing;