Harnack’s Theorem and Newton Hyperbolas

In this chapter, we give our version of Harnack’s theorem in Section 9.1 and discuss Hilbert’s related (16^th) problem in Section 9.4. In between, we introduce new representations via diamond diagrams of nonsingular numerical curves, suggested by the Newton hyperbolas. These give loops (as in the graphs from Chapters 4 and 5) but also indicate geometric position relative to the three axes (x, y, and z, where the z-axis is the infinite line) in addition to the other loops, so we can better describe our curves relative to the (16^th) problem. In the last section, we give some details on how we constructed the diamond diagrams.

9.1 Harnack’s Theorem

For nonsingular curves, each simple closed path is a topological component, and topological components are pseudo-lines and ovals. But for singular curves (including reducible curves), simple closed paths may intersect at singularities to be part of the same topological component. When we perturb a singular curve to create a nearby nonsingular curve, these simple closed paths may split into separate components or not, but a small random perturbation is very unlikely to undo a previous perturbation and glue topological components together. Special consideration is needed for curves with isolated points or singularities on the infinite line; the latter is easily handled by changing to an FLT equivalent curve without infinite singularities.

f=(x^2+y^2)^2+3x^2y-y^3;
ContourPlot[{f==0,f-.05==0,f+.05==0},{x,-1,1},{y,-.8,1.2}]

We originally had one topological component: having subtracted a small constant (the number of simple closed paths) but leaving still one topological component. Subtracting a small constant splits the curve into three topological components.

We want to put a bound on the number of topological components possible for a curve of degree d. Since random perturbation does not subtract components, it is enough to look at nonsingular curves. We will use three tools from earlier sections of the book:

At the end of Chapter 1, we showed that one can construct a curve of degree d through any affine collection of (((d+2)(d+1))/2)-1 points.

Properties 1, 2, and 3 from Section 8.5.

Bézout’s theorem from Chapter 5.

The following example will be a warm-up. In Chapter 7, we catalog all possible conics and cubics, but we will give a new argument that a nonsingular cubic can have only two topological components.

Suppose a cubic has three topological components: two ovals and one pseudo-line. We pick one point on each oval, say p and q. There is a unique line ℓ through p and q that, by Property 2 (Section 8.5), must meet the pseudo-line at a point r.

ℓ is the orange line. By a trivial application of Bézout’s theorem, a line can only intersect a cubic in three or fewer real points, but this line also intersects the cubic in two other points on the ovals. Therefore, this configuration is impossible for a cubic.

Suppose f=0 is a projective curve of degree d>3, let

Clear[d];
m= (((d-1)(d-2))/2)  + 1;

Suppose the associated projective curve has a simple closed path decomposition with m ovals (Subscript[Ω, 1]),(Subscript[Ω, 2]),...,(Subscript[Ω, m]) and one more simple closed path Γ (which might be an oval if d is even, or pseudo-line if d is odd). In the second case, Γ is certainly infinite. We will assume our curve is not just a collection of isolated points and Γ is an oval (which is not an isolated point and, therefore, infinite in the first case). We pick a random point on each oval (Subscript[Ω, i]) but not a singular point (therefore not on any other (Subscript[Ω, i])).

We now pick ((d(d-1))/2)-1-m random points on Γ; this number is positive since d>3. Again, choosing randomly ensures that these points are not also on any of the (Subscript[Ω, i]).

So we have ((d(d-1))/2)-1 points, and by our global interpolation method from Chapter 1, this is a curve g=0 of degree d-2 through these points. By our construction, f=0 and g=0 cannot share a common component, but by Property 1  (Section 8.5), the total intersection multiplicity of g=0 with each oval (Subscript[Ω, 1]),...,(Subscript[Ω, m]) must be even, so g=0 intersects each of these ovals in at least two points.

Expand[2m+d(d-1)/2-1-m]

Expand[d(d-2)]

We counted at least one more point than we were supposed to have, so our supposition above cannot be true.

This leads to Harnack’s theorem: let f=0 be an algebraic curve of degree d, which is not a union of isolated points. The number of topological connected components of this curve in the real projective plane is less than or equal to (((d-1)(d-2))/2)+1. Moreover, if singular f=0 admits a decomposition into simple closed curves, satisfying Property 3 (Section 8.5), then the number of simple closed curves in this decomposition is also less than or equal to (((d-1)(d-2))/2)+1.

Our argument followed the argument in Bochnak’s book (1998) except—as noted above—we can slightly perturb a singular curve to get our decomposition into ovals, satisfying our properties in Section 8.5, and the second part only requires these properties.

The first term in m in the nonsingular case reminds classical algebraic geometers of the genus. In fact, most classical geometers will prove Harnack’s theorem using the genus (see Appendix 6 in Fischer’s book [2001]), but Harnack’s theorem has little to do with the genus.

{ContourPlot[x^4+y^4-1==0,{x,-1.5,1.5},{y,-1.5,1.5}],ContourPlot[16-20 (x^2)+4 (x^4)-20 (y^2)+17 (x^2) (y^2)+4 (y^4)==0,{x,-2.5,2.5},{y,-2.5,2.5}]}

On the left, we have a genus-3 curve with one oval. On the right, a genus-0 curve with decompositions into two to four ovals.

9.2 Descartes’s Rule and Viro Diagrams

The most complicated procedure in this book is the exact procedure that draws Viro diagrams. For continuity of our discussion, we save this code for the end of this chapter.

Descartes’s Rule

We return to your college algebra class where you learned Descartes’s rule. Although it is no longer useful as a tool for solving univariate polynomial equations, it is still a useful theoretical idea. Here, we work exclusively with numerical polynomials which implies, among other things, that no coefficient is exactly zero and there are no multiple zeros. Then Descartes’s rule can be formulated in the following combinatorial and visual way:

First, assign to a polynomial f=(Subscript[a, 0])+(Subscript[a, 1])x+⋯+(Subscript[a, d])(x^d) a list s={(Subscript[s, 1]),(Subscript[s, 2]),…,(Subscript[s, d+1])}, where (Subscript[s, j]) is zero if (Subscript[a, j+1]) is positive and (Subscript[s, j]) is 1 if (Subscript[a, j+1]) is negative. Note: the index shift and some of the other adjustments to make this compatible with Mathematica. We now have

f= (((-1))^(Subscript[s, 1]))|(Subscript[a, 0])| + (((-1))^(Subscript[s, 2]))|(Subscript[a, 1])|x + ⋯ + (((-1))^(Subscript[s, d+1]))|(Subscript[a, d])|(x^d).

Then we draw the diagram as follows: on a horizontal axis, if 0<j ≤d+1, put a green dot at {j-1,0} if (Subscript[s, j])=0 and put a red dot if (Subscript[s, j])=1. For -d≤j≤0 if j is even, we have the same color as at -j while if j is odd, we put the opposite color.

