5
$\begingroup$

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]&]]
$\endgroup$
7
  • $\begingroup$ Have you counted rotations? $\endgroup$
    – user202729
    Dec 4, 2017 at 10:56
  • $\begingroup$ About "better method"... If you means faster, just hardcode the answer. $\endgroup$
    – user202729
    Dec 4, 2017 at 10:59
  • $\begingroup$ I don't like a hardcode answer, efficiency is not important here. $\endgroup$
    – matrix42
    Dec 4, 2017 at 11:10
  • $\begingroup$ PermutationProduct may be useful: Try it online! $\endgroup$
    – user202729
    Dec 4, 2017 at 11:11
  • $\begingroup$ Alternatively you can create the matrix and use Transpose (which is equivalent to the PermutationProduct approach above). $\endgroup$
    – user202729
    Dec 4, 2017 at 11:20

3 Answers 3

12
+50
$\begingroup$

Let's start with the original 92 cases:

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]]

first eight queens solution

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

Symmetries overview

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

All 12 unique solutions

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

Visualize Queen solutions symmetry graph

$\endgroup$
4
$\begingroup$

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[
    SparseArray[Thread[Transpose@{sol,Range[8]}->1]],
    Mesh->True,
    DataReversed->{True,False}
]

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

enter image description here

Next, a reflection corresponds to a reverse:

reflect[solution_] := Reverse[solution]

Another visualization:

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

enter image description here

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

$\endgroup$
2
$\begingroup$

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

enter image description here

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

$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$ May 28, 2020 at 20:58

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.