File Coverage

lib/Games/Sokoban/Controller.pm

Criterion	Covered	Total	%
statement	9	99	9.0
branch	0	32	0.0
condition	0	13	0.0
subroutine	3	23	13.0
pod	14	14	100.0
total	26	181	14.3

package Games::Sokoban::Controller;

use strict;
use warnings;
use Games::Sokoban;

our $VERSION = '0.01';

sub new {
  my $class = shift;
  bless { model => Games::Sokoban->new, @_ }, $class;
}

sub set_data {
  my ($self, $data, $format) = @_;
  $self->{model}->data($data, $format);
  $self->{level_id} = $self->{model}->normalise;
  $self->{model}->data($data, $format);
  $self->reset;
}

sub level_id { shift->{level_id} }

sub reset {
  my $self = shift;
  my $model = $self->{model};
  $self->{data} = $model->data;
  $self->{size} = [$model->{w}, $model->{h}];
  $self->{pos}  = [$model->start];
  $self->{replaced} = [];
  $self->{step} = 0;
}

sub size   { @{shift->{size}} }
sub width  { shift->{size}[0] }
sub height { shift->{size}[1] }

sub get {
  my ($self, $pos) = @_;
  substr($self->{data}, $self->_pos($pos), 1);
}

sub _rel {
  my ($self, $rel_pos) = @_;
  $rel_pos->[0] += $self->{pos}[0];
  $rel_pos->[1] += $self->{pos}[1];
  $self->get($rel_pos);
}

sub _replace {
  my ($self, $pos, $char) = @_;
  $pos->[0] += $self->{pos}[0];
  $pos->[1] += $self->{pos}[1];
  substr($self->{data}, $self->_pos($pos), 1, $char);
  push @{$self->{replaced}}, $pos;
}

sub _pos {
  my ($self, $pos) = @_;
  my ($x, $y) = @$pos;
  my ($w, $h) = @{$self->{size}};
  if ($x < 0)   { $x = 0; }
  if ($y < 0)   { $y = 0; }
  if ($x >= $w) { $x = $w - 1; }
  if ($y >= $h) { $y = $h - 1; }
  $x + $y * ($w + 1);  # +1 for "\n"
}

sub _dump {
  my $self = shift;
  my $data = $self->{data};
  my $left = $data =~ /([\.\+])/;
  my $done = $data =~ /(\*)/;
  my $dump = join "",
      $data, "\n",
      "pos: (", $self->{pos}[0], ", ", $self->{pos}[1], ")\n",
      "step: ", $self->{step}, "\n",
      "left: ", ($left || 0), "\n",
      "done: ", ($done || 0), "\n";

  if (defined wantarray) {
    return $dump;
  }
  else {
    print STDERR "\n", $dump;
  }
}

sub _move {
  my ($self, $delta, $direction) = @_;

  my ($x, $y) = @{$self->{pos}};
  my ($dx, $dy) = @$delta;
  my $me   = $self->_rel([0, 0]);
  my $dest = $self->_rel([$dx, $dy]);

  $self->{direction} = $direction;
  @{$self->{replaced}} = ();

  my $moved;
  if ($dest eq ' ' or $dest eq '.') {
    $self->_replace([0, 0] => ($me eq '@' ? ' ' : '.'));
    $self->_replace([$dx, $dy] => ($dest eq ' ' ? '@' : '+'));
    $moved = 1;
  }
  elsif ($dest eq '$' or $dest eq '*') {
    my $next = $self->_rel([$dx * 2, $dy * 2]);
    if ($next eq ' ' or $next eq '.') {
      $self->_replace([0, 0] => ($me eq '@' ? ' ' : '.'));
      $self->_replace([$dx, $dy] => ($dest eq '$' ? '@' : '+'));
      $self->_replace([$dx * 2, $dy * 2] => ($next eq ' ' ? '$' : '*'));
      $moved = 1;
    }
    else {
      $self->_debug("blocked");
    }
  }
  else {
    $self->_debug("wall");
  }
  if ($moved) {
    $self->{step}++;
    $self->{pos} = [$x + $dx, $y + $dy];
    return @{$self->{replaced}};
  }
  return;
}

sub go_right { shift->_move([1, 0], 'right') }
sub go_left  { shift->_move([-1, 0], 'left') }
sub go_up    { shift->_move([0, -1], 'up') }
sub go_down  { shift->_move([0, 1], 'down') }

sub direction { shift->{direction} || 'left' }

sub solved {
  my $self = shift;
  my $left = $self->{data} =~ /([\.\+\$])/;
  !$left;
}

sub _debug {
  my $self = shift;
  print STDERR @_, "\n" if $self->{debug};
}

1;

__END__