Finding 36 integer solutions to a set of 14 equations using various boundary conditions

What is good way to solve this system of equations? I have it run now for quite some time and it does not spit out a solution.

n = 857097;
Solve[{n == n1^3 + n2^3 + n3^3 + n4^3 + n5^3 + n6^3,
n == n7^3 + n8^3 + n9^3 + n10^3 + n11^3 + n12^3,
n == n13^3 + n14^3 + n15^3 + n16^3 + n17^3 + n18^3,
n == n19^3 + n20^3 + n21^3 + n22^3 + n23^3 + n24^3,
n == n25^3 + n26^3 + n27^3 + n28^3 + n29^3 + n30^3,
n == n31^3 + n32^3 + n33^3 + n34^3 + n35^3 + n36^3,
n == n1^3 + n7^3 + n13^3 + n19^3 + n25^3 + n31^3,
n == n2^3 + n8^3 + n14^3 + n20^3 + n26^3 + n32^3,
n == n3^3 + n9^3 + n15^3 + n21^3 + n27^3 + n33^3,
n == n4^3 + n10^3 + n16^3 + n22^3 + n28^3 + n34^3,
n == n5^3 + n11^3 + n17^3 + n23^3 + n29^3 + n35^3,
n == n6^3 + n12^3 + n18^3 + n24^3 + n30^3 + n36^3,
n == n1^3 + n8^3 + n15^3 + n22^3 + n29^3 + n36^3,
n == n6^3 + n11^3 + n16^3 + n21^3 + n26^3 + n31^3,
1 <= n1 < 100 && 1 <= n2 < 100 && 1 <= n3 < 100 && 1 <= n4 < 100 &&
1 <= n5 < 100 && 1 <= n6 < 100 && 1 <= n7 < 100 && 1 <= n8 < 100 &&
1 <= n9 < 100 && 1 <= n10 < 100 && 1 <= n11 < 100 &&
1 <= n12 < 100 && 1 <= n13 < 100 && 1 <= n14 < 100 &&
1 <= n15 < 100 && 1 <= n16 < 100 && 1 <= n17 < 100 &&
1 <= n18 < 100 && 1 <= n19 < 100 && 1 <= n20 < 100 &&
1 <= n21 < 100 && 1 <= n22 < 100 && 1 <= n23 < 100 &&
1 <= n24 < 100 && 1 <= n25 < 100 && 1 <= n26 < 100 &&
1 <= n27 < 100 && 1 <= n28 < 100 && 1 <= n29 < 100 &&
1 <= n30 < 100 && 1 <= n31 < 100 && 1 <= n32 < 100 &&
1 <= n33 < 100 && 1 <= n34 < 100 && 1 <= n35 < 100 &&
1 <= n36 < 100}, {n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11,
n12, n13, n14, n15, n16, n17, n18, n19, n20, n21, n22, n23, n24,
n25, n26, n27, n28, n29, n30, n31, n32, n33, n34, n35,
n36}, Integers]

EDIT:

The problem I keep running into is that I have to find a unique solution, such that none of the variables is equal to each other.

• It might be worth finding all possible solutions to the first equation, and consider permutations of these. Apr 16, 2020 at 17:38
• @mikado Thank you for your comment. Is there a way to program that in a smart way, such that Mathematica can solve for the rest of the equations after solving that problem first. Apr 16, 2020 at 17:45
• This is rather a math question than Mathematica question. Apr 16, 2020 at 18:20
• @user64494 I want to use Mathematica to solve it. Apr 16, 2020 at 18:21
• The following n = 857097;FindInstance[n == n1^3 + n2^3 + n3^3 + n4^3 + n5^3 + n6^3 && 1 <= n1 < 100 && 1 <= n2 < 100 && 1 <= n3 < 100 && 1 <= n4 < 100 && 1 <= n5 < 100 && 1 <= n6 < 100, {n1, n2, n3, n4, n5, n6}, Integers] works. The result is (* {{n1 -> 1, n2 -> 1, n3 -> 29, n4 -> 45, n5 -> 53, n6 -> 84}}*) . Apr 16, 2020 at 19:31

