Computing Gaussian curvature

Can Gaussian curvature $K$ be computed from WolframAlpha or any other available Mathematica program? Please indicate the program or its reference.

If input parametrization is given as Gaussian curvature of

X[u,v] = {Cos[u] Cos[v], Cos[u] Sin[v], Sin[u]}

it simply outputs an assembly of three individual Cartesian prismatic Monge 3D (u,v) plots and their plotted K but does not refer to meridians and parallels of a single unit sphere surface.

Note this parametric surface of unit sphere (S^2) should have constant Gaussian curvature: 1.

Surface:

x[u_, v_] := {Cos[u] Cos[v], Cos[u] Sin[v], Sin[u]}


First fundamental form:

fff = FullSimplify[With[{p1 = D[x[a, b], a], p2 = D[x[a, b], b]},
{p1.p1, p1.p2, p2.p2}]];


Second fundamental form:

nm = FullSimplify[Cross[D[x[a, b], a], D[x[a, b], b]]];
unm = FullSimplify[nm/Sqrt[nm.nm]];
sec = {D[x[a, b], {a, 2}], Derivative[1, 1][x][a, b],
D[x[a, b], {b, 2}]};
sff = FullSimplify[#.unm & /@ sec];


Gaussian Curvature:

de[{e_, f_, g_}] = e g - f^2
FullSimplify[de[#1]/de[#2] & @@ {sff, fff}]


yields 1

The mean curvature:

FullSimplify[(sff Reverse[fff]).{1, -2, 1}/(2 de[fff])]


yields: Sqrt[Cos[a]^2] Sec[a], which is clearly 1 as required.

i.e. K=1, H=1, $\kappa1 =1,\kappa2=1$

Simplifications can be challenging...others will have better approaches

• Dear @ ubpdqn. Thanks for understanding Gauss.
– eldo
Oct 6, 2014 at 8:20
• @eldo "Die Mathematik ist die Königin der Wissenschaften..." Oct 6, 2014 at 8:25
• en.wikipedia.org/wiki/Sphere
– eldo
Oct 6, 2014 at 8:30
• @ubpdqn: Jawohl ...ihre Schönheit verdoppelt mit Mathematica. Oct 6, 2014 at 9:35
• @Narasimham I just posted the answer to illustrate a way to calculate Gaussian curvature for smooth surfaces (manifolds) using first and second fundamental forms. Varying x[u,v] should work for other surfaces, acknowledging issues of singular points, ugly expressions from limitations of simplifications. Oct 6, 2014 at 9:44

Definition

GaussCurvature[f_] :=
With[{dfu = D[f, u], dfv = D[f, v]},
Simplify[(Det[{D[dfu, u], dfu, dfv}] Det[{D[dfv, v], dfu, dfv}] -
Det[{D[f, u, v], dfu, dfv}]^2) / (dfu.dfu  dfv.dfv - (dfu.dfv)^2)^2]];


Sphere

GaussCurvature[{Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}]


1

Ellipsoid

ellipsoid = {2 Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]};

cur = GaussCurvature[ellipsoid]


plo =
Plot3D[cur, {u, 0, Pi}, {v, 0, 2 Pi},
ColorFunction -> "TemperatureMap",
PlotRange -> Full]


range = Last[PlotRange /. AbsoluteOptions[plo, PlotRange]]


{0.25, 4.}

ParametricPlot3D[ellipsoid, {u, 0, Pi}, {v, 0, 2 Pi},
Mesh -> False,
ColorFunction -> Function[{x, y, z, u, v},
ColorData["TemperatureMap"][Rescale[cur, range]]],
ColorFunctionScaling -> False]


Torus

torus = {(2 + Cos[v]) Cos[u], (2 + Cos[v]) Sin[u], Sin[v]};

cur = GaussCurvature[torus]


plo =
Plot3D[cur, {u, 0, 2 Pi}, {v, 0, 2 Pi},
ColorFunction -> "TemperatureMap",
PlotRange -> Full]


range = Last[PlotRange /. AbsoluteOptions[plo, PlotRange]]


{-1., 0.333333}

par =
ParametricPlot3D[
torus, {u, 0, 2 Pi}, {v, 0, 2 Pi},
ImageSize -> 400,
Mesh -> False,
ColorFunction -> Function[{x, y, z, u, v},
ColorData["TemperatureMap"][Rescale[cur, range]]],
ColorFunctionScaling -> False,
PlotPoints -> 70];

bar =
BarLegend[{"TemperatureMap", range}, Automatic];

Row[{par, bar}]


Moebius with gaussian mesh lines

f = {Cos[v] (3 + u Cos[v/2]), Sin[v] (3 + u Cos[v/2]), u Sin[v/2]};
cur = GaussCurvature[f];

ParametricPlot3D[f, {u, -1.5, 1.5}, {v, 0, 2 Pi},
Boxed -> False,
PlotStyle -> Opacity[0.8],
ImageSize -> 500,
Mesh -> 12,
PlotPoints -> 120,
MeshFunctions -> Function[{x, y, z, u, v}, Rescale[cur, {-0.04, -0.02}]],
ColorFunction -> Function[{x, y, z, u, v},
ColorData["DarkRainbow"][Rescale[cur, {-0.04, -0.02}]]],
ColorFunctionScaling -> False]


Comparison with Mean Curvature

sincos = {u, v, Sin[u] Cos[v]};
cur = GaussCurvature[sincos];
range = Last[PlotRange /. AbsoluteOptions[plo, PlotRange]];

p1 =
ParametricPlot3D[sincos, {u, 0, 2 Pi}, {v, 0, 2 Pi},
ImageSize -> 500,
Mesh -> 6,
PlotLabel -> Style["Gaussian Curvature\n", 16, Bold],
PlotPoints -> 120,
MeshFunctions -> Function[{x, y, z, u, v}, Rescale[cur, range]],
ColorFunction -> Function[{x, y, z, u, v},
ColorData["Rainbow"][Rescale[cur, range]]],
ColorFunctionScaling -> False];

MeanCurvature[f_] :=
With[{du = D[f, u], dv = D[f, v]},
Simplify[(Det[{D[du, u], du, dv}] * dv.dv -
2 Det[{D[f, u, v], du, dv}] * du.dv + Det[{D[dv, v], du, dv}] * du.du) /
(2 Simplify[(du.du*dv.dv - (du.dv)^2)]^(3/2))]];

cur = MeanCurvature[sincos];
plo = Plot3D[cur, {u, 0, 2 Pi}, {v, 0, 2 Pi}];
range = Last[PlotRange /. AbsoluteOptions[plo, PlotRange]];

p2 =
ParametricPlot3D[sincos, {u, 0, 2 Pi}, {v, 0, 2 Pi},
ImageSize -> 500,
Mesh -> 6,
PlotLabel -> Style["Mean Curvature\n", 16, Bold],
PlotPoints -> 120,
MeshFunctions -> Function[{x, y, z, u, v}, Rescale[cur, range]],
ColorFunction -> Function[{x, y, z, u, v},
ColorData["Rainbow"][Rescale[cur, range]]],
ColorFunctionScaling -> False];

Row[{p1, p2, BarLegend[{"Rainbow", range}, LegendMarkerSize -> 400]}]


Update for space curves

curvature[f_] :=
With[{d1 = D[f, u], d2 = D[f, {u, 2}]},
Norm[Cross[d1, d2]] / Norm[d1]^3 // Simplify]

loxodromes[a_, b_] :=
{
2 a E^(b u) Cos[u],
2 a E^(b u) Sin[u],
a^2 E^(2 b u) - 1
} / (1 + a^2 E^(2 b u))

cur = curvature[loxodromes[1, 0.1]];

plo = Plot[cur, {u, -4 Pi, 4 Pi}, PlotRange -> All]


range = Last[PlotRange /. AbsoluteOptions[plo, PlotRange]];

Show[

ParametricPlot3D[loxodromes[1, 0.1], {u, -4 Pi, 4 Pi},
ColorFunction -> Function[{x, y, z, u, v},
ColorData["Rainbow"][Rescale[cur, range]]],
ColorFunctionScaling -> False,
PlotStyle -> Thickness[0.01]],

Graphics3D[{Opacity[0.2], Sphere[]}],

ImageSize -> 500]


• @eldo very nice and thank you for book recommendation...will add to my wish list Oct 7, 2014 at 1:40
• @eldo congratulations on 10K! Oct 8, 2014 at 9:00
• @ubpdqn Thank you very much for noticing :)
– eldo
Oct 8, 2014 at 17:58

Another expression using Cross

gaussianCurvature[r_, {u_, v_}] :=
Module[{n, ru = D[r, u], rv = D[r, v], ruv = D[r, u, v]},
n = Cross[ru, rv];
((D[ru, u].n) (D[rv, v].n) - (ruv.n)^2)/(n.n)^2 // Simplify
]


Examples

gaussianCurvature[{Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}, {u, v}]


1

Curvatures of implicitly defined surfaces

1. Gaussian curvature

Based upon burnout's answer to this question:

How to speed up estimation of Mean and Gaussian curvatures on triangular meshes?

we can compute the Gaussian curvature of implicitly defined surfaces as follows:

fun = -x^2 + x^4 - y^2 + y^4 - z^2 + z^4;

d1 = D[fun, {{x, y, z}}] // Simplify;
d2 = D[fun, {{x, y, z}, 2}] // Simplify;

gauss[x_, y_, z_] =
Simplify[((d1 . LinearSolve[d2, d1]) Det[d2]) / (# . # & [d1])^2];

Legended[
ContourPlot3D[fun == -1/2, {x, -1, 1}, {y, -1, 1}, {z, -1, 1},
ColorFunction ->
Function[{x, y, z, u, v},
ColorData["TemperatureMap"][Rescale[gauss[x, y, z], {-3, 3}]]],
ColorFunctionScaling -> False,
Mesh -> False,
PlotPoints -> 70],
BarLegend[{"TemperatureMap", {-3.1, 3.1}}, Automatic]]


The scaling of {-3, 3} was inserted manually, because I didn't find a way to automate this. But this doesn't take too long. Start with {-1, 1} and go up or down.

2. Mean curvature

The same link also provides a formula for Mean curvature:

fun = -x^2 + x^4 - y^2 + y^4 - z^2 + z^4;

d1 = D[fun, {{x, y, z}}] // Simplify;
d2 = D[fun, {{x, y, z}, 2}] // Simplify;

mcur[x_, y_, z_] =
Simplify[(d1 . d2 . d1 - Tr[d2] (# . # &[d1])) / (2 (# . # & [d1])^(3/2))];

Legended[
ContourPlot3D[fun == -1/2, {x, -1, 1}, {y, -1, 1}, {z, -1, 1},
ColorFunction -> Function[{x, y, z, u, v},
ColorData["TemperatureMap"][Rescale[Abs @ mcur[x, y, z], {0, 3}]]],
ColorFunctionScaling -> False,
Mesh -> False,
PlotPoints -> 70],
BarLegend[{"TemperatureMap", {0, 3.1}}, Automatic]]


3. Mesh lines

The two curvature functions can also be applied to mesh lines:

fun = x^4 + y^4 + z^4 - (x^2 + y^2 + z^2)^2 + 3 (x^2 + y^2 + z^2);

d1 = D[fun, {{x, y, z}}] // Simplify;
d2 = D[fun, {{x, y, z}, 2}] // Simplify;

mcur[x_, y_, z_] =
Simplify[(d1 . d2 . d1 -
Tr[d2] (# . # & [d1])) / (2 (# . # &[d1])^(3/2))];

Legended[
ContourPlot3D[fun == 3, {x, -2, 2}, {y, -2, 2}, {z, -2, 2},
ColorFunction -> Function[{x, y, z, u, v},
ColorData["TemperatureMap"][Rescale[Abs @ mcur[x, y, z], {0, 1}]]],
ColorFunctionScaling -> False,
Mesh -> 12,
MeshFunctions ->
Function[{x, y, z, u, v}, Rescale[Abs @ mcur[x, y, z], {0, 1}]],
PlotPoints -> 70],
BarLegend[{"TemperatureMap", {0, 1.1}}, Automatic]]


• In the image transition of double curvature K depicted beautifully. Base faces ( of fattened tetrahedron ) transition with negative K from base towards sides and among side faces with positive K . Perhaps in each corner octant $(0,1)$ it would be clearer. Oct 24, 2023 at 20:27