Lab 3 Tutorial

There are two files on the web server for this lab.   This file contains a tutorial and instructions.  You should do your work in a separate file -- I have provided a template called Lab3_report.nb.

We are going to get Mathematica to draw graphs of contour lines (implicitly defined curves),  and tangent lines to those curves

Initialization

Off[General::spell];
Off[General::spell1];
Off[ParametricPlot3D::ppcom];
Needs["Graphics`Colors`"];

SetOptions[Graphics,Axes->False,AxesOrigin->{0,0},AspectRatio->Automatic];
SetOptions[Graphics3D,ViewPoint->{5,2,1},Boxed->False,AspectRatio->Automatic];
SetOptions[ParametricPlot3D,ViewPoint->{5,2,1},AspectRatio->Automatic];
SetOptions[Plot3D,ViewPoint->{5,2,1},AspectRatio->Automatic];
SetOptions[ParametricPlot,AspectRatio->Automatic];
SetOptions[Plot,AspectRatio->Automatic];

colorQ[a_]:=(Head[a]===RGBColor);
grayQ[a_]:=(Head[a]===GrayLevel);
thickQ[a_]:=(Head[a]===Thickness);
absthickQ[a_]:=(Head[a]===AbsoluteThickness);
notruleQ[u_] := !(Head[u]===Rule);
ruleQ[u_] := (Head[u]===Rule);

Norm::usage = "Norm[expr] returns the Euclidean length of the
		vector, 'expr'.";

Norm[a_?VectorQ] := Sqrt[a.a];

Angle[a_?VectorQ,b_?VectorQ] := ArcCos[Simplify[(a.b)/(Norm[a] Norm[b])]];

Proj[a_?VectorQ,b_?VectorQ] := ((a.b)/(b.b))b;

tol = .5*10^-6;

OrthUp[a_?VectorQ] :=
	Module[{b,c,d,f},
		d = N[a/Norm[a]];
		If[Chop[d[[3]]^2 - 1,tol] == 0, b={1,0,0} ,
		b = {0,0,1} - d[[3]] d; b = b/Norm[b];];
	Return[b]];
	
OrthSet[a_?VectorQ] :=
	Module[{b,c,d},
		d = N[a/Norm[a]];
		If[Chop[d[[1]],tol]==0,b={1,0,0},
			 If[Chop[d[[2]],tol]==0,b={0,1,0},
			  b={-d[[2]],d[[1]],0}]];
			b=b/Norm[b];c = Cross[d,b];
	Return[{b,c/Norm[c],d}]];

				
Rotate[a_?VectorQ,theta_] :=
	Module[{u,v,r},
		u = OrthSet[a];
		v = Transpose[u];
		r = N[{{Cos[theta],-Sin[theta],0},{Sin[theta],Cos[theta],0},{0,0,1}}];
	Return[v.r.u]];

Vector2D[tail_,tip_,opts___]:=
	Module[{ntail,ntip,sopts,Punit,up,arrow},
	ntail = N[tail];
	ntip = N[tip];
	
	sopts = Join[Select[{opts},colorQ],Select[{opts},
				thickQ],Select[{opts},absthickQ],Select[{opts},grayQ]];

If[Chop[ntail.ntail+ntip.ntip,tol] == 0,
			(*too small to plot or not number*)
			Return[Graphics[Point[{0,0}]]];
	,						
If[Chop[(ntip-ntail).(ntip-ntail),tol] == 0,
		Return[Graphics[{Join[sopts,{Line[{ntail,ntip}]}]}]];
	,
	Punit = 0.075 (ntip-ntail) ;
	up = 0.15 {-Punit[[2]],Punit[[1]]};
	arrow = Line[{ntail,ntip,ntip-Punit+up,ntip,ntip-Punit-up}];
	]];
Return[Graphics[{Join[{AbsoluteThickness[2]},Join[sopts,{arrow}]]}]];
];

