# Visualization of Gaussian Curvature

I need to visualize Gaussian Curvature of a parametric surface. There is a solution in this math.SE post.

However, I'm not sure its working because when I draw a sphere it's all white, but it should be red or brown (because its Gaussian curvature is positive):

GaussianCurvature[f_, {u_, v_}] :=
Simplify[(Det[{D[f, {u, 2}], D[f, u], D[f, v]}] Det[{D[f, {v, 2}],
D[f, u], D[f, v]}] -
Det[{D[f, u, v], D[f, u],
D[f, v]}]^2)/(D[f, u].D[f, u] D[f, v].D[f,
v] - (D[f, u].D[f, v])^2)^2];

Options[gccolor] =
Select[Options[ParametricPlot3D], FreeQ[#, ColorFunctionScaling] &];

Off[RuleDelayed::rhs];

gccolor[f_, {u_, ura__}, {v_, vra__}, opts___?OptionQ] :=
Module[{cf, gc, rng},
cf = ColorFunction /. {opts} /. Options[gccolor];
If[cf === Automatic, cf = ColorData["LightTemperatureMap"]];
gc[u_, v_] = GaussianCurvature[f, {u, v}];
rng = Last[
PlotRange /.
AbsoluteOptions[
Plot3D[gc[u, v], {u, ura}, {v, vra},
PerformanceGoal -> "Speed", PlotRange -> Full], PlotRange]];
ParametricPlot3D[f, {u, ura}, {v, vra},
ColorFunction ->
Function[{x, y, z, u, v}, cf[Rescale[gc[u, v], rng]]],
ColorFunctionScaling -> False,
Evaluate[FilterRules[{opts}, Options[gccolor]]]]];

On[RuleDelayed::rhs];

gccolor[{Cos[u] Sqrt[1 - v^2], Sin[u] Sqrt[1 - v^2], v}, {u, 0,
2 Pi}, {v, -1, 1}] How can I modify that code such that for any point on the surface if its Gaussian curvature is positive it turns red and if its zero it turns to white and for negative it turns to blue? Also, if I can do this with any other software please tell me.

• Hi, try put there ColorFunction similar to those: mathematica.stackexchange.com/q/47749/5478
– Kuba
May 14 '14 at 5:10
• You are right, I don't have time now to focus on this. I will try to update my answer later unless someone else do this.
– Kuba
May 14 '14 at 9:44
• I prolly should fix that routine when I find the time… Jun 9 '15 at 10:09
• OP says he can wait... ;) Jun 9 '15 at 10:33

I finally got around to fixing the routine in the math.SE answer the OP linked to. To make this answer self-contained, I'll reproduce the definitions here:

GaussianCurvature[f_, {u_, v_}] :=
Simplify[(Det[{D[f, {u, 2}], D[f, u], D[f, v]}]
Det[{D[f, {v, 2}], D[f, u], D[f, v]}] -
Det[{D[f, u, v], D[f, u], D[f, v]}]^2)/
(D[f, u].D[f, u] D[f, v].D[f, v] - (D[f, u].D[f, v])^2)^2];

Options[gccolor] = DeleteCases[Options[ParametricPlot3D], ColorFunctionScaling -> _];

gccolor[f_, {u_, ura__}, {v_, vra__}, opts : OptionsPattern[]] :=
Module[{cf = OptionValue[ColorFunction], gc},
If[cf === Automatic, cf = ColorData["ThermometerColors"]];
gc = Function @@ {{u, v}, GaussianCurvature[f, {u, v}]};
ParametricPlot3D[f, {u, ura}, {v, vra},
ColorFunction -> (cf[1/(1 + Exp[-2 gc[#4, #5]])] &),
ColorFunctionScaling -> False,
Evaluate[FilterRules[{opts}, Options[gccolor]]],
Lighting -> "Neutral"]]


The fix involved the use of a sigmoidal function to map values of the curvature to the interval $$(0,1)$$, which is the natural domain of the usual color functions. With this, we obtain the expected red sphere:

gccolor[{Cos[u] Sqrt[1 - v^2], Sin[u] Sqrt[1 - v^2], v}, {u, 0, 2 π}, {v, -1, 1}] and a pseudosphere now has the expected blue color:

gccolor[{Cos[u] Sech[v], Sin[u] Sech[v], v - Tanh[v]}, {u, 0, 2 π}, {v, 0, 3}] (P.S. I also fixed the corresponding mean curvature coloring routine.)

• OK, trying to fix this to be compatible with version 12's underflow handling is taking more time and energy than I can currently devote. (Difficulties with using the Cloud version make the task even more annoying.) Neither LogisticSigmoid[] nor Rescale[] are able to cope with this application either. O well. Jan 30 '20 at 3:07