The Josephus Problem is described here, with extension of killing every $k$th problem. In the simple case where every other person is killed, we can also use the binary trick.

w[n_] := FromDigits[RotateLeft[IntegerDigits[n, 2]], 2]

The code works well.

This page gives good simulation with different values of $n$ and $k$. I have coded the answers in a recursive way,

Table[win[1, i] = 1, {i, 2, 12}];
win[n_, k_: 2] := 
  win[n, k] = 
    Block[{$RecursionLimit = Infinity}, 
      If[Mod[win[n - 1, k] + k, n] == 0, n, Mod[win[n - 1, k] + k, n]]]

With $RecursionLimit = Infinity, it still works well for up to a certain number like


But it won't work for


And the kernel just quits.

I am wondering

  1. is there a way to improve the code?

  2. is there a way to formulate the generic problem in an easier way like in binary which works for $k=2$?


I can't work out win[50000] straight away. But if I start small, it still works and the kernel won't quit, like excuting these in order.


works fine.

  • 1
    $\begingroup$ Related: 69286, 33595 $\endgroup$ – C. E. Aug 7 '19 at 16:26
  • $\begingroup$ @C.E. Thanks. Looks interesting. Both were approached from a crude way, where numbers just got dropped. Is there any other Mathematical ways like the Binary method? $\endgroup$ – CasperYC Aug 7 '19 at 22:51
  • 2
    $\begingroup$ The implicit answer to that question is no, or people would have used it. $\endgroup$ – C. E. Aug 8 '19 at 4:07

Your problem arrises because you are recursing downward. With large n such as 50000, this mean a huge recursive structure must be built all the way down to n = 1 before the memoization can take place. Mathematica runs out of memory and the kernel crashes. In other words, the memoization isn't doing you much good.

As you point out in your update, you can get win[n] for a large n by working in steps. This works because at each step a lot of memoization is already in place. If you take this idea really seriously and do the stepping by 1, you can get solutions for large n without monkeying with $RecursionLimit. And the code will be fast.

Here is how I did it.

win[1] = 1;
With[{k = 2},
  win[n_] :=
    win[n] = If[Mod[win[n - 1] + k, n] == 0, n, Mod[win[n - 1] + k, n]]]
With[{n = 50000},
  Do[win[i], {i, 2, n}];


Now that win[50000] has been computed any smaller value is available.




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