10
$\begingroup$

The dynamic billiard demonstration, that can be found on wolfram demonstrations (here), is only designed for an ellipsoid-shape boundary(snapshot below).


A snapshot of the demonstration available on wolfram, with only ellipsoid boundaries:

enter image description here


Bunimovich stadium:

enter image description here

Characteristic: The Bunimovich stadium as boundary for the dynamical billiard, gives rise to chaotic motion.

Image taken from scholarpedia.


Details on oval-shape boundary:

  • Transformed ellipsoid, into oval (quadrupole), parametrized by the radius of curvature R of the boundary as a function of the angle $\phi$ between the tangent vector and the x-direction:

$$R(\phi)=1+\delta \cos(2\phi)$$

With $\phi \in [0,2\pi)$ (one example for could be $\delta=0.07$).

Alternatively, relation between the $x,y$ coordinates and $\phi$ are given as follows: $$ x(\phi)= \sin(\phi)+\frac{\delta}{2}\sin(\phi)+\frac{\delta}{6}\sin(3\phi) $$ $$ y(\phi)=-\cos(\phi)+\frac{\delta}{2}\cos(\phi)-\frac{\delta}{6}\cos{3\phi} $$

Some visualisation of such boundary: enter image description here


  • Are there also parametric equations for the Bunimovich stadium? Similar to the ones provided for the oval boundary.

References:

Parametrization and image from: Semiclassical Transition from an Elliptical to an Oval Billiard, by Martin Sieber.

The code for the dynamic billiard, written by Dan S. Reznik, can be found here.

$\endgroup$
3
  • $\begingroup$ Of course I know how to do all this because I've worked on it extensively, but I don't think an answer is within the scope of this Q&A format. You would have to narrow down your question to a specific Mathematica issue. I would prefer to post my own code instead of trying to modify the code you posted without any comments. $\endgroup$
    – Jens
    Oct 28, 2014 at 21:49
  • $\begingroup$ Closely related: Poincaré map for dynamic billiard. Both are essentially requests for code, building on a copy of the same demonstration authored by Dan Reznik. $\endgroup$
    – Jens
    Oct 28, 2014 at 22:40
  • $\begingroup$ Yes, using a case distinction. But as I said initially, you have to make your question more specific so that anyone who answers won't get dragged into an extended discussion trying to hit a moving target because the goal is initially set too broadly. E.g., is speed a main concern, or code readability, or user-friendliness, or extensibility to non-convex shapes, etc. Seems to me like a tutorial would be needed, too. $\endgroup$
    – Jens
    Oct 28, 2014 at 23:03

1 Answer 1

14
$\begingroup$

My defined function next find {nextpoint, nextdirection} value from {startpoint, startdirection} using NSolve.

next[{sp_, sd_}][δ_] := Module[{φ, sol, fp, fd},
  sol = NSolve[{{x[φ, δ], y[φ, δ]} == 
      sp + t sd, Abs[t] > 10^(-9), 0 <= φ < 2 π}, {t, φ}, Reals]// Quiet;
  sol = If[Length[sol] > 0, sol[[1]]];
  fp = {x[φ, δ], y[φ, δ]} /. sol;
  fd = rDirec[sd, (D[y[φ, δ], φ]/D[x[φ, δ], φ] /. sol)];
  {fp, fd}
]

and second function rDirec is to decide reflected direction that is transformed by the following diagram.

enter image description here

rDirec[d_, m_] := With[{sd = Normalize[N@d], θ = ArcTan[m]},
  RotationTransform[θ][ReflectionTransform[{0, 1}][
     RotationTransform[-θ][sd]]] // Normalize
]

This is your function for drawing.

x[φ_, δ_] := Sin[φ] + δ/2 Sin[φ] + δ/6 Sin[3φ];
y[φ_, δ_] := -Cos[φ] + δ/2 Cos[φ] - δ/6 Cos[3φ];

now you can use these next and rDirec for reflecting process of any parametric functions like this.

