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@/