# How many times do the two given curves intersect at the origin?

I'm trying to find a way for Mathematica help me with the following (the book, ISBN: 038731802X, allows me to use any CAS / program.

Here is a question:

How many times do the two given curves intersect at the origin?

$$\quad(a)\quad y = x^3$$

which I can rewrite as $$y-x^3 = 0$$

$$\quad(b)\quad y^4 + 6x^3*y + x^8 == 0$$

I can view both curves using:

ContourPlot[{y^4 + 6 x^3*y + x^8 == 0, y - x^3 == 0}, {x, -5, 5}, {y, -5, 5}]


However, I have no idea how to find the the multiplicity of the zeros at the origin. I'm really stuck.

Count[Solve[y^4 + 6 x^3*y + x^8 == 0 /. {y -> x^3}], {x -> 0}]

(* 6 *)


You can explicitly see that the degree of intersection at $(0,0)$ is $6$ using:

p1 = y - x^3;
p2 = y^4 + 6 x^3 y + x^8;
Factor[p2 /. y -> x^3]


Also revealing is:

Factor @ GroebnerBasis[{p1, p2}, {y, x}]


Giving

{x^6 (x^6 + x^2 + 6), y - x^3}


This result is connected to Bézout's Theorem (covered in your textbook).

• I like the way you think.
– paw
Aug 16, 2014 at 20:27
• This is my favorite solution among all the ones offered. Gröbner bases are very useful! May 20, 2015 at 6:53

### General approach

If {x0, y0} is a root of a polynomial system {p1, p2} such that there is no other root of the form {x0, y1}, the multiplicity is given by the multiplicity of the zero x0 of the resultant

Resultant[p1, p2, y]


We can compute the multiplicity of this zero with

SparseArray[
CoefficientList[Resultant[p1, p2, y] /. x -> x0 + u, u]
]["NonzeroPositions"][[1, 1]] - 1


If a root {x0, y0} lines up with another root {x0, y1}, a linear transformation of the variables can always be found so that moves all the other roots off the line x = x0. So in principle, this method can be applied to any system.

OP's example

In the OP's case, the command can be simplified a little since x0 == 0:

SparseArray[
CoefficientList[Resultant[y^4 + 6 x^3*y + x^8, y^2 - x^3, y], x]
]["NonzeroPositions"][[1, 1]] - 1
(*
6
*)


### Comparison

I assume the OP wants a method, not just the answer. (The OP's is simple enough to do, plug in x^3 for y, in one's head after all.) We compare the NSolve method and @belisarius's Solve method with the Resultant method.

My original method was to use NSolve, which seems to work although the docs do not promise that it will, like this if we add Count as @belisarius did:

Count[NSolve[{p1 == 0, p2 == 0}, {x, y}], {x -> 0., y -> 0.}]


Generalizing @belisarius's answer, I would get something like

Count[Solve[p1 == 0 /. #, x, Reals] & /@ Solve[p2 == 0, y] // Flatten, x -> 0]


which indeed yields 6 on the OP's example.

A more difficult example

Now let's consider the system with y^2 replacing y in the second polynomial:

p = {y^4 + 6 x^3*y + x^8, y^2 - x^3};


The two solve-based methods give different answers:

Count[NSolve[p == {0, 0}, {x, y}], {x -> 0., y -> 0.}]
(* 9 *)

Count[Solve[p[] == 0 /. #, x, Reals] & /@ Solve[p[] == 0, y] // Flatten, x -> 0]
(* 10 *)


One solution gets counted twice in the Solve method, I guess, because the Resultant method yields

SparseArray[CoefficientList[Resultant[p[], p[], y], x]]["NonzeroPositions"][[1, 1]] - 1
(* 9 *)


Failure on repeated x0 - and the workaround

If we add some factors to the OP's system so that {x, y} = {0, 1} is a root, all the current solutions fail to yield 6:

p = {(y^4 + 6 x^3*y + x^8) (x^2 + (y - 1)^2), (y - x^3) (y - 1)};

Count[NSolve[p == {0, 0}, {x, y}], {x -> 0., y -> 0.}]
(* 3 *)

Count[Solve[p[] == 0 /. #, x, Reals] & /@ Solve[p[] == 0, y] //
Flatten, x -> 0]
(* 8 *)

SparseArray[CoefficientList[Resultant[p[], p[], y], x]]["NonzeroPositions"][[1, 1]] - 1
(* 8 *)


Edit: Actually NSolve gets close, literally. Numerical error leads to three of the roots being slightly off:

Count[Chop[NSolve[p == {0, 0}, {x, y}], 10^-50], {x -> 0, y -> 0}]
(* 6 *)


One can also use the Resultant method by transforming the coordinates so that the root {0, 1} is moved off the line x = 0:

With[{p = p /. {x -> x + y, y -> y}},
SparseArray[CoefficientList[Resultant[p[], p[], y], x]]["NonzeroPositions"][[1, 1]] - 1]
(* 6 *)


Simply switching x and y also works in this case.

Orginal answer -- NSolve gives the correct multiplicity in V10

NSolve will return the multiplicity, which turns out to be 6 in this case:

NSolve[{y^4 + 6 x^3*y + x^8 == 0, y - x^3 == 0}, {x, y}, Reals]
(*
{{x -> 0., y -> 0.}, {x -> 0., y -> 0.}, {x -> 0., y -> 0.},
{x -> 0., y -> 0.}, {x -> 0., y -> 0.}, {x -> 0., y -> 0.}}
*)


(I included a solution using Eliminate but it's not worth the space it would take up.)

• Thank you very much for the help, Michael. Aug 16, 2014 at 2:19
• @MichaelE2 Could you help me understand why Solve would only return one set of {x -> 0., y -> 0.}? Aug 16, 2014 at 5:10
• @seismatica the command returned the following: {{{x -> 0, y -> 0}, 1}} :( I'm going crazy with this issue. Aug 16, 2014 at 5:26
• @seismatica I'm using exactly (copy/past) and even typping the exact commands. Only the command of belisarius worked so far. Aug 16, 2014 at 5:30
• @LuizRobertoMeier See mathematica.stackexchange.com/questions/18393/… Aug 17, 2014 at 21:48

This is not an answer, but is too long for a comment. NSolve produces different results for

NSolve[{y^4 + 6 x^3*y + x^8 == 0, y - x^3 == 0}, {x, y}, Reals]


according to the Mathematica version it is evaluated in.

In V9, it produces

{{x -> 0, y -> 0}}


while in V10 it produces

{{x -> 0., y -> 0.}, {x -> 0., y -> 0.}, {x -> 0., y -> 0.},
{x -> 0., y -> 0.}, {x -> 0., y -> 0.}, {x -> 0., y -> 0.}}


In my opinion, the V10 result is clearly to be preferred.

• Does Solve have different results between these two versions? I don't have MMA 9 to compare. Aug 16, 2014 at 17:51
• I am with all working fine with my update to V10. Also I notice that in V9 I can get the same answers when I don't explicitly use Reals and instead I use Tally[] and/or Select[] to filter '0.' instead of 0 Also, the study of curves isn't only about (0.,0.) but where n curves will touch m times , including projective geometry (curves / objects / points going to infinity). Aug 16, 2014 at 23:27