Manipulate[
 list = NestList[next[#][δ] &, {{x[s, δ], y[s, δ]},{1, 1.7}},20]//Quiet;
 ParametricPlot[{x[φ, δ], y[φ, δ]}, {φ, 0, 4 π},
  Epilog -> {Blue,
    Arrow[{#[[1]], #[[1]] + Normalize[#[[2]]]/5}] & /@ list,
    Black, Line[Partition[Transpose[list][[1]], 3, 1]],
    Red,
    Arrow[{list[[1, 1]], list[[1, 1]] + Normalize[list[[1, 2]]]/5}]}],
 {{δ, 0.4}, 0.1, 0.9}, {s, 0, π/4},
 ContinuousAction -> False,
 SaveDefinitions -> True
]

Blockquote

Version Update

list = {};
DynamicModule[{list,φ,p1, p2, bf = False, pf = False, df = 0.4, sf = 0},
 Manipulate[
  p1 = {x[φ, δ], y[φ, δ]};
  If[df != δ, list = {}; bf = False; pf = False]; df = δ;
  If[sf != φ, p2 = Through[{Cos, Sin}[φ + π/2]]/4]; sf = φ;
  If[! pf, 
   Graphics[Locator[Dynamic[p1 + p2, (p2 = Normalize[# - p1]/4) &]],
    Prolog -> {Blue,
      If[list =!= {} && bf, {Opacity[0.2],
        Arrowheads[Small], 
        Arrow[{#[[1]], #[[1]] + Normalize[#[[2]]]/4}] & /@ list,
        Black, Line[Partition[Transpose[list][[1]], 3, 1]],
        Red, Opacity[1], Arrowheads[Medium], 
        Arrow[{list[[1, 1]],list[[1, 1]] + Normalize[list[[1, 2]]]/4}]}],
      Black, 
      ParametricPlot[{x[θ,δ], y[θ,δ]}, {θ, 0, 4 π}][[1]],
      Orange, PointSize[Large], Point[p1], Thick, 
      Dynamic@Arrow[{p1, p1 + p2}]
      }, Axes -> True, PlotRange -> {{-1.3, 1.3}, {-1, 1}}, 
    ImageSize -> 300],
   lines = Partition[Transpose[list][[1]], 3, 1];
   Animate[Graphics[{Opacity[0.2], Line@lines[[;;t]]},
     Epilog -> {
       Black, 
       ParametricPlot[{x[θ,δ], y[θ,δ]}, {θ, 0, 4 π}][[1]],
       Orange, PointSize[Large], Point[p1], Thick, 
       Dynamic@Arrow[{p1, p1 + p2}]
       }, Axes -> True, PlotRange -> {{-1.3, 1.3}, {-1, 1}}, 
     ImageSize -> 300], {t, 1, Length[lines], 1}, Paneled -> False, 
    ControlPlacement -> Bottom]
   ],
  Pane[Row[{
     Pane[Column[{
        Row[{Button[" Run ", bf = True; pf = False; 
           list = NestList[next[#][δ] &, {{x[φ,δ], y[φ,δ]}, p2}, 10]],
          Dynamic@Button[If[! pf, " Play ", " Back "], pf = ! pf,
            Enabled -> bf, 
            Background -> If[! pf, Automatic, Orange]]}],
        Row[Button["+" <> ToString@#,
            list = Join[list, NestList[next[#][δ] &,
               If[list === {}, 
                If[bf, {{x[φ,δ], y[φ,δ]}, p2}], 
                Last[list]], #]], Enabled -> Dynamic@bf] & /@ {5, 10, 20}]}
       ], ImageMargins -> {{0, 20}, {0, 0}}],
     Pane[Column[{
        Control@{{δ, 0.4}, 0.1, 0.9},
        Control[{{φ,π/4}, 0, 2 π}]}]]}]],
  ContinuousAction -> True,
  SaveDefinitions -> True]]

Example

Blockquote

or

enter image description here

$\endgroup$
2
  • $\begingroup$ +1, There was an error in the parametrization formula I had provided, now they are corrected, you may want to edit your provided answer accordingly. Thanks $\endgroup$
    – Ellie
    Oct 28, 2014 at 22:31
  • 2
    $\begingroup$ Maybe you could add Red, Arrow[{list[[1,1]], list[[1,1]] + Normalize[list[[1,2]]]/5}] after Blue,Arrow... so that the initial position can always be found (shown in red then). $\endgroup$
    – Ellie
    Oct 29, 2014 at 13:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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