Методы минимизации целых чисел

Question

Я должен минимизировать набор функций из n переменных, которые могут принимать значения из целочисленного диапазона.

Функции имеют общий вид:

f[{s1_,... sn_}]:= Kxy KroneckerDelta[sx,sy] + Kwz KroneckerDelta[sw,sz] +/- ..

Где Kmn также являются целыми числами.

Например,

f[{s1_, s2_, s3_, s4_, s5_}:= KroneckerDelta[s1, s2] - KroneckerDelta[s1, s4] +
                              KroneckerDelta[s1, s5] + KroneckerDelta[s3, s4] + 
                              KroneckerDelta[s3, s5] + KroneckerDelta[s4, s5]; 

Гдеsi_ должен находиться в диапазоне [3].

Я могу легко переборщить, например:

rulez = Table[s[i] -> #[[i]], {i, 5}] & /@ Tuples[Range[3], 5]; 
k1    = f[Table[s[i], {i, 5}]] /. rulez;

{Min[k1], Tuples[Range[3], 5][[#]] & /@ Position[k1, Min[k1]]}
(*
->
{-1,{{{1, 2, 2, 1, 3}}, {{1, 2, 3, 1, 2}}, {{1, 3, 2, 1, 3}}, {{1, 3, 3, 1, 2}}, 
     {{2, 1, 1, 2, 3}}, {{2, 1, 3, 2, 1}}, {{2, 3, 1, 2, 3}}, {{2, 3, 3, 2, 1}}, 
     {{3, 1, 1, 3, 2}}, {{3, 1, 2, 3, 1}}, {{3, 2, 1, 3, 2}}, {{3, 2, 2, 3, 1}}}}
*)

Очевидно, что для больших наборов переменных и больших диапазонов значений, кажется, потребуется вечность.

Я пытался Minimize[ ], но получаю результаты, которые не удовлетворяют условиям (!):

Minimize[{f[Table[s[i], {i, 5}]],  And @@ Table[1 <= s[i] <= 3, {i, 5}]},
         Table[s[i], {i, 5}], Integers]
(*
-> {2, {s[1] -> 0, s[2] -> 0, s[3] -> 0, s[4] -> 0, s[5] -> 0}}
*)

Или в других случаях просто не получается:

g[{s1_, s2_, s3_, s4_, s5_}]:= KroneckerDelta[s1, s3] - KroneckerDelta[s1, s4] +
                               KroneckerDelta[s1, s5] + KroneckerDelta[s3, s4] + 
                               KroneckerDelta[s3, s5] + KroneckerDelta[s4, s5]; 

Minimize[{g[Table[s[i], {i, 5}]],  And @@ Table[1 <= s[i] <= 3, {i, 5}]},
         Table[s[i], {i, 5}], Integers]
(*
-> 
During evaluation of In[168]:= Minimize::infeas: There are no values of
{s[1],s[2],s[3],s[4],s[5]} for which the constraints 1<=s[1]<=3&&1<=s[2]<=3&&
1<=s[3]<=3&&1<=s[4]<=3&&1<=s[5]<=3 are satisfied and the objective function  
KroneckerDelta[s[1],s[3]]-KroneckerDelta[s[1],s[4]]+KroneckerDelta[s[1],s[5]]+
KroneckerDelta[s[3],s[4]]+KroneckerDelta[s[3],s[5]]+KroneckerDelta[s[4],s[5]] 
is real valued.  >>
Out[169]= {\[Infinity], s[1]->Indeterminate, s[2]->Indeterminate, 
                        s[3]->Indeterminate, s[4]->Indeterminate, 
                        s[5]->Indeterminate}}
*)

Итак, вопрос состоит из двух частей:

Почему Minimize[ ] терпит неудачу? И как лучше решить этот тип проблем с mathematica ?

Редактировать

Просто чтобы подчеркнуть, первый вопрос:

Почему не удается свернуть []?

Не то чтобыдругая часть менее важна, но я пытаюсь понять, когда инвестировать свое время в скрытность с Minimize[ ], а когда нет.

Answer 1

Вы можете установить его как задачу целочисленного линейного программирования и отправить его в Минимизировать в этой форме.Я покажу один из способов сделать это ниже.Дельты Кронекера теперь представляют собой просто целочисленные переменные, ограниченные между 0 и 1, с некоторыми соотношениями, которые заставляют k [i, j] быть 1, когда s [i] == s [j], и ноль в противном случае (при этом используются знаки коэффициента имаксимальное значение коэффициента).

Ниже показан полный набор ограничений, а также выражение, которое мы будем минимизировать.

highval = 3;
list = {{1, 2}, {1, 4}, {1, 5}, {3, 4}, {3, 5}, {4, 5}};
coeffs = {1, -1, 1, 1, 1, 1};
v1list = Apply[k, list, 1];
expr = coeffs.v1list
v2list = Map[s, Range[5]];
allvars = Flatten[{v1list, v2list}];
c1 = Map[0 <= # <= 1 &, v1list];
c2 = Map[1 <= # <= highval &, v2list];
c3 = Map[# <= 0 &, 
   Sign[coeffs]*
    Map[{highval*(# - 1) - (s[#[[1]]] - s[#[[2]]]), 
       highval*(# - 1) - (s[#[[2]]] - s[#[[1]]])} &, v1list], {2}];
c4 = Element[allvars, Integers];
constraints = Flatten[{c1, c2, c3}]

k[1, 2] - k[1, 4] + k[1, 5] + k[3, 4] + k[3, 5] + k[4, 5]  

{0 <= k[1, 2] <= 1, 0 <= k[1, 4] <= 1, 0 <= k[1, 5] <= 1, 0 <= k[3, 4] <= 1, 
 0 <= k[3, 5] <= 1, 0 <= k[4, 5] <= 1,

 1 <= s[1] <= 3, 1 <= s[2] <= 3, 1 <= s[3] <= 3, 1 <= s[4] <= 3, 1 <= s[5] <= 3, 

 3*(-1 + k[1, 2]) - s[1] + s[2] <= 0, 3*(-1 + k[1, 2]) + s[1] - s[2] <=  0, 
-3*(-1 + k[1, 4]) + s[1] - s[4] <= 0,-3*(-1 + k[1, 4]) - s[1] + s[4] <= 0, 
 3*(-1 + k[1, 5]) - s[1] + s[5] <= 0, 3*(-1 + k[1, 5]) + s[1] - s[5] <= 0,  
 3*(-1 + k[3, 4]) - s[3] + s[4] <= 0, 3*(-1 + k[3, 4]) + s[3] - s[4] <= 0, 
 3*(-1 + k[3, 5]) - s[3] + s[5] <= 0, 3*(-1 + k[3, 5]) + s[3] - s[5] <= 0, 
 3*(-1 + k[4, 5]) - s[4] + s[5] <= 0, 3*(-1 + k[4, 5]) + s[4] - s[5] <= 0}

Теперь просто вызовите Minimize, указав Integers в качестве домена.

Minimize[{expr, constraints}, allvars, Integers]

Out[235]= {-1, {k[1, 2] -> 0, k[1, 4] -> 1, k[1, 5] -> 0, 
                k[3, 4] -> 0, k[3, 5] -> 0, k[4, 5] -> 0,
                s[1] -> 2, s[2] -> 2, s[3] -> 2, s[4] -> 2, s[5] -> 2}}

Даниэль Лихтблау Вольфрам Исследования

Answer 2

Проблема, похоже, связана с KroneckerDelta. Если я определяю функцию, которая эквивалентна, пока вводятся целые числа, она работает (или, по крайней мере, выглядит так):

In[177]:= kd[x_, y_] := Round[10^-(x - y)^2]

In[179]:= 
g[{s1_, s2_, s3_, s4_, s5_}] := 
  kd[s1, s3] - kd[s1, s4] + kd[s1, s5] + kd[s3, s4] + kd[s3, s5] + 
   kd[s4, s5];
Minimize[{g[{s1, s2, s3, s4, s5}], 
  And @@ Map[1 <= # <= 3 &, {s1, s2, s3, s4, s5}]}, {s1, s2, s3, s4, 
  s5}, Integers]

Out[180]= {-1, {s1 -> 1, s2 -> 1, s3 -> 2, s4 -> 1, s5 -> 3}}