Lemniscate

Author

Eric W. Weisstein
July 16, 2020

This notebook downloaded from http://mathworld.wolfram.com/notebooks/PlaneCurves/Lemniscate.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Lemniscate.html.

©2020 Wolfram Research, Inc. except for portions noted otherwise

Plot

ParametricPlot

ParametricPlot[{Cos[t],Sin[t]Cos[t]}/(1+Sin[t]^2),{t,0,2π}]

Polar

PolarPlot[(Sqrt[Cos[2θ]]),{θ,0,2π}]

Plot[Through[{Re,Im}[(Sqrt[Cos[2θ]])]],{θ,0,2π},Evaluated->True,PlotStyle->{Red,Yellow}]

Equations

From Foci

((((x^2)+(y^2)))^2)==2 (a^2) ((x^2)-(y^2))

Expand[(x^2 + y^2)^2 - 2*a^2*(x^2 - y^2)]

FullSimplify[Factor[Expand[Subtract@@{((x-a)^2+y^2)((x+a)^2+y^2),a^4}]]]

FullSimplify[%==0]

Polar Equation

Eliminate[{(x^2+y^2)^2==2a^2(x^2-y^2),x==r Cos[θ],y==r Sin[θ],Sin[θ]^2+Cos[θ]^2==1},{x,y}]

Simplify[Solve[r2+(a^2) (-2+4 ((Sin[θ])^2))==0,r2]]

From Parametric

Factor/@GroebnerBasis[Append[Thread[(1+sin^2){x,y}-a {cos,sin cos}],sin^2+cos^2-1],{x,y},{cos,sin},MonomialOrder->EliminationOrder]

{x,y}=a {Cos[t],Sin[t] Cos[t]}/(1+Sin[t]^2);

ArcTan[y/x]

Toric Section that approximates a lemniscate

Equation of a torus:

Entity["Surface","Torus"]["CartesianEquation"][a,c][x,y,z]

Manipulate[ContourPlot[(((c-(Sqrt[(x^2)+(y^2)])))^2)+(z^2)==(a^2),{x,-2,2},{z,-2,2}],{c,.1,1},{a,.1,1},{y,0,1}]

Take y==c-a, which is tangent to the inner circumference:

ExpandAll[(c-Sqrt[x^2+y^2])^2+z^2-a^2/.y->c-a]

Squaring the above:

eqn1=Factor[(-2 a c+2 (c^2)+(x^2)+z^2)^2-(2 c (Sqrt[(a^2)-2 a c+(c^2)+(x^2)]))^2]

This equation *looks* like a lemniscate:

Block[{c=1,a=.4},ContourPlot[eqn1==0,{x,-1.5,1.5},{z,-.6,.6},AspectRatio->Automatic]]

But isn't, since it differs by terms that can't all be set to 0:

ExpandAll[(c-Sqrt[x^2+y^2])^2+z^2-a^2]

leqn=Entity["PlaneCurve","Lemniscate"]["AlgebraicEquation"][a][x,z]

Manipulate[ContourPlot[{
-4 a c (x^2)+(x^4)-4 a c (z^2)+4 (c^2) (z^2)+2 (x^2) (z^2)+(z^4)==0,
(a^2) (x^2)-(x^4)-(a^2) (z^2)-2 (x^2) (z^2)-(z^4)
},{x,-1.5,1.5},{z,-.6,.6},AspectRatio->Automatic],{c,.1,1},{a,.1,1}]

Coefficient[{eqn1,eqn2},x,2]/.{y->0,z->0}

Coefficient[{eqn1,eqn2},y,2]/.{x->0,z->0}

Here are the half-widths:

Assuming[a>0&&c>0,Simplify@MaxValue[{x,eqn1==0},{x,z}]]

Assuming[a>0&&c>0,Simplify@MaxValue[{x,leqn==0},{x,z}]]/.a->w

Now set the widths equal:

eq1=4 a c (x^2)-(x^4)+4 a c (z^2)-4 (c^2) (z^2)-2 (x^2) (z^2)-(z^4);
eq2=(w^2) (x^2)-(x^4)-(w^2) (z^2)-2 (x^2) (z^2)-(z^4)/.w->2(Sqrt[a c])

And subtract:

eq1-eq2//FullSimplify

So the equations will be the same if the torus has:

%/.c->2a

Block[{a=1},ParametricPlot3D[Evaluate[Entity["Surface","Torus"]["ParametricEquations"][a,2a][u,v]],{u,0,2π},{v,0,2π}]]

Manipulate[With[{w=2(Sqrt[a c])},ContourPlot[
{-4 a c (x^2)+(x^4)-4 a c (z^2)+4 (c^2) (z^2)+2 (x^2) (z^2)+(z^4)==0,
(w^2) (x^2)-(x^4)-(w^2) (z^2)-2 (x^2) (z^2)-(z^4)},{x,-2,2},{z,-2,2},ContourStyle->{Directive[AbsoluteThickness[3],Blue],Darker@Yellow}]],{{a,.5},.1,2},{{c,1.},.1,2}]

