TransWikia.com

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

Mathematica Asked on November 25, 2021

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

2 Answers

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

Answered by Akku14 on November 25, 2021

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 $1le 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.

Answered by flinty on November 25, 2021

Add your own answers!

Ask a Question

Get help from others!

© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP