There's more than one way to do things PerlMonks

### Lights out puzzle

by ambrus (Abbot)
 on Nov 28, 2011 at 09:46 UTC Need Help??

Here's a quick Monday morning puzzle.

You have a 14x14 rectangular game board except that the last 7 fields of the last row are missing. Each field has a lamp, and a button that toggles the lamps on that field and each of its neighbours in a cardinal direction, altogether at most five lamps. At the start, all lights are lit. Find out which buttons to push to unlight all lights.

Why I like this puzzle is:

brute forcing won't work, but there's an intermediate algorithm that's fast enough for this board size but easier to code than the general algorithm that solves this for larger board sizes.

Solution:

```0 1 0 1 0 0 0 1 0 1 0 0 0 0
0 0 1 0 0 1 0 0 1 0 0 1 1 1
1 1 0 1 0 0 0 1 0 1 0 1 0 1
1 1 0 0 0 0 0 0 0 0 1 1 0 1
0 0 0 0 1 1 1 0 1 1 1 0 1 1
0 0 1 0 1 0 1 1 1 0 0 0 1 0
1 0 0 1 1 0 0 0 0 1 0 0 1 1
0 0 1 1 0 0 0 0 1 0 0 0 0 1
0 0 1 0 1 1 1 0 0 1 1 1 1 1
1 0 1 0 1 0 1 0 1 1 0 0 0 0
0 1 1 1 1 0 1 1 1 0 1 0 0 0
1 1 1 0 0 1 0 0 0 0 0 0 1 1
1 1 0 1 1 0 1 0 0 1 0 0 1 1
0 0 0 1 1 0 0

Update: here's an example. Suppose we have a 3x4 board with the last 1 field of the last row missing. At the start, it looks like this, all lamps lit:

``` ****
****
***
Now we press the button on the bottom left field so three lights go off:
``` ****
.***
..*
then press the button above that so two lights turn back on but two lights go off:
``` .***
*.**
*.*
now press the second button in the bottom row:
``` .***
****
.*.
now the button above that one:
``` ..**
...*
...
finally press the top right button:
```....
....
...
and all the lights are off, so we've solved this small board.

Replies are listed 'Best First'.
Re: Lights out puzzle
by salva (Abbot) on Nov 28, 2011 at 11:26 UTC
Perl may not be the right tool to solve that problem.

A generic solution using GNU-Prolog (that has a very fast finite domain constraint solver):

```lights_on(Len, W, Sol) :-
length(Sol, Len),
fd_domain_bool(Sol),
make_constraints(0, Len, W, Sol),
fd_labeling(Sol).

print_sol(W, Sol) :-
length(L, W),
(   append(L, T, Sol)
->  write(L),
nl,
print_sol(W, T)
;   write(Sol),
nl ).

make_constraints(Ix, Len, W, Sol) :-
(   Ix == Len
->  true
;   make_constraint(Ix, W, Sol),
Ix1 is Ix + 1,
make_constraints(Ix1, Len, W, Sol)).

nth0(Ix, L, Var) :-
Ix1 is Ix + 1,
nth(Ix1, L, Var).

up(Ix, W, Sol, Var) :-
Ix1 is Ix - W,
(   nth0(Ix1, Sol, Var)
->  true
;   Var = 0 ).

down(Ix, W, Sol, Var) :-
Ix1 is Ix + W,
(   nth0(Ix1, Sol, Var)
->  true
;   Var = 0 ).

left(Ix, W, Sol, Var) :-
Ix1 is Ix - 1,
(   Ix1 // W =:= Ix // W,
nth0(Ix1, Sol, Var)
->  true
;   Var = 0).

right(Ix, W, Sol, Var) :-
Ix1 is Ix + 1,
(   Ix1 // W =:= Ix // W,
nth0(Ix1, Sol, Var)
->  true
;   Var = 0).

make_constraint(Ix, W, Sol) :-
nth0(Ix, Sol, This),
up(Ix, W, Sol, Up),
down(Ix, W, Sol, Down),
right(Ix, W, Sol, Right),
left(Ix, W, Sol, Left),
This ## Up ## Down ## Right ## Left.

test :-
W = 14,
H = 14,
Missing = 7,
Len is W * H - Missing,
lights_on(Len, W, Sol),
print_sol(W, Sol).

