Butterfly Curve

Author

Eric W. Weisstein
March 12, 2012

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

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

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

Additional Authors

Fay curve from Margherita Barile
April 25, 2002

Cundy and Rollett

Degree

eqn=y^6-(x^2-x^6);

Expand[eqn]

AlgebraicDegree[y^6==x^2-x^6,{x,y}]

Plots

V5

Plot[{-(x^2-x^6)^(1/6),(x^2-x^6)^(1/6)},{x,-1,1},Ticks->None,
PlotStyle->Red,
PlotRange->All,
AspectRatio->Automatic]

ImplicitPlot[y^6==x^2-x^6,{x,-1.01,1.01},Ticks->None,
PlotPoints->200,
PlotStyle->Red,
PlotRange->All,
AspectRatio->Automatic]

ParametricPlot[{{x,-(x^2-x^6)^(1/6)},{x,(x^2-x^6)^(1/6)}},{x,-1,1},
Ticks->None,
PlotRange->All,
PlotStyle->Red,
AspectRatio->Automatic]

ParametricPlot[{x,(x^2-x^6)^(1/6)},{x,-1,1},
PlotRange->All,
PlotStyle->Red,
AspectRatio->Automatic]

ImplicitPlot[y^6==x^2-x^6,{x,-1.01,1.01},{y,-1.01,1.01},Ticks->None,
PlotPoints->200,PlotRange->All,
PlotStyle->Red,
AspectRatio->Automatic]

V6

ContourPlot[eqn==0,{x,-1,1},{y,-.9,.9},Ticks->None,
ContourStyle->Red,
AspectRatio->Automatic,MaxRecursion->3]

Plot[{-(x^2-x^6)^(1/6),(x^2-x^6)^(1/6)},{x,-1.00,1.00},Filling->{1->{2}}]

Plot[{-(x^2-x^6)^(1/6),(x^2-x^6)^(1/6)},{x,-1,1},Filling->{1->{2}},Method->{"BoundaryOffset"->False}]

Manipulate[ContourPlot[y^6==a^4x^2-x^6,{x,-5,5},{y,-5,5},AspectRatio->Automatic],{{a,1},.1,5}]

Area

<<Graphics`InequalityGraphics`

InequalityPlot[y^6<x^2-x^6,{x,-∞,∞},{y,-∞,∞}]

Integrate[Boole[y^6<x^2-x^6],{x,-∞,∞},{y,-∞,∞}]//Timing

NIntegrate[Boole[y^6<x^2-x^6],{x,-∞,∞},{y,-∞,∞}]//Timing

<<Utilities`Simplify`

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

GammaSimplify[%]

N[%,20]

4NIntegrate[((((x^2)-(x^6)))^(1/6)),{x,0,1}]

V8

Integrate[Boole[y^6<x^2-x^6],{x,-∞,∞},{y,-∞,∞}]

FullSimplify[%]

FullSimplify[(-Root[-(x^2)+(x^6)+((#1)^6)&,1]+Root[-(x^2)+(x^6)+((#1)^6)&,2]),x>0]

Plot[(-Root[-(x^2)+(x^6)+((#1)^6)&,1]+Root[-(x^2)+(x^6)+((#1)^6)&,2]),{x,-1,1}]

Integrate[Boole[y^6<x^2-x^6],{y,-∞,∞},{x,-∞,∞}]//Timing

Arc Length

(sx=ArcLength[{x,(x^2-x^6)^(1/6)},x])//Timing

4NIntegrate[(Sqrt[1+D[(x^2-x^6)^(1/6),x]^2]),{x,0,1},WorkingPrecision->20]

(s=4Integrate[(Sqrt[1+D[(x^2-x^6)^(1/6),x]^2]),{x,0,1}])//Timing

FullSimplify[(Sqrt[1+((((2 x-6 (x^5)))^2)/(36 ((((x^2)-(x^6)))^(5/3))))]),0<x<1]

Plot[Sqrt[1+(2*x-6*x^5)^2/(36*(x^2-x^6)^(5/3))],{x,0,1},PlotStyle->Red]

Numerical y

NIntegrate[(1/(z^(5/4)))(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))]),{z,1,∞}]

NIntegrate[(1/(z^(5/4)))(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))]),{z,1,∞},WorkingPrecision->20]

NIntegrate[(1/(z^(5/4)))(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))]),{z,1,∞},WorkingPrecision->20,Method->"GaussKronrod"]

NIntegrate[(1/(z^(5/4)))(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))]),{z,1,∞},WorkingPrecision->20,Method->"GlobalAdaptive"]

