Optimizing Subject to a Constraint

Code

graphics:=(
points=If[showLagrangePoints,{Green,PointSize[0.03],Point[{{x,y,f[x,y]}/.NSolve[Grad[f[x,y],{x,y}]==lambda*Grad[constraint[x,y],{x,y}]&&constraint[x,y]==0,{x,y,lambda},Reals]}]},{}];
xyConstraint=If[showConstraintInXYPlane,ContourPlot3D[constraint[x,y]==0,{x,xLeft,xRight},{y,yLeft,yRight},{z,-1,1},MeshFunctions->{#3&},Mesh->{{0}},MeshStyle->{{Gray,Thickness[0.008]}},ContourStyle->Opacity[0],BoundaryStyle->None],{}];
meshFunctions=If[showConstraintOnSurface,{#1&,#2&,constraint[#1,#2]&},{#1&,#2&}];
mesh={10,10,{0}};
meshStyle={Automatic,Automatic,{Red,Thickness[0.008]}};
If[showConstraintOnSurface,Append[meshFunctions,constraint],];
xyPlane=If[showXYPlane,Plot3D[0,{x,xLeft,xRight},{y,yLeft,yRight},Mesh->None,PlotStyle->Opacity[xyOpacity]],{}];
Show[Graphics3D[{points}],xyPlane,xyConstraint,Plot3D[f[x,y],{x,xLeft,xRight},{y,yLeft,yRight},MeshFunctions->meshFunctions,Mesh->mesh,MeshStyle->meshStyle,PlotStyle->Opacity[surfaceOpacity]],Axes->Automatic,AxesLabel->{x,y,z},BoxRatios->{1,1,1},PlotRange->Automatic,ViewPoint->{20,4,8},Ticks->ticks]);

Graphics

f[x_,y_]:=y^2-x;
constraint[x_,y_]:=2x^2+2x y + y^2-1;
showXYPlane=True;
showConstraintInXYPlane=True;
showConstraintOnSurface=True;
showLagrangePoints=True;

(*Display parameters*)
xLeft=-3/2;
xRight=3/2;
yLeft=-3/2;
yRight=3/2;
ticks->Automatic;
xyOpacity=0.5;
surfaceOpacity=0.75;

graphics

Constrained Extrema and Level Curves

Code

graphics[t_]:=(
currentZ=(1-t)*min+t*max;
points=Graphics[{Green,PointSize[0.02],Point[Take[#,2]&/@Select[extrema,#[[3]]<currentZ&]]}];
Show[contourPlot,constraintPlot,points,ContourPlot[f[x,y]==currentZ,{x,-4,4},{y,-4,4},ContourStyle->{Green,Thickness[0.008]}],Graphics[points],Axes->Automatic,AxesLabel->{x,y},PlotRange->{{-4,4} ,{-4,4}},Ticks->ticks])

animationInitial :=(
extrema={x,y,f[x,y]}/.NSolve[Grad[f[x,y],{x,y}]==lambda*Grad[constraint[x,y],{x,y}]&&constraint[x,y]==0,{x,y,lambda},Reals];
min=Minimize[{f[x,y],xLeft≤x≤xRight,yLeft≤y≤yRight},{x,y}][[1]];
max=Maximize[{f[x,y],xLeft≤x≤xRight,yLeft≤y≤yRight},{x,y}][[1]];
contourPlot=ContourPlot[f[x,y],{x,-4,4},{y,-4,4},Contours->20];
constraintPlot=ContourPlot[constraint[x,y]==0,{x,-4,4},{y,-4,4},ContourStyle->{Red,Thickness[0.008]},Ticks->ticks];
)

animation:=(
animationInitial;
Table[Image[graphics[t]],{t,0,1,1/(duration*framerate)}]
)

Graphics

It may take several seconds to run this command, as all frames of the animation are precomputed so that it can run smoothly.

f[x_,y_]:=2x^2+3y-x y^2;
constraint[x_,y_]:=x^2+y^2-9;

duration=3;
framerate=12;

(*Display parameters*)
plotRange->{{-4,4},{-4,4}};
xLeft=-32/10;
xRight=32/10;
yLeft=-32/10;
yRight=32/10;
ticks->Automatic;

frames=animation;
ListAnimate[frames,DefaultDuration->duration]

Constrained Extrema and Gradient Vector Fields

Code

graphics:=(
grad=Grad[f[x,y],{x,y}];
extrema={x,y,f[x,y]}/.NSolve[Grad[f[x,y],{x,y}]==lambda*Grad[constraint[x,y],{x,y}]&&constraint[x,y]==0,{x,y,lambda},Reals];

constraintPlot=If[showConstraint,ContourPlot[constraint[x,y]==0,{x,-4,4},{y,-4,4},ContourStyle->{Red,Thickness[0.008]}],{}];
points=If[showLagrangePoints,Graphics[{Green,PointSize[0.02],Point[Take[#,2]&/@extrema]}],{}];
field=VectorPlot[grad,{x,-4,4},{y,-4,4}];
Show[field,constraintPlot,points,Axes->Automatic,AxesLabel->{x,y},PlotRange->{{-4,4} ,{-4,4}}])

Graphics

f[x_,y_]:=2x^2+3y-x y^2;
constraint[x_,y_]:=x^2+y^2-9;
showConstraint=True;
showLagrangePoints=True;
graphics