Perl Weekly Challenge 247.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 247.
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.
Example 1
The givers are randomly chosen but don't share family names with the receivers.
Input: @names = ('Mr. Wall',
'Mrs. Wall',
'Mr. Anwar',
'Mrs. Anwar',
'Mr. Conway',
'Mr. Cross',
);
Output:
Mr. Conway -> Mr. Wall
Mr. Anwar -> Mrs. Wall
Mrs. Wall -> Mr. Anwar
Mr. Cross -> Mrs. Anwar
Mr. Wall -> Mr. Conway
Mrs. Anwar -> Mr. Cross
Example 2
One gift is given to a family member.
Input: @names = ('Mr. Wall',
'Mrs. Wall',
'Mr. Anwar',
);
Output:
Mr. Anwar -> Mr. Wall
Mr. Wall -> Mrs. Wall
Mrs. Wall -> Mr. Anwar
I make a hash mapping full names to family names, and family names to arrays of full names. I sort family names according to their number of members, starting with the most numerous. Then, a solution may be found by circulating families and choosing a different member until depleted. The last receiver gives a gift to the first giver and that is the end. The code fits a 2.5 liner, but the full code is much more comprehensible (actually, I wrote it first and then compressed it).
Example 1:
perl -Mexperimental=postderef -E 'while(<>){chomp;($u,$l)=split " ";$l{$_}=$l;push $p{$l}->@*, $_;}
@f=sort {$p{$b}->@*<=>$p{$a}->@*}keys %p;while(@f){$h=shift @f;$g=shift $p{$h}->@*;$p//=$g;
push @f, $h if $p{$h}->@*;$r=$f[0]?$p{$f[0]}[0]:$p;say "$g -> $r";}' << END
Mr. Wall
Mrs. Wall
Mr. Anwar
Mrs. Anwar
Mr. Conway
Mr. Cross
END
Results:
Mr. Wall -> Mr. Anwar
Mr. Anwar -> Mr. Conway
Mr. Conway -> Mr. Cross
Mr. Cross -> Mrs. Wall
Mrs. Wall -> Mrs. Anwar
Mrs. Anwar -> Mr. Wall
Example 2:
perl -Mexperimental=postderef -E 'while(<>){chomp;($u,$l)=split " ";$l{$_}=$l;push $p{$l}->@*, $_;}
@f=sort {$p{$b}->@*<=>$p{$a}->@*}keys %p;while(@f){$h=shift @f;$g=shift $p{$h}->@*;$p//=$g;
push @f, $h if $p{$h}->@*;$r=$f[0]?$p{$f[0]}[0]:$p;say "$g -> $r";}' << END
Mr. Wall
Mrs. Wall
Mr. Anwar
END
Results:
Mr. Wall -> Mr. Anwar
Mr. Anwar -> Mrs. Wall
Mrs. Wall -> Mr. Wall
The full code follows.
1 # Perl weekly challenge 247
2 # Task 1: Secret Santa
3 #
4 # See https://wlmb.github.io/2023/12/11/PWC247/#task-1-secret-santa
5 use v5.36;
6 use experimental qw(postderef);
7 my %last_name;
8 my %person;
9 # Input from STDIN, one name per line
10 while(<>){
11 chomp;
12 my (undef,$last)=split " ";
13 $last_name{$_}=$last;
14 push $person{$last}->@*, $_;
15 }
16 my @families=sort {$person{$b}->@*<=>$person{$a}->@*} keys %person;
17 my $first_giver;
18 while(@families){
19 my $family_giver=shift @families;
20 my $giver=shift $person{$family_giver}->@*;
21 $first_giver//=$giver;
22 push @families, $family_giver if $person{$family_giver}->@*;
23 my $receiver=$families[0]?$person{$families[0]}[0]:$first_giver;
24 say "$giver -> $receiver";
25 }
Example 1:
./ch-1.pl << "END"
Mr. Wall
Mrs. Wall
Mr. Anwar
Mrs. Anwar
Mr. Conway
Mr. Cross
END
Results:
Mr. Anwar -> Mr. Wall
Mr. Wall -> Mr. Cross
Mr. Cross -> Mr. Conway
Mr. Conway -> Mrs. Anwar
Mrs. Anwar -> Mrs. Wall
Mrs. Wall -> Mr. Anwar
Example 2:
./ch-1.pl << "END"
Mr. Wall
Mrs. Wall
Mr. Anwar
END
Results:
Mr. Wall -> Mr. Anwar
Mr. Anwar -> Mrs. Wall
Mrs. Wall -> Mr. Wall
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.
Example 1
Input: $s = 'abcdbca'
Output: 'bc'
'bc' appears twice in `$s`
Example 2
Input: $s = 'cdeabeabfcdfabgcd'
Output: 'ab'
'ab' and 'cd' both appear three times in $s and 'ab' is
lexicographically smaller than 'cd'.
One can map the characters of the string into pairs of characters, map the with a hash to their number and sort them. The result fits a two-liner.
Examples:
perl -E 'for(@ARGV){@l=split "";$f=shift @l;$c{$_}++ for map{$n=$f;$f=$_;"$n$f"}@l;
@s=sort{$c{$b}<=>$c{$a}||$a cmp $b} keys %c;say "$_ -> $s[0]"}' abcdbca cdeabeabfcdfabgcd
Results:
abcdbca -> bc
cdeabeabfcdfabgcd -> ab
The full code is similar.
1 # Perl weekly challenge 247
2 # Task 2: Most Frequent Letter Pair
3 #
4 # See https://wlmb.github.io/2023/12/11/PWC247/#task-2-most-frequent-letter-pair
5 use v5.36;
6 die <<~"FIN" unless @ARGV;
7 Usage: $0 S1 [S2...]
8 to find the most frequent pair of consecutive letters
9 from each of the strings S1, S2...
10 FIN
11 for(@ARGV){
12 my @letters=split "";
13 my $first=shift @letters;
14 my %count;
15 $count{$_}++ for map{my $previous=$first; $first=$_; "$previous$first"}@letters;
16 my @sorted =sort{$count{$b}<=>$count{$a}||$a cmp $b} keys %count;
17 say "$_ -> $sorted[0]"
18 }
Examples:
./ch-2.pl abcdbca cdeabeabfcdfabgcd
Results:
abcdbca -> bc
cdeabeabfcdfabgcd -> ab
Written on December 11, 2023