package Games::LMSolve::Alice;
use strict;
use warnings;
use Games::LMSolve::Base qw(%cell_dirs);
use vars qw(@ISA);
@ISA=qw(Games::LMSolve::Base);
my %cell_flags =
(
'ADD' => 1,
'SUB' => -1,
'GOAL' => 0,
'START' => 1,
'BLANK' => 0,
);
sub input_board
{
my $self = shift;
my $filename = shift;
my $spec =
{
'dims' => {'type' => "xy(integer)", 'required' => 1},
'layout' => {'type' => "layout", 'required' => 1},
};
my $input_obj = Games::LMSolve::Input->new();
my $input_fields = $input_obj->input_board($filename, $spec);
my ($width, $height) = @{$input_fields->{'dims'}->{'value'}}{'x','y'};
my (@board);
my $line;
my $line_number=0;
my $lines_ref = $input_fields->{'layout'}->{'value'};
my $read_line = sub {
if (scalar(@$lines_ref) == $line_number)
{
return 0;
}
$line = $lines_ref->[$line_number];
$line_number++;
return 1;
};
my $gen_exception = sub {
my $text = shift;
die "$text on $filename at line " .
($input_fields->{'layout'}->{'line_num'} + $line_number + 1) .
"!\n";
};
my ($y,$x);
my ($start_x,$start_y);
$y = 0;
$x = 0;
INPUT_LOOP: while ($read_line->())
{
while (length($line) > 0)
{
$line =~ s/^\s+//;
if ($line =~ /\S/)
{
if ($line =~ /^\[([^\]]*)\]/)
{
my $flags_string = uc($1);
my @flags = (split(/,/, $flags_string));
my @dirs = (grep { exists($cell_dirs{$_}) } @flags);
my @flag_flags = (grep { exists($cell_flags{$_}) } @flags);
my @unknown_flags =
(grep
{
(!exists($cell_dirs{$_})) &&
(!exists($cell_flags{$_}))
}
@flags
);
if (scalar(@unknown_flags))
{
$gen_exception->("Unknown Flags on Cell (" . join(",", @unknown_flags) . ")");
}
$board[$y][$x] =
{
'dirs' => { map { $_ => $cell_dirs{$_} } @dirs },
'flags' => { map { $_ => $cell_flags{$_} } @flag_flags },
};
if (exists($board[$y][$x]->{'flags'}->{'START'}))
{
if (defined($start_x))
{
$gen_exception->("Two starts were defined!\n");
}
$start_x = $x;
$start_y = $y;
}
$x++;
if ($x == $width)
{
$x = 0;
$y++;
if ($y == $height)
{
last INPUT_LOOP;
}
}
$line =~ s/^.*?\]//;
}
elsif ($line =~ /^#/)
{
# Do nothing - it's a comment
$line = "";
}
else
{
$gen_exception->("Junk at Line");
}
}
}
}
if ($y != $height)
{
$gen_exception->("Input Terminated Prematurely after reading y=$y x=$x");
}
if (! defined($start_x))
{
$gen_exception->("The Starting Position was not defined anywhere");
}
$self->{'height'} = $height;
$self->{'width'} = $width;
$self->{'board'} = \@board;
return [ $start_x, $start_y, 1 ];
}
# A function that accepts the expanded state (as an array ref)
# and returns an atom that represents it.
sub pack_state
{
my $self = shift;
my $state_vector = shift;
return pack("ccc", @{$state_vector});
}
# A function that accepts an atom that represents a state
# and returns an array ref that represents it.
sub unpack_state
{
my $self = shift;
my $state = shift;
return [ unpack("ccc", $state) ];
}
# Accept an atom that represents a state and output a
# user-readable string that describes it.
sub display_state
{
my $self = shift;
my $state = shift;
my ($x, $y, $d) = @{ $self->unpack_state($state) };
return sprintf("X = %i ; Y = %i ; d = %i", $x+1, $y+1, $d);
}
# This function checks if a state it receives as an argument is a
# dead-end one.
sub check_if_unsolvable
{
my $self = shift;
my $coords = shift;
return ($coords->[2] == 0);
}
sub check_if_final_state
{
my $self = shift;
my $coords = shift;
return exists($self->{'board'}->[$coords->[1]][$coords->[0]]->{'flags'}->{'GOAL'})
}
# This function enumerates the moves accessible to the state.
# If it returns a move, it still does not mean that it is a valid
# one. I.e: it is possible that it is illegal to perform it.
sub enumerate_moves
{
my $self = shift;
my $coords = shift;
return keys(%{$self->{'board'}->[$coords->[1]][$coords->[0]]->{'dirs'}});
}
# This function accepts a state and a move. It tries to perform the
# move on the state. If it is succesful, it returns the new state.
#
# Else, it returns undef to indicate that the move is not possible.
sub perform_move
{
my $self = shift;
my $coords = shift;
my $m = shift;
my $offsets = [ map { $_ * $coords->[2] } @{$cell_dirs{$m}} ];
my @new_coords = @$coords;
$new_coords[0] += $offsets->[0];
$new_coords[1] += $offsets->[1];
my $new_cell = $self->{'board'}->[$new_coords[1]][$new_coords[0]]->{'flags'};
# Check if we are out of the bounds of the board.
if (($new_coords[0] < 0) || ($new_coords[0] >= $self->{'width'}) ||
($new_coords[1] < 0) || ($new_coords[1] >= $self->{'height'}) ||
exists($new_cell->{'BLANK'})
)
{
return undef;
}
if (exists($new_cell->{'ADD'}))
{
$new_coords[2]++;
}
elsif (exists($new_cell->{'SUB'}))
{
$new_coords[2]--;
}
return [ @new_coords ];
}
1;
=head1 NAME
Games::LMSolve::Alice - driver for solving the Alice
mazes.
=head1 SYNOPSIS
NA - should not be used directly.
=head1 METHODS
=head2 $self->input_board()
Overrided.
=head2 $self->pack_state()
Overrided.
=head2 $self->unpack_state()
Overrided.
=head2 $self->display_state()
Overrided.
=head2 $self->check_if_unsolvable()
Overrided.
=head2 $self->check_if_final_state()
Overrided.
=head2 $self->enumerate_moves()
Overrided.
=head2 $self->perform_move()
Overrided.
=head1 SEE ALSO
L<Games::LMSolve::Base>.
For more about Alice mazes see L<http://www.logicmazes.com/alice.html>.
=head1 AUTHORS
Shlomi Fish, L<http://www.shlomifish.org/>
=cut