f=-4.872507552870091`+3.4368580060422964` x-0.2018126888217524` (x^2)-0.22054380664652573` (x^3)+0.030211480362537763` (x^4)
DD1=descartesDiagram[coefficientSigns[f,{x}]]

g=10.070348961821836` -3.1854981245813794` x+1.6605231078365708` (x^2)-0.5956460147354319` (x^3)-0.4997923643670461` (x^4)+0.13414266577361014` (x^5)+0.004018754186202277` (x^6)-0.0016744809109176153` (x^7)
DD2=descartesDiagram[coefficientSigns[g,{x}]]

In both examples, the total number of crossings of the x-axis (the middle horizontal line in the diagram) is exactly d. Descartes’s rule can now be stated:

The number of positive zeros of a univariate polynomial is never more than the number of positive crossings in the diagram and differs from this diagram by an even number. Likewise, the number of negative zeros of the polynomial is never more than the number of negative crossings and differs by an even number.

The Descartes’s diagram for f says we must have one negative crossing and one or three positive ones. For g, there can be zero or two negative crossings and one, three, or five positive ones.

Column[{DD1,Plot[f,{x,-10,10}, PlotRange->1,PlotStyle->Blue, ClippingStyle->Blue, AspectRatio->.2]}]

Column[{DD2,Plot[g,{x,-10,10}, PlotRange->1,PlotStyle->Blue, ClippingStyle->Blue, AspectRatio->.2]}]

The two match for f, both in number of crossings and asymptotically—that is, the clipped plot is positive at either end if the Desargues’s plot is as well. For g, there is again an asymptotic match, but there are two fewer positive crossings.

For later purposes, we will use a sketch rather than a clipped plot (for example, using g above) and techniques from the end of the chapter.

G=<|{-7}->0,{-6}->0, {-5}->1,{-4}->1,{-3}->1,{-2}->0, {-1}->0,{0}->0,{1}->0,{2}->0,{3}->1,{4}->1,{5}->0,{6}->1,{7}->1|>;
Column[{DD2,descartesSketch[G,7]}]

The green-red plot is the prediction from Descartes’s rule while the orange-brown plot is a representation of the actual plot. It should be noted that this representation is produced by a human, not a machine, and, therefore, is not unique. We will continue these conventions.

The variable G is called an association. This data type will be discussed in Section 9.4. You can also find out more from the Wolfram Language & System Documentation Center or in Stephen Wolfram’s online book An Elementary Introduction to the Wolfram Language (2017).

Viro Diagrams

A two-dimensional version of this is called a Viro diagram after Oleg Viro, a Russian mathematician who proposed a similar idea in 1978. It is important to note that the diagrams here are different from the diagrams in Viro’s famous 1978–1980 papers. In fact, these are abstractions of Gauss’s idea: a positive plane region using lattice points and bound by a curve, but (as in the Descartes’s diagrams) we can get the first quadrant region from the coefficient signs and try to predict what will happen in the other three quadrants.

We have a bivariate numerical polynomial of degree d,

f[x,y] = (Subscript[a,  0, 0])+(Subscript[a,  1, 0])x+(Subscript[a,  0, 1])y+ (Subscript[a,  2, 0])(x^2)+(Subscript[a,  1, 1])x y+ (Subscript[a , 0, 2])(y^2)+⋯ + (Subscript[a,  0, d])(y^d).

By “numerical,” we mean that all the coefficients (Subscript[a,  i, j]) are nonzero machine numbers. Moreover, assume the solution curve f[x,y]=0 is nonsingular (as in Chapter 5) and {1,0,0} and {0,1,0} are not infinite points (although there may be infinite points near them). The goal is to count the number of points where the curve crosses the three axes x=0, y=0, and z=0, where the last axis is the infinite line. These axes, in turn, can be divided into positive and negative parts, where, for the infinite line, {x,y,0} is positive if x y >0 (that is, points adjacent to quadrants I and III in the high-school plane).

f=newtonHyperbola[413,x,y]
viroDiagram[f,x,y]

We have a diamond with lattice points {i,j} on the boundary and in the interior for |i|+|j|≤3. Each such point with 0≤i,j in the first quadrant represents a monomial (x^i)(y^j) of f. If the coefficient (Subscript[a, i,j]) is positive, the lattice point will be pictured by a green dot. If the coefficient is negative, the coefficient will be given by a red dot. In the diagram above, {0,0} is red since the constant coefficient -1 is negative, but {1,0} is green since the coefficient of x is 1, and so on.

In the first quadrant, the monomial (x^i)(y^j) will always be positive off the axes, so the sign of the term (Subscript[a, i,j])(x^i)(y^j) will depend on the sign of the coefficient (Subscript[a, i,j]), but in the other quadrants, (x^i)(y^j) will not always be positive. This will depend on which quadrant it is and whether i and j are even or odd. The color of a dot will depend on the sign of the term, so when (x^i)(y^j) is negative, the color will change. In the second quadrant, x is negative and y is positive, so (x^i)(y^j) is positive if i is even (otherwise (x^i)(y^j) will be negative). The color changes for odd i but remains the same for even i. In the third quadrant, x and y are both negative, so (x^i)(y^j) is positive if both i and j are positive or are both negative. In other words, (x^i)(y^j)>0 if i and j have the same parity. Thus colors are preserved (or off-diagonal lines). The fourth quadrant is like the second but the color changes for odd j.

S=Select[Flatten[Table[{i,j},{i,0,6},{j,0,6}],1],Total[#]≤6&];
A=Association[Table[p->0,{p,S}]];
Show[plotAssoc[dvAssoc[A],Green,Red],Axes->True]

We then draw boundary curves separating the green and red regions. As Gauss pointed out, these curves are continuous and are closed or only have endpoints at the edge of the drawing. We accomplish this in this setting by considering the squares with vertices {{i,j},{i+1,j},{i+1,j+1}, and {i,j+1}}. If adjacent vertices are a different color, then the curve should go through the midpoint of that edge. Each square must have an even number of such edges: 0, 2, or 4. The cases with zero or two edges are clear. If there are four edges, then opposite vertices are the same color and we have an ambiguous situation.

D1=viroDiagram[newtonHyperbola[613,x,y],x,y]

We have some utility functions to allow the user to pick specific choices. In addition, although our standing assumption in this section is that our curves are nonsingular, we can represent a simple crossing as well.

D2=Show[D1,pickMagenta[-2,-1],pickCyan[0,-1],pickSingularity[0,-2]]

In the diagram above, the number of crossings of the x, y, and infinite (z) axes is exactly three. Here, the infinite axis can be represented by two consecutive outer edges; for example, the edges of the first and second quadrant. From the projective point of view, if a curve hits the outer edge in the first quadrant, it reappears at the antipodal outer edge of the third quadrant (likewise for quadrants two and four).

Optionally, use the Graphics primitive Text to label these “infinite” points. There are four of these, you may need to use several trials to get the placement correct.  See the example below.

D3=Show[D2,Graphics[{Black,Text["A",{.5,2.7}],Text["B",{3.3,0}],Text["C",{1.8,-1.5}], Text["A",{-.8,-2.5}],Text["B",{-2.8,-.5}],Text["C",{-1.5,1.8}] }]]

{Show[D3,ListPlot[{Labeled[{.5,-1.5},"S"],Labeled[{1.5,-.5},"Q"],Labeled[{-1,-.5},"R"],Labeled[{-1.5,0},"P"]}]],Graph[{"A"->"Q","Q"->"B","B"->"P","P"->"C","C"->"S","S"->"R","R"->"S","S"->"A"},VertexLabels->"Name"]}

This Viro diagram, especially with our choices at the ambiguous squares, is only a representation of a theoretically possible curve, not the curve on Newton Hyperbola 613 (which is nonsingular, among other things). In the next section, we will give the correct diagram for Newton Hyperbola 613. Like Descartes’s rule, our Viro diagrams simply give constraints on the geometry and topology of a curve with given coefficient signs, but any given curve may be missing components, infinite points, or just crossings of the axes.

Newton Hyperbolas

Newton was interested in cataloging real cubic functions sometime between 1676 and 1704 (Struik, 1986), and he called them hyperbolas because of the asymptotes. In Chapter 1, I have generated a numbered list of approximately (2^28) curves up to degree 6 with asymptotes (which I call as such in honor of Newton’s work). These curves incorporate each sign sequence and maximize the number of quadrant changes in their Viro diagrams, but the actual topology of these curves may not be the same as the abstract curve of the Viro diagram.

f=newtonHyperbola[210,x,y]

{Show[viroDiagram[f,x,y],pickCyan[0,-1]],RegionPlot[f>0, {x,-7,7},{y,-7,7},Axes->True]}

The scale of the region plot makes it hard to see, but f has three zeros on the positive x-axis and negative y-axis.

{x,y}/.NSolve[{f,y}]
{x,y}/.NSolve[{f,x}]
infiniteRealPoints[f,x,y]

In this case, the actual curve matches the topology of the Viro diagram.

However, we can make the positive region smaller by changing the constant term to 0.3 (which does not change the sign of that term and hence gives the same ambiguous Viro diagram).

g=f-.7
{Show[viroDiagram[g,x,y],pickMagenta[0,-1]],RegionPlot[g>0, {x,-7,7},{y,-7,7},Axes->True]}

{x,y}/.NSolve[{g,y}]
{x,y}/.NSolve[{g,x}]
infiniteRealPoints[g,x,y]

Note that this does change the actual zeros on the positive x-axis and negative y-axis but not the number of zeros. The infinite points are unchanged.

h=f-.38587
{Show[viroDiagram[h,x,y],pickSingularity[0,-1]],RegionPlot[h>0, {x,-7,7},{y,-7,7},Axes->True]}

This example shows why we must keep the ambiguous squares ambiguous, generally all cases could be possible.

When Harnack stated his curve theorem in 1876, he claimed to have maximal examples (called M-curves) for each degree—that is, a curve of degree d with (((d-1)(d-2))/2)+1 connected projective components. Viro has a recipe for the diagrams and a proof of existence of curves with these topologies. Here is a Newton-hyperbola-friendly version constructed inductively.

f0=1;
f1=f0 -x-y; (* NH6 *)
f2=f1+ .2x^2- x y+.2y^2; (* NH22 *)
f3=f2-.2^3x^3-.2x^2y-.2x y^2-.2^3y^3; (* NH982 *)
f4=f3+.2^6x^4-.2^3x^3y+.2x^2y^2-.2^3x y^3+.2^6y^4; (* NH11222 *)
f5=f4- .2^10x^5-.2^6x^4y-.2^3 x^3y^2-.2^3x^2y^3-.2^6x y^4-.2^10y^5; (* NH2075606 *)
f6=f5+ .2^15x^6-.2^10x^5y+.2^6x^4y^2-.2^3x^3y^3+.2^6x^2y^4-.2^10x y^5+.2^15y^6; (* NH90155990 *)

{{Labeled[viroDiagram[f3,x,y],"d=3"],Labeled[viroDiagram[f4,x,y],"d=4"]},{Labeled[viroDiagram[f5,x,y],"d=5"],Labeled[viroDiagram[f6,x,y],"d=6"]}}

My Newton hyperbolas do not give curves with the topologies of their Viro diagrams; they only give the large component that intersects the positive x and y axes.

h3=f3-2x y

{viroDiagram[h3,x,y],RegionPlot[h3>0,{x,-40,40},{y,-40,40},Axes->True]}

h4=f4-x^2 y- 6x y -x y^2
{viroDiagram[h4,x,y],RegionPlot[h4>0,{x,-33,33},{y,-33,33},Axes->True]}

{x,y}/.NSolve[{h4,x}]
{x,y}/.NSolve[{h4,y}]
infiniteRealPoints[h4,x,y]

Of course, there are easier, better known M-curves in degree 3 and 4. I will leave it to the reader to come up with explicit examples of curves with the topologies of f 5 and g5.

9.3 Description of Curves by Gauss Diagrams

The stated goal of this book was: given a bivariate polynomial f(x,y), we want to describe the geometry of the real solution set f(x,y)=0 as concisely and accurately as possible, giving the affine and/or projective topology (as well as some positional information). So far, we have considered Euler graphs, Gauss hemisphere plots, as well as plots of the curve (or components on the Möbius band model of the projective plane). I now propose a Gauss diagram as it visually gives the most information, and, in the spirit of Gauss, we view a real algebraic plane curve as the complete boundary of its positive set f(x,y)=0.

A Gauss diagram is a diamond diagram (like the Viro diagrams), but here, the lattice points in the interior represent affine points and the color depends on whether the affine point is in a positive or negative complimentary region of the curve. Points on the x and y axes of the diagram represent points actually on the axes. The points on the outer boundary (z-axis) represent infinite points. The color depends on the parity of nearby affine points. A curve is drawn, separating the positive and negative points. Those cells with diagonal positive and negative points are again ambiguous and the choice of curves inside these cells must be set by the user, as in Viro diagrams. In general, it is not expected that the Viro rules will hold for Gauss diagrams. However, if they hold on to the axes (x,y,z) mod 2 (meaning the number of axis crossings can be an even number less than those in a Viro diagram), we then call the Gauss diagram plausible.

I claim that every curve of degree d has a plausible Gauss diagram of size d, but this is not obvious nor do I have a proof. Such a structural result would be at least as deep as Harnack’s theorem. I also do not claim that each plausible Gauss diagram actually matches a real plane curve, but it would be a nice theorem if someone could prove this.

In this chapter, we indicate how to attempt a plausible Gauss diagram for a given curve, but first, we introduce two new functions.

axisPoints[f_,x_,y_]:={x,y}/.NSolve[{f,x y},{x,y},Reals];

In Chapters 6, 7, and 8, we learned how to examine the projective plane near the infinite points. The following will make this easier (we will give an example later).

The inspectInfPoint function puts together several other functions to allow us to quickly see what is happening at an infinite point and give affine points that directly lead to the infinite points. ip is the infinite point and r is a positive radius usually less than one. We want a circle that intersects the curve only near the infinite points.

Options[inspectInfPoint]={output->All};
inspectInfPoint[f_,ip_,r_,x_,y_,OptionsPattern[]]:=Module[{A,g,bp,ap,sol,GP},
A=ip2z[ip,x,y];
g=FLT[f,A,x,y];
sol=NSolve[{g,x^2+y^2-r^2},{x,y},Reals];
If[Length[sol]>0,bp={x,y}/.sol;
ap=flti[#,Inverse[A]]&/@bp,
bp={}; ap={}];
GP:=Show[gaussPlot[g,r,bp], ContourPlot[y==0,{x,-r,r},{y,-r,r},ContourStyle->Directive[Orange,Dashed]], ImageSize->Small];
Switch[OptionValue[output],"plot",Return[GP],"data",Return[{A,g,bp,ap}],Default,Continue];
Echo[A,"Transformation"];
Echo[g," Transformed equation"];
Echo[bp,"boundary points coordinates relative to infinite point"];
Echo[ap, "affine coordinates boundry points"];
GP]

Newton hyperbolas generally have the property that the underlying vertex colors can come, mod 2.

f413=newtonHyperbola[413,x,y]
P413=viroDiagram[f413,x,y]

This gives the most general picture possible (based on Descartes’s rule), but all features shown may not be present; for example, there could be only one infinite point instead of three. Our next steps should be to compute the infinite points, the default critical points, the zeros on the axes, and the region plot.

infiniteRealPoints[f,x,y]

Because another run of the above may change randomly we give one run a permanent name.

ip1={{-10.85416992667319`,-0.41808746430026433`,0},{0.21474561787537816`,5.575114363519059`,0},{-3.541380878628873`,3.541380878628877`,0}};
ipp={"A","B","C"};
lbl1=Table[{ipp[[i]]->ip1[[i]]},{i,3}]//MatrixForm
criticalPoints[f,x,y]
axisPoints[f,x,y]

RegionPlot[f413>0,{x,-35,35},{y,-35,35}]

In this case, all the features are accounted for: the three infinite points, the three affine components of the curve, the three positive zeros on the x-axis, and the one positive and two negative zeros on the y-axis.

{Labeled[Show[P413,Graphics[{Black,Text["B",{.5,2.7}],Text["B",{-.7,-2.5}],Text["A",{2.5,.8}],Text["A",{-2.8,-.55}],Text["C",{1.75,-1.55}],Text["C",{-1.5,1.7}]  }],      ImageSize->Medium],lbl1,Bottom],Graph[{"B"->"C", "C"->"B","A"->"A"},VertexLabels->"Name"]}

From this final picture, we see this curve has two projective components: the pseudo-line A ↔ A and the oval B ↔ C.

f613=newtonHyperbola[613,x,y]
P613= viroDiagram[f613,x,y]

infiniteRealPoints[f613,x,y]

ip2={{-13.921560965941756`,-0.536239082552866`,0},{0.09360388955643906`,2.430095637389799`,0},{-1.9892548567375314`,1.989254856737531`,0}};
ipp={"A","B","C"};
lbl2=Table[{ipp[[i]]->ip2[[i]]},{i,3}]//MatrixForm
criticalPoints[f613,x,y]
{x,y}/.NSolve[{f613,x y},{x,y},Reals]

RegionPlot[f613>0,{x,-10,10},{y,-10,10}]

P613a:=Show[P613,pickMagenta[-2,-1],pickCyan[0,-1],pickCyan[0,-2]];
P613b={Labeled[Show[P613a,Graphics[{Black,Text["A",{-2.7,-.55}],Text["A",{2.5,.7}],Text["B",{.5,2.7}] ,Text["B",{-.7,-2.5}],Text["C",{1.8,-1.55}],Text["C",{-1.5,1.7}]     }],
ImageSize->Medium],lbl2,Bottom],Graph[{"A"->"C","C"->"B","B"->"A"},VertexLabels->"Name"]}

Not only do we have a connected green set, but we also have the actual intersections of the curve with the axes. In fact, this corresponds with the correct components. Here, there is only one projective component: the pseudo-line A → C →B → A.

Continuing with Newton hyperbola 613 the next example shows what happens if we perturb the polynomial without changing any signs.  In particular the raw Viro Diagram will remain unchanged, but the ambiguous cells will be resolved differently so the diagram matches the new polynomial.

g613=Expand[f613+.8]

We first note that, since we are only changing the constant term, the infinite points stay the same as they depend only on the maximal form.

RegionPlot[g613>0,{x,-10,10}, {y,-10,10}]

Changing our choices on the ambiguous cells we have

Pg=Show[P613,pickCyan[-2,-1],pickMagenta[0,-1],pickCyan[0,-2]];

Pgb={Labeled[Show[Pg,Graphics[{Black,Text["A",{-2.7,-.55}],Text["A",{2.5,.7}],Text["B",{.5,2.7}] ,Text["B",{-.7,-2.5}],Text["C",{1.8,-1.55}],Text["C",{-1.5,1.7}]     }],
ImageSize->Medium],lbl2,Bottom],Graph[{"A"->"B","B"->"C","C"->"A"},VertexLabels->"Name"]}

So we still get the same graph although we traverse, in Gauss’ orientation, the graph in the opposite direction.  In both of the last two examples the Viro diagram, after choice of ambiguous squares, does describe the curve well.  In the next example the Viro diagram does not describe the curve so needs to be changed to a Gauss Diagram by changing some of the points.  We color this diagram orange and brown to distuish from the Viro Diagram.

h=0.23445264214028833` -1.5927585520147027` x-2.580519513261532` (x^2)-1.1688260976780054` (x^3)-0.2695282534264044` y-1.302314874550769` x y-1.4177824535874757` (x^2) y+0.01151627436977342` (y^2)+0.05893043878998516` x (y^2)+0.4495559920915271` (y^3);

viroDiagram[h,x,y]

infiniteRealPoints[h,x,y]
axisPoints[h,x,y]

We get one asymptote and one axis point on each axis (which are confirmed by using the RegionPlot function). This is still valid by Descartes’s rule because in each case, we are missing an even number of points:

RegionPlot[h>0,{x,-10,10},{y,-10,10}, Axes->True]

In this case, it is the association that must be changed rather than the ambiguous squares.

We can get by with changing one value on each axis (and quite a few off of the axes) to eliminate the two infinite points:

Ah=dvAssoc[coefficientSigns[h,{x,y}]]

AssociateTo[Ah, {{-2,0}->0,{0,1}->0,{-1,1}->1,{-2,1}->0,{-1,2}->0,{1,-2}->1,{2,-1}->1}];

dDiagram[Ah]

Alternatively to AssociateTo, we have the toggle function, which changes (i.e. toggles) the value from 0 to 1 or 1 to 0, so we only have to list the points to be changed.

toggle[A_,K_]:=Module[{B},
B=A;
Do[If[B[p]==0,B[p]=1,B[p]=0],{p,K}];
B]

Ah=dvAssoc[coefficientSigns[h,{x,y}]];
Ah=toggle[Ah, {{-2,0},{0,1},{-1,1},{-2,1},{-1,2},{1,-2},{2,-1}}];
dDiagram[Ah]

Since this is not a Viro diagram grid points, showing the same data:

Ah=toggle[Ah,{{0,-2},{1,-1},{0,-1}}];

P1=dDiagram[Ah];
Show[P1,  Graphics[{Black, Text["A",{1.85,1.5}],Text["A",{-1.5,-1.75}]  }]]

It now looks a little more like the actual curve, but we are far from the original Viro diagram, showing that the Viro diagram may show too much complexity. However, this could be perhaps recovered by a perturbation, leaving the signs unchanged. We now have a finite oval and a pseudo-line projectively.

f18=newtonHyperbola[18540,x,y]
B1=dvAssoc[coefficientSigns[f18,{x,y}]];
Q1= dDiagram[B1, pcolr->Green,ncolr->Red];
{Q1, RegionPlot[f18>0,{x,-30,30},{y,-30,30}, Axes->True]}

The Viro diagram tells us there is one infinite real point in quadrants II and IV and one or three in quadrants I and III. There may be zero or two crossings of each of the positive and negative x-axis, one crossing of the negative y-axis, and one or three crossings of the positive y-axis.

Show[viroDiagram[f18,x,y], pickMagenta[-2,-2],pickMagenta[0,-2],Graphics[{Black,Text["D",{1.8,-2.5}],Text["A",{3.5,.8}],Text["B",{2.5,1.8}],Text["C",{.8,3.5}],Text["D",{-1.5,2.7}],Text["A",{-3.8,-.5}],Text["B",{-2.8,-1.5}],Text["C",{-.5,-3.8}]  }]]

Closer analysis shows this is false.  There actually are 4 infinite points

infiniteRealPoints[f18,x,y]

Fixing the order

irp18={{-0.873117679283266`,-127.7785512635922`,0},{-4.016062383721934`,85.89315341645948`,0},{-2.751471610903479`,-0.07949057221115022`,0},{-2.7521931681371776`,-0.030435823035661506`,0}};
Airp18=<|"A"->irp18[[4]],"B"->irp18[[3]],"C"->irp18[[3]],"D"->irp18[[1]]|>

We see that there are four infinite points, as is often the case with Newton hyperbolas. Two are near {0, 1, 0} and the other two are near {1, 0, 0}.

in1=inspectInfPoint[f18, {0,1,0}, 1,x,y,output->"plot"]

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

This is not clear. It looks like there is a singularity at {1,0,0}, but that is not likely as infiniteRealPoints recorded two nearby infinite points (and Newton hyperbolas are not known to be singular).

inspectInfPoint[f18,{1,0,0},.1,x,y]

in2={{31.274814308993278`,-1.2665540243905862`},{-47.90208487681591`,-2.1212057690097192`},{-21.18241973795016`,0.13537047756803747`},{34.324060769362205`,1.45584105351298`}};

The curve has a continuous arc from point 4 in the first quadrant to point 1 in the fourth quadrant, passing through the negative half plane while the arc from point 2 to point 3 stays in the negative half plane.

cp=criticalPoints[f18,x,y]

we make these permanent by an association

acp18={{-138.81734479303344`,-3.2773512335871615`},{-109.56699575850641`,-2.6891885040001884`},{0.0012513272918888757`,-4.97536378737042`},{3.4309630264809243`,-0.7449491171336651`},{-3.4005990686248637`,2.533819378090668`},{-0.3867791123580645`,0.40124298228957733`}};
Acp18=<|Table[i->acp[[i]],{i,6}]|>

We draw two plots. The first is a magnification near the origin. For the second plot, we use a larger x-scale and labeled points. The points with positive label are the critical points.

{ContourPlot[f18==0,{x,-8,8},{y,-8,8}, Axes->True],
Show[ContourPlot[f18==0,{x,-150,50},{y,-10,10}, Axes->True],ListPlot[{Table[Labeled[Acp18[i],i],{i,6}],Table[Labeled[in2[[i]],-i],{i,4}]}]]}

Among other things, note that RegionPlot failed to pick up the curve accurately by the x-axis in the first and fourth quadrants.

axisPoints[f18,x,y]

Finally, the curve crosses twice in the positive x-axis, twice on the negative x-axis, three times in the positive y-axis, and only once on the negative y-axis.

B2=B1;
AssociateTo[B2,{{1,0}->1, {-2,-1}->0,{0,2}->0,{0,3}->1, {-1,-2}->0,{1,-3}->0,{1,-1}->0,{2,-1}->0,{1,-3}->1}];
{Show[dDiagram[B2], labelI[3,0,"A"], pickCyan[-3,-1],pickMagenta[0,0],  Graphics[{Black,Text["D",{1.8,-2.5}],Text["A",{3.5,.8}],Text["B",{2.5,1.8}],Text["C",{.8,3.5}],Text["D",{-1.5,2.7}],Text["A",{-3.8,-.5}],Text["B",{-2.8,-1.5}],Text["C",{-.5,-3.8}]  }],ListPlot[{Labeled[{-3,-.5},1],Labeled[{-1.9,-.4},2],Labeled[{.2,-1.5},3],Labeled[{-.5,.5},6],Labeled[{-1.5,.5},5],Labeled[{.7,-.9},4]}],ImageSize->Medium],Graph[{"A"->4,4->"B", "B"->1,1->"A", "C"->6,6->2,2->5,5->"D","D"->3,3->"C"},VertexLabels->"Name", ImageSize->Small]}

Where A is approximately {1, .01,0}, B is {1, .02,0}, C is {.01, 1,0} and D is {-.05,1,0} and the numbers are the indexes of the critical points:

Acp18

While the Viro diagram looks quite different, it is mostly a matter of choosing ambiguous squares to get the correct diamond diagram. However, the finite oval in quadrant I of the Viro diagram does not exist in this curve. In the first and second quadrant, A should go directly to E without crossing the x-axis.

f=newtonHyperbola[1050752,x,y];
M1=dvAssoc[coefficientSigns[f,{x,y}]];
AssociateTo[M1,{{-1,2}->0,{-1,3}->0,{2,1}->0,{3,1}->0,{0,-4}->1,{-1,-3}->1,{-2,-2}->1}];
P5:=dDiagram[M1];
{Show[P5,pickMagenta[-3,1],pickMagenta[-3,0],pickMagenta[-1,-1],pickCyan[-1,-2],Graphics[{Black,Text["A",{.9,4.5}],Text["A",{-.8,-4.5}],Text["E",{-1.8,3.5}],Text["E",{1.9,-3.5}], Text["D",{-2.5,2.8}], Text["D",{2.5,-2.8}],Text["C",{-3.8,1.5}],Text["C",{3.5,-1.8}],Text["B",{-4.5,.8}], Text["B",{4.8,-.5}] }]], Graph[{"A"->"E","E"->"A", "B"->"C","C"->"D", "D"->"B"},VertexLabels->"Name"]}

Unless the curve is numeric (as explained above) the techniques above will not work directly. Any plane algebraic curve is equivalent to a numeric curve; in some cases, the Gauss diagram of this numeric curve can explain the curve. If the curve has bad singularities, a dDiagram is not appropriate.

To get an equivalent numeric curve from an exact curve, one can first pick three small positive random numbers.

{ar,br,cr}=RandomReal[{.3,.6},3]

Rrot=RotationMatrix[ar,{br,cr,1}]

fn=FLT[f,Rrot,x,y]

f= gaussCurve[z^3-8,x,y,z]

infiniteRealPoints[f,x,y]

{ar,br,cr}= {0.3898838058945685`,0.48542069774603913`,0.49793752820382864`};

