Lights Out Puzzle

Author

Eric W. Weisstein
October 11, 2002

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Games/LightsOutPuzzle.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/LightsOutPuzzle.html.

Initialization

<<Graphics`Colors`;
<<Graphics`Arrow`;
<<LinearAlgebra`MatrixManipulation`;

Z[{i_,j_},{m_,n_}]:=ReplacePart[ZeroMatrix[m,n],1,Select[{{i-1,j},{i,j-1},{i,j},{i,j+1},{i+1,j}},0<#[[1]]≤m&&0<#[[2]]≤n&]
]

LightsOut[m_List?MatrixQ,opts___]:=DensityGraphics[Reverse[m],
opts,
ColorFunction->(Switch[#,0,Gray,1,Yellow]&),
ColorFunctionScaling->False,
AspectRatio->Automatic,Frame->False]

LightsOutPresses[m_List?MatrixQ,i_List?MatrixQ]:=Module[{},
FoldList[Mod[Plus[Z[#2,Dimensions[m]],#1],2]&,m,Position[i,1]]
]/;Equal@@(Dimensions/@{i,m})

LightsOutFrames[m_List?MatrixQ,p_List?MatrixQ,opts___]:=Module[
{
l=LightsOutPresses[m,p],
pos=Position[p,1],
disks,
i,
h=Dimensions[m][[1]]
},
disks=Disk[{-1/2+#[[2]],h-#[[1]]+1/2},.19]&/@pos;
Append[Table[
LightsOut[l[[i]],Epilog->{Red,disks[[i]]}],
{i,Length[pos]}],
LightsOut[Last[l]]
]
]/;Equal@@(Dimensions/@{p,m})

LightsOutAnimation[m_List?MatrixQ,p_List?MatrixQ,opts___]:=Module[
{
l=LightsOutPresses[m,p],
pos=Position[p,1],
disks,
i,
h=Dimensions[m][[1]]
},
presses=Reverse[NestList[Rest,Reverse[pos],Length[pos]-1]];
disks=Flatten[Function[f,Disk[{-1/2+f[[2]],h-f[[1]]+1/2},.19]]/@#]&/@presses;
Flatten[{LightsOut[First[l]],
Table[
LightsOut[l[[i+1]],Epilog->{{Red,First[disks[[i]]]},Rest[disks[[i]]]}],
{i,Length[pos]}],
LightsOut[Last[l],Epilog->Last[disks]]
}]
]/;Equal@@(Dimensions/@{p,m})

©2005 Wolfram Research, Inc. except for portions noted otherwise

Graphics

Show[GraphicsArray[{
LightsOut[pat={{0,1,0},{1,1,0},{0,1,1}},
Epilog->{Red,Disk[1.5{1,1},.19]}
],
Graphics[{Red,Arrow[{.2,0},{.8,0},HeadLength->.2,HeadWidth->.4]}],
LightsOut[{{0,0,0},{0,0,1},{0,0,1}}]
}]]

Solving the Game

v4.2

LightsOutEqns[l_List?MatrixQ,x_]:=Module[{d=Dimensions[l],i,j},
Sum[Z[{i,j},d]x[i,j],{i,d[[1]]},{j,d[[2]]}]==l]

LightsOutSolve[l_List?MatrixQ,x_]:=Module[{d=Dimensions[l],i,j},
Solve[{Sum[Z[{i,j},d]x[i,j],{i,d[[1]]},{j,d[[2]]}]==l,Modulus==2},
Flatten[Array[x,d]],Mode->Modular]
]

Using Solve (very slow)

LightsOutSolve[l_List?MatrixQ]:=Module[{d=Dimensions[l],x,i,j,soln},
soln=Solve[{Sum[Z[{i,j},d]x[i,j],{i,d[[1]]},{j,d[[2]]}]==l,Modulus==2},
Flatten[Array[x,d]],Mode->Modular];
If[soln=={},{},AllSolutions[soln,d,x]]
]

AllSolutions[soln_,d_,x_]:=Module[{v=Variables[Array[x,d]/.soln],n,i},
n=Length[v];
If[n==0,
Array[x,d]/.soln,
Mod[Array[x,d]/.soln[[1]]/.Table[v[[i]]->#[[i]],{i,n}]&/@Flatten[Outer[List,Sequence@@Table[{0,1},{n}]],n-1],2]
]
]

BackSubstitute[l_List?MatrixQ]:=Module[{d=Dimensions[l],i,j},
Mod[Table[Sum[Z[{i,j},d]l[[i,j]],{i,d[[1]]},{j,d[[2]]}][[i,j]],{i,d[[1]]},{j,d[[2]]}],2]
]

RotationReflectionQ[x_List?MatrixQ,y_List?MatrixQ]:=Module[{r},MemberQ[Flatten[{#,Reverse[#],r=Reverse/@#,Reverse[r]}&/@{x,Transpose[x]},1],y]
]/;Equal@@(Dimensions/@{x,y})

Using LinearSolve and NullSpace (very fast)

LightsOutLinearSolve[l_List?MatrixQ]:=Module[{d=Dimensions[l],i,j,n},
m=Flatten/@Flatten[Table[Z[{i,j},d],{i,d[[1]]},{j,d[[2]]}],1];
ps=LinearSolve[m,Flatten[l],Modulus->2];
ns=NullSpace[m,Modulus->2];
n=Length[ns];
Partition[#,d[[1]]]&/@If[n==0,{ps},
f=Flatten[Outer[List,Sequence@@Table[{0,1},{n}]],n-1];
Mod[ps+Plus@@(ns #)&/@f,2]
]
]

LightsOutSolutionsCount[l_List?MatrixQ]:=Module[{d=Dimensions[l],i,j,n},
m=Flatten/@Flatten[Table[Z[{i,j},d],{i,d[[1]]},{j,d[[2]]}],1];
2^Length[NullSpace[m,Modulus->2]]
]

solns=Table[LightsOutLinearSolve[Table[1,{n},{n}]],{n,15}];//Timing

solns=Table[LightsOutLinearSolve[Table[1,{n},{n}]],{n,25}];//Timing

solns=Table[LightsOutLinearSolve[Table[1,{n},{n}]],{n,30}];//Timing

Number of solutions on squares

Table[LightsOutSolutionsCount[Table[1,{n},{n}]],{n,15}]

Timing[counts=Table[LightsOutSolutionsCount[Table[1,{n},{n}]],{n,30}]]

Timing[counts=Table[LightsOutSolutionsCount[Table[1,{n},{n}]],{n,50}]]

counts={1,1,1,16,4,1,1,1,256,1,64,1,1,16,1,256,4,1,65536,1,1,1,16384,16,1,1,1,1,1024,1048576,1,1048576,65536,16,64,1,1,1,4294967296,1,4,1,1,16,1,1,1073741824,1,256,256};

LightsOutDots[m_List?MatrixQ]:=Module[{
h=Dimensions[m][[1]],
pos=Position[m,1],
},
disks=Disk[{-1/2+#[[2]],h-#[[1]]+1/2},.19]&/@pos;
LightsOut[Table[0,Evaluate[Sequence@@List/@Dimensions[m]]],Epilog->{Red,disks}]
]

Show[GraphicsArray[Sequence@@Partition[#,5,5,{1,1},{}]&/@Map[LightsOutDots,Take[solns,{2,7}],{2}]],
PlotRange->All]

Map[MatrixForm,uniqsolns=Union[#,SameTest->RotationReflectionQ]&/@Take[solns,18],{2}]//ColumnForm

Length/@uniqsolns

Length/@uniqsolns

Show[GraphicsArray[Sequence@@Partition[#,5,5,{1,1},{}]&/@Map[LightsOutDots,Take[uniqsolns,{2,7}],{2}]],
PlotRange->All]

Number of presses on squares

allpresses=Map[Count[#,1,{2}]&,solns,{2}];//Timing

presses=Min/@allpresses

presses=Min/@allpresses

Figures

Show[LightsOut[solns[[2,1]]]]

Enumeration

Matrix Form

Map[MatrixForm,solns,{2}]//ColumnForm

v5.0

<<LinearAlgebra`MatrixManipulation`;

Z[{i_,j_},{m_,n_}]:=ReplacePart[ZeroMatrix[m,n],1,Select[{{i-1,j},{i,j-1},{i,j},{i,j+1},{i+1,j}},0<#[[1]]≤m&&0<#[[2]]≤n&]
]

LightsOutReduce[l_List?MatrixQ,x_]:=Module[{d=Dimensions[l],i,j},
Reduce[And@@((#==0||#==1)&/@Flatten[Array[x,d]])&&And@@Flatten[Table[Mod[Sum[Z[{i,j},d]x[i,j],{i,d[[1]]},{j,d[[2]]}][[i,j]],2]==l[[i,j]],{i,d[[1]]},{j,d[[2]]}]],Flatten[Array[x,d]]]
]

LightsOutReduce[Table[1,{2},{2}],x]

LightsOutReduce[Table[1,{3},{3}]]//Timing

Solve[{LightsOutEqns[Table[1,{4},{4}],x],Modulus==2},Flatten[Array[x,{4,4}]],Mode->Modular]

Example

LightsOutSolve[{{0,1,0},{1,1,0},{0,1,1}}]

l={{0,1,0},{1,1,0},{0,1,1}};

Show[GraphicsArray[LightsOutFrames[
{{0,1,0},{1,1,0},{0,1,1}},
{{1,1,1},{0,0,0},{0,0,1}}]]]

Show[GraphicsArray[LightsOut/@LightsOutPresses[
{{0,1,0},{1,1,0},{0,1,1}},
{{1,1,1},{0,0,0},{0,0,1}}]]]

Show/@Flatten[LightsOutAnimation[
{{0,1,0},{1,1,0},{0,1,1}},
{{1,1,1},{0,0,0},{0,0,1}}]]

No Solution

Show[LightsOut[{{1,0,0},{0,0,0}}]]

LightsOutReduce[{{1,0,0},{0,0,0}}]

LightsOutSolve[{{1,0,0},{0,0,0}}]

Solvable

arrays[m_,n_]:=Partition[#,m]&/@Flatten[Outer[List,Sequence@@Table[{0,1},{m n}]],m n-1]

Solvable 2×1

solns=Select[arrays[2,1],LightsOutSolve[#]≠{}&]

Length[%]

2^1

Solvable 2×2

solns=Select[arrays[2,2],LightsOutSolve[#]≠{}&]

Length[%]

2^4

Solvable 3×1

solns=Select[arrays[3,1],LightsOutSolve[#]≠{}&]

Length[%]

2^3

Solvable 3×2

solns=Select[arrays[3,2],LightsOutSolve[#]≠{}&]

Show[GraphicsArray[Partition[LightsOut/@solns,4]]]

Multiple solutions

LightsOutReduce[Table[1,{2},{3}],x]

rules=ToRules[x[1,1]==0&&x[1,2]==0&&x[1,3]==1&&x[2,1]==1&&x[2,2]==0&&x[2,3]==0||x[1,1]==0&&x[1,2]==1&&x[1,3]==1&&x[2,1]==0&&x[2,2]==1&&x[2,3]==1||x[1,1]==1&&x[1,2]==0&&x[1,3]==0&&x[2,1]==0&&x[2,2]==0&&x[2,3]==1||x[1,1]==1&&x[1,2]==1&&x[1,3]==0&&x[2,1]==1&&x[2,2]==1&&x[2,3]==0]

Show[GraphicsArray[LightsOutFrames[{{1,1,1},{1,1,1}},#]&/@(Array[x,{2,3}]/.{rules})]]

Solvable 3×3

Length[solns=Select[arrays[3,3],LightsOutSolve[#]≠{}&]]

2^9

Solvable 4×3

Length[solns=Select[arrays[4,3],LightsOutSolve[#]≠{}&]]

2^12

Solvable 4×4

(soln=LightsOutReduce[Table[1,{4},{4}],x])//Timing