Solving chess bishop problem

Question

I have generalized the problem in this way where I have a list

list=Tuples[Range[8],2]  

I want to find the largest sublist in which the addition of the two entries for any two elements of the sublist will not be same and similarly the subtraction of the two entries for any two elements of the sublist will not be same. Ex:
sublist ={{1,3},{2,5},{7,3}}

here $1-3\neq 2-5 \neq 7-3$ and $1+3\neq 2+5 \neq 7+3$.

Answer 1

Mathematica's FindIndependentVertexSet can find maximal independent set (size 14 =2n-2) by default. The following finds "12". I have not explored symmetries as I am about to sit down for family Christmas Lunch. Happy Holidays to All!

tu = Tuples[Range[8], 2]
fun[{a_, b_}, v_] := Module[{},
  UndirectedEdge[{a, b}, #] & /@ 
   NestWhileList[# + v &, {a, b}, 
    1 <= #[[1]] <= 8 && 1 <= #[[2]] <= 8 &]]
g[a_, b_] := Module[{v = {1, 1}, w = {-1, 1}, dr, ul, dl, ur},
  dr = fun[{a, b}, v];
  ul = fun[{a, b}, -v];
  dl = fun[{a, b}, w];
  ur = fun[{a, b}, -w];
  Join[dr[[2 ;; -2]], ul[[2 ;; -2]], dl[[2 ;; -2]], ur[[2 ;; -2]]]]
grph = Graph[
   Union[Catenate[g @@@ tu], 
    SameTest -> (List @@ #1 == Reverse[List @@ #2] &)]];

So,

is = FindIndependentVertexSet[grph]
pts = # - {1/2, 1/2} & /@ is[[1]]
r = Catenate@Table[{0, 1}, 4]
r2 = RotateLeft[r]
ArrayPlot[Flatten[Table[{r, r2}, 4], 1], 
 Epilog -> {Red, PointSize[0.02], Point[pts]}]

12:

ies = FindIndependentVertexSet[grph, {14}, 12];
ap[p_] := 
 ArrayPlot[Flatten[Table[{r, r2}, 4], 1], 
  Epilog -> {Red, PointSize[0.04], Point[# - {1/2, 1/2} & /@ p]}]
Grid[Partition[ap /@ ies, 4]]

Answer 2

Another approach using FindIndependentEdgeSet:

In[58]=
squares = Tuples[Range[8],2];
edges = Replace[squares, {x_,y_} -> DirectedEdge[a[x-y],d[x+y]],{1}];
ind = FindIndependentEdgeSet[edges];
bishops = ind /. Thread[Rule[edges, squares]]

Out[58]= {{1,1},{7,8},{2,1},{1,3},{1,4},{1,5},{1,6},
{1,7},{8,1},{8,2},{8,6},{8,3},{8,5},{8,4}}

Each edge connects an ascending diagonal equivalence to a descending diagonal equivalence, and the independent edge set means none of the starting vertices or ending vertices are repeated.

Unfortunately, FindIndependentEdgeSet isn't designed to come up with more than one maximal set, unlike FindIndependentVertexSet, so if one is interested in all of the maximal sets, FindIndependentVertexSet would be more useful.

Answer 3

Here is another solution using linear programming (well, "just" Maximize) in the spirit of these answers: "How to fill a grid make its total be largest", "LinearProgramming approach for 'best teams' algorithm".

The advantage of this approach is that it gives a lot of flexibility to impose solutions characteristics through the constraints.

Below first we do the bishops problem, then we do the proposed generalization in the question.

Plotting functions

---

Clear[ChessBoard]
ChessBoard[n_Integer] := Table[Mod[i + j, 2], {i, n}, {j, n}];

---

Clear[PlotChessBoardSolution]
PlotChessBoardSolution[n_, {}, opts : OptionsPattern[]] := 
  ArrayPlot[ChessBoard[n], opts, Mesh -> All];
PlotChessBoardSolution[n_, solCoords : {{_Integer, _Integer} ..}, 
   opts : OptionsPattern[]] :=

  ArrayPlot[ChessBoard[n], opts, Mesh -> All, 
   Epilog -> {Red, PointSize[0.04], 
     Point[# - {1/2, 1/2} & /@ solCoords]}];

Bishops placement

Constraints

---

Clear[DiagonalCells]
DiagonalCells[{i_Integer, j_Integer}, v_, n_Integer] :=
  Union@Select[
    Flatten[Map[Table[{i, j} + k*#, {k, 0, n}] &, {v, -v}], 1], 
    n >= #[[1]] > 0 && n >= #[[2]] > 0 &];

---

Clear[LeftRightDiagonalContraint, RightLeftDiagonalContraint]
LeftRightDiagonalContraint[x_Symbol, {i_Integer, j_Integer}, 
   n_Integer] :=
  Total[x @@@ DiagonalCells[{i, j}, {1, 1}, n]] <= 1;
RightLeftDiagonalContraint[x_Symbol, {i_Integer, j_Integer}, 
   n_Integer] :=
  Total[x @@@ DiagonalCells[{i, j}, {-1, 1}, n]] <= 1;

Example:

LeftRightDiagonalContraint[x, {1, 2}, 8]

(* x[1, 2] + x[2, 3] + x[3, 4] + x[4, 5] + x[5, 6] + x[6, 7] + x[7, 8] <= 1 *)

Solution (with Maximize)

Chess board size:

n = 8;

Variables:

Clear[x]
vars = Flatten@Array[x, {n, n}];

Binary constraints:

binConstr = Map[0 <= # <= 1 &, vars];

Diagonal constraints:

cs = Union@
   Join[
    Table[LeftRightDiagonalContraint[x, {1, j}, n], {j, n}],
    Table[LeftRightDiagonalContraint[x, {j, 1}, n], {j, n}],
    Table[RightLeftDiagonalContraint[x, {1, j}, n], {j, n}],
    Table[RightLeftDiagonalContraint[x, {j, n}, n], {j, n}]
    ];
Length[cs]

(* 30 *)

For the bishops problem the solution is found fairly quickly using Maximize. Note that we can put additional constraints of the form x[i,j]==0 or x[i,j]>0 in order to derive different solutions.

AbsoluteTiming[
 sol = Maximize[Join[{Total[vars]}, cs, binConstr(*,{x[2,1]==0}*)], 
    vars, Integers];
 ]
sol[[1]]

(* {0.19802, Null}

14 *)

Getting the solution coordinates:

solCoords = List @@@ Select[sol[[2]], #[[2]] > 0 &][[All, 1]]

(* {{1, 3}, {1, 4}, {1, 5}, {1, 6}, {2, 1}, {2, 8}, {7, 1}, {7, 8}, {8, 1}, {8, 3}, {8, 4}, {8, 5}, {8, 6}, {8, 8}} *)

Plot the solution:

PlotChessBoardSolution[n, solCoords, ImageSize -> Small]

Proposed generalization

Constraints

Clear[CoordinatesConstraint]
CoordinatesConstraint[x_Symbol, {i_Integer, j_Integer}, n_Integer] :=
    Block[{t},
   t = Tuples[Range[n], 2];
   t = Select[t, #[[1]] - #[[2]] == i - j || #[[1]] + #[[2]] == i + j &];
   If[Length[t] <= 1, {}, Total[x @@@ Union[Append[t, {i, j}]]] <= 1]
   ];

Example:

CoordinatesConstraint[x, {4, 5}, 8]

(* x[1, 2] + x[1, 8] + x[2, 3] + x[2, 7] + x[3, 4] + x[3, 6] + x[4, 5] + x[5, 4] + x[5, 6] + x[6, 3] + x[6, 7] + x[7, 2] + x[7, 8] + x[8, 1] <= 1 *)

Solution (with Maximize)

n = 8;

Clear[x]
vars = Flatten@Array[x, {n, n}];

binConstr = Map[0 <= # <= 1 &, vars];

cs = Union@
   Flatten@Table[
     CoordinatesConstraint[x, {i, j}, n], {i, n}, {j, n}];
cs // Length

(* 62 *)


AbsoluteTiming[
 sol = Maximize[Join[{Total[vars]}, cs, binConstr], vars, Integers];
 ]
sol[[1]]

(* {31.9932, Null}

 2 *)

solCoords = List @@@ Select[sol[[2]], #[[2]] > 0 &][[All, 1]]

(* {{3, 8}, {6, 6}} *)

PlotChessBoardSolution[n, solCoords, ImageSize -> Small]

Answer 4

Crude and procedural:

list = Tuples[Range[8], 2]

{{1, 1}, {1, 2}, {1, 3}, ....}

op = Table[{i, Total@list[[i]], Subtract @@ list[[i]]}, {i, 1, Length@list}]

{{1, 2, 0}, {2, 3, -1}, {3, 4, -2}, ....}

In op, the first element numbers the tuples. Gathered by the second and third elements:

g = SortBy[
  Map[Flatten[#, 1] &] /@ (GatherBy[#, Last] & /@ 
     GatherBy[op, #[[2]] &]), Length]

{{{1, 2, 0}}, {{64, 16, 0}}, {{2, 3, -1}, {9, 3, 1}}, ....}

Three Do loops (sorry...):

final = {};
Do[
 out = {Flatten[g, 1][[k]]};
 Do[
  Do[
   If[
    Not@MemberQ[out[[All, 2]], g[[i, j, 2]]] && 
     Not@MemberQ[out[[All, 3]], g[[i, j, 3]]], 
    out = out~Join~{g[[i, j]]}, Nothing],
   {j, 1, Length@g[[i]]}],
  {i, 1, Length@g}];
 final = AppendTo[final, out], {k, Length@Flatten[g, 1]}]
final = DeleteDuplicates@final;
final = Sort /@ final[[All, All, 1]] // DeleteDuplicates;

The first final has 128 elements; the second has 64, and the last final has 45 elements (there should be 36 solutions, but I didn't take into account the condition "rotationally and reflectively distinct solutions").

ImageAssemble@Partition[#, 9] &@
 Table[MatrixPlot[#, ColorFunction -> "Monochrome", 
     FrameTicks -> None, Mesh -> All, MeshStyle -> Directive@Gray] &@
   SparseArray[Rule[#, 1] & /@ list[[final[[k]]]], {8, 8}], {k, 1, 
   Length@final}]

For example, in the second row, the second and last solutions are symmetric, so should be counted as the same. Also, the second and last are symmetric etc.