view release on metacpan or  search on metacpan

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

    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 {
        my ($interp) = @_;
        my $ip       = $interp->get_curip;
        my $critter = $$ip{_ai_critter};
        my $count    = $ip->svalue(1);
        return $ip->dir_reverse unless $critter->spend($critter->stackcost * $count);
        return Language::Befunge::Ops::block_open(@_);
    }

    # override op_flow_jump_to to impose skip count checking
    sub _op_flow_jump_to_wrap {
        my ($interp) = @_;
        my $ip       = $interp->get_curip;
        my $critter  = $$interp{_ai_critter};
        my $count    = $ip->svalue(1);
        return $ip->dir_reverse unless $critter->spend($critter->repeatcost * abs($count));
        return Language::Befunge::Ops::flow_jump_to(@_);
    }