# Simulating Theatre puzzle

I have been trying to simulate the process of the theatre puzzle from the Joy of X (Strogatz). The puzzle, and some relevant material are here.

My simplistic coding for this process follows:

seatchoice[u_] := Module[{r, s}, r = RandomReal[]; s = RandomChoice[u];
If[And[MemberQ[u, s + 1], MemberQ[u, s - 1]],
If[r <= 0.5, Complement[u, {s, s + 1}],Complement[u, {s - 1, s}]],
If[MemberQ[u, s + 1], Complement[u, {s, s + 1}],
If[MemberQ[u, s - 1], Complement[u, {s - 1, s}],
If[And @@ (# >= 2 & /@ Differences[Sort[u]]), u,
If[Length[u] == 0, u,
seatchoice[u]]]]]]];
emptyfraction[v_] := N@Length[FixedPoint[seatchoice, Range[v]]]/v;


I have consistently found despite simulations for 100, 1000,2000 seats (recursion and iteration limits are exceeded for large inputs) that expectations are consistently approx 0.124 (versus expected approx 0.135) with narrowing bounds with increasing sample size or sample number. Further, the closed form for the expectation of number of empty seats suggests this approaches limit from above.

Question: Is this related to dependencies/other in my coding of puzzle; related to pseudorandom number generation in Mathematica; other issues

A visualization from my code is appended.

-

I am going to present several methods of simulation, hopefully in increasing order of performance.

### Method 1

We can carry out the filling of seats, at least as I understand the puzzle, quite literally like this:

fillseats[seats_List] :=
ReplacePart[seats,
{{1}, {2}} + RandomChoice @ ReplaceList[seats, {a___, 0, 0, ___} :> Length@{a}] -> 1
]

sim1[n_] := Tr @ Quiet @ FixedPoint[fillseats, 0 ~ConstantArray~ n]


Test:

sim1[1000] // Timing

{1.061, 866}


This works by first filling a list of length n with zeros, then repeatedly finding every appearance of the sequence 0, 0, randomly picking one of them, and replacing both zeros with ones. When there are no more seats to fill the simulation stops.

Tr is used to find the sum of the resultant vector, in other words the number of seats filled. It can be left out to see the actual "seat" filling.

### Method 2

Observing the mechanics of the simulation above we can see that we are always operating on pairs of positions. For example, with seven total seats there are these possible seating positions:

{{1, 2}, {2, 3}, {3, 4}, {4, 5}, {5, 6}, {6, 7}}


We can represent this by the first value of each pair: {1, 2, 3, 4, 5, 6}. When a pair of seats is filled we remove the index from the list and any remaining indexes that are $index\pm 1$. The simulation is stopped when the index list does not change, signifying that it is empty.

2 (Length[#] - 2) & is used to count the filled seats from the number of times seats are filled. (-2 is needed to account for the starting and ending values in FixedPointList that do not represent fills.)

sim2[n_] :=
FixedPointList[
DeleteCases[#2, # | # + 1 | # - 1] &[Quiet@RandomChoice@#, #] &,
Range[n - 1]
] // 2 (Length[#] - 2) &


This method is a lot faster than sim1. For example, 100 simulations each filling 1,000 seats:

1 - Sum[sim2[1000], {100}]/(100*1000) // Timing

{2.043, 0.13656}


We can rewrite sim2 in a way that proves faster for simulations with a large number of seats. Here the index list of pairs, e.g. {1, 2, 3, 4, 5, 6} is replaced by a fixed-length vector, filled with ones: {1, 1, 1, 1, 1, 1}. SparseArray Properties are used to quickly find the positions of all remaining ones. Update: moved conversion to Sparse Array outside the loop.

sim3[n_] :=
Module[{x, n1 = n - 1, i = 0},
x = SparseArray @ ConstantArray[1, {n1}];
While[Tr@x =!= 0,
i++;
x[[Clip[{-1, 0, 1} + RandomChoice @ x["AdjacencyLists"], {1, n1}]]] = 0
];
2 i
]


Timings with 10,000 seats:

sim2[10000] // Timing
sim3[10000] // Timing

{1.919, 8624}

{0.172, 8694}


### Method 3

I believe it is possible to pick the order of seat filling from the beginning and achieve the same filling probability. I generate all possible seating pairs with Partition[Range@n, 2, 1], randomize them, then simply try filling those seats in that order, moving to the next one if any requested seat is already filled.

sim4 =
Compile[{{n, _Integer}},
Module[{seats, trys},
seats = ConstantArray[0, n];
trys = RandomSample @ Partition[Range@n, 2, 1];
Do[If[seats[[i]] === {0, 0}, seats[[i]] = {1, 1}], {i, trys}];
Tr @ seats
]
];


Filling one million seats:

sim4[1*^6] // Timing

{0.359, 864766}


One thousand simulations of filling 10,000 seats:

Sum[sim4[10000], {1000}] // Timing

{3.26, 8645808}


Proportion of empty seats:

1 - (8645808 / 1*^7)

0.135419

-
Thank you very much for this polite stepwise education. My use of nested conditionals was both ugly and inefficient and I have learned (and will learn) a lot from your code examples. –  ubpdqn Dec 18 '12 at 2:39
sim4[] is wonderful...My summary: 1. Make a constant ary of zeroes to represent empty seats 2. Generate a random partition of Range[n] of size two with offset 1. This generates a possible final theatre set of side by side seats and the sample elements are just the part indices for the seats3. Fill empty side by side seats from your random sample 4. Use Magthematica's generalised trace to sum to 1s for the filled seats 5. The answer is just the complement normalized tp n...thank you as I said learned a lot! –  ubpdqn Dec 18 '12 at 3:12
@ubpdqn Glad I could help. A couple of more learned gents (than I) said sim4 is correct so apparently my caveat is unfounded. –  Mr.Wizard Dec 18 '12 at 3:50
Have been trouble with a long hyperlink and so deleted a number of comments. So using Google URL shortener here is my sharing of @Mr.Wizard sim4[] with some runs goo.gl/HVjff –  ubpdqn Dec 18 '12 at 5:17
{"extraction_info": {"found_math": true, "script_math_tex": 0, "script_math_asciimath": 0, "math_annotations": 0, "math_alttext": 0, "mathml": 0, "mathjax_tag": 0, "mathjax_inline_tex": 1, "mathjax_display_tex": 0, "mathjax_asciimath": 1, "img_math": 0, "codecogs_latex": 0, "wp_latex": 0, "mimetex.cgi": 0, "/images/math/codecogs": 0, "mathtex.cgi": 0, "katex": 0, "math-container": 0, "wp-katex-eq": 0, "align": 0, "equation": 0, "x-ck12": 0, "texerror": 0, "math_score": 0.2843458652496338, "perplexity": 3283.6250471785675}, "config": {"markdown_headings": true, "markdown_code": true, "boilerplate_config": {"ratio_threshold": 0.18, "absolute_threshold": 10, "end_threshold": 15, "enable": true}, "remove_buttons": true, "remove_image_figures": true, "remove_link_clusters": true, "table_config": {"min_rows": 2, "min_cols": 3, "format": "plain"}, "remove_chinese": true, "remove_edit_buttons": true, "extract_latex": true}, "warc_path": "s3://commoncrawl/crawl-data/CC-MAIN-2014-35/segments/1409535919066.8/warc/CC-MAIN-20140901014519-00027-ip-10-180-136-8.ec2.internal.warc.gz"}