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]

In reply to Re: league games schedule algorithm by rir
in thread league games schedule algorithm by cLive ;-)

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.