# Implementation of Bean machine (Galton board)

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}]


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};
[email protected], {n}]; AppendTo[A, P[[-1, 1]]], {i, 10^4}]


The animation below was created by GeoGebra

• Do you have any code for the animation you added to your question? Even if not Mathematica code? Jun 21, 2021 at 16:26
• You might find this interesting: Flexible Galton Board Jun 21, 2021 at 16:55
• @Jagra That animation was created by Geogebra, geogebra.org/classic/tygxktjn Jun 22, 2021 at 2:02
• The Geogebra link gives you a good idea of the controls to include in your Manipulate Jun 22, 2021 at 12:47

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}] @


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}]


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]


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}]


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

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,
• ...