view release on metacpan or  search on metacpan

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

Find a physics plugin in the database.  Note that this is for internal
use; external users should use ->new(), below.

=cut

    sub find_physics {
        my $name = shift;
        return undef unless exists $rules{$name};
        return $rules{$name};
    }

}


=head1 CONSTRUCTOR

=head2 new

    my $physics = Physics->new('ttt');

Fetch a class instance for the given physics engine.  The argument
passed should be the name of a physics engine... for instance, 'ttt'
or 'othello'.  The physics plugin should be in a namespace under
'AI::Evolve::Befunge::Physics'... the module will be loaded if
necessary.

=cut

sub new {
    my ($package, $physics) = @_;
    my $usage = 'Usage: Physics->new($physicsname);';
    croak($usage) unless defined($package);
    croak($usage) unless defined($physics);
    my $module = 'AI::Evolve::Befunge::Physics::' . $physics;
    $module->require;
    my $rv = find_physics($physics);
    croak("no such physics module found") unless defined $rv;
    $rv = {%$rv}; # copy of the original object
    return bless($rv, $module);
}


=head1 METHODS

Once you have obtained a class instance by calling ->new(), you may
call the following methods on that instance.

=head2 run_board_game

    my $score = $physics->run_board_game([$critter1,$critter2],$board);

Run the two critters repeatedly, so that they can make moves in a
board game.

A score value is returned.  If a number greater than 0 is returned,
the critter wins.  If a number less than 0 is returned, the critter
loses.

The score value is derived in one of several ways... first priority
is to bias toward a creature which won the game, second is to bias
toward a creature who did not die (when the other did), third,
the physics plugin is asked to score the creatures based on the moves
they made, and finally, a choice is made based on the number of
resources each critter consumed.


=cut

