Keratoid Cusp

Author

Eric W. Weisstein
February 20, 2012

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

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

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

Equation

eqn=y^2-(x^2 y+x^5);

Plot3D

Plot3D[y^2-(x^2 y+x^5),{x,-1,2},{y,-2,2},PlotRange->{-1,1}.1,PlotStyle->Opacity[.2]]

Plot3D[-y^2+x^2 y+x^5,{x,-1,2},{y,-2,2},MeshFunctions->{#3&},Mesh->{{0.}},PlotPoints->50]

Plot

V5

<<Graphics`ImplicitPlot`

ImplicitPlot[y^2==x^2 y+x^5,{x,-1,2},PlotStyle->Red,Ticks->None,AspectRatio->1,PlotRange->{{-.3,.4},{-.05,.07}}]

ImplicitPlot[y^2==x^2 y+x^5,{x,-1,2},{y,-2,2},PlotStyle->Red,Ticks->None,AspectRatio->1]

ContourPlot[y^2-(x^2 y+x^5),{x,-1,2},{y,-2,2},Contours->{0},ContourShading->False,Ticks->None,AspectRatio->1]

V6

<<Graphics`ImplicitPlot`

ImplicitPlot[y^2==x^2 y+x^5,{x,-1,2},PlotStyle->Red,Ticks->None,
AspectRatio->1,PlotRange->{{-.3,.4},{-.05,.07}},ImageSize->Small]

ImplicitPlot[y^2==x^2 y+x^5,{x,-.5,.5},PlotStyle->Blue,Ticks->None,
AspectRatio->Automatic,ImageSize->Small]

soln[x_]:=Module[{y,soln},
soln=Select[y/.NSolve[y^2==x^2 y+x^5,y],Im[#]==0.&];
If[soln==={},{},{x,#}&/@soln]
]

Show[Graphics[{Red,Flatten[Table[soln[x],{x,-1,.5,.01}],1]}],Axes->True]

ContourPlot[y^2==x^2 y+x^5,{x,-1,2},{y,-2,2},ContourStyle->Red,PlotPoints->20]

ContourPlot[x^2 y+x^5-y^2==0,{x,-1,2},{y,-2,2},ContourStyle->Red]

ContourPlot[y^2-(x^2 y+x^5)==0,{x,-1,2},{y,-2,2},ContourStyle->Red]

Tangents

Solving for y

xsoln=y/.Solve[y^2==(x^2 y+x^5),y]

Plot[Evaluate[xsoln],{x,-.3,0},PlotStyle->List/@{Red,Blue}]

Solve[xsoln[[1]]==ssoln[[2]],x]

xsoln[[1]]/.x->-1/4

Solve[D[xsoln[[2]],x]==0,x]

xsoln[[2]]/.x->-6/25

Solving for x

ysoln=x/.Solve[y^2==(x^2 y+x^5),x]

Length[ysoln]

ParametricPlot[Evaluate[{#,y}&/@ysoln],{y,-.1,.1},PlotStyle->List/@{Red,Yellow,Green,Blue,Purple}]

Area

<<Graphics`InequalityGraphics`

InequalityPlot[y^2<x^2 y+x^5,{x,-∞,0},{y,-∞,∞},AspectRatio->Automatic]

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

Properties

eqn=a^3y^2==a^2x^2y+x^5;

Block[{a=1},ContourPlot[Evaluate@eqn,{x,-1,2},{y,-2,2}]]

Note missing loop on negative x-axis.

Arc Length Solving for x

dsx=FullSimplify[(Sqrt[1+D[#,x]^2])&/@xsoln]

NIntegrate[#,{x,-1/4,0}]&/@dsx

Plus@@%

v4.2

Integrate[Plus@@dsx,{x,-1/4,0}]//Timing

v5.1

Integrate[Plus@@dsx,{x,-1/4,0}]//Timing

v6

Integrate[Plus@@dsx,{x,-1/4,0}]//Timing

Arc Length Solving for y

dsy=FullSimplify[(Sqrt[1+D[#,y]^2])&/@Take[ysoln,2]]

NIntegrate[#,{y,0,108/3125}]&/@dsy

Plus@@%

v4.2

Integrate[Plus@@dsy,{x,0,108/3125}]//Timing

v5.1

Integrate[Plus@@dsy,{x,0,108/3125}]//Timing

v6

Integrate[Plus@@dsy,{x,0,108/3125}]//Timing

Implicit Curvature

SortBy[FullSimplify[Curvature[eqn,{x,y}],a>0],ByteCount]

Inflection Points

InflectionPoints[eqn,{x,y}]

<<Graphics`ImplicitPlot`

ImplicitPlot[eqn==0,{x,-.3,.4},Epilog->{Point[{Root[3+39 #1+164 ((#1)^2)+225 ((#1)^3)&,1],Root[-27+2439 #1-72446 ((#1)^2)+759375 ((#1)^3)&,1]}]}]

Singular Points

SingularPoints[eqn,{x,y}]//Union

ImplicitSlope

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

Tangential Angle