Solving a system of equations using the data generated by PowersRepresentations and ParallelTable

Question

First of all, it is possible to check the code that I am asking for because I know that $x=3051$ must yield at least a solution to the problem.

Well, I have the following system of equations:

Now, I need to solve this system for {n1,n2,n3,n4,n5,n6,n7,n8,n9} . The values of $x$ that needs to be tried come from the following code:

ParallelTable[
 If[TrueQ[Length[
     Select[Select[PowersRepresentations[n, 3, 2], Times @@ # != 0 &],
       Length[#] == Length[Union[#]] &]] >= 6], n, Nothing], {n, 0, 
  10000}]

(* {314,329,341,...,9998} *)

Question: How can I loop through the values given by the ParallelTable code ({314,329,341,...,9998}) in order to check if the system of equations gives a solution for a certain value of $x$?

---

So, the first case to check would be when $x=314$ and the solutions that has to be tried are given by:

Select[Select[PowersRepresentations[314, 3, 2], Times @@ # != 0 &], 
Length[#] == Length[Union[#]] &]

(* {{1, 12, 13}, {3, 4, 17}, {3, 7, 16}, {5, 8, 15}, {7, 11, 12}, {8, 9, 
  13}} *)

So, we need to try to solve the following system of equations using the possible values, given from the code above ({{1,12,13},{3,4,17},{3,7,16},{5,8,15},{7,11,12},{8,9,13}}):

x=314;
Solve[{x == n1^2 + n2^2 + n3^2, x == n4^2 + n5^2 + n6^2, 
      x == n7^2 + n8^2 + n9^2, x == n1^2 + n4^2 + n7^2, 
      x == n2^2 + n5^2 + n8^2, x == n3^2 + n6^2 + n9^2}, {n1, n2, n3, n4, 
      n5, n6, n7, n8, n9}]

Answer 1

Post here my comment as an answer (actually I'm not sure this is the right answer). Define table of x values (just as given by OP):

    xvals = ParallelTable[
   If[TrueQ[
     Length[Select[
        Select[PowersRepresentations[n, 3, 2], Times @@ # != 0 &], 
        Length[#] == Length[Union[#]] &]] >= 6], n, Nothing], {n, 0, 
    10000}];

Now we can use this to substitute for x when solving the given system of equations, and to speed-up the code we can use ParallelMap:

ParallelMap[
  Solve[{# == n1^2 + n2^2 + n3^2, # == n4^2 + n5^2 + n6^2, # == 
      n7^2 + n8^2 + n9^2, # == n1^2 + n4^2 + n7^2, # == 
      n2^2 + n5^2 + n8^2, # == n3^2 + n6^2 + n9^2}, {n1, n2, n3, n4, 
     n5, n6, n7, n8, n9}, PositiveIntegers] &, xvals[[;; 50]]];

This gives the solution in terms of positive integer numbers, and because of time and memory consumption one can use several ranges of xvals (here the first 50 values are used).

One can also solve for particular x:

x = 3051;
sol=Solve[{x == n1^2 + n2^2 + n3^2, x == n4^2 + n5^2 + n6^2, 
  x == n7^2 + n8^2 + n9^2, x == n1^2 + n4^2 + n7^2, 
  x == n2^2 + n5^2 + n8^2, x == n3^2 + n6^2 + n9^2}, {n1, n2, n3, n4, 
  n5, n6, n7, n8, n9}, PositiveIntegers]

This gives many solutions and {n1 -> 29, n2 -> 41, n3 -> 23, n4 -> 1, n5 -> 37, n6 -> 41, n7 -> 47, n8 -> 1, n9 -> 29} is among them.

To check if all the solutions are unique we can do:

Select[DeleteDuplicates /@ Values[sol], Length[#] == 9 &]

In the case of x = 3051 we have repeated values (1, 29, 41) and this Select command gives empty list as an output {}, that means there is no unrepeated values.

Using ParallelTable (as OP suggested in comments):

sol = ParallelTable[
   Solve[{x == n1^2 + n2^2 + n3^2, x == n4^2 + n5^2 + n6^2, 
     x == n7^2 + n8^2 + n9^2, x == n1^2 + n4^2 + n7^2, 
     x == n2^2 + n5^2 + n8^2, x == n3^2 + n6^2 + n9^2, 
     x == n1^2 + n5^2 + n9^2}, {n1, n2, n3, n4, n5, n6, n7, n8, n9}, 
    PositiveIntegers], {x, 0, 2000}];

Map[Select[Length[#] == 9 &]@*DeleteDuplicates, 
  Values[sol], {2}] //. {} -> Nothing

We Map at 2nd level (at all sub-lists of sol): composition (@*) of deleting repeated values (DeleteDuplicates) and slecting sub-lists with length of 9 (all distinct values). Finally one can delete empty lists by repeatedly applying rule {} -> Nothing and see if something is left in the end.

Answer 2

mm = Partition[Array[Subscript[n, #] &, 9], 3];
TeXForm @ MatrixForm @ mm

$\left( \begin{array}{ccc} n_1 & n_2 & n_3 \\ n_4 & n_5 & n_6 \\ n_7 & n_8 & n_9 \\ \end{array} \right)$

We can restate the problem as finding a 3X3 matrix of distinct square integers with identical row and column sums.

"to check if the system of equations gives a solution for a certain value of x?"

For the related problem, given an integer x find a 3X3 matrix of distinct square integers such that every row and every column sum to x, we can use a semi-brute-force approach using IntegerPartitions of x with 3 elements restricting elements to square numbers.

xx = 314;
ip = IntegerPartitions[xx, {3}, Range[Ceiling[xx^(1/2)]]^2];
{{289, 16, 9}, {256, 49, 9}, {225, 64, 25}, {169, 144, 1}, {169, 81, 64}, {144, 121, 49}}

Construct 3X3 matrices taking 3-subsets of ip and select the duplicate-free ones:

dupFreeMatrices = Select[DuplicateFreeQ[Join @@ #] &]@Subsets[ip, {3}];
MatrixForm /@ dupFreeMatrices

The rows in each of these matrices sum to 314 by construction.

We next check if we can re-organize any of these matrices by permuting row elements to get a matrix with desired column sums.

For xx = 314 find that this impossible:

Join @@ ((Select[Total[#] == {xx,xx,xx} &]@Tuples[Permutations /@ #]) & /@ dupFreeMatrices)

{}

Combining the steps into a function:

ClearAll[findMat]
findMat = Module[{cums = ConstantArray[#,3], 
   mats = Select[DuplicateFreeQ[Join @@ #] &] @ 
     Subsets[Select[DuplicateFreeQ]@IntegerPartitions[#, {3}, 
        Range[Ceiling[#^(1/2)]]^2], {3}]},
  Join @@ ((Select[Total[#] == csums &]@Tuples[Permutations /@ #]) & /@ mats)]&;

Checking few entries from the list produced by OP's ParallelTable:

findMat /@ {314, 329, 341, 3051}

 {{}, {}, {}, {}}

For x up to 10000, we find two numbers,3249 and 3969, for which we can find 9 distinct square integers satisfying the constraints in OP's system (1):

sols  = ParallelTable[findMat[n] /. {} -> Nothing, {n, 0, 10000}];


{Total[#[[1, 1]]], MatrixForm /@ #} & /@ sols

A faster version is to keep the first row and permute the second and third rows when we take Tuples:

ClearAll[findMat2]
findMat2 = Module[{csums = ConstantArray[#, 3], 
     mats = Select[DuplicateFreeQ[Join @@ #] &]@
       Subsets[Select[DuplicateFreeQ]@
         IntegerPartitions[#, {3}, Range[Ceiling[#^(1/2)]]^2], {3}]},
    Join @@ ((Select[Total[#] == csums &]@
          Tuples[{{#[[1]]}, Permutations[#[[2]]], 
            Permutations[#[[3]]]}]) & /@ mats)] &;

solsB = ParallelTable[findMat2[n] /. {} -> Nothing, {n, 0, 10000}];

{Total[#[[1, 1]]], MatrixForm /@ #} & /@ solsB

If we take all column permutations of matrices in solsB we get the longer lists in sols.