Contour Initialization

Needs["Graphics`Colors`"];

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]];

SetOptions[Plot3D,ViewPoint->{5,3,1},
	BoxRatios ->Automatic,PlotPoints->30,
	AxesLabel->{"x","y","z"}];
SetOptions[ContourPlot,PlotPoints->30,
	AxesLabel->{"x","y"}];

spaceCurve[ fun:{_, _, _}, ul:{_, u0_, u1_, du_}, opts___] :=
	Show[ Graphics3D[Line[Table[N[fun], ul]]], opts,ViewPoint->{5,3,1} ] /;
			NumberQ[N[u0]] && NumberQ[N[u1]] && NumberQ[N[du]]

spaceCurve[fun_, {u_, u0_, u1_}, opts___] :=
Module[{plotpoints},
    plotpoints = PlotPoints /. {opts} /. Options[Plot3D];
	spaceCurve[ fun, {u, u0, u1, (u1-u0)/(plotpoints-1)}, opts ]
    ];

\(\(sliceSurface[z_, xLo_, xHi_, yLo_, yHi_, zLo_, zHi_, opts___] := 
        Module[{web, box, 
            slicePlane}, 
box = {{xLo -  .01, 
                xHi +  .01}, {yLo -  .01, yHi +  .01}, {zLo -  .01, 
                zHi +  .01}}; 
web = {}; 

          Do[AppendTo[web, 
              spaceCurve[{x, y, z}, {y, yLo, yHi}, PlotRange -> box, 
                DisplayFunction -> 
                  Identity]]; 
slicePlane = 
              Graphics3D[
                Polygon[{{x, yLo, zLo}, {x, yHi, zLo}, {x, yHi, zHi}, {x, 
                      yLo, zHi}, {x, yLo, zLo}}]]; 
            Show[slicePlane, web, opts, ViewPoint -> {5, 3, 1}, 
              PlotRange -> box, 
              DisplayFunction -> $DisplayFunction];
	, {x, xLo, 
              xHi, \((xHi - xLo)\)/5}]; 

          Do[AppendTo[web, 
              spaceCurve[{x, y, z}, {x, xLo, xHi}, PlotRange -> box, 
                DisplayFunction -> 
                  Identity]]; 
slicePlane = 
              Graphics3D[
                Polygon[{{xLo, y, zLo}, {xHi, y, zLo}, {xHi, y, zHi}, {xLo, 
                      y, zHi}, {xLo, y, zLo}}]]; 
            Show[web, slicePlane, opts, ViewPoint -> {5, 3, 1}, 
              PlotRange -> box, 
              DisplayFunction -> $DisplayFunction];
	, {y, yLo, 
              yHi, \((yHi - yLo)\)/5}]; 
Show[web, opts, 
            ViewPoint -> {5, 3, 1}, PlotRange -> box, 
            DisplayFunction -> $DisplayFunction];];\)\)

