Wolfram mathematica 寻找21元不等式的界

关于21个变量，我有以下不等式：

当我在上面运行Reduce[ineq，Integers]时，Mathematica挂起一个 好久不见了

这是有道理的：x[1]…x[21]有许多组值 满足不等式

---

我真正想要的是每个变量的界，例如，2是否有许多满足不等式的值集

我通过Mathematica运行了以下命令：

In[14]:= ineqs = {x0 == 3, x1 >= 1, x1 <= x0, x2 >= 1, x2 <= x1, 
       x3 >= 1, x3 <= x2, x4 >= 1, x4 <= x3, x5 <= x4 + 3, x5 >= 1, 
       x6 >= 1, x6 <= x5, x7 >= 1, x7 <= x6, x8 >= 1, x8 <= x7, x9 >= 1, 
       x9 <= x8, x10 >= 1, x10 <= x9, x11 >= 1, x11 <= x10, x12 >= 1, 
       x12 <= x11, x13 >= 1, x13 <= x12, x14 <= x13 + 4, x14 >= 1, 
       x15 >= 1, x15 <= x14, x16 >= 1, x16 <= x15, x17 <= x16 + 6, 
       x17 >= 1, x18 >= 1, x18 <= x17, x19 >= 1, x19 <= x18, x20 >= 1, 
       x20 <= x19, x21 >= 1, x21 <= x20, x21 == 1};

In[15]:= vars = 
      Union[{x0, x1, x1, x2, x2, x3, x3, x4, x4, x5, x5, x6, x6, x7, x7, 
        x8, x8, x9, x9, x10, x10, x11, x11, x12, x12, x13, x13, x14, x14, 
        x15, x15, x16, x16, x17, x17, x18, x18, x19, x19, x20, x20, x21, 
        x21, x21}];

In[16]:= FindInstance[ineqs, vars]

---

我还没能说服Mathematica提供另一套作业，用铅笔和纸做的一点工作并不能让我找到其他的作业。但时间已经晚了，我可能错过了一些明显的东西。

好吧，结果证明，解这组特殊的方程是非常困难的 简单，只要稍微重写其中一些：

x5 <= x4 + 3 becomes x5 - 3 <= x4 
x6 <= x5 becomes x6 - 3 <= x5 - 3 

依此类推，直至：

x13 <= x12 becomes x13 - 3 <= x12 - 3 
x14 <= x13 + 4 becomes x14 - 7 <= x13 -3 

通过这样做，{x0，x1，x2，x3，x4，x5-3，x6-3，…，x13-3，x14-7，…，x21} 成为从3开始的严格递减整数序列 以1结束

事实上，任何具有该属性的序列都是有效的，因为xi>=1是三位一体的 满意

然而，虽然这可以解决这一特定的问题 不等式，它一般不起作用，所以我不认为它是

---

完整的解决方案

我支持另一个线程中给出的CLPFD建议。使用SWI Prolog 5.10：

:- use_module(library(clpfd)).

vars([X0,X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,X11,X12,X13,X14,X15,X16,X17,X18,
      X19,X20,X21]) :-
        X0 #= 3, X1 #>= 1, X1 #=< X0, X2 #>= 1, X2 #=< X1,
        X3 #>= 1, X3 #=< X2, X4 #>= 1, X4 #=< X3, X5 #=< X4 + 3,
        X5 #>= 1, X6 #>= 1, X6 #=< X5, X7 #>= 1, X7 #=< X6,
        X8 #>= 1, X8 #=< X7, X9 #>= 1, X9 #=< X8, X10 #>= 1,
        X10 #=< X9, X11 #>= 1, X11 #=< X10, X12 #>= 1, X12 #=< X11,
        X13 #>= 1, X13 #=< X12, X14 #=< X13 + 4, X14 #>= 1, X15 #>= 1,
        X15 #=< X14, X16 #>= 1, X16 #=< X15, X17 #=< X16 + 6, X17 #>= 1,
        X18 #>= 1, X18 #=< X17, X19 #>= 1, X19 #=< X18, X20 #>= 1,
        X20 #=< X19, X21 #>= 1, X21 #=< X20, X21 #= 1.

---

现在已经足够晚了，可能有一些光滑的减少，但这是有效的