Here is the curve actually obtained from cutting a torus with a==0.4 and c==1 with the plane y==0.6:

Entity["Surface","Torus"]["ParametricEquations"]

ParametricPlot3D[Evaluate[Entity["Surface","Torus"]["ParametricEquations"][.4,1][u,v]],{u,0,2π},{v,0,2π}]

FullSimplify[Entity["Surface","Torus"]["CartesianEquation"][(4/10),1][x,y,z]/.y->6/10]

ContourPlot[(((-1+(Sqrt[(9/25)+(x^2)])))^2)+(z^2)==(4/25),{x,-2,2},{z,-1,1},AspectRatio->Automatic]

Expand[(((-1+(Sqrt[(9/25)+(x^2)])))^2)]-((4/25)-(z^2))

Expand[-(((((6/5)+(x^2)+(z^2)))^2) -4((9/25)+(x^2)))]

MaxValue[{x,(((-1+(Sqrt[(9/25)+(x^2)])))^2)+(z^2)==(4/25)},{x,z}]

leqn/.a->2(Sqrt[(2/5)])

ContourPlot[{
((8 (x^2))/5)-(x^4)-((12 (z^2))/5)-2 (x^2) (z^2)-(z^4),
((8 (x^2))/5)-(x^4)-((8 (z^2))/5)-2 (x^2) (z^2)-(z^4)
},{x,-1.3,1.3},{z,-.5,.5},AspectRatio->Automatic,PlotLegends->{"toric section","lemniscate"}]

<<Graphics`Shapes`
<<Hidekazu`Knife`

With[{a=1,b=.4},Show[Graphics3D[{EdgeForm[],knife[Graphics3D[Torus[a,b,50,50]],{0,1,0,a-b},{-.5,0,0},{0,.5,0}][[1]]}],Boxed->False,ViewPoint->{0,-2,2.5}]
]