plot3DContour[f_,xCnt_,yCnt_,scale_,opts___]:= 
Module[{zSs,surface,contour,cont,baseContour,combined,crvs3Dplus,fPlus,crvs3Dminus,fMinus},

zSs = Table[N[f[x,y]],{x,xCnt-scale,xCnt+scale,scale/30},
			{y,yCnt-scale,yCnt+scale,scale/30}];
zMIN = Min[zSs];

contour = ContourPlot[ f[x,y] ,{x,xCnt-scale,xCnt+scale},
			{y,yCnt-scale,yCnt+scale},PlotPoints->30,ContourStyle->Blue,
			DisplayFunction -> Identity];
topo=Show[contour,ContourShading->False,
      ContourStyle->AbsoluteThickness[1],DisplayFunction->Identity];
      			
surface = Plot3D[f[x,y] ,{x,xCnt-scale,xCnt+scale},{y,yCnt-scale,yCnt+scale},opts,ViewPoint->{5,3,1},Mesh->False,BoxRatios->Automatic,DisplayFunction->Identity];

fPlus[x_,y_]=f[x,y]+scale/100;
crvs3Dplus = Show[Graphics3D[First[Graphics[topo]]/.Line[pts_]:>(val=Apply[fPlus,First[pts]];
Line[Map[Append[#,val]&,pts]]
)],DisplayFunction->Identity];

fMinus[x_,y_]=f[x,y]-scale/100;
crvs3Dminus = Show[Graphics3D[First[Graphics[topo]]/.Line[pts_]:>(val=Apply[fMinus,First[pts]];
Line[Map[Append[#,val]&,pts]]
)],DisplayFunction->Identity];

cont = Show[contour,ContourShading->False,
				DisplayFunction -> Identity];

baseContour = First[Graphics[cont]];
					
baseContour = Graphics3D[baseContour /. Line[x_]:>
			Line[Map[Append[#,zMIN]&,x]]];

combined = Show[surface,baseContour,crvs3Dplus,crvs3Dminus,Graphics3D[{Red,AbsolutePointSize[4],Point[{xCnt,yCnt,f[xCnt,yCnt]}]}],DisplayFunction->$DisplayFunction];
Return[combined]
		];

sliceAt[f_,xCnt_,yCnt_,scale_,z_,zMIN_,optns___] :=
	Module[{surface,plane,contour,pLz,contLz,w},

	surface = Plot3D[ f[x,y] , {x,xCnt-scale,xCnt+scale},
						{y,yCnt-scale,yCnt+scale},
				PlotPoints->30,BoxRatios->Automatic,Mesh->False,optns,
				AxesLabel->{"x","y","z"},
				ViewPoint->{5,3,1},
				DisplayFunction->Identity];


	plane[w_] := Graphics3D[Polygon[{{xCnt-scale,yCnt-scale,w},{xCnt+scale,yCnt-scale,w},{xCnt+scale,yCnt+scale,w},{xCnt-scale,yCnt+scale,w},{xCnt-scale,yCnt-scale,w}}]];
						
	contour[w_] := ContourPlot[ f[x,y] ,
		{x,xCnt-scale,xCnt+scale},{y,yCnt-scale,yCnt+scale},
		PlotPoints->30, Contours->{w},ContourStyle->Blue,DisplayFunction->Identity];

				
	pLz = plane[z];

	contLz = Show[Evaluate[contour[z]],
			ContourShading->False,
			DisplayFunction -> Identity];

	contLz = First[Graphics[contLz]];
					
	contLz = Graphics3D[contLz /. Line[x_]:>
			Line[Map[Append[#,zMIN]&,x]]];

Show[surface,pLz,contLz,
		DisplayFunction->$DisplayFunction];]

Zoom Initialization

Off[General::spell];
Off[General::spell1];
SetOptions[ParametricPlot3D,ViewPoint->{5,3,1},AspectRatio->Automatic];
SetOptions[Plot3D,ViewPoint->{5,3,1},BoxRatios->Automatic];
SetOptions[ContourPlot,PlotPoints->30];

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

BeginPackage["zoom3D`"];

zoom3D::usage = "zoom[f, x,y, dx] expands the graph of f[x,y]
about the point (x,y,f[x,y]) in 10 steps until the specified
dx appears unit size.";

Begin["`Private`"];
Needs["Graphics`Colors`"];

snglFrame[f_,x_,y_,dx_,deltaX_,opns___] := 
Module[{z,box,ddx,ddy,fX,fY,dz,xaxis,yaxis,zaxis,plot,tang},
z = N[f[x,y]];

plot = Plot3D[ f[x+ddx,y+ddy]-z,{ddx, -deltaX,deltaX},{ddy, -deltaX,deltaX},opns,
		PlotRange->{ -deltaX,deltaX},BoxRatios->Automatic,
		Axes->None,Ticks->None,Boxed->False,
		DisplayFunction->Identity];
		
fX[ddx_,ddy_] := Evaluate[D[f[ddx,ddy],ddx]];
fY[ddx_,ddy_] := Evaluate[D[f[ddx,ddy],ddy]];

dz[ddx_,ddy_] :=  fX[x,y] ddx + fY[x,y] ddy;
tang = Plot3D[ dz[ddx,ddy] ,{ddx, -deltaX .7,deltaX .7},{ddy, -deltaX .7,deltaX .7},
		PlotRange->{ -deltaX,deltaX},BoxRatios->Automatic, PlotPoints->3,
		Axes->None,Boxed->False, Ticks->None,
		DisplayFunction->Identity];
	
box = Line[N[{{-dx,-dx,-dx},{-dx,dx,-dx},{-dx,dx,dx},{-dx,-dx,dx},{-dx,-dx,-dx},
			{-dx,-dx,-dx},{dx,-dx,-dx},
			{dx,dx,-dx},{dx,dx,dx},{dx,-dx,dx},{dx,-dx,-dx}}]];
			
box = Join[{box,Line[N[{{-dx,-dx,dx},{dx,-dx,dx}}]],
		Line[N[{{-dx,dx,dx},{dx,dx,dx}}]],
		Line[N[{{-dx,dx,-dx},{dx,dx,-dx}}]]}];

box = Graphics3D[{AbsoluteThickness[2],Red,box}];
		
				
If[ (N[Abs[x]]<N[deltaX]&&N[Abs[y]]<N[deltaX]&&N[Abs[z]]<N[deltaX]),
xaxis = {AbsoluteThickness[3],Green,Line[N[{{-deltaX,-y,-z},
						{3 deltaX/4,-y,-z}}]]};
xaxis = Graphics3D[{xaxis,Text["x",N[{.9 deltaX,-y,-z}]]}];
yaxis = {AbsoluteThickness[3],Green,Line[N[{{-x,-deltaX,-z},
						{-x,3 deltaX/4,-z}}]]};
yaxis = Graphics3D[{yaxis,Text["y",N[{-x,.9 deltaX,-z}]]}];
zaxis = {AbsoluteThickness[3],Green,Line[N[{{-x,-y,-deltaX},
						{-x,-y,3 deltaX/4}}]]};
zaxis = Graphics3D[{zaxis,Text["z",N[{-x,-y,.9 deltaX}]]}];
Show[{plot,xaxis,yaxis,zaxis,box,tang}]
		,
Show[{plot,box,tang}]
]];

zoom3D[f_,x_,y_,dx_,opns___] := Module[{n},

deltaX = Table[N[dx^(n/9)],{n,0,9}];
Map[
Show[
GraphicsArray[{snglFrame[f,x,y,dx,2.5,
				Ticks->{{-1,1},{-1,1},{-1,1}},opns],
				snglFrame[f,x,y,dx,#]}],
DisplayFunction->$DisplayFunction]&,deltaX];
];

End[];
EndPackage[];

\(\(\( (*BeginPackage["zoom2D`"]; 
zoom2D::usage = "zoom[f,x,y, dx] expands the contour graph of f[x,y]
about the point (x,y,f[x,y]) in 10 steps until the specified
dx appears unit size."; 
Something\ is\ screwed\ up\ with\ Arrow[ . ]*) \)\(
\)\( (*\(Begin["`Private`"];\)*) \)\(
\)\(\(Needs["Graphics`Colors`"];\)\(
\)
    \(\(snglContour[f_, x_, y_, dx_, deltaX_, opns___] := 
        Module[{z, box, ddx, ddy, fX, fY, dz, xaxis, yaxis, plot, tang, zSs, 
            xx, yy, deltaZ}, 
z = 
            f[x, y]; 
zSs = 
            Table[N[f[xx, yy]], {xx, x - deltaX, x + deltaX, deltaX/30}, {yy, 
                y - deltaX, y + deltaX, 
                deltaX/30}]; 
deltaZ = 
            Max[zSs] - \ Min[zSs]; 
zSs = 
            z + Table[
                zz, {zz, \(-deltaZ\)/2, deltaZ/2, \ 
                  deltaZ/4}]; 

plot = 
            ContourPlot[
              f[x + ddx, y + ddy], {ddx, \(-deltaX\), 
                deltaX}, {ddy, \(-deltaX\), deltaX}, Contours -> zSs, 
              FrameTicks -> None, 
              DisplayFunction -> 
                Identity]; 

fX[ddx_, 
              ddy_] := Evaluate[D[f[ddx, ddy], ddx]]; 
fY[
              ddx_, ddy_] := 
            Evaluate[D[f[ddx, ddy], ddy]]; 
dz[ddx_, ddy_] := 
            fX[x, y]\ ddx + 
              fY[x, y]\ ddy; 
gradf = {fX[x, y], 
              fY[x, y]}; 

tang = 
            ContourPlot[
              dz[ddx, ddy], {ddx, \(-deltaX\)\  .7, 
                deltaX\  .7}, {ddy, \(-deltaX\)\  .7, deltaX\  .7}, 
              Contours -> {0.0}, ContourStyle -> Red, 
              ContourShading -> False, FrameTicks -> None, 
              DisplayFunction -> 
                Identity]; 

tang = \ 
            Show[{tang, Arrow[deltaX\ gradf, Brown], 
                Graphics[{DarkGreen, {Line[{{\(- .5\) dx, 0}, {dx, 0}}], 
                      Line[{{0, \(- .5\) dx}, {0, dx}}]}}], 
                Graphics[{AbsolutePointSize[4], Red, Point[{0, 0}]}]}, 
              DisplayFunction -> 
                Identity]; 

box = 
            Graphics[{AbsoluteThickness[2], Red, 
                Line[N[{{\(-dx\), \(-dx\)}, {\(-dx\), dx}, {dx, 
                        dx}, {dx, \(-dx\)}, {\(-dx\), \(-dx\)}}]]}]; 

If[\((N[Abs[x]] < N[deltaX] && 
                N[Abs[y]] < N[deltaX])\), 
            xaxis = {AbsoluteThickness[2], 
                Blue, {Text["x", N[{ .9\ deltaX, \(-y\)}]], 
                  Line[N[{{\(-deltaX\), \(-y\)}, {\  .8  
                            deltaX, \(-y\)}}]]}}; 
xaxis = 
              Show[Graphics[xaxis], 
                DisplayFunction -> 
                  Identity]; 
yaxis = {AbsoluteThickness[
                  2], Blue, {Line[
                    N[{{\(-x\), \(-deltaX\)}, {\(-x\),  .8\ deltaX}}]], 
                  Text["y", 
                    N[{\(-x\),  .9\ deltaX}]]}}; 
yaxis = 
              Graphics[yaxis, 
                DisplayFunction -> 
                  Identity]; 
Show[{plot, xaxis, yaxis, 
                box, tang, 
                Graphics[{DarkGreen, {Line[{{\(-deltaX\), 0}, {deltaX, 0}}], 
                      Line[{{0, \(-deltaX\)}, {0, deltaX}}]}}], 
                Graphics[{AbsolutePointSize[4], Red, Point[{0, 0}]}]}], 
            Show[{plot, box, tang, 
                Graphics[{DarkGreen, {Line[{{\(-deltaX\), 0}, {deltaX, 0}}], 
                      Line[{{0, \(-deltaX\)}, {0, deltaX}}]}}], 
                Graphics[{AbsolutePointSize[4], Red, 
                    Point[{0, 0}]}]}]]];\)\(
\)
    \)\(
\)
    \(\(zoom2D[f_, x_, y_, dx_, opns___] := 
        Module[{n, first}, 
          deltaX = 
            Table[N[dx^\((n/9)\)], {n, 0, 8}]; 
first = 
            Show[{snglContour[f, x, y, dx, 2.5, 
                  FrameLabel -> {"dx", "dy"}, 
                  RotateLabel -> False, opns], 
                Arrow[gradf, Brown]}]; 
Map[
            Show[GraphicsArray[{first, 
                    snglContour[f, x, y, dx, #, 
                      FrameLabel -> {"dx", "dy"}, 
                      RotateLabel -> False, opns]}], 
                DisplayFunction -> $DisplayFunction] &, 
            deltaX];];\)\(
\)
    \)\( (*\(End[];\)*) \)\(
\)
    \( (*\(EndPackage[];\)*) \)\)\)\)

The idea discussed last time is:

The local approximation of a function by its total differential can be seen on a Contour Plot of the function and its differential.  This is done in the same seqence of steps:

(1) Define z = f[x,y]

(2) Compute the symbolic total differential (including both partial derivatives)

(3) Fix the point of tangency, (x,y), and compute z = f[x,y] and the specific  dz = m dx + n dy

(4) Plot the surface and tangent

(5) Zoom in to scale dU

Clear[x, y, dx, dy, f, fX, fY];
\(\(\(f[x_, y_] := \ Exp[\(-\(x\^2\/3\)\) + y\^2\/5];\)\(
\)
    \)\)
fX[x_, y_]  :=  Evaluate[D[f[x, y], x]];
\(\(\(fY[x_, y_]\  := \ Evaluate[D[f[x, y], y]];\)\(
\)
    \)\)
dz[dx_, dy_] := fX[x, y] dx + fY[x, y] dy;
Print["The function  z = f[x,y] = ", f[x, y]];
Print["has symbolic total differential"];
Print["dz = ", dz[dx, dy]];
x = 1.0;
y = -1.0;
z = f[x, y];
Print["At (x,y,f[x,y]) =", {x, y, 
          z}, " the differnetial"];
Print["dz = ", dz[dx, dy]];
curves = 
        ContourPlot[f[x + dx, y + dy] - z, {dx, -3, 3}, {dy, -3, 3}, 
          DisplayFunction -> Identity];
lines = 
        ContourPlot[dz[dx, dy], {dx, -3, 3}, {dy, -3, 3}, 
          ContourStyle -> Red, ContourShading -> False, 
          DisplayFunction -> Identity];
lines  =  
        Show[{lines, Arrow[{fX[x, y], fY[x, y]}, Brown], 
            Graphics[{DarkGreen, {Line[{{- .5, 0}, {1, 0}}], 
                  Line[{{0, - .5}, {0, 1}}]}}], 
            Graphics[{AbsolutePointSize[4], Red, Point[{0, 0}]}]}, 
          DisplayFunction -> Identity];
Show[GraphicsArray[{curves, lines}], 
        DisplayFunction -> $DisplayFunction];
Show[{curves, lines}, 
        DisplayFunction -> $DisplayFunction];
dU = 0.05;
zoom2D[f, x, y, dU];

Example 1 of tangent line

The quantity a is the scale.  Make a small to achieve a big magnification.

Clear[a, scale ,  x, y, dx, dy, f, fX, fY, gradf];
a  =  scale  =  1;
f[x_, y_] := ((x^2)/4) - ((y^3)/3);
fX[x_, y_] := Evaluate[(∂_x) f[x, y]];
fY[x_, y_] := Evaluate[(∂_y) f[x, y]];
gradf[x_, y_]  :=  {fX[x, y],  
          fY[x, y]};
dz[dx_, dy_] := 
        fX[x, y] dx + fY[x, y] dy;
{x0,  y0}  =  {2, 1};
f[x0,  y0]
gradf[x0, y0]

plot  =  
        ContourPlot[
          f[x0 + dx, y0 + dy] - z, {dx, -a, a}, {dy, -a, a},  
          DisplayFunction -> Identity];
line  =  
        ContourPlot[
          fX[x0, y0] dx  +  fY[x0, y0] dy, {dx, -a, a}, {dy, -a, 
            a}, Contours -> {0}, ContourShading -> False, 
          ContourStyle ->  Red,  
          DisplayFunction -> Identity];
Show[{plot,  line},  
      DisplayFunction  ->  $DisplayFunction]

Example 2 of tangent line

The quantity a is the scale.  Make a small to achieve a big magnification.

Clear[a,  scale,  x, y, dx, dy, f, fX, fY, gradf];
a  =  scale  =  1;
f[x_, y_] := 3/2  -  x^2/3  -  y^2/6;
fX[x_, y_] := Evaluate[(∂_x) f[x, y]];
fY[x_, y_] := Evaluate[(∂_y) f[x, y]];
gradf[x_, y_]  :=  {fX[x, y],  
          fY[x, y]};
dz[dx_, dy_] := 
        fX[x, y] dx + fY[x, y] dy;
{x0,  y0}  =  {1, -1};
f[x0,  y0]
gradf[x0, y0]
plot  =  
        ContourPlot[
          f[x0 + dx, y0 + dy] - z, {dx, -a, a}, {dy, -a, a},  
          DisplayFunction -> Identity];
line  =  
        ContourPlot[
          fX[x0, y0] dx  +  fY[x0, y0] dy, {dx, -a, a}, {dy, -a, 
            a}, Contours -> {0}, ContourShading -> False, 
          ContourStyle ->  Red,  
          DisplayFunction -> Identity];
Show[{plot,  line},  
      DisplayFunction  ->  $DisplayFunction]