#! 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"; <STDIN>;
    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;