With[{a=1,b=.17},
Show[Graphics3D[{EdgeForm[],Fold[knife[#1,{Sequence@@#2,0,b-a}]&,Graphics3D[Torus[a,b,60,60]],{{0,1},{0,-1},{1,0},{-1,0}}][[1]]}],Boxed->False]
]

Properties

lemniscate=a{Cos[t],Sin[t]Cos[t]}/(1+Sin[t]^2);
eqn=a^2 x^2-x^4-a^2 y^2-2 x^2 y^2-y^4;

AlgebraicEquation

Entity["PlaneCurve","Lemniscate"]["AlgebraicEquation"][a][x,y]

(x^2+y^2)^2-2c^2(x^2-y^2)//Expand

ArcLengthFunction

Entity["PlaneCurve","Lemniscate"]["ArcLengthFunction"][a][t]

v5

ArcLength[lemniscate,t]

Simplify[ArcLength[lemniscate,{t,0,2π}],a>0]

v6

ArcLength[lemniscate,t]

FullSimplify[√((((-((2 a ((Cos[t])^2) Sin[t])/(((1+((Sin[t])^2)))^2))-((a Sin[t])/(1+((Sin[t])^2)))))^2)+(((-((2 a ((Cos[t])^2) ((Sin[t])^2))/(((1+((Sin[t])^2)))^2))+((a ((Cos[t])^2))/(1+((Sin[t])^2)))-((a ((Sin[t])^2))/(1+((Sin[t])^2)))))^2)),0<t<2π&&a>0]

Simplify[ArcLength[lemniscate,{t,0,2π}],a>0]

V6.1

ArcLength[lemniscate,t,Assumptions->t>0&&a>0]

ArcLength

s1=Entity["PlaneCurve","Lemniscate"]["ArcLength"][a]

s2=4 a EllipticK[-1]

s1-s2//FullSimplify

FunctionExpand[s2]

Exact

Integrate[(((Sqrt[2]) a)/(Sqrt[3-Cos[2 t]])),{t,0,2π}]

4Integrate[(((1-((((r/a)))^4)))^(-1/2)),{r,0,a}]

2.Sqrt[2]EllipticK[1/2]

4Integrate[(((1-(t^4)))^(-1/2)),{t,0,1}]

N[%]

N[4EllipticK[-1]]

N[(((Gamma[(1/4)])^2)/(Sqrt[2π]))]

Area

RegionPlot[(x^2+y^2)^2<(x^2-y^2),{x,-1,1},{y,-.5,.5},AspectRatio->Automatic,PlotStyle->Hue[.5],Axes->True,Frame->False]

ParametricPlot[{Cos[t],Sin[t]Cos[t]}/(1+Sin[t]^2),
{t,-π/2,π/2},PlotStyle->Red,AspectRatio->Automatic]

Parametric

2Area[lemniscate,{t,-π/2,π/2}]

Radial

2Area[a Sqrt[Cos[2θ]],{θ,-π/4,π/4}]

Area[(Sqrt[Cos[2θ]]),{θ,0,2π}]

Cartesian

Integrate[Boole[(x^2+y^2)^2<(x^2-y^2)],{x,-∞,∞},{y,-∞,∞}]

Integrate[Boole[(x^2+y^2)^2<(x^2-y^2)],{y,-∞,∞},{x,-∞,∞}]

N[%]

AreaInertiaTensor

AreaInertiaTensor[(x^2+y^2)^2<(x^2-y^2),{x,y}]//N

AreaInertiaTensor[(x^2+y^2)^2<(x^2-y^2),{y,x}]//N

AreaInertiaTensor[(Sqrt[Cos[2θ]]),{θ,-π/4,π/4}]+AreaInertiaTensor[(Sqrt[Cos[2θ]]),{θ,3π/4,5π/4}]

N[%]

CartesianEquation

Entity["PlaneCurve","Lemniscate"]["CartesianEquation"][c][x,y]

Centroid

Total@{Centroid[(Sqrt[Cos[2θ]]),{θ,-π/4,π/4}],Centroid[(Sqrt[Cos[2θ]]),{θ,3π/4,5π/4}]}

Centroid[(x^2+y^2)^2<(x^2-y^2),{x,y}]//Timing

N[%2]//Chop

Centroid[(x^2+y^2)^2<(x^2-y^2),{y,x}]//Timing

N[%3]//Chop

Curvature

Parametric

FullSimplify[Curvature[lemniscate,t],a>0&&0<t<2π]

Plot[((3 (Sqrt[2]) Cos[t])/(Sqrt[3-Cos[2 t]])),{t,-π,π}]

Polar

FullSimplify[Curvature[a Sqrt[Cos[2 q]],q],a>0&&0<q<2π]

Refine[%,a>0]

Implicit

SortBy[FullSimplify[Curvature[eqn,{x,y}],a>0&&(x|y)∈Reals],ByteCount]

Differential Equation

xy=a^2 x^2-x^4-a^2 y[x]^2-2 x^2 y[x]^2-y[x]^4

eqs=Table[D[xy,{x,i}],{i,0,3}];

gb=SortBy[Factor/@GroebnerBasis[eqs,{x,y[x],y'[x],y''[x],y'''[x]},{a},MonomialOrder->EliminationOrder],ByteCount]

Length[gb]

Height

leqn=Entity["PlaneCurve","Lemniscate"]["AlgebraicEquation"][a][x,y]

Assuming[a>0,Simplify@MaxValue[{y,leqn==0},{x,y}]]

Inflection Points

InflectionPoints[eqn,{x,y}]

InflectionPoints[lemniscate,t]

ParametricEquations

Entity["PlaneCurve","Lemniscate"]["ParametricEquations"][c][t]

PolarEquation

Entity["PlaneCurve","Lemniscate"]["PolarEquation"][c][r]

cart=Entity["PlaneCurve","Lemniscate"]["CartesianEquation"][c][x,y]

FullSimplify[cart/.{x->r Cos[θ],y->r Sin[θ]},r>0]

Singular Points

SingularPoints[eqn,{x,y}]

Slope

Slope[a{Cos[t],Sin[t] Cos[t]}/(1+Sin[t]^2),t]//FullSimplify

Slope[a Sqrt[Cos[2 q]],q]//FullSimplify

Slope[a^2 x^2-x^4-a^2 y^2-2 x^2 y^2-y^4==0,{x,y}]//FullSimplify

SpecialAffineCurvature

FullSimplify[SpecialAffineCurvature[lemniscate,t],a>0&&0<t<2π]

Tangential Angle

v5

TangentialAngle[lemniscate,t,Assumptions->t>0]

v6

TangentialAngle[lemniscate,t,Assumptions->t>0]

Width

leqn=Entity["PlaneCurve","Lemniscate"]["AlgebraicEquation"][a][x,y]

Assuming[a>0,Simplify@MaxValue[{x,leqn==0},{x,y}]]

Lemniscate by Envelope

ParametricPlot[
{
{t,Sqrt[t^2-1]},
{-t,Sqrt[t^2-1]},
{t,-Sqrt[t^2-1]},
{-t,-Sqrt[t^2-1]}
},
{t,1,3},
AspectRatio->Automatic,Ticks->None,
PlotRange->{{-3,3},{-2,2}},
Epilog->Table[{
Circle[{t,Sqrt[t^2-1]},Sqrt[2t^2-1]],
Circle[{-t,Sqrt[t^2-1]},Sqrt[2t^2-1]],Circle[{t,-Sqrt[t^2-1]},Sqrt[2t^2-1]],Circle[{-t,-Sqrt[t^2-1]},Sqrt[2t^2-1]]},
{t,1,2,.1}]]

Vector Properties

parm=a {Cos[t],Sin[t] Cos[t]}/(1+Sin[t]^2);
assum=a>0&&0<t<2π;
xform={Abs[x_]^(n_/;Mod[n,2]==0):>x^n};

VectorLength

Assuming[assum,FullSimplify[Norm[parm]/.xform]]

NormalVector

Assuming[assum,FullSimplify[NormalVector[parm,t]/.xform]]

TangentVector

Assuming[assum,FullSimplify[TangentVector[parm,t]/.xform]]