Vector3D[tail_,tip_,opts___]:=
	Module[{ntail,ntip,sopts,Punit,up,u2,u3,u4,rotmat,arrow},
	ntail = N[tail];
	ntip = N[tip];
	
	sopts = Join[Select[{opts},colorQ],Select[{opts},
				thickQ],Select[{opts},absthickQ],Select[{opts},grayQ]];

If[Chop[ntail.ntail+ntip.ntip,tol] == 0,
			(*too small to plot or not number*)
			Return[Graphics3D[Point[{0,0,0}]]];					
	,		
If[Chop[(ntip-ntail).(ntip-ntail),tol] == 0,
		Return[Graphics3D[{Join[sopts,{Line[{ntail,ntip}]}]}]];
	,
	Punit = (ntip-ntail);
	rotmat = Rotate[Punit,N[Pi/2]];
	up = OrthUp[Punit];
	Punit = .075 Punit;
	up = .15 Norm[Punit] up;
	u2 = rotmat.up;
	u3 = rotmat.u2;
	u4 = rotmat.u3;
	arrow = Line[{ntail,ntip,
				ntip - Punit + up,ntip,
				ntip - Punit + u2,ntip,
				ntip - Punit + u3,ntip,
				ntip - Punit + u4}];
	]];
Return[Graphics3D[{Join[{AbsoluteThickness[2]},Join[sopts,{arrow}]]}]];
];

aRCtAN[y_,x_] := Module[{v},
	If[ Chop[N[x],tol] == 0 ,If[ N[y] < 0, v = -N[Pi/2], v = N[Pi/2]],
		v = N[ArcTan[y/x]];
		If[ x < 0 && y < 0, v = N[Pi -  v],v]];
	Return[v]];

Arc2D[X_,Y_,opts___] := Graphics[{opts,
		Disk[{0,0},1,{Min[
							aRCtAN[
						N[X[[2]]],N[X[[1]]]
								]
							,
							aRCtAN[
							N[Y[[2]]],N[Y[[1]]]
								]
						]
						,
					Max[
							aRCtAN[
						N[X[[2]]],N[X[[1]]]
								]
							,
							aRCtAN[
							N[Y[[2]]],N[Y[[1]]]
								]
						]}
				]}
				];
Arc3D[X_,Y_] := 
	Module[{t,U,V},
		U[V_]:= N[(1/Sqrt[V.V]) V];
		Return[Graphics3D[
		Polygon[Append[Table[U[t X + (1-t) Y],{t,0,1,0.1}],{0,0,0}]]
				]
		]
	];

(*Zero Arrow causes trouble. Put in Vector?*)

Vector[tail_,tip_,opts___]:=
	If[Length[N[tail]]==2,Return[Vector2D[tail,tip,opts]],
		Return[Vector3D[tail,tip,opts]]];
		
Arrow[vec_,opts___]:= 
	Module[{a,b},
				If[Length[N[vec]]==2,
				a=ToExpression["Tail"]/.Select[{opts},ruleQ]/.
					{ToExpression["Tail"]->{0,0}};
				Return[Vector2D[a,a+vec,opts]],
				a=ToExpression["Tail"]/.Select[{opts},ruleQ]/.
					{ToExpression["Tail"]->{0,0,0}};
				Return[Vector3D[a,a+vec,opts]]]
				];

Frame2D[delta_] := 
      Graphics[{
     Green,Line[{{-delta/4,0},{delta,0}}],
                    Text["x",{1.01 delta,0}],Line[{{0,-delta/4},{0,delta}}],Text["y",{0, 1.01 delta}]}];

Frame3D[delta_] := 
      Graphics3D[{Green,Line[{{-delta/4,0,0},{delta,0,0}}],Text["x",{1.01 delta,0,0}],Line[{{0,-delta/4,0},{0,delta,0}}],Text["y",{0, 1.01 delta,0}],Line[{{0,0,-delta/4},{0,0,delta}}],Text["z",{0,0,1.01 delta}]}];

