Finding all roots with $x,y\in\Bbb Z^+$

Question

When we do a contour plot of the following function, it looks like there may be more $x,y\in\Bbb Z^+ \text{ that solve } f(x,y)=0$.

ContourPlot[
  6 + x^4*y + 6*y^2 + 11*y^3 + 6*y^4 + y^5 + 
  x^2*(6 + 11*y + 18*y^2 + 6*y^3) == 
  x*(11 + 6*y + 22*y^2 + 18*y^3 + 4*y^4 + 
  x^2*(1 + 6*y + 4*y^2)), {x, -72, 72}, {y, -72, 72}]

If we do

Reduce[6 + x^4*y + 6*y^2 + 11*y^3 + 6*y^4 + y^5 - x^3*(1 + 6*y + 4*y^2) + 
x^2*(6 + 11*y + 18*y^2 + 6*y^3) - x*(11 + 6*y + 22*y^2 + 18*y^3 + 4*y^4) == 
0&&x>0&&y>0, {x, y}, Integers]

We get $(x|y)\in \mathbb{Z}\land \left((x=1\land y=1)\lor (x=2\land (y=1\lor y=2))\lor (x=3\land (y=1\lor y=2\lor y=3))\lor \left(x\geq 5\land \left(y=\text{Root}\left[\text{$\#$1}^5+\text{$\#$1}^4 (6-4 x)+\text{$\#$1}^3 \left(6 x^2-18 x+11\right)+\text{$\#$1}^2 \left(-4 x^3+18 x^2-22 x+6\right)+\text{$\#$1} \left(x^4-6 x^3+11 x^2-6 x\right)-x^3+6 x^2-11 x+6\&,1\right]\lor y=\text{Root}\left[\text{$\#$1}^5+\text{$\#$1}^4 (6-4 x)+\text{$\#$1}^3 \left(6 x^2-18 x+11\right)+\text{$\#$1}^2 \left(-4 x^3+18 x^2-22 x+6\right)+\text{$\#$1} \left(x^4-6 x^3+11 x^2-6 x\right)-x^3+6 x^2-11 x+6\&,2\right]\lor y=\text{Root}\left[\text{$\#$1}^5+\text{$\#$1}^4 (6-4 x)+\text{$\#$1}^3 \left(6 x^2-18 x+11\right)+\text{$\#$1}^2 \left(-4 x^3+18 x^2-22 x+6\right)+\text{$\#$1} \left(x^4-6 x^3+11 x^2-6 x\right)-x^3+6 x^2-11 x+6\&,3\right]\right)\right)\right)$

It shows the last root in an odd way and doesn't give the root $f(11, 6)$ explicitly.

Is there any way to force Mathematica to provide all the integer roots?

Answer 1

You could try a direct way using NSolve:

f[x_, y_] :=6 + x^4*y + 6*y^2 + 11*y^3 + 6*y^4 + y^5 +x^2*(6 + 11*y + 18*y^2 + 6*y^3) - (x*(11 + 6*y + 22*y^2 + 18*y^3 + 4*y^4 +x^2*(1 + 6*y + 4*y^2)))

xy=NSolve[{f[x, y] == 0 && 0 <= x <= 72 && 0 <= y <= 72}, {x,y}, Integers]
(*{{x -> 1, y -> 0}, {x -> 1, y -> 1}, {x -> 2, y -> 0}, {x -> 2,y -> 1}, {x -> 2, y -> 2}, {x -> 3, y -> 0}, {x -> 3, 
y -> 1}, {x -> 3, y -> 2}, {x -> 3, y -> 3}, {x -> 5,y -> 1}, {x -> 11, y -> 6}}*)

Show[{ContourPlot[f[x, y] == 0, {x, 0, 10}, {y, 0,10}],Graphics[{Red,Point[{x, y} /. xy]}]}]