Hope you enjoy the league.

Update: If we fall through to the bottom of the PROBLEM loop,
the code should die as it can't resolve the problem.
No change made to below.

#!/usr/bin/perl
use strict;
use warnings;

# XXX marks badness.

# This program assumes an elitist outlook.  The better team
# at a shared venue is always given preference to play at
# home vs. the 'B' team.
#
# Here team codes are generated:
#     1.1 is the #1 A team \
#     1.2 is the #1 B team -->  these share a venue: venue #1
#     2   is another team

# This is a quick hack, hacked straight through, i.e. inelegant
# run-on code.


my @match;   # periods w/ their pairings
my @entries; # the teams


############### Build the team list.
{
    my ( $entry_ct, $shared_tab_ct );
    ( $shared_tab_ct, $entry_ct) = ( 3, 18); # XXX magic values

    print "Total $entry_ct entries with ", 2* $shared_tab_ct,
      " sharing tables.\n";

    # Check specified constraint
    die "Too many shared tables" if 6* $shared_tab_ct < $entry_ct;

    # build entry list
    for ( my $e = 0 ; $e < $shared_tab_ct ; ++$e ) {
        push @entries, $e + 1 . ".1";
        push @entries, $e + 1 . ".2";
    }
    for ( my $e = $shared_tab_ct * 2 ; $e < $entry_ct ; ++$e ) {
        push @entries, $e + 1;
    }

    # maybe add a bye
    push @entries, "0" if @entries % 2;
}


# Create raw permutations for each periods' pairings.
my @sched;
{
    my @mute = @entries;
    my $head = shift @mute;
    my $period;
    for ( my $i = 1 ; $i <= @mute ; ++$i ) {
        $period = [ $head, @mute ];
        push @mute, $mute[0];
        shift @mute;
        push @sched, $period;
    }
}


# Do the pairings for each period.
for ( my $p = 0 ; $p < @sched ; ++$p ) {
    my @conflicts = ();

#    print "Period ", $p + 1, "\n";
    # Fold permutations to build naive pairings.
    for ( my $i = 0 ; $i < @entries / 2 ; ++$i ) {
        $match[$p]->[$i]->{home} = $sched[$p]->[$i];
        $match[$p]->[$i]->{away} = $sched[$p]->[ @entries - $i - 1 ];
    }

#    for ( my $j = 0 ; $j < @entries / 2 ; ++$j ) {
#        print "$match[$p]->[$j]->{home} vs $match[$p]->[$j]->{away}\n
+";
#    }


    # Find problem venues.
    for ( my $k = 0 ; $k < @entries / 2 ; ++$k ) {
        $conflicts[ int( $match[$p]->[$k]->{home} ) ] += 1;
    }
    my @prob_list = ();
    for ( my $i = 0 ; $i < @conflicts ; ++$i ) {
        push @prob_list, $i
            if ( defined $conflicts[$i] && 1 < $conflicts[$i] );
    }

#    { local $, = " "; print "\@prob_list", @prob_list, "\n"; }


    # Find non-problem shared venues -- can't let
    # these become problems.
    my @ok_list = ();
    for ( my $n = 0 ; $n < @entries / 2 ; ++$n ) {
        next unless is_sharing( $match[$p]->[$n]->{home} );
        next if
           grep $_ eq &venue( $match[$p]->[$n]->{home}), @prob_list;
        push @ok_list, venue( $match[$p]->[$n]->{home})
           unless
              grep $_ eq venue( $match[$p]->[$n]->{home}), @ok_list;
    }


#    unless (@prob_list) {
#        print "No Revision Necessary";
#        next;
#    }


    # Fix the problems.
    PROBLEM:
    foreach my $prob (@prob_list) {
        my $team = $prob . ".2";    # pick the B team
        my ($pair) =
          grep { $_->{home} eq $team } @{ @match->[$p] };
        if ($pair) {
            if ( not is_sharing( $pair->{away} ) ) {
                rev($pair);
                next PROBLEM;
            }
            else {
                if ( !grep $pair->{away} eq $_, @ok_list ) {
                    rev($pair);
                    push @ok_list, $pair->{away};
                    next PROBLEM;
                }
            }
        }
        else {
            $team = $prob . ".1";
            $pair = grep $_->{home} eq $team, @{@match->[$p]};
            if ($pair) {
                if ( not is_sharing( $pair->{away} ) ) {
                    rev($pair);
                    next PROBLEM;
                }
                else {
                  if (!grep $pair->{away} eq $_, @ok_list){           
+                                                                     
+                                                        
                        rev($pair);
                        push @ok_list, $pair->{away};
                        next PROBLEM;
                    }
                }
            }
        }
    }

    print "\nPeriod ", $p + 1, "\n";
    for ( my $j = 0 ; $j < @entries / 2 ; ++$j ) {
        print "$match[$p]->[$j]->{home} vs " .
             "$match[$p]->[$j]->{away}\n";
    }
    print "\n\n";
}


# Flip a pairing.
sub rev {
    ($_[0]->{home}, $_[0]->{away}) = ($_[0]->{away}, $_[0]->{home});
}


# Boolean:  Named team is_sharing a venue.
sub is_sharing { $_[0] != int( $_[0] ); }


# Get venue from team.
sub venue { int( $_[0] ); }
[download]