Rrot=RotationMatrix[ar,{br,cr,1}]

fn=FLT[f,Rrot,x,y]

infiniteRealPoints[fn,x,y]

{RegionPlot[f>0,{x,-10,10},{y,-10,10},Axes->True], RegionPlot[fn>0,{x,-10,10},{y,-10,10},Axes->True]}

AC=coefficientSigns[fn,{x,y}];
DC=dvAssoc[AC];
dDiagram[DC]

This is not correct on two counts: the component in the second quadrant should not cross either axis and the finite oval shown in the fourth quadrant does not exist.

DC1=DC;
AppendTo[DC1,{{1,-1}->1,{-1,0}->1,{0,1}->1}];
P=dDiagram[DC1];
Show[P, Graphics[{Black, Text["{.67,.75,0}",{2,1.75},Background->White],Text["{-.67,-.75,0}",{-2.6,-1.55}],Text["{.98,-.19,0}",{2.5,-.8},Background->White] ,Text["{-.98,.19,0}",{-2.5,.85},Background->White]}]]

Our second example is the singular Chebyshev quartic, which is also not numeric and has {0,1,0} as a point where the curve is tangent to the infinite line.

f=1-8x^2+8x^4+3y-4y^3
fn = FLT[f,Rrot,x,y]

{ContourPlot[f==0,{x,-4,4},{y,-3,7},ContourStyle->Blue,Axes->True],Show[ContourPlot[fn==0,{x,-4,4},{y,-3,7},ContourStyle->Blue,Axes->False],Graphics[{Black,Text["1",{-.8,0}],Text["2",{1,.8}],Text["8",{0,1}],  Text["5",{-1.9,5.7}], Text["3",{.5,-1.2}], Text["6",{-.6,-1.7}],Text["9",{0,-.1}], Text["7", {.8,-.2}] ,Text["4",{2.1,-1}]  }]]}

