2
$\begingroup$

I have a system of equations/inequalities involving 36 numbers $p_{11},p_{12},...,p_{16},p_{21},...,p_{66}$.

I have some equations/inequalities, such as

(i) $0\le p_{i,j}\le 1$ for all $i,j$.

(ii) the sum of all the terms $$\sum_{i,j=1}^{6}p_{ij}\le 1,$$

(iii) the sum along each of the 6 rows $$\sum_{j=1}^6p_{1j}=\frac{4}{15},\sum_{j=1}^6p_{2j}=\frac{2}{15},\sum_{j=1}^6p_{3j}=\frac{4}{45},\sum_{j=1}^6p_{4j}=\frac{1}{15},\sum_{j=1}^6p_{5j}=\frac{4}{75},\sum_{j=1}^6p_{6j}=\frac{2}{45},$$

and

(iv) the sum along each of the 6 columns $$\sum_{i=1}^6p_{i1}\le\frac{1}{6},\sum_{i=1}^6p_{i2}\le \frac{1}{6},\sum_{i=1}^6p_{i3}\le\frac{1}{6},\sum_{i=1}^6p_{i4}\le\frac{1}{6},\sum_{i=1}^6p_{i5}\le1/6,\sum_{i=1}^6p_{i6}\le\frac{1}{6}.$$

I am trying to estimate certain sums of the $p_{i,j}$'s. For example, I am interested in whether $p_{14}+p_{16}+p_{34}+p_{54}+p_{56}>\frac{1}{6}.$

Perhaps there is not not info in this particular case to make a conclusion, but I would like to learn how to implement this in Mathematica in case I use a different list of entries.

Is there a way to answer such questions on Mathematica?

$\endgroup$
  • $\begingroup$ Your condition in (ii) doesn't make sense -- you are summing over i but there is no i in the term being summed. But as a strategy for solving the problem: why not start with a smaller problem (say 3 by 3) and try to solve it there first? $\endgroup$ – bill s May 12 '17 at 12:46
  • $\begingroup$ It would be helpful to have actual code provided. $\endgroup$ – Daniel Lichtblau May 12 '17 at 15:26
4
$\begingroup$

Yes, this is a standard sort of linear programming problem.

Here is the basic setup.

pmat = Array[p, {6, 6}];
vars = Flatten[pmat];
c1 = Map[0 <= # <= 1 &, vars];
c2 = Thread[Total[pmat] <= 1/6];
c3 = Thread[
   Total[pmat, {2}] == {4/15, 2/15, 4/45, 1/15, 4/75, 2/45}];
constraints = Join[c1, c2, c3];

Form the objective function.

posns = {{1, 4}, {1, 6}, {3, 4}, {5, 4}, {5, 6}};
obj = Total[Apply[p, posns, {1}]]

(* Out[992]= p[1, 4] + p[1, 6] + p[3, 4] + p[5, 4] + p[5, 6] *)

See if it can exceed 1/6 (method: find its max).

Maximize[{obj, constraints}, vars]

(* Out[1005]=
 {1/3, {p[1, 1] -> 19/450, p[1, 2] -> 1/30, p[1, 3] -> 0, 
  p[1, 4] -> 11/450, p[1, 5] -> 0, p[1, 6] -> 1/6, p[2, 1] -> 0, 
  p[2, 2] -> 2/15, p[2, 3] -> 0, p[2, 4] -> 0, p[2, 5] -> 0, 
  p[2, 6] -> 0, p[3, 1] -> 0, p[3, 2] -> 0, p[3, 3] -> 0, 
  p[3, 4] -> 4/45, p[3, 5] -> 0, p[3, 6] -> 0, p[4, 1] -> 0, 
  p[4, 2] -> 0, p[4, 3] -> 1/15, p[4, 4] -> 0, p[4, 5] -> 0, 
  p[4, 6] -> 0, p[5, 1] -> 0, p[5, 2] -> 0, p[5, 3] -> 0, 
  p[5, 4] -> 4/75, p[5, 5] -> 0, p[5, 6] -> 0, p[6, 1] -> 0, 
  p[6, 2] -> 0, p[6, 3] -> 2/45, p[6, 4] -> 0, p[6, 5] -> 0, 
  p[6, 6] -> 0}} *)

So that sum can be as large as 1/3 which answers in the affirmative that it can exceed 1/6. Is it of necessity greater? That can be answered with a minimization.

Minimize[{obj, constraints}, vars]

(* Out[1042]= {0, {p[1, 1] -> 1/6, p[1, 2] -> 1/10, p[1, 3] -> 0, 
  p[1, 4] -> 0, p[1, 5] -> 0, p[1, 6] -> 0, p[2, 1] -> 0, 
  p[2, 2] -> 1/15, p[2, 3] -> 11/450, p[2, 4] -> 19/450, p[2, 5] -> 0,
   p[2, 6] -> 0, p[3, 1] -> 0, p[3, 2] -> 0, p[3, 3] -> 4/45, 
  p[3, 4] -> 0, p[3, 5] -> 0, p[3, 6] -> 0, p[4, 1] -> 0, 
  p[4, 2] -> 0, p[4, 3] -> 0, p[4, 4] -> 1/15, p[4, 5] -> 0, 
  p[4, 6] -> 0, p[5, 1] -> 0, p[5, 2] -> 0, p[5, 3] -> 4/75, 
  p[5, 4] -> 0, p[5, 5] -> 0, p[5, 6] -> 0, p[6, 1] -> 0, 
  p[6, 2] -> 0, p[6, 3] -> 0, p[6, 4] -> 2/45, p[6, 5] -> 0, 
  p[6, 6] -> 0}} *)

So this sum can indeed be smaller than 1/6.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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