Some of Santa's Reindeer are gathering for a little holiday party, and wish to do Secret Santa for gift-giving, where everyone is assigned each to another to bring a gift. This can be assigned by drawing a name from a hat, and keeping it if it's someone else, and replacing it if you draw yourself. But Comet and Cupid give each other gifts all the time, and last year Donner gave to Dancer, so those shouldn't occur this year. Which means that the list has to really be checked twice & thrice, also to make sure that no one is left out or doubled up. Math::Combinatorics, with some List::Util assistance, will give us all the possible combinations to check for one that works.
The approach is make an NxN grid represented by a 1-D array 0..N*N-1, and the solution (if any) will be one of the N*N-choose(N) combinations. So we'll get a random one of those, test it, and repeat until we find one or run out. Actually, it's (N*N-N-X) choose N, since the diagonal of the NxN, which is N elements, can immediately be excluded, as can any other (X of them) exclusions provided by the user.
So for N=6, it's a 6x6 grid, with 36 elements 0-35, from 27 (36 minus 6 diagonals minus 3 exceptions) of which we'll choose 6. Those 9 exclusions are shown with strike-through in the grid below. Now shuffle(( up the initial order of those 27, and then use Math::Combinatorics 1 to start iterating through the combinations with the next_combination() method. Once a combination passes all the checks, we have all our Secret Santas (shown in red on the grid) and display them in the output.
| 0 | 1 | 2 | 3 | 4 | 5 | |
|---|---|---|---|---|---|---|
| 0 | 0 | 1 | 2 | 3 | 4 | 5 |
| 1 | 6 | 7 | 8 | 9 | 10 | 11 |
| 2 | 12 | 13 | 14 | 15 | 16 | 17 |
| 3 | 18 | 19 | 20 | 21 | 22 | 23 |
| 4 | 24 | 25 | 26 | 27 | 28 | 29 |
| 5 | 30 | 31 | 32 | 33 | 34 | 35 |
There are C(27,6) = 296010 total combinations.
Tried 13074 combinations.
Dasher => Comet
Dancer => Cupid
Comet => Dancer
Cupid => Donner
Donner => Blitzen
Blitzen => Dasher
1 use Math::Combinatorics; 2 use List::Util qw/shuffle first/; 3 4 # 0 1 2 3 4 5 5 my @set = qw/ Dasher Dancer Comet Cupid Donner Blitzen /; 6 7 my $N = scalar @set; 8 my @exclude = ( 9 [ 4 => 1 ], # Donner => 'Dancer' 10 [ 2 => 3 ], # Comet => 'Cupid' 11 [ 3 => 2 ], # Cupid => 'Comet' 12 ); 13 14 my %exceptions = map { my ($r,$c) = @$_; $r*$N+$c => undef } @exclude; 15 my $combinat = Math::Combinatorics->new( 16 count => $N, 17 data => [shuffle grep { int($_/$N)!=$_%$N && ! exists $exceptions{$_} } 0 .. $N*$N-1] 18 ); 19 20 my (%givers, %recips); 21 my $ct=0; 22 my $numItems = $N*$N-$N-scalar(keys %exceptions); 23 printf "There are C(%d,%d) = %.f total combinations.\n", 24 $numItems, $N, 25 factorial($numItems)/factorial($numItems-$N)/factorial($N); 26 while(my @combo = $combinat->next_combination){ 27 $ct++; 28 %givers = map { int($_/$N) => $_%$N } @combo; 29 @recips{values %givers} = keys %givers; # invert hash 30 do{ %givers=(); next } if 31 keys(%givers) != $N 32 || keys(%recips) != $N 33 ; 34 last; 35 } 36 print "Tried $ct combinations.\n"; 37 die "no valid combination exists" unless %givers; 38 39 printf "%s => %s\n", @set[ $_, $givers{$_} ] for keys %givers;
1. The same module has a derange() method that should improve efficiency (it implicitly excludes the diagonal and enforces the 1-per-row/1-per-col constraints), but the concise algorithm using that is less transparent and left as an exercise to the reader.