$Assumptions = t ∈ Reals;

Curvas planas

El diedro de F-S

Esta función calcula a partir de una curva α (parametrizada con respecto a la variable t, que no es necesariamente la longitud de arco) el vector tangente, el vector normal y la curvatura.

El resultado es una lista con tres elementos: el vector tangente, el normal, y la curvatura.

proc[α:{_,_}] := Module[{αt, tt, nn, κ},
αt = FullSimplify[D[α, t]];
tt = FullSimplify[Normalize[αt]];
nn = {-tt[[2]], tt[[1]]}; 
κ = FullSimplify[Det[{αt, D[αt,t]}]/((Norm[αt])^3)];
{tt, nn, κ}
];

Ejemplo: La circunferencia de radio 1 parametrizada por {Cos[t], Sin[t]}

proc[{Cos[t], Sin[t]}]

Ejemplo: La elipse de semiejes 2 y 1, parametrizada por {2 Cos[t], Sin[t]}

proc[{2Cos[t], Sin[t]}]

Algunos ejemplos

Armemos una lista de ejemplos para usar más abajo.

Clear[Ejemplo2D];
SetAttributes[Ejemplo2D, {HoldAll}];
Ejemplo2D /: Format[e:Ejemplo2D[l_List]] := 
Interpretation[Ejemplo2D[Evaluate["Nombre" /. l]], e];