AC=coefficientSigns[fn,{x,y}];
DC=dvAssoc[AC];
T=dDiagram[DC]

This doesn’t look much like the contour plot of fn, but the axis points are counted correctly and Descartes is OK with this (since the number of infinite points of fn, 0, is an even number less than the diagram).

Since we have a singular curve with normal crossings, we replace the ambiguous
squares with singular squares.

Show[T, pickSingularity[-2,1],pickSingularity[0,1],pickSingularity[0,-3],
Graphics[{Black, Text["4",{3.5,-.7}], Text["5",{2.5,-1.8}],Text["6",{1.8,-2.5}], Text["7",{.5,-3.8}],   Text["4",{-3.7,.5}], Text["5",{-2.7,1.5}],Text["6",{-1.5,2.7}], Text["7",{-.7,3.5}],Text["2",{.7,1.7}],Text["1",{-1.3,1.7}], Text["3",{.7,-2.3}], Text["9",{-.4,-.5}],Text["8",{-.5,1.7}] }]]

Graph[{1->5,5->2,2->7,7->3,3->6,6->1, 1->8,8->2,2->4,4->3,3->9,9->1},VertexLabels->"Name", DirectedEdges->False]

The diamond diagram above has the same projective topology as the curve but not the same affine topology.

9.4 Some More Topology of the Real Projective Plane