Below I've recognized that your equations actually represent a kind of magic square of cubes, which wasn't mentioned in the question or comments. I've coded how to generate the equations and constraints without writing them all out 'manually' - hopefully this is useful if you explore similar, smaller, more tractable problems.

Your problem is very hard, and I don't expect this will ever finish and return 36 results, but this is how you'd solve it if you had all the time and memory in the world:

c = 857097;
variables = Array[x, 36];
matrix = ArrayReshape[variables, {6, 6}];

magicSquareConstraint = And @@ Flatten[{
(* rows of the matrix *)
c == # & /@ Total[Transpose[matrix^3]],
(* columns of the matrix *)
c == # & /@ Total[matrix^3],
(* Both diagonals of the matrix *)
c == Total[Diagonal[matrix^3]],
c == Total[Diagonal[Reverse[matrix^3, 2]]]
}];

uniqueConstraint = (And @@ (Unequal @@@ Subsets[variables, {2}]));
rangeConstraint = (And @@ (1 <= # < 100 & /@ variables));

FindInstance[
magicSquareConstraint  && uniqueConstraint && rangeConstraint,
variables, PositiveIntegers, 36
]

Another possibility is to find random 6x6 magic squares for the linear problem over domain $$1\le x_i<100$$ using LinearOptimization. This is much faster than FindInstance and see my answer here. Then you could cube the solutions to the linear problem and check the constraints are still valid. However, I suspect upon cubing, most magic squares would not preserve the magic property.

Let me provide you 99 number combinations that all fit the conditions. Pick the right one out to get your magic cube.

The cubic of the first 94 numbers is below n. Combine them all with a boole number r[i] and use NMinimize and NMaximize to find allowed combinations. (This takes about 20 minutes). Retransform the r[i] to i and delete multiples with Union.

n = 857097;
rn = Array[r, 94];
rr = Range[94]^3;
tot = Total@rn == 6;
int = rn \[Element] Integers;
th01 = And @@ Thread[0 <= rn <= 1];

(tabmin =
Table[DeleteCases[
rn (rn /.
NMinimize[{r[j], tot && int && th01 && rn.rr == n}, rn][[2]]),
0], {j, 1, 94}]) // Timing

Do the same with tabmax ... NMaximize...

ncomb = Join[tabmin, tabmax] /. r[aa_] -> aa // Union;

I leave it to you to find fitting combinations.

ncomb = {{1, 2, 3, 21, 72, 78}, {1, 2, 4, 58, 59, 77}, {1, 2, 6, 16,
42, 92}, {1, 2, 8, 12, 64, 84}, {1, 2, 9, 14, 58, 87}, {1, 2, 12,
36, 60, 84}, {1, 2, 32, 46, 56, 82}, {1, 3, 14, 15, 71, 79}, {1,
5, 34, 54, 62, 75}, {1, 6, 9, 15, 42, 92}, {1, 8, 18, 42, 52,
86}, {1, 8, 22, 35, 69, 78}, {1, 9, 21, 39, 60, 83}, {1, 10, 20,
34, 47, 89}, {1, 13, 20, 48, 68, 75}, {1, 22, 47, 50, 65, 70}, {2,
3, 7, 37, 65, 81}, {2, 4, 17, 35, 58, 85}, {2, 4, 24, 28, 57,
86}, {2, 7, 10, 29, 30, 93}, {2, 8, 9, 10, 64, 84}, {2, 8, 16, 18,
49, 90}, {2, 11, 19, 51, 70, 72}, {2, 18, 28, 30, 46, 89}, {2,
32, 34, 49, 64, 74}, {3, 5, 27, 31, 68, 79}, {3, 6, 13, 54, 57,
80}, {3, 7, 14, 38, 52, 87}, {3, 13, 15, 33, 48, 89}, {4, 5, 9,
11, 64, 84}, {4, 5, 12, 17, 27, 94}, {4, 5, 45, 47, 48, 82}, {4,
6, 17, 33, 54, 87}, {4, 6, 39, 49, 65, 74}, {4, 6, 41, 48, 62,
76}, {4, 7, 29, 32, 70, 77}, {4, 7, 38, 44, 57, 81}, {4, 9, 11,
13, 42, 92}, {4, 9, 14, 39, 73, 74}, {4, 9, 18, 43, 68, 77}, {4,
9, 38, 44, 70, 72}, {4, 10, 32, 42, 65, 78}, {4, 12, 14, 57, 64,
74}, {4, 15, 20, 32, 39, 91}, {4, 17, 22, 32, 60, 84}, {4, 17, 29,
43, 70, 74}, {4, 18, 48, 51, 63, 71}, {4, 20, 25, 44, 70,
74}, {4, 21, 30, 35, 57, 84}, {4, 24, 33, 47, 68, 73}, {4, 28, 32,
41, 46, 86}, {4, 30, 40, 56, 57, 74}, {4, 30, 42, 53, 57,
75}, {4, 31, 38, 41, 68, 73}, {5, 7, 19, 21, 69, 80}, {5, 10, 20,
24, 31, 93}, {5, 13, 20, 34, 68, 79}, {5, 23, 33, 45, 55, 82}, {5,
28, 38, 45, 63, 76}, {6, 7, 17, 31, 63, 83}, {6, 7, 23, 25, 29,
93}, {6, 8, 25, 42, 44, 88}, {6, 8, 31, 55, 62, 75}, {6, 9, 18,
32, 70, 78}, {6, 9, 21, 32, 51, 88}, {6, 10, 15, 27, 47, 90}, {6,
11, 30, 37, 57, 84}, {6, 12, 14, 19, 73, 77}, {6, 12, 17, 18, 24,
94}, {6, 12, 19, 20, 33, 93}, {6, 14, 25, 29, 51, 88}, {6, 16, 17,
45, 59, 82}, {6, 23, 35, 36, 64, 79}, {6, 26, 27, 37, 40,
89}, {6, 28, 47, 56, 61, 69}, {6, 38, 45, 55, 60, 69}, {7, 8, 12,
29, 60, 85}, {7, 8, 16, 27, 71, 78}, {7, 8, 22, 25, 50, 89}, {7,
9, 22, 53, 65, 75}, {7, 9, 50, 52, 57, 74}, {7, 11, 15, 29, 42,
91}, {7, 25, 44, 53, 57, 75}, {7, 26, 41, 49, 52, 80}, {7, 29, 30,
32, 45, 88}, {7, 32, 51, 57, 59, 67}, {8, 9, 15, 18, 49, 90}, {8,
13, 27, 33, 61, 83}, {8, 20, 27, 31, 52, 87}, {8, 21, 43, 49, 56,
78}, {8, 28, 30, 37, 57, 83}, {8, 29, 31, 39, 63, 79}, {8, 33,
34, 38, 66, 76}, {8, 35, 43, 58, 62, 67}, {9, 11, 29, 46, 52,
84}, {9, 26, 42, 46, 64, 74}, {10, 28, 33, 48, 56, 80}, {11, 18,
20, 25, 28, 93}, {12, 14, 18, 25, 58, 86}
};

Test

Total@(#^3) & /@ ncomb
• I get an error when I try to run your code. Jul 22, 2020 at 18:11
• Without knowing what error, i can't say anything. On my pc it works. Remember tabmax with NMaximize is not shown. Jul 22, 2020 at 18:14
• I edited a picture in my question above, where the error is shown. What am I doing wrong? Jul 22, 2020 at 18:17
• Sorry, i corrected it tabmin[[2]] was wrong. Simpliy tabmin. Jul 22, 2020 at 18:18
• Okay thanks! But I do not know how to filter the solutions with this number of solutions, can you help me a bit further? Jul 22, 2020 at 18:25