This notebook contains additional material to the Mathematica GuideBooks  (Springer-Verlag, New York, 2004) http://www.MathematicaGuideBooks.org . It uses the stylesheet of the Mathematica GuideBooks, which is embedded.

Graphics Volume, Chapter 1

Given a list of real numbers {(Subscript[p, 1]),(Subscript[p, 2]),…,(Subscript[p, n])} with (∑_(k=1)^n)(Subscript[p, k])=1, interpret (Subscript[p, k]) as the probability to break a 1D stick {a,b} into k parts at k-1 randomly chosen points from the interval [a,b]. Starting with the stick {0,1}, repeatedly breaking all nontrivially broken sticks (meaning once a piece of a stick was trivially “broken” with probability (Subscript[p, 1]) into one part, it will no longer be considered for further breaking) as long as the stick piece is longer than a minimal length (Subscript[l, min]). Implement a one-liner that carries out the stick breaking. Model the breaking for the probabilities {0.5,0.5}, such that more than 1000 broken pieces result. Visualize the resulting stick pieces.

breakStick[{a_, b_}, pList_, lMin_] :=
If[(* is stick longer than minimal length? *) b - a <= lMin, {a, b}, 
   If[Length[#] === 1, {#[[1]]},
      (* break recursively *)
      breakStick[#, pList, lMin]& /@ #]&[(* random break points in [a, b] *)
       Partition[Flatten[{a, Sort[Table[Random[Real, {a, b}], 
        (* number of break points *)
        {Position[Rest[FoldList[Plus, 0, 
                  (* normalize *) pList/(Plus @@ pList)]], 
                  PatternTest[_, (* random number for break points *)
                                 Evaluate[Evaluate[# > Random[]]&]], 
                               {1}, 1][[1, 1]] - 1}]], b}], 2, 1]]]

In the following example, exactly one nontrivial breaking process occurs.

SeedRandom[8]
breakStick[{0, 1}, {1/2, 1/2}, 0]

In the next example three breaks occur and we have four pieces at the end.

SeedRandom[124]
breakStick[{0, 1}, {1/2, 1/2}, 0]

To generate 1000 pieces for the probabilities {0.5,0.5}, we need a a suitable seed. The next input searches for such a seed.

Module[{r = 1, o = 2, max = 0, maxr = 0, Λ = 10^3, λ},
 While[SeedRandom[r]; 
       λ = Length[Level[breakStick[{0, 1}, Table[1/o, {o}], 0], {-2}]];
           If[λ > max, max = λ; maxr = r]; λ < Λ, r++]; r]

To visualize the broken sticks, we display their starting and ending positions ,long the x-axis and display the time at which the break occurs vertically.

stickPieceGraphics[brokenSticks_] := 
Graphics[MapIndexed[Function[{i, p}, Line[{#, Length[p]}& /@ i]], 
                    brokenSticks, {-2}], 
        Frame -> True, PlotRange -> All];

Here is the above breaking process and two others visualized.

Show[GraphicsArray[stickPieceGraphics /@
{SeedRandom[162];  breakStick[{0, 1}, {1/2, 1/2}, 0],
 SeedRandom[ 89];  breakStick[{0, 1}, {1/3, 1/3, 1/3}, 10^-6],
 SeedRandom[  3];  breakStick[{0, 1}, {1/4, 1/4, 1/4, 1/4}, 10^-6]}]]