sub run_board_game {
    my ($self, $aref, $board) = @_;
    my $usage = 'Usage: $physics->run_board_game([$critter1, $critter2], $board)';
    croak($usage) unless ref($self) =~ /^AI::Evolve::Befunge::Physics/;
    croak($usage) unless ref($board) eq 'AI::Evolve::Befunge::Board';
    my ($critter1, $critter2) = @$aref;
    croak($usage) unless ref($critter1) eq 'AI::Evolve::Befunge::Critter';
    croak($usage) unless ref($critter2) eq 'AI::Evolve::Befunge::Critter';
    croak($usage) if @$aref != 2;
    croak($usage) if @_ > 3;
    my $moves = 1;
    $self->setup_board($board);
    my @orig_players = ({critter => $critter1, stats => {pass => 0}},
                   {critter => $critter2, stats => {pass => 0}});
    my @players = @orig_players;
    # create a dummy Result object, just in case the loop never gets to player2
    # (because player1 died on the first move).
    $players[1]{rv} = Result->new(name => $critter2->blueprint->name, tokens => $critter2->tokens);
    while(!$self->over($board)) {
        my $rv = $players[0]{rv} = $players[0]{critter}->move($board, $players[0]{stats});
        my $move = $rv->choice();
        undef $move unless ref($move) eq 'Language::Befunge::Vector';
        if(!defined($move)) {
            if($self->can_pass($board,$players[0]{critter}->color())) {
                $players[0]{rv}->moves($moves);
            } else {
                if($rv->died) {
                    verbose("player ", $players[0]{critter}->color(), " died.\n");
                } else {
                    $rv->died(0.5);
                    $rv->fate('conceded');
                    verbose("player ", $players[0]{critter}->color(), " conceded.\n");
                }
                last;
            }
        }
        $moves++;
        $self->make_move($board, $players[0]{critter}->color(), $move) if defined $move;
        # swap players
        my $player = shift @players;
        push(@players,$player);
    }

    $board->output() unless get_quiet();

    # tally up the results to feed to compare(), below.
    my ($rv1   , $rv2   ) = ($orig_players[0]{rv}   , $orig_players[1]{rv}   );
    my ($stats1, $stats2) = ($orig_players[0]{stats}, $orig_players[1]{stats});
    $rv1->stats($stats1);
    $rv2->stats($stats2);
    $rv1->won(1) if $self->won($board) == $critter1->color();
    $rv2->won(1) if $self->won($board) == $critter2->color();

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

=item The one with a greater (asciibetical) name

=back

=cut

# This is essentially a big $critter1 <=> $critter2 comparator.
sub compare {
    my ($self, $rv1, $rv2) = @_;
    my $rv;
    $rv = ($rv1->won()    <=> $rv2->won()   )*32; #    prefer more winning
    $rv = ($rv1->score()  <=> $rv2->score() )*16  # or prefer more scoring
        unless $rv;
    $rv = ($rv1->moves()  <=> $rv2->moves() )*8   # or prefer more moves
        unless $rv;
    $rv = ($rv1->tokens() <=> $rv2->tokens())*4   # or prefer more tokens
        unless $rv;
    $rv = ($rv2->died()   <=> $rv1->died()  )*2   # or prefer less dying
        unless $rv;
    $rv = ($rv2->name()   cmp $rv1->name()  )*1   # or prefer quieter names
        unless $rv;
    return $rv;
}


=head2 setup_and_run_board_game

    my $score = $physics->setup_and_run_board_game($bp1, $bp2);

Creates Critter objects from the given Blueprint objects, creates a
game board (with board_size as determined from the physics plugin),
and calls run_board_game, above.

=cut

sub setup_and_run_board_game {
    my ($self, $config, $bp1, $bp2) = @_;
    my $usage = '...->setup_and_run($config, $blueprint1, $blueprint2)';
    croak($usage) unless ref($config) eq 'AI::Evolve::Befunge::Util::Config';
    croak($usage) unless ref($bp1)    eq 'AI::Evolve::Befunge::Blueprint';
    croak($usage) unless ref($bp2)    eq 'AI::Evolve::Befunge::Blueprint';
    my @extra_args;
    push(@extra_args, Config    => $config);
    push(@extra_args, Physics   => $self);
    push(@extra_args, Commands  => $$self{commands});
    push(@extra_args, BoardSize => $self->board_size);
    my $board = Board->new(Size => $self->board_size);
    my $critter1 = Critter->new(Blueprint => $bp1, Color => 1, @extra_args);
    my $critter2 = Critter->new(Blueprint => $bp2, Color => 2, @extra_args);

    return $self->run_board_game([$critter1,$critter2], $board);
}


=head2 double_match

    my $relative_score = $physics->double_match($bp1, $bp2);

Runs two board games; one with bp1 starting first, and again with
bp2 starting first.  The second result is subtracted from the first,
and the result is returned.  This represents a qualitative comparison
between the two creatures.  This can be used as a return value for
mergesort or qsort.

=cut

sub double_match :Export(:DEFAULT) {
    my ($self, $config, $bp1, $bp2) = @_;
    my $usage = '...->double_match($config, $blueprint1, $blueprint2)';
    croak($usage) unless ref($config) eq 'AI::Evolve::Befunge::Util::Config';
    croak($usage) unless ref($bp1)    eq 'AI::Evolve::Befunge::Blueprint';
    croak($usage) unless ref($bp2)    eq 'AI::Evolve::Befunge::Blueprint';
    my ($data1, $data2);
    $data1 = $self->setup_and_run_board_game($config,$bp1,$bp2);
    $data2 = $self->setup_and_run_board_game($config,$bp2,$bp1);
    return ($data1 - $data2) <=> 0;
}


=head1 COMMAND CALLBACKS

These functions are intended for use as Befunge opcode handlers, and
are used by the Physics plugin modules.

=head2 op_make_board_move

    01M

Pops a vector (of the appropriate dimensions for the given board, not
necessarily the same as the codesize) from the stack, and attempts
to make that "move".  This is for Physics engines which represent
board games.

=cut

sub op_make_board_move {
    my ($interp)= @_;
    my $critter = $$interp{_ai_critter};
    my $board   = $$interp{_ai_board};
    my $color   = $$critter{color};
    my $physics = $$critter{physics};
    my $vec     = v($interp->get_curip->spop_mult($board->size->get_dims()));
    return Language::Befunge::Ops::dir_reverse(@_)
        unless $physics->valid_move($board, $color, $vec);
    $$critter{move} = $vec;
}

=head2 op_query_tokens

    T

Query the number of remaining tokens.

=cut

sub op_query_tokens {
    my ($interp)= @_;
    my $critter = $$interp{_ai_critter};
    $interp->get_curip->spush($critter->tokens);
}