view release on metacpan or  search on metacpan

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

    }

    $$self{color} = $args{Color};
    croak "Color must be greater than 0" unless $$self{color} > 0;
    $$self{physics} = $args{Physics};
    croak "Physics must be a reference" unless ref($$self{physics});
    
    # set up our corral to be twice the size of our code or our board, whichever
    # is bigger.
    my $maxpos = Language::Befunge::Vector->new_zeroes($$self{dims});
    foreach my $dim (0..$$self{dims}-1) {
        if(!exists($$self{boardsize})
         ||($$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) = @_;

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

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(@_);
    }

    # override op_flow_repeat to impose loop count checking
    sub _op_flow_repeat_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_repeat(@_);
    }

    # override op_spawn_ip to impose thread count checking
    sub _op_spawn_ip_wrap {
        my ($interp) = @_;
        my $ip       = $interp->get_curip;
        my $critter  = $$interp{_ai_critter};
        my $cost     = 0;$critter->threadcost;
        foreach my $stack ($ip->get_toss(), @{$ip->get_ss}) {
            $cost   += scalar @$stack;
        }
        $cost       *= $critter->stackcost;
        $cost       += $critter->threadcost;
        return $ip->dir_reverse unless $critter->spend($cost);
        # This is a hack; Storable can't deep copy our data structure.
        # It will get re-added to both parent and child, next time around.
        delete($$ip{_ai_critter});
        return Language::Befunge::Ops::spawn_ip(@_);
    }