NIntegrate[(1/(z^(5/4)))(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))]),{z,1,∞},WorkingPrecision->20,Method->"DoubleExponential"]

Numerical x

4*NIntegrate[Sqrt[1+(x/3-x^5)^2/(x^2-x^6)^(5/3)],{x,0,1}]

4*NIntegrate[Sqrt[1+(x/3-x^5)^2/(x^2-x^6)^(5/3)],{x,0,1},WorkingPrecision->20]

4*NIntegrate[Sqrt[1+(x/3-x^5)^2/(x^2-x^6)^(5/3)],{x,0,1},WorkingPrecision->20,Method->"GaussKronrod"]

4*NIntegrate[Sqrt[1+(x/3-x^5)^2/(x^2-x^6)^(5/3)],{x,0,1},WorkingPrecision->20,Method->"GlobalAdaptive"]

4*NIntegrate[Sqrt[1+(x/3-x^5)^2/(x^2-x^6)^(5/3)],{x,0,1},WorkingPrecision->20,Method->"LocalAdaptive"]

4*NIntegrate[Sqrt[1+(x/3-x^5)^2/(x^2-x^6)^(5/3)],{x,0,1},WorkingPrecision->20,Method->"DoubleExponential"]

V8

Integrate[(Sqrt[1+((((2 x-6 (x^5)))^2)/(36 ((((x^2)-(x^6)))^(5/3))))]),x]//Timing

Integrate[(Sqrt[1+((((2 x-6 (x^5)))^2)/(36 ((((x^2)-(x^6)))^(5/3))))]),{x,0,1}]//Timing

Transform to y

Simplify[(Sqrt[1+((((2 x-6 (x^5)))^2)/(36 ((((x^2)-(x^6)))^(5/3))))])/.x->1/y,y>0]/.y->(z^(1/4))

FullSimplify[(Sqrt[1+((((2 x-6 (x^5)))^2)/(36 ((((x^2)-(x^6)))^(5/3))))])/.x->1/(z^(1/4)),z>0]

FullSimplify[(1/3) (Sqrt[9+(4/(((-1+z))^(5/3)))-(4/(((-1+z))^(2/3)))+(((-1+z))^(1/3))])-(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))]),z>0]

D[1/y,y]

Plot[(Sqrt[(1+((((-3+(y^4)))^2)/(9 (((-1+(y^4)))^(5/3)))))])(-(1/(y^2))),{y,1,1000}]

4NIntegrate[(Sqrt[(1+((((-3+(y^4)))^2)/(9 (((-1+(y^4)))^(5/3)))))])((1/(y^2))),{y,1,∞}]

FullSimplify[(Sqrt[(1+((((-3+(y^4)))^2)/(9 (((-1+(y^4)))^(5/3)))))])((1/(y^2))),y>1]

Integrate[(1/(y^2))(Sqrt[(1+((((-3+(y^4)))^2)/(9 (((-1+(y^4)))^(5/3)))))]),{y,1,∞}]

Integrate[(1/(y^2))(Sqrt[(1+((((-3+(y^4)))^2)/(9 (((-1+(y^4)))^(5/3)))))]),y]

Transform to z

FullSimplify[(Sqrt[1+((((2 x-6 (x^5)))^2)/(36 ((((x^2)-(x^6)))^(5/3))))])/.x->1/(z^(1/4)),z>0]

FullSimplify[(1/3) (Sqrt[9+(4/(((-1+z))^(5/3)))-(4/(((-1+z))^(2/3)))+(((-1+z))^(1/3))])-(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))]),z>0]

D[1/(z^(1/4)),z]

4NIntegrate[(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))])(1/(4 (z^(5/4)))),{z,1,∞}]

