# How can I get the unique solution?

The eight queens puzzle has 92 distinct solutions. If solutions that differ only by the symmetry operations of rotation and reflection of the board are counted as one, the puzzle has 12 solutions.

My code gives 24 unique solutions, how can I fix it, or is there any better method?

Length[sols=Cases[Permutations[Range[8]],{a_,b_,c_,d_,e_,f_,g_,h_}/;
a+1!=b+2!=c+3!=d+4!=e+5!=f+6!=g+7!=h+8 && a-1!=b-2!=c-3!=d-4!=e-5!=f-6!=g-7!=h-8]]

Length[DeleteDuplicates[sols, #+#2==Table[9,8]||#==Reverse[#2]||Reverse[#]+#2==Table[9,8]&]]

• Have you counted rotations? Dec 4, 2017 at 10:56
• About "better method"... If you means faster, just hardcode the answer. Dec 4, 2017 at 10:59
• I don't like a hardcode answer, efficiency is not important here. Dec 4, 2017 at 11:10
• PermutationProduct may be useful: Try it online! Dec 4, 2017 at 11:11
• Alternatively you can create the matrix and use Transpose (which is equivalent to the PermutationProduct approach above). Dec 4, 2017 at 11:20

Length[sols = Cases[
Permutations[Range[8]], {a_, b_, c_, d_, e_, f_, g_, h_} /;
a + 1 != b + 2 != c + 3 != d + 4 != e + 5 != f + 6 != g + 7 != h + 8 &&
a - 1 != b - 2 != c - 3 != d - 4 != e - 5 != f - 6 != g - 7 != h - 8
]]


92

To make reasoning about symmetries a bit easier let's write a function to convert to matrix representation

QueenMatrix[sol_] := Normal@SparseArray[Thread[Transpose[{Range[8], sol}] -> 1]]


which means we can now visualize our solutions, e.g.

MatrixPlot@QueenMatrix@sols[[1]]


Now find all the symmetries that we can apply in terms of the matrix representation:

g = MatrixPlot[#1, PlotLabel -> #2] & @@@
With[{m = QueenMatrix@sols[[1]]},
{{m, "Original"},
{Reverse@m, "Mirror Rows"},
{Reverse /@ m, "Mirror Columns"},
{Reverse[Reverse /@ m], "Rotate 180\[Degree]"},
{Transpose[m], "Mirror at Main Diagonal"},
{Table[m[[i, Length[m] - j + 1]], {j, Length[m]}, {i,Length[m]}], "Rotate Left 90\[Degree]"},
{Table[m[[Length[m] - i + 1, j]], {j, Length[m]}, {i,Length[m]}], "Rotate Right 90\[Degree]"},
{Table[m[[Length[m] - i + 1, Length[m] - j + 1]], {j, Length[m]}, {i,Length[m]}], "Mirror at Anti-Diagonal"}
}
] // Partition[#, 4] & // GraphicsGrid


After verifying they all make sense we can turn this into a function which checks if two solution matrices fall under any of those symmetry relations:

CheckMatrixSymmetries[mat1_, mat2_] := EqualTo[#2] /@ {
Reverse@#,
Reverse /@ #,
Reverse[Reverse /@ #],
Transpose[#],
Table[#[[i, Length[#] - j + 1]], {j, Length[#]}, {i, Length[#]}],
Table[#[[Length[#] - i + 1, j]], {j, Length[#]}, {i, Length[#]}],
Table[#[[Length[#] - i + 1, Length[#] - j + 1]], {j, Length[#]}, {i, Length[#]}]
} &[mat1, mat2] // Apply[Or]


Now we can do the original case reduction with DeleteDuplicates in terms of our matrix symmetry checker

Length[
sols3 = DeleteDuplicates[
sols,
CheckMatrixSymmetries @@ (QueenMatrix /@ {#1, #2}) &
]
]


12

to find the unique solutions

Partition[MatrixPlot@*QueenMatrix /@ sols3, 4] // GraphicsGrid


## Visualization of the solution symmetry group

As a bonus let's look at the adjacency graph created by our CheckMatrixSymmetries function with the help of GraphPlot:

GraphPlot[
(* creates our adjacency matrix *)
Outer[Boole@*CheckMatrixSymmetries, #, #, 1] &[QueenMatrix /@ sols],
VertexLabeling -> True,
VertexRenderingFunction -> (Inset[
MatrixPlot[
QueenMatrix@sols[[#2]],
FrameTicks -> None, Mesh -> All, Frame -> False, ImageSize -> 40
],
#1
]&),
ImageSize -> 660
]


You can see that most unique solutions belong to a group of eight similar solutions obtained by our mirroring and rotation symmetries. The only exception being the last group of four, which due to their inherent 180 degree rotation symmetry collapses to only four different solutions. Those are also my favorite! :)

Your solutions give the rank of the Queen for each file. So, a simple rotation corresponds to a permutation of {8, 7, 6, 5, 4, 3, 2, 1} by the solution:

rotate[solution_] := Permute[Reverse @ Range[8], solution]


Let's see this in action:

sols[[1]]
rotate @ sols[[1]]


{1, 5, 8, 6, 3, 7, 2, 4}

{8, 2, 4, 1, 7, 5, 3, 6}

Or using a variant of @ThiesHeideke's visualization function:

QueenMatrix[sol_] := MatrixPlot[
Mesh->True,
DataReversed->{True,False}
]

QueenMatrix[sol[[1]]]->QueenMatrix[rotate@sol[[1]]]


Next, a reflection corresponds to a reverse:

reflect[solution_] := Reverse[solution]


Another visualization:

QueenMatrix[sols[[1]]] -> QueenMatrix[reflect[sols[[1]]]]


So, using rotate and reflect we can canonicalize each solution:

canon[solution_] := First @ Sort @ Join[
NestList[rotate, solution, 3],
NestList[rotate, reflect@solution, 3]
]


The unique solutions are then given by:

DeleteDuplicates[canon /@ sols]
% //Length


{{1, 5, 8, 6, 3, 7, 2, 4}, {1, 6, 8, 3, 7, 4, 2, 5}, {2, 4, 6, 8, 3, 1, 7, 5}, {2, 5, 7, 1, 3, 8, 6, 4}, {2, 5, 7, 4, 1, 8, 6, 3}, {2, 6, 1, 7, 4, 8, 3, 5}, {2, 6, 8, 3, 1, 4, 7, 5}, {2, 7, 3, 6, 8, 5, 1, 4}, {2, 7, 5, 8, 1, 4, 6, 3}, {3, 5, 2, 8, 1, 7, 4, 6}, {3, 5, 8, 4, 1, 7, 2, 6}, {3, 6, 2, 5, 8, 1, 7, 4}}

12

I think we should consider a more general case.

How to reduce the elements of list by a Group.

I've written such a function before.

cyc2rul[Cycles[M_]]:=Flatten[Rule@@@Partition[#,2,1,1]&/@M]
Options[cycReduce]={Orderless->True};
cycReduce[inlist_,cyc_,OptionsPattern[]]:=
Block[{i=1,list=inlist,l,rul,del},
l=Length[Transpose@@cyc];
rul=cyc2rul[cyc];
Catch@Quiet@While[i>0,
del=Rest@NestList[#/.rul&,Check[list[[i++]],Throw[list]],l-1];
del=If[OptionValue[Orderless],Sort/@del,del];
list=DeleteCases[Alternatives@@del][list];
]
]


First encode the sols to the board numbers.

sols=Select[Permutations[n=Range@8],And@@Unequal@@@{#+n,#-n}&];
enc=MapIndexed[#+8(First[#2]-1)&,#]&/@sols


Numbered from the top left corner, {1,5,8,6,3,7,2,4} becomes {1,13,24,30,35,47,50,60} now.

There're 4 symmetrical groups and 1 rotation group.

MatrixForm[m=Array[8(#1-1)+#2&,{8,8}]]
groups={
{m,Reverse/@m},           (*"Mirror at Columns"*)
{m,Reverse@m},            (*"Mirror at Rows"*)
{m,Transpose[m]},         (*"Mirror at Main Diagonal"*)
{m,ConjugateTranspose[m]},(*"Mirror at Conjugate Diagonal"*)
NestList[Transpose@Reverse@#&,m,3](*"Rotate"*)
};


Then do the group reduce and get:

toC[mat_]:=Cycles[Union[Flatten[Transpose[mat,{3,1,2}]/.{a_,a_}->Nothing,1],SameTest->(Sort@#1==Sort@#2&)]];
Length[redu=Fold[cycReduce,enc,toC/@groups]]


Wait...there're 14 solutions...what's going wrong.

dec=MapIndexed[#+8(1-First[#2])&,#]&/@redu
{{1,5,8,6,3,7,2,4},{1,6,8,3,7,4,2,5},{2,4,6,8,3,1,7,5},
{2,5,7,1,3,8,6,4},{2,5,7,4,1,8,6,3},{2,6,1,7,4,8,3,5},
{2,6,8,3,1,4,7,5},{2,7,3,6,8,5,1,4},{2,7,5,8,1,4,6,3},
{3,5,7,1,4,2,8,6},{3,5,8,4,1,7,2,6},{3,6,2,5,8,1,7,4},
{3,6,2,7,1,4,8,5},{3,6,2,7,5,1,8,4}
}


Last two havn't been reduced, seems I lost some symmetries.

cycReduce[list,{cyc1,cyc2...}] != Fold[cycReduce,list,{cyc1,cyc2...}]

Glad to see if anyone can help solve this problem.

Reduce lists under permutation group

• I think the problem is with ConjugateTranspose, which doesn't "mirror at conjugate diagonal" but does a regular transpose and then takes the complex conjugate (which does nothing for an all-real matrix). The least verbose substitute I can find is Reverse@Transpose@Reverse. May 28, 2020 at 20:58