view release on metacpan or  search on metacpan

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

=head1 STANDALONE FUNCTIONS

=head2 register_physics

    register_physics(
        name       => "ttt",
        token      => ord('T'),
        decorate   => 0.
        board_size => Language::Befunge::Vector->new(3, 3),
        commands   => { M => \&AI::Evolve::Befunge::Physics::op_board_make_move },
    );

Create a new physics plugin, and register it with the Physics plugin
database.  The "name" passed here can be used later on in ->new()
(see below) to fetch an instance of that physics plugin.

The arguments are:

    name:       The name of the Physics module.  Used by Physics->new
                to fetch the right plugin.
    token:      A unique numeric token representing this Physics
                plugin.  It is possible that a Critter could evolve
                that can function usefully in more than one universe;
                this token is pushed onto its initial stack in order
                to encourage this.
    decorate:   Used by graphical frontends.  If non-zero, the
                graphical frontend will use special icons to indicate
                spaces where a player may move.
    commands:   A hash of op callback functions, indexed on the
                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');
                    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();
    $rv1->score($self->score($board, $critter1->color, $moves));
    $rv2->score($self->score($board, $critter2->color, $moves));
    return $self->compare($rv1, $rv2);
}


=head2 compare

    $rv = $physics->compare($rv1, $rv2);

Given two return values (as loaded up by the L</run_board_game>
method, above), return a comparison value for the critters they belong
to.  This is essentially a "$critter1 <=> $critter2" comparison; a
return value below 0 indicates that critter1 is the lesser of the two
critters, and a return value above 0 indicates that critter1 is the
greater of the two critters.  The following criteria will be used for
comparison, in decreasing order of precedence:

=over 4

=item The one that won

=item The one that didn't die

=item The one that scored higher

=item The one that made more moves

=item The one that had more tokens afterwards