# How do we solve N-Rooks variation using primes?

Using a $p_n$x $p_n$ matrix, how can we solve the N-Rooks problem to find a prime in every row and column?

Table[MatrixForm[Table[If[PrimeQ[n], "P", "."], {m, 0, Prime[o]^2 - Prime[o],
Prime[o]}, {n, m + 1, m + Prime[o]}]], {o, 1, 8}]


Here is the $11$x$11$ matrix with the possible prime positions for the queens:

Note: single primes are always in the $p$-th column.

This is one possible solution (done by hand):

Edit Changed the title and link as Paxinum suggested.
OEIS A215637 has these counts of multiple solutions through $10th$ prime:
$$1, 1, 1, 2, 7, 72, 2144, 2641, 1345721, 2191254096$$

• I think you need to qualify the question a bit more... What is the equivalent condition of "two queens not attacking each other"?
– rm -rf
Oct 27, 2012 at 2:53
• @rm-rf, primes share no rows or colummns Oct 27, 2012 at 3:12
• Ah, I see. So your 11x11 was the set of all possible positions then...
– rm -rf
Oct 27, 2012 at 3:13
• @rm-rf, yes, All we need to do is circle one prime in each row and each column. In this example, we would have 11 circles. Oct 27, 2012 at 3:19
• Then this is not an $n$-queen problem, but an $n$-rook problem... Oct 28, 2012 at 9:08

A very simple one, not very elegant :

f[o_] := Module[{mat, sol, vars, const, output},
mat = Table[If[PrimeQ[n], Unique["p"], 0], {m, 0, Prime[o]^2 - Prime[o],
Prime[o]}, {n, m + 1, m + Prime[o]}];
vars = Cases[Flatten[mat], _?(Not[NumericQ[#]] &)] ;
const = Join[{Last[First[mat]] == 1}, Total[#] == 1 & /@ mat,
Total[#] == 1 & /@ Transpose[mat],
sol = FindInstance[const, vars, Integers];
output = (mat /. First[sol])
]

f[8]/.{0 -> "."} //MatrixForm


• Hey, could you help me understand the puzzle?
– Rojo
Oct 27, 2012 at 8:44
• I understood you want to build a matrix with "P"'s and 0's such that there is only one "P" in every row and column - some sort of simplified sudoku. Oct 27, 2012 at 8:46
– Rojo
Oct 27, 2012 at 8:47
• The position where the 1's can be placed. Oct 27, 2012 at 8:47
• Oh so in 9x9 matrix, 2nd row, 1st column would be 10th position so you can't put a 1 there? Sorry, 5:50AM, slept 2hs yesterday
– Rojo
Oct 27, 2012 at 8:50

Another possibility, at least for relatively small matrices, is to take the determinant (strictly speaking it is the permanent that is required, I suppose).

For example, for an $11 \times 11$ matrix (o=5), I find there are 7 solutions.

primePositions5 =
Position[With[{o = 5},
Table[If[PrimeQ[n], 1, 0], {m, 0, Prime[o]^2 - Prime[o],
Prime[o]}, {n, m + 1, m + Prime[o]}]], 1];

mylist = List @@ (Det@
SparseArray[## -> Subscript[a, ##] & /@
primePositions5] /. {-x_ -> x})


gives the following:

Matrix plots of all seven solutions:

MatrixPlot[
Normal@SparseArray[(List @@ #) /.
Subscript[a, {x_, y_}] -> {x, y} -> 1], Mesh -> All,
ImageSize -> 200] & /@ mylist


I'll give then as a grid:

I reckon it needs to be emphasized that the Mathematica's Det command is slow.

With o=7 which gives a $17 \times 17$ matrix, I obtain 2144 solutions. For 0 =8 ($19 \times 19$), the figure is 2641. I could not go beyond this with the computer I am using (with Mathematica 7, as it so happens).

For o=4 ($7 \times 7$), I get two solutions:

### Update for Mathematica 11

In Mma 11, we can use the Permanent function

myListAlt = List @@ (SparseArray[## -> Subscript[a, ##] & /@  primePositions5] //
Permanent // Expand)


The behaviour of Det seems to have changed somewhat since this question was posted.
I now need to Expand the result of the Det function:

mylist = List @@ (Expand@
Det@SparseArray[## -> Subscript[a, ##] & /@
primePositions5] /. {-x_ -> x})


and

mylist == myListAlt


True

• Very nice solution! +1 Oct 29, 2012 at 18:08
• FWIW: it is well-known that computing the permanent is an even more difficult task than computing the determinant... Oct 30, 2012 at 0:18
• The built-in Permanent[] can be a bit slow; see here for slightly faster routines. I should also note at this point that Ilan Vardi discussed a similar problem in his book Computational Recreations in Mathematica. Aug 19, 2016 at 10:02

This is neither elegant nor smart nor memory efficient. It is a brute force method to get all solutions of a given size

isGood[m_] := Sort@m === reye@Length@m;
i : reye[l_] := i = Reverse@IdentityMatrix@l;

getAllSolutions[n_?PrimeQ] := With[{id = IdentityMatrix@n},
Pick[id, #, 1] & /@ Boole@PrimeQ@Partition[Range[n^2], n] //
Tuples]~Select~isGood;


So

Row[MatrixForm /@ #] & /@
Composition[getAllSolutions, Prime]~Array~4 //
Column@Riffle[#, "New prime"] &


Gives

EDIT

I imagined that a solution along the lines of @bgatessucks 's great answer, but with booleans, would be more efficient and appropriate. However, while this is true for sizes below 13 (an order of magnitude faster in my tests), for some reason it suddenly becomes terribly slow afterwards.

v2[n_?PrimeQ, nsols_Integer: 1] := Module[{mat, vars},
{mat, {vars}} =
Reap[PrimeQ@Partition[Range[n^2], n] /. True :> Sow@Unique["p"]];
SatisfiabilityInstances[
And @@ BooleanCountingFunction[{1}, n] @@@
Join[mat, Transpose@mat], vars, nsols] /.
res_ :> (mat /. (Thread[vars -> #] & /@ res) /. {False -> ".",
True -> "P"})
]


Now

MatrixForm /@ v2[Prime@6, 3]


Gives