#! perl -slw
use strict;
use List::Util qw[ shuffle max min reduce sum first ];
our $SECTIONS ||= 15;
our $STUDENTS ||= 50;
our $MAXCHOICE ||= $SECTIONS;
our $R ||= int rand 1000;
print "!$R!";
srand( $R );
## Gen some test data
my %sections = map{;
sprintf( "Section_%03d", $_ )
=>
{available => 1 }
} 0 .. $SECTIONS - 1;
my @sections = sort keys %sections;
my $n = $STUDENTS - $SECTIONS;
$sections{ $sections[ rand @sections ] }{ available }++
while $n--;
printf "Sections: %d \n\t%s\n", scalar keys %sections, join "\n\t",
map{ join " $_ =>", %{ $sections{ $_ } } } @sections;
my %students = map{
my $prefs = 1+int( rand $MAXCHOICE );
sprintf( "Student_%03d", $_ )
=>
[ ( shuffle( 0 .. $SECTIONS-1 ) )[ 0 .. $prefs-1 ] ]
} 0 .. $STUDENTS-1;
my @students = sort keys %students;
printf "Students: %d [%s\n]\n", scalar keys %students,
join ', ', map{ "\n\t$_\t[ @{ $students{ $_ } } ]" } @students;
## Main algorithm
my $maxChoices = max( map{ scalar @{ $students{ $_ } } } @students );
for my $choice ( 0 .. $maxChoices ) {
my $byChoice = reduce{
push @{ $a }, []
if defined $a->[ -1 ][ 0 ]
and ( $students{ $students[ $a->[ -1 ][ 0 ] ] }[ $choice ]||1e99 )
!= ( $students{ $students[ $b ] }[ $choice ]||1e99 ) ;
push @{ $a->[ -1 ] }, $b;
$a
} [[]], sort{
($students{ $students[ $a ] }[ $choice ]||99999) <=> ($students{ $students[ $b ] }[ $choice ]||99999) ## By nth choice
or
@{ $students{ $students[ $a ] } } <=> @{ $students{ $students[ $b ] } } ## or number of choices
} 0 .. $#students;
my @allocated;
for my $chose ( @$byChoice ) {
next unless defined $students{ $students[ $chose->[ -1 ] ] }[ $choice ];
my $section = sprintf "Section_%03d",
$students{ $students[ $chose->[ -1 ] ] }[ $choice ];
# print "Sect:$section; avail: $sections{ $section }{ available }\t[@{[ sort {$a<=>$b} @$chose ]}][@{[ sort {$a<=>$b} @allocated ]}]";
if( @$chose <= $sections{ $section }{ available } ) {
push @{ $sections{ $section }{ allocated } }, @students[ @$chose ];
$sections{ $section }{ available } -= @$chose;
push @allocated, @$chose;
# print "Alloc1: \t\t\t[@{[ sort {$a<=>$b} @$chose ]}][@{[ sort {$a<=>$b} @allocated ]}]";
next;
}
my @lastChoice = grep{
$#{ $students{ $students[ $_ ] } } == $choice
} @$chose;
# print "lastchoice: \t\t[@lastChoice]";
if( @lastChoice and @lastChoice <= $sections{ $section }{ available } ) {
push @{ $sections{ $section }{ allocated } }, @students[ @lastChoice ];
$sections{ $section }{ available } -= @lastChoice;
@{ $chose } = grep{
my $allocated = $_;
!grep{ $_ == $allocated } @lastChoice
} @$chose;
push @allocated, @lastChoice;
# print "Alloc2: \t\t\t[@{[ sort {$a<=>$b} @$chose ]}][@{[ sort {$a<=>$b} @allocated ]}]";
}
if( @$chose and $sections{ $section }{ available } ) {
my @random = ( shuffle( @$chose ) )[ 0 .. $sections{ $section }{ available } - 1 ];
push @{ $sections{ $section }{ allocated } }, @students[ @random ];
$sections{ $section }{ available } = 0;
@{ $chose } = grep{
my $allocated = $_;
!grep{ $_ == $allocated } @random
} @$chose;
push @allocated, @random;
# print "Alloc3: \t\t\t[@{[ sort {$a<=>$b} @$chose ]}][@{[ sort {$a<=>$b} @allocated ]}]";
}
}
delete @students[ @allocated ];
@students = grep{ defined } @students;
# print "left: @students"; ;
last unless @students;
}
print "\nUnallocated after main pass; [@students]";
my @withPlaces = grep{ $sections{ $_ }{ available } } sort keys %sections;
print "Sections with places: [@withPlaces]\n";
@withPlaces = map{ m[(\d+)]; 0+$1 } @withPlaces;
my $sentinel = $students[ 0 ];
JIGGLE:
while( @students ## students without a place
and sum( map{ $_->{ available } } values %sections ) ## and places unallocated
) {
my $unplaced = shift @students; ## Grab the first unplaced student
for my $choice ( map{ sprintf 'Section_%03d', } @{ $students{ $unplaced } } ) { ## And look at their choices
## Look at the students currently allocated to each of those choices
for my $placed ( @{ $sections{ $choice }{ allocated } } ) {
print "looking at placed student $placed";
## And check if there are places availble in any of their alternate choices?
my $alternateSection = first{
my $alt = $_;
grep{ $alt == $_ } @withPlaces
} @{ $students{ $placed } };
## If so,
if( $alternateSection ) {
$alternateSection = sprintf 'Section_%03d', $alternateSection;
## Remove them from their current placement, and add the unplaced student in their place
@{ $sections{ $choice }{ allocated } } = (
$unplaced,
grep{ !m[$placed] } @{ $sections{ $choice }{ allocated } }
);
## And re-place them into that alternate
push @{ $sections{ $alternateSection }{ allocated } }, $placed;
## And decrement the places available there.
$sections{ $alternateSection }{ available }--;
print "moved $placed to $alternateSection and put $unplaced in $choice\n";
next JIGGLE;
}
}
## If we got here, then we couldn't jiggle a place for the last unplaced student,
## so stick 'em back into the list. !!! POTENTIAL INFINITE LOOP !!!
push @students, $unplaced;
print "Failed to replace $unplaced\n";
last JIGGLE if $students[ 0 ] = $sentinel; ## Crude, but this loop has too many conditions!
}
}
print "\nUnallocated after one-level jiggle(TM); [@students]";
print "$_($sections{ $_ }{ available }) => ", ref $sections{ $_ }{ allocated }
? "[ @{ $sections{ $_ }{ allocated } } ]"
: "[EMPTY]"
for sort keys %sections;