Here's a couple of sample runs:
[pimento:~] simonm% perl -w /tmp/t.pl 1 2 3 Competing: 3 schools, 6 entrants Structure: 3 rounds of 3 panels Panel Size: 2 entries each Calculation: required 5 attempts in 0 seconds Teams: - A1 - B1, B2 - C1, C2, C3 Round 1: - B2, C3 - C1, B1 - C2, A1 Round 2: - C3, B1 - A1, C1 - B2, C2 Round 3: - C2, B1 - A1, C3 - C1, B2 perl -w /tmp/t.pl 3 3 3 3 3 3 3 3 3 3 Competing: 10 schools, 30 entrants Structure: 3 rounds of 6 panels Panel Size: 5 entries each Calculation: required 1062 attempts in 12 seconds Teams: - A1, A2, A3 - B1, B2, B3 - C1, C2, C3 - D1, D2, D3 - E1, E2, E3 - F1, F2, F3 - G1, G2, G3 - H1, H2, H3 - I1, I2, I3 - J1, J2, J3 Round 1: - B2, C2, D1, J2, A2 - C3, I2, H3, J3, G3 - E1, F1, I1, B3, A3 - F3, B1, H1, C1, G2 - E3, H2, F2, D2, A1 - D3, E2, J1, G1, I3 Round 2: - A1, G1, C3, B1, J2 - D3, A2, J3, I1, H2 - B3, H1, I3, G3, D2 - E2, A3, H3, F3, C2 - E3, J1, C1, F1, B2 - G2, F2, D1, I2, E1 Round 3: - F1, H1, I2, E2, J2 - B1, A2, G3, J1, F2 - I3, C2, E1, J3, A1 - C1, H2, A3, D1, G1 - B3, C3, F3, D3, E3 - I1, G2, D2, H3, B2
And here's the source code:
use strict; ### Constants my $number_of_rounds = 3; my $max_per_panel = 6; my $max_per_team = 3; # Make this number bigger to get better results at the cost of running + slower my $attempts_before_enlarging_panels = 1000; ### Parse Arguments unless ( scalar @ARGV ) { print "Usage: pass the number of participants from each team as argu +ments\n"; exit; } my @entrants = @ARGV; ### Build Teams my %teams; my $team_id = 'A'; foreach my $count ( @entrants ) { die "Too many people on team $team_id: $count" if ( $count > $max_pe +r_team ); foreach my $j ( 1 .. $count ) { $teams{$team_id}->[ $j - 1 ] = "$team_id$j"; } $team_id ++; } my @participants = map { @$_ } values %teams; ### Declare Result Variable my @rounds; my $start_time = time(); my $attempts = 1; ### Determine Panel Size my $panels_required = int( .99 + scalar(@participants) / $max_per_pane +l ); $panels_required = $max_per_team if ( $panels_required < $max_per_team + ); PANEL_EXPANSION: { my $base_per_panel = int( scalar(@participants) / $panels_required ) +; my $oversize_panels = scalar(@participants) - ($panels_required * $b +ase_per_panel ); my $most_per_panel = $base_per_panel + ( $oversize_panels ? 1 : 0 ); my @panel_sizes = ( ( $oversize_panels ? ( $most_per_panel ) x $oversize_panels : () + ), ( $base_per_panel ) x ( $panels_required - $oversize_panels ) ); ### Attempt to Build Panels ATTEMPT: { # The "zero round" contains the teams themselves @rounds = [ map $teams{$_}, sort keys %teams ]; foreach my $round ( 1 .. $number_of_rounds ) { # warn "Building round $round\n"; my %exclusions; foreach my $panel ( map @$_, @rounds ) { foreach my $a ( @$panel ) { foreach my $b ( @$panel ) { $exclusions{$a}->{$b} = 1; } } } # warn "Should exclude: " . join(', ', map { my $a = $_; map "$a +-$_", sort keys %{$exclusions{$a}} } sort keys %exclusions) . "\n"; my @available = @participants; my @panels; foreach my $panel ( 1 .. $panels_required ) { # warn " Building panel $panel ($panel_sizes[$panel - 1])\n"; my @entries; foreach ( 1 .. $panel_sizes[$panel - 1] ) { last unless scalar @available; my %exclude = map { $_ => 1 } map { sort keys %{$exclusions{$_}} } @ +entries; # warn " Avoiding " . join(', ', sort keys %exclude) . +"\n"; my @candidates = ( grep { ! $exclude{$_} } @available ) or d +o { # warn "Can't find a candidate in: " . join(', ', @availab +le); if ( $attempts ++ % $attempts_before_enlarging_panels ) { # warn "Trying again..." redo ATTEMPT; } else { # warn "This is taking too long; expanding number of pan +els..."; $panels_required ++; redo PANEL_EXPANSION; } }; my $candidate = $candidates[ int rand scalar @candidates ]; # warn " Selecting $candidate\n"; push @entries, $candidate; @available = grep { $_ ne $candidate } @available; } # @entries = map $teams{$_}->[$panel - 1], sort keys %teams; $panels[$panel - 1] = \@entries; } $rounds[$round] = \@panels; } } ### Display Competition Info print "Competing: " . scalar(@entrants) . " schools, " . scalar(@participants) . " entrants\n"; print "Structure: $number_of_rounds rounds of $panels_required panel +s\n"; print "Panel Size: $most_per_panel entries " . ( $oversize_panels ? "or less (" . join(', ', @panel_sizes) . ")" : 'each' ) . "\n" +; print "Calculation: required $attempts attempts in " . ( time - $start_time ) . " seconds\n"; } ### Display Teams and Rounds foreach my $round ( 0 .. $#rounds ) { print( "\n" . ( $round ? "Round $round" : "Teams" ) . ":\n" ); my @panels = @{ $rounds[$round] }; foreach my $panel ( @panels ) { print( "- " . join(', ', @$panel) . "\n" ) } }
As you can see, it's not terribly elegant, and there's a chance that it will needlessly allocate one or two more panels than are strictly needed, but it handles arbitrary numbers of entries from each school, and it does seem to work consistently.
In reply to Re: Perl for Adjudication
by simonm
in thread Perl for Adjudication
by dejoha
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |