$Author: leiser $
$Id: LagrangeMultiplier.nb 2058 2010-03-12 10:08:45Z leiser $
$LastChangedDate: 2010-03-12 11:08:45 +0100 (Fri, 12 Mar 2010) $

fastMode = False; (* Tweak performance here *)
cinit=1.5;
showLeveLCurves =True;
showVectors=True;
viewPoint=N[{Pi,Pi,0.3}];
cmax=2.6;
extremumLimitAngle = 8;
f[x_,y_]:=-x^2- y-1;
fx[x_,y_]:=D[f[x,y],x];
fy[x_,y_]:=D[f[x,y],y];
NormGradf[c_,t_] :=Norm[{fx[x,y]/.{x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
fy[x,y]/. {x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
0
}];
g[x_,y_]:=x^2+y^2;
gx[x_,y_]:=D[g[x,y],x];
gy[x_,y_]:=D[g[x,y],y];
NormGradg[c_,t_] :=Norm[{gx[x,y]/.{x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
gy[x,y]/. {x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
0
}];
constrPlot2D[c_]:=ParametricPlot[
N[{Sqrt[c]*Sin[x],Sqrt[c]*Cos[x]}],
{x,0,2Pi},
PlotStyle->Directive[Thickness[0.003],RGBColor[0,0,1]]];
po={1,0};
t=0;
caption=;

(*CELL WITH TABS AND MANIPULATE (S)*)
TabView[{
(*First Tab*)
Style["Lagrange-Multiplikatoren",14,Bold]->Column[{

(*First Row (Header and Explanation Button*)
Row[{Button[Style["Hinweise",9],
CreateDocument[
TextCell[
Pane[
Column[{
(*Explanation Texts*)
TextCell[Row[{
"\nDiese Visualisierung illustriert die Methode der Lagrange-Multiplikatoren ",
"an einem Beispiel. Es sollen die lokalen Extrema einer Funktion ",
Text[Style["f(x,y) := -(x^2)-y-1"],14],
" unter der Nebenbedingung ",
Text[Style["g(x,y) := (x^2)+(y^2) = c (c∈ℝ)",14]],
" gefunden werden.\n"}],
12,FontFamily-> "Helvetica"],
TextCell[Row[{
"Als erstes können Sie die Konstante c einstellen und damit die genaue Nebenbedingung festlegen.\n\n",
"Bewegen Sie mit der Maus den Punkt auf dem Kreis unten links und beobachten Sie, wie die beiden ",
"Gradientenvektoren (grau der Zielfunktion, blau der Nebenbedingung) sich verändern.",
"Oberhalb des Plots wird hierbei der Winkel zwischen den Gradientenvektoren angezeigt. Wenn Sie sich einem kritischen Punkt nähern, wechselt die Farbe der Gradienten auf rot. Im kritischen Punkt sind die Gradienten kollinear und der Winkel ",Text[Style["(0^◦), bzw. (180^◦)",14]],". \n\n",
"Verwenden Sie die Perspektive 'Von unten', um die Situation der Niveaulinien zu studieren. Probieren Sie aus, ","wie sich eine Veränderung der Nebenbedingung (Konstante c) auswirkt.\n\n"
}],12,FontFamily-> "Helvetica"]
(*more,if necessary...*)
(*End Explanation Texts*)
}]
]
],(*End TextCell*)
WindowFrame->"Normal",WindowSize->{650,500},WindowTitle->"Hinweise"
],(*End CreateDocument*)
ImageSize->{80,20}]},(*End Button*)
ImageSize->{960,25},Background->RGBColor[0.9,0.9,0.9],Alignment->{Right,Top}],
(*End Row*)

(*Second Row:Manipulate element*)
Manipulate[

t=If[
ArcTan[po[[1]]/Norm[po],po[[2]]/Norm[po]]≥0,
Evaluate[-(9Pi)/18-ArcTan[po[[1]]/Norm[po],po[[2]]/Norm[po]]],
Evaluate[-(9 Pi)/18-2 Pi-ArcTan[po[[1]]/Norm[po],po[[2]]/Norm[po]]]
];
(* REM: "Strange shift" of -Pi/3 only introduced for intuitive location on circle *)
angleInDegrees =Round[
VectorAngle[{fx[x,y]/.{x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
fy[x,y]/. {x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]}},
{gx[x,y]/.{x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
gy[x,y]/. {x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]}}]*(180/3.1414),0.01];

Column[{
Row[{""}],
Row[{  (* Info line above plot *)
Text[Style["∠(∇f,∇g) = ",14,RGBColor[0,0,0]]],
" ",
Text[Style[
angleInDegrees
,14,
If[Abs[angleInDegrees] < extremumLimitAngle 
|| Abs[180-angleInDegrees] <  extremumLimitAngle,
RGBColor[1,0,0],
RGBColor[0,0,0]]]
],
Text[Style["\!\(\*SuperscriptBox[\(\\ \), \(°\)]\)",14,
If[Abs[angleInDegrees] < extremumLimitAngle 
|| Abs[180-angleInDegrees] <  extremumLimitAngle,
RGBColor[1,0,0],
RGBColor[0,0,0]]]
]
}],
Row[{
 Text[Style["∇f ≈ λ∇g  ⟹  NEAR LOCAL EXREMUM!",14,
If[Abs[angleInDegrees] < extremumLimitAngle 
|| Abs[180-angleInDegrees] <  extremumLimitAngle,
RGBColor[1,0,0,1],
RGBColor[0,0,0,0]]
]]
}],
Show[

(* Plot of function g(x,y), which defines constraint (see below) *)
If[showPlotOfg,
Plot3D[g[x,y],{x,-2,2},{y,-2,2},
Mesh->None,ColorFunction->Function[{x,y,z},RGBColor[0,0,1]],
PlotRange->{{-2,2},{-2,2},{-2,cmax}},PlotStyle->Directive[Opacity[0.4]],
ClippingStyle->None],
Plot3D[,{x,-2,2},{y,-2,2}]
],

(* Plot of objective function f(x,y) *)
Plot3D[f[x,y],{x,-2,2},{y,-2,2},
Mesh->None,ColorFunction->Function[{x,y,z},RGBColor[0.5,0.5,0.5]],
PlotRange->{{-2,2},{-2,2},{-4,Automatic}},PlotStyle->Directive[Opacity[0.4]],
ClippingStyle->None],

(* Plot of f, for all solutions of constraints, ie, f(D) for D = {(x,y) | g(x,y) = c} *)
ParametricPlot3D[
N[{Sqrt[c]*Sin[x],Sqrt[c]*Cos[x],f[Sqrt[c]*Sin[x],Sqrt[c]*Cos[x]]}],
{x,0,2Pi},
PlotStyle->Directive[Thickness[0.003],RGBColor[0,0,1]]],

(* Plot of constraint g(x,y) = c *)
constr=ParametricPlot3D[
N[{Sqrt[c]*Sin[x],Sqrt[c]*Cos[x],c}],
{x,0,2Pi},
PlotStyle->Directive[Thickness[0.003],RGBColor[0,0,1,If[showPlotOfg,0.4,0]]]],

(* Level curves of g (beware: affects performance!) *)
ParametricPlot3D[
If[showLevelCurveOfFunctiong,
{Table[N[{Sqrt[c+delta]*Sin[x],Sqrt[c+delta]*Cos[x],-4}],{delta,0,0,0.2}]}
],
{x,0,2Pi},
PlotStyle->Directive[Thickness[0.002],RGBColor[0,0,0.7,0.3]]
],

(* Level curves of f (beware: affects performance) *)
ParametricPlot3D[
If[showLevelCurveOfFunctionf,
If[fastMode,
N[{x,Solve[f[x,y]==f[Sqrt[c]*Sin[x],Sqrt[c]*Cos[x]]][[1]][[1]][[2]],-4}],
{Table[N[{x,Solve[f[x,y]==f[Sqrt[c]*Sin[x],Sqrt[c]*Cos[x]]][[1]][[1]][[2]]+delta,-4}],{delta,{-3,-2,0,1}}]}
]
],
{x,-2,2},
PlotStyle->Directive[Thickness[0.002],RGBColor[0.2,0.2,0.2,0.7]]
],

(* Current point on surface *)
Graphics3D[{PointSize[0.02],
Point[p=N[{Sqrt[c]*Sin[t],Sqrt[c]*Cos[t],f[Sqrt[c]*Sin[t],Sqrt[c]*Cos[t]]}]]
}
],

(* Gradient vector of f *)
If[showGradientVectors,
Graphics3D[
{Arrowheads[{0,.02}],Thickness[0.004],
If[Abs[angleInDegrees] < extremumLimitAngle 
|| Abs[180-angleInDegrees] <  extremumLimitAngle,
RGBColor[1,0,0],
RGBColor[0.2,0.2,0.2]]
,
Arrow[
{
p,
p
+{fx[x,y]/.{x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
fy[x,y]/. {x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
0
} / (1.5 NormGradf[c,t])
}]
}],
Graphics3D[]
],

(* Gradient vector of g *)
If[showGradientVectors,
Graphics3D[
{Arrowheads[{0,.02}],Thickness[0.004],
If[Abs[angleInDegrees] < extremumLimitAngle 
|| Abs[180-angleInDegrees] <  extremumLimitAngle,
RGBColor[1,0,0],
RGBColor[0,0,0.7]]
,
Arrow[{
p,
p
+{gx[x,y]/.{x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
gy[x,y]/. {x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]} ,
0
} /  (1.5 NormGradg[c,t])
}]
}],
Graphics3D[]
],

(* Projection of current point *)
Graphics3D[{PointSize[0.02],RGBColor[0,0,0,If[showGradientVectorsOnLevelCurves,0.3,0]],
Point[N[{Sqrt[c]*Sin[t],Sqrt[c]*Cos[t],-4}]]
}
],

(* Projection of gradient vector of f on level curve *)
If[showGradientVectorsOnLevelCurves,
Graphics3D[
{Arrowheads[{0,.02}],Thickness[0.004],
If[Abs[angleInDegrees] < extremumLimitAngle 
|| Abs[180-angleInDegrees] <  extremumLimitAngle,
RGBColor[1,0,0],
RGBColor[0.2,0.2,0.2]],
Arrow[
{
{p[[1]],p[[2]],-4},
{p[[1]],p[[2]],-4}
+{fx[x,y]/.{x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
fy[x,y]/. {x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
0
} / (1.5 NormGradf[c,t])
}]
}],
Graphics3D[]
],

(* Projection of gradient vector of g on level curve *)
If[showGradientVectorsOnLevelCurves,
Graphics3D[
{Arrowheads[{0,.02}],Thickness[0.004],
If[Abs[angleInDegrees] < extremumLimitAngle 
|| Abs[180-angleInDegrees] <  extremumLimitAngle,
RGBColor[1,0,0],
RGBColor[0,0,0.7]],
Arrow[{
{p[[1]],p[[2]],-4},
{p[[1]],p[[2]],-4}
+{gx[x,y]/.{x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]},
gy[x,y]/. {x->N[Sqrt[c]]*N[Sin[t]],y->N[Sqrt[c]]*N[Cos[t]]} ,
0
} /  (1.5 NormGradg[c,t])
}]
}],
Graphics3D[]
],

PlotRange->{{-2.5,2.5},{-2.5,2.5},{-4.01,cmax}},AspectRatio->1,ImageSize->{550,550},
ViewPoint->Dynamic[viewPoint],AxesLabel->{"x","y","f(x,y)\ng(x,y}"}, 
Background->RGBColor[1,1,1],ImagePadding->60
], (* End Show *)
Row[{Style["Legende:",10,FontFamily-> "Helvetica",Underlined]}],
Image[caption,ImageSize-> {550,Automatic}]

},Center,Background->RGBColor[1,1,1]], (* End Column *)

(* Manipulate parameters *)
Style["Wähle Nebenbedingung:",11],
{{c,cinit,Dynamic[Style["g(x,y) = c ="<>ToString[c],11]]},0.05,cmax,0.1,ControlType->Slider},

"",
{{showPlotOfg,True,Style["Zeige Plot von g(x,y)",11]},{True,False}},
"",
{{showLevelCurveOfFunctionf,True,Style["Zeige Niveaukurven von f(x,y)",11]},{True,False}},
"",
{{showLevelCurveOfFunctiong,True,Style["Zeige Niveaukurve für g(x,y) = c",11]},{True,False}},
"",
{{showGradientVectorsOnLevelCurves,True,Style["Zeige Gradientenvektoren auf Niveaukurven",11]},{True,False}},
"",
{{showGradientVectors,True,Style["Zeige Gradientenvektoren",11]},{True,False}},
"",
{{viewPoint,N[{Pi,Pi,0.3}]->Style["Standard",11],Style["Perspektive:",11]},
{N[{Pi,Pi,0.3}]->Style["Standard",11],N[{0,0,-Infinity}]->Style["Von unten",11]},ControlType->RadioButton},
"",

Delimiter,
Style["Mit der Maus den Punkt bewegen:",11],
Dynamic[
LocatorPane[
Dynamic[po],
Graphics[
Show[
ParametricPlot[{Sin[x],Cos[x]},{x,0,2 Pi},Axes-> None],
Graphics[{PointSize[Large],Dynamic[Point[po/Norm[po]]]}
],
Background-> RGBColor[1,1,1,0],ImageMargins-> {{50,10},{10,10}}
]
],Appearance->None
]
],

SaveDefinitions->True,AppearanceElements->None,ControlPlacement->Left,Paneled->False ,SynchronousInitialization->True
]
(*End Manipulate*)
(*End Second Row*)
},Background->RGBColor[0.92,0.92,0.92]] (*End Column*)
(*End First Tab*)


},Background->RGBColor[1,1,1](*TabView Background*)
] (*End TabView*)

(*END OF CELL WITH TAB AND MANIPULATE (S)*)

2010, Team LEMUREN und Meike Akveld, Departement Mathematik, ETH Zürich | Licence: CC-BY-SA

Rel. 1.0 | $LastChangedDate  2010-03-12 11:08:45 +0100 (Fri, 12 Mar 2010) $