8

I would like to understand how can I plot Arnold tongues (see figure below) with help of Wolfram Mathematica.

enter image description here

From this question, I have borrowed the function that computes the winding number of the circle map. My own version (in order to be consistent with the figure presented above) is

WindingNumber = 
  Compile[{n, η, ϵ, ϕ0}, (Nest[# + η + ϵ*Sin[#] &, ϕ0, n] - ϕ0)/(2*Pi*n)];

Here, η is the parameter, ϕ0 is the initial value and ϵ is the parameter, too. I know that each Arnold tongue corresponds to the rational value of WindingNumber. So, my idea is to check that for a given values of ϵ and η is rational or not. To do it, I need the Wolfram Mathematica analog of RationalQ function (see discussion here). As I understand, there is no analog of RationalQ function, but in this question, I see the naive realization:

TrueQ@Element[x, Rationals]

where (as I understand) one checks that x belongs to Rationals (or not). So, I have tried to create a grid of parameters η and ϵ with help of Table. For each point of the grid, I check is WindingNumber rational or not with the help of the function written above. If true, I mark this point by 1, if false, I mark by 0, so I write

ArnoldTongues = Table[{ϵ, 2*Pi*i, 
    If[TrueQ@Element[WindingNumber [100, 2*Pi*i, 1.0, 0], Rationals], 1, 
     0]}, {i, 0, 1, 0.01}, {ϵ, 0, 1, 0.01}];

As a result, I have the array that is suitable for ListDensityPlot.

However, I obtain that the winding number is always irrational for every point on my grid, which is impossible. What am I doing wrong?

Domen
  • 23,608
  • 1
  • 27
  • 45
Artem Alexandrov
  • 803
  • 4
  • 11
  • @ChrisK , I have updated the question, now everything seems consistent – Artem Alexandrov Aug 23 '23 at 19:05
  • 1
    Your function WindingNumber only returns real numbers. Mathematica does not consider any real number to be rational. Only explicit ratios of integers are considered rational. Compare TrueQ@Element[0.25, Rationals] with TrueQ@Element[1/4, Rationals] – Bob Hanlon Aug 23 '23 at 19:53
  • @BobHanlon , okey, I can try Rationalize. But it seems useless. Does any other approach to visualize Arnold tongues in Wolfram Mathematica exist? – Artem Alexandrov Aug 23 '23 at 20:51
  • You can just Cases[wnums, wnum_ ;/ Abs[wnum - ratonal] < tol] for each rational you want and some tol, e.g. 1E-4 – I.M. Aug 24 '23 at 02:56
  • @I.M. , so, first I generate list of wnums and compare each element with a given rational with the predefined tolereance tol? Does it mean that I have to generate list of rationals, too? – Artem Alexandrov Aug 24 '23 at 07:17
  • There is a nice demo of Arnold tongues at the Wolfram Demonstration project: https://demonstrations.wolfram.com/ArnoldTongues/ – bill s Aug 30 '23 at 16:10

1 Answers1

11
(* Set compitation target, use "WVM" if no C compiler is avaliable *)
ClearAll[target] ;
target = "C" ;
ClearAll[windingNumber];
windingNumber = Compile[
    {{n,_Integer},{eta,_Real},{epsilon,_Real},{phi,_Real}},
    (Nest[# + eta + epsilon*Sin[#] &, phi, n] - phi)/(2*Pi*n),
    RuntimeAttributes -> {Listable},
    Parallelization -> True,
    CompilationTarget -> target,
    RuntimeOptions -> "Speed"
];

Generate wnums on a rectangular eta-epsilon grid:

(* Set number of iterations and grid size *)
n = 10^3;
m = 5*10^3;

(* Generate grid )
eta = 2Pi*Subdivide[0.0, 1.0, m - 1] ;
epsilon = Subdivide[0.0, 1.0, m - 1] ;


(* Set initial condition *)
phi = 0.0 ;


(* Compute winding numbers *)
wnums = Reverse[Table[windingNumber[n, eta, eps, phi], {eps, epsilon}]] ;

Plot all values:

(* Plot all winding numbers *)
ArrayPlot[wnums, DataRange -> {MinMax[eta], MinMax[epsilon]}, FrameTicks -> {{True, None}, {True, None}}, ImageSize -> 900, AspectRatio -> 1/4, PlotRangePadding -> None]

enter image description here

Filter and plot tongues:

(* Select close to a rational with a given tolerance *)
tol = 10.^-3;
rationals = {0, 1/5, 1/4, 1/3, 1/2, 2/3, 3/4, 4/5, 1} ;
ClearAll[select] ;
select[tol_, list_, rational_] := N[UnitStep[Clip[Abs[list - rational], {0.0, tol}, {-1.0, -1.0}]]] ; 
tongues = Fold[Plus, Map[select[tol, wnums, #] &, rationals]] ;
ArrayPlot[tongues, DataRange -> {MinMax[eta], MinMax[epsilon]}, FrameTicks -> {{True, None}, {True, None}}, ImageSize -> 900, AspectRatio -> 1/4, PlotRangePadding -> None]

enter image description here

I.M.
  • 2,926
  • 1
  • 13
  • 18