4
$\begingroup$

Bean machine is a triangular array of pegs, Balls are dropped onto the top peg and then bounce their way down to the bottom where they are collected in little bins.Each time a ball hits one of the pegs, it bounces either left or right.

I'm trying to make a Bean machine (Galton board), probably like this effect. The problem now is slow to generate random paths, and the path is sometimes displayed incomplete. Is there a better way to achieve it? Or generate and plot in real time instead of generating all the lists first. Also, how to make real-time statistics and graphs below?

n = 10;
pts = Table[{(2 j - i)/Sqrt[3], -i}, {i, 0., n}, {j, 0, i}];

paths = Table[FoldList[ Function[{x, i}, RandomChoice@
       Select[MovingAverage[pts[[i + 1]], 2], Norm[# - x] == 2/Sqrt[3] &]], N@{0, -1}, 
 Range[2, n]], {5000}]; // AbsoluteTiming

Manipulate[
 bsf = BSplineFunction[paths[[Floor@i]], SplineDegree -> 1];
 t = FractionalPart[i];
 Graphics[{Point /@ pts, {
    Red, Dashed, Point[bsf[t]], Line@Table[bsf[t0], {t0, 0, t, 0.01}]
    }}, Axes -> True], {i, 1, Length@paths, 0.01}]

enter image description here

Updated code

Clear["`*"];
n = 10;
pts = Table[{(2 j - i)/Sqrt[3], -i}, {i, 0., n}, {j, 0, i}];
p2 = Mean@pts[[2]];

P = {};

Dynamic[Graphics[{Point /@ pts, {Red, Dashed, Arrow@Join[{p2}, P]}}, PlotLabel -> i]]
Dynamic[BarChart[SortBy[Tally[Round[A, 10^-9.]], First][[All, 2]]]]

A = {};
Do[
 P = {};
 pt = p2;
 Do[AppendTo[P, pt]; 
    pt = pt + {RandomChoice[{1, -1} /Sqrt[3]], -1}; 
    Pause@0.01, {n}]; AppendTo[A, P[[-1, 1]]], {i, 10^4}]

The animation below was created by GeoGebra Created by GeoGebra

$\endgroup$
4
  • $\begingroup$ Do you have any code for the animation you added to your question? Even if not Mathematica code? $\endgroup$
    – Jagra
    Jun 21 at 16:26
  • $\begingroup$ You might find this interesting: Flexible Galton Board $\endgroup$
    – Jagra
    Jun 21 at 16:55
  • $\begingroup$ @Jagra That animation was created by Geogebra, geogebra.org/classic/tygxktjn $\endgroup$
    – expression
    Jun 22 at 2:02
  • $\begingroup$ The Geogebra link gives you a good idea of the controls to include in your Manipulate $\endgroup$
    – Jagra
    Jun 22 at 12:47
3
$\begingroup$
ClearAll[trilattice, singlePath]
trilattice[n_] := {PointSize[Medium], 
   Point[Prepend[{0, 1}] @ (Join @@ MapIndexed[Thread[{#, -#2[[1]] + 1}] &, 
        Range[-(# + 1)/2, (# + 1)/2] & /@ Range[0, n]])]};

singlePath[length_] := Accumulate[Prepend[{0, 0}] @ 
    Thread[{RandomChoice[{1, -1}/2, length], -1}]];

Examples:

n = 10;
pth = singlePath @ n;

Animate[Graphics[{trilattice[n], Red, Dashed, Line[pth[[;; j]]], 
   AbsolutePointSize[7], Point[pth[[j]]]}], {j, 1, n + 1, 1}]

enter image description here

frames1 = Table[Graphics[{trilattice[n], Red, Dashed, Line[pth[[;; j]]], 
     AbsolutePointSize[7], Point[pth[[j]]]}], {j, n + 1}];

Export["galton1.gif", frames1, 
  AnimationRepetitions -> Infinity, "DisplayDurations" -> 1/5]

enter image description here

n = 10; 
SeedRandom[1];
joinedpaths = Join @@ Table[singlePath[n], 200];

histograms = Table[Histogram[Most @ 
 joinedpaths[[(n + 1) ;; (n + 1 + (n + 1) (Floor[j/(n + 1)])) ;; (n + 1), 
       1]],
   {MovingAverage[Range[-6, 6], 2]}, "Probability", 
    PerformanceGoal -> "Speed", ImageSize -> 1 -> 25, 
    GridLines -> {None, Range[5]/10}, 
    GridLinesStyle -> Dotted, 
    ImageSize -> 1 -> 30, 
    FrameTicks -> {{Automatic, None}, {Range[-5, 5], None}}, 
    FrameStyle -> {{LineOpacity -> 0, None}, {Automatic, Automatic}}, 
    Frame -> {{True, False}, {True, True}}, 
    PlotRange -> {{-7, 7}, {0, 1/2}}], {j, 1, Length[joinedpaths] - 1, 1}];

lines = Table[Graphics[GraphicsComplex[joinedpaths, 
   {Red, Dashed, Line[Range[(1 + Ceiling[j - (n + 1), n + 1]), j]], 
    AbsolutePointSize[7], Point@j}]], 
  {j, 1, Length[joinedpaths] - 1, 1}];

Manipulate[Column[{
    Show[Graphics[{trilattice[n]}], lines[[j]], 
     PlotRange -> {{-7, 7}, All}, FrameStyle -> Opacity[0], 
     FrameTicks -> {{Automatic, None}, {Range[-5, 5], None}}, 
     Frame -> True, ImageSize -> 1 -> 25], 
    histograms[[j]]}, 
  Alignment -> Center, Spacings -> 5], 
 {j, 1, Length[joinedpaths] - 1, 1}]

enter image description here

$\endgroup$
1
$\begingroup$

Extended comment to resources and some suggestions on strategy...

Wolfram Demonstration Project links:

I'll try to get to more of an answer over the next day or so, but until then, give some thought to simplifying your approach:

Something like the following might more directly contribute to getting/displaying what you want:

Show[
  ListPlot[pts, PlotStyle -> Black],
  ParametricPlot[bsf[t], {t, 0, 1}, 
   PlotStyle -> Directive[Red, Dashed]]
  ]]

I think it would better correspond to what you want to show, e.g., a background against which you display the action.

I further suggest that your Manipulate serve you better if it contain more manipulated inputs. These could include:

  • the number of paths you want to run,
  • how many steps or levels you want in the Galton Board,
  • probability a bay would bounce left or right,
  • ...

Lot's more about all of this in the attached links.

Again, I'll try to get to more of an answer over the next day or so.

$\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.