In this section, we discuss some more consequences of the topology of the projective plane and some questions that have arisen from these consequences. The general reference for this section is Section 11.6 of Bochnak (1998). This material is also largely available on Wikipedia.

As mentioned in Section 8.5 discussing the Möbius band model of a projective curve loop, an oval is defined to be a loop (or component in the nonsingular case) that separates the projective plane into two topological components. Some deeper topological reasoning shows that one of these components will be topologically a disk (two sided) while the other will be an actual Möbius band (one sided).

As was pointed out in Chapter 8, some geometers would prefer to think of the boundary Möbius band model as a small circle about the origin rather than collapsed to the origin. The full projective plane is a Möbius band with a disk attached, so the previous statement follows by going backwards.

The component of the complement of this curve containing the (dashed) infinite line is an actual Möbius band while the other component contained the original boundary of the band (which is pinched to the origin), so that component is a disk; that is, the light brown interior of the original circle.

Generally, we can call the (topologically speaking) disk component the interior of the oval. Now, restricting to nonsingular curves for the rest of this section, it is possible that a component lies in the interior of another component. It is further possible that another component lies in the interior of the second component, and so on. We get a nest of components. For each oval in this nest, its depth is the number of ovals containing it, so our outer oval has depth zero.

A simple consequence of the fact that a line (or other curve) must intersect an oval in an even number of points is the following. Suppose we have a nest of ovals. Pick a point p on the outer oval and a second point q on the innermost oval. Then this line must intersect each oval in the nest in a positive even number of points. If the innermost oval has depth k (that is, there are k+1 curves in the nest), then this line intersects the curve containing all these ovals in at least 2(k+1) points. Therefore, this curve has a degree of at least 2(k+1). Simple algebra shows that the number of ovals in a nest must be less than or equal to (d/2), where d is the degree of the curve.