FullSimplify[(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))])(1/(4 (z^(5/4))))]

Integrate[(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))])(1/(4 (z^(5/4)))),z]

Integrate[(1/(z^(5/4)))(Sqrt[1+((((-3+z))^2)/(9 (((-1+z))^(5/3))))]),{z,1,∞}]

GaussKronrodRule

$MessagePrePrint=.
res1=4NIntegrate[Sqrt[1+(2*x-6*x^5)^2/(36*(x^2-x^6)^(5/3))],{x,0,1/2,1},WorkingPrecision->300,PrecisionGoal->50,Method->{GlobalAdaptive,MaxRecursion->3000,MaxNumberOfErrorIncreases->100000}];//Timing
res1

$MessagePrePrint=.
res2=4NIntegrate[Sqrt[1+(2*x-6*x^5)^2/(36*(x^2-x^6)^(5/3))],{x,0,1/2,1},WorkingPrecision->300,PrecisionGoal->60,Method->{GlobalAdaptive,MaxRecursion->3000,MaxNumberOfErrorIncreases->100000}];//Timing
res2

res1-res2

ClenshawCurtisRule PrecisionGoal->50

$MessagePrePrint=.
res2=4NIntegrate[Sqrt[1+(2*x-6*x^5)^2/(36*(x^2-x^6)^(5/3))],{x,0,1/2,1},WorkingPrecision->250,PrecisionGoal->50,Method->{GlobalAdaptive,Method->{ClenshawCurtisRule, Points->40},MaxRecursion->3000,MaxNumberOfErrorIncreases->100000}];//Timing
res2

$MessagePrePrint=.
res1=4NIntegrate[Sqrt[1+(2*x-6*x^5)^2/(36*(x^2-x^6)^(5/3))],{x,0,1/2,1},WorkingPrecision->300,PrecisionGoal->50,Method->{GlobalAdaptive,Method->{ClenshawCurtisRule, Points->50},MaxRecursion->3000,MaxNumberOfErrorIncreases->100000}];//Timing
res1

res1-res2

ClenshawCurtisRule PrecisionGoal->100

$MessagePrePrint=.
res2=4NIntegrate[Sqrt[1+(2*x-6*x^5)^2/(36*(x^2-x^6)^(5/3))],{x,0,1/2,1},WorkingPrecision->600,PrecisionGoal->100,Method->{GlobalAdaptive,Method->{ClenshawCurtisRule, Points->50},MaxRecursion->3000,MaxNumberOfErrorIncreases->100000}];//Timing
res2

$MessagePrePrint=.
res1=4NIntegrate[Sqrt[1+(2*x-6*x^5)^2/(36*(x^2-x^6)^(5/3))],{x,0,1/2,1},WorkingPrecision->600,PrecisionGoal->110,Method->{GlobalAdaptive,Method->{ClenshawCurtisRule, Points->100},MaxRecursion->3000,MaxNumberOfErrorIncreases->100000}];//Timing
res1

res1-res2//N

Subtract the leading terms to get a smooth bounded integrand and integrate the  integrable divergents parts by hand

From: Michael Trott
Date: Wed, 18 Jan 2012 09:39:26 -0600

Both integrands are not good because of the fractional divergents at the end points.

Subtract the leading terms to get a smooth bounded integrand and integrate the integrable divergents parts by hand:

ex=Integrate[1/(3 x^(2/3)) - (2 (-1)^(1/6))/(3 2^(2/3) (x - 1)^(5/6)), {x, 0, 1}]

intCartesian =
 4 (NIntegrate[
     Sqrt[1 + (2 x - 6 x^5)^2/(36 (x^2 - x^6)^(5/3))] -Re[1/(3 x^(2/3)) + (-2 (-1)^(1/6))/(3 2^(2/3) (x - 1)^(5/6))], {x, 0, 1},
     WorkingPrecision -> 200, PrecisionGoal -> 110,
     MaxRecursion -> 100,
     Method -> "GaussKronrod"] + Re[ex])

