view release on metacpan or  search on metacpan

lib/AI/Evolve/Befunge/Critter.pm  view on Meta::CPAN

package AI::Evolve::Befunge::Critter;
use strict;
use warnings;

use Language::Befunge;
use Language::Befunge::Storage::Generic::Vec;
use IO::File;
use Carp;
use Perl6::Export::Attrs;
use Scalar::Util qw(weaken);

use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors(
    # basic values
    qw{ boardsize codesize code color dims maxlen maxsize minsize },
    # token currency stuff
    qw{ tokens codecost itercost stackcost repeatcost threadcost },
    # other objects we manage
    qw{ blueprint physics interp }
);

use AI::Evolve::Befunge::Util;
use aliased 'AI::Evolve::Befunge::Critter::Result' => 'Result';

=head1 NAME

    AI::Evolve::Befunge::Critter - critter execution environment


=head1 DESCRIPTION

This module is where the actual execution of Befunge code occurs.  It
contains everything necessary to set up and run the code in a safe
(sandboxed) Befunge universe.

This universe contains the Befunge code (obviously), as well as the
current board game state (if any).  The Befunge code exists in the
negative vector space (with the origin at 0, Befunge code is below
zero on all axes).  Board game info, if any, exists as a square (or
hypercube) which starts at the origin.

The layout of befunge code space looks like this (for a 2d universe):

       |----------|         |
       |1         |         |
       |09876543210123456789|
    ---+--------------------+---
    -10|CCCCCCCCCC          |-10
     -9|CCCCCCCCCC|         | -9
     -8|CCCCCCCCCC          | -8
     -7|CCCCCCCCCC|         | -7
     -6|CCCCCCCCCC          | -6
     -5|CCCCCCCCCC|         | -5
     -4|CCCCCCCCCC          | -4
     -3|CCCCCCCCCC|         | -3
     -2|CCCCCCCCCC          | -2
     -1|CCCCCCCCCC|         | -1
    --0| - - - - -BBBB - - -|0--
      1|          BBBB      |  1
      2|          BBBB      |  2
      3|          BBBB      |  3
      4|                    |  4
      5|          |         |  5
      6|                    |  6
      7|          |         |  7
      8|                    |  8
      9|          |         |  9
    ---+--------------------+---
       |09876543210123456789|
       |1         |         |

lib/AI/Evolve/Befunge/Critter.pm  view on Meta::CPAN

         ||($$self{codesize}->get_component($dim) > $$self{boardsize}->get_component($dim))) {
            $maxpos->set_component($dim, $$self{codesize}->get_component($dim));
        } else {
            $maxpos->set_component($dim, $$self{boardsize}->get_component($dim));
        }
    }
    my $minpos = Language::Befunge::Vector->new_zeroes($$self{dims}) - $maxpos;
    my $maxlen = 0;
    foreach my $d (0..$$self{dims}-1) {
        my $this = $maxpos->get_component($d) - $minpos->get_component($d);
        $maxlen = $this if $this > $maxlen;
    }
    $$self{maxsize} = $maxpos;
    $$self{minsize} = $minpos;
    $$self{maxlen}  = $maxlen;

    my $interp = Language::Befunge::Interpreter->new({
        dims    => $$self{dims},
        storage => 'Language::Befunge::Storage::Generic::Vec'
    });
    $$self{interp} = $interp;
    $$self{codeoffset} = $minpos;
    my $cachename = "storagecache-".$$self{dims};
    if(exists($$self{blueprint}{cache})
    && exists($$self{blueprint}{cache}{$cachename})) {
        $$interp{storage} = $$self{blueprint}{cache}{$cachename}->_copy;
    } else {
        if($$self{dims} > 1) {
            # split code into lines, pages, etc as necessary.
            my @lines;
            my $meas = $$self{codesize}->get_component(0);
            my $dims = $$self{dims};
            my @terms = ("", "\n", "\f");
            push(@terms, "\0" x ($_-2)) for(3..$dims);

            push(@lines, substr($$self{code}, 0, $meas, "")) while length $$self{code};
            foreach my $dim (0..$dims-1) {
                my $offs = 1;
                $offs *= $meas for (1..$dim-1);
                for(my $i = $offs; $i <= scalar @lines; $i += $offs) {
                    $lines[$i-1] .= $terms[$dim];
                }
            }
            $$self{code} = join("", @lines);
        }

        $interp->get_storage->store($$self{code}, $$self{codeoffset});
        # assign our corral size to the befunge space
        $interp->get_storage->expand($$self{minsize});
        $interp->get_storage->expand($$self{maxsize});
        # save off a copy of this befunge space for later reuse
        $$self{blueprint}{cache} = {} unless exists $$self{blueprint}{cache};
        $$self{blueprint}{cache}{$cachename} = $interp->get_storage->_copy;
    }
    my $storage = $interp->get_storage;
    $$storage{maxsize} = $$self{maxsize};
    $$storage{minsize} = $$self{minsize};
    # store a copy of the Critter in the storage, so _expand (below) can adjust
    # the remaining tokens.
    $$storage{_ai_critter} = $self;
    weaken($$storage{_ai_critter});
    # store a copy of the Critter in the interp, so various command callbacks
    # (below) can adjust the remaining tokens.
    $$interp{_ai_critter} = $self;
    weaken($$interp{_ai_critter});

    $interp->get_ops->{'{'} = \&AI::Evolve::Befunge::Critter::_block_open;
    $interp->get_ops->{'j'} = \&AI::Evolve::Befunge::Critter::_op_flow_jump_to_wrap;
    $interp->get_ops->{'k'} = \&AI::Evolve::Befunge::Critter::_op_flow_repeat_wrap;
    $interp->get_ops->{'t'} = \&AI::Evolve::Befunge::Critter::_op_spawn_ip_wrap;

    my @invalid_meths = (',','.','&','~','i','o','=','(',')',map { chr } (ord('A')..ord('Z')));
    $$self{interp}{ops}{$_} = $$self{interp}{ops}{r} foreach @invalid_meths;

    if(exists($args{Commands})) {
        foreach my $command (sort keys %{$args{Commands}}) {
            my $cb = $args{Commands}{$command};
            $$self{interp}{ops}{$command} = $cb;
        }
    }


    my @params;
    my @vectors;
    push(@vectors, $$self{boardsize}) if exists $$self{boardsize};
    push(@vectors, $$self{maxsize}, $$self{codesize});
    foreach my $vec (@vectors) {
        push(@params, $vec->get_all_components());
        push(@params, 1) for($vec->get_dims()+1..$$self{dims});
    }
    push(@params, $$self{threadcost}, $$self{stackcost}, $$self{repeatcost}, 
         $$self{itercost}, $$self{tokens}, $$self{dims});
    push(@params, $self->physics->token) if defined $self->physics->token;

    $$self{interp}->set_params([@params]);

    return $self;
}


