Ampersand Curve

Author

Eric W. Weisstein
February 16, 2012

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

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

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

Degree

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

(y^2-x^2)(x-1)(2x-3)-4(x^2+y^2-2x)^2/.{x->x/a,y->y/a}

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

Factor[Expand[Subtract@@eqn]]

AlgebraicDegree[eqn,{x,y}]

With[{a=1},RegionPlot[4 (x^2+y^2-2 a x)^2<(y^2-x^2) (x-a) (2 x-3 a),{x,-2,2},{y,-2,2}]]

With[{a=.4},RegionPlot[4 (x^2+y^2-2 a x)^2<(y^2-x^2) (x-a) (2 x-3 a),{x,-2,2},{y,-2,2}]]

Plot

V5.2

<<Graphics`ImplicitPlot`

ImplicitPlot[(y^2-x^2)(x-1)(2x-3)==4(x^2+y^2-2x)^2,{x,-3,3},
PlotStyle->Red,
Ticks->None,AspectRatio->Automatic]

V6

ContourPlot[(y^2-x^2)(x-1)(2x-3)==4(x^2+y^2-2x)^2,{x,-.2,1.6},{y,-1.2,1.2},
ContourStyle->Red,AspectRatio->Automatic,MaxRecursion->4,ImageSize->150,Axes->True]

Intersections

Show[
Block[{$DisplayFunction=Identity},
{
ImplicitPlot[(y^2-x^2)(x-1)(2x-3)==4(x^2+y^2-2x)^2,{x,1,3},
PlotStyle->Blue,
Ticks->None,AspectRatio->Automatic],
ImplicitPlot[(y^2-x^2)(x-1)(2x-3)==4(x^2+y^2-2x)^2,{x,-3,1},
PlotStyle->Red,
Ticks->None,AspectRatio->Automatic]
}]]

Equations

Cartesian

Solve[(y^2-x^2)(x-1)(2x-3)==4(x^2+y^2-2x)^2,y]//FullSimplify

p1=Plot[((Sqrt[3+(11-6 x) x-(Sqrt[3]) (Sqrt[-(((-1+x))^2) (-3+2 x) (1+10 x)])])/(2 (Sqrt[2]))),{x,-.7,1.5},AspectRatio->Automatic,PlotStyle->Red]

Plot[Im[((Sqrt[3+(11-6 x) x+(Sqrt[3]) (Sqrt[-(((-1+x))^2) (-3+2 x) (1+10 x)])])/(2 (Sqrt[2])))],{x,-.5,2}]

((Sqrt[3+(11-6 x) x+(Sqrt[3]) (Sqrt[-(((-1+x))^2) (-3+2 x) (1+10 x)])])/(2 (Sqrt[2])))/.x->-1/10

((Sqrt[3+(11-6 x) x+(Sqrt[3]) (Sqrt[-(((-1+x))^2) (-3+2 x) (1+10 x)])])/(2 (Sqrt[2])))/.x->3/2

N[%]

p2=Plot[((Sqrt[3+(11-6 x) x+(Sqrt[3]) (Sqrt[-(((-1+x))^2) (-3+2 x) (1+10 x)])])/(2 (Sqrt[2]))),{x,-1/10,1.5},AspectRatio->Automatic,PlotStyle->Blue,PlotRange->All]

Show[{p1,p2},PlotRange->All,Epilog->{PointSize[.02],Point[{{-1/10,((Sqrt[23])/10)},{3/2,((Sqrt[3])/2)}}]}]

Parametric

curve=a FullSimplify[((37 Cos[t]-Abs[Cos[2 t]] (Sqrt[66-126 Cos[2 t]])+5 Cos[3 t])/(2 (9+2 Cos[2 t]+Cos[4 t]))){Cos[t],Sin[t]},0<t<2π]

Polar

Simplify[(y^2 - x^2) (x - 1) (2 x - 3) - 4 (x^2 + y^2 - 2 x)^2/.{x->r Cos[θ],y->r Sin[θ]}]

FullSimplify[-(1/2) (r^2) (16+9 (r^2)-37 r Cos[θ]+2 (11+(r^2)) Cos[2 θ]-5 r Cos[3 θ]+(r^2) Cos[4 θ]),0<θ<2π]

Collect[(16+9 (r^2)-37 r Cos[θ]+2 (11+(r^2)) Cos[2 θ]-5 r Cos[3 θ]+(r^2) Cos[4 θ]),r]//TraditionalForm

FullSimplify[Solve[(16+9 (r^2)-37 r Cos[θ]+2 (11+(r^2)) Cos[2 θ]-5 r Cos[3 θ]+(r^2) Cos[4 θ])==0,r],0<θ<2π]

