Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

Re^2: Looking for help with AI::Genetic and classroom scheduling

by fizbin (Chaplain)
on Feb 23, 2005 at 06:58 UTC ( #433606=note: print w/ replies, xml ) Need Help??


in reply to Re: Looking for help with AI::Genetic and classroom scheduling
in thread Looking for help with AI::Genetic and classroom scheduling

Okay, I've finally managed to get working the approach I mentioned in my other reply, that of having the genes be precedence vectors for class assignments. However, first this requires a hack to AI::Genetic to work around a perl bug.

The fix is to change sortIndividuals in AI/Genetic.pm to read: (this is tweaking one line)

sub sortIndividuals { my ($self, $list) = @_; return [sort {$b->score <=> $a->score} map {$_->score;$_} @$list]; }
Update: You also have to change the two sort commands in AI/Genetic/OpSelection.pm if you want this to work reliably for small populations. In both cases, change
sort {$b->score <=> $a->score}
to
sort {$b->score <=> $a->score} map {$_->score;$_}

An alternative to patching AI::Genetic internals is to get a version of perl that doesn't suffer from the bug described here: http://www.nntp.perl.org/group/perl.perl5.porters/37481. To my knowledge, such a version of perl does not yet exist, but hey, you are merlyn.

Once that's done, you can try my approach. However, to make it easier to understand and compare side-by-side with your original approach, I rewrote your approach so that both ways of coding this had as much identical code as possible. This means that neither approach is implemented as cleanly or as efficiently as it could be - the goal was side-by-side comparison, not efficiency. In fact, the two scripts are now so similar that I'm just going to present yours as I recoded it and then explain how to transform it into mine:

#!/usr/bin/perl use strict; $|++; my @CLASSES = split /\s+/, <<'END'; XXX a-1 a-2 a-3 a-4 a-5 b-1 b-2 b-3 b-4 b-5 c-1 c-2 c-3 d-1 d-2 d-3 d-4 d-5 e-1 e-2 e-3 e-4 f-1 f-2 f-3 f-4 f-5 f-6 g-1 END my $SLOTS = 6; my $ROOMS = 3; use AI::Genetic; my $ga = AI::Genetic->new ( -fitness => \&my_fitness, -type => 'listvector', -terminate => \&my_terminate ); $ga->init([(\@CLASSES) x ($SLOTS * $ROOMS)]); $ga->evolve(rouletteTwoPoint => 20); print "final winners\n"; for my $i ($ga->getFittest(5)) { show_individual($i); } sub is_acceptable { # Is choice $_[0] an acceptable choice in slot $_[1], # room $_[2], with the array-of-arrays in $_[3] ? my ($choice, $slotnum, $roomnum, $config_so_far) = @_; return 1 unless $choice =~ /(.+-)/; # XXX is always acceptable my $teacher = $1; for my $pslot (0..$slotnum-1) { for my $proom (0..$ROOMS-1) { return 0 if ($choice eq $config_so_far->[$pslot][$proom]); } } for my $proom (0..$roomnum-1) { return 0 if ($config_so_far->[$slotnum][$proom] =~ /^$teacher/); } 1; # So it's acceptable } sub make_config { my (@genes) = @_; [ map {my $s=$_; [ map {$genes[$_ + $s*$ROOMS]} (0..$ROOMS-1) ]; } (0..$SLOTS-1) ]; } sub show_individual { my $i = shift; printf "score: %g\n", $i->score; my @g = $i->genes; my $config = make_config(@g); do { print " ", join " ", @$_; print "\n"; } for @$config; print "\n"; } sub my_fitness { my $genes = shift; my $score = 0; ## process slot by slot my $config = make_config(@$genes); for my $s (0..$SLOTS-1) { for my $r (0..$ROOMS-1) { local $_ = $config->[$s][$r]; ## "in with the good"... $score++ if /-/; # good if scheduled (no room left beh +ind!) $score += 0.5 if /3/; # good if it's a 3 (simulate user de +mand) ## "and out with the bad"... if (!is_acceptable($_,$s,$r,$config)) {$score -= 100;} } } return $score; } sub my_terminate { my $ga = shift; print "[", $ga->getFittest->score, "]"; ## show_individual($ga->getFittest); return 0; # do not terminate }
Now, to change that into my approach, where the genes represent class priorities, first change the setup code to:
my $ga = AI::Genetic->new ( -fitness => \&my_fitness, -type => 'rangevector', -terminate => \&my_terminate ); $ga->init([map {[0,100]} @CLASSES]);
Then, change the make_config sub:
sub make_config { my (@genes) = @_; # sort classes in order by genes: use Data::Dumper; my (@order) = sort {$genes[$a] <=> $genes[$b];} (0..$#CLASSES); my (@sclasses) = @CLASSES[@order]; push(@sclasses, (qw{XXX}) x ($SLOTS * $ROOMS)); my ($config) = []; for my $s (0..$SLOTS-1) { push @$config, []; for my $r (0..$ROOMS-1) { my $i=0; while (!is_acceptable($sclasses[$i],$s,$r,$config)) {$i++;} push @{$config->[-1]}, splice(@sclasses,$i,1); } } $config; }
And that's it.

The interesting thing is that this priority-driven approach converges almost instantly with the scoring function you supplied - the first or second generation usually has a configuration that scores at 20.5 or 21. (21 is the max. possible here)

I would be interested to know what more advanced scoring functions you come up with later and whether this priority-driven approach ends up being significantly better in practice than your initial approach of having a gene for each room/slot combination.

-- @/=map{[/./g]}qw/.h_nJ Xapou cets krht ele_ r_ra/; map{y/X_/\n /;print}map{pop@$_}@/for@/


Comment on Re^2: Looking for help with AI::Genetic and classroom scheduling
Select or Download Code
How to do it with no AI::Genetic hacks
by fizbin (Chaplain) on Feb 23, 2005 at 16:06 UTC
    As halley pointed out to me in node 433726, there is in fact a way to avoid the necessity of changing AI::Genetic at all, though it requires a small use of prototyping, which I know you abhor, to make it work.

    In my version, you just have to write the make_config sub like this:

    sub make_config { my (@genes) = @_; # sort classes in order by genes: # stupid #!@#!#$! sort bug my $sortsub = sub ($$) { my ($a,$b) = @_; $genes[$a] <=> $genes[$b]; }; my (@sclasses) = @CLASSES[sort $sortsub (0..$#CLASSES)]; push(@sclasses, (qw{XXX}) x ($SLOTS * $ROOMS)); my ($config) = []; for my $s (0..$SLOTS-1) { push @$config, []; for my $r (0..$ROOMS-1) { my $i=0; while (!is_acceptable($sclasses[$i],$s,$r,$config)) {$i++;} push @{$config->[-1]}, splice(@sclasses,$i,1); } } $config; }
    -- @/=map{[/./g]}qw/.h_nJ Xapou cets krht ele_ r_ra/; map{y/X_/\n /;print}map{pop@$_}@/for@/

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://433606]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (5)
As of 2014-09-01 11:49 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite cookbook is:










    Results (6 votes), past polls