File Coverage

blib/lib/Games/Perlwar.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Games::Perlwar;

our $VERSION = '0.03';

use strict;
use warnings;
use utf8;

use Safe;
use XML::Simple;
use XML::Writer;
use XML::LibXML;
use IO::File;

use Games::Perlwar::Array;
use Games::Perlwar::Cell;
use Games::Perlwar::AgentEval;

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub new {
    my( $class, $dir ) = @_;
    my $self = { dir => $dir || '.', interactive => 1 };
    chdir $self->{dir};
    bless $self, $class;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub clear_log {
	my $self = shift;
	$self->{log} = ();
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub load_players_from_config {
    my( $self, $config ) = @_;

    my %player;
    for my $player ( $config->findnodes( '/configuration/players/player' ) ) {
        my $name   = $player->findvalue( '@name' );
        my $color  = $player->findvalue( '@color' );
        my $status = $player->findvalue( '@status' ) || 'OK' ;

        $player{ $name } = { color => $color, status => $status };
    }

    return %player;
}

sub load_players_from_iteration {
    my( $self, $iter ) = @_;

    my %player;
    for my $player ( $iter->findnodes( '/iteration/summary/player' ) ) {
        my $name   = $player->findvalue( '@name' );
        my $color  = $player->findvalue( '@color' );
        my $status = $player->findvalue( '@status' ) || 'OK' ;

        $player{ $name } = { color => $color, status => $status };
    }

    return %player;
}

sub load_players_adhoc {
    my( $self, $config ) = @_;

    my $community_file = $config->findvalue(
                            '/configuration/players/@community' );
    my @players = XML::LibXML->new
                             ->parse_file( $community_file )
                             ->findnodes( '//player' );

    @players = grep { -e 'mobil/'.$_->findvalue('@name') } @players;

    my %player;
    for my $player ( @players ) {
        my $name   = $player->findvalue( '@name' );
        my $color  = $player->findvalue( '@color' );
        my $status = 'OK' ;

        $player{ $name } = { color => $color, status => $status };
    }

    return %player;
}

sub load {
    my ( $self, $iteration, $replay ) = @_;

    # if it's a replay, we load from the current iteration,
    # then get the newcomers from the next iteration.
    # if not, we get the newcomers from mobil station
    # the loading of newcomers must happen in
    # run_iteration


	print "loading configuration.. \n";

    my $parser = XML::LibXML->new;

    my $config = $parser->parse_file( 'configuration.xml' );

    $self->{replay} = $replay;

    my $filename;
    if ( defined $iteration ) {
        $filename = sprintf( "round_%05d.xml", $iteration );
        die "can't load iteration $iteration\n"
            unless -e $filename;
    }
    else {
        $filename = 'round_current.xml';
    }
    my $current_iteration = $parser->parse_file( $filename );

	$self->{round} = $current_iteration->findvalue( '/iteration/@nbr' );
	print "loading iteration $self->{round}\n";

    $self->{conf}{gameLength} =
        $config->findvalue( '/configuration/gameLength/text()' );
    $self->{gameVariant} =
        $config->findvalue( '/configuration/gameVariant/text()' );
    $self->{conf}{agentMaxSize} =
        $config->findvalue( '/configuration/agentMaxSize/text()' );

    $self->{conf}{theArraySize} =
        $config->findvalue( '/configuration/theArraySize/text()' );
	$self->{theArray} = Games::Perlwar::Array->new({
                            size => $self->{conf}{theArraySize} });
    $self->{theArray}->load_from_xml( $current_iteration );

    if ( $self->{round} == 0 ) {

        $self->{conf}{player} = {
            $config->findvalue( '//players/@list' ) eq 'predefined'
                ?  $self->load_players_from_config( $config )
                :  $self->load_players_adhoc( $config )
        };
    }
    else {
        $self->{conf}{player} = { $self->load_players_from_iteration(
                                                    $current_iteration ) };
    }

    $self->set_game_status(
        $current_iteration->findvalue( '/iteration/summary/status' )
            || 'ongoing' );
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub visit_mobil_station {
    my $self = shift;

    $self->{newcomers} = [];
    chdir 'mobil';

    opendir my $dir, '.' or die "couldn't open dir mobil: $!\n";
    my @files = sort { -M $b <=> -M $a }
                grep { exists $self->{conf}{player}{$_} }
                     readdir $dir;
    closedir $dir;

    my @newcomers;
    for my $player ( @files ) {
        my $date = localtime( $^T - (-M $player)*24*60*60 );

        my $fh;
        my $code;
        {
            undef $/;
            open $fh, $player or die;
            $code = <$fh>;
            close $fh;
        }

        unlink $player or $self->log( "ERROR: $!" );

        push @newcomers, [ $player, $date, $code  ];
    }

    chdir '..';

    return @newcomers;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub get_game_status {
    return $_[0]->{conf}{gameStatus};
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub set_game_status {
    return $_[0]->{conf}{gameStatus} = $_[1];
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub play_round
{
	my $self = shift;

	# check if the game is over (because a player won)
	if( $self->get_game_status eq 'over' ) {
		print "game is already over, exiting\n";
		return;
	}

    $self->{round}++;

	$self->{log} = [];
	$self->log( localtime() . " : running round ".$self->{round} );

	# import newcomers
	$self->log( "train arriving from Station Mobil.." );
	$self->introduce_newcomers;

	# check if players are eliminated
	$self->checkForEliminatedPlayers;

	# run each slot
	$self->log( "running the Array.." );
    $self->runSlot( $_ ) for 0..$self->{conf}{theArraySize}-1;

    # end of round checks
    $self->{theArray}->reset_operational;

	# check for victory
    $self->agent_census;

    my @survivors;
    for my $p ( keys %{$self->{conf}{player}} ) {
        if ( $self->{conf}{player}{$p}{agents} ) {
            push @survivors, $p;
        }
        else {
            $self->{conf}{player}{$p}{status} = 'EOT';
        }
    }

    if ( @survivors > 1 ) {
        print scalar( @survivors ),
            " players still have agents on the field\n";
    } else {
        print @survivors ? "only $survivors[0] left!\n"
                        : "no survivor!\n";
        # TODO update the config w/ victory
        $self->set_game_status( 'over' );
    }

	# check if the game is over (because round > game length)
    $self->endtime_reached if $self->{round} >= $self->{conf}{gameLength};

    $self->save;
    delete $self->{newcomers};
    delete $self->{old_iteration};
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub endtime_reached {
    my $self = shift;

    print "number of rounds limit reached, game is over\n";
    $self->set_game_status( 'over' );

    my $player = $self->{conf}{player};

    my %census = $self->agent_census;

    my @k = reverse sort { $census{$a} <=> $census{$b} }
                    grep { $player->{status} == 'OK' } keys %$player;

    return unless @k;

    $player->{ shift @k }{status} = 'w1nn3r';
    $player->{$_}{status} = 'EOT' for @k;

    return;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub save
{
	my $self = shift;

	print "saving round $self->{round}..\n";

	#$self->saveConfiguration;

	#XMLout( $self->{conf}, OutputFile => "configuration.xml", RootName => 'configuration' );


	my $output = new IO::File(">round_current.xml");
	my $writer = new XML::Writer(OUTPUT => $output);

	$writer->startTag( "iteration", nbr => $self->{round} );

    $writer->startTag( 'summary' );
    $writer->dataElement( 'status' =>  $self->get_game_status );

    my %census = $self->agent_census;

    for my $p ( keys %{$self->{conf}{player} } ) {
        $writer->emptyTag( 'player',
            name   => $p,
            status => $self->{conf}{player}{$p}{status},
            color  => $self->{conf}{player}{$p}{color},
            agents => $census{ $p },
        );
    }

    $writer->endTag( 'summary' );

	if( $self->{newcomers} )
	{
		$writer->startTag( 'newcomers' );

		for( @{$self->{newcomers}} )
		{
			my @x = @$_;
			$writer->dataElement( 'newcomer', $x[2], player => $x[0], time => $x[1] );
		}
		$writer->endTag;
	}


	if( $self->{log} )
	{
  		$writer->startTag( 'log' );
  		$writer->dataElement( 'entry', $_ ) for @{$self->{log}};
  		$writer->endTag;
	}

    $self->{theArray}->save_as_xml( $writer );

	$writer->endTag;
	$writer->end();

	$output->close();

	open my $current_file, "round_current.xml" or die;
	open my $archive, sprintf( ">round_%05d.xml", $self->{round} ) or die "$!";
	print $archive $_ while <$current_file>;
	close $current_file;
	close $archive;
}

##########################################################################

sub saveConfiguration
{
    die "obsolete\n";
	my %conf = @_ == 1 ? %{$_[0]->{conf}} : @_;

	my $output = new IO::File(">configuration.xml");
	my $writer = new XML::Writer(OUTPUT => $output, NEWLINES => 1);

	$writer->startTag( 'configuration' );
	$writer->dataElement( 'title', $conf{title} );
	$writer->dataElement( 'gameStatus', $conf{gameStatus} );
	$writer->dataElement( 'gameLength', $conf{gameLength} );
	$writer->dataElement( 'theArraySize', $conf{theArraySize} );
	$writer->dataElement( 'snippetMaxLength', $conf{snippetMaxLength} );

	$writer->dataElement( 'currentIteration', $conf{currentIteration} );
	if( $conf{mamboDecrement} )
	{
		$writer->dataElement( 'mamboDecrement', $conf{mamboDecrement} );
	}
	$writer->dataElement( 'note', ref $conf{note} ? %{$conf{note}}
                                                  : $conf{note}   );

	foreach( keys %{$conf{player}} )
	{
		$writer->dataElement( 'player', $_, color => $conf{player}{$_}{color},
			password => $conf{player}{$_}{password}, status => $conf{player}{$_}{status} );
	}

	$writer->endTag;
	$writer->end;
	$output->close;
}

##########################################################################

sub checkForEliminatedPlayers
{
	my $self = shift;

	no warnings 'uninitialized';

	$self->log( "checking for eliminated players.." );

	my %score = $self->{theArray}->census;

	for my $player ( keys %{ $self->{conf}{player} } )
	{
		next if $self->{conf}{player}{$player}{status} eq 'EOT';
		unless( $score{ $player }  )
		{
			$self->log( "\tplayer $player lost all agents, eliminated" );
			$self->{conf}{player}{$player}{status} = 'EOT';
		}
	}

}

sub get_iteration_newcomers {
    my( $self, $iteration ) = @_;

    my $iter = XML::LibXML->new->parse_file(
        sprintf( "round_%05d.xml", $iteration )
    );

    my @newcomers;
    for my $n ( $iter->findnodes( '//newcomer' ) ) {
        my $owner = $n->findvalue( '@player' );
        my $code = $n->findvalue( 'text()' );
        my $date = $n->findvalue( '@time' );

        push @newcomers, [ $owner, $date, $code ];
    }

    return @newcomers;
}

##########################################################################

sub introduce_newcomers
{
	no warnings 'uninitialized';
	my $self = shift;

    # TODO special case for adhoc at iteration 0

    my @newcomers = $self->{replay} ? $self->get_iteration_newcomers( )
                                    : $self->visit_mobil_station
                                    ;

    $self->{newcomers} = \@newcomers;

    $self->log( "\tno-one was aboard" ) unless @newcomers;

    AGENT: for my $newcomer ( @newcomers ) {
        my( $player, $date, $code ) = @$newcomer;
        $self->log( "\t".$player."'s new agent is aboard (u/l'ed $date)" );
        # dead players can't submit agents
        if( $self->{conf}{player}{$player}{status} eq 'EOT' ) {
            $self->log( "\tplayer is eliminated, can't submit a new agent" );
            next AGENT;
        }

        my @available_slots = $self->{theArray}->empty_cells;

        if( @available_slots > 0 )
        {
            my $slot = $available_slots[ rand @available_slots ];
            $self->log( "\tagent inserted at cell $slot" );
            $self->{theArray}->cell( $slot )->insert({
                owner => $player,
                code => $code,
            });
            next AGENT;
        }

        # no empty cells, maybe a cell already occupied by
        # the player?
        @available_slots = $self->{theArray}->cells_belonging_to( $player );

        if( @available_slots > 0 )
        {
            my $slot = $available_slots[ rand @available_slots ];
            $self->log( "agent at cell $slot is upgraded" );
            $self->{theArray}->cell( $slot )->insert({
                owner => $player,
                code => $code,
            });
            unlink $player or $self->log( "ERROR: $!" );
            next AGENT;
        }

        $self->log( "no empty slot left, agent deleted" );
    }
}

##########################################################################

sub log
{
  my $self = shift;

  return @{$self->{log}} unless @_;

  if( $self->{interactive} ) {
    local $\ = "\n";
    print for @_;
  }

  push @{$self->{log}}, @_;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub insert_agent {
	my ( $self, $pos, $player, $code ) = @_;

    if( $pos >= $self->{conf}{theArraySize} ) {
	    $self->log( "can't insert agent: cell $pos out of bound" );
        return;
    }

    $self->{theArray}->cell( $pos )->insert({
        owner => $player,
        code => $code,
    });
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub run_cell {
    my( $self, $cell_id, $vars_ref ) = @_;
    my %vars;
    %vars = %$vars_ref if $vars_ref;

    return $self->array->run_cell( $cell_id => {
       %vars,
       '$S' => $self->{conf}{agentMaxSize},
       '$I' => $self->{conf}{gameLength},
       '$i' => $self->{round},
    } );

}

##########################################################################

# ( $result, $error, @array ) = $pw->execute( @array )
# executes the code of $array[0]
sub execute
{
	my( $self, $cell_id ) = @_;

    # what happens in execute(), stays in execute
    local *STDERR;
    my $warnings;
    open STDERR, '>', \$warnings;

    my $owner =  $self->array->cell( $cell_id )->get_owner;

	local @_ = $self->array->get_cells_code( $cell_id );
	local $_ = $_[0];
	my @o = $self->array->get_facades( $cell_id );

	# run this in a safe
	my $safe = new Safe 'Container';
	$safe->permit( qw/ rand time sort :browse :default / );
	my $result;
	my $error;

	eval
	{
    	local $SIG{ALRM} = sub { die "timed out\n" };
    	alarm 3;
		undef $@;
		my $code = $_[0];
		@Container::Array = @_;
		@Container::o = @o;
		@Container::O = $owner;
		$Container::S = $self->{conf}{snippetMaxLength};
		$Container::I = $self->{conf}{gameLength};
		$Container::i = $self->{conf}{currentIteration};
		$safe->share_from( 'Container',
                           [ '$S', '$I', '$i', '@_', '@o', '$O' ] );
		$result = $safe->reval( <
local *_ = \\\@Array;
\$_ = \$_[0];
$code
EOT

    	$error = $@;
    	alarm 0;
  	};

    return ( $result, $error ) if $error;

    my @code_array = $safe->reval( '@Array' );
    $owner = $safe->reval( '$o[0]' );
    $code_array[0] = $safe->reval( '$_' );

    return( $result, $error, $owner, @code_array );
}

##########################################################################

sub runSlot {
  	my ( $self, $slotId ) = @_;

    my $cell = $self->{theArray}->cell( $slotId );

    # diddled cells and empty cells aren't executed
	return if $cell->is_empty
           or not $cell->get_operational;

	$self->log( "cell $slotId: agent owned by ".$cell->get_owner );

    my @code_array  = $self->{theArray}->get_cells_code( $slotId );
    my @owner_array = $self->{theArray}->get_facades( $slotId );

	# exceed permited size?
    my $code = $cell->get_code;
  	if( length $code > $self->{conf}{agentMaxSize} ) {
    	$self->log( "\tagent crashed: is ".length($code)." chars, exceeds max permitted size $self->{conf}{snippetMaxSize}" );
        $cell->delete;
    	return;
  	}

  	$self->log( "\texecuting.." );

    # TODO  squeeze in the ownership array
    my $agent = $self->run_cell( $slotId );

	if( $agent->crashed ) {
    	$self->log( "\tagent crashed: ".$agent->error_msg );
        $cell->delete;
    	return;
  	}

    $cell->set_code( $agent->eval( '$_' ) );
    $cell->set_facade( $agent->eval( '$o' ) );

    no warnings qw/ uninitialized /;

  	my $output = $agent->return_value;
    my $result = $output;
  	$output = substr( $output, 0, 24 ).".." if length $output > 25;
  	$output =~ s#\n#\\n#g;

    $self->log( "\tagent returned: $output" );

    if( $result =~ /^!(-?\d*)$/ ) {
        $self->_nuke_operation( $slotId, $1 );
    }
    elsif( $result =~ /^\^(-?\d*)$/ ) {
        $self->_p0wn_operation( $slotId, $1 );
    }
    elsif( $result =~ /^~(-?\d*)$/ ) {
        $self->_alter_operation( $slotId, $1, [ $agent->eval( '@Array' ) ] );
    }
    elsif( $result =~ /^(-?\d*):(-?\d*)$/ ) {
        $self->_copy_operation( $slotId, $1, $2 );
    }
    else {
    	$self->_noop_operation();
    }
}

sub _nuke_operation {
    my( $self, $agent_index, $target_index ) = @_;

    $target_index = $self->relative_to_absolute_position( $agent_index, $target_index );
    return if $target_index == -1;

    if( $self->array->cell( $target_index )->is_empty ) {
        $self->log( "\tno agent found at cell $target_index" );
        return;
    }

    $self->array->cell( $target_index )->clear;
    $self->log( "\tagent in cell $target_index destroyed" );
}

sub _p0wn_operation {
    my( $self, $agent_index, $target_index ) = @_;

    $target_index = $self->relative_to_absolute_position( $agent_index, $target_index );

    return if $target_index == -1;

    my $target = $self->{theArray}->cell( $target_index );

    if( $target->is_empty ) {
	   $self->log( "\tno agent to p0wn in cell $target_index" );
	   return;
    }

    $self->log( "\tagent in cell $target_index p0wned" );
    $target->set_owner( $self->{theArray}->cell( $agent_index )->get_owner );
}

sub relative_to_absolute_position {
  my( $self, $slotId, $shift ) = @_;
  $shift ||= 0;

  if( abs( $shift ) > $self->{conf}{theArraySize} ) {
    $self->log( "\tposition $shift out-of-bound" );
    return -1;
  }
  $slotId += $shift + 2 * $self->{conf}{theArraySize};
  $slotId %= $self->{conf}{theArraySize};

  return $slotId;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub _alter_operation {
    my ( $self, $agent_index, $target_index, $Array_ref ) = @_;

    my $abs_target_index = $self->relative_to_absolute_position( $agent_index, $target_index );
    return if $abs_target_index == -1;

    my $target = $self->{theArray}->cell( $abs_target_index );

    if ( $target->is_empty ) {
        $self->log( "\tno agent found at cell $abs_target_index" );
      	return;
    }

    $target->set_code( $Array_ref->[$target_index] );
    $self->log( "\tcode of agent in cell $abs_target_index altered" );
}

sub _copy_operation {
    my( $self, $agent_index, $source_index, $dest_index ) = @_;

    $source_index = $self->relative_to_absolute_position( $agent_index, $source_index );
    $dest_index   = $self->relative_to_absolute_position( $agent_index, $dest_index );

    # source or destination invalid? We do nothing
    return if $source_index == -1 or $dest_index == -1;

    my $theArray = $self->{theArray};
    my $target = $theArray->cell( $dest_index );
    my $agent = $theArray->cell( $agent_index );

    if( $target->get_owner
        and $target->get_owner ne $agent->get_owner )
    {
        $self->log( "\tagent in cell $dest_index already owned by ".
                    $target->get_owner );
        return;
    }

    $self->log( "\tagent of cell $source_index copied into cell $dest_index" );
    $target->copy( $agent );
    $target->set_operational( 0 );
}

sub _noop_operation {
    $_[0]->log( "\tno-op" );
}

sub readCell {
	my( $self, $cellId ) = @_;
	return undef unless $self->{theArray}[$cellId];
	return ( $self->{theArray}[$cellId]{owner}, $self->{theArray}[$cellId]{code}  );
}

sub writeCell {
	my( $self, $pos, $owner, $code ) = @_;
	$self->{theArray}[$pos] = { owner => $owner, code => $code };
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub array {
    return $_[0]->{theArray};
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


sub agent_census {
    my( $self ) = @_;

    my %player = %{$self->{conf}{player}};

    my %census = $self->{theArray}->census;

    for my $p ( keys %player ) {
        $player{$p}{agents} = $census{$p} || 0;
    }

    return %census;
}


=begin notes

my $pw = new Games::Perlwar;

$pw->{interactive} = 1;
$pw->{theArray} = [ { owner => 'Yanick', name => 'Neo', code => 'print "Hello world!"' },
                    { owner => '1337 h4ck3r', name => 'crash me', code => 'exit' },
                    { owner => '1337 h4ck3r', name => 'readdir me', code => 'opendir DIR, "."; return readdir DIR;' },
                    { owner => '1337 h4ck3r', name => 'infinite loop', code => '1 while 1' },
                    { owner => '1337 h4ck3r', name => 'backticks', code => '`ls`' },
                    { owner => '1337 h4ck3r', name => 'kill next', code => '"!1"' },
                    { owner => '1337 h4ck3r', name => 'must die', code => '"I am still alive?"' },
                    { owner => 'Yanick', name => 'good boy', code => '1' },
                    { owner => 'Yanick', name => 'owner', code => '"~-1"' },
                    { owner => 'Yanick', name => 'too big', code => 'a' x 200 },
                    ];
$pw->{config}{arraySize} = @{ $pw->{theArray} };
$pw->{config}{maxSnippetSize} = 100;

$pw->runSlot( $_ ) for 0..9;

=end notes

=cut

1;

__END__