r1=((37 Cos[θ]-Abs[Cos[2 θ]] (Sqrt[66-126 Cos[2 θ]])+5 Cos[3 θ])/(2 (9+2 Cos[2 θ]+Cos[4 θ])));
r2=((37 Cos[θ]+Abs[Cos[2 θ]] (Sqrt[66-126 Cos[2 θ]])+5 Cos[3 θ])/(2 (9+2 Cos[2 θ]+Cos[4 θ])));

Solve[66-126 Cos[2 θ]==0,θ]

q1=(1/2) ArcCos[(11/21)];

N[%]

{PolarPlot[r1,{θ,0,2π}],PolarPlot[r2,{θ,0,2π}]}

{PolarPlot[r1,{θ,q1,π-q1}],PolarPlot[r2,{θ,q1,π-q1}]}

{PolarPlot[r1,{θ,π+q1,2π-q1}],PolarPlot[r2,{θ,π+q1,2π-q1}]}

{PolarPlot[((37 Cos[θ]-Abs[Cos[2 θ]] (Sqrt[66-126 Cos[2 θ]])+5 Cos[3 θ])/(2 (9+2 Cos[2 θ]+Cos[4 θ]))),{θ,0,π}],
PolarPlot[((37 Cos[θ]+Abs[Cos[2 θ]] (Sqrt[66-126 Cos[2 θ]])+5 Cos[3 θ])/(2 (9+2 Cos[2 θ]+Cos[4 θ]))),{θ,0,π}]}

((37 Cos[θ]-Abs[Cos[2 θ]] (Sqrt[66-126 Cos[2 θ]])+5 Cos[3 θ])/(2 (9+2 Cos[2 θ]+Cos[4 θ])))

Properties

ArcLength

Plot[r1,{θ,0,2π}]

Plot[Evaluate[Through[{Re,Im}[r1]]],{θ,0,2π},WorkingPrecision->20]

r=((37 Cos[θ]+Abs[Cos[2 θ]] (Sqrt[66-126 Cos[2 θ]])+5 Cos[3 θ])/(2 (9+2 Cos[2 θ]+Cos[4 θ])))/.Abs[x_]:>Sqrt[x^2];

D[Sqrt[x^2],x]

ds=Simplify[(Sqrt[r^2+D[r,θ]^2]),0<θ<2π]

Curvature

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

ByteCount/@%

Inflection Points

pts=InflectionPoints[eqn,{x,y}]//Union

Take[pts,-2]

ContourPlot[eqn==0,{x,-.2,1.6},{y,-1.2,1.2},AspectRatio->Automatic,MaxRecursion->5,Epilog->{Point[pts]}]

Singularities

pts=SingularPoints[eqn,{x,y}]

ContourPlot[eqn==0,{x,-.2,1.6},{y,-1.2,1.2},ContourStyle->Red,AspectRatio->Automatic,MaxRecursion->4,Axes->True,Epilog->{PointSize[.04],Point[pts]}]

Slope

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

FullSimplify[Slope[eqn,{x,y}],a>0]//Union

Tangential Angle

TangentialAngle[curve,t,Assumptions->a>0&&t>0]

Solve x(y)

ysoln=x/.Solve[(y^2-x^2)(x-1)(2x-3)==4(x^2+y^2-2x)^2,x]

