Sample solutions and discussion Perl Expert Quiz of The Week #16 (20040519) [ This week's question, and this followup report, were provided by Shlomi Fish. Thanks, Shlomi! - MJD ] You will write a program that schedules the semester of courses at Haifa University. @courses is an array of course names, such as "Advanced Basket Weaving". @slots is an array of time slots at which times can be scheduled, such as "Monday mornings" or "Tuesdays and Thursdays from 1:00 to 2:30". (Time slots are guaranteed not to overlap.) You are also given a schedule which says when each course meets. $schedule[$n][$m] is true if course $n meets during time slot $m, and false if not. Your job is to write a function, 'allocate_minimal_rooms', to allocate classrooms to courses. Each course must occupy the same room during every one of its time slots. Two courses cannot occupy the same room at the same time. Your function should produce a schedule which allocates as few rooms as possible. The 'allocate_minimal_rooms' function will get three arguments: 1. The number of courses 2. The number of different time slots 3. A reference to the @schedule array It should return a reference to an array, say $room, that indicates the schedule. $room->[$n] will be the number of the room in which course $n will meet during all of its time slots. If courses $n and $m meet at the same time, then $room->[$n] must be different from $room->[$m], because the two courses cannot use the same room at the same time. For example, suppose: Time slots 0 1 2 3 4 Courses 0 X X (Advanced basket weaving) 1 X X X (Applied hermeneutics of quantum gravity) 2 X X (Introduction to data structures) The @schedule array for this example would contain ([1, 1, 0, 0, 0], [0, 1, 1, 0, 1], [1, 0, 0, 1, 0], ) 'allocate_minimal_rooms' would be called with: allocate_minimal_rooms(3, 5, \@schedule) and might return [0, 1, 1] indicating that basket weaving gets room 0, and that applied hermeneutics and data structures can share room 1, since they never meet at the same time. [1, 0, 0] would also be an acceptable solution, of course. ----------------------------------------- Well, this quiz generated several solutions from several people: 0. MJD sent a test suite: http://article.gmane.org/gmane.comp.lang.perl.qotw.discuss/1661 And I sent a test suite of my own: http://article.gmane.org/gmane.comp.lang.perl.qotw.discuss/1662 1. Roger Burton West sent an exhaustive search solution: http://perl.plover.com/~alias/list.cgi?1:mss:1599 2. Ronald J. Kimball also sent an exhaustive search one, this time using string operations to represent the schedule array. http://perl.plover.com/~alias/list.cgi?1:mmn:1600 3. Christian Duhl identified that the problem was NP-Complete transformed it to a graph colouring problem and solved it using this: http://article.gmane.org/gmane.comp.lang.perl.qotw.discuss/1666 5. I sent my own solution (which I'll give below). This one uses intermediate truth tables between courses and rooms. http://perl.plover.com/~alias/list.cgi?1:mmn:1603 6. Finally, Mark Jason Dominus posted his solution that also used recursion as well as string operations. http://perl.plover.com/~alias/list.cgi?1:mmn:1604 Here is my sample solution. It is smarter than the brute-force method, but still recursive and may explode for certain schedules. It works by assigning a room to a course, and then finding a course that requires a different room. It then assigns another room to this course. The algorithm maintains a truth table of which courses can be allocated to which rooms. Once a room was allocated to a class, all of the classes that share time-slots with this class are marked as being unable to use the room. If all the rooms that were allocated so far are unusable by a certain class, then it is allocated a new room. If the algorithm reaches a place where a room can be allocated to any of several classes, it recurses with each possibility. ============================================== package Assign; use strict; require Exporter; use vars qw(@ISA @EXPORT); @ISA=qw(Exporter); @EXPORT = qw(allocate_minimal_rooms); sub new { my $class = shift; my $self = {}; bless $self, $class; $self->_init(); return $self; } sub _init { return 0; } sub get_params_from_file { my $self = shift; my $in_file = shift; local (*I); open I, "<$in_file" || die "Could not open file for reading"; my $line = ; chomp($line); my ($classes_num, $time_slots_num) = split(/\s+/, $line); my @table; for my $i (1 .. $classes_num) { $line = ; chomp($line); if (length($line) ne $time_slots_num) { die "Wrong number of characters in line " . ($i+1); } my $is_assigned_once = 0; my @time_slots; foreach my $c (split(//, $line)) { my $is_true = ($c ne " "); if ($is_true) { $is_assigned_once = 1; } push @time_slots, $is_true; } if (! $is_assigned_once) { die "Class has no allocated time slots in line " . ($i+1) . "."; } push @table, \@time_slots; } return ($classes_num, $time_slots_num, \@table); } sub assign_params { my $self = shift; my ($classes_num, $time_slots_num, $table) = @_; $self->{'c_n'} = $classes_num; $self->{'ts_n'} = $time_slots_num; $self->{'table'} = $table; return 0; } sub read { my $self = shift; my $in_file = shift; return $self->assign_params( $self->get_params_from_file($in_file) ); } use constant NONE => 0; use constant ASSIGNED => 1; use constant CANNOT => 2; sub solve_for_teachers_num { my $self = shift; my $teachers_num = shift; my $classes_num = $self->get_classes_num(); my $time_slots_num = $self->{'ts_n'}; my $hours_table = $self->{'table'}; # A trivial case for assignment if ($teachers_num >= $classes_num) { return [ 0 .. ($classes_num-1) ]; } my $assign_first_flag = 1; if (@_) { $assign_first_flag = 0; } # This maintains a truth table of which teacher # can or cannot teach which class. my $truth_table = shift || [ map { [ (NONE) x $classes_num ] } (1 .. $teachers_num) ]; # This is a bitmask that indicates which classes are going to # be assigned a teacher for and which already were assigned. my $class_bitmask = shift || [(0) x $classes_num]; my $assign_class_teacher = sub { my $class = shift; my $teacher = shift; for my $t (0..($teachers_num-1)) { $truth_table->[$t]->[$class] = (($t == $teacher) ? ASSIGNED : CANNOT ); } for my $ts (0 .. ($time_slots_num-1)) { if ($hours_table->[$class]->[$ts]) { for my $c (0 .. ($classes_num-1)) { next if ($c == $class); if ($hours_table->[$c]->[$ts]) { $truth_table->[$teacher]->[$c] = CANNOT; } } } } $class_bitmask->[$class] = 1; }; if ($assign_first_flag) { $assign_class_teacher->(0,0); } my $num_assigned_teachers = shift || 1; TEACHERS_ASSIGNMENT_LOOP_1: while ($num_assigned_teachers < $teachers_num) { # Find a class that has to be assigned a new teacher my $suitable_class; CLASS_LOOP: for my $class (0 .. ($classes_num-1)) { # This class was already assigned so there's no need # to check it again. next if $class_bitmask->[$class]; for my $t (0 .. ($num_assigned_teachers - 1)) { if ($truth_table->[$t]->[$class] != CANNOT) { next CLASS_LOOP; } } # We found a suitable class. $suitable_class = $class; last CLASS_LOOP; } if (defined($suitable_class)) { $assign_class_teacher->( $suitable_class, $num_assigned_teachers++ ); } else { last TEACHERS_ASSIGNMENT_LOOP_1; } } if ($num_assigned_teachers == $teachers_num) { my $class=0; my $run_first = 1; while ($run_first && ($class < $classes_num)) { $run_first = 0; CLASS_ASSIGN_SINGULAR_TEACHER_LOOP: for($class=0;$class < $classes_num; $class++) { # This class was already assigned so there's no need # to check it again. next if ($class_bitmask->[$class]); my $teachers_count = 0; my $available_teacher; for my $t (0 .. ($teachers_num-1)) { if ($truth_table->[$t]->[$class] == NONE) { $teachers_count++; $available_teacher = $t; } } if ($teachers_count == 1) { $assign_class_teacher->( $class, $available_teacher ); last CLASS_ASSIGN_SINGULAR_TEACHER_LOOP; } } } } my $class_to_iterate_over; for($class_to_iterate_over=0; $class_to_iterate_over<$classes_num; $class_to_iterate_over++) { last if (! $class_bitmask->[$class_to_iterate_over]); } if ($class_to_iterate_over == $classes_num) { return $self->create_summary($truth_table); } my @teachers = (grep { $truth_table->[$_]->[$class_to_iterate_over] == NONE } (0 .. ($teachers_num-1)) ); # Save a backup copy. my $backup_truth_table = $truth_table; my $backup_class_bitmask = $class_bitmask; foreach my $iter_teacher (@teachers) { # Duplicate $truth_table = [ map { [ @$_ ] } @$backup_truth_table ]; $class_bitmask = [ @$backup_class_bitmask ]; $assign_class_teacher->($class_to_iterate_over, $iter_teacher); my $ret = $self->solve_for_teachers_num( $teachers_num, $truth_table, $class_bitmask, $num_assigned_teachers ); if ($ret) { return $ret; } } return undef; } sub create_summary { my $self = shift; my $truth_table = shift; my $classes_num = $self->get_classes_num(); return [ map { my $c = $_; (grep { $truth_table->[$_]->[$c] == ASSIGNED } (0..(scalar(@$truth_table)-1)) ) } (0 .. ($classes_num-1)) ]; } sub solve { my $self = shift; my $teachers_num = $self->get_classes_num(); my ($ret, $prev_ret); while ($teachers_num >= 1) { $ret = $self->solve_for_teachers_num($teachers_num); last if (!$ret); $teachers_num--; $prev_ret = $ret; } return $prev_ret; } sub get_classes_num { my $self = shift; return $self->{'c_n'}; } sub allocate_minimal_rooms { my ($classes_num, $time_slots_num, $schedule) = (@_); my $obj = Assign->new(); $obj->assign_params($classes_num, $time_slots_num, $schedule); return $obj->solve(); } 1; __END__ Regards, Shlomi Fish