Message Boards Message Boards

Peaceful chess queen armies

enter image description here

I was solving the Rosetta problem Peaceful chess queen armies just now. The idea is to place q armies of queens, each m large, on a n-by-n chess board such that one army of queen can not capture any other queen. The task there ask us to place 2 armies of each 4 queens on a 5*5 board:

ClearAll[ValidSpots, VisibleByQueen, SolveQueen, GetSolution]
VisualizeState[state_] := Module[{q, cells, colors,},
  colors = DeleteCases[Union[Flatten@state[[All, All, "q"]]], -1];
  colors = Thread[colors -> (ColorData[106] /@ Range[Length[colors]])];
  q = MapIndexed[
    If[#["q"] == -1, {}, 
      Text[Style[#["q"], 20, #["q"] /. colors], #2]] &, state, {2}];
  cells = 
   MapIndexed[{If[OddQ[Total[#2]], FaceForm[], 
       FaceForm[GrayLevel[0.8]]], EdgeForm[Black], 
      Rectangle[#2 - 0.5, #2 + 0.5]} &, state, {2}];
  Graphics[{cells, q}, ImageSize -> Length[First@state] 30]
  ]
ValidSpots[state_, tp_Integer] := Module[{vals},
  vals = 
   Catenate@
    MapIndexed[
     If[#1["q"] == -1 \[And] DeleteCases[#1["v"], tp] == {}, #2, 
       Missing[]] &, state, {2}];
  DeleteMissing[vals]
  ]
VisibleByQueen[{i_, j_}, {a_, b_}] := 
 i == a \[Or] j == b \[Or] i + j == a + b \[Or] i - j == a - b
PlaceQueen[state_, pos : {i_Integer, j_Integer}, tp_Integer] := 
 Module[{vals, out},
  out = state;
  out[[i, j]] = Association[out[[i, j]], "q" -> tp];
  out = MapIndexed[
    If[VisibleByQueen[{i, j}, #2], <|#1, 
       "v" -> Append[#1["v"], tp]|>, #1] &, out, {2}];
  out
  ]
SolveQueen[state_, toplace_List] := 
 Module[{len = Length[toplace], next, valid, newstate},
  If[len == 0,
   tmp = state;
   Print[VisualizeState@state];
   Abort[];
   ,
   next = First[toplace];
   valid = ValidSpots[state, next];
   Do[
    newstate = PlaceQueen[state, v, next];
    SolveQueen[newstate, Rest[toplace]]
    ,
    {v, valid}
    ]
   ]
  ]
GetSolution[n_Integer?Positive, m_Integer?Positive, numcol_ : 2] := 
 Module[{state, tp},
  state = ConstantArray[<|"q" -> -1, "v" -> {}|>, {n, n}];
  tp = Flatten[Transpose[ConstantArray[#, m] & /@ Range[numcol]]];
  SolveQueen[state, tp]
  ]
GetSolution[5, 4, 2]

enter image description here

Notice that no queen of army 1 can capture any queen of army 2 (and vice versa).

But we can go much beyond that, let;s check what can happen for a given chess board size how many we can place for the case of 2 armies:

GetSolution[3, 1]
GetSolution[4, 2]
GetSolution[5, 4]
GetSolution[6, 5]
GetSolution[7, 7]

enter image description here

We can also look at more than 2 armies, let's look at 3 armies:

enter image description here

There are many more things to explore: not only square chessboard but also rectangular chessboard, more colors, other chess pieces…

POSTED BY: Sander Huisman
7 Replies

I guess i've done 100+ recent months… ~150 or so remaining. See you in the next stream :-)

POSTED BY: Sander Huisman

I love to see the enthusiasm behind solving more Rosetta Code problems! Thanks Sander!

POSTED BY: Kevin Reiss

I'm aware of generating functions but have never used them myself. Would rotations/reflections of non-symmetric solutions give different functions, is that problematic?

POSTED BY: Sander Huisman

If you remove the Abort[] in the SolveQueen function it will keep on finding all of them and printing them as they are found.

Using Transpose and Reverse one could quite easily check whether it has reflected or rotational symmetry.

Cheers!

POSTED BY: Sander Huisman

Very neat! I do not entirely understand if GetSolution[] gives you a particular solution and are there more solutions for specific input numbers $[n,m]$? Also I am curious is there any easy way to say when the solution will be 2-fold or 4-fold rotationally symmetric.

POSTED BY: Sam Carrettie
Posted 3 years ago

Nice! It makes me wonder if we could set this up using a generating function. Where the power of, say, x would be the column and the power of y would be the row (the coordinates). The coefficient would be the army (1 or 2 in this case). Your first picture with the yet unknown generating function GetSolutionGF[5, 4, 2] would have output 1XY+1X^5 Y+2X^3 Y^2 +2X^2 Y^3+2X^4 Y^3+2X^3 Y^4+1X Y^5+1X^5 Y^5.

POSTED BY: Dave Himes

enter image description here -- you have earned Featured Contributor Badge enter image description here Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you!

POSTED BY: EDITORIAL BOARD
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract