7
$\begingroup$

I try to realize the graphical linear programming method. Here is my code

Clear[GraphicalMethod]
GraphicalMethod[L_?VectorQ, A_?MatrixQ, b_?VectorQ, vars_?VectorQ] := 
 Module[{obj = L.vars, 
   cond = Thread[A.vars <= b]~Join~Thread[vars >= 0], r, sol, x1, x2},
  sol = Maximize[{L.vars, Thread[A.vars <= b]~Join~Thread[0 <= vars]},
     vars];
  x1 = Max[
    First@vars /. Solve[#, First@vars] & /@ 
     Thread[First /@ (A.vars) == b]];
  x2 = Max[
    Last@vars /. Solve[#, Last@vars] & /@ 
     Thread[Last /@ (A.vars) == b]];
  r = Sequence[Evaluate@{First@vars, 0, x1}, 
    Evaluate@{Last@vars, 0, x2}];
  Print[sol];
  Manipulate[
   Show[RegionPlot[And @@ cond, Evaluate@r, 
     BoundaryStyle -> {Blue, Thick}], 
    ContourPlot[Evaluate@Apply[Equal, cond, 1], Evaluate@r, 
     ContourStyle -> {{Blue, Thick}}],
    ContourPlot[obj == k, Evaluate@r, ContourStyle -> {{Red, Thick}}]
    ], {{k, N@(First@sol)/2, "Objective Function"}, 0, First@sol, 
    Appearance -> "Open"}]]

GraphicalMethod[{12, 15}, {{4, 3}, {2, 5}}, {12, 10}, {x[1],x[2]}]

It can work for this example, but if we have conditions for 1 variable

GraphicalMethod[{12, 15}, {{4, 0}, {2, 5}}, {12, 10}, {x[1],x[2]}]

it

x1 = Max[First@vars /. Solve[#, First@vars] & /@ 
    Thread[First /@ (A.vars) == b]];
x2 = Max[Last@vars /. Solve[#, Last@vars] & /@ 
    Thread[Last /@ (A.vars) == b]];

gives False and function will not work. I understand why, but I haven't another ideas how to get the optimal interval r for x[1] and x[2]. Can you help me?

|improve this question
$\endgroup$
  • 1
    $\begingroup$ Have you seen LinearProgramming which might ease the input of the problem? $\endgroup$ – gwr Nov 10 '15 at 14:14
  • $\begingroup$ Welcome to Mathematica.SE! I suggest the following: 0) Browse the common pitfalls question 1) As you receive help, try to give it too, by answering questions in your area of expertise. 2) Read the faq! 3) When you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge. Also, please remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign! $\endgroup$ – Dr. belisarius Nov 10 '15 at 15:00
6
$\begingroup$

I believe the following does more or less the same and is much easier to read:

Clear[GraphicalMethod];
GraphicalMethod[c_?VectorQ, m_?MatrixQ, b_?VectorQ] :=
 Module[{k, eqs, l2, l1, jeq, x = {x1, x2}},
  k = c.LinearProgramming[-c, m, Thread[{b, -1}]];
  eqs = Reduce /@ Thread[m.x == b];
  jeq = Join[eqs, {k == x.c}];
  {l2, l1} = Max@Flatten[Solve /@ (jeq /. # -> 0)][[All, 2]] & /@ x;
  Manipulate[
   Show[
    RegionPlot [And@@ Thread[m.x <= b], {x1, 0, l1}, {x2, 0, l2}],
    ContourPlot[Evaluate@eqs,           {x1, 0, l1}, {x2, 0, l2}],
    ContourPlot[k1 == x.c,              {x1, 0, l1}, {x2, 0, l2},ContourStyle -> Red]],
   {{k1, k/2, "Objective Function"}, 0, k}]]

c = {12, 15};
m = {{4, 3}, {2, 5}};
b = {12, 8};

GraphicalMethod[c, m, b]

Mathematica graphics

|improve this answer
$\endgroup$
  • $\begingroup$ Brilliant :) I'm very grateful to you $\endgroup$ – luck_liv Nov 11 '15 at 13:37
  • $\begingroup$ One more question: maybe, it's better to write k = c.LinearProgramming[-c, m, Thread[{b, -1}]] ? $\endgroup$ – luck_liv Nov 12 '15 at 16:07
  • $\begingroup$ @luck_liv Why do you think that that is better? $\endgroup$ – Dr. belisarius Nov 12 '15 at 16:49
  • 1
    $\begingroup$ LinearProgramming[c,m,b] finds a vector x that minimizes the quantity c.x subject to the constraints m.x>=b and x>=0. So, if it's maximize problem, we need to minimize the quantity -c.x subject to the constraints m.x<=b and x>=0. GraphicalMethod[{2, 4}, {{-2, 3}, {1, 1}, {3, -2}}, {12, 9, 12}] gives the wrong answer if k = c.LinearProgramming[c, m, b] $\endgroup$ – luck_liv Nov 12 '15 at 17:19
  • $\begingroup$ @luck_liv Oh, I see. You're right. Going to edit the code. Thanks a lot for checking it $\endgroup$ – Dr. belisarius Nov 12 '15 at 17:25
5
$\begingroup$

The following is a quick and dirty patch. You can do something more elegant taking it as a template:

Clear[GraphicalMethod]
GraphicalMethod[L_?VectorQ, A_?MatrixQ, b_?VectorQ, vars_?VectorQ] := 
 Module[{obj = L.vars, cond = Thread[A.vars <= b]~Join~Thread[vars >= 0], r, sol, x1, x2},
   sol = Maximize[{L.vars, Thread[A.vars <= b]~Join~Thread[0 <= vars]}, vars];
  x1 = Max[First@vars /. Solve[#, First@vars] & /@ Thread[First /@ (A.vars) == b]];
  x2 = Max[Last@vars /. Solve[#, Last@vars] & /@ Thread[Last /@ (A.vars) == b]];
  x2 = First@ If[NumericQ[x2], {x2}, Evaluate[ Last[vars]] /. (Solve[
        obj == sol[[1]] /. Evaluate[First[vars]] -> 0])];
  x1 = First@ If[NumericQ[x1], {x1}, Evaluate[First[vars]] /. (Solve[
        obj == sol[[1]] /. Evaluate[Last[vars]] -> 0])];
  r = Sequence[Evaluate@{First@vars, 0, x1}, Evaluate@{Last@vars, 0, x2}];

  Print[sol];
  Manipulate[Show[
    RegionPlot[And @@ cond, Evaluate@r, BoundaryStyle -> {Blue, Thick}], 
    ContourPlot[Evaluate@Apply[Equal, cond, 1], Evaluate@r, ContourStyle -> {{Blue, Thick}}],
    ContourPlot[obj == k, Evaluate@r, 
     ContourStyle -> {{Red, Thick}}]], {{k, N@(First@sol)/2, 
     "Objective Function"}, 0, First@sol, Appearance -> "Open"}]]

And then

Row[{
  GraphicalMethod[{12, 15}, {{4, 3}, {2, 5}}, {12, 10}, {x[1], x[2]}],
  GraphicalMethod[{12, 15}, {{4, 0}, {2, 5}}, {12, 10}, {x[1], x[2]}],
  GraphicalMethod[{12, 15}, {{4, 0}, {0, 5}}, {12, 10}, {x[1], x[2]}]}]

Mathematica graphics

|improve this answer
$\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.