It solves any problem where N < 20 in a few seconds.

This is a nice solution.

I too was thinking that perl might not be the best tool for solving this, but for an entirely different reason. I wasn't thinking of this puzzle as a constraint satisfaction problem. Of course not, since it's

linear,
which is what my second solution uses.

But once you mentioned it, viewing as a constraint satisfaction problem also makes sense. After all,

like I noticed for my first solution, once you decide about the buttons of the first row, they determine all the other buttons easily. So much that if you write the program as a constraint program in the natural way, the constraint solver can also determine all the buttons from the ones in the first row, thus a constraint solution must be at least as fast as my first solution.

Update: for reference, the last time salva has surprised me with a nice solution using a finite domain constraint solver was Re^4: Seven by seven farming puzzle.

Update: I ran the solution for (20, 20, 2). Your prolog solution took two and a half minutes (I have modified the printing part somewhat, but used GNU prolog). My perl solution took 40 seconds. So my opinion is that this prolog+finite-domain solution is fast enough. (Update: the same solution ran in SWI prolog is riddiculously slow though.)

Re: Lights out puzzle (perl solution)
by ambrus (Abbot) on Nov 28, 2011 at 21:41 UTC

Here's a solution written in perl, then some explanation on how it works.

```use 5.014; use warnings;
our(\$R, \$C, \$M) = (14, 14, 7);
if (@ARGV) {
3 == @ARGV or die "Usage: lights R C M";
(\$R, \$C, \$M) = map int, @ARGV;
}
my @c = ((\$C) x (\$R-1), \$C-\$M);
my @m = map { (1<<\$_)-1 } @c;
T: for my \$t (0 .. \$m[0]) {
my @b; my @l = @m;
for my \$r (0 .. \$R-1) {
my \$b = \$b[\$r] = \$r <= 0 ? \$t : \$m[\$r] & \$l[\$r-1];
\$r+1 < \$R and \$l[\$r+1] ^= \$m[\$r+1] & \$b;
\$l[\$r] ^= \$m[\$r] & (\$b<<1 ^ \$b ^ \$b>>1);
0 <= \$r-1 and \$l[\$r-1] ^= \$m[\$r-1] & \$b;
}
0 == \$l[\$R-1] && 0 == \$l[\$R-2] or next T;
say "Found solution: [";
for my \$r (0 .. \$R-1) {
for my \$c (0 .. \$C-1) {
print " ", (\$c[\$r] <= \$c ? " " : \$b[\$r]>>\$c & 1 ? "P" : ".
+");
}
if (0) {
print "  > ";
for my \$c (0 .. \$C-1) {
print " ", (\$c[\$r] <= \$c ? " " : \$l[\$r]>>\$c & 1 ? "*"
+: ".");
}
}
say "";
}
say "]";
}
say "done searching (R=\$R, C=\$C, M=\$M).";
__END__

Example output.

```Found solution: [
. P . P . . . P . P . . . .
. . P . . P . . P . . P P P
P P . P . . . P . P . P . P
P P . . . . . . . . P P . P
. . . . P P P . P P P . P P
. . P . P . P P P . . . P .
P . . P P . . . . P . . P P
. . P P . . . . P . . . . P
. . P . P P P . . P P P P P
P . P . P . P . P P . . . .
. P P P P . P P P . P . . .
P P P . . P . . . . . . P P
P P . P P . P . . P . . P P
. . . P P . .
]
done searching (R=14, C=14, M=7).

The idea of this code is that once you know what buttons to push in the first row, it's trivial to compute what buttons you should push in all the other rows. You go from top to bottom, and in each row you press the buttons where the light in the row just above is lit.

So our algorithm (the algorithm I was alluding to in the spoiler of the original post) is to simply try out all combinations of buttons to press in the top row and see which ones work. Most of them won't work because some lights will remain lit in the bottom two rows.

A trick that makes the code shorter is that we're representing a row of lights or buttons as bits in a single integer. This way, the flipping of lights is easier to describe because fewer loops are needed. This is still not the shortest way to write code, because I wanted to keep it understandable.

To understand the code, comment out the line with next T;, enable the branch that dumps @c, and run for smaller inputs such as 4 3 1 or 6 5 2.

