3
$\begingroup$

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.

enter image description here

Improve this question
$\endgroup$
8
  • 1
    $\begingroup$ It might be worth finding all possible solutions to the first equation, and consider permutations of these. $\endgroup$
    – mikado
    Apr 16, 2020 at 17:38
  • $\begingroup$ @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. $\endgroup$
    – Jan Eerland
    Apr 16, 2020 at 17:45
  • $\begingroup$ This is rather a math question than Mathematica question. $\endgroup$
    – user64494
    Apr 16, 2020 at 18:20
  • $\begingroup$ @user64494 I want to use Mathematica to solve it. $\endgroup$
    – Jan Eerland
    Apr 16, 2020 at 18:21
  • 1
    $\begingroup$ 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}}*) . $\endgroup$
    – user64494
    Apr 16, 2020 at 19:31

2 Answers 2

Reset to default
2
$\begingroup$

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.

Improve this answer
$\endgroup$
1
$\begingroup$

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
Improve this answer
$\endgroup$
6
  • $\begingroup$ I get an error when I try to run your code. $\endgroup$
    – Jan Eerland
    Jul 22, 2020 at 18:11
  • $\begingroup$ Without knowing what error, i can't say anything. On my pc it works. Remember tabmax with NMaximize is not shown. $\endgroup$
    – Akku14
    Jul 22, 2020 at 18:14
  • $\begingroup$ I edited a picture in my question above, where the error is shown. What am I doing wrong? $\endgroup$
    – Jan Eerland
    Jul 22, 2020 at 18:17
  • $\begingroup$ Sorry, i corrected it tabmin[[2]] was wrong. Simpliy tabmin. $\endgroup$
    – Akku14
    Jul 22, 2020 at 18:18
  • $\begingroup$ Okay thanks! But I do not know how to filter the solutions with this number of solutions, can you help me a bit further? $\endgroup$
    – Jan Eerland
    Jul 22, 2020 at 18:25

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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