#!/usr/bin/perl
$SIOD = "/usr/local/bin/siod";
$CHILDREN = 100;	# Children per generation
$LOG = "evolve.log";	# Log file

# SIOD built-in functions:
@siod_funcs = (

	'*', '+', '-', '/', '<', '<=', '=', '>', '>=', 'abs', 'acos',
	'and', 'append', 'apply', 'aref', 'array->hexstr', 'aset',
	'ash', 'asin', 'ass', 'assoc', 'assq', 'assv', 'atan',
	'atan2', 'base64decode', 'base64encode', 'begin', 'bit-and',
	'bit-not', 'bit-or', 'bit-xor', 'butlast', 'bytes-append',
	'caaar', 'caadr', 'caar', 'cadar', 'caddr', 'cadr', 'car',
	'cdaar', 'cdadr', 'cdar', 'cddar', 'cdddr', 'cddr', 'cdr',
	'cond', 'copy-list', 'cos', 'define', 'delq', 'eq?', 'equal?',
	'eqv?', 'eval', 'exit', 'exp', 'first', 'fmod', 'fnmatch',
	'gc-info', 'gc-status', 'get', 'hexstr->bytes', 'href',
	'hset', 'if', 'lambda', 'larg-default', 'last', 'length',
	'let', 'let*', 'list', 'log', 'lref-default', 'make-list',
	'mapcar', 'max', 'member', 'memq', 'memv', 'min', 'mkdatref',
	'nconc', 'not', 'nreverse', 'nth', 'null?', 'number->string',
	'number?', 'or', 'pair?', 'parse-number', 'pow', 'prin1',
	'print', 'print-to-string', 'prog1', 'qsort', 'quit', 'quote',
	'read-from-string', 'rest', 'reverse', 'set!', 'set-car!',
	'set-cdr!', 'set-symbol-value!', 'sin', 'sqrt', 'srand',
	'srandom', 'strbreakup', 'strcat', 'strcmp', 'strcpy',
	'strcspn', 'string->number', 'string-append',
	'string-dimension', 'string-downcase', 'string-length',
	'string-lessp', 'string-search', 'string-trim',
	'string-trim-left', 'string-trim-right', 'string-upcase',
	'string?', 'strspn', 'subset', 'substring',
	'substring-equal?', 'sxhash', 'symbol-bound?', 'symbol-value',
	'symbol?', 'symbolconc', 'tan', 'trunc', 'unbreakupstr',
	'url-decode', 'url-encode', 'while'

);

# SIOD built-in variables
@siod_vars = (
	'*pi*', 'errobj', 'nil', 't', '""'
	);

