#!/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;
}