Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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:

N-RooksPrimeVariation

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

This is one possible solution (done by hand):

N-RooksPrimeSolution

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

share|improve this question
    
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 '12 at 2:53
    
@rm-rf, primes share no rows or colummns –  Fred Kline Oct 27 '12 at 3:12
    
Ah, I see. So your 11x11 was the set of all possible positions then... –  rm -rf Oct 27 '12 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. –  Fred Kline Oct 27 '12 at 3:19
2  
Then this is not aa n-queen problem, but an n-rook problem... –  Paxinum Oct 28 '12 at 9:08

3 Answers 3

up vote 5 down vote accepted

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], 
    Thread[GreaterEqual[vars, 0]]];
  sol = FindInstance[const, vars, Integers];
  output = (mat /. First[sol])
]

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

prime

share|improve this answer
    
Hey, could you help me understand the puzzle? –  Rojo Oct 27 '12 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. –  b.gatessucks Oct 27 '12 at 8:46
2  
But couldn't those be 1s and 0s? What's prime about this? –  Rojo Oct 27 '12 at 8:47
2  
The position where the 1's can be placed. –  b.gatessucks Oct 27 '12 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 '12 at 8:50

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

Mathematica graphics

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

Mathematica graphics

share|improve this answer
    
+1, another fine solution. –  Fred Kline Oct 27 '12 at 9:43
    
@FredDanielKline, added an edit –  Rojo Oct 27 '12 at 18:26

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:

enter image description here

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:

enter image description here

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:

7x 7 matrix

share|improve this answer
    
Very nice solution! +1 –  Fred Kline Oct 29 '12 at 18:08
1  
FWIW: it is well-known that computing the permanent is an even more difficult task than computing the determinant... –  J. M. Oct 30 '12 at 0:18
    
+1 love these kind of answers –  Rojo Nov 14 '12 at 18:45
    
@Rojo Thanks! Love your answers, BTW :-) –  TomD Nov 15 '12 at 11:37

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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