Python Code to Mathematica for Classical Map of Kicked Top

Question

I am trying to convert this Python code for Classical map of kicked top to Mathematica.

For a single trajectory, I am able to write the code properly.

Here is the converted code

(*Parameters*)
p = 1.73;
k = 2.0;

(*Defining the mapping function (classical map of a quantum kicked \
top)*)
F[x_, y_, z_] := Module[{z1, x1, y1},
  z1 = z*Cos[p] - x*Sin[p];
  x1 = (x*Cos[p] + z*Sin[p])*Cos[k*z1] - y*Sin[k*z1];
  y1 = (x*Cos[p] + z*Sin[p])*Sin[k*z1] + y*Cos[k*z1];
  {x1, y1, z1}]

(*Parameters*)
n = 500;
(*Number of iterations*)
x0 = 0.5;
z0 = -0.3;
y0 = Sqrt[1 - Round[x0^2 + z0^2, 10^-15]];

(*Data storing space for x,y,and z for 'n' iterations*)

x = Table[0, {n}];
y = Table[0, {n}];
z = Table[0, {n}];

(*Storing initial points*)
x[[1]] = x0;
y[[1]] = y0;
z[[1]] = z0;

(*Iterations*)
For[i = 2, i <= n, 
 i++, {xi, yi, zi} = F[x[[i - 1]], y[[i - 1]], z[[i - 1]]];
 (*Mapping x,y,z*)
 (*Storing the data of new x,y,z*)
 x[[i]] = xi;
 y[[i]] = yi;
 z[[i]] = zi;]

(*Plotting*)
ListPlot[Transpose[{x, z}], PlotStyle -> PointSize[0.01],
  AxesLabel -> {"X", "Z"}, PlotLabel -> "Single trajectory"]

However, some problems arise when I try to convert the second part. Even though there is no error, it keeps on running and no results come.

Here is the code

(*Parameters*)
n = 100;(*number of iterations*)
num = 21;

(*Data storing space of x,y,and z for'n' iterations*)

x = Table[0, {n}];
y = Table[0, {n}];
z = Table[0, {n}];

(*Initial points*)
x0data = Range[-1, 1, (2/num)];
z0data = Range[-1, 1, (2/num)];

(*Create plots*)
{plot1, plot2} = 
  ListLinePlot[{}, PlotRange -> {{-1, 1}, {-1, 1}}, AspectRatio -> 1, 
     ImageSize -> 400, PlotStyle -> PointSize[0.01], 
     AxesLabel -> {"X", "Z"}, PlotLabel -> "Initial points"] & /@ {1, 
    2};

contnopoints = 0;

(*Iteration*)
For[i = 1, i <= Length[x0data], i++,
 For[j = 1, j <= Length[z0data], j++,
  If[Round[x0data[[i]]^2 + z0data[[j]]^2, 0.00000000000001] <= 1, 
   contnopoints++;
   x[[1]] = x0data[[i]];
   z[[1]] = z0data[[j]];
   y[[1]] = 
    Sqrt[1 - 
      Round[x0data[[i]]^2 + z0data[[j]]^2, 0.000000000000001]];
   For[k = 2, k <= n, 
    k++, {xi, yi, zi} = F[x[[k - 1]], y[[k - 1]], z[[k - 1]]];
    (*mapping x,y,z*)
    x[[k]] = Round[xi, 0.0000001];
    y[[k]] = Round[yi, 0.0000001];
    z[[k]] = Round[zi, 0.0000001];
    If[xi^2 + yi^2 + zi^2 > 1.001, 
     Print["At i =", i, " x or y or z in negative. ", 
       xi^2 + yi^2 + zi^2];]];
   plot1 = 
    Show[plot1, 
     ListPlot[{{x0data[[i]], z0data[[j]]}}, 
      PlotStyle -> PointSize[0.01]]];
   plot2 = 
    Show[plot2, 
     ListLinePlot[Transpose[{x, z}], 
      PlotStyle -> PointSize[0.005]]];]]]

(*Display plots*)
Show[{plot1, plot2}, ImageSize -> 200]

(*Plot titles,labels,etc.*)
plot1 = 
 Show[plot1, 
  PlotLabel -> 
   "Initial points, no. of points = " <> ToString[contnopoints]]
plot2 = Show[plot2, 
  PlotLabel -> 
   "Phase Space(Y0>0)  p=k,\n n = " <> ToString[contnopoints]]

(*Export plots if needed*)
(*Export["PhaseSpace_k4.png",{plot1,plot2}]*)

The plots should come as this

Please help me resolve this problem. Thank you

Answer 1

p = 1.73;
k = 2.0;
F[x_, y_, z_] := Module[{z1, x1, y1}, z1 = z*Cos[p] - x*Sin[p];
  x1 = (x*Cos[p] + z*Sin[p])*Cos[k*z1] - y*Sin[k*z1];
  y1 = (x*Cos[p] + z*Sin[p])*Sin[k*z1] + y*Cos[k*z1];
  {x1, y1, z1}]
x0 = 0.5;
z0 = -0.3;
y0 = Sqrt[1 - Round[x0^2 + z0^2, 10^-15]] // N;
n = 500;
ListPlot[NestList[F @@ # &, {x0, y0, z0}, n - 1][[All, {1, 3}]], 
 PlotLabel -> "Single trajectory", Axes -> False, Frame -> True, 
 FrameLabel -> {{"Z", ""}, {"X", ""}}]
Clear[x0, y0, z0, n, p, k]

p = 1.73;
k = 2.0;
F[x_, y_, z_] := Module[{z1, x1, y1}, z1 = z*Cos[p] - x*Sin[p];
  x1 = (x*Cos[p] + z*Sin[p])*Cos[k*z1] - y*Sin[k*z1];
  y1 = (x*Cos[p] + z*Sin[p])*Sin[k*z1] + y*Cos[k*z1];
  {x1, y1, z1}]
ta = {#[[1]], 
     Sqrt[1 - Round[#[[1]]^2 + #[[2]]^2, 10^-15]] // N, #[[2]]} & /@ 
   Flatten[Table[
     If[i^2 + j^2 <= 1, {i, j}, Nothing], {i, -1, 1, 0.1}, {j, -1, 1, 
      0.1}], 1];
ListPlot[List /@ ta[[All, {1, 3}]], AspectRatio -> Automatic, 
 PlotLabel -> 
  "Initial points, no. of points = " <> ToString[Length@ta], 
 Axes -> False, Frame -> True, FrameLabel -> {{"Z", ""}, {"X", ""}}]
n = 500;
ListPlot[Table[
  NestList[F @@ # &, ta[[i]], n - 1][[All, {1, 3}]], {i, 1, 
   Length@ta}], 
 PlotLabel -> 
  "Phase Space(Y0>0)  p=" <> ToString[p] <> ", k=" <> ToString[k], 
 Axes -> False, Frame -> True, FrameLabel -> {{"Z", ""}, {"X", ""}}, 
 AspectRatio -> Automatic]
Clear[x0, y0, z0, n, p, k, ta]