Subject: [SPOILER] Expert Quiz - my solution
Newsgroups: gmane.comp.lang.perl.qotw.discuss
Date: 2004-05-22 14:18:14 GMT (4 years, 6 weeks, 2 days, 9 hours and 1 minute ago)
Hi,
I transformed the problem to a well known one, see comments in my code.
Greetings, Christian
Code:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
package Graph;
# This is a very simplified class representing a graph just for this
purpose.
sub new {
my $g = bless({}, shift);
$g->vertices(0);
$g->alists([]);
return $g;
} # sub
Graph::new
#------------------------------------------------------------------------------
sub _property {
my $self = shift; # Object
my $attr = shift; # attribute to get or set
my $setter = @_ == 1; # Is the method a setter?
my $value = shift; # value (if setter)
# If we would use "if (defined $value)" here, we couldn't set a
attribute
# to undef, so this form is used:
if ($setter) {
my $old_value = $self->{$attr};
$self->{$attr} = $value;
return $old_value;
}
else {
return $self->{$attr};
}
} # sub
Graph::_property
#------------------------------------------------------------------------------
sub vertices { return shift->_property('vertices', @_) }
sub alists { return shift->_property('alists', @_)
}
#------------------------------------------------------------------------------
sub color {
my $self = shift;
my $algorithm = shift;
my @colors = ();
return @colors unless $self->vertices();
for (0..$self->vertices()-1) {
push @colors, -1;
}
if ($algorithm eq 'backtracking') {
# calculate upper limit with greedy:
my @colgreedy = $self->color('greedy');
my $maxcolor = 0;
for (@colgreedy) {
$maxcolor = $_ if $_ > $maxcolor;
}
# stepping down until no better solution can be found:
my $success = 1;
my $colref_old = \@colgreedy;
while ($success) {
--$maxcolor;
my @bcolors;
push @bcolors, -1 for (0..$self->vertices()-1);
$success = $self->_kBacktracking($maxcolor, \@bcolors);
if ($success) {
$colref_old = [ @bcolors ];
}
}
$colors[$_] = $colref_old->[$_] for (0..$self->vertices()-1);
}
elsif ($algorithm eq 'simple') {
$colors[0] = 0;
for my $v (1..$self->vertices()-1) {
$colors[$v] = 0;
while ($self->_has_neighbour_with_color($v, $colors[$v],
\@colors)) {
++$colors[$v];
}
}
}
elsif ($algorithm eq 'greedy') {
$_ = 0 for @colors;
my $color = 0;
my $counter = 0;
while ($counter < $self->vertices()) {
++$color;
for my $v (0..$self->vertices()-1) {
if ($colors[$v] < 1 and $colors[$v] != -$color) {
$colors[$v] = $color;
++$counter;
for my $n ( @{ $self->alists()->[$v] } ) {
$colors[$n] = -$color if $colors[$n] < 1;
}
}
}
}
--$_ for @colors; # Fängt bei Null an!
}
else {
die "unknown algorithm '$algorithm'";
}
return @colors;
} # sub
Graph::color
#------------------------------------------------------------------------------
sub _has_neighbour_with_color {
my $self = shift; # object
my $v = shift; # vertex
my $col = shift; # color number
my $colors = shift; # reference to color array
for my $n ( @{ $self->alists()->[$v] } ) {
return 1 if $$colors[$n] == $col;
}
return 0;
} # sub
Graph::_has_neighbour_with_color
#------------------------------------------------------------------------------
sub _kBacktracking {
my $self = shift; # object
my $k = shift; # color number
my $c = shift; # reference to color array
die "_kBacktracking : Farbe $k zu klein." if $k < 0;
return $self->_btcTry(0, $k, $c);
} # sub
$self->_kBacktracking
#------------------------------------------------------------------------------
sub _btcTry {
my $self = shift; # object
my $i = shift; # vertex number
my $k = shift; # color number
my $c = shift; # reference to color array
my $n = $self->vertices();
my $color = -1;
my $q = 0;
die "_btcTry : vertex i = $i is not valid (valid is: [0, " . ($n-1) .
"])"
if $i >= $n;
die "_btcTry : color k = $k is not valid (valid is: [0, " . ($n-1) .
"])"
if $k < 0 or $k >= $n;
while (not $q and $color != $k) {
++$color;
last if $i == 0 and $color > 0;
if ($self->_btcPossible($i, $color, $c)) {
$c->[$i] = $color;
if ($i < $n-1) {
$q = $self->_btcTry($i+1, $k, $c);
$c->[$i] = -1 unless $q;
}
else {
$q = 1;
}
}
}
return $q;
} # sub
_btcTry
#------------------------------------------------------------------------------
sub _btcPossible {
my $self = shift; # object
my $i = shift; # vertex number
my $color = shift; # color number
my $c = shift; # reference to color array
for my $n (@{ $self->alists()->[$i] }) {
return 0 if $c->[$n] == $color;
}
return 1;
} # sub _btcPossible
package main;
#Today's quiz and next Monday's solution come courtesy of Pr. Shlomi Fish.
#Thank you, Shlomi!
#
#
# 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.
sub main ();
sub allocate_minimal_rooms ($$$);
main();
exit;
sub main () {
my @courses = (
'Advanced basket weaving',
'Applied hermeneutics of quantum gravity',
'Introduction to data structures'
);
my @slots = (
'Monday morning _very_ early :-D',
'Tuesday',
'We. 10:00 to 12:00',
'Th. 19:00 to 20:00',
'Friday evening',
);
my @schedule = (
[1, 1, 0, 0, 0],
[0, 1, 1, 0, 1],
[1, 0, 0, 1, 0],
);
my $rooms = allocate_minimal_rooms(scalar @courses,
scalar @slots,
\@schedule);
for my $rind (0..$#$rooms) {
print "course '$courses[$rind]' meets in room ", @{$rooms}[$rind],
".\n";
}
} # sub main
sub allocate_minimal_rooms ($$$) {
my $nrofcourses = shift;
my $nrofslots = shift;
my $schedule = shift;
#
# first caculating minimal overlap:
# (only for a minimum value, jfyi)
#
if (0)
{
my @minlapslots;
my $min = 1;
for my $sind (0..$nrofslots-1) {
$minlapslots[$sind] = 0;
for my $cind (0..$nrofcourses-1) {
$minlapslots[$sind] += $schedule->[$cind][$sind];
}
$min = $minlapslots[$sind] if $min < $minlapslots[$sind];
}
print "We need at least $min rooms.\n";
print Dumper(\@minlapslots);
}
# This problem is NP complete. It's analog to the problem of coloring
the
# vertices of a graph with the minimum number of colors.
#
# And about this problem and solutions for it I wrote my degree
# dissertation in graph theory.
#
# Thusfor I transform the problem to a graph, where each vertex stands
for
# one course and an edge stands for a slot, in which both of the
adjacent
# vertexes (=courses) will meet:
my $graph = new Graph;
$graph->vertices($nrofcourses);
my $alists = $graph->alists();
for my $cind (0..$nrofcourses-1) {
$graph->alists()->[$cind] = [];
for my $cind2 (0..$nrofcourses-1) {
next if $cind == $cind2;
for my $sind (0..$nrofslots-1) {
if (
$schedule->[$cind ][$sind] and
$schedule->[$cind2][$sind]
)
{
push @{$graph->alists()->[$cind]}, $cind2;
}
}
}
}
print Dumper($graph);
#
# Now we could use any algorithm we want to color the graph, if we want
# the exact minimal number of rooms, we have to use backtracking.
# Else we could use any heuristic algorithm we want, as greedy for
example.
# The first one will be exact, the latter one much faster.
#
# In my degree dissertation I discussed many algorithms (but I used C++
# and not Perl). If anyone here is interessted, I could post more
# algorithms.
#
# Color the graph:
my @rooms = $graph->color('backtracking');
#my @rooms = $graph->color('greedy');
#my @rooms = $graph->color('simple');
return \@rooms;
# This was a very mathematical way of solving the given problem:
# transforming it in a problem I solved before and solve that 
# Thusfore a "direct" transformation of the backtracking algorithm to
the
# form of the given problem would perhaps be faster, but I wanted to
show
# the interrelation of the given problem to graph theory.
# NP complete problems like this one won't be solved by an exact
algorithm
# with polynomial complexity. If you find such an algorithm, you will
get
# rich :-D Because if you solve any of the NP complete Problems, you
have
# solved _all_ of them, including Traveling Salesman Problem and much
more.
} # allocate_minimal_rooms