# randomatom
# Generate a random atom (non-list) Lisp expression
sub randomatom
{
	my $objclass = int(rand 3);	# Randomly decide what to return

	if ($objclass == 0)		# Built-in variable
	{
		# Return a random variable
		my $var = $siod_vars[rand $#siod_vars+1];
		return $var;
	} elsif ($objclass == 1)	# Integer
	{
		# Return a random integer between 0 and 999.
		my $i = int(rand(1000));
		return $i;
	} elsif ($objclass == 2)	# Identifier
	{
		# Return a random identifier between "id0" and "id19".
		my $id = "id" . int(rand(20));
		return $id;
	}
}

# randomprog
# Generate a random piece of Lisp-like code. There is no guarantee
# that it is valid Scheme, though.
#
# This function returns a Perl data structure that mimics the
# structure of the resulting Lisp program: lists are anonymous lists,
# and may be nested arbitrarily deeply.
sub randomprog
{
	my $objclass = int(rand 10);

	if ($objclass < 3)
	{
		# 30% of the time, just generate an atom.
		return &randomatom;
	} else {			# Function call
		# The rest of the time, generate a function call
		my $retval = [];

		# Pick a function to call
		my $func = $siod_funcs[rand $#siod_funcs+1];
		push @{$retval}, $func;

		# ... and some arguments
		while (int(rand(2)) == 0)
		{
			push @{$retval}, &randomprog;
		}
		return $retval;
	}
}

# lisp
# Return the printed representation of the Program, in Lisp
sub lisp
{
	my $str = shift;

	if (ref($str) eq "")		# Not a reference
	{
		return $str;
	} elsif (ref($str) eq "SCALAR")	# Reference to atom
	{
		return $$str;
	}

	# Otherwise, it must be a list
	return $retval = "(" . join(" ", map {&lisp($_)} @{$str}). ")";
}

# deep_copy
# Make a deep copy of a program. That is, if the program includes
# references to lists, this function makes copies of those lists,
# instead of just copying the references.
sub deep_copy
{
	my $arg = shift;

	if (ref($arg) eq "")
	{
		return $arg;
	} elsif (ref($arg) eq "SCALAR")
	{
		my $temp = $$arg;
		return \$temp;
	}

	# Otherwise, it must be a list
	return [ map {&deep_copy($_)} @{$arg} ];
}

# mutate
# Make a change to a program.
#
# Walks down the program, picks a point (either an atom or a sublist)
# at random, and makes some change to it. This change can be a
# replacement (replace the branch with something random), deletion
# (remove the branch altogether), or doubling (in a list, replace a
# branch with two copies of itself in succession).
sub mutate
{
	my $prog = shift;

	if (ref($prog) eq "")
	{
		# This is an atom. Replace it with something else.
		my $temp;
		if (rand() < 0.4)
		{
			$temp = &randomprog;
		} else {
			$temp = &randomatom;
		}
		return $temp;
	} elsif (ref($prog) eq "SCALAR")
	{
		my $temp = &randomatom;
		return \$temp;
	}

	# Otherwise, it must be a list
	my $r = rand;
	my $nth = int(rand($#{$prog}));		# Pick a list element
	if ($r < 0.1)
	{
		# 10% of the time, replace the whole list with something
		# else.
		return &randomprog;
	} elsif ($r < 0.2)
	{
		# 10% of the time, delete the selected item.
		splice @{$prog}, $nth, 1;
	} elsif ($r < 0.3)
	{
		# 10% of the time, duplicate the selected item
		splice @{$prog}, $nth, 0, &deep_copy($prog->[$nth]);
	} else {
		# The rest of the time, recursively mutate the selected item.
		$prog->[$nth] = &mutate($prog->[$nth]);
	}

	return $prog;
}

# score
# Calculate the fitness score for the given program (and a few other
# things).
# Actually, this function returns a list of three items, for
# efficiency: the printed representation of the program (this needs to
# be done anyway to calculate the score), its output, and its score.
sub score
{
	my $prog = shift;
	my $printed = &lisp($prog);
	my $output;
	my $score = 0;
	my $correct = 0;

	# Run the program.
	# It would have been nice to embed SIOD in Perl, but I can't
	# easily do that. Instead, we just write the program to a file
	# and run it.
	open PROG, "> candidate.scm";

	# In order to avoid infinite loops, we first set the CPU usage
	# limit to 1 second. Next we wrap the program in a (prin1)
	# statement to pretty-print its output.
	print PROG <<EOT;
(cpu-usage-limits 1 1)
(prin1
	$printed
)
EOT
	close PROG;
	$output = `$SIOD -v0 candidate.scm`;
	if ($? != 0)
	{
		# A program that doesn't compile isn't very fit
		return ($printed, "", -10000);
	}

	# We have the output. Now compare it to the input.
	my @orig = split(//, $printed);
	my @output = split(//, $output);
	my $retval = 0;
	while ($#orig >= 0)
	{
		# Suggestions for further experimentation: give points
		# for each matching character. Subtract (perhaps a
		# different number of) points for each non-matching
		# character.
		if ($orig[0] eq $output[0])
		{
			$correct++;
		}
		shift @orig;
		shift @output;
	}
	# Score depends primarily on proportion of matching
	# characters.
	# Suggestions for further experimentation: add or subtract
	# points for length, either linearly or non-linearly (e.g.,
	# length($printed) ** 2, or 1.04 ** length($printed))
	$score = int($correct/length($printed) * 100);

	# Penalize uninteresting programs.
	$score -= 200 unless $output =~ /[^-\d\.\"\(\)]/;
	$score -= 200 if $output eq "t";

	return ($printed, $output, $score);
}

### Main program

# Generate a progenitor. Get its score.
$ancestor = &randomprog;
($best_printed, $best_output, $best_score) = &score($ancestor);

open LOG, "> $LOG";
select(LOG); $| = 1; select(STDOUT);

# Keep making generations forever.
for ($generation = 0; ; $generation++)
{
	print LOG "===== Generation $generation:\n";
	print "Generation $generation\n";
	print "Ancestor:\n";
	print "printed: [$best_printed]\noutput: [$best_output]\nscore: $best_score\n\n";

	# Generate a number of children
	for ($childno = 0; $childno < $CHILDREN; $childno++)
	{
		# Each child is a mutant version of this generation's
		# ancestor
		$child = &mutate(&deep_copy($ancestor));

		# Get the child's score.
		($printed, $output, $score) = &score($child);
		print $childno, ": ", $printed, "\n";
		if ($score >= $best_score)
		{
			# We've found a winner (so far).
			$best_score = $score;
			$best_prog = $child;
			$best_printed = $printed;
			$best_output = $output;
		}
	}
	if ($best_printed ne $last_gen_winner)
	{
		print LOG <<EOT;
===== Best for generation $generation:
Program:
	 $best_printed
Output:
	[$best_output]
Score:	$best_score
EOT
		if ($best_printed eq $best_output)
		{
			print LOG "----- This was a self-replicating program\n";
		}
	}

	# Keep the child with the highest score as the ancestor of the
	# next generation. If none of the children scored higher than
	# the ancestor, the ancestor will be retained.
	$ancestor = $best_prog;
	$last_gen_winner = $best_printed;
}
close LOG;