Code for Electronic Supplement

FindRoots2D

FindRoots2D::usage=
"FindRoots2D[funcs,{x,a,b},{y,c,d}] finds all nontangential solutions to {f=0, g=0} in the given rectangle.";

Options[FindRoots2D]={PlotPoints->Automatic, MaxRecursion->Automatic};

FindRoots2D[funcs_,{x_,a_,b_},{y_,c_,d_},opts___]:=Module[{fZero,seeds,signs,fy},
fy=Compile[{x,y},Evaluate[funcs[[2]]]];
fZero=Cases[Normal[ContourPlot[funcs[[1]]==0,{x,a-((b-a)/97),b+((b-a)/103)},{y,c-((d-c)/98),d+((d-c)/102)},Evaluate[FilterRules[{opts}, Options[ContourPlot]]]]], Line[z_] :> z,∞];
seeds=Flatten[(signs=
Sign[Apply[fy,#,{1}]];#1[[1+Flatten[Position[Rest[signs * RotateRight[signs]],-1]]]])&/@fZero,1];
If[seeds=={},{},Select[Union[
({x,y}/.FindRoot[{funcs[[1]],funcs[[2]]},{x,#[[1]]},{y,#[[2]]},Evaluate[FilterRules[{opts}, Options[FindRoot]]]]&)/@seeds, SameTest -> (Norm[#1-#2]<10^-6&)],a≤#[[1]]≤b&&c≤#[[2]]≤d&]]]

SetOptions[#, ImageSize-> 4 72]& /@ {Graphics, Plot3D, Plot, ContourPlot, DensityPlot, ListContourPlot};

Three-Dimensional Graphs

Code for Chapter Opening Art

.  Using Two-Dimensional Tools

f[x_,y_]:=((x^2)+3 (y^2)) (E^(1-(x^2)-(y^2)));

ContourPlot[f[x,y],{x,-2,2},{y,-2.5,2.5}]

ContourPlot[f[x,y],{x,-2,2},{y,-2.5,2.5},ColorFunction->(Hue[1-((#)/2)]&)]

ContourPlot[f[x,y],{x,-2,2},{y,-2.5,2.5},ColorFunction->ColorData["Temperature"],FrameTicks->{Automatic,Automatic,None,None}]

Manipulate[Column[
{ColorData["Gradients"][[i]],ContourPlot[f[x,y],{x,-2,2},{y,-2.5,2.5},ColorFunction->(ColorData[ColorData["Gradients"][[i]]])]}],{i,1,51,1}]

Manipulate[Pane[Column[{Style[Dynamic[ColorData["Gradients"][[i]]],FontFamily->"Times"],ContourPlot[f[x,y],{x,-2,2},{y,-2.5,2.5},ColorFunction->(Dynamic[ColorData[ColorData["Gradients"][[i]]][#1]]&)]}]],{{i,18},1,51,1}]

ContourPlot[f[x,y],{x,-2,2},{y,-2.5,2.5},FrameTicks->{Range[-2,2],Range[-2,2],None,None},ContourShading->False,Contours->{1,0.5},ContourStyle->{{Thickness[0.015]},{Thickness[0.003]}}]

DensityPlot[f[x,y],{x,-2,2},{y,-2.5,2.5}]

Manipulate[Plot[f[x,y],{y,-2.5,2.5}, PlotRange->{-0.2,3.2}, Frame->True, Axes->False, PlotStyle->{Thick, Black}], {{x,0}, -2.5, 2.5, Appearance->"Labeled"}]

zdata=Table[f[x,y]+RandomReal[{-0.1,0.1}],{y,-2.5,2.5,0.2},{x,-2,2,0.2}];

Short[zdata,15]

ListContourPlot[zdata,ContourShading->False,ContourStyle->Thick, InterpolationOrder->5]

.  Plotting Surfaces

f[x_,y_]:=((x^2)+3 (y^2)) (E^(1-(x^2)-(y^2)));
Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5}]

Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},BoxRatios->Automatic,AxesEdge->{Automatic,{1,-1},{1,1}},AxesLabel->{"x","y",None}]

Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},Mesh -> All,BoxRatios->Automatic,Axes->None, PlotStyle->None,MaxRecursion->4]

Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},BoxRatios->Automatic,AxesEdge->{Automatic,{1,-1},{1,1}},AxesLabel->{"x","y",None},MeshFunctions-> (#3&),MeshStyle->Brown,Mesh->10,RegionFunction -> (#3≥0.2 &)]

Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},BoxRatios->Automatic,AxesEdge->{Automatic,{1,-1},{1,1}},AxesLabel->{"x","y",None},MeshFunctions->{#3&,#2&},MeshStyle->{Directive[Thick,Red],Thick},Mesh->{{1},{1,-1}},RegionFunction->(#3>0.2&)]

Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},
			BoxRatios->{4,5,3},ViewPoint->{0.8,-1,0.6},AxesEdge->{Automatic,{1,-1},{1,1}},AxesLabel->{"x","y","z"},PlotStyle->None,MeshStyle->Directive[Thick,Gray],BoxStyle->{Black,Thickness[0.015]}]

p=Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},BoxRatios->{4,5,3},ViewPoint->{1.6,0,0},Ticks->{{0,-2},Range[-2,2],Range[0,3]},AxesEdge->{{-1,1},Automatic,Automatic},AxesLabel->{None,"y","z"}]

Show[p,ViewPoint->{1.6,0,.3},AxesEdge->{None,{1,-1},None}]

Show[p,ViewPoint->{1.6,0,0.7},AxesEdge->{None,{1,-1},None}]

Show[p,ViewPoint->{0.6,-1.6,0.25},Ticks->{{0,-2,2},{0,-2,2},Range[0,3]},AxesEdge->{{-1,-1},{1,-1},Automatic}]

Manipulate[Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},Ticks->None,BoxRatios->{4,5,3},Ticks->{{0,-2},Range[-2,2],Range[0,3]},SphericalRegion->True,
ViewPoint -> Dynamic[{r Cos[θ],r Sin[θ],z}],PlotLabel->Dynamic[StringForm["ViewPoint = ``",NumberForm[Chop[{r Cos[θ],r Sin[θ],z}],3]]]],{θ,0,2π},{{r,2.5},2,4},{{z,2},0,3}]

Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},Boxed->False,ColorFunction->(Hue[#2]&),Mesh->None,AxesLabel->{"x","y","z"}]

Plot3D[f[x,y],{x,-2,2},{y,-2.5,2.5},Boxed->False,PlotStyle->{Orange,Specularity[White,20]},Mesh->None]

gradient=Simplify[(∂_({{x,y}}))f[x,y]]

cps={x,y}/.Solve[(gradient/(E^(1-(x^2)-(y^2))))=={0,0}]

Reduce[gradient=={0,0}]

{x,y} /. {ToRules[Reduce[gradient=={0,0}]]}

ContourPlot[Evaluate[Thread[gradient==0]],{x,-3,3},{y,-3,3},ContourStyle->{Directive[Red,Thickness[0.012]],Directive[Blue,Thickness[0.012]]}]

cps=Chop[FindRoots2D[gradient,{x,-10,10},{y,-10,10}]]

SecondDerivativeTest[f_,{x_,y_},{a_,b_}]:=Module[{dxx=(∂_(x,x))f/.{x->a,y->b},disc},
disc=dxx (∂_(y,y))f-((((∂_(x,y))f))^2)/.{x->a,y->b};
				Which[dxx<0&&disc>0,"Local maximum",
			            dxx>0&&disc>0,"Local minimum",
			            disc<0,"Saddle point",
			           disc==0,"Test fails"]]

SecondDerivativeTest[f[x,y],{x,y},{0,0}]

TableForm[({SecondDerivativeTest[f[x,y],{x,y},#],#,f@@#}&)/@cps,TableDepth->2,TableHeadings->{None,{"Type","Critical point","Function value"}}]

.  Mixed Partial Derivatives Need Not Be Equal

f=((x y ((x^2)-(y^2)))/((x^2)+(y^2)));
Plot3D[f,{x,-2,2},{y,-2,2},Boxed->False,AxesLabel->{"x","y",None},MeshFunctions->{#1&,#2&,#1&,#2&},Mesh->{15,15,{0},{0}},MeshStyle->{Thin,Thin,{Red,Thickness[0.018]},{Red, Thickness[0.018]}}]

(∂_(x,y))f==(∂_(y,x))f

(∂_x)f/.x->0

(∂_y)((∂_x)f/.x->0)

(∂_(x,y))f/.x->0

(∂_(y,x))f/.y->0

(∂_(x,y))f/.{{x->0},{y->0}}

mixed = Simplify[(∂_(x,y))f]

Plot3D[mixed,{x,-2,2},{y,-2,2},MeshFunctions-> (#3&),Mesh -> 15,MeshStyle->Brown,MaxRecursion->4,ViewPoint->{1,-2.3,1.},AxesLabel->{"x","y",None},AxesEdge -> {{-1,-1},{1,-1},{1,1}}]

{mixed/.{x->a,y->a},mixed/.y->0}

mixed/.{x->r Cos[θ],y->r Sin[θ]}

Simplify[%]

ParametricPlot3D[{r Cos[θ],r Sin[θ],(3 Cos[2 θ]-Cos[6 θ])/2},{r,0,1},{θ,0,2 π},Axes->None,MeshFunctions-> (#3&),Mesh->20,MeshStyle->Brown]

.  Failure of the Only-Critical-Point-in-Town Test

Clear[f];f[x_,y_]:=3 x (E^y)-(x^3)-(E^(3 y));
(∂_({{x,y}}))f[x,y]

eqn=Simplify[{(1/3) (∂_x)f[x,y]==0,(((∂_y)f[x,y])/(E^y))==0}]

eqn=eqn[[2]]/.y->Log[(x^2)]

{x,Log[(x^2)]}/.Solve[eqn]

{f[1,0],f[-2,-2.]}

Plot3D[f[x,y],{x,-3,2.1},{y,-5,1},
	ViewPoint->{0.5,1.5,0.5},AxesEdge->{{1,-1},{1,-1},{-1,1}},
	Boxed->False,Ticks->{Automatic,Automatic,{-1.5,0,1.5}},
         MeshFunctions->(#3&),Mesh->{Range[-3,2.8,0.2]},MeshShading->{Pink,White},
	AxesLabel->{"x","y","z"},MaxRecursion->6,PlotPoints->80,PlotRange->{-3,2.8},ClippingStyle->None]

Plot3D[-((((x^2)y-x-1))^2)-((((x^2)-1))^2),{x,-1.8,1.8},{y,-2,10},BoxRatios->1,PlotRange->{-8,0.2},MeshFunctions->(#3&),Mesh->{Range[-8,0,0.25]},MeshShading->{Pink,White},ClippingStyle->None,MaxRecursion->6,AxesEdge->{{-1,-1},{1,-1},{-1,-1}},AxesLabel->{"x","y","z"},Boxed->False,ViewPoint->{0.5,-2,1.5}]

Plot3D[(E^(-x)) (x (E^(-x))+Cos[y]),{x,-1,4},{y,-14,11},ViewPoint->{-2.4,0.3,.3},AxesLabel->{"x","y",None},Boxed->False,MaxRecursion->5,PlotPoints->50,ClippingStyle->None,MeshFunctions-> {(#3&)},MeshShading->{Pink,White},Mesh->{Range[-3,1,0.15]},AxesEdge->{{-1,1},{-1,-1},{-1,-1}},PlotRange->{-1,1.1}]

.  Raising Contours to New Heights

f[x_,y_]:=((x^2)+3 (y^2)) (E^(1-(x^2)-(y^2)));
surface=Plot3D[f[x,y],{x,-2,2},{y,-3,3},Boxed->False,ViewPoint->{2.2,0,1.5},Ticks->{Range[-2,1],Range[-2,2],{1,2,3}},AxesEdge->{{-1,-1},{1,-1},{1,-1}},Mesh ->None,AxesLabel->{"x","y",None}];

cp=ContourPlot[f[x,y],{y,-2.5,2.5},{x,-2,2},Contours->Range[ 0.1,2.8,0.3],ContourShading->False,FrameLabel-> {"y","x"},RotateLabel->False,ContourStyle->Directive[Black,Thickness[0.007]],AspectRatio->0.6]

cpsingle[v_] := ContourPlot[f[x,y]==v,{y,-2.5,2.5},{x,-2,2}]
Do[data[c]=Cases[Normal[cpsingle[c]],Line[_],∞],{c,0.1,2.8,0.3}];

Do[data3D[c]=data[c]/. {y_Real,x_} :> {x,y,f[x,y]},{c,0.1,2.8,0.3}]

Graphics3D[data3D/@Range[0.1,2.8,0.3],ViewPoint->{2.2,0,1.5}]

Manipulate[ Grid[{{
Show[surface,Graphics3D[{Thick,Red,data3D[c]}],PlotRegion->{{0,1},{0,1.25}}],
Show[cp,Graphics[{Thick,Red,data[c]}]]}}],{{c,0.1,"Contour level"},0.1,2.8,0.3,Appearance->"Open"}, TrackedSymbols->{c}]

Manipulate[Animate[ Grid[{{
Show[surface,Graphics3D[{Thick,Red,data3D[c]}],PlotRegion->{{0,1},{0,1.25}}],
Show[cp,Graphics[{Thick,Red,data[c]}]]}}],{{c,0.1,"Contour level"},0.1,2.8,0.3},AnimationRate->Rate, Paneled->False],{{Rate,0.5,"Animation rate"},Range[0.1,0.7,0.1],SetterBar}]

.  A New View of Pascal's Triangle

Plot3D[Binomial[x,y],{x,-4.2,5.1},{y,-3,5},Mesh->{Range[-4,4,1]},MeshFunctions->(#3&),MeshStyle->Brown,Boxed->False,ClippingStyle->False,PlotRange->{-4,4},ViewPoint->{0.7,-2.3,0.7},AxesLabel->{"x", "y",None},AxesEdge->{{-1,-1},{1,-1},{-1,-1}},Exclusions->{x==-1,x==-2,x==-3,x==-4},PlotPoints->40, ImageSize->420]