Now quick someone bribe zentara to put a TK interface to this... and I'll get nothing done for the next week. :)
Re: Lights out puzzle
by marto (Bishop) on Nov 28, 2011 at 09:48 UTC

My immediate reaction would be to press the button on the wall socket/power source, no power to the board, no lights :P

Re: Lights out puzzle
by choroba (Bishop) on Nov 28, 2011 at 18:09 UTC
Here's a quick Monday morning puzzle.
Quick?? I spent several hours on it, not being able to come with anything better then this:
```#!/usr/bin/perl

package Board;

use warnings;
use strict;

use constant _CROSS => ([0, 0], [-1, 0], [1, 0], [0, -1], [0, 1]);

my %click;

sub new {
my (\$class, \$value) = @_;
my \$board = [];
@\$board = map [(\$value) x 14], 1 .. 13;
push @\$board, [(\$value) x 7];
\$click{refaddr(\$board)} = [map ([(0) x 14], 1 .. 13), [(0) x 7]];
bless \$board, \$class;
return \$board;
} # new

sub finished {
my \$board = shift;
return not grep {grep \$_, @\$_} @\$board;
} # finished

sub show {
my \$board = shift;
for my \$row (@\$board) {
return unless defined \$row;
print map \$_ ? '*' : defined \$_ ? '.' : '', @\$row;
print "\n";
}
} # show

sub _cross {
my (\$board, \$x, \$y) = @_;
my @cross = grep {
\$_->[0] >= 0
and \$_->[1] >= 0
and ref \$board->[\$_->[1]]
and defined \$board->[\$_->[1]][\$_->[0]]
} map [\$x + \$_->[0], \$y + \$_->[1]],
_CROSS;
return @cross;
} # _cross

sub toggle {
my (\$board, \$x, \$y) = @_;
my \$old = \$board->[\$y][\$x];
return unless defined \$old;
\$board->[\$y][\$x] = \$old eq 1 ? 0 : 1;
} # toggle

sub at {
my (\$board, \$x, \$y) = @_;
return if \$x < 0
or \$y < 0
or not ref \$board->[\$y]
or not defined \$board->[\$y][\$x];
return \$board->[\$y][\$x];
} # at

sub around {
my (\$board, \$x, \$y) = @_;
return map \$board->at(@\$_), \$board->_cross(\$x, \$y);
} # around

sub click {
my (\$board, \$x, \$y) = @_;
return unless defined \$board->[\$y][\$x];
+];
\$board->toggle(\$_->[0], \$_->[1])
for \$board->_cross(\$x, \$y);
} # click

sub row {
my (\$board, \$y) = @_;
return @{ \$board->[\$y] };
} # row

sub clean {
my \$board = shift;
for my \$y (1 .. 13) {
for my \$x (0 .. 13) {
\$board->click(\$x, \$y) if \$board->at(\$x, \$y-1);
}
}
} # clean

sub lastrow {
my \$board = shift;
return map \$board->at(\$_, 13 - (\$_ > 6)), (0 .. 13);
} # lastrow

sub history {
my \$board = shift;
my @h = @{ \$click{refaddr(\$board)} };
print map (\$_ ? 1 : '0', @\$_),"\n" for @h;
} # history

##########################################################

package main;

use warnings;
use strict;

sub stringify {
return join q[], map \$_ ? 1 : 0, @_;
} # stringify

if (@ARGV) {
my \$b = Board->new(1);
open my \$IN, '<', \$ARGV[0] or die \$!;
while (<\$IN>) {
chomp;
for my \$i (0 .. length()-1 ) {
\$b->click(\$i, \$.-1) if substr \$_, \$i, 1;
}
\$b->show;
}

} else {
my %cache;
for my \$i (0 .. 13) {
my \$b = Board->new(0);
\$b->click(\$i, 0);
\$b->clean;
my \$k = stringify(\$b->lastrow);
\$cache{\$k} = \$i;
}

delete \$cache{'0' x 14};

my \$board = Board->new(1);
while (1) {
\$board->clean;
my \$last = stringify(\$board->lastrow);
if (exists \$cache{\$last}) {
\$board->click(\$cache{\$last}, 0);
} elsif (not \$board->finished) {
\$board->click(int rand 13, int rand 2) for 1 .. 1 + int ra
+nd 5;
} else {
last;
}
}
\$board->history;
}
It's a bit randomized, but usually runs under 2 seconds on my machine. Run it with a filename as an argument to check the solution saved in the file.
Update: Removed forgotten debugging line.
Here are some comments on how it works:
The code clears all the lines except for the last one (clean) the simple way: if there is a light, click underneath. The last line (or, better to say, broken line, i.e. the last line plus the remaining half of the previous one) is then solved half-randomly. At the beginning, I cache how clicking on the top line influences the last line, but only for one click on the line (i.e. I only know what the last line will be after having one light lit). Therefore, I have to click randomly until I get a cached position that I can solve. This works well for size 14, but the time doubles for each +2 in size, so size 20 is already too slow. Caching more positions could be added easily (like clicking two times), but I am not sure how much time it would take to cache all possible combinations on the first line.
Because the order of clicks is not important, I keep a separate map of the board with 0 for the even clicks and 1 for the odd ones. This separate board is the output of the program.

I changed the definition of the show and toggle methods like this:

```sub show {
my \$board = shift;
print "\e[H";
for my \$row (@\$board) {
return unless defined \$row;
print map \$_ ? '*' : defined \$_ ? '.' : '', @\$row;
print "\e[K\n";
}
print "\e[J";
use Time::HiRes "sleep";
sleep(6e-3);
} # show