Clear[campo];
nombresDeCampos = {"Nombre", "Parametrización", "Dominio", "PlotRange",};
campo[Ejemplo2D[l_], "Opciones"] := FilterRules[l, Except[nombresDeCampos]];
Do[
(campo[Ejemplo2D[l_], #] := # /. l)&[c],
{c,  nombresDeCampos}
];

ejemplos2D = {
Ejemplo2D[{"Nombre"->"Elipse",
"Parametrización"->{2Cos[t],Sin[t]},
"Dominio"->{0,2π},
"PlotRange"->{{-4,4},{-3,3}}
}],
Ejemplo2D[{"Nombre"->"Circunferencia",
"Parametrización"->{Cos[t],Sin[t]},
"Dominio"->{0,2π},
"PlotRange"->{{-4,4},{-3,3}}
}],
Ejemplo2D[{"Nombre"->"Parábola",
"Parametrización"->{t,(t^2)},
"Dominio"->{-2,2},
"PlotRange"->{{-10,10},{0,8}}
}],
Ejemplo2D[{"Nombre"->"Hipérbola",
"Parametrización"->{Sinh[t],Cosh[t]},
"Dominio"->{-2,2},
"PlotRange"->{{-10,10},{0,10}}
}],
Ejemplo2D[{"Nombre"->"Espiral de Arquímedes","Parametrización"->{(1/5) t Cos[t],(1/5) t Sin[t]},
"Dominio"->{0,6 π},
"PlotRange"->{{-5,5},{-5,5}}
}],
Ejemplo2D[{"Nombre"->"Espiral logarítimica","Parametrización"->{(1/50) (E^t) Cos[t],(1/50) (E^t) Sin[t]},
"Dominio"->{0,6 π},
"PlotRange"->{{-10,10},{-10,10}}
}],
Ejemplo2D[{"Nombre"->"Lemniscata de Bernoulli","Parametrización"->{((Cos[t])/(((Sin[t])^2)+1)),((Sin[t] Cos[t])/(((Sin[t])^2)+1))},
"Dominio"->{0.01,2π-0.01},
"PlotRange"->{{-2,2},{-2,2}}
}],Ejemplo2D[{"Nombre"->"Cardioide","Parametrización"->{2 Cos[t] (1+Cos[t]),2 (1+Cos[t]) Sin[t]},
"Dominio"->{-π+0.01, π-0.01},
"PlotRange"->{{-4,4},{-4,4}}
}],
Ejemplo2D[{"Nombre"->"Catenaria",
"Parametrización"->{t,Cosh[t]},
"Dominio"->{-2,2},
"PlotRange"->{{-4,4},{0,5}}
}],
Ejemplo2D[{"Nombre"->"Cisoide de Diocles",
"Parametrización"->{((2 (t^2))/(1+(t^2))),((2 (t^3))/(1+(t^2)))},
"Dominio"->{-2,2},
"PlotRange"->{{-6,2},{-4,4}}
}],
Ejemplo2D[{"Nombre"->"Tractriz",
"Parametrización"->{Sin[t],Cos[t]+Log[Tan[(t/2)]]},
"Dominio"->{0.01,π-0.01},
"PlotRange"->{{0,2},{-2,2}}
}],
Ejemplo2D[{"Nombre"->"Limaçon",
"Parametrización"->{Cos[t] (1+2 Cos[t]),(1+2 Cos[t]) Sin[t]},
"Dominio"->{0,2 π},
"PlotRange"->{{-1,3.25},{-2,2}}
}]
};

La evoluta

La evoluta de una curva es el lugar geométrico de sus centros de curvatura.

Clear[evoluta];
SetAttributes[evoluta, HoldFirst];
Options[evoluta] = {info -> None};
evoluta[α_, opts:OptionsPattern[evoluta]] :=
Module[{tt, nn, κ},
{tt, nn, κ} = If[OptionValue[info] == None, proc[α], OptionValue[info]];
Simplify[α + nn / κ]
]

El centro de curvatura en cualquier punto de una circunferencia es el centro de ésta: su evoluta, entonces, es una «curva» constante.

evoluta[{Cos[t], Sin[t]}]

Más interesante, la evoluta de una elipse es una curva llamada astroide: su parametrización es

evoluta[{2Cos[t], Sin[t]}]

Para verla, hagamos un dibujo: la curva en azul es, claro, la elipse de partida, mientras que la roja es su evoluta.

Block[{α, β},
α = {2Cos[t], Sin[t]};
β = evoluta[α];
ParametricPlot[{α, β, γ, δ}, {t, 0, 2π},
PlotStyle -> {Blue, Red}, ImageSize -> Small,  Ticks -> None]
]

La evoluta a una curva α tiene en cada punto como tangente a la normal de α en el punto correspondiente.
Decimos que es una envolvente de la familia de normales de α.

Esto puede verse inmediatamente en un dibujo si, además de dibujar a la curva y a su envolvente, dibujamos las rectas normales:

Clear[envolventeDeNormales];
Options[envolventeDeNormales] = {PlotPoints -> Automatic, info -> None};
envolventeDeNormales[α_, {t0_, t1_}, opts:OptionsPattern[{envolventeDeNormales, ParametricPlot}]] := 
Module[{tt, nn, κ, pts},
pts = OptionValue[PlotPoints];
If[pts == Automatic, pts = 100];
{tt, nn, κ} = If[OptionValue[info] == None, proc[α], OptionValue[info]];
ParametricPlot[{α, α+ nn / κ},
{t, t0, t1},
Prolog -> {
Thin,Darker[Gray],
Line[Table[N[{α, α+1.5nn / κ }], {t, t0, t1, (t1-t0)/pts}]]
}, 
Ticks -> False,
Evaluate[FilterRules[{opts}, Options[ParametricPlot]]]
]
]

Algunos ejemplos:

Manipulate[
Module[{ex = ejemplos2D[[e]]},
envolventeDeNormales[
campo[ex, "Parametrización"], 
campo[ex, "Dominio"], 
ImageSize -> Medium, 
PlotRange -> campo[ex, "PlotRange"], 
Sequence@@campo[ex, "Opciones"]
]
],
{{e, 1, "Curva:"}, 
	MapIndexed[#2[[1]]-> campo[#1, "Nombre"]&, ejemplos2D], 
	ControlType -> PopupMenu},
TrackedSymbols :> {e}
]

Es más ilustrativa una animación para ver esto:

Clear[envolventeDeNormalesAnimacion];
Options[envolventeDeNormalesAnimacion] = {PlotPoints -> Automatic, info -> None};
envolventeDeNormalesAnimacion[α_, {t0_, t1_}, opts:OptionsPattern[{envolventeDeNormalesAnimacion, ParametricPlot}]] := 
Module[{tt, nn, κ, pts, curvas},
pts = OptionValue[PlotPoints];
If[pts == Automatic, pts = 100];
{tt, nn, κ} = If[OptionValue[info] == None, proc[α], OptionValue[info]];
curvas = ParametricPlot[{α, α+ nn / κ},{t, t0, t1},
Ticks -> False,Evaluate[FilterRules[{opts}, Options[ParametricPlot]]]
];
Animate[
Show[curvas,Graphics[{Line[{α, α+1.5nn / κ }]}] /. t -> s], 
{{s, t0, "t"}, t0, t1}, AnimationDirection -> ForwardBackward
]
]

Module[{ex, α, t0, t1, range, tt, nn, κ, d, curvas},
Manipulate[
ex = ejemplos2D[[e]];
α = campo[ex, "Parametrización"];
{t0, t1} = campo[ex, "Dominio"];
{tt, nn, κ} = proc[α];
range = campo[ex, "PlotRange"];
d = Norm[range[[All, 2]]-range[[All, 1]]];
curvas = ParametricPlot[{α, α+ nn / κ},{t, t0, t1},
Ticks -> False,PlotRange -> range, ImageSize -> Medium,
Evaluate[FilterRules[{campo[ex, "Opciones" ]}, Options[ParametricPlot]]]
];
DynamicModule[{s = t0},
Column[{
Dynamic[Show[curvas,Graphics[{Line[{α, α+d nn / κ }]}] /. t -> s]],
Animator[Dynamic[s],  {t0, t1},
AnimationDirection->ForwardBackward,AnimationRunning->True]
}]
], 
{{e, 1, "Curva:"}, 
	MapIndexed[#2[[1]]-> campo[#1, "Nombre"]&, ejemplos2D],
	ControlType -> PopupMenu},
TrackedSymbols -> {e}
]
]

Iluminando una curva desde un punto

Si iluminamos una curva con rayos de luz emitidos desde un punto, podemos buscar la curva envolvente de los rayos. 
Esa curva se ve de forma bastante evidente en los siguientes dibujos.

Clear[rayos];
rayos[α_, {t0_, t1_}, light_, opts:OptionsPattern[]] := Module[{tt, pts},
pts = 100;
tt = Simplify@Normalize@D[α, t];
Show[
{ ParametricPlot[α, {t, t0, t1},  PlotStyle -> Thick, Ticks -> None],
Graphics[{
Thin, Black,
Table[
With[{p=Evaluate[α]},
Line[{light, p, p+10*((light-p)-2 tt Dot[light-p, tt])}]
], {t, t0, t1, (t1-t0)/pts}
],
Magenta, PointSize[0.025],  Point[light]
}]
}, opts]
];

Por ejemplo si iluminamos una parábola desde un punto en su concavidad, tenemos el siguiente dibujo:

rayos[{(t^2),t}, {-2, 2}, {3, 0.25}, ImageSize -> Small]

Si iluminamos una elipse desde uno de sus focos, los rayos se concentran en el otro foco, de manera que la envolvente de esos rayos es degenerada:

rayos[{2Cos[t],Sin[t]}, {0, 2π}, {(Sqrt[3]),0}, ImageSize -> Medium]

Varios ejemplos más: para cada una de estas curvas, es posible mover el punto de luz con el cursor del mouse.

Manipulate[
Module[{ex = ejemplos2D[[e]]},
rayos[campo[ex, "Parametrización"],campo[ex, "Dominio"], p, PlotRange -> campo[ex, "PlotRange"],
ImageSize -> Medium]
],
{{e, 1, "Curva:"}, MapIndexed[#2[[1]] -> campo[#, "Nombre"]&, ejemplos2D],ControlType -> PopupMenu},
{{p, {0,0}}, Locator},
TrackedSymbols :> {e, p}
]

Reconstrucción de una curva plana a partir de su curvatura

Clear[reconstruir];
Options[reconstruir] = {initialPoint -> {0,0}, initialTangent->{1,0}};
reconstruir[κ_, {t0_, t1_}, 
opts:OptionsPattern[{reconstruir, ParametricPlot}]
] := Module[{p0, θ0, α},
p0 = OptionValue[initialPoint];
θ0 = ArcTan@@OptionValue[initialTangent];
α = {x, y} /. NDSolve[
{
x'[t]== Cos[θ[t]],
y'[t]== Sin[θ[t]],
θ'[t] == κ,
x[t0] == p0[[1]], 
y[t0] == p0[[2]], 
θ[0] == θ0
}, {x, y, θ}, {t, t0, t1}
][[1]];
ParametricPlot[{α[[1]][t], α[[2]][t]}, {t, t0, t1},
Evaluate[FilterRules[{opts}, Options[ParametricPlot]]]]
];

Curvas en el espacio

El triedro de F-S

proc[α:{_,_, _}] := Module[{αt, αtt, v, αttt, tt, nn, bb, κ, τ},
αt = Simplify@D[α, t];
αtt = Simplify@D[αt, t];
v = Simplify@Cross[αt, αtt];
αttt = Simplify@D[αtt, t];
tt = Simplify@ Normalize@ αt;
bb = Simplify@ Normalize@ v;
nn = Cross[bb, tt];
κ = Norm[v]/((Norm[αt])^3);
τ = Dot[v, αttt]/((Norm[v])^2);
FullSimplify@{tt, nn, bb, κ, τ}
];

Visualizaciones del triedro

Montaña rusa

Clear[rollerCoaster];
SetAttributes[rollerCoaster, HoldFirst];
Options[rollerCoaster] = {Steps -> 100};
rollerCoaster[α:{_,_,_}, {t0_, t1_}, 
opts:OptionsPattern[{rollerCoaster, Graphics3D}]] := 
Module[{tt, nn, bb, κ, τ, pts, curve},
pts = OptionValue[Steps];
If[pts == Automatic, pts = 50];
{tt, nn, bb, κ, τ} = proc[α];
curve = {Thick, Line[Table[N@α,{t, t0, t1, (t1-t0)/pts}]]};
Manipulate[
Graphics3D[
{
curve,
{Yellow, Polygon[N[{α, α+nn/3, α+bb/3} /. t -> s]]},
{Red, Thick, Line[N[{α, α+nn} /. t -> s]]},
{Blue, Thick, Line[N[{α, α+bb} /. t -> s]]}
},
Evaluate[FilterRules[{opts}, Options[Graphics3D]]]
],
{{s, t0, "t"}, t0, t1}
]
]

rollerCoaster[{Cos[4t], Sin[4t], (t^3)/(((2π))^2)}, {0, 2π},
ImageSize -> Small]

Curvas paralelas

Clear[curvasParalelas];
SetAttributes[curvasParalelas, HoldFirst];
Options[curvasParalelas] = {threads -> 10, radius -> 1};
curvasParalelas[α:{_,_,_}, {t0_, t1_}, 
opts:OptionsPattern[{curvasParalelas, ParametricPlot3D}]] := 
Module[{tt, nn, bb, κ, τ, pts, curve, r, n},
{tt, nn, bb, κ, τ} = proc[α];
r = OptionValue[radius];
n = OptionValue[threads];
ParametricPlot3D[
Evaluate[Prepend[Table[α + r(Cos[θ] nn + Sin[θ] bb), {θ, 0, 2π, 2π/n}], α]],
{t, t0, t1}, PlotStyle -> Prepend[Table[{Black}, {i, 0, n}], {Thickness[0.005], Red}],
Evaluate[FilterRules[{opts}, Options[ParametricPlot3D]]]
]
]

Module[{ejemplo},
ejemplo = {
{"Trefoil knot",{(2+Cos[3t])Cos[2t], (2+Cos[3t])Sin[2t], Sin[3t]}, {0, 2π},
{threads -> 4, radius -> 0.2}},
{"Figure eight knot", {(2+Cos[2t])Cos[3t], (2+Cos[2t])Sin[3t], Sin[4t]}, {0, 2π},
{threads -> 8, radius -> 0.2}},
{"Curva al azar", {2Cos[t],2Sin[t], (t^3)/14}, {-2π, 2π}, {threads -> 4, radius ->0.75}}
};
Manipulate[
curvasParalelas[
Evaluate[ejemplo[[e, 2]]], ejemplo[[e, 3]], 
ImageSize -> Medium, Sequence@@ejemplo[[e, 4]], Boxed -> False, Axes -> None,
SphericalRegion->True, ImageSize -> Large],
{{e, 1, "Curva:"}, MapIndexed[#2[[1]]-> #1[[1]]&, ejemplo], ControlType -> PopupMenu}
]
]

Bandas

Clear[bandas];
SetAttributes[bandas, HoldFirst];
Options[bandas] = {width -> 1};
bandas[α:{_,_,_}, {t0_, t1_}, 
opts:OptionsPattern[{bandas, ParametricPlot3D}]] := 
Module[{tt, nn, bb, κ, τ, pts, curve, w},
{tt, nn, bb, κ, τ} = proc[α];
w = OptionValue[width];
ParametricPlot3D[
{α+s nn, α+s bb},
{t, t0, t1}, {s, -w, w},
MeshStyle -> None,Mesh -> {100, 2},
Evaluate[FilterRules[{opts}, Options[ParametricPlot3D]]]
]
]

Module[{ejemplo},
ejemplo = {
{"Trefoil knot",{(2+Cos[3t])Cos[2t], (2+Cos[3t])Sin[2t], Sin[3t]}, {0, 2π},
{width -> 0.2}},
{"Figure eight knot", {(2+Cos[2t])Cos[3t], (2+Cos[2t])Sin[3t], Sin[4t]}, {0, 2π},
{width -> 0.2}},
{"Curva al azar", {2Cos[t],2Sin[t], (t^3)/14}, {-2π, 2π}, {threads -> 4, radius ->0.75}}
};
Manipulate[
bandas[
Evaluate[ejemplo[[e, 2]]], ejemplo[[e, 3]], 
ImageSize -> Medium, Sequence@@ejemplo[[e, 4]], Boxed -> False, Axes -> None,
SphericalRegion->True, ImageSize -> Large],
{{e, 1, "Curva:"}, MapIndexed[#2[[1]]-> #1[[1]]&, ejemplo], ControlType -> PopupMenu}
]
]

Superficies regladas

Clear[superficieFS];
SetAttributes[superficieFS, HoldFirst];
Options[superficieFS] = {Width -> 2};
superficieFS[α:{_,_,_}, {t0_, t1_}, which_,
opts:OptionsPattern[{superficieFS, ParametricPlot3D}]] := 
Module[{tt, nn, bb, κ, τ, v, width},
width = OptionValue[Width];
{tt, nn, bb, κ, τ} = proc[α];
v = {tt, nn, bb}[[which]];
Show[{
Graphics3D[Tube[Table[N@α, {t, t0, t1, (t1-t0)/100}], 0.25]],
ParametricPlot3D[
α + s v, {t, t0, t1}, {s, -width, width}
]
}
]
]

superficieFS[{Cosh[t], Sinh[t], t}, {-2, 2}, 3, Width -> 6]

Reconstrucción a partir de la curvatura

Clear[reconstruir3D];
SetAttributes[reconstruir3D, HoldFirst];
Options[reconstruir3D] = {initialPoint -> {0,0,0}, initialTangent->{1,0,0}, colorBy -> "Curvature"};
reconstruir3D[κ_, τ_, {t0_, t1_}, 
opts:OptionsPattern[{reconstruir3D, ParametricPlot3D}]
] := Module[{p0, v0, α, max, min},
p0 = OptionValue[initialPoint];
v0 = OptionValue[initialTangent];
Which[
OptionValue[colorBy]=="Curvature", color = κ, 
OptionValue[colorBy]=="Torsion",color = τ,
OptionValue[colorBy] == "TotalCurvature", color = (κ^2)+(τ^2),
True, color = κ
];
max = NMaxValue[{color, t0≤t≤t1}, t];
min = NMinValue[{color, t0≤t≤t1}, t];
α = {x, y, z} /. NDSolve[
{
x'[t] == tt1[t], y'[t] == tt2[t], z'[t] == tt3[t], 
tt1'[t] == κ nn1[t], tt2'[t] == κ nn2[t], tt3'[t] == κ nn3[t], 
nn1'[t] == -κ tt1[t]-τ bb1[t], nn2'[t] == -κ tt2[t]-τ bb2[t], nn3'[t] == -κ tt3[t]-τ bb3[t], 
bb1'[t] == τ nn1[t], bb2'[t] == τ nn2[t], bb3'[t] == τ nn3[t],
x[0] == p0[[1]], y[0] == p0[[2]], z[0] == p0[[3]], 
tt1[0] == 1, tt2[0] == 0, tt3[0] == 0,
nn1[0] == 0, nn2[0] == 1, nn3[0] == 0,
bb1[0] == 0, bb2[0] == 0, bb3[0] == 1
}, {x, y, z, tt1, tt2, tt3, nn1, nn2, nn3, bb1, bb2, bb3}, {t, t0, t1}
][[1]];
ParametricPlot3D[{α[[1]][t], α[[2]][t], α[[3]][t]}, {t, t0, t1},
PlotStyle -> Thickness[0.01],
ColorFunction -> Function[{x,y,z,s}, Hue[N[((color /. t -> t0+s(t1+t0))-min)/(max-min+0.1)/2+1/2]]],
Evaluate[FilterRules[{opts}, Options[ParametricPlot3D]]]]
];

ParametricPlot[{x,y}, {x, 0, 1}, {y, 0, 0.1}, Axes -> False,
ColorFunction -> Function[{x, y, u, v}, Hue[u/2+1/2]], Mesh ->None]

reconstruir3D[Cos[t],Sin[t]+Cos[1.1t]/3, {0, 16π}, colorBy -> "Curvature",
Ticks -> False, PlotStyle -> Thick, SphericalRegion -> True]

Ejemplos

Torus knots

Clear[torusKnot];
torusKnot[{p_, q_}, {a_, b_, c_}] := {(a+b Cos[q t])Cos[p t], (a+b Cos[q t])Sin[p t], c Sin[q t]};

Module[{α, tt, nn, bb, κ, τ},
Manipulate[
α = torusKnot[{p,q}, {a,b,c}];
{tt, nn, bb, κ, τ} = proc[α];
Show[{
ParametricPlot3D[
{(a+b Cos[t])Cos[st], (a+b Cos[t])Sin[s], c Sin[s]},
{t, 0, 2π}, {s,0, 2π}
],
ParametricPlot3D[α + (Cos[θ] nn + Sin[θ] bb)/3, {t, 0, 2π}, {θ, 0, 2π},
SphericalRegion -> True, Boxed -> False, Axes -> False, PlotRange -> 2{{-3,3}, {-3,3}, {-3,3}},
PlotStyle -> Thickness[0.01], MeshStyle -> None, PlotPoints -> {100, 4}
]
}],
{{p, 2}, 1, 10, 1, Appearance -> "Labeled"},
{{q, 3}, 1, 10, 1, Appearance -> "Labeled"},
Delimiter,
{{a, 3}, 0, 10, Appearance -> "Labeled"}, 
{{b, 2}, 0, 10, Appearance -> "Labeled"}, 
{{c, 1}, 0, 10, Appearance -> "Labeled"},
ContinuousAction -> None,
ControlPlacement -> Left
]
]