Beefy Boxes and Bandwidth Generously Provided by pair Networks
Come for the quick hacks, stay for the epiphanies.
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
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@/

In reply to Re^2: Looking for help with AI::Genetic and classroom scheduling by fizbin
in thread Looking for help with AI::Genetic and classroom scheduling by merlyn

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others admiring the Monastery: (6)
As of 2024-03-28 13:45 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found