Burnside Curve

Author

Eric W. Weisstein
February 16, 2012

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

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

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

Definition

eqn=y^2-x(x^4-1);

Equation

AlgebraicDegree[eqn,{x,y}]

Expand[eqn]

y/.FullSimplify[Solve[y^2-x(x^4-1)==0,y],x∈Reals]

Plot

V5

<<Graphics`ImplicitPlot`

ImplicitPlot[y^2==x(x^4-1),{x,-2,1.3},PlotStyle->Red]

V6

ContourPlot[eqn==0,{x,-1.05,1.5},{y,-2,2},ContourStyle->Red,Axes->True,Frame->False]

Properties

Area

RegionPlot[eqn<0,{x,-2,2},{y,-1.5,1.5}]

Integrate[Boole[eqn<0],{x,-∞,0},{y,-∞,∞}]//Timing

<<Utilities`Simplify`

GammaSimplify[(((Sqrt[π]) Gamma[(3/8)])/(4 Gamma[(15/8)]))]

FunctionExpand[%]

Implicit Curvature

FullSimplify[ImplicitCurvature[eqn,{x,y}],(x|y)∈Reals]

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

ByteCount/@%

Factor[%%]

Inflection Points

InflectionPoints[eqn,{x,y}]

pts=RootReduce[%]

ContourPlot[eqn==0,{x,-2,2},{y,-2,2},Epilog->{Point[pts]}]

Singular Points

SingularPoints[eqn,{x,y}]

Slope

Slope[y^2==x (x^4-1),{x,y}]//FullSimplify

Slope[y^2==x (x^4-1),{x,y}]//FullSimplify

Uniformization

x[0]:=0
y[0]:=0
x[τ_?NumericQ]:=Module[{g,w2},
g=WeierstrassInvariants[{2,2τ}];
w2=WeierstrassP[2,g];
(WeierstrassP[1,g]-w2)/(WeierstrassP[τ,g]-w2)
]
y[τ_?NumericQ]:=Module[{g,pt,p2t,pht},
g=WeierstrassInvariants[{2,2τ}];
pt=WeierstrassP[τ,g];
p2t=WeierstrassP[2τ,g];
pht=WeierstrassP[τ/2,g];
ph=WeierstrassP[1/2,g];
p2tplus1=WeierstrassP[2τ+1,g];
p1=WeierstrassP[1,g];
4I(pt-p2t)(pht-pt)(pht-WeierstrassP[τ+2,g])(ph-p2tplus1)(ph-p1)/(pht-p1)/(pht-p2tplus1)/WeierstrassPPrime[1/2,g]/WeierstrassPPrime[τ,g]
]

Show[{
ParametricPlot[{x[I τ],y[I τ]},{τ,-5,5},PlotRange->{{-1,1},{-1,1}},
AspectRatio->Automatic,
PlotStyle->Thickness[.01],DisplayFunction->Identity],
ImplicitPlot[y^2==x(x^4-1),{x,-2,1.3},
PlotStyle->{Dashing[{.02}],Thickness[.01],Red},DisplayFunction->Identity]
},DisplayFunction->$DisplayFunction]

Plot[{x[I τ],y[I τ]},{τ,-.1,.1},PlotStyle->{Red,Blue}]

Plot[{x[I τ],y[I τ]},{τ,0,.1},PlotStyle->{Red,Blue}]

Timing[xs=Table[{τ,N[x[I τ],25]},{τ,-10,10,1/10}];]

Timing[ys=Table[{τ,N[y[I τ],100]},{τ,-10,10,1/10}];]

Show[GraphicsArray[{
Show[
ListPlot[#[[1]],PlotJoined->True,PlotStyle->#[[2]],DisplayFunction->Identity]&/@{{xs,Red},{ys,Blue}},AxesLabel->TraditionalForm/@{t,{x[t],y[t]}}],
ListPlot[Transpose[{Last/@xs,Last/@ys}],DisplayFunction->Identity,PlotJoined->True,PlotStyle->Red,PlotRange->All,
AxesLabel->TraditionalForm/@{x,y},
AspectRatio->Automatic]
}],GraphicsSpacing->-.2]

Incorrect Parameterization

x2[0]:=0
x2[τ_]:=-EllipticTheta[3,0,Exp[Pi I τ/2]]/EllipticTheta[4,0,Exp[Pi I  τ/2]]
y2[τ_]:=I EllipticTheta[3,0,Exp[Pi I τ/2]]^(1/2)EllipticTheta[2,0,Exp[Pi I τ/2]]^2/EllipticTheta[4,0,Exp[Pi I  τ/2]]^(5/2)

Timing[xs=Table[{τ,N[x2[I Abs[τ]],20]},{τ,0,6,1/5}];]

Timing[ys=Table[{τ,N[y2[I τ],50]},{τ,0,6,1/5}];]

Show[GraphicsArray[{
Show[
ListPlot[#[[1]],PlotJoined->True,PlotStyle->#[[2]],DisplayFunction->Identity]&/@{{xs,Red},{ys,Blue}},AxesLabel->TraditionalForm/@{τ,{x[τ],y[τ]}}],
ListPlot[Transpose[{Last/@xs,Last/@ys}],DisplayFunction->Identity,PlotJoined->True,PlotStyle->Red,PlotRange->{{-2,0},Automatic},
AxesLabel->TraditionalForm/@{x,y},
AspectRatio->Automatic]
}],GraphicsSpacing->-.2]

Plot[Re[y[t I]/y2[t I]],{t,-2,2}]