ineq={...}; pivotAt[set_, j_] := Select[set, And[ Not[FreeQ[#, x[u_] /; u <= j]], FreeQ[#, x[u_] /; u > j] ] &] triangularize[set_] := Module[{left, i, new}, left = set; Reap[ For[i = 0, i <= 21, i++, new = pivotAt[left, i]; Sow[new]; left = Complement[left, new]; ]][[2, 1]] ] Module[{ tri, workingIntervals, partials, increment, i }, tri = triangularize[ineq]; workingIntervals[set_] := set /. { t_ <= c_ :> {t, Interval[{-\[Infinity], Max[c]}]}, t_ == c_ :> {t, Interval[{Min[c], Max[c]}]}, t_ >= c_ :> {t, Interval[{Max[c], \[Infinity]}]}}; partials = {}; increment[slice_] := Rule[#[[1, 1]], IntervalIntersection @@ #[[All, 2]]] &[ workingIntervals[slice /. partials ] ]; For[i = 1, i <= Length[tri], i++, partials = Join[partials, {increment[tri[[i]]]}]; ]; partials ] 这是允许的，因为变量之间的相关性如此之高意味着不考虑低

-编辑-

当然，上述的结果是

{x[0] -> Interval[{3, 3}], x[1] -> Interval[{1, 3}], x[2] -> Interval[{1, 3}], x[3] -> Interval[{1, 3}], x[4] -> Interval[{1, 3}], x[5] -> Interval[{1, 6}], x[6] -> Interval[{1, 6}], x[7] -> Interval[{1, 6}], x[8] -> Interval[{1, 6}], x[9] -> Interval[{1, 6}], x[10] -> Interval[{1, 6}], x[11] -> Interval[{1, 6}], x[12] -> Interval[{1, 6}], x[13] -> Interval[{1, 6}], x[14] -> Interval[{1, 10}], x[15] -> Interval[{1, 10}], x[16] -> Interval[{1, 10}], x[17] -> Interval[{1, 16}], x[18] -> Interval[{1, 16}], x[19] -> Interval[{1, 16}], x[20] -> Interval[{1, 16}], x[21] -> Interval[{1, 1}]}

---

我很确定把x1改成2也行。事实上，我认为形式3,3,3..1,1,1的许多序列也可以工作。除了X0、X5、X14、X17、X21之外，大多数席的方程是相同的，所以我很确定，例如从3到1的下降可以发生在X1和X4之间的任何点上。虽然你可以得到2的外边界，但你绝对正确。我想说的是，我会接受界限。我不需要整个20维的有效点格。那么，有没有一种有效的边界求解方法？ ineq={...}; pivotAt[set_, j_] := Select[set, And[ Not[FreeQ[#, x[u_] /; u <= j]], FreeQ[#, x[u_] /; u > j] ] &] triangularize[set_] := Module[{left, i, new}, left = set; Reap[ For[i = 0, i <= 21, i++, new = pivotAt[left, i]; Sow[new]; left = Complement[left, new]; ]][[2, 1]] ] Module[{ tri, workingIntervals, partials, increment, i }, tri = triangularize[ineq]; workingIntervals[set_] := set /. { t_ <= c_ :> {t, Interval[{-\[Infinity], Max[c]}]}, t_ == c_ :> {t, Interval[{Min[c], Max[c]}]}, t_ >= c_ :> {t, Interval[{Max[c], \[Infinity]}]}}; partials = {}; increment[slice_] := Rule[#[[1, 1]], IntervalIntersection @@ #[[All, 2]]] &[ workingIntervals[slice /. partials ] ]; For[i = 1, i <= Length[tri], i++, partials = Join[partials, {increment[tri[[i]]]}]; ]; partials ] {x[0] -> Interval[{3, 3}], x[1] -> Interval[{1, 3}], x[2] -> Interval[{1, 3}], x[3] -> Interval[{1, 3}], x[4] -> Interval[{1, 3}], x[5] -> Interval[{1, 6}], x[6] -> Interval[{1, 6}], x[7] -> Interval[{1, 6}], x[8] -> Interval[{1, 6}], x[9] -> Interval[{1, 6}], x[10] -> Interval[{1, 6}], x[11] -> Interval[{1, 6}], x[12] -> Interval[{1, 6}], x[13] -> Interval[{1, 6}], x[14] -> Interval[{1, 10}], x[15] -> Interval[{1, 10}], x[16] -> Interval[{1, 10}], x[17] -> Interval[{1, 16}], x[18] -> Interval[{1, 16}], x[19] -> Interval[{1, 16}], x[20] -> Interval[{1, 16}], x[21] -> Interval[{1, 1}]}