sub sortIndividuals { my ($self, $list) = @_; return [sort {$b->score <=> $a->score} map {$_->score;$_} @$list]; } #### sort {$b->score <=> $a->score} #### sort {$b->score <=> $a->score} map {$_->score;$_} #### #!/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 behind!) $score += 0.5 if /3/; # good if it's a 3 (simulate user demand) ## "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 } #### my $ga = AI::Genetic->new ( -fitness => \&my_fitness, -type => 'rangevector', -terminate => \&my_terminate ); $ga->init([map {[0,100]} @CLASSES]); #### 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; } #### -- @/=map{[/./g]}qw/.h_nJ Xapou cets krht ele_ r_ra/; map{y/X_/\n /;print}map{pop@$_}@/for@/