Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Comment on

( #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":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

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

    How do I use this? | Other CB clients
    Other Users?
    Others having an uproarious good time at the Monastery: (4)
    As of 2014-09-20 00:32 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      How do you remember the number of days in each month?











      Results (151 votes), past polls