Final Examples

We look at the curve f=((((x^2)+(y^2)))^2)-4(x^3)(y^2) from the introduction to answer the second “Looking Ahead” exercise from Chapter 1, showing possible answers as well as describing Newton Hyperbola 336941. As usual, if you are reading this as a notebook, initialize the global functions notebook (Appendix 2).

10.1 Curve from the Introduction

f= (x^2+y^2)^2-4x^3y^2;
ContourPlot[f==0,{x,-5,5},{y,-5,5}]

This doesn’t look quite right for a (5^th) degree curve; something must be missing.

cp=criticalPoints[f,x,y]

The last one is the origin {0,0}, but there is nothing on the plot near {0,0}, even though {0,0} is an obvious solution of f=0. It might be an isolated singular point. We can see that the minimum form at the point {0,0} (see Section 3.4) is ((((x^2)+ (y^2)))^2). This clearly has its only real zero at {0,0}, confirming the isolated singular point.

infiniteRealPoints[f,x,y]

We find the usual suspects, { 0,1,0},{1,0,0}, but a curve of degree 5 should have an odd number of infinite points counted by multiplicity.

P1=inspectInfPoint[f,{0,-1,0},.5,x,y, output->"plot"];
P2=inspectInfPoint[f,{1,0,0},.5,x,y,output->"plot"];
Row[{P1,P2}]

Both appear to intersect the infinite line in multiple points.

g1=FLT[f, ip2z[{0,-1,0},x,y],x,y]

g2=FLT[f, ip2z[{1,0,0},x,y],x,y]

intersectionMultiplicity[g1, y,{0,0}, 1.*^-10]

intersectionMultiplicity[g2,y,{0,0}, 1.*^-10]

ap1=inspectInfPoint[f,{0,1,0},.5, x,y,output->"data"][[4]];
ap2=inspectInfPoint[f,{1,0,0},.5, x,y,output->"data"][[4]];
cp=criticalPoints[f,x,y];
pp=Join[ap1,ap2,cp]

ContourPlot[f==0,{x,-25,25},{y,-25,25},Epilog->{PointSize[Medium],Red,Point[pp]}]

The plot above shows that we have now accounted for all real components and infinite behaviour. We see that, topologically, this real curve consists of an isolated zero and one pseudo-line intersecting the infinite line in five (counting multiplicity) points. The whole pseudo-line is best seen in hemisphere and the Möbius band model of the projective plane. As in Chapter 8, the dashed line is the infinite line for the Möbius band model. I leave the work for these plots to the reader using the methods of Chapter 8.

10.2 Curve from Chapter 1: Looking Ahead

The question was to describe the possibilities of completing the picture below in the real projective plane in general and describe this curve in particular.

f=newtonHyperbola[336941,x,y]

ContourPlot[f==0, {x,-20,20},{y,-20,20},PlotLabel->"Plot 1"]

infiniteRealPoints[f,x,y];
axisPoints[f,x,y];

