Peaceful chess queen armies: Difference between revisions

=={{header|Mathematica}}/{{header|Wolfram Language}}==

<lang Mathematica>ClearAll[ValidSpots, VisibleByQueen, SolveQueen, GetSolution]

VisualizeState[state_] := Module[{q, cells},

q = MapIndexed[If[#["q"] == -1, {}, Text[Style[#["q"], 24], #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}]

]

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,

Print[VisualizeState@state];

Print[StringRiffle[StringJoin /@ Map[ToString, state[[All, All, "q"]] /. -1 -> ".", {2}], "\n"]];

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[8, 4, 3](* Solves placing 3 armies of each 4 queens on an 8*8 board*)

GetSolution[5, 4, 2](* Solves placing 2 armies of each 4 queens on an 5*5 board*)</lang>

{{out}}

<pre>[Graphical object]

1....1..

..2....2

....3...

.3....3.

...1....

1.......

..2....2

....3...

[Graphical object]

1...1

..2..

.2.2.

..2..

1...1</pre>