Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
PerlMonks  

5x5 Puzzle

by Adam (Vicar)
on Jan 27, 2001 at 04:30 UTC ( [id://54682]=CUFP: print w/replies, xml ) Need Help??

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() );

Replies are listed 'Best First'.
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; } }
      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...)

        Must...stop...tinkering...

        Anyways the above was so darned close to working for rectangular boards that I just had to extend it to cover that. It defaults to 5x5. If you pass one argument it does nxn. 2 and it does nxm. Still just brute force.

        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]); }
      Thinking about the nature of the beast, I'd bet on powers of 4 having extra solutions and the squares that that have 4xN+1 sides (5, 9, 13, 17) having extra solutions as well. I think the 16x16 will have at least 2**16 solutions since it is actually a 2x2 of 4x4s and the 4x4 had 2**4 solutions. It also wouldn't suprise me that 13x13 had 8**8 solutions.

      --
      $you = new YOU;
      honk() if $you->love(perl)

        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. :-)

        Actually there is but one solution of size 13 but 16 again of size 14.

        Note that choosing the values for one side suffice to lay out the rest of the board. I think that has something to do with the pattern.

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.

Re: 5x5 Puzzle (Sol'N)
by Adam (Vicar) on Jan 31, 2001 at 09:48 UTC
    For those people who have not run tilly's code, a solution set for the above puzzle is...

    ...in an html comment in this node.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://54682]
Approved by root
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others about the Monastery: (3)
As of 2024-04-19 22:03 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found