Ever see that puzzle with the 5x5 grid where you have to toggle the colors until you get the whole grid to be the same color? (it would start one color, and you had to get it to be the other color). Well, I was trying to remember the solution, so I coded up the puzzle. It can be solved in 15 moves, I will post the answer next week. Here is my code for the puzzle:
#!perl -w
use strict;
{
package Board;
my $white = '_';
my $black = '#';
# Construct a new board.
sub new
{
my $proto = shift || die "Expected class";
my $class = ref($proto) || $proto;
my $self = [[($white)x5],[($white)x5],[($white)x5],
[($white)x5],[($white)x5]];
bless ($self, $class);
return $self;
}
# Returns true if the board is all black. False otherwise.
sub Finished
{
my $self = shift || die "Expected self";
for( @$self )
{
for( @$_ )
{
return 0 if $white eq $_;
}
}
return 1;
}
# Returns a display version of the board, suitable for printing.
sub Display
{
my $self = shift || die "Expected self";
my $rowN = 0;
my @disp = map {"$_\n"} " 12345", map {++$rowN . join('', @$_)
+} @$self;
return wantarray ? @disp : join '', @disp;
}
# Toggle the location given, and the locations to the N, E, S, & W
sub Toggle
{
die "Incorrect number of args" unless 3 == @_;
my ( $self, $x, $y ) = @_;
die "X ($x) out of range\n" if $x > 5 or 1 > $x;
die "Y ($y) out of range\n" if $y > 5 or 1 > $y;
$self->_ToggleSquare( $x, $y );
$self->_ToggleSquare( $x+1, $y );
$self->_ToggleSquare( $x-1, $y );
$self->_ToggleSquare( $x, $y+1 );
$self->_ToggleSquare( $x, $y-1 );
return undef;
}
# Toggle the given location. No-op if location is out of range.
sub _ToggleSquare
{
die "Incorrect number of args" unless 3 == @_;
my ( $self, $x, $y ) = @_;
return undef if $x > 5 or 1 > $x or $y > 5 or 1 > $y;
($x, $y) = map { $_ - 1 } $x, $y;
$self->[$x]->[$y] = $white eq $self->[$x]->[$y] ? $black : $wh
+ite;
return undef;
}
}
sub GetMove
{
print "> ";
my $move = <>; # Read from STDIN, or a file.
my ($control, $x, $y) = $move =~ m/^\s*([a-zA-Z]+|(\d)[\/,\s-]?(\d
+))\s*$/;
($x, $y) = GetMove() if not defined $control; # Repeat as necessar
+y
die "Game Over\n" if $control && $control =~ m/^[qQeE]/; # quit, e
+xit, etc.
return ($x, $y);
}
sub main
{
my $board = Board->new();
my @moves = ();
while( not $board->Finished() )
{
print $board->Display();
my @move = GetMove();
push @moves, \@move;
$board->Toggle( @move );
}
print "Success! ", scalar( @moves ), " moves.\n";
print join( "\n", map { join '-', @$_ } @moves ), "\n";
return 0;
}
exit( main() );
|
Re (tilly) 1: 5x5 Puzzle
by tilly (Archbishop) on Jan 29, 2001 at 11:38 UTC
|
At first I had ignored this, then decided to do it. It was
a more fun challenge than I thought. There are, not
counting the order of the moves, actually 4 solutions in
15 moves for a 5x5 board. What follows is the throw-away
script I wrote to find this. By default it solves a 5x5
board. Pass it an argument and it will solve an nxn
board. (I tried it in the 1..10 range and found that there
is 1 solution for 1, 2, 3, 6, 7, 8 and 10. As I mentioned,
there are 4 for 5, plus 16 for 4 and 256 for 9. Don't ask
me why, I merely report what I found...)
It would not be hard to extend this to handle
arbitrary rectangular boards. I also didn't need the
globals but this is throw-away code and it was easier
that way. I make no apologies for the huge numbers of
anonymous functions. The fact that I can feasibly find
all 64 solutions for an 11x11 board by brute-force
search on my old laptop speaks loudly enough for the
efficiency of the method...
use strict;
use Carp;
use vars qw($min $max @board @soln @toggles);
$min = 1;
$max = shift(@ARGV) || 5;
@board = map [map 0, $min..$max], $min..$max;
foreach my $x ($min..$max) {
foreach my $y ($min..$max) {
push @toggles, ["$x-$y", ret_toggle_square($x, $y)];
}
}
find_soln();
sub find_soln {
if (! @toggles) {
# Solved!
print join " ", "Solution:", map $_->[0], @soln;
print "\n";
}
else {
my $toggle = shift(@toggles);
# Try with, then without
if ($toggle->[1]->()) {
push @soln, $toggle;
find_soln();
pop @soln;
}
if ($toggle->[1]->()) {
find_soln();
}
unshift @toggles, $toggle;
}
}
# Returns a function that switches one square and returns
# true iff the new color is black
sub ret_swap_square {
my ($x, $y) = @_;
#print "Generated with $x, $y\n";
my $s_ref = \($board[$x-1][$y-1]);
return sub {$$s_ref = ($$s_ref + 1) %2;};
}
# Returns a function that toggles one square and its
# neighbours, and returns whether or not any neighbour
# has turned to white and cannot return to black without
# swapping again with $x lower or $x the same and $y lower.
sub ret_toggle_square {
my ($x, $y) = @_;
my @fin_swaps;
my @other_swaps;
unless ($x == $min) {
push @fin_swaps, ret_swap_square($x - 1, $y);
}
if ($x == $max) {
unless ($y == $min) {
push @fin_swaps, ret_swap_square($x, $y - 1);
}
if ($y == $max) {
push @fin_swaps, ret_swap_square($x, $y);
}
else {
push @other_swaps, ret_swap_square($x, $y);
unless ($y == $max) {
push @other_swaps, ret_swap_square($x, $y+1);
}
}
}
else {
unless ($y == $min) {
push @other_swaps, ret_swap_square($x, $y - 1);
}
push @other_swaps, ret_swap_square($x, $y);
push @other_swaps, ret_swap_square($x + 1, $y);
unless ($y == $max) {
push @other_swaps, ret_swap_square($x, $y + 1);
}
}
return sub {
$_->() foreach @other_swaps;
my $ret = 1;
$ret *= $_->() foreach @fin_swaps;
return $ret;
}
}
| [reply]
[d/l] |
|
|
After some thought I realized that I could find several
speedups. The first and biggest is what order the toggles
are searched in. When you choose elements on one side, you
can conclude diagonally. But I have to fill in the entire
board before drawing interesting conclusions. Therefore by
just reording what path you take you move the decision
closer to the conclusion and speed things up.
The other thing that I changed is that I separated the
decision about what paths to take from the toggling. As it
stands for most of the board the decision is obvious
from examining one board element what you have to do. But
I was toggling twice whether or not I needed it. But by
separating out that logic I make the logical structure
simpler, and I believe it is slightly faster.
So here is a much speeded up version of the code:
use strict;
use vars qw($min $max @board @soln @toggles);
$min = 1;
$max = shift(@ARGV) || 5;
@board = map [map 0, $min..$max], $min..$max;
foreach my $x ($min..$max) {
foreach my $y ($min..$max) {
push @toggles, [
[$x, $y],
ret_valid_toggles($x, $y),
ret_toggle_square($x, $y)
];
}
}
# Sort them in an order where conclusions are discovered faster
@toggles = sort {
($a->[0][0] + $a->[0][1]) <=> ($b->[0][0] + $b->[0][1]) or
$a->[0][0] <=> $b->[0][0]
} @toggles;
find_soln();
sub find_soln {
if (! @toggles) {
# Solved!
print join " ", "Solution:", map "$_->[0][0]-$_->[0][1]", @soln;
print "\n";
}
else {
my $toggle = shift(@toggles);
foreach ($toggle->[1]->()) {
if ($_) {
$toggle->[2]->();
push @soln, $toggle;
find_soln();
pop @soln;
$toggle->[2]->();
}
else {
find_soln();
}
}
unshift @toggles, $toggle;
}
}
# Returns a function that toggles one square and its
# neighbours.
sub ret_toggle_square {
my ($x, $y) = @_;
my @to_swap= square_ref($x, $y);
unless ($x == $min) {
push @to_swap, square_ref($x - 1, $y);
}
unless ($y == $min) {
push @to_swap, square_ref($x, $y - 1);
}
unless ($x == $max) {
push @to_swap, square_ref($x + 1, $y);
}
unless ($y == $max) {
push @to_swap, square_ref($x, $y + 1);
}
return sub { $$_ = not $$_ foreach @to_swap; };
}
# Returns a test functions that returns a list of valid
# toggle states to try
sub ret_valid_toggles {
my ($x, $y) = @_;
my @checks;
if ($min < $x) {
push @checks, square_ref($x-1, $y);
}
if ($max == $x) {
if ($min < $y) {
push @checks, square_ref($x, $y-1);
}
if ($max == $y) {
push @checks, square_ref($x, $y);
}
}
if (not @checks) {
return sub {(0, 1)};
}
else {
my $check = shift @checks;
if (not @checks) {
return sub {not $$check};
}
else {
return sub {
my $val = $$check;
(grep {$$_ != $val} @checks) ? () : not $val;
};
}
}
}
# Given x, y returns a reference to that square on the board
sub square_ref {
my ($x, $y) = @_;
return \($board[$x-1][$y-1]);
}
UPDATE
Removed the ret_swap_square() function. Toggles go much faster if each swap is done directly rather than
indirectly through a function call. (Removing 5 extra
function calls per toggle matters...) Also dropped the
unused Carp that snuck in through habit. (This is
throw-away code...) | [reply]
[d/l] |
|
|
use strict;
use vars qw($min $max_x $max_y @board @soln @toggles);
$min = 1;
$max_x = shift(@ARGV) || 5;
$max_y = shift(@ARGV) || $max_x;
# The board starts empty and entries will autovivify. :-)
foreach my $x ($min..$max_x) {
foreach my $y ($min..$max_y) {
push @toggles, [
[$x, $y],
ret_valid_toggles($x, $y),
ret_toggle_square($x, $y)
];
}
}
# Sort them in an order where conclusions are discovered faster
@toggles = sort {
($a->[0][0] + $a->[0][1]) <=> ($b->[0][0] + $b->[0][1]) or
$a->[0][0] <=> $b->[0][0]
} @toggles;
find_soln();
sub find_soln {
if (! @toggles) {
# Solved!
print join " ", "Solution:", map "$_->[0][0]-$_->[0][1]", @soln;
print "\n";
}
else {
my $toggle = shift(@toggles);
foreach ($toggle->[1]->()) {
if ($_) {
$toggle->[2]->();
push @soln, $toggle;
find_soln();
pop @soln;
$toggle->[2]->();
}
else {
find_soln();
}
}
unshift @toggles, $toggle;
}
}
# Returns a function that toggles one square and its
# neighbours.
sub ret_toggle_square {
my ($x, $y) = @_;
my @to_swap= square_ref($x, $y);
unless ($x == $min) {
push @to_swap, square_ref($x - 1, $y);
}
unless ($y == $min) {
push @to_swap, square_ref($x, $y - 1);
}
unless ($x == $max_x) {
push @to_swap, square_ref($x + 1, $y);
}
unless ($y == $max_y) {
push @to_swap, square_ref($x, $y + 1);
}
return sub { $$_ = not $$_ foreach @to_swap; };
}
# Returns a test functions that returns a list of valid
# toggle states to try
sub ret_valid_toggles {
my ($x, $y) = @_;
my @checks;
if ($min < $x) {
push @checks, square_ref($x-1, $y);
}
if ($max_x == $x) {
if ($min < $y) {
push @checks, square_ref($x, $y-1);
}
if ($max_y == $y) {
push @checks, square_ref($x, $y);
}
}
if (not @checks) {
return sub {(0, 1)};
}
else {
my $check = shift @checks;
if (not @checks) {
return sub {not $$check};
}
else {
return sub {
my $val = $$check;
(grep {$$_ != $val} @checks) ? () : not $val;
};
}
}
}
# Given x, y returns a reference to that square on the board
sub square_ref {
my ($x, $y) = @_;
return \($board[$x-1][$y-1]);
}
| [reply]
[d/l] |
|
|
| [reply] |
|
|
OK, I figured I would tackle this problem smarter, not harder. With some success.
First of all note that if you specify the first column, the next column is completely determined by the need to make
the entries in the first column come out black. The
following column is likewise determined by the need to
make the entries in the second column come out black. And
so on to the end. So it all comes down to choosing the
first column correctly so that the n'th column comes out all black. (Or equivalently so that nothing would go into the n+1'th column.)
But note, what happens if you compare what happens if you reverse a single choice in the first column. Well you get a pattern of switching what toggles you make through the rest of the puzzle! And the pattern of switches does not depend upon what other parameters you chose. (The final outcome of toggle/not toggle depends on other patterns, but the pattern of toggles you reverse for a single toggle does not.)
To someone with a math background this looks suspiciously like a linear algebra problem over Z/2. (Z/2 is the set of integers mod 2 - ie 1's and 0's with addition and multiplication mod 2.) In fact it is. For each choice in the first column we have a pattern of switches it would make to toggles in the n+1'st column. If we start with a blank first column we have a pattern of switches we see in the n+1'st column. We want to find a linear combination (that is linear combination in Z/2) of choices in the first column that add up to that base pattern of switches and cancels it out.
Basic linear algebra tells us that the answer set is either empty or a vector space of some dimension over Z/2. So this doesn't tell us why there are any solutions, but it does tell us that if we have a solution, the number of solutions will be a power of 2. Of course we have seen cases where we have 1 solution, 2**2 solutions, 2**2**2 solutions, 2**2**2**2 solutions, and I suspect that 19 has 2**2**2**2**2 solutions. Why that is seen I don't know. I don't even know why there are any solutions.
However if I remain interested enough over the next couple of days, I know I can use linear algebra to find how many solutions to the n*n problem exist. That can be O(n**3) rather than the current exponential beast. If I do that I will probably want to do the general n*m problem. And I am not sure how easy my reasoning will be for others to figure out. So I may not do it.
But if anyone is interested, tell me about it and I will be more likely to take the effort. :-)
| [reply] |
|
|
| [reply] |
We'll have to wait an entire week? :-(
by orkysoft (Friar) on Jan 28, 2001 at 07:01 UTC
|
I wonder how many moves I'll have made by then... ;-)
I'll also take a look at your OO code. I made an OO program a while ago, but I don't seem to comprehend the syntax and mechanisms that well yet. | [reply] |
Re: 5x5 Puzzle (Sol'N)
by Adam (Vicar) on Jan 31, 2001 at 09:48 UTC
|
| [reply] |
|
|
