28 Bitangents on a Real Plane Quartic

It is an interesting fact that there are plane quartic curves \(TraditionalForm
      \`∑\_\(i + j ≤ 4\)\(a\_\(i  j\)\) \(x\^i\) y\^j = 0\) which have 28 real bitangents in the real x - y plane [Shioda 1995]. A bitangent is a line which is tangent to two points of a given curve at the same time. Here we will explicitly calculate all 28 bitangents for the quartic

(12^2) ((x^4) + (y^4)) - (15^2) ((x^2) + (y^2)) + 
              350  (x^2) (y^2) + 81=0. 

This quartic is symmetric with respect to x and y. In the following we will make use of the symmetry \(TraditionalForm
      \`under  the  exchange  of  variables  x ↔ \ \(y.\)\)

p[x_, y_] = 
      (12^2) ((x^4) + (y^4)) - (15^2) ((x^2) + (y^2)) + 350  (x^2) (y^2) + 
        81

We implement the calculation of the discriminant of a polynomial, defined as the resultant of a polynomial and its derivative. We will later on make use of the obvious fact that a polynomial has a double root if and only if its discriminant vanishes.

Discriminant[𝓅_, x_] := 
      Factor[Resultant[𝓅, (∂_x) 𝓅, x]] /; 
        PolynomialQ[𝓅, x]

Using the function ContourPlot we can visualize the quartic under interest. Its shape resembles two intersecting ellipses. This is not accidental. If one takes an ellipse ((x^2)/(a^2))+((y^2)/(b^2))-1 = 0 and its image after rotation by (π/2), namely ((x^2)/(b^2))+((y^2)/(a^2))-1=0, multiplies these  two implicit representations and adds a constant C  to make the resulting polynomial irreducible (adding the constant C means, geometrically speaking, smoothing out the cusps at the points of intersection of the two ellipses) one obtains
 
(((x^2)/(a^2))+((y^2)/(b^2))-1)(((x^2)/(b^2))+((y^2)/(a^2))-1)-C \(TraditionalForm
      \`\( = α\)\_1\ \((x\^4 + y\^4)\) + 
        α\_2\ \((x\^2 + y\^2)\) + \(α\_3\) x\^2\ y\^2 + 
        α\_4\), 

a quartic similar in form to the above.

quartic = 
      ContourPlot[Evaluate[p[x, y]], {x, -1.5, 1.5}, {y, -1.5, 1.5}, 
        Contours -> {0}, PlotPoints -> 80, 
        ContourLines -> False, 
        ColorFunction -> (GrayLevel[If[# > 0, 1, 0.5]]&)];

The 28 bitangents are formed in the following way: There are 6 possibilities for picking two out of the four regions. Each of these pairs of regions will have four bitangents, two on the outside boundaries and two crossing ones. This makes 24 bitangents. Additionally there are 4 bitangents on the inner side of every region itself parallel to the x- and y-axes. Taking them all together results in 28 real bitangents.

Exact Calculation of the 28 Bitangents

In the following we will in a heuristic manner calculate most of these tangents. At the end we give a general method of calculation.

Looking at the quartic p[x,y],  it becomes obvious that one class of bitangents will be parallel to the x- and y-axes. Assuming x = a we get the following equation for the intersection of the line  x = a with our quartic.

(Subscript[r, 1]) = Factor[Resultant[p[x, y], x - a, x]]

The condition that this intersection be a tangent requires the last equation to have a double root for y, so using the above defined function Discriminant we get:

(Subscript[d, 1]) = Discriminant[(Subscript[r, 1]), y]

Solving for a,  we have the following result:

(Subscript[s, 1]) = Union[Solve[(Subscript[d, 1]) == 0, a]]

We sort out all imaginary solutions and all lines which do not have exactly two common points with our quartic (the condition for a bitangent).

\(goodSolutionQ[sol_] := 

      \(\((Length[Union[#]] === 2 && Union[Im[y /. #]] == {0})\)&\)[\ 		

        		\ \ \ \ \ \ \ \ 		\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 
        Solve[\((p[a, y] /. sol)\) == 0, y]]\)

(Subscript[s, 1]) = Select[(Subscript[s, 1]), goodSolutionQ]

The points of intersection corresponding to these values of a are given by:

(Subscript[t, 1]) = 
      Union[Flatten[
          Function[s, 
              (Point[{a /. s, #}]&)/@
                (y /. Solve[(p[a, y] /. s) == 0, y])]/@(Subscript[s, 1])]]

Here we show the four bitangents that are parallel to the y-axis, as well as the equivalent ones which are parallel to the x-axis (here we use the above mentioned  x ↔ y symmetry of p[x,y]).

opts  = 
       {PlotRange -> {{-1.25, 1.25}, {-1.25, 1.25}}, 
        Frame -> False, Axes -> False};

(Subscript[x, min]) = -(3/2);   (Subscript[x, max]) = (3/2);

Show[{quartic,
		       (Subscript[B, 1])=Graphics[{Thickness[0.0001],PointSize[0.012],
					(Line[{{#, (Subscript[x, min])}, {#, (Subscript[x, max])}}]&)/@
                        (a /. (Subscript[s, 1])),\(Map[Reverse, 
					
                        \((Line[{{#, x\_min}, {#, x\_max}}]&)\)/@
                          \((a /. s\_1)\), {3}]\),
					(Subscript[t, 1]),Map[Reverse, (Subscript[t, 1]), {2}]}]},opts];

The second class of bitangents will be the ones crossing between opposite segments of the quartic. Because of the symmetry of the quartic under consideration, these lines will go through the origin. Proceeding as above, we calculate the intersection of the quartic with a line y=ax. We have:

(Subscript[r, 2]) = Factor[Resultant[p[x, y], y - a  x, x]]

Again requiring that for a tangent we have a double zero, we get:

(Subscript[d, 2]) = Discriminant[(Subscript[r, 2]), y]

We can easily solve for possible a's.

(Subscript[s, 2]) = Union[Solve[(Subscript[d, 2]) == 0, a]]

Selecting again the right a's we finally arrive at the following values for a:

\(goodSolutionQ[sol_] := 
      \(Im[a /. sol] === 0 && 

            \((Length[Union[#]] === 2 && \ Union[Im[x /. #]] === {0})\)&\)[

        \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 		\ \ \ \ \ \ \ \ \ \ \ \ \ 	
        Solve[\((p[x, a  x] /. sol)\) == 0, x]]\)

(Subscript[s, 2]) = Select[(Subscript[s, 2]), goodSolutionQ]

The points of intersection of these bitangents with the quartic are:

(Subscript[t, 2]) = 
      Union[Flatten[
          Function[s, 
              (Point[{#, a  # /. s}]&)/@
                (x /. Solve[(p[a  x, x] /. s) == 0, x])]/@(Subscript[s, 2])]]

Here we show the four bitangents that go through the origin:

\(\(Show[{quartic, 
		
        B\_2 = Graphics[{Thickness[0.0001], PointSize[0.015], 
              \((Line[{{x\_min, \(x\_min\) #}, {x\_max, \(x\_max\) #}}]&)\)/@
                \((a /. s\_2)\), t\_2}]}, opts]; \)\)

Taking into account the symmetry of the quartic under consideration, it becomes obvious that a third class of bitangents—the outer ones for adjacent regions—are parallel to the lines y = x or y = -x . So this time we look for bitangents of the form  y = x + m. The resulting equation for m is:

(Subscript[r, 3]) = Factor[Resultant[p[x, y], y - x - m, x]]

We have a tangency condition if m satisfies the following equation:

(Subscript[d, 3]) = Discriminant[(Subscript[r, 3]), y]

This gives the following possible values for m:

(Subscript[s, 3]) = Union[Solve[(Subscript[d, 3]) == 0, m]]

Selecting the real values we have:

(Subscript[s, 3]) = Select[(Subscript[s, 3]), Im[m /. #] == 0&]

The corresponding points where these lines meet the quartic are given by:

(Subscript[t, 3]) = 
      Union[Flatten[
          Function[s, 
              (Point[{#, # + m /. s}]&)/@
                (x /. Solve[(p[x + m, x] /. s) == 0, x])]/@
            (Subscript[s, 3])]]

Here are these eight bitangents:

\(\(Show[{quartic, 
		
        B\_3 = Graphics[{Thickness[0.0001], PointSize[0.015], 
              \((Line[{{x\_min, \ \ \ x\_min + #}, {x\_max, \ x\_max + #}}]&)
                  \)/@\((m /. s\_3)\), 
              \((Line[{{x\_min, \(-x\_min\) - #}, {x\_max, 
                          \(-x\_max\) - #}}]&)\)/@\((m /. s\_3)\), t\_3, 
              Map[{1, \(-1\)}\ #1&, t\_3, {2}]}]}, opts]; \)\)

Now comes the final class of bitangents, the crossing ones between adjacent regions of the quartic. This time we have to take into account a general form of a line y = m x  +  b. The resulting lines will have nonobvious values for m and b.

The condition of being a bitangent means that there are two points ((Subscript[x, 1]), (Subscript[y, 1])) and  ((Subscript[x, 2]), (Subscript[y, 2])) which are are tangent and that the slope of the line through ((Subscript[x, 1]), (Subscript[y, 1])) and  ((Subscript[x, 2]), (Subscript[y, 2])) has the same slope as the slope at ((Subscript[x, 1]), (Subscript[y, 1])) and  ((Subscript[x, 2]), (Subscript[y, 2])). Additionally we want the two points  ((Subscript[x, 1]), (Subscript[y, 1])) and  ((Subscript[x, 2]), (Subscript[y, 2])) to be distinct. In the following GroebnerBasis calculation we can force this by using the equation \(TraditionalForm
      \`1 - z\ \((\((x\_1 - x\_2)\)\^2 + \((y\_1 - y\_2)\)\^2)\)\) where z is a new variable. These conditions translate into the following set of equations:

\(\(Numerator\ [Together[#]]&\)[

        			{\(y\_2 - y\_1\)\/\(x\_2 - x\_1\) + 
            ∂\_\(x\_1\)p[x\_1, y\_1]\/∂\_\(y\_1\)p[x\_1, 
                  y\_1], \(y\_2 - y\_1\)\/\(x\_2 - x\_1\) + 
            ∂\_\(x\_2\)p[x\_2, y\_2]\/∂\_\(y\_2\)p[x\_2, 
                  y\_2], 
				p[x\_1, y\_1], p[x\_2, y\_2], 
			
          1 - z \((\((x\_1 - x\_2)\)\^2 + \((y\_1 - y\_2)\)\^2)\)}] /. {
        y\_1 -> \ m\ x\_1 + b, \ y\_2 -> m\ x\_2 + b}\)

We now eliminate the variables (Subscript[x, 1]), (Subscript[x, 2]), and z to obtain a set of equations for m and b.

gb = 
      Factor/@ GroebnerBasis[%, {m, b}, {(Subscript[x, 1]), (Subscript[x, 2]), z}, 
          MonomialOrder -> EliminationOrder]

mbPolys=Last /@ gb;

By choosing to eliminate b from all possible combinations of the above equations, and by keeping equations with real solutions for m, we get the following set of equations.

Select[
      Union[Flatten[
          Table[Cases[
              Factor[Resultant[
                  mbPolys[[i]], 
                  mbPolys[[j]], 
                  b]], _Plus?(MemberQ[#, m, ∞]&), 
              ∞], {i, Length[mbPolys]}, {j, i + 1, 
              Length[mbPolys]}]]], 
      And@@(Im[#] == 0&)/@
            (m /. {ToRules[Roots[# == 0, m, Quartics -> False]]})
              &]

Within this approach we find all finite values for b and m, and we also obtain the equations m = 1, m = -1, and 49 - 150 (m^2) + 49 (m^4)from above. After checking the explicit numerical values, we recognize that the last equation for m we are looking for is given by 936 - 17503 (m^2) + 936 (m^4). In a similar manner one can obtain the equation for b, namely 279  -  775  (b^2)  +  104  (b^4) = 0. (The additional equations we got for b and m would lead to complex ((Subscript[x, 1]), (Subscript[y, 1])) and  ((Subscript[x, 2]), (Subscript[y, 2])) and are not of interest here.)

A much easier and faster way than using algebraic techniques like Resultant and GroebnerBasis is to use a numerical approch to calculate the remaining bitangents numerically.

For the two points ((Subscript[x, 1]), (Subscript[y, 1])) and  ((Subscript[x, 2]), (Subscript[y, 2])) itself we get following system 𝒮 of polynomial equations.

\(𝒮 = 
      Numerator\ @
        \(Together@

          			{\(y\_2 - y\_1\)\/\(x\_2 - x\_1\) + 
              ∂\_\(x\_1\)p[x\_1, y\_1]\/∂\_\(y\_1\)p[
                    x\_1, y\_1], 
            \(y\_2 - y\_1\)\/\(x\_2 - x\_1\) + 
              ∂\_\(x\_2\)p[x\_2, y\_2]\/∂\_\(y\_2\)p[
                    x\_2, y\_2], p[x\_1, y\_1], p[x\_2, y\_2]}\)\)

Using the function FindRoot with starting values appropriate for a bitangent which touches the lower part of the quartic at the right side and the right side of the quartic at the upper end, we find these tangency points.

\(s\_4 = 
      FindRoot[Evaluate[\(# == 0&\)/@𝒮], 

        		\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {x\_1, 0.7}, {
          y\_1, 0.4}, {x\_2, 0.4}, {y\_2, \(-0.7\)}]\)

Using these points we can calculate the parameters m and b.

{m, b} = {(((Subscript[y, 2]) - (Subscript[y, 1]))/((Subscript[x, 2]) - (Subscript[x, 1]))) /. (Subscript[s, 4]), 
        (Subscript[y, 1]) - (((Subscript[y, 2]) - (Subscript[y, 1]))/((Subscript[x, 2]) - (Subscript[x, 1]))) (Subscript[x, 1]) /. (Subscript[s, 4])}

These values are in agreement with the roots of the above derived equations for m and b.

\(Module[{m, b}, 

      	{\(NRoots[936 - 17503\ m\^2 + 936\ m\^4 == 0, m]
            \)[[\(-1\), 2]], 
        \(NRoots[279 - 775\ b\^2 + 104\ b\^4 == 0, b]\)[[1, 
          2]]}]\)

Thus we have found the following eight bitangents:

\(\(Show[{quartic, 
		
        B\_4 = Graphics[{Thickness[0.0001], PointSize[0.015], 
	
              With[{twoTangents = 
                    N@{Line[{{x\_min, \(x\_min\) m + b}, {x\_max, 
                              \(x\_max\) m + b}}], 
                        Map[Reverse[\(-#\)]&, 
                          Line[{{x\_min, \(x\_min\) m + b}, {x\_max, 
                                \(x\_max\) m + b}}], {2}], {
                            Point[{x\_1, y\_1}], Point[{x\_2, y\_2}]} /. 
                          s\_4, {Point[{\(-y\_1\), \(-x\_1\)}], 
                            Point[{\(-y\_2\), \(-x\_2\)}]} /. s\_4}}, 

                Table[Map[{{Cos[φ], Sin[φ]}, {
                            \(-Sin[φ]\), Cos[φ]}}.#&, 
                    twoTangents, {\(-2\)}], {φ, 0, 3  π/2, 
                    π/2}]]}]}, \ opts]; \)\)

Finally, all 28 bitangents shown together.

Show[{quartic, (Subscript[B, 1]), (Subscript[B, 2]), (Subscript[B, 3]), (Subscript[B, 4])}, opts];

References

Blum, R. and Guinand, A. P.,  Canad. Math. Bull. 7, 399 (1964).
Cox, D., Little, J., O'Shea, D., Ideals, Varieties, and Algorithms, Springer, New York 1992.
Coxeter, H. S. M. Am.Math.Monthly 75,5 (1968).
Edge, W. L., Proc. Royal Soc. Edinburgh 124 A, 729 (1994).
Kimberling, C., The Mathematics Teacher 89, 1, 26 (1996).
Shioda, F.,  Comm. Math. Univ. Sancti Pauli 44, 109 (1995).
Söddy, F. Nature 137,1021 (1936).
Trott, M. The Mathematica Guidebook, TELOS-Springer, 1997.