[Solution] Perl 'Medium' QOTW

No pretty tricks from tourney or game theory, but it's not super ugly or 
expensive.

Starts by making a list of all the games that ultimately must be played 
in the entire tourney. It then attempts to create a schedule, one day at 
a time. It scans all the matches left to be played, and add each one if 
possible (neither team already scheduled for that day). If it gets the 
required number of matches, it returns the match. Otherwise, it 
backtracks to find a different solution.

Once a day is set, those matches are removed from the pool, and a new 
day begins, if there are any matches left to be played.

Recursion is used to make the backtracking simple.

-- Rod Adams


#!/usr/bin/perl

for (1..5) {
 print $_*2, ":\n";
 $x = allocate_schedule($_*2);
 pprint ($x);
}

sub allocate_schedule {
 my $n = $_[0];
 $n & 1 and die "Can't schedule odd number of teams\n";

 # Create list of all matches
 my @Matches;
 for my $n1 (0 .. $n-2) {
   for my $n2 ($n1+1 .. $n-1) {
     push @Matches, [$n1, $n2];
   }
 }

 my @result = ();
 my $match_per_day = $n / 2;
 while (@Matches) {
   my $result = create_day($match_per_day, [], \@Matches,0);
   if (defined($result)) {
     push @result, $result;
   } else {
     die "Impossible to Schedule.\n";
   }
 }
 return \@result;
}

sub create_day {
 my ($left, $today, $remaining, $tail) = @_;
 return $today if $left <= 0;

 # look for a match to add
 for my $m ($tail .. $#$remaining) {
   my ($t1, $t2) = @{$$remaining[$m]};
   next if defined($$today[$t1]);
   next if defined($$today[$t2]);

   $$today[$t1] = $t2;
   $$today[$t2] = $t1;

   my $result = create_day($left-1, $today, $remaining, $m+1);
   if (defined($result)) {
     splice(@$remaining, $m, 1, );
     return $result;
   } else {
     $$today[$t1] = $$today[$t2] = undef;
   }
 }

 # no matches worked... abort
 return undef;
}


sub pprint {
 my @out;
 for my $x (@{$_[0]}) {
   push @out, '[' . join(',', @$x) . ']';
 }
 print "[", join(",\n ", @out), "]\n";
}

__END__