File Coverage

blib/lib/Karel/Robot/WithGrid.pm

Criterion	Covered	Total	%
statement	126	128	98.4
branch	24	28	85.7
condition			n/a
subroutine	38	38	100.0
pod	16	16	100.0
total	204	210	97.1

package Karel::Robot::WithGrid;

=head1 NAME

Karel::Robot::WithGrid

=head1 DESCRIPTION

A robot with an associated grid. To create the robot, use

    my $robot = 'Karel::Robot'->new;
    my $grid  = 'Karel::Grid'->new(x => 10, y => 12);
    $robot = $robot->set_grid($grid, 1, 1);

=head1 METHODS

=over 4

=cut

use warnings;
use strict;
use parent 'Karel::Robot';
use Karel::Util qw{ positive_int };
use Carp;
use List::Util qw{ first };
use Clone qw{ clone };
use constant {
    CONTINUE         => 0,
    FINISHED         => 1,
    FINISHED_DELAYED => 2,
    QUIT             => -1,
};
use Moo::Role;
requires qw{ set_grid knows };

=item $robot->x, $robot->y

    my ($x, $y) = map $robot->$_, qw( x y );

Coordinates of the robot in its grid.

=cut

has [qw[ x y ]] => ( is  => 'rwp',
                     isa => \&positive_int,
                   );

=item $robot->grid

    my $grid = $robot->grid;

The associated C object.

=cut

my $grid_type = sub {
    my ($grid) = @_;
    eval { $grid->isa('Karel::Grid') } or croak "Invalid grid type\n";
};


has grid => ( is  => 'rwp',
              isa => $grid_type,
            );

=item $robot->set_grid($grid, $x, $y, $direction);

Initialize the grid. Grid must be an object of the C
type, C<$x> and C<$y> are coordinates of the robot, C<$direction> is
one of C (defaults to C). Dies if the robot's place is
occupied by a wall.

=cut

around set_grid => sub {
    my (undef, $self, $grid, $x, $y, $direction) = @_;
    $self->_set_grid($grid);
    $self->_set_x($x);
    $self->_set_y($y);
    $self->_set_direction($direction) if $direction;
};

=item $robot->drop_mark

Drop mark in the current location. Dies if there are already 9 marks.

=cut

sub drop_mark {
    my ($self) = shift;
    $self->grid->drop_mark($self->coords);
    return 1
}

=item $robot->pick_mark

Picks up one mark from the current location. Dies if there's nothing
to pick.

=cut

sub pick_mark {
    my ($self) = shift;
    $self->grid->pick_mark($self->coords);
    return 1
}

=item $robot->direction

  my $direction = $robot->direction;

Returns the robot's direction: one of C.

=cut

my $string_list = sub {
    do {
        my %strings = map { $_ => 1 } @_;
        sub { $strings{+shift} or croak "Invalid string" }
    }
};

has direction => ( is      => 'rwp',
                   isa     => $string_list->(qw( N W S E )),
                   default => 'N',
                 );

=item $robot->left

Turn the robot to the left.

=cut

my @directions = qw( N W S E );
sub left {
    my ($self) = @_;
    my $dir = $self->direction;
    my $idx = first { $directions[$_] eq $dir } 0 .. $#directions;
    $self->_set_direction($directions[ ($idx + 1) % @directions ]);
    return FINISHED
}

=item $robot->coords

Returns the robot's coordinates, i.e. C and C.

=cut

sub coords {
    my ($self) = @_;
    return ($self->x, $self->y)
}

=item $robot->cover

Returns the grid element at the robot's coordinates, i.e.

  $r->grid->at($r->coords)

=cut

sub cover {
    my ($self) = @_;
    return $self->grid->at($self->coords)
}

=item $robot->facing_coords

Returns the coordinates of the grid element the robot is facing.

=cut

my %facing = ( N => [0, -1],
               E => [1, 0],
               S => [0, 1],
               W => [-1, 0]
             );

sub facing_coords {
    my ($self) = @_;
    my $direction = $self->direction;
    my @coords = $self->coords;
    $coords[$_] += $facing{$direction}[$_] for 0, 1;
    return @coords
}

=item $robot->facing

Returns the contents of the grid element the robot is facing.

=cut

sub facing {
    my ($self) = @_;
    $self->grid->at($self->facing_coords)
}


has _stack => ( is        => 'rwp',
                predicate => 'is_running',
                clearer   => 'not_running',
                isa       => sub {
                    my $s = shift;
                    'ARRAY' eq ref $s or croak "Invalid stack";
                    ! grep 'ARRAY' ne ref $_, @$s
                        or croak "Invalid stack element";
                }
              );

sub _pop_stack {
    my $self = shift;
    shift @{ $self->_stack };
    $self->not_running unless @{ $self->_stack };
}

sub _push_stack {
    my ($self, $commands) = @_;
    unshift @{ $self->_stack }, [ clone($commands), 0 ];
}


sub _stacked { shift->_stack->[0] }

sub _stack_command {
    my $self = shift;
    my ($commands, $index) = @{ $self->_stacked };
    return $commands->[$index]
}

sub _stack_previous_commands {
    shift->_stack->[1][0]
}