ParametricPlot[Evaluate[{#,y}&/@soln],{y,-1.3,1.3},PlotStyle->List/@{Red,Yellow,Green,Blue},AspectRatio->Automatic]

Solve y(x)

xsoln=y/.Solve[(y^2-x^2)(x-1)(2x-3)==4(x^2+y^2-2x)^2,y]

Plot[Evaluate[soln],{x,-1,3},PlotStyle->List/@{Red,Yellow,Green,Blue},AspectRatio->Automatic]

Tangents

xs=x/.Solve[soln[[1]]==soln[[3]],x];
Transpose[{xs,soln[[1]]/.x->#&/@xs}]//FullSimplify

pts1={{-(1/10),-((Sqrt[23])/10)},{1,-1},{(3/2),-((Sqrt[3])/2)}};

ContourPlot[eqn==0,{x,-.2,1.6},{y,-1.2,1.2},AspectRatio->Automatic,MaxRecursion->5,Epilog->{Point[pts1]}]

xs=x/.Solve[D[soln[[4]],x]==0,x];
Transpose[{xs,soln[[4]]/.x->#&/@xs}]//FullSimplify

pts2={{(1/2),((Sqrt[5])/2)},{(1/120) (159-(Sqrt[201])),(1/40) (Sqrt[1389+67 (Sqrt[(67/3)])])}};

ContourPlot[eqn==0,{x,-.2,1.6},{y,-1.2,1.2},AspectRatio->Automatic,MaxRecursion->5,Epilog->{Point[pts2]}]

xs=x/.Solve[D[soln[[2]],x]==0,x];
Transpose[{xs,soln[[2]]/.x->#&/@xs}]//FullSimplify

ContourPlot[eqn==0,{x,-.2,1.6},{y,-1.2,1.2},AspectRatio->Automatic,MaxRecursion->5,Epilog->{Point[pts2]}]

Area Implicit

<<Graphics`InequalityGraphics`

InequalityPlot[(y^2-x^2)(x-1)(2x-3)>4(x^2+y^2-2x)^2,{x,-∞,∞},{y,-∞,∞}]

Integrate[Boole[(y^2-x^2)(x-1)(2x-3)>4(x^2+y^2-2x)^2],{x,-∞,∞},{y,-∞,∞}]

Numeric

NIntegrate[Boole[(y^2-x^2)(x-1)(2x-3)>4(x^2+y^2-2x)^2],{x,-∞,∞},{y,-∞,∞}]

NIntegrate[Boole[(y^2-x^2)(x-1)(2x-3)>4(x^2+y^2-2x)^2],{x,-∞,∞},{y,-∞,∞},WorkingPrecision->100]//Timing

Area y(x)

dax1=FullSimplify[xsoln[[1]]-xsoln[[3]]]

Numeric

ax=2NIntegrate[dax1,{x,-1/10,3/2},MaxRecursion->15]

2NIntegrate[dax1,{x,-1/10,3/2},MaxRecursion->15,WorkingPrecision->50]

v4.2

2Integrate[dax1,{x,-1/10,3/2}]//Timing

v5.1

2Integrate[dax1,{x,-1/10,3/2}]//Timing

v6.0

2Integrate[dax1,{x,-1/10,3/2}]//Timing

Area x(y)

Region 1

day1=Simplify[ysoln[[2]]-ysoln[[1]]]

Numeric

ay1=NIntegrate[day1,{y,-((Sqrt[5])/2),0},MaxRecursion->15]

v4.2

Integrate[day1,{y,-((Sqrt[5])/2),0}]//Timing

...hangs...

v5.1

Integrate[day1,{y,-((Sqrt[5])/2),0}]//Timing

...hangs...

v6.0

Integrate[day1,{y,-((Sqrt[5])/2),0}]//Timing

...hangs...

Region 2

day2=Simplify[ysoln[[4]]-ysoln[[3]]]

Numeric

ay2=NIntegrate[day2,{y,(1/40)(Sqrt[1389-67(Sqrt[(67/3)])]),(1/40)(Sqrt[1389+67(Sqrt[(67/3)])])}]

v4.2

Integrate[day2,{y,(1/40)(Sqrt[1389-67(Sqrt[(67/3)])]),(1/40)(Sqrt[1389+67(Sqrt[(67/3)])])}]//Timing

...hangs...

v5.1

Integrate[day2,{y,(1/40)(Sqrt[1389-67(Sqrt[(67/3)])]),(1/40)(Sqrt[1389+67(Sqrt[(67/3)])])}]//Timing

...hangs...

v6.0

Integrate[day2,{y,(1/40)(Sqrt[1389-67(Sqrt[(67/3)])]),(1/40)(Sqrt[1389+67(Sqrt[(67/3)])])}]//Timing

...hangs...

Together

ax

2(ay1+ay2)

Arc Length y(x)

dx1=Simplify[(Sqrt[1+((D[#,x])^2)])&/@xsoln[[{1,3}]]]

FullSimplify[{(Sqrt[1+((((11-12 x+(((Sqrt[3]) (-11+73 x-102 (x^2)+40 (x^3)))/(Sqrt[-(((-1+x))^2) (-3-28 x+20 (x^2))]))))^2)/(32 (3+11 x-6 (x^2)-(Sqrt[3]) (Sqrt[-(((-1+x))^2) (-3-28 x+20 (x^2))]))))]),(1/2) (Sqrt[4+((((22-24 x+(((Sqrt[3]) (22-146 x+204 (x^2)-80 (x^3)))/(Sqrt[-(((-1+x))^2) (-3-28 x+20 (x^2))]))))^2)/(32 (3+11 x-6 (x^2)+(Sqrt[3]) (Sqrt[-(((-1+x))^2) (-3-28 x+20 (x^2))]))))])},-1/10≤x≤3/2]

Numeric

sx=2Plus@@(NIntegrate[#,{x,-1/10,3/2}]&/@dx1)

v4.2

2Plus@@(Integrate[#,{x,-1/10,3/2}]&/@dx1)//Timing

...hangs...

v5.1

2Plus@@(Integrate[#,{x,-1/10,3/2}]&/@dx1)//Timing

v6

2Plus@@(Integrate[#,{x,-1/10,3/2}]&/@dx1)//Timing

Arc Length x(y)

Region 1

dy1=Simplify[(Sqrt[1+((D[#,y])^2)])&/@ysoln[[{1,2}]]]

dy1=(Sqrt[1+((D[#,y])^2)])&/@ysoln[[{1,2}]];

Numeric

sy1=2NIntegrate[#,{y,-((Sqrt[5])/2),0},MaxRecursion->15,WorkingPrecision->10,SingularityDepth->10]&/@dy1;

Region 2