#!/usr/bin/perl # Cesspool Genetic Corewars Warrior Generator # Author: Jacob Torrey # Date: 11/9/08 ## TODO: # -> Replace the naive cross function with a smarter one use strict; our $MC = 0.05; our $INITLEN = 5; my $NUMGEN = 25; my $PC = 0.2; my %scores; my $POPSIZE = 50; my @arr = gen_init($POPSIZE); for (my $i = 0; $i < $NUMGEN; $i++) { %scores = fitness(@arr); my $j = 0; my $tmp; foreach my $k (sort {$scores{$b} cmp $scores{$a}} keys %scores) { if($j < $PC * $POPSIZE) { if($j == 0) { $tmp = $k; } else { push(@arr, cross($tmp, $k)); } } else { mutate($k); } $j++; } } foreach my $k (sort {$scores{$a} cmp $scores{$b}} keys (%scores)) { print $k.' '.$scores{$k}."\n"; } sub cross { my $filename1 = shift; my $filename2 = shift; my $name1 = $filename1; $name1 =~ s/\..*$//g; my $name2 = $filename2; $name2 =~ s/\..*$//g; my $name = $name1.'x'.$name2; my $filename = $name.'.red'; my $p1 = `cat $filename1`; my $p2 = `cat $filename2`; $p1 =~ s/^.*;START\n//mgsi; $p1 =~ s/\n;END.*$//gmis; $p2 =~ s/^.*;START\n//mgsi; $p2 =~ s/\n;END.*$//gmsi; write_prog($filename, $name, $p1.$p2); return $filename; # my $p1a = split(/\n/, $p1); # my $p2a = split(/\n/, $p2); } sub write_prog { my $filename = shift; my $name = shift; my $program = shift; my $skel = `cat skel.red`; open(FP, ">$filename"); $skel =~ s/NAME/$name/; $skel =~ s/;BODY/$program/gmi; print FP $skel; close(FP); } sub mutate { my $filename = shift; my $name = $filename; $name =~ s/\..*$//g; my $program = `cat $filename`; if(rand() < $MC) { $program =~ s/^.*;START\n//smgi; $program =~ s/\n;END.*$//gmsi; my $op = $program; for(my $i = 0;; $i++) { my $ii = $i + int(rand(5)); $program =~ s/$i/$ii/; if($program ne $op) { last; } } write_prog($filename, $name, $program); } return $filename; } sub fitness { my @files = @_; my $cmd = "corewars-cmd -l REDCODE -s 64000 -h"; my $string = ''; my %scores; for (my $i = 0; $i < scalar(@files); $i++) { $string .= ' '.@files[$i]; } my @res = `$cmd$string`; for (my $i = 0; $i < scalar(@res); $i++) { my $score = @res[$i]; my $name = @res[$i]; $score =~ s/\s{2,3}\d*\s+//; $score =~ s/\s+.*$//; chomp $score; $name =~ s/\s{2,3}\d*\s+\d+\s+//; $name =~ s/\s+.*$//; chomp $name; $name .= '.red'; $scores{$name} = $score; } return %scores; } sub gen_init { my $num = shift; my @names; my @commands = qw(dat mov add sub jmp mov dat); for (my $i = 0; $i < scalar($num); $i++) { my $prog = ''; my $name = 'cp'.$i; my $filename = $name.'.red'; for (my $j = 0; $j < scalar($INITLEN); $j++) { # Pick some random commands $prog .= "\t".@commands[int(rand(scalar(@commands)))].' '.(int(rand(10)) - 5).', '.(int(rand(10)) - 5)."\n"; } write_prog($filename, $name, $prog); push(@names, $filename); } return @names; }