8
$\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$
  • $\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 '14 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 '14 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 '14 at 23:03
11
$\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$
  • $\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$ – Phonon Oct 28 '14 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$ – Phonon Oct 29 '14 at 13:22

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.