Gauss Map and Curvature

$surfaces = {
{-(x/2)+(x^3)+(y^2),{-0.3,1.2},0.234,"generic graph"},
{1-(x^2)-(y^2),{-0.8,1.6},0.2,"positive curvature (down)"},
{(x^2)+(y^2),{0.,1.65},0.2,"positive curvature (up)"},
{(x^2)-(y^2),{-1.,1.},0.2,"negative curvature"},
{1-(x^2),{0.1,1.7},0.2,"zero curvature"},
{(x^3)-3 x (y^2),{-1.5,1.5},0.25,"degenerate monkey saddle"},
{3 x y ((x^2)-(y^2)),{-0.75,0.75},0.4,"degenerate four-saddle"}
}; 
MyNorm[v_]:=(Sqrt[v.v]) ; 
$dom=0.9;(*" domain for (x,y) "*) 
$pt0={0.,0.};
$ρ=0.2;
$surfacePlot=Plot3D[$surfaces[[1,1]],{x,-$dom,$dom},{y,-$dom,$dom},BoxRatios->Automatic,PlotRange->$surfaces[[1,2]],PlotRangePadding->0.5,ClippingStyle->None,Mesh->{{$ρ^2},{0},{0}},MeshFunctions->{#1^2+#2^2&,#1&,#2&},PlotStyle->Directive[Opacity[0.4],ColorData["BeachColors"][0.2]]];
$gaussPlot=ParametricPlot3D[Evaluate[#/MyNorm[#]&@{-D[$surfaces[[1,1]],x],-D[$surfaces[[1,1]],y],1}/.{x->$pt0[[1]]+$ρ Cos[t],y->$pt0[[2]]+$ρ Sin[t]}],{t,0,2π}];

Manipulate[Pane[
With[{
z0=surface/.{x->pt0[[1]],y->pt0[[2]]},
myNormal=#/MyNorm[#]&@{-D[surface,x],-D[surface,y],1},
myT1=#/MyNorm[#]&@{1,0,D[surface,x]/.{x->pt0[[1]],y->pt0[[2]]}},
dS=(1+D[surface,x]^2+D[surface,y]^2)^(1/2),
D2surface={{D[surface,{x,2}],D[surface,x,y]},{D[surface,x,y],D[surface,{y,2}]}}/.{x->pt0[[1]],y->pt0[[2]]}},
With[{
myT2=Cross[myNormal/.{x->pt0[[1]],y->pt0[[2]]},myT1],
dS0=dS/.{x->pt0[[1]],y->pt0[[2]]}
},
With[{
a1=(* area on surface *)Quiet[Re[NIntegrate[dS,{y,pt0[[2]]-ρ,pt0[[2]]+ρ},{x,pt0[[1]]-Sqrt[ρ^2-(y-pt0[[2]])^2],pt0[[1]]+Sqrt[ρ^2-(y-pt0[[2]])^2]}]]],
a2=(* area on Gauss sphere *)With[{dGS=Cross[D[myNormal,x],D[myNormal,y]].myNormal//Simplify},
Quiet[Re[NIntegrate[dGS,{y,pt0[[2]]-ρ,pt0[[2]]+ρ},{x,pt0[[1]]-Sqrt[ρ^2-(y-pt0[[2]])^2],pt0[[1]]+Sqrt[(ρ^2)-(y-pt0[[2]])^2]}]]]],
κ=Function[{ϕ},Evaluate[Drop[Cos[ϕ]myT1+Sin[ϕ]myT2,-1].(D2surface/dS0).Drop[Cos[ϕ]myT1+Sin[ϕ]myT2,-1]]]},
With[{
θmax=θ0/.Quiet[FindMaximum[κ[θ0],{θ0,3.},AccuracyGoal->5,PrecisionGoal->6]][[2]]
(*θmin=θmax+π/2*)
},
surfacePlot=Plot3D[surface,{x,-$dom,$dom},{y,-$dom,$dom},BoxRatios->Automatic,PlotRange->plotRng,PlotRangePadding->0.5,ClippingStyle->None,Mesh->{{ρ^2},{0},{0}},MeshFunctions->{(#1-pt0[[1]])^2+(#2-pt0[[2]])^2&,(Sin[θmax]myT1-Cos[θmax]myT2).{#1-pt0[[1]],#2-pt0[[2]],#3-z0}&,(Cos[θmax]myT1+Sin[θmax]myT2).{#1-pt0[[1]],#2-pt0[[2]],#3-z0}&},PlotStyle->Directive[Opacity[0.4],ColorData["BeachColors"][0.2]]];
gaussPlot=ParametricPlot3D[Evaluate[myNormal/.{x->pt0[[1]]+ρ Cos[t],y->pt0[[2]]+ρ Sin[t]}],{t,0,2π}];
Column[{
Dynamic[Refresh[Module[{x00,y00,normalLine},
x00=pt0[[1]]+ρ Cos[θ];
y00=pt0[[2]]+ρ Sin[θ];
normalLine=Function[{pt},{AbsoluteThickness[1.5],ColorData["DeepSeaColors"][0.05],Line[{pt,pt+myNormal/.{x->x00,y->y00}}]}];
Row[{Show[(* Gauss sphere *)
Graphics3D[{{Opacity[0.2],ColorData["AvocadoColors"][0.6],Sphere[{0,0,0}]},normalLine[{0,0,0}],Point[myNormal/.{x->pt0[[1]],y->pt0[[2]]}]}],
gaussPlot,
Lighting->"Neutral", SphericalRegion->True,ImageSize->170,ViewPoint->Dynamic[vp], ViewVertical->Dynamic[vv]],
Style["÷",Large],
Show[(*" surface, mesh: loop, principal normal sections "*)
surfacePlot,
Graphics3D[{PointSize[Medium],Point[{pt0[[1]],pt0[[2]],z0}],normalLine[{x00,y00,surface/.{x->x00,y->y00}}]}],
SphericalRegion->True,ImageSize->290, ViewPoint->Dynamic[vp], ViewVertical->Dynamic[vv]]}]],TrackedSymbols->{θ}]],
Pane[Column[{
Row[{"area ",NumberForm[a2,4]," ÷ ","area ",NumberForm[a1,4]," = ", Quiet[NumberForm[a2/a1,4]]}],Row[{ "⟶ curvature ",NumberForm[(((Det[D2surface])/(dS0^4))),4]," = ","max ",NumberForm [Chop[κ[θmax]],4]," × ","min ",NumberForm[Chop[κ[θmax+π/2(*=θmin*)]],4]}]},Alignment->{Center,Bottom}],ImageSize->{450,32},Alignment->{Center,Bottom}]
},Alignment->{Center,Center}
]]]]],
ImageSize->{500,340},Alignment->{Center,Center}],
{{surface,$surfaces[[1,1]]},#[[1]]&/@$surfaces,ActionMenu[#, (#1[[-1]]:>({surface,plotRng,ρ,name}=#1)& )/@$surfaces,ImageSize->{125,36}]&},
{{pt0,$pt0,"pt"},{-$dom+0.1,-$dom+0.1},{$dom-0.1,$dom-0.1},ControlPlacement->Left},
{{θ,0.,"normal"},0.,2.π},
{{ρ,$ρ,"radius"},(10^(-6)),0.5,Appearance->"Labeled"},
{{plotRng,$surfaces[[1,2]]},None},
{{vp,{2,-2.5,3}},None},{{vv,{0,0,1}},None},{name,None},{{surfacePlot,$surfacePlot},None},{{gaussPlot,$gaussPlot},None},
TrackedSymbols:>{surface,pt0,ρ,θ},AutorunSequencing->{1,3,4,2},
SaveDefinitions->True
]

The Gauss map maps the unit normal of a surface (on the right) to the unit sphere (on the left). The area surrounding the point on the surface is thus mapped to an area on the unit sphere. As the radius of the loop approaches zero, the ratio of these areas approaches the Gaussian curvature of the surface at the point, which is also equal to the product of the principal curvatures (the maximum and minimum curvatures of the normal sections through the points).

Select a surface from the top pull-down menu (a description is given in the menu, but the function is displayed on the button). A point may be selected by moving the 2D slider. The Gauss map maps a loop around the point onto a loop on the unit sphere. Move the "normal" slider to observe the following: Looking down the normal vector, if the surface has positive Gaussian curvature at the point, the loop on the unit sphere is traversed counterclockwise (positive direction); if it has negative curvature, the loop is traversed clockwise (negative direction). About a degenerate saddle point, the loop may wind more than once on the Gauss sphere for each time around the point on the surface. Move the "radius" slider to observe the following: The loops will change size. As the radius of the loop approaches zero, the ratio of the surface areas contained by (1) the loop on the sphere (counting orientation and multiplicity of the loop) and (2) the loop on the surface approaches the Gaussian curvature of the surface at the point.

Below the graphics is some curvature data. The surface areas contained by the loops, their quotient, and the Gaussian curvature are given. Further, the Gaussian curvature is equal to the product of the principal curvatures, which are defined to be the maximum and minimum curvatures of the normal sections through the point. The normal sections corresponding to the principal curvatures are shown in the surface graphic.

Snapshot 1: elliptical paraboloid

Snapshot 2: hyperbolic paraboloid

Snapshot 3: degenerate saddle

Contributed by: Michael Rogers (Oxford College/Emory University)