6
$\begingroup$

How do I enumerate a sample space with up to 6 coin tosses where 4 Heads ensures a win. For e.g {HHHH},{HTHHH},{TTHHHH},{HTTHHH} etc.I tried the following but I do not know how to do a variable length selection in patterns

Select[Tuples[{H, T}, 6], Counts[#][H] == 4 &]

but it does not stop for cases where 4 heads or 1 Tails and 4 heads occur.

$\endgroup$
2
  • $\begingroup$ "it does not stop for cases where 4 heads or 1 Tails and 4 heads occur." - Tuples[list, n] will only generate lists of length n, so where would "4 heads or 1 Tails and 4 heads" come from? $\endgroup$ Dec 18, 2015 at 16:22
  • $\begingroup$ Yes. I agree but I want to generate 4 and 5 element lists that match the criteria i.e. {HHHH},{THHHH} and only 6 element subsets with 4 heads $\endgroup$
    – arvind
    Dec 18, 2015 at 16:30

5 Answers 5

7
$\begingroup$
StringJoin /@ (Permutations[{"H", "H", "H", "H", "T", "T"}, {6}] //. {a__, "T"} :> {a})

{"HHHH", "HHHTH", "HHHTTH", "HHTHH", "HHTHTH", "HHTTHH", "HTHHH", "HTHHTH", "HTHTHH", "HTTHHH", "THHHH", "THHHTH", "THHTHH", "THTHHH", "TTHHHH"}

$\endgroup$
1
  • $\begingroup$ Yep! That's it! $\endgroup$ Dec 18, 2015 at 19:13
7
$\begingroup$

Just for fun you can model this situation as a discrete Markov process. In the following state 1 is 0 heads, state 2 is 1 head,...state 5 is 4 or more heads (and an absorbing state). You can simulate and use a stopping function once random function goes into state 5. I have assumed probability of heads 1/2 but of course you could change for fun...

markov =
  {{1/2, 1/2, 0, 0, 0},
   {0, 1/2, 1/2, 0, 0},
   {0, 0, 1/2, 1/2, 0},
   {0, 0, 0, 1/2, 1/2},
   {0, 0, 0, 0, 1}};
rfun[n_] := 
  RandomFunction[dm, {0, 6}, n, 
   Method -> {Automatic, 
     "StoppingFunction" -> Function[{len, pos}, pos != 5]}];
fun[n_] := 
 Module[{ans = (StringJoin @@@ ((Differences[#[[All, 2]]] & /@ 
          rfun[n]["Paths"]) /. {0 -> "T", 1 -> "H"}))}, 
  Row[{Column[
     Quiet[ans /. {x_?(StringLength[#] <= 6 &) :> 
         Style[x, Red, Bold]}], Frame -> True], 
    Count[ans, _?(StringLength[#] <= 6 &)]/n, 
    PDF[dm[6], k] // PiecewiseExpand}]]

Some examples of sample size 10. The highlighted (in red) are those that stop <=6 coin flips. This small size just for visualization.

Row[Table[fun[20], {3}]]
Graph[dm]

enter image description here

$\endgroup$
3
$\begingroup$

Since I suspect that David G. Stork is correct (see comments below), here is a way to get the "winning" terminating sequences:

Join[{"HHHH"}
 , StringJoin /@ Permutations[Append[ConstantArray["H", 4], "T"]]
 , StringJoin[Join[#, {"H"}]] & /@ Permutations[{"H", "H", "H", "T", "T"}]
]
(* {"HHHH", "HHHHT", "HHHTH", "HHTHH", "HTHHH", "THHHH", "HHHTTH", "HHTHTH", "HHTTHH", "HTHHTH", "HTHTHH", "HTTHHH", "THHHTH", "THHTHH", "THTHHH", "TTHHHH"} *)

To automate:

winningRolls[toWin_Integer, maxRolls_Integer] /; maxRolls >= toWin := 
  Flatten@Table[
    StringJoin[Join[#, ConstantArray["H", kk]]] & /@ Permutations[Join[ConstantArray["H", toWin - kk], ConstantArray["T", kk]]]
    , {kk, 0, maxRolls - toWin}
   ]
winningRolls[4, 7]
(* {"HHHH", "HHHTH", "HHTHH", "HTHHH", "THHHH", "HHTTHH", "HTHTHH", "HTTHHH", "THHTHH", "THTHHH", "TTHHHH", "HTTTHHH", "THTTHHH", "TTHTHHH", "TTTHHHH"} *)

Here's a way:

StringJoin /@ Flatten[Permutations[Join[#, ConstantArray["H", 4]]] & /@ {{"T"}, {"T", "T"}}, 1]
(* {"THHHH", "HTHHH", "HHTHH", "HHHTH", "HHHHT", "TTHHHH", "THTHHH", "THHTHH", "THHHTH", "THHHHT", "HTTHHH", "HTHTHH", "HTHHTH", "HTHHHT", "HHTTHH", "HHTHTH", "HHTHHT", "HHHTTH", "HHHTHT", "HHHHTT"} *)

Or, if you want to generate the lists somewhat programmatically.

numHeadsToWin = 4;
numRollsList = {5, 6};
StringJoin /@ Flatten[Permutations /@ IntegerPartitions[numHeadsToWin, numRollsList, {0, 1}] /. {1 -> "H", 0 -> "T"}, 1]
(* {"HHHHTT", "HHHTHT", "HHHTTH", "HHTHHT", "HHTHTH", "HHTTHH", "HTHHHT", "HTHHTH", "HTHTHH", "HTTHHH", "THHHHT", "THHHTH", "THHTHH", "THTHHH", "TTHHHH", "HHHHT", "HHHTH", "HHTHH", "HTHHH", "THHHH"} *)
$\endgroup$
4
  • $\begingroup$ But it isn't what you asked for. For instance, it does not give the case you explicitly requested: "it does not stop for cases where 4 heads...". $\endgroup$ Dec 18, 2015 at 17:06
  • $\begingroup$ @DavidG.Stork. I had a hard time interpreting that statement by the OP. What do you think it means exactly? (Perhaps it means, for instance, that "THHHHT" shouldn't be allowed, because the person would already have "won" on "THHHH"?) $\endgroup$
    – march
    Dec 18, 2015 at 17:24
  • $\begingroup$ I interpret the question to be: "select any set of sequences of H and T, up to length 6, that contains exactly four Hs, stopping when those four Hs have appeared." Thus {HHHH} should be presented and {THHHHT} should not be presented. $\endgroup$ Dec 18, 2015 at 17:28
  • $\begingroup$ @arvind! Please see the updated post. I would like to know if the comments above are correct. Also: it is customary to upvote a question that you have accepted. $\endgroup$
    – march
    Dec 18, 2015 at 17:54
3
$\begingroup$

Here is an inelegantly programmed solution, which can be streamlined, if you wish.

Here is a list of all strings of length exactly 6 that have exactly 4 Hs:

xxx = StringJoin /@ 
  Select[Tuples[{"H", "T"}, 6], Counts[#]["H"] == 4 &]

(* {"HHHHTT", "HHHTHT", "HHHTTH", "HHTHHT", "HHTHTH", "HHTTHH", "HTHHHT", "HTHHTH", "HTHTHH", "HTTHHH", "THHHHT", "THHHTH", "THHTHH", "THTHHH", "TTHHHH"} *)

If the last letter in a string is a T, then that string is "useless" (because the game would have already ended) and should be deleted. Here's a set that has this property, i.e., is either a length-6 string ending in H or a length-5 string with exactly 4 Hs:

yyy = If[StringEndsQ[#, "T"], StringDrop[#, -1], #] & /@ xxx

(* {"HHHHT", "HHHTH", "HHHTTH", "HHTHH", "HHTHTH", "HHTTHH", "HTHHH", "HTHHTH", "HTHTHH", "HTTHHH", "THHHH", "THHHTH", "THHTHH", "THTHHH", "TTHHHH"} *)

If the last letter of a string in this list is a T, then that string is "useless" and should be deleted:

If[StringEndsQ[#, "T"], StringDrop[#, -1], #] & /@ yyy

(* {"HHHH", "HHHTH", "HHHTTH", "HHTHH", "HHTHTH", "HHTTHH", "HTHHH", "HTHHTH", "HTHTHH", "HTTHHH", "THHHH", "THHHTH", "THHTHH", "THTHHH", "TTHHHH"} *)

This is the final list that satisfies all the questioner's requests. Note that the "accepted" solution does not satisfy the request. For instance, the accepted solution does not include {HHHH} whereas the questioner explicitly demanded that this string be included. Moreover, the questioner explicitly worried about "variable length" strings, and the "accepted" solution does not contain strings of variable length. As the question poser stated in a comment: "I want to generate 4 and 5 element lists that match the criteria i.e. {HHHH},{THHHH}"


Here's the shortest code I could find:

StringJoin /@ 
 Flatten[(Select[Tuples[{"H", "T"}, #], 
      Counts[#]["H"] == 4 && Last[#] == "H" &] & /@ {4, 5, 6}), 1]

(* {"HHHH", "HHHTH", "HHTHH", "HTHHH", "THHHH", "HHHTTH", "HHTHTH", "HHTTHH", "HTHHTH", "HTHTHH", "HTTHHH", "THHHTH", "THHTHH", "THTHHH", "TTHHHH"} *)

$\endgroup$
2
$\begingroup$
   StringJoin /@ (Union[#[[;; Position[Accumulate[ #], 4][[1,1]]]] &
        /@ Select[ Tuples[{0, 1}, 6] , Count[#, 1] >= 4 & ] ] 
        /. {1 -> "H",  0 -> "T"} )

{"HHHH", "THHHH", "HTHHH", "HHTHH", "HHHTH", "TTHHHH", "THTHHH", "THHTHH", "THHHTH", "HTTHHH", "HTHTHH", "HTHHTH", "HHTTHH", "HHTHTH", "HHHTTH"}

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.