View2D[stuff_] := Show[stuff,Frame2D[1]];
View3D[stuff_] := Show[stuff,Frame3D[1]];

Procedure for Finding the Implicit Tangent Line (from the text)

Programming the Procedure in x--y coordinates

The following sample program steps do the textbook procedure for finding the equation of the tangent to a contour of a given function.  Work through these steps comparing the computer results with your own hand computations.  Put them together with print statements in your solution to the exercises.

Recall how to define a function with replaceable variables and enter the next input cell:

Clear[x, y, f, fX, fY, gradf];
f[x_, y_] = 9 - (x^2) + (y^3)

A contour of a particular level like f[x, y] = 6 can be plotted by entering the next command:

ContourPlot[f[x, y], {x, -5, 5}, {y, -5, 5}, 
        Contours -> {6}, ContourShading -> False];

This would be difficult to plot by hand.  Copy, paste and edit the command to plot the contour

We can compute the partial derivative with respect to x and define it as a function fX[x, y] = ∂(f/∂)x[x, y] in general for any defined f[x, y] by entering the next input cell (assuming the function is already entered.)

fX[x_, y_] = D[f[x, y], x]

Show by hand that ∂(f/∂)x[x, y] = -2 x  for the function defined above and compare this with your output.

Now define fY[x, y] = ∂(f/∂)y[x, y] and enter its definition in the next input cell.

