# How to draw a curve projection?

I want to draw the following projection picture for the cuspidal cubic curve in Mathematica. Does anybody know how to do this?

• ContourPlot[y^2 == x^3, {x, -2, 2}, {y, -2, 2}] Commented Mar 27 at 10:12
• Thank you, but I want to add the projection part(down arrow and the bottom line) as well. Your answer only gives the curve part. Commented Mar 27 at 10:20
• What information can you get from the bottom line? As I see it, it provides no information about the function. Commented Mar 27 at 11:02
• @azerbajdzan It denotes the projection onto x-axis, and the dashed line is the singilarity of the function at the origin. That's why I would like to keep them. Commented Mar 27 at 11:07
• I see no projection. I see line from left to right without any difference between region on the left of the zero and right of the zero. Commented Mar 27 at 11:20

Mainly because I wanted to figure out the Bezier curve, having just given another Bezier answer. After doing it, I thought, Why not share?, even though this sort of plain Graphics is what I learned to do back around 1990 and was still doing when I found this community. Others may benefit from looking up Text[] for any annotations to be added (be sure to check out MaTeX  too) as well as styling directives like Thickness and colors.

Block[{t = 0.9, x, y, pts},
x = t^2; y = t^3;
pts = {{x, -y}, {-1/3 x, y}, {-1/3 x, -y}, {x, y}};
Graphics[{
White, EdgeForm[Black], Rectangle[-{x, x}, {x, x}]
, Black, BezierCurve[pts]
, {Dashed, Black, Line[{{0, x}, {0, -1.6 x}}]}
, {Black, Line[{{-x, -1.6 x}, {t^2, -1.6 x}}],
Line[{{0, -1.56 x}, {0, -1.64 x}}],
Arrow[{{0.1 x, -1.1 x}, {0.1 x, -1.5 x}}]}
}]
]


Note: On my Front End, there seems to be a bug ("14.0.0 for Mac OS X ARM (64-bit) (December 13, 2023)"). Depending on the image size of the graph, the cusp is sometimes not rendered. The export seems to work, though.

fu = y^2 == x^3;
xrange = {-2, 2};
lines = Select[
FunctionDomain[SolveValues[fu, y], x] /.
Inequality | GreaterEqual | LessEqual | Greater | Less | Or ->
List // Flatten, NumericQ];

GraphicsColumn[{ContourPlot[
Evaluate@fu, {x, Splice@xrange}, {y, -3, 3},
Epilog -> {Dashed, InfiniteLine[{{#, 0}, {#, 1}}] & /@ lines},
FrameLabel -> {{"", ""}, {"", fu}}],
Graphics[{ColorData[97, 1], AbsoluteThickness[1.6],
MeshPrimitives[
Region[ImplicitRegion[
LogicalExpand[
FunctionDomain[SolveValues[#, y], x] && y == 0.05], {x,
y}], PlotRange -> {xrange, {-0.1, 0.1}}] //
DiscretizeRegion, 1]}, PlotRange -> {xrange, {-0.1, 0.1}},
Axes -> {True, False}]}] &@fu


• Thank you very much, I see you have added more examples which is great! Commented Mar 27 at 15:58