Кубики и суммы

[lel0lel]

С удовольствием. Приду с работы и выложу.

[lel0lel]

Пример для "классического" кубика-октаэдра. Определяем сумму и сумму квадратов на кубиках: $S_1=\sum _{i=1}^8 i, S_2=\sum _{i=1}^8 i^2.$ Вычисляем наибольшее возможное по модулю число на гранях, очевидно это $\lfloor\sqrt{S_2}\rfloor$. Далее обе суммы представляем в виде двух сумм $S_1=S_{11}+S_{12}$, $S_2=S_{21}+S_{22}$ (подразумеваем, что в каждом слагаемом сумма от четырёх граней); возможно, что тут оптимальнее будет представлять в виде суммы трёх или четырёх слагаемых, я поленился проверять. Это улучшение (оно существенно ускоряет счёт) я дописал после сообщения Sender. Будет двойной цикл по $S_{12}, S_{22}$, можно наоборот по $S_{11}, S_{12}$, но прежде определим две очевидные функции:

S21[S22_] := S2 - S22;
S11[S12_] := S1 - S12;

Цикл

S12S22 = {}; Do[
 If[S12^2/4 <= S22 && S11[S12]^2/4 <= S21[S22], 
  AppendTo[S12S22, {S12, S22}]], {S12, -4Floor[\sqrt{S_2}] 4Floor[\sqrt{S_2}]}, {S22, 0, S2}]

В нём пробегаем по всем возможным значениям $S_{12}$ и $S_{22}$; поскольку в сумме $S_{12}$ наибольшее возможное по модулю слагаемое равно $\lfloor\sqrt{S_2}\rfloor$, а всего слагаемых четыре, то пределы по $S_{12}$ от $-4\lfloor\sqrt{S_2}\rfloor$ до $4\lfloor\sqrt{S_2}\rfloor$ (тут, конечно, можно ещё существенно сузить интервал, но тоже поленился). В цикле делается проверка удовлетворяют ли пары $\{S12, S22\}$, $\{S11, S21\}$ неравенству для среднего арифметического и среднего квадратичного. На выходе имеем строку (одномерный массив) $S12S22$, в котором все допустимые суммы разбиения восьмигранного кубика на два четырёхгранных. Ищем для каждого элемента $S12S22$ решение и одновременно решение для сопряжённой пары $\{S11, S21\}$, если решения одновременно существуют, то будем комбинировать решения, цикл проходит по всем найденным разбиениям:

str = {}; Do[(s2 = Solve[{Sum[l[i], {i, 1, 4}] == S12S22[[j, 1]], Sum[l[i]^2, {i, 1, 4}] == S12S22[[j, 2]], l[1] <= l[2] <= l[3] <= l[4]}, Table[l[i], {i, 1, 4}], Integers]; s1 = Solve[{Sum[l[i + 4], {i, 1, 4}] == S11[S12S22[[j, 1]]], Sum[l[i + 4]^2, {i, 1, 4}] == S21[S12S22[[j, 2]]], l[5] <= l[6] <= l[7] <= l[8]}, Table[l[i], {i, 5, 8}], Integers]; If[Length[s1] != 0 && Length[s2] != 0, Do[AppendTo[str, Sort[Union[s1[[k]], s2[[kk]]]]], {k, 1, Length[s1]}, {kk, 1, Length[s2]}]]; If[IntegerQ[j/10], Print[j]]), {j, 1, Length[S12S22]}] // Timing

Можно не пользоваться встроенной функцией Solve, она с опцией Integers всё равно ищет целочисленные решения обычным перебором, но для маленького числа переменных (в нашем случае их четыре) ускорение по-моему не будет существенным. В цикле есть место

If[Length[s1] != 0 && Length[s2] != 0, Do[AppendTo[str, Sort[Union[s1[[k]], s2[[kk]]]]], {k, 1, Length[s1]}, {kk, 1, Length[s2]}]]

То есть если одновременно нашлись решения, то мы составляем из найденных решений всевозможные комбинации, они являются решениями для восьмигранника. Наконец, формируем отсортированный массив найденных решений и выбрасываем повторяющиеся:

STR = {}; Do[ AppendTo[STR, Sort[{Last[str[[i, 1]]], Last[str[[i, 2]]], Last[str[[i, 3]]], Last[str[[i, 4]]], Last[str[[i, 5]]], Last[str[[i, 6]]], Last[str[[i, 7]]], Last[str[[i, 8]]]}]], {i, 1, Length[str]}] 
Union[STR] 
Length[Union[STR]]

Ссылка на nb файл:
https://dropmefiles.com/Z3OPd
Кстати, пока писал сообщение подумал, что надо попробовать каждый раз разбивать суммы на два слагаемых, то есть собрать всё вышеописанное в одну процедуру и вызывать её рекурсивно. Почти уверен, что тогда до додекаэдра доберёмся очень легко. Ведь идея Sender ускоряет процесс в несколько раз.

[alisa-lebovski]

Спасибо, интересно, обдумаю.