sub _stack_previous_index {
    shift->_stack->[1][1]
}

sub _run {
    my ($self, $prog) = @_;
    $self->_set__stack([ [$prog, 0] ]);
}

=item $robot->run($command_name)

Run the given command.

=cut

sub run {
    my ($self, $command) = @_;
    my $parsed = $self->parser->parse("run $command");
    $self->_run($$parsed);
}

=item $robot->forward

Moves the robot one cell forward in its direction.

=cut

sub forward {
    my ($self) = @_;
    croak "Can't walk through walls" if $self->facing =~ /w/i;
    my ($x, $y) = $self->facing_coords;
    $self->_set_x($x);
    $self->_set_y($y);
    return FINISHED
}

=item $robot->repeat($count, $commands)

Runs the C command: decreases the counter, and if it's
non-zero, pushes the body to the stack. Returns 0 (CONTINUE) when it
should stay in the stack, 1 (FINISHED) otherwise.

=cut

sub repeat {
    my ($self, $count, $commands) = @_;
    if ($count) {
        $self->_stack_command->[1] = $count - 1;
        $self->_push_stack($commands);
        return CONTINUE

    } else {
        return FINISHED
    }
}

=item $isnot_south = $robot->condition('!S')

Solve the given condition. Supported parameters are:

=over 4

=item * N E S W

Facing North, East, South, West

=item * m

Covering mark(s).

=item * w

Facing a wall.

=item * !

Negates the condition.

=back

Returns true or false, dies on invalid condition.

=cut

sub condition {
    my ($self, $condition) = @_;
    my $negation = $condition =~ s/!//;
    my $result;

    if ($condition =~ /^[NESW]$/) {
        $result = $self->direction eq $condition;

    } elsif ($condition eq 'w') {
        $result = $self->facing =~ /w/i;

    } elsif ($condition eq 'm') {
        $result = $self->cover =~ /^[1-9]$/;

    } else {
        croak "Invalid condition '$condition'"
    }

    $result = ! $result if $negation;
    return $result
}

=item $robot->If($condition, $commands, $else)

If $condition is true, puts $commands to the stack, otherwise puts
$else to the stack. Returns 2 (FINISH_DELAYED) in the former case, 1
(FINISHED) in the latter one.

=cut

sub If {
    my ($self, $condition, $commands, $else) = @_;
    if ($self->condition($condition)) {
        $self->_push_stack($commands);
    } elsif ($else) {
        $self->_push_stack($else);
    } else {
        return FINISHED
    }
    return FINISHED_DELAYED
}

=item $robot->While($condition, $commands)

Similar to C, but returns 0 (CONTINUE) if the condition is true,
i.e. it stays in the stack.

=cut

sub While {
    my ($self, $condition, $commands) = @_;
    if ($self->condition($condition)) {
        $self->_push_stack($commands);
        return CONTINUE

    } else {
        return FINISHED
    }
}

=item $robot->call($command)

Checks whether the robot knows the command, and if so, pushes its
definition to the stack. Dies otherwise. Returns 2 (FINISH_DELAYED).

=cut

sub call {
    my ($self, $command_name) = @_;
    my $commands = $self->knows($command_name);
    if ($commands) {
        $self->_push_stack($commands);
    } else {
        croak "Unknown command $command_name.";
    }
    return FINISHED_DELAYED
}

=item $robot->stop

Stops execution of the current program and clears the stack. Returns
-1 (QUIT).

=cut

sub stop { shift->not_running; QUIT }

=item $robot->step

Makes one step in the currently running program.

=cut

sub step {
    my ($self) = @_;
    croak 'Not running!' unless $self->is_running;

    my ($commands, $index) = @{ $self->_stacked };

    my $command = $commands->[$index];
    my $action = { f   => 'forward',
                   l   => 'left',
                   p   => 'pick_mark',
                   d   => 'drop_mark',
                   r   => 'repeat',
                   i   => 'If',
                   w   => 'While',
                   q   => 'stop',
                   c   => 'call',
                   x   => sub { FINISHED },
                 }->{ $command->[0] };
    croak "Unknown action " . $command->[0] unless $action;

    my $finished = $self->$action(@{ $command }[ 1 .. $#$command ]);
    # warn "$command->[0], $finished.\n";
    # use Data::Dump; warn Data::Dump::dump($self->_stack);

    { FINISHED, sub {
          if (++$index > $#$commands) {
              $self->_pop_stack;

          } else {
              $self->_stacked->[1] = $index;
          }
      },
      CONTINUE, sub { @_ = ($self); goto &step },
      FINISHED_DELAYED, sub {
          $self->_stack_previous_commands
               ->[ $self->_stack_previous_index ][0] = 'x';
      },
      QUIT, sub { },
    }->{ $finished }->();
}

=back

=head1 RETURN VALUES

There are three special return values corresponding to the stack handling:

 0 CONTINUE
 1 FINISHED
 2 FINISHED_DELAYED

If a command returns C, the stack doesn't change. If it
returns C, the following command in the stack is executed.
If it returns C, new commands are put in the stack,
but once they're finished, the command behaves as if finished, too.

=cut

__PACKAGE__