A curve of degree 2 or 3 cannot have nested ovals, but a curve of degree 4 could possibly have a nest of two ovals. In fact, we can give a simple family of examples showing that when d=2n, it is possible to have a nest of n=(d/2) ovals. Take the Gauss curve of p=((z^2)-1) ((z^2)-4)...((z^2)-(n^2)).

M={{0,1,0},{0,0,1},{1,0,0}}
g4=gaussCurve[(z^2-1)(z^2-4),x,y,z]
h4=FLT[g4,M,x,y]
{ContourPlot[g4==0,{x,-10,10},{y,-10,10}],ContourPlot[h4==0,{x,-3,3},{y,-2,2}]}

g6=gaussCurve[(z^2-1)(z^2-4)(z^2-9),x,y,z]
h6=FLT[g6,M,x,y]
{ContourPlot[g6==0,{x,-15,15},{y,-15,15}],ContourPlot[h6==0,{x,-5,5},{y,-3,3}]}

g5=gaussCurve[(z^2-1)(z^2-4)(z+5),x,y,z]
h5=FLT[g5,M,x,y]
{ContourPlot[g5==0,{x,-15,15},{y,-15,15}],ContourPlot[h5==0,{x,-5,5},{y,-3,3}]}

In 1900, the famous mathematician David Hilbert proposed a list of 23 problems he thought were most important for mathematicians to study in the coming century. Problem 16 had two parts. The first had to do with Harnack’s theorem (Section 9.1): that a nonsingular, real algebraic plane curve of degree d could have, at most, m=(((d-1)(d-2))/2)+1 components. Hilbert wanted to know more details about how an M-curve (one with m components) could look.

For example, in Section 9.2 we give Viro diagrams of Harnack’s M-curves for d=3, 4, 5, and 6. For degree 3 and 4, there is no nesting. In degree 5 and 6, there is one small oval inside the “big” oval with the other nine ovals in the exterior of the big oval. It is now known that there are two other possibilities: nine ovals of depth 1 in a big oval and one outside or five ovals inside a big oval with five outside.

Some early work on this problem was done by Virginia Ragsdale in the early 1900s. She let p be the number of ovals of even depth and n be the number of odd depth. Harnack’s theorem says that for a curve of degree d,p+n≤(((d-1)(d-2))/2)+1 with equality for an M-curve. She conjectured that for a curve of d=2k,

p≤((3k(k-1))/2) +1 and n≤((3k(k-1))/2).

Later, Ivan Petrovsky showed that instead

p-n≤((3k(k-1))/2) +1 and n-p≤((3k(k-1))/2).

Ragsdale’s conjecture was later disproved by Viro, who was able to use his method to find counterexamples.

A related result for M-curves of degree d=2k is that (p-n)-(k^2), which could be positive or negative, is a multiple of 8. So if k=3 and d=6, then n+p=11, but p-n must differ from 9 by a multiple of 8. So the only possibilities are p=10, n=1, p=2, n=9 or p=6, n=5 as described above.

Here are some diamond diagrams for the topology of these M-curves. However, since they are not Viro diagrams, they do not imply existence of algebraic curves with these diagrams. That existence is due to David Hilbert in 1891.

Additional results on the first part of Hilbert’s 16th problem have been discovered in this century, but the problem is still not completely solved.

9.5 Another Drawing Method for Diagrams of Symmetric Sparse Curves

We would like to give the maximal nests in the previous section in terms of diamond diagrams, but the method in the Newton hyperbola section above does not do a good job because of the symmetry about the y-axis. Instead, we go back to Gauss, who considered a real algebraic curve as the boundary between positive and negative values of the defining polynomial. Therefore, instead of looking at the coefficients, we look at the values of the polynomial and associate the vertices of our grid with these. The diamond diagram algorithm (with some human help) does a good job of drawing the separating curve.

We will assume our nonsingular polynomial function is positive at the origin—that is, has a positive constant term and has some symmetry there. Let rr be a list of d increasing positive numbers, where d is the degree of the curve. Our first function plots the region plot of the function with the diamonds. They should have vertices in the changing positive and negative regions as the distance from the origin increases.

plotDiamonds[f_,rr_, x_,y_]:=Module[{m},
m=Max[rr];
If[Length[rr]≠tDeg[f,x,y], Echo[" wrong number of diamonds","WARNING"]];
Show[RegionPlot[f>0,{x,-m,m},{y,-m,m}],ContourPlot[Abs[x]+Abs[y],{x,-m,m},{y,-m,m},Contours->rr,ContourShading->None]]];

The second function then samples the polynomial along the sides of the diamonds and gives an association assigning these values to the vertices.

