Simple Enumeration of Coin Tosses

Question

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.

Answer 1

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

Answer 2

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]

Answer 3

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"} *)

Answer 4

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"} *)

Answer 5

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