3
$\begingroup$

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.

$\endgroup$
6
  • 1
    $\begingroup$ I have trouble follow the logic by which the elements of the list are reordered; would you comment on that? $\endgroup$
    – Mr.Wizard
    Oct 28, 2014 at 0:26
  • 1
    $\begingroup$ @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. $\endgroup$
    – martin
    Oct 28, 2014 at 0:30
  • $\begingroup$ So it is not strictly necessary for your output so long as the elements that you show remain at each step? $\endgroup$
    – Mr.Wizard
    Oct 28, 2014 at 0:31
  • $\begingroup$ @Mr.Wizard no, not at all - just didn't know how to do it concisely! $\endgroup$
    – martin
    Oct 28, 2014 at 0:32
  • $\begingroup$ Okay, I think I understand and I am trying to think of a clean way to write that. $\endgroup$
    – Mr.Wizard
    Oct 28, 2014 at 0:40

3 Answers 3

5
$\begingroup$

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}
$\endgroup$
7
  • $\begingroup$ AH! That's it - brilliant! :) $\endgroup$
    – martin
    Oct 28, 2014 at 0:52
  • $\begingroup$ @martin Please check the output carefully; I am not certain of my logic regarding Mod. $\endgroup$
    – Mr.Wizard
    Oct 28, 2014 at 0:53
  • $\begingroup$ yes, just checked - looks good to me - NestList - that was it! $\endgroup$
    – martin
    Oct 28, 2014 at 0:54
  • 1
    $\begingroup$ It looks great as it is to me - presentation is really clear $\endgroup$
    – martin
    Oct 28, 2014 at 1:03
  • 1
    $\begingroup$ @martin Alright, I'll leave it be. I'm glad I could help! :-) $\endgroup$
    – Mr.Wizard
    Oct 28, 2014 at 1:03
3
$\begingroup$
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}
}*)
$\endgroup$
1
  • $\begingroup$ another great approach - hank you fro your help here! :) $\endgroup$
    – martin
    Oct 29, 2014 at 15:13
3
$\begingroup$
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.

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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