15
|
10122 Views
|
7 Replies
|
28 Total Likes
View groups...
Share
GROUPS:

# Peaceful chess queen armies

Posted 3 years ago
 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]  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]  We can also look at more than 2 armies, let's look at 3 armies: There are many more things to explore: not only square chessboard but also rectangular chessboard, more colors, other chess piecesâ€¦
7 Replies
Sort By:
Posted 3 years ago
 -- you have earned Featured Contributor Badge 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 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 3 years ago
 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 3 years ago
 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 3 years ago
 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 3 years ago
 I love to see the enthusiasm behind solving more Rosetta Code problems! Thanks Sander!
Posted 3 years ago
 I guess i've done 100+ recent monthsâ€¦ ~150 or so remaining. See you in the next stream :-)