Devil's Curve

Author

Eric W. Weisstein
February 17, 2012

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

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

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

Definition

eqn[a_,b_][x_,y_]:=y^4-a^2y^2-(x^4-b^2x^2)

eqn=y^4-a^2y^2-(x^4-b^2x^2);

Equations

Cartesian

AlgebraicDegree[eqn[a,b][x,y],{x,y}]

ContourPlot[eqn[##][x,y]==0,{x,-4,4},{y,-4,4},AspectRatio->Automatic,ContourStyle->Red,PlotPoints->20]&@@@{{1,2},{1,Sqrt[2]},{1,1},{1,1.01},{1,.9},{1,.5}}

Cartesian

<<Graphics`ImplicitPlot`

eqn1=y^4-a^2 y^2-(x^4-b^2 x^2)

eqn2=y^2(y^2-a^2)-x^2(x^2-b^2)

Simplify[eqn1-eqn2]

g1=ImplicitPlot[y^4-y^2==x^4-2x^2,{x,-3,3},Ticks->None,PlotStyle->Red]

g2=Show[
Block[{$DisplayFunction=Identity},
Table[ImplicitPlot[y^4-a^2 y^2==x^4-b^2x^2/.b->1,{x,-3,3},AspectRatio->Automatic,Ticks->None,PlotStyle->Hue[a],
PlotRange->{{-1,1},{-1,1}}1.5
],
{a,.05,1,.05}]]]

Show[GraphicsArray[{g1,g2}],ImageSize->500]

Polar

Take a=1, b=2

FullSimplify[y^4-a^2 y^2-x^4+b^2x^2/.{x->r Cos[θ],y->r Sin[θ]}]

Solve[%==0,r]//FullSimplify

Function[{a,b},PolarPlot[((Sqrt[(a^2)+(b^2)+(-(a^2)+(b^2)) Sec[2 θ]])/(Sqrt[2])),{θ,0,2π},PlotStyle->Red]]@@@{{1,2},{1,Sqrt[2]},{1,1},{1,1.01},{1,.9},{1,.5}}

movie=Table[PolarPlot[((Sqrt[(1^2)+(b^2)+(-(1^2)+(b^2)) Sec[2 θ]])/(Sqrt[2])),{θ,0,2π},PlotStyle->Red,PlotRange->3,Ticks->None],{b,.5,2,.02}];

<<Utilities`GIF`

Export[$GIFDirectory<>"DevilsCurve.gif",movie,"Interlaced"->True,"TransparentColor"->GrayLevel[1],AnimationRepetitions->∞,"DisplayDurations"->0.1]//Timing

ListAnimate[movie]

GraphicsGrid[Partition[Take[movie,{1,-1,5}],5],ImageSize->400,Spacings->200]

Manipulate[PolarPlot[((Sqrt[(1^2)+(b^2)+(-(1^2)+(b^2)) Sec[2 θ]])/(Sqrt[2])),{θ,0,2π},PlotStyle->Red,PlotRange->3,PerformanceGoal->"Quality"],{b,.5,2}]

Function[{a,b},PolarPlot[((Sqrt[(a^2)+(b^2)+(-(a^2)+(b^2)) Sec[2 θ]])/(Sqrt[2])),{θ,0,2π},PlotStyle->Red]]@@@{{1,2},{1,Sqrt[2]},{1,1.01}}

Parametric

With[{a=1,b=Sqrt[2]},Plot[Evaluate[Through[{Re,Im}[((Sqrt[(a^2)+(b^2)+(-(a^2)+(b^2)) Sec[2 t]])/(Sqrt[2]))]]],{t,0,2π}]]

With[{a=1,b=Sqrt[2]},ParametricPlot[((Sqrt[(a^2)+(b^2)+(-(a^2)+(b^2)) Sec[2 t]])/(Sqrt[2])){Cos[t],Sin[t]},{t,0,2π}]]

Cundy and Rollet's Electric Motor

ImplicitPlot[y^2(y^2-96)==x^2(x^2-100),{x,-15,15},Ticks->None,PlotStyle->Red]

Properties

curve=((Sqrt[(a^2)+(b^2)+(-(a^2)+(b^2)) Sec[2 t]])/(Sqrt[2])){Cos[t],Sin[t]};

Curvature

ImplicitCurvature[{y^2(y^2-b^2)-x^2(x^2-a^2),x,y}]

Simplify[Together[Curvature[curve,t]],0<t<2π&&a>0&&b>0]

FullSimplify[%,0<t<2π&&a>0&&b>0]

FullSimplify[(((Sqrt[2]) (((((a^2)+(b^2)))^2)+4 (-(a^4)+(b^4)) Sec[2 t]+4 ((a^4)-(b^4)) ((Sec[2 t])^3)-((((a^2)-(b^2)))^2) ((Sec[2 t])^4)))/( (((((((a^2)+(b^2)))^2)+2 (-(a^4)+(b^4)) Sec[2 t]+((((a^2)-(b^2)))^2) ((Sec[2 t])^4)))^(3/2))))(Sqrt[(a^2)+(b^2)+(-(a^2)+(b^2)) Sec[2 t]]),0<t<2π&&a>0&&b>0]

Area

1./(Sqrt[2])

Block[{a=1,b=1},RegionPlot[y^4-a^2y^2-(x^4-b^2x^2)<0,{x,-2,2},{y,-2,2},Axes->True]]

Block[{a=(Sqrt[2]),b=1},RegionPlot[y^4-a^2y^2-(x^4-b^2x^2)>0,{x,-2,2},{y,-2,2}]]

Implicit Curvature

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

Singular Point

SingularPoints[eqn,{x,y}]

Factor[eqn/.a->1]

Slope

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

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

Tangential Angle

TangentialAngle[curve,t]