view release on metacpan or  search on metacpan

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

=cut

sub new {
    my $package = shift;
    my %args = (
        # defaults
        Color       => 1,
        @_
    );
    # args
    my $usage = 
      "Usage: $package->new(Blueprint => \$blueprint, Physics => \$physics,\n"
     ."                     Tokens => 2000, BoardSize => \$vector, Config => \$config)";
    croak $usage unless exists  $args{Config};
    $args{Tokens}     = $args{Config}->config('tokens'     , 2000) unless defined $args{Tokens};
    $args{CodeCost}   = $args{Config}->config("code_cost"  , 1   ) unless defined $args{CodeCost};
    $args{IterCost}   = $args{Config}->config("iter_cost"  , 2   ) unless defined $args{IterCost};
    $args{RepeatCost} = $args{Config}->config("repeat_cost", 1   ) unless defined $args{RepeatCost};
    $args{StackCost}  = $args{Config}->config("stack_cost" , 1   ) unless defined $args{StackCost};
    $args{ThreadCost} = $args{Config}->config("thread_cost", 10  ) unless defined $args{ThreadCost};

    croak $usage unless exists  $args{Blueprint};
    croak $usage unless exists  $args{Physics};
    croak $usage unless defined $args{Color};

    my $codelen = 1;
    foreach my $d ($args{Blueprint}->size->get_all_components) {
        $codelen *= $d;
    }
    croak "CodeCost must be greater than 0!"   unless $args{CodeCost}   > 0;
    croak "IterCost must be greater than 0!"   unless $args{IterCost}   > 0;
    croak "RepeatCost must be greater than 0!" unless $args{RepeatCost} > 0;
    croak "StackCost must be greater than 0!"  unless $args{StackCost}  > 0;
    croak "ThreadCost must be greater than 0!" unless $args{ThreadCost} > 0;
    $args{Tokens} -= ($codelen * $args{CodeCost});
    croak "Tokens must exceed the code size!"  unless $args{Tokens}     > 0;
    croak "Code must be freeform!  (no newlines)"
        if $args{Blueprint}->code =~ /\n/;

    my $self = bless({}, $package);
    $$self{blueprint}  = $args{Blueprint};
    $$self{boardsize}  = $args{BoardSize} if exists $args{BoardSize};
    $$self{code}       = $$self{blueprint}->code;
    $$self{codecost}   = $args{CodeCost};
    $$self{codesize}   = $$self{blueprint}->size;
    $$self{config}     = $args{Config};
    $$self{dims}       = $$self{codesize}->get_dims();
    $$self{itercost}   = $args{IterCost};
    $$self{repeatcost} = $args{RepeatCost};
    $$self{stackcost}  = $args{StackCost};
    $$self{threadcost} = $args{ThreadCost};
    $$self{tokens}     = $args{Tokens};
    if(exists($$self{boardsize})) {
        $$self{dims} = $$self{boardsize}->get_dims()
            if($$self{dims} < $$self{boardsize}->get_dims());
    }
    if($$self{codesize}->get_dims() < $$self{dims}) {
        # upgrade codesize (keep it hypercubical)
        $$self{codesize} = Language::Befunge::Vector->new(
            $$self{codesize}->get_all_components(),
            map { $$self{codesize}->get_component(0) }
                (1..$$self{dims}-$$self{codesize}->get_dims())
        );
    }
    if(exists($$self{boardsize})) {
        if($$self{boardsize}->get_dims() < $$self{dims}) {
            # upgrade boardsize
            $$self{boardsize} = Language::Befunge::Vector->new(
                $$self{boardsize}->get_all_components(),
                map { 1 } (1..$$self{dims}-$$self{boardsize}->get_dims())
            );
        }
    }

    $$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) = @_;
    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;