#!/usr/bin/env perl

# Course placer. Demonstration program showing the use of
# many Perl fundamentals, written and Copyright Well House
# Consultants Ltd. Phone +44 (0) 1225 708225

$coursemax = "@ARGV" || 6; # maximum trainees per course
open (FH,"requests") or # file of course requests
        die "No incoming file of place requests\n";

# set up list of names, hash of requirements and hash of courses
################################################################

while (<FH>) {
        my ($name,@want) = split (/[\s,]+/);
        $request{$name} = \@want;
        foreach $course (@want) {
                $c{$course}++;
                $tops{$course}+=0 ;
                }
        $tops{$want[0]}++ ;
        $ntrainees++;
        }

# Our input data is now in
# %c hash of course names, containing number of
# expressions of a preference for each
# %tops hash of coures names, containing a count of
# top preferences
# %request hash of lists of preferences. The main data
# for the forthcoming sections
# Above data is NOT altered during iterations

# List out incoming stats. This section does not alter the
# data.

print "Incoming trainees: $ntrainees\n";
print "Different courses requested: ",$nc=scalar(keys %c),"\n";
print "Places per course: $coursemax\n";
print "Total places available: ",$nc*$coursemax,"\n\n";
foreach $course (sort keys %c) {
        print "$c{$course} expressed interest in $course\n";
        print "$tops{$course} had top choice of $course\n\n";
        }

($ntrainees > $nc * $coursemax) and die "Not enough places\n";

# place people one by one on to their most available course
###########################################################

# Put code from here down in a loop to keep trying to get
# a better result; otherwise, we may end up with a result
# that cannot be improved but is in an iteration "cul de sac"

$iterationcount = 10; # number of iterations to run

for ($iteration=0; $iteration<$iterationcount; $iteration++) {

my %assign;

# Take all the trainees (in a random order) and place each in
# turn on their highest choice course that's still available

@names = shuffle(keys %request);

foreach $person (@names) {
        my @want = @{$request{$person}};
        $placed = 0;
        foreach $try (@want) {
                if ($assign{$try} > ($coursemax-1)) {
                        next;
                } else {
                        $oncourse{$person} = $try;
                        $assign{$try}++;
                        $placed = 1;
                        last;
                }
        }
# If none of their choices is available, store them for the
# next stage - see if you can place other people on a
# choice thay have made first!

        unless ($placed) {
                # warn ("Can't place $person yet\n") ;
                push @filler,$person;
                }
}

# spread the unsatisfied around amongst courses that are slack!
# Start with most popular courses for better results later?
# But this will lead to some dreadful slack courses!
# Doesn't make much difference if courses are really tight
###############################################################

while (1) {
foreach $course (sort {$a <=> $b} keys %c) {
        next if ($assign{$course} > ($coursemax-1));
        $force = pop @filler;
        last unless ($force);
        $oncourse{$force} = $course;
        $assign{$course}++;
        }
last unless ($force);
}

# print out the initial assignments and scores for this iteration
# if you're in debug mode; also get a score. 0 is a perfect
# score (everyone on their top choice) and 1 is taken off that
# score for each time someone is moved one place down their list
# of preferences

# At this point, %oncourse is a hash of people containing the
# name of the course they are provisionally selected to attend.
# %assign contains the course names and the number of people
# assigned to each. So far, it is only used to avoid overbooking
# of a course (already done), but it might be useful later as
# we enhance the algorithm.

$value = reportscore (0); # change to 1 to test improvement loop!

# See if we can improve scores by doing a crossover swap
########################################################

# keep trying this loop until no further improvements are made

do {
$swapped = 0;
$| = 1; # do not buffer the following output
print "."; # for trace / debug / interest purposes
for ($k=0; $k<@names; $k++) {
        for ($j=$k+1; $j<@names; $j++) {

                $temp = $oncourse{$names[$k]};
                $oncourse{$names[$k]} = $oncourse{$names[$j]};
                $oncourse{$names[$j]} = $temp;

                $newvalue = reportscore(0);
                # print "$newvalue, $value ";

                if ($newvalue > $value) {
                        # print "*";
                        $value = $newvalue;
                        $swapped++;
                        next;
                } else {
                        $temp = $oncourse{$names[$k]};
                        $oncourse{$names[$k]} = $oncourse{$names[$j]};
                        $oncourse{$names[$j]} = $temp;
                        }
        }
}
} while ($swapped);
$|=0; # turn buffereing back on

# "reportscore" works out the score; with a parameter of 2, it also
# sets up a hash called final that is keyed on course names, and each
# element contains a list of people on that course

$value = reportscore (2);
# tabulate(); # do this if tracing

# If this is the best iteration so far, or the fist iteration, store it

unless ($iteration) {
        $bestvalue = $value -1;
        }
if ($bestvalue < $value) {
                print "Improved to $value\n";
                $bestvalue = $value;
                %bestcourse = %oncourse;
        } else {
                print "Remains at $bestvalue (only achieved $value)\n";
        }

undef %oncourse;
undef %final;

} # End of 10 x iteration loop

# Restore the settings that we saved during the best iteration, recalculate
# the scores and provide a full report of who is on what course.

%oncourse = %bestcourse;
reportscore (1);
reportscore(2);
tabulate();

############################################################################

sub reportscore {
        my ($trace) = $_[0];
        $skipper = 0;
        foreach $p (sort keys %oncourse) {
                $chnum = 0;
                for ($i=0; $i<=$coursemax; $i++) {
                        $chnum++;
                        last if ($request{$p}[$i] eq $oncourse{$p});
                        $skipper--;
                }
                printf ("%10s is on %10s - their choice %d\n",ucfirst($p),
                                        $oncourse{$p},$chnum) if ($trace == 1);
                $pstack = $p." ".("*" x ($chnum-1));
                push @{$final{$oncourse{$p}}},$pstack if ($trace == 2);
        }
        print "Measure of success in place people - $skipper points\n"
                                        if ($trace == 1);
        return $skipper;
}

############################################################################

sub shuffle {
        my @input = @_;
        my @output;
        while (@input) {
                $posn = int(rand(@input));
                push @output,splice(@input,$posn);
                }
        return @output;
        }

#############################################################################

sub tabulate {
foreach $course (sort keys %final) {
        printf "%-6s ",$course;
        foreach $student (sort @{$final{$course}}) {
                printf "%-10s",ucfirst($student) ;
                }
        print "\n";
        }
}

__END__

=head1 The place_people program

This is a program which allows you to place people on their
preferred course and uses an I<Iteration technique> to improve
on its first results is everyone cannot be given their
first choice.

Inputs:

=over 4

=item 1

A file called B<requests> containing each persons name and
list of course ordered by their preference

=item 2

A command line parameter which is the maximum number of
people that can be taken on each course