fY[...

Verify by hand that your definition computes the right partial derivative for the entered function, ∂(f/∂)y[x, y] = ?

Use your partial derivative to compute ∂(f/∂)y[2, 2] = ??  and check your answer by hand for this function.

fY[2, 2]

Recall that Mathematica denotes vectors using curly brackets, (({{x}, {y}}))={x, y}, and use your partial derivative functions to define the gradient function

gradf[x_, y_] =.  ..

The formula ∂(f/∂)x[x, 
            y] dx  +  ∂(f/∂)y[x, 
            y] dy  becomes a particular linear expression, m dx  +  n dy when x and y are specified.  First show by hand that the tangent to the contour f[x, y] = 6 at (x, y) = (2, 1) for this function has equation

Enter the next command:

x0 = 2
y0 = 1
fX[x0, y0] (x - x0) +  fY[x0, y0] (y - y0)

Assigning values to x0 and y0 fixes the function and particular gradient as well:

f[x0, y0]
gradf[x0, y0]

Plot the implicit linear function m dx  +  n dy = 0 for -1 ≤ dx ≤ 1 and  -1 ≤ dy ≤ 1 by specifying the contour 0:

scale = 1;
ContourPlot[
      fX[x0, y0] (x - x0) +  fY[x0, y0] (y - y0), {x, x0 - scale, 
        x0  + scale}, {y, y0 - scale, y0 + scale}, Contours -> {0}, 
      ContourShading -> False]

Here is a line plot with some more options and a larger scale:

scale = 2; 
    line = ContourPlot[
        fX[x0, y0] (x - x0)  +  fY[x0, y0] (y - y0), {x, 
          x0 - scale, x0 + scale}, {y, y0 - scale, y0 + scale}, 
        ContourShading -> False, Contours -> {0}, 
        ContourStyle -> Blue, FrameLabel -> {"x", "y"}, 
        RotateLabel -> False];

Plot the nonlinear contour in local coordinates centered at the point of tangency (x0, y0) as follows: (Recall that we fixed x0 and y0.)

scale = 5; 
    curve = ContourPlot[
        f[x, y], {x, x0 - scale, x0 + scale}, {y, y0 - scale, y0 +  scale}, 
        Contours -> {f[x0, y0]}, ContourShading -> False, 
        ContourStyle -> Red];

Show the contour, tangent line and point of tangency:

curve = 
        Show[curve, line, 
          Graphics[{Brown, AbsolutePointSize[5], 
              Point[{x0, y0}]}]];

Show[{curve, line,  
          Vector[{x0,  y0}, {x0, y0}  +  gradf[x0, y0], Purple]}, 
        PlotRange -> {{x0 - scale, x0 + scale}, {y0 - scale, 
              y0 + scale}}];

Step-by-step Summary

Clear[x, y, f, fX, fY, dx, dy, gradf];
f[x_, y_] = 9 - (x^4)/5 - (y^3)/8

fX[x_, y_] = D[f[x, y], x]
fY[x_, y_] = D[f[x, y], y]
gradf[x_, y_] = {fX[x, y], fY[x, y]}

x0 = 1
y0 = 1

fX[x0, y0] (x - x0) +  fY[x0, y0] (y - y0)

Clear[scale,  line]
scale = 5; 
    line = ContourPlot[
        fX[x0, y0] (x - x0)  +  fY[x0, y0] (y - y0), {x, 
          x0 - scale, x0 + scale}, {y, y0 - scale, y0 + scale}, 
        ContourShading -> False, Contours -> {0}, 
        ContourStyle -> Blue, FrameLabel -> {"x", "y"}, 
        RotateLabel -> False];

Clear[scale,   curve,  all]
scale = 5; 
    curve = ContourPlot[
        f[x, y], {x, x0 - scale, x0 + scale}, {y, y0 - scale, y0 +  scale}, 
        Contours -> {f[x0, y0]}, ContourShading -> False, 
        ContourStyle -> Red];
all = 
        Show[{curve, line, 
            Vector[{x0,  y0}, {x0, y0}  +  gradf[x0, y0], Purple], 
            Graphics[{Brown, AbsolutePointSize[5], Point[{x0, y0}]}]}, 
          PlotRange -> {{x0 - scale, x0 + scale}, {y0 - scale, 
                y0 + scale}}];

Altogethernow

Clear[x, y, f, fX, fY, gradf,  line,  curve,  all];
f[x_, 
        y_] = ((x^2) + 
            2  (y^2)) (E^(-((x^2) + (y^2))))
ContourPlot[
      f[x, y], {x, -3, 3}, {y, -3, 3}]
fX[x_, y_] = D[f[x, y], x]
fY[x_, y_] = D[f[x, y], y]
gradf[x_, y_] = {fX[x, y], fY[x, y]}
x0 = 1
y0 = 1
scale = 1; 
    line = ContourPlot[
        fX[x0, y0] (x - x0)  +  fY[x0, y0] (y - y0), {x, 
          x0 - scale, x0 + scale}, {y, y0 - scale, y0 + scale}, 
        ContourShading -> False, Contours -> {0}, 
        ContourStyle -> Blue, FrameLabel -> {"x", "yy"}, 
        PlotPoints -> 2, 
        RotateLabel -> False];
scale = 2; 
    curve = ContourPlot[
        f[x, y], {x, x0 - scale, x0 + scale}, {y, y0 - scale, y0 + scale}, 
        ContourShading -> False, Contours -> {f[x0, y0]}, 
        ContourStyle -> Red, 
        PlotPoints -> 30];
all = 
        Show[{curve, line, 
            Vector[{x0,  y0},  {x0,  y0} + gradf[x0, y0], Purple], 
            Graphics[{Brown, AbsolutePointSize[5], Point[{x0, y0}]}]}, 
          PlotRange -> {{x0 - scale, x0 + scale}, {y0 - scale, 
                y0 + scale}}];

Exercise:  Do this exercise in the separate template file 
Lab3_report.nb

For each of the following functions and specified points (x0, y0), plot the contour of the function through the specified point, compute the equation of the tangent to this contour at this point, plot the tangent line,  and plot the contour and the tangent line together.

a)	f[x, y] = 9 - (x^2) - ((y^2)/3) , (x0,  y0)  =  (1,  2)

b)	f[x, y] = 5  Sin[x y] Exp[-((x^2)/4) - ((y^2)/9)],  (x0, y0) = (1, 1)

c)	f[x, y] = Cos[(x^2) - x]/(1 + (y^2)) - (1/2) x Sin[3 y],  (x0, y0) = (2, 2)