#!/usr/bin/perl -w

# Based on ideas and code by Brad Murray (bjm@a2b01118.paralynx.bconne
+cted.net), 
# posted to perl-ai list June 3 1999.  Completed and maintained by Ken
# Williams (ken@forum.swarthmore.edu).

# VERSION: $Revision: 1.4 $

use strict;


my @functions = (
                 # Format is 'function <pretty version>: <actual code>
+'
                 'function add($a,$b): ($a+$b)',
                 'function mul($a,$b): ($a*$b)',
                 'function sin($a,$b): sin($a)',
                 'function log($a,$b): do{my $_a=$a; $_a ? log(abs($_a
+)) : 0}',
                );

my @terminals = (
                 sub {'$x'},
                 sub {'$x'},
                 sub { int(rand(20) - 10) },
                 sub { int(rand(20) - 10) },
                );

my $maxdepth = 5;
my $pop = 20;
my $mates = 5;
my $gen = 200;

# Get target data set
my @target = split ',', scalar <DATA>;

# Build a starting population of $pop Organisms
my @world = map {{organism => new Organism}} 1..$pop;

my $count = 0;
while ($count<$gen) {
  print "\nGENERATION ", ++$count, "\n";

  foreach (@world) {
    $_->{fitness} = &fitness($_->{organism},@target);
    $_->{as_string} = $_->{organism}->as_string;
  }

  @world = sort { 
             $a->{fitness} <=> $b->{fitness} 
                            or
    length $a->{as_string} <=> length $b->{as_string} 
  } @world;

  foreach (@world) {
    print "=================== Fitness: $_->{fitness} ================
+===\n";
    print $_->{as_string}, "\n";
  }

  # Kill off some organisms, mate some others to take their spots.  We
  # mate the top n organisms with random elements from the population.
  for (1..$mates) {
    pop @world;
    my ($org1, $org2) = ($world[$mates-1]{organism}, $world[rand @worl
+d]{organism});
    ($org1, $org2) = ($org2, $org1) if int rand 2; # Maybe switch role
+s
    my $child = $org1->mate($org2);
    unshift @world, {organism => $child};
    print "Created '@{[$child->as_string]}' from '@{[$org1->as_string]
+}' and '@{[$org2->as_string]}'\n";
  }

  # mutate one organism at random
  my $to_mutate = $world[rand @world]{organism};
  print "Mutated '@{[$to_mutate->as_string]}' into ";
  $to_mutate->mutate;
  print "'@{[$to_mutate->as_string]}'\n";

  # Uncomment if you want to watch each step
  #print "<RETURN> to continue:"; <STDIN>;
}

sub fitness {
  # Determine the fitness of an organism in this crazy world

  my ($org, @target) = @_;
  my $sumdiff = 0;

  foreach (0..$#target) {
    $sumdiff += abs($org->evaluate({'x'=>$_}) - $target[$_]);
  }
  return $sumdiff/@target;
}

#####################################################################
package Organism;
use Storable qw(dclone store);


# Syntax tree is a set of hash entries:
#  $node->{a} = $another_node or undef
#  $node->{b} = $another_node or undef
#  $node->{contents} = $function or 'x' or constant
#
# Example:
#  sin(7 * log($x))
# 
#  sin(multiply(7,log($x,0)),0)
#
#                  sin
#                 /   \
#                /     \
#        multiply       0--undef
#        /      \        \
#       7        log      undef
#      / \        / \
# undef  undef   x   0--undef
#               / \   \
#          undef   \   undef
#                 undef
#
# In Perl data structures:
# { contents => 'function sin($a,$b): sin($a)',
#   a        => {
#                contents => 'function mul($a,$b): ($a*$b)',
#                a        => 7,
#                b        => {
#                             contents => 'function log($a,$b): do{my 
+$_a=$a; $_a ? log(abs($_a)) : 0}',
#                             a        => '$x',
#                             b        => 0,
#                            },
#                },
#   b         => 0,
# }


sub new {
  my $package = shift;
  my $self = {tree => $package->_buildTree() };
  return bless $self, $package;
}

sub _buildTree {
  my $self = shift;
  my $depth = shift || 0;
  
  my %tree;

  $tree{contents} = ($depth > $maxdepth or int rand(3)) ?
                     &{$terminals[rand @terminals]} :
                     $functions[rand @functions];

  # 'a' and 'b' are the two arguments to functions
  if ($tree{contents} =~ /^function /) {
    $tree{'a'} = $self->_buildTree($depth + 1);
    $tree{'b'} = $self->_buildTree($depth + 1);
  }

  return \%tree;
}

sub _treeIndex {
  # Generates a list of all the nodes in this tree.  These are
  # references to the stuff in the object itself, so changes to the
  # elements of this list will change the object.

  my $self = shift;
  my $tree = shift || $self->{tree};
  my @sofar = @_;

  # Dump the content nodes into a list
  
  if ($tree->{contents} =~ /^function /) {
    return(@sofar, 
           $tree, 
           $self->_treeIndex($tree->{'a'}, @sofar), 
           $self->_treeIndex($tree->{'b'}, @sofar)
          );
  } else {
    return(@sofar, $tree);
  }
}

sub mate {
  my ($self, $partner) = @_;
  my $self_clone = dclone $self;

  # Get part of a node from $partner and stick it somewhere in $self_c
+lone
  my @clone_index = $self_clone->_treeIndex;
  my @partner_index = $partner->_treeIndex;

  %{ $clone_index[rand @clone_index] } = %{ dclone $partner_index[rand
+ @partner_index] };

  $self_clone->clear_cache;
  return $self_clone;
}

sub mutate {
  my $self = shift;

  my @index = $self->_treeIndex;
  %{ $index[rand @index] } = %{ $self->_buildTree($maxdepth-1) };
  $self->clear_cache;
}

sub evaluate {
  my $self = shift;
  my $params = shift;
  
  my $x = $params->{'x'};
  return eval $self->expression;
}


sub expression {  # Turn the syntax tree into a Perl expression
  my $self = shift;
  my $tree = shift || $self->{tree};

  # Check the cache
  return $self->{expr} if defined $self->{expr};

  local $_ = $tree->{contents}; # A shortcut for the current node

  if ( s/^function [^:]*: (.*)/$1/ ) { # Extract the perl expression
    s/\$([a-zA-Z]+)/$self->expression($tree->{$1})/ge;
  } 

  $self->{expr} = $_ if $tree eq $self->{tree}; # A nasty trick
  return $_;
}

sub as_string {  # Turn the syntax tree into a readable expression
  my $self = shift;
  my $tree = shift || $self->{tree};

  # Check the cache
  return $self->{string} if defined $self->{string};

  local $_ = $tree->{contents}; # A shortcut for the current node

  if ( s/^function ([^:]*):.*/$1/ ) { # Extract the format picture
    s/\$([a-zA-Z]+)/$self->as_string($tree->{$1})/ge;
  }

  $self->{string} = $_ if $tree eq $self->{tree}; # A nasty trick
  return $_;
}

sub clear_cache {
  # Invalidate the cached information.  Typically done after mutation
  # or mating, because the cache represents the old data.
  my $self = shift;
  $self->{expr} = $self->{string} = undef;
}


__END__
-1407,-931,-577,-327,-163,-67,-21,-7,-7,-3,23,89,213,413,707,1113,1649
[download]

Edit: Footpad, 3 Aug 2001 - 7:37 am (PDT)