2011年一橋大第５問

「それ以降は投げない」という条件のみ，標本点の生成時に適用します．

FindSequenceFunction[Function[n,
    S = Tuples[{a2, a3, a6, b2, b3, b6}, n]
          /. {{x___, a6, ___} -> {x, a6}, {x___, b6, ___} -> {x, b6}} // DeleteDuplicates;
    F1 = Select[S, Length@# == n && MemberQ[{a2, a3, a6}, Last@#] &];
    F2 = Select[S, Length@# == n && Last@# == a6 &];
    F3 = Select[S, Last@# == a6 &];
    P = Switch[#[[1]], a2, 1/2, a3, 1/3, a6, 1/6, _, 0]*
       Product[Switch[{#[[i - 1]], #[[i]]},
         {(a2 | b3), a2}, 1/2, {(a3 | b2), b2}, 1/2,
         {(a2 | b3), a3}, 1/3, {(a3 | b2), b3}, 1/3,
         {(a2 | b3), a6}, 1/6, {(a3 | b2), b6}, 1/6, {_, _}, 0
         ], {i, 2, Length@#}] &;
    Total@(P /@ F3)] /@ Range@6, n] // FullSimplify // AbsoluteTiming

{0.401784, 1/5 2^(-1 - n) 3^-n (-1 - 5^(1 + n) + 6^(1 + n))}

ReplaceAllは纏めた方がコードは簡潔ですが，選択が入るので遅くなります．

For[k = 0, k < 6, k++, S = Tuples[{a2, a3, a6, b2, b3, b6}, k];
  S = DeleteDuplicates[
    S /. {{x___, a6, ___} -> {x, a6}, {x___, b6, ___} -> {x, b6}}];] // AbsoluteTiming

{0.022484, Null}

For[k = 0, k < 6, k++, S = Tuples[{a2, a3, a6, b2, b3, b6}, k];
  S = DeleteDuplicates[
    S /. {x___, y : (a6 | b6), ___} -> {x, y}];] // AbsoluteTiming

{0.566015, Null}

また，問題文が表（そうと）している数学的対象をストレートにコード化し，全ての条件を標本空間の生成時に

FindSequenceFunction[Function[n,
    S = Tuples[{a2, a3, a6, b2, b3, b6}, n]
          /. {b2 | b3 | b6, ___} -> {0} 
          /. {___, a2, b2 | b3 | b6, ___} -> {0} /. {___, b2, a2 | a3 | a6, ___} -> {0}
          /. {___, b3, b2 | b3 | b6, ___} -> {0} /. {___, a3, a2 | a3 | a6, ___} -> {0}
          /. {x___, a6, ___} -> {x, a6} /. {x___, b6, ___} -> {x, b6} // DeleteDuplicates;
    F1 = Select[S, Length@# == n && MemberQ[{a2, a3, a6}, Last@#] &];
    F2 = Select[S, Length@# == n && Last@# == a6 &];
    F3 = Select[S, Last@# == a6 &];
    P = Times @@ # /. {a2 | b2 -> 1/2, a3 | b3 -> 1/3, a6 | b6 -> 1/6} &;
    Total@(P /@ F3)] /@ Range@6, n] // FullSimplify // AbsoluteTiming

{0.328467, 1/5 2^(-1 - n) 3^-n (-1 - 5^(1 + n) + 6^(1 + n))}

のように適用すれば，無駄なリストがないので速くもなるようです．