sub toggle {
my (\$board, \$x, \$y) = @_;
my \$old = \$board->[\$y][\$x];
return unless defined \$old;
\$board->[\$y][\$x] = \$old eq 1 ? 0 : 1;
} # toggle

and now I can see the lights being chased down to the bottom of the board. Looks nice.
Yes, in fact, I did something similar for debugging :-)
Re: Lights out puzzle
by Ratazong (Monsignor) on Nov 28, 2011 at 10:02 UTC

Good Monday morning also to you, ambrus!

Lights out is really nice. Especially the simplicity of the solution: if it is solvable (not all board-configurations are), it takes at maximum n*m turns on an n-by-m board. However when I try it manually, I need many, many more (if I ever finish it) ...

Rata (who's only adventure into VB-for-Excel-programming was a 5x5 - version of this game)

Re: Lights out puzzle (non-perl solution)
by ambrus (Abbot) on Nov 29, 2011 at 14:38 UTC

Here's a non-perl solution, with explanation.

For larger boards, this one is much faster than my program above. (You could try (29, 30, 2) or (39, 40, 2) as large examples where there's a unique button combination this program finds very quickly but that would take ages to found with the previous program.)

We're using the GAP computer algebra system as a tool. Download this program and save it as say lights.g. Load it in a GAP session either by giving the filename as a command-line argument when you start gap, or by executing the statement Read("lights.g");. Then try lightout(14, 14, 7); to get the solution to the original challenge.

In general, lightout(r, c, m); will show one solution for a board with r rows and c columns with the last m cells of the last column missing. The three arguments work the same as in my previous solution, but this time I print only one solution, not all of them.

```# lights out, see http://www.perlmonks.com/?node_id=940327

lightout := function(nr, nc, nm)
local onbd, forbd, linbd, nlin, wirelin, lightlin, sollin, solbd;
onbd := function(r, c)
return 1 <= r and r <= nr and 1 <= c and c <= nc and
(r < nr or c <= nc - nm);
end;
forbd := function(f)
local r, c;
for r in [1 .. nr - 1] do
for c in [1 .. nc] do
f(r, c);
od;
od;
for c in [1 .. nc - nm] do
f(nr, c);
od;
end;
linbd := List([1 .. nr], c -> []);
nlin := 0;
forbd(function (r, c)
nlin := nlin + 1;
linbd[r][c] := nlin;
end);
wirelin := NullMat(nlin, nlin, GF(2));
forbd(function (r, c)
local d, r1, c1;
for d in [[0, 0], [0, 1], [0, -1], [1, 0], [-1, 0]] do
r1 := r + d[1]; c1 := c + d[2];
if onbd(r1, c1) then wirelin[linbd[r][c]][linbd[r1][c1]] := Z(
+2); fi;
od;
end);
lightlin := List([1 .. nlin], c -> Z(2)); # all lamps lit
ConvertToVectorRep(lightlin);
#sollin := lightlin / wirelin;
sollin := SolutionMat(wirelin, lightlin);
solbd := List(linbd, v -> sollin{v});
Print("Found a solution for (R=", nr, ", C=", nc, ", M=", nm, ")\n");
Display(solbd);
end;

# try this for example:
#lightout(14, 14, 7);

Example session:

```gap> lightout(14, 14, 7);
Found a solution for (R=14, C=14, M=7)
. 1 . 1 . . . 1 . 1 . . . .
. . 1 . . 1 . . 1 . . 1 1 1
1 1 . 1 . . . 1 . 1 . 1 . 1
1 1 . . . . . . . . 1 1 . 1
. . . . 1 1 1 . 1 1 1 . 1 1
. . 1 . 1 . 1 1 1 . . . 1 .
1 . . 1 1 . . . . 1 . . 1 1
. . 1 1 . . . . 1 . . . . 1
. . 1 . 1 1 1 . . 1 1 1 1 1
1 . 1 . 1 . 1 . 1 1 . . . .
. 1 1 1 1 . 1 1 1 . 1 . . .
1 1 1 . . 1 . . . . . . 1 1
1 1 . 1 1 . 1 . . 1 . . 1 1
. . . 1 1 . .
gap>

Here, we are representing the game as the matrix wirelin over GF(2). The element wirelin[u][v] is 1 if and only if the button on field u toggles the light on field v. (Here, the fields on the game board are indexed with single integers assigned sequentially. The matrix wirelin is, incidentally, symmetric.) Thus, if b is a vector of GF(2) elements telling which buttons you push, b*wirelin will be the vector of which lights are toggled. To determine how to toggle all lights, we thus just have to solve the linear equation b*wirelin = lightlin over GF(2), where lightlin is an all-one vector.

Now solving a linear equation over GF(2) is something apparently very few libraries can do, which is why I chose GAP which has a function for this.

This solution thus works in time polynomial in the size of the game board. Also, all the heavy loops are done inside the GAP core, which is optimized well. (Of course, it's probably possible to make even faster programs if you want to solve very large boards, but I don't think we'll need that.) No wonder for large boards, say 30x30, it finishes much faster than my previous solution, as that would have to try 2**30 starting positions.

Update: this might not be very idiomatic GAP. I don't have much practice in programming GAP, in particular I don't know the libraries enough and also I can't wrap my head around one-based indexing of lists.

Now solving a linear equation over GF(2) is something apparently very few libraries can do

That's quite easy to implement, so easy that, well... see Algorithm::GaussianElimination::GF2.

Using that module, the Lights On problem gets reduced to:

```use strict;
use warnings;

use Algorithm::GaussianElimination::GF2;

use 5.010;

(@ARGV >= 1 and @ARGV <= 2) or die "Usage:\n  \$0 len [width]\n\n";

my (\$len, \$w) = @ARGV;

unless (defined \$w) {
\$w = int sqrt(\$len);
\$w++ unless \$w * \$w == \$len;
}

my \$a = Algorithm::GaussianElimination::GF2->new;

for my \$ix (0..\$len-1) {
my \$eq = \$a->new_equation;

\$eq->b(1);
\$eq->a(\$ix, 1);
my \$up = \$ix - \$w;
\$eq->a(\$up, 1) if \$up >= 0;
my \$down = \$ix + \$w;
\$eq->a(\$down, 1) if \$down < \$len;
my \$left = \$ix - 1;
\$eq->a(\$left, 1) if \$left % \$w + 1 != \$w;
my \$right = \$ix + 1;
\$eq->a(\$right, 1) if \$right % \$w and \$right < \$len;
}

my (\$sol, @base0) = \$a->solve;

if (\$sol) {
my @sol = @\$sol;
while (@sol) {
my @row = splice @sol, 0, \$w;
say "@row";
}

for my \$sol0 (@base0) {
say "sol0:";
my @sol0 = @\$sol0;
while (@sol0) {
my @row = splice @sol0, 0, \$w;
say "@row";
}
}
}
else {
say "no solution found"
}
On my computer the 14x14-7 problem gets solved in 0.06 seconds.

Create A New User
Node Status?
node history
Node Type: perlmeditation [id://940327]
Approved by marto
Front-paged by Corion
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (4)
As of 2018-02-22 19:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
When it is dark outside I am happiest to see ...

Results (298 votes). Check out past polls.

Notices?