# Pare down list recursively

What is the best way to pare down a list whereby the $n$th number is removed from the list recursively? This

a = Range[15]; nu = 6;
b = DeleteCases[  Table[If[Mod[a[[n]], nu] == 0, 0, a[[n]]], {n, 1, Length@a}], 0]
c = Join[Take[b, -Mod[Length@a, nu]],   Take[b, Length@b - Mod[Length@a, nu]]]
d = DeleteCases[  Table[If[Mod[n, nu] == 0, 0, c[[n]]], {n, 1, Length@c}], 0]
e = Join[Take[d, -Mod[Length@b, nu]],   Take[d, Length@d - Mod[Length@b, nu]]]
f = DeleteCases[  Table[If[Mod[n, nu] == 0, 0, e[[n]]], {n, 1, Length@e}], 0]
g = Join[Take[f, -Mod[Length@c, nu]],   Take[f, Length@f - Mod[Length@c, nu]]]
h = DeleteCases[  Table[If[Mod[n, nu] == 0, 0, g[[n]]], {n, 1, Length@g}], 0]
i = Join[Take[h, -Mod[Length@d, nu]],   Take[h, Length@h - Mod[Length@d, nu]]]
j = DeleteCases[  Table[If[Mod[n, nu] == 0, 0, i[[n]]], {n, 1, Length@i}], 0]
k = Join[Take[j, -Mod[Length@e, nu]],   Take[j, Length@j - Mod[Length@e, nu]]]
l = DeleteCases[  Table[If[Mod[n, nu] == 0, 0, k[[n]]], {n, 1, Length@k}], 0]
m = Join[Take[l, -Mod[Length@f, nu]],   Take[l, Length@l - Mod[Length@f, nu]]]
n = DeleteCases[  Table[If[Mod[n, nu] == 0, 0, m[[n]]], {n, 1, Length@m}], 0]
o = Join[Take[n, -Mod[Length@g, nu]],   Take[n, Length@n - Mod[Length@g, nu]]]
p = DeleteCases[  Table[If[Mod[n, nu] == 0, 0, o[[n]]], {n, 1, Length@o}], 0]


is clearly not good practice, but hopefully it gets across the idea. I tried using Nest without success - not sure what is best way to attack it.

• I have trouble follow the logic by which the elements of the list are reordered; would you comment on that? Oct 28, 2014 at 0:26
• @Mr.Wizard it is as though the elements are arranged in a circle and the $6$th element is knocked out on each cycle. The rearranging is just to simulate that they are arranged in a circle and the cycle is continuous till the list is pared down to just $1$ element. Oct 28, 2014 at 0:30
• So it is not strictly necessary for your output so long as the elements that you show remain at each step? Oct 28, 2014 at 0:31
• @Mr.Wizard no, not at all - just didn't know how to do it concisely! Oct 28, 2014 at 0:32
• Okay, I think I understand and I am trying to think of a clean way to write that. Oct 28, 2014 at 0:40

Let's find out if I understand the problem and if this works:

fn[nu_][{o_, a_}] := {# - 1, Delete[a, #]} & @ Mod[nu + o, Length@a, 1]

NestList[fn[6], {0, Range@15}, 14][[All, 2]] // Column

{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}
{1,2,3,4,5,7,8,9,10,11,12,13,14,15}
{1,2,3,4,5,7,8,9,10,11,13,14,15}
{1,2,4,5,7,8,9,10,11,13,14,15}
{1,2,4,5,7,8,9,11,13,14,15}
{1,4,5,7,8,9,11,13,14,15}
{1,4,5,7,8,9,13,14,15}
{1,4,7,8,9,13,14,15}
{1,4,7,8,9,13,14}
{1,4,7,8,9,14}
{1,4,7,8,14}
{1,4,7,8}
{1,7,8}
{7,8}
{7}

• AH! That's it - brilliant! :) Oct 28, 2014 at 0:52
• @martin Please check the output carefully; I am not certain of my logic regarding Mod. Oct 28, 2014 at 0:53
• yes, just checked - looks good to me - NestList - that was it! Oct 28, 2014 at 0:54
• It looks great as it is to me - presentation is really clear Oct 28, 2014 at 1:03
• @martin Alright, I'll leave it be. I'm glad I could help! :-) Oct 28, 2014 at 1:03
g[list_, incr_] := Module[{i = 1},
NestWhileList[ Delete[#, i = Mod[i+incr-1, Length@#, 1]] &, list, Length@# > 1 &]]

g[Range@15, 6] // Column

(*{
{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15},
{1, 2, 3, 4, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15},
{1, 2, 3, 4, 5, 7, 8, 9, 10, 11, 13, 14, 15},
{1, 2, 4, 5, 7, 8, 9, 10, 11, 13, 14, 15},
{1, 2, 4, 5, 7, 8, 9, 11, 13, 14, 15},
{1, 4, 5, 7, 8, 9, 11, 13, 14, 15},
{1, 4, 5, 7, 8, 9, 13, 14, 15},
{1, 4, 7, 8, 9, 13, 14, 15},
{1, 4, 7, 8, 9, 13, 14},
{1, 4, 7, 8, 9, 14},
{1, 4, 7, 8, 14},
{1, 4, 7, 8},
{1, 7, 8},
{7, 8}
{7}
}*)

• another great approach - hank you fro your help here! :) Oct 29, 2014 at 15:13
josephus[nu_, list_] :=
NestList[Rest@RotateLeft[#, nu - 1] &, list, Length[list] - 1]

josephus[6, Range[15]]
(*
{{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15},
{7, 8, 9, 10, 11, 12, 13, 14, 15, 1, 2, 3, 4, 5},
{13, 14, 15, 1, 2, 3, 4, 5, 7, 8, 9, 10, 11},
{4, 5, 7, 8, 9, 10, 11, 13, 14, 15, 1, 2},
{11, 13, 14, 15, 1, 2, 4, 5, 7, 8, 9},
{4, 5, 7, 8, 9, 11, 13, 14, 15, 1},
{13, 14, 15, 1, 4, 5, 7, 8, 9},
{7, 8, 9, 13, 14, 15, 1, 4},
{1, 4, 7, 8, 9, 13, 14},
{14, 1, 4, 7, 8, 9},
{14, 1, 4, 7, 8},
{1, 4, 7, 8},
{7, 8, 1},
{7, 8},
{7}}
*)


Well it gets the right set but in the wrong order :( -- which can be put right :) like this:

RotateRight[#, First[Ordering[#, -1]]] & /@ josephus[6, Range[15]]
(* output that matches (at least) two other answers *)


Still, I liked the basic idea of josephus, that of spinning the circle around to the executioner, instead of figuring out how far he has to go around to kill the next element. No need to Mod anything. If you imagine the circle on a spring as it is rotated left, then what the fix does is let the spring unwind.

• this is an interesting approach - It never ceases to amaze me the ingenuity of ansers on this site! :) Oct 29, 2014 at 15:12
• @martin Also mathematica.stackexchange.com/q/33595/193 Oct 29, 2014 at 15:18
• @belisarius thanks - will check that one out too :) Oct 29, 2014 at 15:26