=head1 METHODS

=head2 invoke

    my $rv = $critter->invoke($board);
    my $rv = $critter->invoke();

Run through a life cycle.  If a board is specified, the board state
is copied into the appropriate place before execution begins.

This should be run within an "eval"; if the critter causes an
exception, it will kill this function.  It is commonly invoked by
L</move> (see below), which handles exceptions properly.

=cut

sub invoke {
    my ($self, $board) = @_;
    delete($$self{move});
    $self->populate($board) if defined $board;
    my $rv = Result->new(name => $self->blueprint->name);
    my $initial_ip = Language::Befunge::IP->new($$self{dims});
    $initial_ip->set_position($$self{codeoffset});
    my $interp = $self->interp;
    push(@{$initial_ip->get_toss}, @{$interp->get_params});
    $interp->set_ips([$initial_ip]);
    while($self->tokens > 0) {
        my $ip = shift @{$interp->get_ips()};
        unless(defined($ip)) {
            my @ips = @{$interp->get_newips};
            last unless scalar @ips;
            $ip = shift @ips;
            $interp->set_ips([@ips]);
        }
        unless(defined $$ip{_ai_critter}) {
            $$ip{_ai_critter} = $self;
            weaken($$ip{_ai_critter});
        }
        last unless $self->spend($self->itercost);
        $interp->set_curip($ip);
        $interp->process_ip();
        if(defined($$self{move})) {
            debug("move made: " . $$self{move} . "\n");
            $rv->choice( $$self{move} );
            return $rv;
        }
    }
    debug("play timeout\n");
    return $rv;
}


=head2 move

    my $rv = $critter->move($board, $score);

Similar to invoke(), above.  This function wraps invoke() in an
eval block, updates a scoreboard afterwards, and creates a "dead"
return value if the eval failed.

=cut

sub move {
    my ($self, $board) = @_;
    my $rv;
    local $@ = '';
    eval {
        $rv = $self->invoke($board);
    };
    if($@ ne '') {
        debug("eval error $@\n");
        $rv = Result->new(name => $self->blueprint->name, died => 1);
        my $reason = $@;
        chomp $reason;
        $rv->fate($reason);
    }
    $rv->tokens($self->tokens);
    return $rv;
}


=head2 populate

    $critter->populate($board);

Writes the board game state into the Befunge universe.

=cut

sub populate {
    my ($self, $board) = @_;
    my $storage = $$self{interp}->get_storage;
    $storage->store($board->as_string);
    $$self{interp}{_ai_board} = $board;
    weaken($$self{interp}{_ai_board});
}


=head2 spend

    return unless $critter->spend($tokens * $cost);

Attempts to spend a certain amount of the critter's tokens.  Returns
true on success, false on failure.

=cut

sub spend {
    my ($self, $cost) = @_;
    $cost = int($cost);
    my $tokens = $self->tokens - $cost;
    #debug("spend: cost=$cost resulting tokens=$tokens\n");
    return 0 if $tokens < 0;
    $self->tokens($tokens);
    return 1;
}


# sandboxing stuff
{
    no warnings 'redefine';

    # override Storage->expand() to impose bounds checking
    my $_lbsgv_expand;
    BEGIN { $_lbsgv_expand = \&Language::Befunge::Storage::Generic::Vec::expand; };
    sub _expand {
        my ($storage, $v) = @_;
        if(exists($$storage{maxsize})) {
            my $min = $$storage{minsize};
            my $max = $$storage{maxsize};
            die "$v is out of bounds [$min,$max]!\n"
                unless $v->bounds_check($min, $max);
        }
        my $rv = &$_lbsgv_expand(@_);
        return $rv;
    }
    # redundant assignment avoids a "possible typo" warning
    *Language::Befunge::Storage::Generic::Vec::XS::expand = \&_expand;
    *Language::Befunge::Storage::Generic::Vec::XS::expand = \&_expand;
    *Language::Befunge::Storage::Generic::Vec::expand     = \&_expand;

    # override IP->spush() to impose stack size checking
    my $_lbip_spush;
    BEGIN { $_lbip_spush = \&Language::Befunge::IP::spush; };
    sub _spush {
        my ($ip, @newvals) = @_;
        my $critter = $$ip{_ai_critter};
        return $ip->dir_reverse unless $critter->spend($critter->stackcost * scalar @newvals);
        my $rv = &$_lbip_spush(@_);
        return $rv;
    }
    *Language::Befunge::IP::spush = \&_spush;

    # override IP->ss_create() to impose stack count checking
    sub _block_open {