view release on metacpan or  search on metacpan

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

                Befunge character that should call them.
    board_size: A Vector denoting the size of a game's board.  This
                field is optional; non-game plugins should leave it
                unspecified.


=cut

{ my %rules;

    sub register_physics :Export(:DEFAULT) {
        my %args = @_;
        croak("no name given")      unless exists $args{name};
        croak("Physics plugin '".$args{name}."' already registered!\n") if exists($rules{$args{name}});
        $rules{$args{name}} = \%args;
    }


=head2 find_physics

    my $physics = find_physics($name);

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');