ip={{-0.0013663242136289378`,0.9999990665786359`,0.`},{0.00944405923828806`,0.9999554038781449`,0.`},{0.7070975075941625`,0.7071160546573124`,0.`},{0.9999829255065721`,0.005843688502762102`,0.`},{0.9999975620703512`,0.002208133454830325`,0.`}};
ap={{466.3649461309457`,0.`},{127.38865636036184`,0.`},{24.999999999999883`,0.`},{4.906245327150322`,0.`},{1.340152181644999`,0.`},{0.`,-435.36783116589487`},{0.`,-210.22357587125362`},{0.`,-2.9730252537553894`},{0.`,-1.4355677090938972`},{0.`,24.999999999992397`}};

K={"A","B","C","D","E"};
ipAss=Association[Table[K[[i]]->ip[[i]],{i,5}]];
apAss=Association[Table[i->ap[[i]],{i,10}]];

Row[{Labeled[Show[RegionPlot[f>0,{x,-20,20},{y,-20,20},Axes->True],
Graphics[{Black,PointSize[Medium],Point[Values[apAss]],Text[4,apAss[4]+{0,2}],Text[5,apAss[5]+{1,2}],Text[9,apAss[9]+{-1,1}],Text[8,apAss[8]+{2,0}],Text["3 →",{18,1}],Text["↑10",{3,18}]}],ImageSize->200],"Plot 1"],Labeled[Show[viroDiagram[f,x,y],Graphics[{Black,Text["A",{-.5,4.8}],Text["B",{1.8,3.5}],Text["C",{2.8,2.5}],Text["D",{3.5,1.8}] ,Text["E",{4.5,.8}],Text["A",{.8,-4.5}],Text["B",{-1.5,-3.8}],Text["C",{-2.5,-2.8}],Text["D",{-3.8,-1.5}] ,Text["E",{-4.8,-.5}]  }],
ListPlot[{Labeled[{4.5,0},1],Labeled[{3.5,0},2],Labeled[{2.5,0},3],Labeled[{1.5,0},4],Labeled[{.5,0},5],Labeled[{0,-4.3},6],Labeled[{0,-3.5},7],Labeled[{0,-1.5},8],Labeled[{0,-.5},9],Labeled[{0,2.5},10]}],ImageSize->300],"Diagram 1"]}]
ipAss
apAss

From the plot, Viro diagram and ip, ap, we can conclude that all infinite and axis points of the Viro diagram exist and the two smallest axis points on each x, y axis are in the plot. The finite component of the plot requires a finite component of the Viro diagram. In addition, the behavior between x-axis zeros 5 and 4 and y-axis zeros 8 and 9 is clear from the previous contour plot.

VD0=viroDiagram[f,x,y];
VD1=Show[VD0,pickCyan[0,-2],pickCyan[0,-1],pickCyan[-2,2],label13[1,3,"B"], label24[0,4,"A"],label13[2,2,"C"],label13[3,1,"D"],label13[4,0,"E"]]

bn={{0},{1}};
Do[bn=Join[Table[Prepend[b,0],{b,bn}],Table[Prepend[b,1],{b,bn}]],{3}];
bn

The output from the next set of code has been turned off. The output from a previous run is shown. Attempting to properly format the output may cause your computer to crash. You can turn it back on by clicking the pull-down menu Cell and selecting Cell Properties ▶ Evaluatable.

Grid[Partition[Table[
Labeled[Show[VD1, If[b[[1]]==0,pickCyan[0,2],pickMagenta[0,2]],If[b[[2]]==0,pickCyan[3,-1],pickMagenta[3,-1]],If[b[[3]]==0,pickCyan[-3,-2],pickMagenta[-3,-2]],
If[b[[4]]==0,pickCyan[-2,-2],pickMagenta[-2,-2]]],
b[[1]]*8+b[[2]]*4+b[[3]]*2+b[[4]]+1],{b,bn}],4]]

These diagrams are all plausible Gauss diagrams for curves matching matching Plot 1 above, but only one of them is actually a Newton hyperbola. Thus, some would also give additional matching curves by eliminating some components or complementary regions. The odd-numbered diagrams do not look like they would give a plot that matches Plot 1 above.

h =-0.6592249684891619`+0.41984463252599646` x-0.05847170393474383` (x^2)+0.0014434473234573883` (x^3)-2.035408876021089`*^-6 (x^4)+2.082939155942196`*^-6 (x^5)-0.5360674151589624` y+0.2942113284492145` x y+0.04358844913164157` (x^2) y+0.0014576493787909805` (x^3) y-7.3709388570770925`*^-6 (x^4) y-0.09483961076768323` (y^2)+0.029932148016941676` x (y^2)+0.03308059628336358` (x^2) (y^2)+0.0011093870567532476` (x^3) (y^2)+0.006657032213909227` (y^3)-0.003967318460561958` x (y^3)-0.0007508723272270821` (x^2) (y^3)+0.0021069757230963533` (y^4)+0.0005191436199134571` x (y^4)+0.00002969169103381663` (y^5);

{Show[RegionPlot[-20<x<20 &&-20<y<20,{x,-40,40},{y,-40,40},PlotStyle->LightYellow],ContourPlot[h==0,{x,-40,40},{y,-40,40}, ContourStyle->Black]],viroDiagram[h,x,y]}

The radius 20 region (in yellow) would not look exactly the same as Plot 1 because the finite component merges with the the component in the first quadrant. In other words, the ambiguous square at {-2,-2} would be magenta rather than cyan. Otherwise, this curve would be similar to the curve in Plot 1 inside radius 20. An analysis (such as in Chapter 9) would give a Gauss diagram. Unlike a Newton hyperbola, there is only one infinite point and only three axis points on each axis.

hass=viroAssociation[h,x,y];
AssociateTo[hass, {{1,3}->0,{2,3}->0,{-2,-2}->0,{-2,-3}->1,{0,-1}->1,{5,0}->0,{4,0}->0,{-1,-1}->0,{0,-1}->0,{0,-2}->0,{-1,-2}->1,{0,-3}->0,{-1,-3}->0,{4,1}->0,{-3,-1}->1,{-4,-1}->1}];
DDH=dDiagram[hass];
GDH=Show[DDH,pickMagenta[-2,2],pickCyan[0,-1],pickMagenta[-2,-2],pickCyan[-2,-3]]

To finish the diagram, we need to specify the last four ambiguous cells. The easiest way to do this is by inspecting the infinite points.

As is often the case with Newton hyperbolas, the infinite points are near {0,1,0}, {1,0,0} and {1,1,0}, so we can inspect these points even though they are not on the curve.

inspectInfPoint[f,{0,1,0},.3,x,y,output->"plot"]

inspectInfPoint[f,{1,0,0},.5,x,y,output->"plot"]

We don’t see an infinite point, but our infiniteRealPoints function did give us two points near there. The problem is that RegionPlot is not good at finding small regions.

inspectInfPoint[f,{1,0,0},.015,x,y,output->"plot"]

We now see these infinite points, but the component is far away.

inspectInfPoint[f,{1,0,0},.015,x,y,output->"data"][[4]]

inspectInfPoint[f,{1,1,0},1,x,y,output->"plot"]

ins1=SortBy[inspectInfPoint[f,{0,1,0},.5,x,y,output->"data"][[4]],Norm]

ins2=SortBy[inspectInfPoint[f,{1,0,0},.5,x,y,output->"data"][[4]],Norm]

ins3=SortBy[inspectInfPoint[f,{1,1,0},1,x,y,output->"data"][[4]],Norm]

J=Join[ins1,ins2,ins3];
allpts=<| Table[i->J[[i]], {i,Length[J]}] |>

Where points 1–6 are in the region near {0,1,0}, 7–12 are near {1,0,0}, and {13–15} are near {1,1,0}.

Thus we have three components: the finite one in the third quadrant with points 10, 11, 5, and 4 above; the large component coming from {1,1,0} at point 15 then 6 that goes to {0,1,0} and down to point 1; and then the jog 7 out and back to 8 down to 16 that heads straight to {1,1,0}.

Show[ContourPlot[f==0,{x,-45,45},{y,-40,40}], ListPlot[Table[Labeled[allpts[i],i],{i,Length[J]}]],Graphics[{Text["B",{2.3,39}],Text["A",{-2,39}],Text["C",{18,39.9}],Text["A",{2.3,-39}],Text["B",{-3,-39}],Text["C",{-44,-20}]}],ImageSize->Large]

Row[{Show[dDiagram[dvAssoc[coefficientSigns[f,{x,y}]]],pickCyan[0,-2],pickCyan[0,-1],pickCyan[-2,2], pickCyan[0,2],pickCyan[3,-1], pickMagenta[-3,-2],pickMagenta[-2,-2], Graphics[{Black,Text[6,{.9,3.7}],Text[16,{2.5,2.2}],Text[1,{0.7,1.7}],Text[7,{2,.7}],Text[9,{2,-1.7}],Text[15,{-2.2,-2.2}],Text[3,{-1.3,-2.2}], Text[2,{.7,-2.2}],Text[4,{-1.2,1.5}],Text[10,{-2,.1}],Text[11,{-2.8,1.5}],Text[0,{4,-.7}],    Text["A",{-.5,4.8}],Text["B",{1.8,3.5}],Text["C",{2.8,2.5}],Text["D",{3.5,1.8}] ,Text["E",{4.5,.8}],Text["A",{.8,-4.5}],Text["B",{-1.5,-3.8}],Text["C",{-2.5,-2.8}],Text["D",{-3.8,-1.5}] ,Text["E",{-4.8,-.5}]     }], ImageSize->Medium],Graph[{"A"->1, 1->7,7->9,9->15,15->"C","C"->16,16->6, 6->"B","B"->"A", 4->10,10->11,11->4,0->"D","D"->"E","E"->0},VertexLabels->"Name"]}]

The numbered points are the relative positions of a few of the numbered points in the previous plot. Point 0 refers to the point at approximately {137,-.2} on the distant component through infinite points D, E.

Show[RegionPlot[-20<x<20&&-20<y<20, {x,-60,60},{y,-60,60},PlotStyle->LightYellow, PlotLabel->"Newton Hyperbola 336941"],ContourPlot[f==0,{x,-60,60},{y,-60,60}],ListLinePlot[{{{24,0},{55,0},{24,-1}},{{-60,-7},{-50,-4},{-60,-1}},{{60,10},{50,7},{60,4}} },   PlotStyle->Dashed],
ListPlot[{Labeled[{1,-60},"A",Right], Labeled[{-2,-60},"B",Left],Labeled[{-59.5,-34},"C",Bottom], Labeled[{-60,-7},"D",Bottom],Labeled[{-50,-4},"b",Right], Labeled[{48,7},"a",Left],Labeled[{-60,-1},"E",Top], Labeled[{60,10},"D",Top],Labeled[{60,4},"E",Bottom],Labeled[{-1,60},"A",Left], Labeled[{2,60},"B",Right],Labeled[{35,60},"C",Right] }],ImageSize->400 ]

We have answered the second problem posed in Chapter 1 that asked for the various ways to complete the plot in the yellow square. Such a finite plot does not give complete information even though theoretically, interpolating on 20 random enough points, there would be enough to reconstruct the equation. The diamond diagrams given showed hypothetical ways a plot like this could be completed, but it should be noted that discovery of the final graph and plot did not depend on those diagrams, only on analyzing the contour plots near the origin and the infinite points. We did not need path tracing or even calculation of the critical points, but using the projective plane and FLT to go back and forward from the affine curve to the curve near infinite points was crucial.

10.3 Conclusion

In the course of this book, we have learned several ways to analyze and represent plane algebraic real curves. In the course of this journey, we have also learned some of the basic properties of these curves, which have classically been developed using algebraic techniques.

Perhaps the most important thing we have learned is that analyzing and plotting a projective plane curve is a finite problem. As I quoted F. S. Macualay (1916) in my introduction, merely proving a problem is finite is not sufficient if the number of operations is too numerous to be carried out in practice. Even 20 years ago, this would have been the case, but working with actual code, we have seen that, at least in our limited examples up to degree 6, that now, especially with the powerful Wolfram Language, that this is in fact feasible.

Of course, this book is only a first look at these methods and there is still a lot of work to be done automating my techniques and using them with curves of much higher degree. If nothing else comes of this book, I hope it can motivate such work in the future.