5
$\begingroup$

I was evaluating the roots of a transcendental equation, when I noticed that Mathematica never finishes but stays in the running state. The following is the code that I was using:

roots = 
  Reduce[
    Sin[z + Sin[z + Sin[z]]] == Cos[z + Cos[z + Cos[z]]] && 
    -3 < Re[z] < 3 && -3 < Im[z] < 3, 
    z] // Quiet;
$\endgroup$
1
  • 3
    $\begingroup$ As a workaround, you might try using FindAllCrossings2D[] on the real and imaginary components of your function. $\endgroup$ – J. M.'s ennui Aug 30 '15 at 5:34
5
$\begingroup$

NSolve with adequate precision works well

$Version

(* "10.2.0 for Mac OS X x86 (64-bit) (July 7, 2015)" *)

eqns = Sin[z + Sin[z + Sin[z]]] == Cos[z + Cos[z + Cos[z]]] && -3 < Re[z] < 
    3 && -3 < Im[z] < 3;

roots = NSolve[eqns, z, WorkingPrecision -> 20];

And @@ (eqns /. roots)

(* True *)

Note that there are a large number of roots

roots // Length

(* 883 *)
$\endgroup$
7
  • $\begingroup$ It's still not working yet, I did exactly the same as yours, and nothing... $\endgroup$ – Herr Schrödinger Aug 30 '15 at 9:00
  • 1
    $\begingroup$ @WaynerKlën What version of Mathematica are you using? $\endgroup$ – Michael E2 Aug 30 '15 at 12:24
  • $\begingroup$ @MichaelE2 I'm using Mathematica 9.0 ! $\endgroup$ – Herr Schrödinger Aug 30 '15 at 19:10
  • $\begingroup$ @WaynerKlën In V9, on my Macbook Pro, this answer returns 1305 roots in 151 seconds; my answer returns the 1251 just as in V10 and takes 146 seconds. (Kinda sad, the regression in V10, even though it's almost 10 times faster.) $\endgroup$ – Michael E2 Aug 30 '15 at 19:22
  • $\begingroup$ @MichaelE2 I really don't know what's happening with my calculations, perhaps my computer, Ireally don't know... Do you think that the source of this problem can be my hardware? My computer is an Intel I3 - 3,30GHz with 3,40625 GB Ram Memory. $\endgroup$ – Herr Schrödinger Sep 1 '15 at 4:01
5
$\begingroup$

I thought it interesting to ask where the roots determined by Bob Hanlon and Michael E2 lie in the complex plane.

pts = Flatten[N[roots, 15] /. Rule[_, z_] -> ReIm[z], 1];
pts2 = Flatten[N[roots2, 15] /. Rule[_, z_] -> ReIm[z], 1];

As noted in their answers, the numbers of roots are 883 and 1251. One might suppose that the first list is a subset of the second, but that is far from the case.

Length[Intersection[pts, pts2]]
Length[Complement[pts, pts2]]
Length[Complement[pts2, pts]]
(* 131
   752
   1120 *)

In all, there are 2003 distinct roots, although many lie close together. In plotting these roots, I noticed that none occurred in the region -15/10 < Re[z] < 0 && 28/10 < Im[z] < 3 and attempted to find some there

eqnsl = Sin[z + Sin[z + Sin[z]]] == Cos[z + Cos[z + Cos[z]]] && 
    -15/10 < Re[z] < 0 && 28/10 < Im[z] < 3;

using the methods described in the previous two answers. NSolve produced two more, and Solve produced ten more. All are plotted below.

ListPlot[{Complement[pts, pts2], Complement[pts2, pts], Intersection[pts, pts2], 
    Union[ptsl, pts2l]}, AspectRatio -> 1, PlotStyle -> {Blue, Green, Red, Brown}]

enter image description here

Many of the points are so close together that they are indistinguishable on the plot. The twelve roots I found are Brown. (The plot is, or should be, symmetric about the Re[z] axis.) I have high confidence that very many more points could be found with further effort, because the function given in the question oscillates extremely rapidly for larger Im[z].

Plot3D[Im[Sin[z + Sin[z + Sin[z]]] - Cos[z + Cos[z + Cos[z]]] /. 
    {z -> x + I y}], {x, 0, 3}, {y, 0, 3}, PlotPoints -> 100]

enter image description here

More PlotPoints would show more structure, although the plot soon would become unintelligible.

Addendum: Roots for z -> - Pi/4 + I y

One of the forty to fifty sets of roots visible in the first figure lies precisely at Re[z] -> -Pi/4, which allows us to take a closer look at it. The original expression in the question can be rewritten as

Nest[Sin[z + #] &, 0, 3] - Nest[Cos[z + #] &, 0, 3]
(* -Cos[z + Cos[z + Cos[z]]] + Sin[z + Sin[z + Sin[z]]] *)

Correspondingly, this expression for the set of roots under discussion can be written as

s45 = Simplify[Nest[TrigExpand[Sin[-Pi/4 + I y + #]] &, 0, 3] - 
               Nest[TrigExpand[Cos[-Pi/4 + I y + #]] &, 0, 3]]
(* -Sqrt[2] Cosh[y + (Cosh[Sinh[y]/Sqrt[2]] (Cos[Cosh[y]/Sqrt[2]] - Sin[Cosh[y]/Sqrt[2]]) 
   Sinh[y])/Sqrt[2] + (Cosh[y] (Cos[Cosh[y]/Sqrt[2]] - Sin[Cosh[y]/Sqrt[2]]) 
   Sinh[Sinh[y]/Sqrt[2]])/Sqrt[2]] (Cos[(Cosh[y + Sinh[y]/Sqrt[2]] (Cos[Cosh[y]/Sqrt[2]] + 
   Sin[Cosh[y]/Sqrt[2]]))/Sqrt[2]] + Sin[(Cosh[y + Sinh[y]/Sqrt[2]] (Cos[Cosh[y]/Sqrt[2]]
   + Sin[Cosh[y]/Sqrt[2]]))/Sqrt[2]]) *)

Conveniently, this expression is purely real, factors, and only the last factor oscillates.

Plot[Evaluate[s45[[4]]], {y, 0, 3}, ImageSize -> Large]

enter image description here

This oscillatory function can be simplified by

s45[[4]] //. Cos[v_] + Sin[v_] :> Sqrt[2] Sin[v + Pi/4]
(* Sqrt[2] Sin[π/4 + Cosh[y + Sinh[y]/Sqrt[2]] Sin[π/4 + Cosh[y]/Sqrt[2]]] *)

Consequently, roots are located at integer values of

s45ph = %[[2, 1]]/Pi
(* (π/4 + Cosh[y + Sinh[y]/Sqrt[2]] Sin[π/4 + Cosh[y]/Sqrt[2]])/π *)
Plot[s45ph, {y, 0, 3}, PlotRange -> All]

enter image description here

Most of the roots evidently are located in the range {y, 2.7, 3.0} A count of the roots can be obtained from the phase function at its first maximum, first minimum, and at y -> 3.

NMaximize[{s45ph, 0 < y < 2}, y]
NMinimize[{s45ph, 0 < y < 3}, y]
s45ph /. y -> 3.
(* {2.4042, {y -> 1.59765}}
   {-158.994, {y -> 2.60531}}
   3807.12 *)

From these values the number of roots can be estimated as 4129. If the other sets have comparable numbers of roots, the total probably is of order 200000.

$\endgroup$
4
  • $\begingroup$ Now that you mention it, the function looks awfully like the start of a fractal… $\endgroup$ – J. M.'s ennui Aug 31 '15 at 12:45
  • $\begingroup$ @Guesswhoitis. Yes, it does. I imagine that there zillions of roots (but not an infinite number). $\endgroup$ – bbgodfrey Aug 31 '15 at 12:49
  • $\begingroup$ @Guesswhoitis. My earlier estimate of a zillion roots evidently was too large. A better estimate would appear to be of order 200000, as noted in the edit to my answer. $\endgroup$ – bbgodfrey Sep 1 '15 at 2:25
  • $\begingroup$ Good analysis. That plot of s45[[4]] was frightening, tho. :) $\endgroup$ – J. M.'s ennui Sep 1 '15 at 2:27
4
$\begingroup$

In V10, Solve works, too, and gives 1251 solutions.

roots2 = Solve[eqns, z]; // AbsoluteTiming
Length@roots2

Solve::incs: Warning: Solve was unable to prove that the solution set found is complete. >>

(*
  {99.1951, Null}
  1251
*)

Maybe there are more, too. The timing is almost 6 times as long as BobHanlon's NSolve command on my computer. But the solutions are exact, so paying some price might be expected. Here is the first one:

First@roots2
(*
  {z -> Root[{Cos[Cos[Cos[#1] + #1] + #1] - Sin[Sin[Sin[#1] + #1] + #1] &, 
             -2.980629752912469515709805878534 - 2.452233595301368860424363570387 I}]}
*)

See How do I work with Root objects?, if you are unfamiliar with Root.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.