Task — Secret Santa

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.

Examples

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

Analysis

I started this task by assigning the people's nams as the keys to a hash. So here's my first failing: it won't work if two people have identical names.

Then there are some conditions that are perhaps just hinted at. The first is that is probably undesirable, though it isn't stated, for a to give to b, and b to a. So let's try to avoid that if possible: I did it by sorting the list of donors and reverse sorting the recipients.

The next challenge is in the words 'randomly assigned'. My initial solution came up with what looked like random assignments, but repeating the exercise came up with the same again, which is decidedly un-random. So rather than sorting the keys of my %people hash, I gave each hash element a random 3-digit value and then sorted them by value using this:
sort {$people{$b} <=> $people{$a}} keys %people

The reverse sort is then just a case of exchanging $a and $b.

And finally we have the requirement that we try to ensure that members of the same family are not donor and recipient of any gift. I think we are entitled to assume (though not always true in real life) that members of a family have the same, unique last name, so we have first to check that there is no eligible non-family-member and if so then find a family member who hasn't already received a gift. And don't forget that a family name might be something like Jones-O'Hara.

Note that the same-family clause will only apply if there is a family that has more members than all the others combined, for example 5 out of 9 in total.

Merry Christmas everyone!

Try it 

Script

#!/usr/bin/perl

use v5.26;    # The Weekly Challenge - 2023-12-11
use utf8;     # Week 247 task 1 - Secret santa
use strict;   # Peter Campbell Smith
use warnings; # Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge

secret_santa('Mr. Wall', 'Mrs. Wall', 'Mr. Anwar', 
    'Mrs. Anwar', 'Mr. Conway', 'Mr. Cross', 
    'Miss Anwar', 'Dr Anwar', 'Lord Anwar');

secret_santa('Rudolph Reindeer', 'Dasher Reindeer', 'Dancer Reindeer',
    'Prancer Reindeer', 'Vixen Reindeer','Comet Reindeer',
    'Cupid Reindeer', 'Donner Reindeer', 'Blitzen Reindeer',
    'Santa Claus', 'Mrs Claus', 'Subordinate Claus');
                 
sub secret_santa {
    
    my (%people, %recipient, $d, $r, $result, $list, $j);
    
    # initialise
    $people{$_} = int(rand(899) + 101)  for (@_);
    $list = '   ';
    
    # find someone with a different surname
    D: for $d (sort {$people{$a} <=> $people{$b}} keys %people) {
        $list .= $d . ($j ++ % 3 == 2 ? qq[,\n   ] : ', ');
        for $r (sort {$people{$b} <=> $people{$a}} keys %people) {
            next if ($d eq $r or $people{$r} == 0);
            if (surname($d) ne surname($r)) {
                $result .= qq[   $d -> $r\n];
                $people{$r} = 0;
                next D;
            }
        }
        
        # no luck, so try for wih the same one
        for $r (sort {$people{$a} <=> $people{$b}} keys %people) {
            next if ($d eq $r or $people{$r} == 0);
            $result .= qq[   $d -> $r\n];
            $people{$r} = 0;
            next D;
        }   
    }
    
    # show results
    $list =~ s|,[\n ]+$||;
    say qq[\nInput:\n$list];
    say qq[Output:\n] . substr($result, 0, -1);
}

sub surname {   
    $_[0] =~ m|([-a-zA-Z']*)$|;
    return $1;
}

Output

Input:
   Lord Anwar, Miss Anwar, Mr. Anwar,
   Mr. Cross, Dr Anwar, Mr. Conway,
   Mr. Wall, Mrs. Wall, Mrs. Anwar
Output:
   Lord Anwar -> Mrs. Wall
   Miss Anwar -> Mr. Wall
   Mr. Anwar -> Mr. Conway
   Mr. Cross -> Mrs. Anwar
   Dr Anwar -> Mr. Cross
   Mr. Conway -> Dr Anwar
   Mr. Wall -> Mr. Anwar
   Mrs. Wall -> Miss Anwar
   Mrs. Anwar -> Lord Anwar

Input:
   Rudolph Reindeer, Comet Reindeer, Dasher Reindeer,
   Prancer Reindeer, Subordinate Claus, Dancer Reindeer,
   Cupid Reindeer, Vixen Reindeer, Santa Claus,
   Mrs Claus, Donner Reindeer, Blitzen Reindeer
Output:
   Rudolph Reindeer -> Mrs Claus
   Comet Reindeer -> Santa Claus
   Dasher Reindeer -> Subordinate Claus
   Prancer Reindeer -> Rudolph Reindeer
   Subordinate Claus -> Blitzen Reindeer
   Dancer Reindeer -> Comet Reindeer
   Cupid Reindeer -> Dasher Reindeer
   Vixen Reindeer -> Prancer Reindeer
   Santa Claus -> Donner Reindeer
   Mrs Claus -> Vixen Reindeer
   Donner Reindeer -> Dancer Reindeer
   Blitzen Reindeer -> Cupid Reindeer