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__
=head1 NAME
Games::Sokoban::Controller - sokoban controller
=head1 SYNOPSIS
use strict;
use warnings;
use Games::Sokoban::Controller;
my $c = Games::Sokoban::Controller->new;
$c->set_data(<<'LEVEL');
#######
#@ . #
# $ #
# #
#######
LEVEL
my @replaced = $c->go_down;
for (@replaced) {
my $char = $c->get($_->[0], $_->[1]);
if ($char eq '@') { ... } # me
if ($char eq '+') { ... } # me on a goal
if ($char eq '$') { ... } # box
if ($char eq '*') { ... } # box on a goal
if ($char eq '.') { ... } # goal
if ($char eq ' ') { ... } # floor
}
if ($c->solved) {
print "SOLVED!\n";
}
=head1 DESCRIPTION
This is a plain Sokoban controller. If you want to play Sokoban, you'll need some front-end.
=head1 METHODS
=head2 new
creates an object.
=head2 set_data (data, format)
set puzzle data (level). See L<Games::Sokoban> for available formats.
=head2 level_id
returns an unique id of the puzzle.
=head2 reset
(re-)initializes the puzzle.
=head2 size, width, height
return width and/or height of the puzzle.
=head2 get (x, y)
returns a character of the (0-based) coordinate.
=head2 go_left, go_right, go_up, go_down
move the player (and a box if applicable), and return an array of coordinates where you need to update because of the move.
=head2 direction
usually returns the direction of the player (C<left>, C<right>, C<up>, C<down>). You may want to use this if you create a graphical front-end.
=head2 solved
returns true if everything is placed correctly.
=head1 SEE ALSO
L<Games::Sokoban>
=head1 AUTHOR
Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2011 by Kenichi Ishigaki.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut