#!/usr/bin/perl -w
package neat;
# NEAT - Neuro-Evolution of Augmenting Topologies

use strict;
use warnings;
use Data::Dumper;

my $DEBUG = 0;

BEGIN {
	use Exporter ();
	our ( $VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS );

	$VERSION = 1.0;
	@ISA = qw( Exporter );
	@EXPORT = qw( 
		Copy
		SaveData
		LoadData
		);
}

# interface methods
sub new 
{
	my $self = {};
	$self->{CLASSNAME} = shift;
	bless $self;
	$self->Init( @_ );
	return $self;
}
sub DESTROY 
{
	my $self = shift;
	# nothing important to be done
}
sub Init 
{
	my $self = shift;
	my $file = shift;
	my $fast = shift;

	die "MUST specify an initial experiment configuration file!"
	 unless defined $file;

	# load the experiment file
	my $data = LoadData( $file );
	foreach my $key ( keys %$data ) {
		$self->{$key} = $data->{$key};
	}

	if ( ! defined $fast ) {
		# re-init topology activation functions
		foreach my $t ( values %{$self->{'topologies'}} ) {
			delete $t->{'code'};
			delete $t->{'func'};
		}
		$self->InitTopologies();
	}

	$DEBUG = $self->{'settings'}->{'debug'};
}
sub InitTopologies
{
	my $self = shift;
	my $net;
	foreach $net ( values %{$self->{'population'}} ) {
		my $t = NetworkTopology( $net );
		$self->AddTopology( $t, $net );
	}
}
sub EvaluationFunction
{
	my ( $self, $func ) = @_;
	$self->{'settings'}->{'eval-func'} = $func;
}
sub EvaluateAll
{
	my $self = shift;

	my @networks = values %{$self->{'population'}};
	my $func = $self->{'settings'}->{'eval-func'};
	foreach my $net ( @networks ) {
		$net->{'fitness'} = &$func( $net );
	}
}
sub Save
{
	my ( $self, $file ) = @_;
	if ( ! defined $file ) {
		$file = $self->{'settings'}->{'experiment'} . "."
			  . $self->{'save'}->{'generation'} . ".pl";
	}
	SaveData( $self, $file );
}
sub Champions
{
	my $self = shift;
	my @champions;
	my ($top,$net,$fitness);

	# initialize the toplogy records
	foreach $top ( values %{$self->{'topologies'}} ) {
		$top->{'members'} = [];
		$top->{'min'} = 1e+99;
		$top->{'max'} = -1e+99;
		$top->{'total'} = 0;
		$top->{'count'} = 0;
		$top->{'last'} = $top->{'avg'};
		$top->{'avg'} = 0;
		$top->{'offspring'} = 0;
	}
	my $min = 1e+99;
	my $max = -1e+99;
	my $total = 0;
	my $count = 0;
	# update topologies with total fitness values
	foreach $net ( values %{$self->{'population'}} ) {
		my $f = $net->{'fitness'};
		# update population min/max/total/count
		$min = $f if $f < $min;
		$max = $f if $f > $max;
		$total += $f;
		$count++;
		
		# update topology min/max/total/count
		$top = $self->{'topologies'}->{ $net->{'topology'} };
		$top->{'min'} = $f if $f < $top->{'min'};
		$top->{'max'} = $f if $f > $top->{'max'};
		$top->{'total'} += $f;
		$top->{'count'}++;
		push @{$top->{'members'}}, $net->{'id'};

		# if this is better than the historical max, save it
		if ( $f > $self->{'save'}->{'max-fitness'} ) {
			$self->{'save'}->{'max-fitness'} = $f;
			$self->{'save'}->{'max-fitness-generation'} = 
				$self->{'save'}->{'generation'};
			$self->{'save'}->{'champion'} = Copy( $net );
		}
	}

	# update global statistics
	$self->{'save'}->{'gen-min'} = $min;
	$self->{'save'}->{'gen-max'} = $max;
	$self->{'save'}->{'gen-avg'} = $total / $count;
	
	# calculate average fitness for each topology
	foreach $top ( values %{$self->{'topologies'}} ) {
		if ( $top->{'count'} > 0 ) {
			$top->{'avg'} = $top->{'total'} / $top->{'count'};
		} else {
			$top->{'avg'} = 0;
		}
	}

	# calculate an adjusted average after throwing out all below-average values
	foreach $top ( values %{$self->{'topologies'}} ) {
		$top->{'adj-total'} = $top->{'total'};
		$top->{'adj-count'} = $top->{'count'};
	}
	foreach $net ( values %{$self->{'population'}} ) {
		my $f = $net->{'fitness'};
		my $top = $self->{'topologies'}->{ $net->{'topology'} };
		if ( $f < $top->{'avg'} ) {
			$top->{'adj-total'} -= $f;
			$top->{'adj-count'}--;
		}
	}
	foreach $top ( values %{$self->{'topologies'}} ) {
		if ( $top->{'adj-count'} > 0 ) {
			$top->{'adj-avg'} = $top->{'adj-total'} / $top->{'adj-count'};
		} else {
			$top->{'adj-avg'} = 0;
		}
	}
	
	# sort members by fitness
	# adjust penalty
	# save best to champions list
	foreach $top ( values %{$self->{'topologies'}} ) {
		# sort members by fitness, descending
		@{$top->{'members'}} = sort {
			$self->{'population'}->{$b}->{'fitness'} <=> 
			$self->{'population'}->{$a}->{'fitness'};
			} @{$top->{'members'}};

		# update 'best' fitness
		if ( defined( $top->{'members'}->[0] ) ) {
			# lookup the fitness of the topology leader
			$fitness = $self->{'population'}->{
				$top->{'members'}->[0] }->{'fitness'};
		
			# add the fitness to the history record (limit 100)
			$top->{'history'} = [] if ( ! exists $top->{'history'} );
			unshift @{$top->{'history'}}, $fitness;
			pop @{$top->{'history'}} if @{$top->{'history'}} > 100;
			
=huh
			# calculate a weighted average
			my $total = 0;
			my $weight = 100;
			my $count = 0;
			foreach my $f ( @{$top->{'history'}} ) {
				$total += $f * $weight;
				$count += $weight;
				$weight--;
			}
			my $avg = $total / $count;
=cut

			# require at least X generations before we start looking
			# at the penalty, to give it a chance to establish itself 
			if ( @{$top->{'history'}} < 5 ) {
				$top->{'penalty'} = 0;
				$top->{'best'} = 0;
			} else {
				# adjust penalty based on improvement
				if ( $fitness > $top->{'best'} ) {
					$top->{'penalty'} *= 0.9; # 90% of what it was
					$top->{'best'} = $fitness;
				} else {
					$top->{'penalty'}++;
				}
			} 

			# save this member as a champion
			push @champions, $top->{'members'}->[0]; 
		}
		# save the second-place member, too, if there is one
		push @champions, $top->{'members'}->[1] 
			if ( defined( $top->{'members'}->[1] ) );
	}
	@champions = sort @champions;
	$self->{'champions'} = \@champions;
	return @champions;
}
sub Epoch
{
	my $self = shift;

	my @champs = Champions( $self );
	my $t; # topology

	# save the experiment data, if requested
	$self->Save() if ( $self->{'settings'}->{'save-epochs'} );

	# calculate minimum/maximum weights and active topology search count
	my %active;
	my $min = $self->{'settings'}->{'max-weight'};
	my $max = - $min;
	foreach my $net ( values %{$self->{'population'}} ) {
		$active{$net->{'topology'}}++;
		next if $net->{'fitness'} < $self->{'topologies'}->{ $net->{'topology'} }->{'avg'};
		foreach my $node ( values %{$net->{'nodes'}} ) {
			foreach my $c ( values %$node ) {
				$min = $c if $c < $min;
				$max = $c if $c > $max;
			}
		}
	}
	$self->{'save'}->{'min-weight'} = $min;
	$self->{'save'}->{'max-weight'} = $max;
	
	$self->{'save'}->{'generation'}++;

	$self->AllocateOffspring();
	my $remaining;

	$self->{'offspring'} = {}; # keep the new offspring here

	# create the new generation. 
	foreach $t ( values %{$self->{'topologies'}} ) {
		$remaining = int( $self->{'settings'}->{'population'} 
					- scalar( keys %{$self->{'offspring'}} ) );
		$remaining = 0 if $remaining < 0;

		# how many offspring are allowed
		# special case for offspring less than 1 but non-zero
		# or where the population limit is exceeded
		my $limit = $self->{'settings'}->{'limit'};
		my $o = abs($t->{'offspring'});
		$o = 3 if ( $o > 0 && $o < 1 );
		$o = int ( $o );
		$o = $limit if ( $o > $limit );
		$o = $remaining if ( $o > $remaining );
		$o = 3 if ( $o < 1 && $t->{'offspring'} > 0 );

		# first place champion
		next unless defined $t->{'members'}->[0];
		my $one = $self->{'population'}->{ $t->{'members'}->[0] };
		$t->{'champion'} = Copy( $one );

		# pass the best one on to the next generation
		next unless $o--; $self->Elite( $one );

		# focus the first few offspring on potentially profitable 
		# changes so that if it is our last chance, we have a 
		# CHANCE of making an improvement during this generation
		next unless $o--; $self->WeightAdjust( $one );  # only change ONE weight
		next unless $o--; $self->WeightsAdjust( $one );  # change all weights
		next unless $o--; $self->WeightsRandom( $one );  # choose all new weights

		# make a list of all members within the topology
		my @members;
		foreach my $m ( @{$t->{'members'}} ) {
			my $n = $self->{'population'}->{$m};
#			next if $n->{'fitness'} < 
#				$self->{'topologies'}->{ $n->{'topology'} }->{'avg'};
			push @members, $m;
		}

		# focus the next group of offspring around 2nd place
		if ( @members > 1 ) {
			my $two = $self->{'population'}->{ $members[1] };
			next unless $o--; $self->Elite( $two );
			next unless $o--; $self->WeightAdjust( $two );  
			next unless $o--; $self->WeightsAdjust( $two );  
			next unless $o--; $self->CrossoverAverage( $one, $two );  # only change ONE weight
			next unless $o--; $self->CrossoverRandom( $one, $two );  # only change ONE weight
			next unless $o--; $self->CrossoverRandom( $one, $two );  # only change ONE weight
		}

		# use this function for a weighted selection of 
		# who to act on
		sub Choose {
			my $self = shift;
			return $self->{'population'}->{ $_[int( rand() * @_ )] };
		}
		
		# for the rest of the offspring, do something at random
		while ( $o-- >= 1 ) {
			# 50% chance of just modifying an existing 
			if ( rand() < 0.5 ) {
				my $net = &Choose( $self, @members );
				my $r = rand();
				   if ( $r < 0.50 ) { $self->WeightsAdjust( $net ); }
			#	elsif ( $r < 0.80 ) { $self->WeightAdjust( $net ); }
				else                { $self->WeightsRandom( $net );  }
			} else {
			# crossover two
				my $one = &Choose( $self, @members );
				my $two = &Choose( $self, @members );
				if ( $one == $two ) {
					# crossover of an individual with itself is useless
					$o++;
					next;
				}
				if ( rand() < 0.5 ) { $self->CrossoverRandom( $one, $two ); }
				else                { $self->CrossoverAverage( $one, $two ); }
			}
		}
	}

	# if we have room left in the population
	# create a topological mutation
	$remaining = ( $self->{'settings'}->{'population'} 
				- scalar( keys %{$self->{'offspring'}} ) );
	my $active = scalar keys %active;
	if ( $remaining && $active < $self->{'settings'}->{'topology-limit'} ) {

		my $net;
		if ( rand() < 0.75 ) {
			# mutate the current champion network
			$net = $self->{'save'}->{'champion'};
		} else {
			# mutate some poor unsuspecting topology champion 
			my ( $which ) = RandomOrder( keys %{$self->{'topologies'}} );
			$net = $self->{'topologies'}->{$which}->{'champion'};
		}

		my $r = rand();
		   if ( $r < 0.05 ) { $self->ConnectionRemove( $net ); }
		elsif ( $r < 0.25 ) { $self->ConnectionSplit( $net );  }
		else                { $self->ConnectionAdd( $net );    }
	}

	# replace the current population with the offspring
	$self->{'population'} = $self->{'offspring'};
	delete $self->{'offspring'};
}
sub Activate
{
	my ( $self, $net, $values ) = @_;
	if ( ! exists( $net->{'topology'} ) ) {
		$self->AddTopology( NetworkTopology( $net ), $net );
	}
	my $func = $self->{'topologies'}->{ $net->{'topology'} }->{'func'};
	&$func( $net, $values );
}
sub Stats
{
	my $self = shift;
	my %seen;
	my $active = 0;
	my $best = 0;
	foreach my $net ( values %{$self->{'population'}} ) {
		$best = $net->{'fitness'} if ( $net->{'fitness'} > $best );
		next if exists $seen{$net->{'topology'}};
		$seen{$net->{'topology'}} = 1;
		$active++;
	}
	return sprintf( "%s: g%04d p%04d t%03d/%04d f%10.10f m%10.10f n%10.10f",
		$self->{'settings'}->{'experiment'},
		$self->{'save'}->{'generation'},
		scalar( keys %{$self->{'population'}} ),
		$active,
		scalar( keys %{$self->{'topologies'}} ),
		$self->{'save'}->{'max-fitness'},
		$self->{'save'}->{'max-weight'},
		$self->{'save'}->{'min-weight'} );
}
sub ChampionNetwork
{
	my $self = shift;
	return $self->{'save'}->{'champion'};
}
# private methods
sub UniqueID
{
	my $self = shift;
	return ++($self->{'save'}->{'unique-id'});
}
sub AddTopology
{
	my ( $self, $topology, $net ) = @_;
	# lookup id
	my ( $id, $n );
	if ( exists $self->{'topology-lookup'}->{$topology} ) {
		$id = $self->{'topology-lookup'}->{$topology};
	} else {
		$id = $self->UniqueID();
		$self->{'topology-lookup'}->{$topology} = $id;
	}

	# init topology record
	$net->{'topology'} = $id;
	if ( ! exists $self->{'topologies'}->{$id} ) {
		$self->{'topologies'}->{$id} = {
			'members' => [],
			'count' => 0,
			'total' => 0,
			'last' => 0,
			'avg' => 0,
			'best' => 0,
			'penalty' => 0,
			'offspring' => 0,
			};
	} else {
		# new blood, reduce any existing penalty
		my $t = $self->{'topologies'}->{$id};
		$t->{'penalty'} /= 2;
		# if was dead, resurrect the elite member
		if ( $t->{'offspring'} == 0 ) {
			$t->{'offspring'} = 2;
			# the one that was just 'created' and
			# the old topology champion/elite
			my $new = Copy( $t->{'champion'} );
			$new->{'elite'} = 1;
			$self->{'offspring'}->{ $new->{'id'} } = $new;
		}
	}
	# lookup and save the activation order
	my @order;
	ActivationOrder( $net, undef, \@order, {} );
	$self->{'topologies'}->{$id}->{'order'} = \@order;

	# identify any non-contributing nodes
	my %useless = $self->UselessNodes( $net );
	$self->{'topologies'}->{$id}->{'ignore'} = \%useless;

	# remove non-contributing nodes from the activation order
	$self->{'topologies'}->{$id}->{'order'} = [];
	foreach $n ( @order ) {
		push @{$self->{'topologies'}->{$id}->{'order'}}, $n
			if ( ! exists( $self->{'topologies'}->{$id}->{'ignore'}->{$n} ) );
	}

	# if using perl activation, add activation function
	if ( $self->{'settings'}->{'activation'} eq 'perl' 
	  && ! exists $self->{'topologies'}->{$id}->{'code'} ) {
		my $code = $self->ActivationFunction_Perl( $net );
		$self->{'topologies'}->{$id}->{'code'} = $code;
		eval "\$self->{'topologies'}->{'$id'}->{'func'} = $code;";
	}
}
sub UselessNodes
{
	my ( $self, $net ) = @_;
	my ( %input, %output, %useless );
	my @order;
	my ( $n, $c );

	@order = @{$self->{'topologies'}->{ $net->{'topology'} }->{'order'}};

	my @list;
	# start by finding all output nodes;
	foreach $n ( @order ) {
		next unless $self->{'nodes'}->{$n}->{'type'} eq 'output';
		push @list, $n;
		$output{$n} = 1;
	}
	# now find all nodes connected to an output node
	while ( @list ) {
		$n = shift @list;
		my @connections = keys %{$net->{'nodes'}->{$n}};
		while ( @connections ) {
			$c = shift @connections;
			next if exists $output{$c};
			$output{$c} = 1;
			push @list, $c;
		}
	}
	# now work the other way...find all input nodes
	@list = ();
	foreach $n ( @order ) {
		next unless $self->{'nodes'}->{$n}->{'type'} eq 'input';
		push @list, $n;
		$input{$n} = 1;
	}
	# now find all nodes connected to an input node
	my $count = 1;
	while ( $count ) {
		$count = 0;
		foreach $n ( @order ) {
			next if exists $input{$n};
			foreach $c ( keys %{$net->{'nodes'}->{$n}} ) {
				next unless exists $input{$c};
				$input{$n} = 1;
				$count++;
				last;
			}
		}
	}
	# all nodes that do not appear in both lists are useless
	foreach $n ( @order ) {
		if ( ! ( exists $input{$n} && exists $output{$n} ) ) {
			$useless{$n} = 1;
		}
	}
	return %useless;
}
sub AllocateOffspring
{
	my $self = shift;
	my $top;
	my ( $total, $temp, $count );
	my $penalty;

	# NOTE: Assumes that $self->Champions() called already

	# calculate a total population fitness adjusted for penalties
	$total = 0;
	foreach $top ( values %{$self->{'topologies'}} ) {
		# penalty is 0..100
		# avg fitness is reduced 1% for each penalty point
		$temp = $top->{'adj-avg'};
		$penalty = $temp * ( $top->{'penalty'} / 
							$self->{'settings'}->{'penalty'} )**10;
		$penalty = $temp if $penalty > $temp;
		$temp -= $penalty;
		$top->{'adjusted'} = $temp;
		$total += $temp;
	}

	# each is allocated offspring based on contribution to total
	$count = $self->{'settings'}->{'population'};
	if ( $total < 1 ) {
		my $offspring = $count / scalar keys %{$self->{'topologies'}};
		foreach $top ( values %{$self->{'topologies'}} ) {
			$top->{'offspring'} = $offspring;
		}
	} else {
		foreach $top ( values %{$self->{'topologies'}} ) {
#			if ( $top->{'total'} < 1 ) {
#				# keep it alive long enough to optimize
#				$top->{'offspring'} = 3;
#			} else {
				$top->{'offspring'} = $count * ( $top->{'adjusted'} / $total );
#			}
		} 
	}
}
sub AvailableConnections
{
	my ( $self, $net ) = @_;
	my $node;
	my $connection;
	my @nodes;
	my @list;
	# make a list of all possible NEW connections
	@nodes = keys %{$net->{'nodes'}};
	foreach $node ( @nodes ) {
		# omit input nodes, they can't have any dependencies
		next if $self->{'nodes'}->{$node}->{'type'} eq 'input';
		foreach $connection ( @nodes ) {
			next if exists( $net->{'nodes'}->{$node}->{$connection} );
			push @list, "${node}:${connection}";
		}
	}
	return RandomOrder( @list );
}
sub ActivationFunction_Perl
{
	my ( $self, $net ) = @_;
	my @nodes;
	@nodes = @{$self->{'topologies'}->{ $net->{'topology'} }->{'order'}};
	my $code = 'sub { my ( $n, $v ) = @_; ';
#			 . 'foreach my $node ( keys %{$n->{\'nodes\'}} ) '
#			 .  '{ $v->{$node} = 0 unless exists $v->{$node}; } ';
	foreach my $node ( @nodes ) {
		my @params;
		foreach my $dep ( sort keys %{$net->{'nodes'}->{$node}} ) {
			# make sure the node we depend on has dependancies,
			# or is an input node
			if ( $self->{'nodes'}->{$dep}->{'type'} eq 'input' 
			  || scalar( keys %{$net->{'nodes'}->{$dep}} ) ) {
				push @params, "(\$v->{'$dep'}*\$n->{'nodes'}->{'$node'}->{'$dep'})";
			}
		}
		if ( @params ) {
			$code .= "\$v->{'$node'} = " 
					. $self->{'nodes'}->{$node}->{'function'}
					. '( ' . join( '+', @params )
					. ", $self->{'nodes'}->{$node}->{'gain'} ); ";
		}
	}
	$code .= '}';
	return $code;
}
sub ActivationFunction_C_PartialEval
{
	# generates a C function that activates a specific network
	# with specific weights and some inputs, pre-calculating as much
	# of the calculations as humanly possible
	# 
	# as of right now, assumes there is only one output
	my ( $self, $net, $values ) = @_;
	
	my $code = '';
	my ( @nodes, @conn );
	my ( $n, $c );
	my $value = Copy( $values ); # don't want to modify the caller's data
	my $accum = {};

	# get the activation order
	@nodes = @{$self->{'topologies'}->{ $net->{'topology'} }->{'order'}};

	# initialize the node accumulators
	foreach $n ( @nodes ) {
		$accum->{$n} = 0;
	}

	# make a copy of the network so we can prune as we pre-calculate
	$net = Copy( $net );

	# pre-calculate the values of any nodes we can
	my $changes = 1;
	while ( $changes ) {
		$changes = 0;
		foreach $n ( @nodes ) {
			next if exists $value->{$n};
			next if $self->{'nodes'}->{$n}->{'type'} eq 'input';
			@conn = keys %{$net->{'nodes'}->{$n}};
			foreach $c ( @conn ) {
				next unless exists $value->{$c};
				$accum->{$n} += $value->{$c} * $net->{'nodes'}->{$n}->{$c};
				delete $net->{'nodes'}->{$n}->{$c};
			}
			# if the node is now complete, calculate its value
			if ( ! scalar( keys %{$net->{'nodes'}->{$n}} ) ) {
				$value->{$n} = eval(
					$self->{'nodes'}->{$n}->{'function'}
					. '( '
					. $accum->{$n}
					. ', '
					. $self->{'nodes'}->{$n}->{'gain'}
					. ');'
				);
				$changes++;
			}
		}
	}

	# make a list of inputs whose value is not passed in (variable)
	# don't need this right now, because the experiment defines the function prototype
=disabled
	my @inputs;
	foreach $n ( @nodes ) {
		next unless ( $self->{'nodes'}->{$n}->{'type'} eq 'input' );
		next if ( exists $values->{$n} );
		push @inputs, $n;
	}

	# if nothing ever changes, just die, but chastise the user first.
	if ( ! @inputs ) {
		printf( "you attempted to form code that calculates a network " .
				"that has no variable inputs.  What's the point?\n" );
		printf( join ",", @inputs );
		die;
	}
=cut

	##### Start of generated code #####
	$code .= "{\n";

	# declare the variables to hold the values of nodes
	my @vars;
	foreach $n ( @nodes ) {
		next if ( $value->{$n} );
		next if ( $self->{'nodes'}->{$n}->{'type'} eq 'input' );
		push @vars, $n;
	}
	$code .= 'double n_' . join( ",n_", @vars ) . ";\n";

	# perform the summation and sigmoid for every node
	foreach $n ( @vars ) {
		my @values;
		foreach $c ( keys %{$net->{'nodes'}->{$n}} ) {
			my $temp = "( ";
			# this should NEVER happen, but just in case...
			if ( exists $value->{$c} ) {
				$temp .= sprintf( "%55.55f", $value->{$c} );
			} else {
				$temp .= "n_$c";
			}
			$temp .= sprintf( " * %55.55f )\n", $net->{'nodes'}->{$n}->{$c} );
			push @values, $temp;
		}
		if ( @values ) {
			my $func = $self->{'nodes'}->{$n}->{'function'};
			if ( $func eq 'sigmoid' ) {
				$code .= 'n_' . $n . ' = 1/(1+exp( -1 * '
					. $self->{'nodes'}->{$n}->{'gain'} 
					. " * (\n" 
					. sprintf( "%55.55f\n+", $accum->{$n} );
				$code .= join "+", @values;
				$code .= ")));\n";
			} elsif ( $func eq 'sum' ) {
				$code .= 'n_' . $n . ' = '
					. sprintf( "%55.55f\n+", $accum->{$n} )
					. join( '+', @values )
					. ";\n";
			} else { die "What kind of activation function is $func?"; }
		}
	}
	# find and 'return' the output node value
	# start looking at the back, because that one SHOULD be it!
	my $found = 0;
	foreach $n ( reverse @vars ) {
		next unless $self->{'nodes'}->{$n}->{'type'} eq 'output';
		$found = 1;
		$code .= "return n_$n;\n}\n";
	}
#	if ( ! $found ) {
#		printf( "attempted to generate code for a network with no obvious output." .
#				"  That was dumb...  " );
#		die;
#	}
#	$net->{'code'} = $code;
	return $code;
}
# offspring producing methods
sub Elite
{
	my ( $self, $net ) = @_;
	# network is copied, unchanged
	my $new = Copy( $net );
	$new->{'elite'} = 1;
	$self->{'offspring'}->{ $new->{'id'} } = $new;
}
sub WeightAdjust
{
	my ( $self, $net ) = @_;
	my $new = Copy( $net );
	$new->{'id'} = $self->UniqueID();
	$new->{'elite'} = 0;
	
	# adjust ONE weight by up to 10 percent in either direction
	my @existing = ExistingConnections( $new );
	my $key = $existing[0];
	return if ( ! defined( $key ) );
	my ( $n, $c ) = split( ":", $key );
	$new->{'nodes'}->{$n}->{$c} = $self->NewWeight( $new->{'nodes'}->{$n}->{$c} );
	$self->{'offspring'}->{ $new->{'id'} } = $new;
}
sub WeightsAdjust
{
	my ( $self, $net ) = @_;
	my $new = Copy( $net );
	$new->{'id'} = $self->UniqueID();
	$new->{'elite'} = 0;
	
	# adjust each weight by up to 10 percent in either direction
	my ( $n, $c );
	foreach $n ( keys %{$new->{'nodes'}} ) {
		foreach $c ( keys %{$new->{'nodes'}->{$n}} ) {
			$new->{'nodes'}->{$n}->{$c} = 
				$self->NewWeight( $new->{'nodes'}->{$n}->{$c} );
		}
	}
	$self->{'offspring'}->{ $new->{'id'} } = $new;
}
sub WeightsRandom
{
	my ( $self, $net ) = @_;
	my $new = Copy( $net );
	$new->{'id'} = $self->UniqueID();
	$new->{'elite'} = 0;

	# give every connection a new weight, chosen at random
	my ( $n, $c );
	foreach $n ( keys %{$new->{'nodes'}} ) {
		foreach $c ( keys %{$new->{'nodes'}->{$n}} ) {
			$new->{'nodes'}->{$n}->{$c} = $self->NewWeight();
		}
	}
	$self->{'offspring'}->{ $new->{'id'} } = $new;
}
sub CrossoverAverage
{
	my ( $self, $one, $two ) = @_;
	my $new = Copy( $one );
	$new->{'id'} = $self->UniqueID();
	$new->{'elite'} = 0;

	# adjust weights to be the average of the two parents
	my ( $n, $c );
	foreach $n ( keys %{$new->{'nodes'}} ) {
		foreach $c ( keys %{$new->{'nodes'}->{$n}} ) {
			if ( exists $two->{'nodes'}->{$n}->{$c} ) {
				$new->{'nodes'}->{$n}->{$c} =  
					( $one->{'nodes'}->{$n}->{$c} 
					+ $two->{'nodes'}->{$n}->{$c} )
					/ 2;
			}
		}
	}
	$self->{'offspring'}->{ $new->{'id'} } = $new;
}
sub CrossoverRandom
{
	my ( $self, $one, $two ) = @_;
	my $new = Copy( $one );
	$new->{'id'} = $self->UniqueID();
	$new->{'elite'} = 0;

	# adjust each weight to be the same as one of the parents,
	# selected at random
	my ( $n, $c );
	foreach $n ( keys %{$new->{'nodes'}} ) {
		foreach $c ( keys %{$new->{'nodes'}->{$n}} ) {
			if ( exists $two->{'nodes'}->{$n}->{$c} 
			  && rand() < 0.5 ) {
				$new->{'nodes'}->{$n}->{$c} = $two->{'nodes'}->{$n}->{$c};
			}
		}
	}
	$self->{'offspring'}->{ $new->{'id'} } = $new;
}
sub ConnectionAdd
{
	my ( $self, $net ) = @_;
	my $id = $self->UniqueID();
	my $topology;
	my $new;
	my @available = $self->AvailableConnections( $net ); # randomized

	print STDERR "c ";

	do {
		$new = Copy( $net );
		$new->{'id'} = $id;
		$new->{'elite'} = 0;

		my ( $n, $c );
		my @nodes = keys %{$new->{'nodes'}};

		# if recurrency not allowed, find first non-recurrent 
		if ( ! $self->{'settings'}->{'allow-recurrent'} ) {
			my $found = 0;
			while ( @available && ! $found ) {
				( $n, $c ) = split( ":", $available[0] );
				if ( IsRecurrent( $new, $c, $n, 1 ) ) {
					shift @available;
				} else {
					$found = 1;
				}
			}
		}

		# if there is NOT one to be added, then split, instead.
		if ( ! defined( $available[0] ) ) {
			return $self->ConnectionSplit( $net );
		}
			
		( $n, $c ) = split ":", $available[0];
		$new->{'nodes'}->{$n}->{$c} = ( rand() - 0.5 ) * 2;
		$topology = NetworkTopology( $new );
		shift @available;
	} while ( exists $self->{'topology-lookup'}->{$topology} );
	$self->AddTopology( $topology, $new );
	$self->{'offspring'}->{ $new->{'id'} } = $new;
	print STDERR "+ ";
}
sub ConnectionRemove
{
	my ( $self, $net ) = @_;
	my $id = $self->UniqueID();
	my $new;
	my $topology;
	my ( $n, $c );
	my @existing = ExistingConnections( $net ); # randomized

	print STDERR "x ";
	do {
		return if ( ! defined( $existing[0] ) );
		$new = Copy( $net );
		$new->{'id'} = $id;
		$new->{'elite'} = 0;

		( $n, $c ) = split ":", $existing[0];
		delete $new->{'nodes'}->{$n}->{$c};
		$topology = NetworkTopology( $new );

		shift @existing;
	} while ( exists $self->{'topology-lookup'}->{$topology} );
	$self->AddTopology( $topology, $new );
	$self->{'offspring'}->{ $new->{'id'} } = $new;
	print STDERR "- ";
}
sub ConnectionSplit
{
	my ( $self, $net ) = @_;
	my $id = $self->UniqueID();
	my $new;
	my $topology;
	my $key;

	my ( $n, $c );
	my @existing = ExistingConnections( $net );
	
	print STDERR "n ";
	
	do {
		$key = $existing[0];  
		shift @existing;
		return unless defined $key;

		$new = Copy( $net );
		$new->{'id'} = $id;
		$new->{'elite'} = 0;

		if ( exists( $self->{'node-lookup'}->{$key} ) ) {
			# re-use old node ID
			$id = $self->{'node-lookup'}->{$key};
		} else {
			# make a new node ID
			$id = $self->UniqueID();
			$self->{'node-lookup'}->{$key} = $id;
			$self->{'nodes'}->{$id} = {
				'id' => $id,
				'type' => 'hidden',
				'function' => 'sigmoid',
				'gain' => $self->{'settings'}->{'gain'},
				'formed' => $key
				};
		}
		# identify endpoints of connection to split
		( $n, $c ) = split ":", $key;
		# make a connection between $n and the new node
		$new->{'nodes'}->{$n}->{$id} = $new->{'nodes'}->{$n}->{$c};
		# between the new and the old connection end point
		$new->{'nodes'}->{$id} = { $c => 1 };
		# delete the old connection
		delete $new->{'nodes'}->{$n}->{$c};
		# if there isn't a connection between the old node and the BIAS node
		# make one
		if ( ! exists $new->{'nodes'}->{$n}->{'bias'} ) {
			$new->{'nodes'}->{$n}->{'bias'} = 0;
		}
		# if there isn't a connection between the new node and the bias,
		# create one
		if ( ! exists $new->{'nodes'}->{$id}->{'bias'} ) {
			$new->{'nodes'}->{$id}->{'bias'} = 0;
		}
		$topology = NetworkTopology( $new );
	} while ( exists $self->{'topology-lookup'}->{$topology} );
	$self->AddTopology( $topology, $new );
	$self->{'offspring'}->{ $new->{'id'} } = $new;
	print STDERR "+ ";
}
# support functions
sub NewWeight
{
	my ( $self, $old ) = @_;
	my $new;
	if ( defined ( $old ) ) {
		# adjust up or down by up to 10 percent
		$new = $old + ( $old * ( ( rand() - 0.5 ) * 0.2 ) );
	} else {
		my $min = $self->{'save'}->{'min-weight'};
		my $range = $self->{'save'}->{'max-weight'} - $min;
		$new = ( rand() * $range ) + $min;
	}
	my $limit =	$self->{'settings'}->{'max-weight'};
	$new = $limit if ( $new > $limit );
	$limit *= -1;
	$new = $limit if ( $new < $limit );
	$self->{'save'}->{'max-weight'} = $new if ( $new > $self->{'save'}->{'max-weight'} );
	$self->{'save'}->{'min-weight'} = $new if ( $new < $self->{'save'}->{'min-weight'} );
	return $new;
}
sub LoadData
{
	my ( $file ) = @_;
	my $def;
	my $data;
	local $/; # load entire file at once
	open FILE, "<$file" or
		die "failed to open file for input:\n  $file\n Error: $!\n";
	$def = <FILE>;
	close FILE;
	eval $def;  # SHOULD set $data if saved via SaveData
	return $data;
}
sub SaveData
{
	my ( $data, $file ) = @_;
	open SAVE, ">$file" or 
		die "failed to open file for output:\n  $file\n Error: $!\n";
	$Data::Dumper::Indent = 1;
	print SAVE Data::Dumper->Dump( [$data], ["data"] );
	close SAVE;
}
sub Copy
{
	my $data = shift;
	my $copy;
	eval Data::Dumper->Dump( [$data], ["copy"] );
	return $copy;
}
sub RandomOrder
{
	my @list = @_;
	my ( $i, $j, $temp );

	for ( $i = 0 ; $i <= $#list ; $i++ ) {
		$j = int( rand() * @list );
		$temp = $list[$i];
		$list[$i] = $list[$j];
		$list[$j] = $temp;
	}
	return @list;
}
sub NetworkTopology
{
	my $net = shift;
	my $node;
	my $cx;
	my @nodes;
	my @connections;

	# make a list of nodes
	@nodes = sort keys %{$net->{'nodes'}};
	# make a list of connections
	foreach $node ( @nodes ) {
		foreach $cx ( keys %{$net->{'nodes'}->{$node}} ) {
			push @connections, "${node}:${cx}";
		}
	}
	# sort the connection list
	@connections = sort @connections;

	# return the topology string
	return "N=" . (join ",", @nodes) . ";" .
			"C=" . ( join ",", @connections);
}
sub ActivationOrder
{
	my ( $net, $node, $order, $seen ) = @_;
	if ( defined( $node ) ) {
		foreach my $next ( sort keys %{$net->{'nodes'}->{$node}} ) {
			if ( ! exists $seen->{$next} ) {
				$seen->{$next} = 1;
				ActivationOrder( $net, $next, $order, $seen );
			}
		}
		push @{$order}, $node;
	}
	else
	{
		foreach $node ( sort keys %{$net->{'nodes'}} ) {
			next if $seen->{$node};
			$seen->{$node} = 1;
			ActivationOrder( $net, $node, $order, $seen );
		}
	}
}
sub ExistingConnections
{
	my $net = shift;
	my $node;
	my $connection;
	my @list;
	# make a list of all existing connections
	foreach $node ( keys %{$net->{'nodes'}} ) {
		foreach $connection ( keys %{$net->{'nodes'}->{$node}} ) {
			push @list, "${node}:${connection}";
		}
	}
	return RandomOrder( @list );
}
sub IsRecurrent
{
	# %seen should only include ancestors, not siblings, in the tree
	my ( $net, $start, %seen ) = @_;

	return 1 if ( $seen{$start} ); # handles directly recurrent
	$seen{$start} = 1;
	my @list = keys %{$net->{'nodes'}->{$start}};
	my $n;
	foreach $n ( @list ) {
		return 1 if ( exists( $seen{$n} ) );
		return 1 if ( IsRecurrent( $net, $n, %seen ) );
	}
	return 0;
}
sub DebugOut
{
	printf( @_ ) if ( $DEBUG );
}
# activation functions
sub sigmoid
{
	my ( $x, $a ) = @_;
	return 1 / ( 1 + exp( - $a * $x ) );
}
sub sum
{
	my ( $x, $a ) = @_;
	return $x * $a;
}

1;