gaussAssoc[f_,rr_,x_,y]:=Module[{A,r,V,d,sgn},
sgn=Switch[Sign[#],1,0,-1,1,0,0]&;
d=tDeg[f,x,y];
If[d≠ Length[rr], Echo[d,"rr size"];Abort[]];
r=Prepend[rr,0];
V=ddVerts[d];
<|Table[v->sgn[f/.Thread[{x,y}->r[[Total[Abs[v]]+1]]/(Total[Abs[v]]+.001)*v]],{v,V}]|>
];

h5=1-10 (x^2)+5 (x^4)+5 y-30 (x^2) y+5 (x^4) y-5 (y^2)+15 (x^2) (y^2)-25 (y^3)+25 (x^2) (y^3)+4 (y^4)+20 (y^5);

rr={.4,.8,.95,2.5,3.5};
plotDiamonds[h5,rr,x,y]

Dh5=dDiagram[gaussAssoc[h5,rr, x,y]]

Show[Dh5,pickCyan[-1,-1],pickMagenta[0,-1]]

The one infinite point is {1,0,0}. This is not properly given by the diagram (in the sense of Viro diagrams) but does give the idea of a horizontal asymptote.

h6=1-15 (x^2)+15 (x^4)-(x^6)-14 (y^2)+84 (x^2) (y^2)-14 (x^4) (y^2)+49 (y^4)-49 (x^2) (y^4)-36 (y^6);
rr6={.1,.5,1,2,3,5};
plotDiamonds[h6,rr6,x,y]

Dh6=dDiagram[gaussAssoc[h6,rr6,x,y]]

Show[Dh6,pickMagenta[-3,1],pickMagenta[-1,2],pickCyan[0,2],pickCyan[2,1], pickMagenta[2,-2], pickMagenta[0,-3], pickCyan[-1,-3],pickCyan[-3,-2], pickMagenta[-1,1],pickCyan[0,1],pickMagenta[0,-2],pickCyan[-1,-2]]

9.6 Appendix: Diamond, Viro, and Gauss Diagrams

A Wolfram Language function we use as a construct is called Association, which has domains and ranges that product lists Keys[A], Values[A], where A is the name of the association. It is not necessary to define these lists in advance.

A=Association[{■->"square",●->"circle",▲->"triangle"}]

Keys[A]
Values[A]

Assuming each key is unique, then an association does work like a function (which is how our example will be).

A[■]
A[3]

The association we will use will have all the lattice points of our diamond as keys.

ddVerts[d_]:=Module[{V},
V[0]={{0,0}};
V[n_]:=V[n]=Join[V[n-1],Reverse[Table[{j,n-j},{j,0,n}]],Table[{-j,n-j},{j,1,n}],Table[{-j,j-n},{j,0,n-1}],Table[{j,j-n},{j,1,n-1}]];
V[d]];

ddVerts[3]

zeroA[d_]:=Association[Table[v->0,{v,ddVerts[d]}]];

A0=zeroA[3]

Starting with this association (which models the empty curve), we can modify to get a nonempty curve by changing some of the keys.

A1=zeroA[3];
A1[{1,1}] = 1; 
AssociateTo[A1,{{-1,2}->1,{0,-3}->1,{1,0}->1,{0,-2}->1,{-1,-1}->1,{-2,0}->1, {-1,-2}->1,{-2,-1}->1}]

plotAssoc[A_,c1_,c2_]:=Module[{K,C1,C2},
K=Keys[A];
C1=Select[K,A[#]==0&];
C2=Select[K,A[#]==1&];
If[Length[C1]==0, Return[ListPlot[K,Axes->False, PlotStyle->c2]]];
If[Length[C2]==0, Return[ListPlot[K,Axes->False, PlotStyle->c1]]];
ListPlot[{C1,C2},PlotMarkers->{●,●},PlotStyle->{c1,c2},Axes->False]];

plotAssoc[A1,Brown,Orange]

As mentioned earlier in Chapter 4 and Section 9.2, we will view adjacent keys of our association {a, b} and {a+1,b} or {a,b+1} as being connected if they have the same value. The connected component of {a,b} is the transitive closure of the relation—that is, all points connected to points connected to {a,b}, and so on, but if {a,b} and {a+1,b} have different values, they will be in different components, so the boundary curve of the component must pass between these points. As in Chapter 4, the boundary of each component is a union of continuous curves.

To draw the diamond diagram showing the boundary curves of the association, we divide up our two-dimensional diamond into squares and a right triangle on the outer boundary of the diamond. Each square will be identified by its lower left vertex {a,b}. This defines the other four vertices {a+1,b}, {a,b+1}, {a+1,b+1}, which, for {a,b} to be a valid square, must all be keys of the association. The sequence of values corresponding to these vertices in this order will be called the value sequence of this square.

{A1[{1,0}],A1[{2,0}],A1[{1,1}], A1[{2,1}]}

sqrSeq[p_,A_]:={A[p],A[p+{1,0}],A[p+{0,1}],A[p+{1,1}]};

By knowing the value sequence, we usually know what the boundary curve looks like in the square. For the square {1,0} above, we see the boundary will cut horizontally across the square. This would be the same for the complementary square—all values the opposite, {1,1,0,0}. Thus we have eight possibilities all being defined by the value square except {0,1,1,0} and its complement {1,0,0,1}. As we saw in Section 9.2, in the case of a Viro diagram of an actual curve, a small perturbation can change the choice, so we consider this case to be ambiguous and draw both cases using dashed lines.

ps0[a_,b_]:=Graphics[{Thin,Gray,Line[{{a,b},{a+1,b},{a+1,b+1},{a,b+1},{a,b}}]}];

ps1[a_,b_]:=Graphics[{Thick,Blue,Circle[{a,b},.5,{0,Pi/2}], Thin,Gray,Line[{{a,b},{a+1,b},{a+1,b+1},{a,b+1},{a,b}}]}];

ps2[a_,b_]:=Graphics[{Thick,Blue,Circle[{a+1,b},.5,{Pi/2,Pi}], Thin,Gray,Line[{{a,b},{a+1,b},{a+1,b+1},{a,b+1},{a,b}}]}];

ps3[a_,b_]:=Graphics[{Thick,Blue,Line[{{a,b+.5},{a+1,b+.5}}], Thin,Gray,Line[{{a,b},{a+1,b},{a+1,b+1},{a,b+1},{a,b}}]}];

ps4[a_,b_]:=Graphics[{Thick,Blue,Circle[{a,b+1},.5,{3Pi/2,2Pi}], Thin,Gray,Line[{{a,b},{a+1,b},{a+1,b+1},{a,b+1},{a,b}}]}];

ps5[a_,b_]:=Graphics[{Thick,Blue,Line[{{a+.5,b},{a+.5,b+1}}], Thin,Gray,Line[{{a,b},{a+1,b},{a+1,b+1},{a,b+1},{a,b}}]}];

ps6[a_,b_]:=Graphics[{Thick,Blue,Circle[{a+1,b+1},.5,{Pi,3Pi/2}], Thin,Gray,Line[{{a,b},{a+1,b},{a+1,b+1},{a,b+1},{a,b}}]}];

ps7[a_,b_]:=Graphics[{Thin,Gray,Line[{{a,b},{a+1,b},{a+1,b+1},{a,b+1},{a,b}}],Thick,Cyan,Dashed,Circle[{a+1,b+1},.5,{Pi,3Pi/2}], Circle[{a,b},.5,{0,Pi/2}],Magenta,Circle[{a+1,b},.5,{Pi/2,Pi}],Circle[{a,b+1},.5,{3Pi/2,2Pi}]}];

sqAassoc=<| {0,0,0,0}->ps0,{1,1,1,1}->ps0,{1,0,0,0}->ps1,{0,1,1,1}->ps1, {0,1,0,0}->ps2,{1,0,1,1}->ps2,{1,1,0,0}->ps3,{0,0,1,1}->ps3,{0,0,1,0}->ps4,{1,1,0,1}->ps4,{1,0,1,0}->ps5,{0,1,0,1}->ps5,{1,1,1,0}->ps6,{0,0,0,1}->ps6,{0,1,1,0}->ps7,{1,0,0,1}->ps7 |>;

For the triangles, we will use the quadrant and the coordinates of the right angle for identification. So pt13[a,b] will be a triangle in the second quadrant with a right angle at key point {a,b}.

triseq1[p_,A_]:={A[p],A[p+{1,0}],A[p+{0,1}]};
triseq2[p_,A_]:={A[p],A[p+{-1,0}],A[p+{0,1}]};
triseq3[p_,A_]:={A[p],A[p+{-1,0}],A[p+{0,-1}]};
triseq4[p_,A_]:={A[p],A[p+{1,0}],A[p+{0,-1}]};

pt10[a_,b_]:=Graphics[{Thin,Gray,Line[{{a,b},{a+1,b},{a,b+1},{a,b}}]}];

pt11[a_,b_]:=Graphics[{Thin,Gray,Line[{{a,b},{a+1,b},{a,b+1},{a,b}}],
Thick,Blue,Circle[{a,b},.5,{0,Pi/2}]}];

pt12[a_,b_]:=Graphics[{Thin,Gray,Line[{{a,b},{a+1,b},{a,b+1},{a,b}}],Thick,Blue,Line[{{a,b+.5},{a+.5,b+.5}}]}];

pt13[a_,b_]:=Graphics[{Thin,Gray,Line[{{a,b},{a+1,b},{a,b+1},{a,b}}],Thick,Blue,Line[{{a+.5,b},{a+.5,b+.5}}]}];

t1Assoc=<|{0,0,0}->pt10,{1,1,1}->pt10,{1,0,0}->pt11,{0,1,1}->pt11,
{1,1,0}->pt12,{0,0,1}->pt12, {0,1,0}->pt13, {1,0,1}->pt13 |>;

Likewise, we need four graphic functions and a corresponding association for each of the other three quadrants. These fifteen functions are in Appendix 2, which should be initialized.

We can now write our main drawing routine for diamond diagrams. The dot colors are, by default, orange for positive (0) and brown for negative (1), but these colors can be changed.

Options[dDiagram]={pcolr->Orange,ncolr->Brown};
dDiagram[A_,OptionsPattern[]]:=Module[{d,sqrs,t1,t2,t3,t4,PS,PT,PB,PA},
d=Max[Total[#]&/@Keys[A]];
sqrs=Select[Keys[A],KeyExistsQ[A,#+{1,0}]&&KeyExistsQ[A,#+{1,1}]&&KeyExistsQ[A,#+{0,1}]&];
PS:=Show[Table[sqAssoc[sqrSeq[p,A]]@@p,{p,sqrs}]];
t1=Select[Keys[A],#[[1]]+#[[2]]==d-1&];
t2=Select[Keys[A],-#[[1]]+#[[2]]==d-1&];
t3=Select[Keys[A],-#[[1]]-#[[2]]==d-1&];
t4=Select[Keys[A],#[[1]]-#[[2]]==d-1&];
PT:=Show[Table[t1Assoc[triseq1[p,A]]@@p,{p,t1}],Table[t2Assoc[triseq2[p,A]]@@p,{p,t2}],Table[t3Assoc[triseq3[p,A]]@@p,{p,t3}],Table[trAssoc[triseq4[p,A]]@@p,{p,t4}]];
PB:=ListLinePlot[{{{-d,0},{d,0}},{{0,-d},{0,d},{d,0},{0,-d},{-d,0},{0,d}}},PlotStyle->Black,Axes->False];
PA:=plotAssoc[A,OptionValue[pcolr],OptionValue[ncolr]];
Show[PS,PT,PB,PA, PlotRange->d+1]
];

{dDiagram[A1], dDiagram[A1,pcolr->Purple,ncolr->LightGray]}

We have several ways to modify this to apply to specific situations. For example, instead of being a diamond, Keys[A] could give lattice points to a rectangle.

Options[sDiagram]={pcolr->Orange,ncolr->Brown};
sDiagram[A_,OptionsPattern[]]:=Module[{d,sqrs,PS,PA},
sqrs=Select[Keys[A],KeyExistsQ[A,#+{1,0}]&&KeyExistsQ[A,#+{1,1}]&&KeyExistsQ[A,#+{0,1}]&];
PS:=Show[Table[sqAssoc[sqrSeq[p,A]]@@p,{p,sqrs}]];
PA:=plotAssoc[A,OptionValue[pcolr],OptionValue[ncolr]];
Show[PS,PA,Axes->True]
]

A nice application of this is the one-dimensional Descartes diagram.

d=4;
sa=\[LeftAssociation]{4}->0,{3}->1,{2}->0,{1}->0,{0}->1\[RightAssociation];

{4}→0 indicates that the coefficient of (x^4) in a polynomial is positive while {0}→1 indicates that the constant coefficient is negative, etc. We do demand an assignment for all degrees up to some degree d.

ssa=sa;AssociateTo[ssa,Table[{-j}->If[Mod[j,2]==0,sa[{j}],1-sa[{j}]],{j,d}]]

K=Flatten[Table[{i,j},{j,-1,1},{i,-d,d}],1];
As=Association[Table[p->Switch[p[[2]],-1,0,0,ssa[{p[[1]]}],1,1],{p,K}]]

sDiagram[As, pcolr->Green,ncolr->Red]

Options[descartesSketch]={pcolr->Orange,ncolr->Brown};
descartesSketch[A_,d_,OptionsPattern[]]:=Module[{SA,T,B,AA},
T=Association[Table[{x,1}->1,{x,-d,d}]];
B=Association[Table[{x,-1}->0,{x,-d,d}]];
AA=Association[Table[{x,0}->A[{x}],{x,-d,d}]];
SA=Union[B,AA,T];
sDiagram[SA,pcolr->OptionValue[pcolr],ncolr->OptionValue[ncolr]]
]

descartesSketch[ssa,4]

descartesDiagram[sa_]:=Module[{d,sqrs,PS,PA,ssa,K,A},
d=Max[Flatten[Keys[sa]]];
ssa=sa;
AssociateTo[ssa,Table[{-j}->If[Mod[j,2]==0,sa[{j}],1-sa[{j}]],{j,d}]];
descartesSketch[ssa,d,pcolr->Green,ncolr->Red]
]

Further, we have the following useful procedure to construct the association sa from a univariate polynomial, which will work for bivariate polynomials as well.

coefficientSigns[f_,X_]:=Module[{A,As},
A=Association[CoefficientRules[f,X]];
As=Association[Table[p->-(Sign[A[p]]-1)/2,{p,Keys[A]}]]
]

f=-3+2x+4x^2-3x^3+x^4;
descartesDiagram[coefficientSigns[f,x]]

In the bivariate case, we would start with an association with keys {i,j} for non-negative i, j so that i+j≦d and values 0 (for a positive coefficient) and 1 (for a negative coefficient). We can then use the Descartes–Viro rules to extend this for {i,j} with Abs[ i ]+Abs[ j ]≤d. Since (earlier in the text) we have started with a sign sequence of s, we first give an auxiliary function for d less than 10.

s2A[s_]:=Module[{n,d,A,K},
n=Length[s];
d=Which[ n==3,1,n==6,2,n==10 ,3,n==15,4,n==21,5,n==28,6, n==36,7,n==45,8,n==55,9,True,Fail];
K=Select[verts[d],(#[[1]]≥0 && #[[2]]≥0)&];
A=Association[Table[K[[i]]->s[[i]],{i,n}]]];

dvAssoc[A_]:=Module[{d,K,V,v,pver},
K=Keys[A];
d=Max[Table[Total[p],{p,K}]];
If[Length[A]≠(d+2)(d+1)/2,Echo["A must have Key {i,j} for all 0≤i,j with i+j≤d"]; Abort[]];
v=ddVerts[d];
V=<| |>;
Do[Which[p[[1]]≥0 && p[[2]]≥0,AppendTo[V,p->A[p]],
p[[1]]<0&&p[[2]]>=0&&Mod[-p[[1]],2]==0, AppendTo[V,p->A[Abs[p]]],
p[[1]]<0&&p[[2]]>=0&&Mod[-p[[1]],2]==1, AppendTo[V,p->(1-A[Abs[p]])],
p[[2]]<0&&p[[1]]>=0&& Mod[-p[[2]],2]==0, AppendTo[V,p->A[Abs[p]]],
p[[2]]<0&&p[[1]]>=0&& Mod[-p[[2]],2]==1, AppendTo[V,p->(1-A[Abs[p]])],
Sign[(-1)^p[[1]]]*Sign[(-1)^p[[2]]]==1, AppendTo[V,p->A[Abs[p]]],
Sign[(-1)^p[[1]]]*Sign[(-1)^p[[2]]]==-1, AppendTo[V,p->(1-A[Abs[p]])]],{p,v}];
V]

viroAssociation[f_,x_,y_]:=dvAssoc[coefficientSigns[f,{x,y}]];

viroDiagram[f_,x_,y_]:=dDiagram[viroAssociation[f,x,y],pcolr->Green,ncolr->Red]

f=newtonHyperbola[413,x,y];
{ dDiagram[dvAssoc[coefficientSigns[f,{x,y}]]],
RegionPlot[{f>0,f<0},{x,-20,20},{y,-20,20}, PlotStyle->{LightBrown,LightOrange}]}

As we will see, this will not always work out so that the Viro diagram gives the correct topology and Descartes’s values of the function.

We now describe some additional utility functions to enhance the diagrams. First, replace ambiguous squares with the user’s choice: the cyan curve, the magenta curve, or a normal crossing. In general, diamond diagrams do not work well in the singular case, but the normal crossing situation (where the curve crosses itself in independent directions) can be handled with care.

pickcyan[a_,b_]:=Graphics[{White,Rectangle[{a+.1,b+.1},{a+.9,b+.9}],Thick,Blue,Circle[{a+1,b+1},.5,{Pi,3Pi/2}], Circle[{a,b},.5,{0,Pi/2}]}];

pickmagenta[a_,b_]:=Graphics[{White,Rectangle[{a+.1,b+.1},{a+.9,b+.9}],Thick,Blue,Circle[{a+1,b},.5,{Pi/2,Pi}],Circle[{a,b+1},.5,{3Pi/2,2Pi}]}];

picksingularity[a_,b_]:=Graphics[{White,Rectangle[{a+.1,b+.1},{a+.9,b+.9}],Thick,Blue,Line[{{a,b+.5},{a+1,b+.5}}],Line[{{a+.5,b},{a+.5,b+1}}]}]

P1=viroDiagram[newtonHyperbola[613,x,y],x,y]

P2=Show[P1,pickcyan[-2,-1],pickmagenta[0,-1],picksingularity[0,-2]]

We can traverse this projective curve A → C → B → A so we have only one projective component. In fact, a cubic curve with this diagram would be a node.

☹ The graphics primitives used in earlier versions labelI,...,label24 do not work with Mathematica 12.  Use Graphics primitive Text instead.  See Appendix 2 Global Functions.