Transpose[{Take[RealDigits[intCartesian][[1]], 99],
  {9, 0, 1, 7, 3, 5, 6, 9, 8, 5, 6, 5, 4, 6, 9, 7, 6, 9, 1, 8, 6, 0,
   9, 6, 3, 4, 0, 2, 9, 7, 0, 0, 7, 7, 0, 0, 3, 9, 3, 0, 5, 9, 7, 1,
   8, 6, 1, 3, 0, 9, 8, 0, 1, 9, 8, 9, 3, 4, 3, 3, 8, 3, 3, 7, 6, 1,
   7, 1, 5, 4, 4, 6, 8, 0, 2, 0, 3, 4, 6, 9, 4, 5, 5, 7, 2, 9, 6, 9,
   7, 0, 5, 9, 3, 1, 0, 3, 5, 8, 7} }]

Position[%75,{x_,y_}/;x≠y,{1},1]

AreaInertiaTensor

AreaInertiaTensor[y^6<x^2-x^6,{x,y}]

AreaInertiaTensor[y^6<x^2-x^6,{y,x}]

Centroid

Centroid[y^6<x^2-x^6,{x,y}]

Centroid[y^6<x^2-x^6,{y,x}]

Curvature

FullSimplify[Curvature[{x,(x^2-x^6)^(1/6)},x],0<x<1]

Plot[((2 (1+9 (x^4)))/(9 (-1+(x^4)) ((((x^2)-(x^6)))^(5/6)) (((1+((((2 x-6 (x^5)))^2)/(36 ((((x^2)-(x^6)))^(5/3))))))^(3/2)))),{x,0,1},PlotStyle->Red]

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

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

ByteCount/@%

Inflection Points

InflectionPoints[eqn,{x,y}]

Singular Points

SingularPoints[eqn,{x,y}]

Slope

Slope[y^6==x^2-x^6,{x,y}]//FullSimplify

Slope[y^6==x^2-x^6,{x,y}]//FullSimplify

Tangential Angle

TangentialAngle[{x,(x^2-x^6)^(1/6)},x]//Timing

Exponential Trig

curve[t_]:={
Sin[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5),Cos[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5 )
}

FullSimplify[#.#&[curve[t]],t>0]//Timing

curve={Sin[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5),Cos[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5)};

V5

<<Graphics`Graphics`

FullSimplify[E^Cos[t]-2Cos[4t]+Sin[t/12]^5/.t->t-Pi/2,t>0]

PolarPlot[(E^(Sin[t]))-2 Cos[4 t]+((Sin[(1/24) (-π+2 t)])^5),{t,0,21π},PlotStyle->Red,PlotPoints->150]

ParametricPlot[
{
Sin[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5),Cos[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5 )
},
 {t,0, 21Pi},Ticks->None,
PlotPoints->100,AspectRatio->Automatic,
PlotStyle->Red]

V6

ParametricPlot[curve[t], {t,0, 21Pi},Ticks->None,AspectRatio->Automatic,PlotStyle->Red]

Arc Length Function

ArcLength[curve[t],t]

Curvature

FullSimplify[Curvature[curve[t],t],t>0]//Timing

SpecialAffineCurvature

Simplify[SpecialAffineCurvature[curve,t],a>0&&t>0]//Timing

FullSimplify[SpecialAffineCurvature[curve,t],a>0&&t>0]//Timing

Slope

Slope[{Sin[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5),Cos[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5)},t]//FullSimplify

Tangential Angles

TangentialAngle[curve[t],t]//Timing

Vector Properties

parm={Sin[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5),Cos[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5)};
assum=(a|t)∈Reals;
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

Combined Plot

Show[GraphicsArray[{
ImplicitPlot[y^6==x^2-x^6,{x,-1,1},
Ticks->None,
PlotRange->All,
DisplayFunction->Identity,
PlotStyle->Red,
AspectRatio->Automatic],
ParametricPlot[{Sin[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5),Cos[t](E^Cos[t]-2Cos[4t]+Sin[t/12]^5 )}, {t,0, 21Pi},Ticks->None,
PlotPoints->100,
PlotStyle->Red,
DisplayFunction->Identity]
}]]

Cundy and Rollet on left; Fay on right

Export to Illustrator to fix glitches at edges