How can I make sure that the plot of this function cross each other or not?

Question

I have this function: $$\frac{1}{16} \left(\sinh (\pi x) \left(64 \left(x^2-4\right) \cosh \left(\frac{2 \pi x}{3}\right) \cos (y)+\left(x^2+4\right)^2+256 x \sinh \left(\frac{2 \pi x}{3}\right) \sin (y)\right)+\left(x^2-12\right)^2 \sinh \left(\frac{7 \pi x}{3}\right)-2 \left(x^2+4\right)^2 \sinh \left(\frac{5 \pi x}{3}\right)\right)+2 \left(x^2-4\right) \sinh \left(\frac{\pi x}{3}\right)$$ I use ContourPlot

f[x_, y_] := 
  2 (-4 + x^2) Sinh[( π x)/3] + 
   1/16 (((4 + x^2)^2 + 64 (-4 + x^2) Cos[y] Cosh[(2  π x)/3] + 
         256 x Sin[y] Sinh[(2  π x)/3]) Sinh[ π x] - 
      2 (4 + x^2)^2 Sinh[(5  π x)/
         3] + (-12 + x^2)^2 Sinh[(7  π x)/3]);

ContourPlot[f[x, y] == 0, {x, 3.42, 3.5}, {y, 0.5, 1.5}, 
 PlotPoints -> 100]

and this is the result

Then, when I diminish the ranges,

ContourPlot[
 f[x, y] == 0, {x, 3.4657283, 3.4657285}, {y, 1.046788, 1.046793}, 
 PlotPoints -> 500]

I get this plot

Now, how can I make sure whether the two curves cross each other or not?

Answer 1

You can solve for $y$ to get the two level sets. Note that the plot in the question is inaccurate, even for a high number of plot points, and it seems to think they are left/right, but actually they are top/bottom:

{f1, f2} = y /. Solve[f[x, y] == 0, y] /. C[1] -> 0;
Plot[{f1, f2}, {x, 3.45, 3.5}]

These expressions are both ArcTan of a large inner expression. We can strip the ArcTan and subtract:

result=FullSimplify[f1[[1]] - f2[[1]]]

... which gives:

-((Sqrt[2]
      Csch[\[Pi] x]^2 \[Sqrt](-x^2 (2 Cosh[(\[Pi] x)/3] + 
          Cosh[\[Pi] x])^2 (155392 - 153856 x^2 + 8608 x^4 - 144 x^6 -
           x^8 - 256 (-6 + x) (6 + x) (32 - 28 x^2 + x^4) Cosh[(
            2 \[Pi] x)/3] - 
          64 (-3776 + 2768 x^2 - 212 x^4 + 3 x^6) Cosh[(4 \[Pi] x)/
            3] - 64 (-12 + x^2) (208 - 96 x^2 + 3 x^4) Cosh[
            2 \[Pi] x] - 
          128 (-12 + x^2)^2 (-4 + x^2) Cosh[(8 \[Pi] x)/
            3] + (-12 + x^2)^4 Cosh[(10 \[Pi] x)/3]) Sinh[(\[Pi] x)/
         3]^8))/(16 - 24 x^2 + x^4 + (4 + x^2)^2 Cosh[(4 \[Pi] x)/3]))

That means they touch at a point provided this equation has a root in the vicinity of $34/10<x<35/10$. Numerically we can maximize it, but this is not a proof. This expression is always negative in the region of interest and if it went positive then you know they cross, but it appears to max out at zero:

NMaximize[{Re@result, 34/10 < x < 35/10}, x, WorkingPrecision -> 50]
(* {0, {x -> 3.4657284157760663194818753686596237797063058094688}} *)

However, we can take a subexpression from this equation and check:

Resolve[Exists[x, 34/10 < x < 35/10,
  (155392 - 153856 x^2 + 8608 x^4 - 144 x^6 - x^8 - 
     256 (-6 + x) (6 + x) (32 - 28 x^2 + x^4) Cosh[(2 \[Pi] x)/3] - 
     64 (-3776 + 2768 x^2 - 212 x^4 + 3 x^6) Cosh[(4 \[Pi] x)/3] - 
     64 (-12 + x^2) (208 - 96 x^2 + 3 x^4) Cosh[2 \[Pi] x] - 
     128 (-12 + x^2)^2 (-4 + x^2) Cosh[(8 \[Pi] x)/
       3] + (-12 + x^2)^4 Cosh[(10 \[Pi] x)/3]) == 0], Reals]
(* result: True *)

This 'proves' that a zero exists and that they do meet at a point. Though without knowing what Resolve/Exists does internally, it's not the most satisfying result.

Answer 2

Using the option MaxRecursion reduces the number of PlotPoints needed.

Clear["Global`*"]

f[x_, y_] := 
  2 (-4 + x^2) Sinh[(π x)/3] + 
   1/16 (((4 + x^2)^2 + 64 (-4 + x^2) Cos[y] Cosh[(2 π x)/3] + 
         256 x Sin[y] Sinh[(2 π x)/3]) Sinh[π x] - 
      2 (4 + x^2)^2 Sinh[(5 π x)/3] + (-12 + x^2)^2 Sinh[(7 π x)/3]);

ContourPlot[f[x, y], {x, 3.42, 3.5}, {y, 0.5, 1.5},
 PlotPoints -> 75, MaxRecursion -> 5]

If the curves intersect then the derivative in each direction should be zero at that point (a minimum in x and a maximum in y).

eqns = Assuming[342/100 < x < 35/10 && 1/2 < y < 3/2,
   Thread[D[f[x, y], {{x, y}}] == {0, 0}] // Simplify];

(sol = FindRoot[eqns, {{x, 346/100}, {y, 1}}, 
 WorkingPrecision -> 50]) // N

(* {x -> 3.46573, y -> 1.04679} *)

Verifying,

Flatten[{eqns, D[f[x, y], {x, 2}] > 0, D[f[x, y], {y, 2}] < 0}] /. 
 sol

(* {True, True, True, True} *)

Zooming in

ContourPlot[f[x, y] == 0, {x, 3.4656, 3.4659}, {y, 1.0465, 1.0472},
 PlotPoints -> 75, MaxRecursion -> 5, ContourShading -> False]