Cfrtjryk

Description

I would like to simulate n games in which two players toss one coin each at the same time: If you toss a tail you will receive two tokens, if you toss a head you will only get one token.

The player who first accumulates at least m tokens wins; if this happens at the same time, the game will result in a draw.

Code

I have written the following code:

m = 10; (* threshhold to win the game *)

n = 10^6; (* number of games simulated *)



flag1 = 0; (* # P1 wins *)

flag2 = 0; (* # P2 wins *)

flag3 = 0; (* # draws *)

flag4 = 0; (* # total throws *)



Do[

    (

        i1 = 0; (* initial score P1 *)

        i2 = 0; (* initial score P2 *)

        i3 = 0; (* initial # of tosses *)



        (* play one game until at least one player has collected m or more tokens *)

        While[i1 < m && i2 < m,

            i1 = i1 + 1 + RandomInteger;

            i2 = i2 + 1 + RandomInteger;

            i3 = i3 + 1

        ];



        (* keep score *)   

        If[i1 >= m && i2 >= m,

            flag3 = flag3 + 1, (* game is a draw *)

            If[i1 > i2,

                flag1 = flag1 + 1, (* P1 wins *)

                flag2 = flag2 + 1  (* P2 wins *)

            ]

        ];



        flag4 = flag4 + i3

    ), 

    n

]

Could someone please kindly tell me how to modify this to make it faster?

Some improvement with Compile and a slightly different "take" on the problem using NestWhile:

cf = Compile[

    {

        { m, _Integer },

        { n, _Integer }

    }, 

    Module[

        {

            game, (* vector to track a single game: { P1 tokens, P2 tokens, tosses } *)

            p1wins = {1, 0, 0, 0},

            p2wins = {0, 1, 0, 0},

            draw   = {0, 0, 1, 0},

            count  = {0, 0, 0, 1}

        },

        (* function returns vector: { # P1 wins, #P2 wins, # draws, # tosses } *)

        Total @ Table[

            (

                (* play game until at least one player has m or more tokens *)

                game = NestWhile[

                    # + { RandomInteger @ {1,2}, RandomInteger @ {1,2} , 1 } &,

                    {0, 0, 0},

                    #[[1]] < m && #[[2]] < m &

                ];

                (* keep score *)

                Which[

                    game[[1]] >= m && game[[2]] >= m, draw,

                    game[[1]] > game[[2]], p1wins,

                    True, p2wins

                ] + game[[3]] * count

            ),

            n

        ]

    ],

    CompilationTarget -> "C" (* this option requires C compiler installed *)

];



cf[ 10, 10^6]; // AbsoluteTiming



(* {0.922876, Null} *)

Maybe more is possible with parallelization.

I wrote something similar to @Okkes (+1), but with a general maximum m.

TeMgame = Compile[{{m, _Integer}},

   Block[{r = Range[m]},

      Sign[

         First[ Pick[r, UnitStep[Accumulate[RandomInteger[{1, 2}, m]] - m], 1]] -

         First[ Pick[r, UnitStep[Accumulate[RandomInteger[{1, 2}, m]] - m], 1]]

   ]], CompilationTarget -> "C", Parallelization -> True]

It is faster than cf from @gwr when m is larger. For example,

AbsoluteTiming[Sort@Tally[Table[TeMgame[200], {10^6}]]]

{10.4598, {{-1, 463391}, {0, 72762}, {1, 463847}}}

ParallelTable on 8 kernels takes 2.5 seconds.

Update

Write TeMgame3 to save the numbers of flips.

TeMgame3 = Compile[{{m, _Integer}},

   Block[{r},

      r = Range[m];

      {First[Pick[r, UnitStep[Accumulate[RandomInteger[{1, 2}, m]] - m], 1]], 

       First[Pick[r, UnitStep[Accumulate[RandomInteger[{1, 2}, m]] - m], 1]]}

   ], CompilationTarget -> "C", Parallelization -> True]

Now run the following to count the total number of flips, as well as the wins, draws, and losses.

AbsoluteTiming[

   With[{t = ParallelTable[TeMgame3[200], {i, 1, 10^6}]},

      {Total[Map[Min, t]], Sort[Tally[Sign[Subtract @@@ t]]]}

   ]]

{2.74122, {131388986, {{-1, 463096}, {0, 73098}, {1, 463806}}}}

Your second question refers to a draw being achieved "only when both players have the same number of coins". I currently do not see how it can be otherwise...

Edit:

m = 10;

n = 100;

Table[Sign@

  Differences@

   Flatten[FirstPosition[#, 1] & /@ 

     UnitStep[Accumulate /@ RandomInteger[{1, 2}, {2, m}] - m]], n]

Original answer

Here is more compact one but slow, it might be improved. ${+1,0,-1}={text{p1 wins},text{draw},text{p2 wins}}$

   n=100;

Table[Sign@

      Differences[

       First@Flatten@Position[#, 10 | 11] & /@ 

        Accumulate /@ RandomInteger[{1, 2}, {2, 10}]], n]