16
$\begingroup$

enter image description here

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$.

$\endgroup$
  • $\begingroup$ To be clear: do you want solutions for the bishop problem or the generalization you propose? (May be both...) $\endgroup$ – Anton Antonov Dec 27 '16 at 13:44
  • $\begingroup$ @AntonAntonov both, although the solution to one can solve the other. $\endgroup$ – m. bubu Dec 27 '16 at 14:17
  • $\begingroup$ "both, although the solution to one can solve the other." -- This is the reason I submitted my solution. IMO, the ILP formulation "scales" better than the other solutions. $\endgroup$ – Anton Antonov Dec 27 '16 at 14:48
  • $\begingroup$ mathworld.wolfram.com/BishopsProblem.html $\endgroup$ – Vaclav Kotesovec Dec 27 '16 at 15:16
14
$\begingroup$

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

enter image description here

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

enter image description here

$\endgroup$
7
$\begingroup$

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.

$\endgroup$
7
$\begingroup$

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]

enter image description here

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]

enter image description here

$\endgroup$
7
$\begingroup$

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

enter image description here

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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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