# Generating "descendants" of a list

The game of "Nim" is played using stones arranged into piles. Players take turns removing 1 or more stones from a single pile, the player who can't take any stones loses. I am interested in writing a function to generate the list of valid game positions from a give position. If $x = \{1,4,5\}$ then $f(x) = \{\{4,5\}, \{1,3,5\},\{1,2,5\},\{1,1,5\},\{1,5\},\{1,4,4\},\{1,3,4\},\ldots, \{1,4\} \}.$ Notice that the relative ordering of the numbers does not matter, i.e. $\{1,4\}$ is equivalent to $\{4,1\}$.

How can I do this in Mathematica? I have a procedural function that (I think) works, but I am interested in knowing a functional solution.

• Please include your working procedural function! It could be worth tweaking that one, along with other answers you might get. Dec 22 '16 at 17:18

Here's the third, and perhaps final version:

nextMove[x : {__Integer}] :=
Sort /@ Table[
Append[Tuples[ReplacePart[List /@ x, k -> Range[x[[k]] - 1]]], Delete[x, k]],
{k, 1, Length@x}
]~Flatten~1 // DeleteDuplicates

nextMove[{1, 4, 5}]
(* {{0, 4, 5}, {1, 0, 5}, {1, 1, 5}, {1, 2, 5}, {1, 3, 5},
{1, 4, 0}, {1, 4, 1}, {1, 4, 2}, {1, 4, 3}, {1, 4, 4}} *)
nextMove[{3, 3}]
(* {{1, 3}, {2, 3}, {3}} *)


Here's a second pass:

nextMove[x : {__Integer}] := Table[
Tuples[ReplacePart[List /@ x, k -> Range[0, x[[k]] - 1]]],
{k, 1, Length@x}
]~Flatten~1

nextMove[{1, 4, 5}]
(* {{0, 4, 5}, {1, 0, 5}, {1, 1, 5}, {1, 2, 5}, {1, 3, 5},
{1, 4, 0}, {1, 4, 1}, {1, 4, 2}, {1, 4, 3}, {1, 4, 4}} *)


To remove the zeros, one possibility is

nextMove[x : {__Integer}] := Table[
Tuples[ReplacePart[List /@ x, k -> Range[0, x[[k]] - 1]]],
{k, 1, Length@x}
]~Flatten~1 /. {a___, 0, b___} :> {a, b}


Another possibility (that doesn't require post-processing) is

nextMove[x : {__Integer}] := Table[
Append[Tuples[ReplacePart[List /@ x, k -> Range[x[[k]] - 1]]], Delete[x, k]],
{k, 1, Length@x}
]~Flatten~1


Here's a first pass. It is somewhat procedural:

nextMove[x : {__Integer}] := Module[
{moves = Range[0, # - 1] & /@ x, xs = List /@ x, subs},
Table[
subs = xs;
subs[[k]] = moves[[k]];
Tuples[subs],
{k, 1, Length@x}
]~Flatten~1
]

• Could you do something like 0->Sequence[] to get rid of the zero elements? Thank you!
– fred
Dec 22 '16 at 17:36
• Or DeleteCases, which I would prefer. Dec 22 '16 at 17:37
• @fred. See edit. Dec 22 '16 at 17:39
• I think it reports duplicates, for example nextMove[{3,3}] gives {3} twice. I think the individual lists need to be sorted, then the big list needs to have union run on it to remove duplicates. Any thoughts?
– fred
Dec 22 '16 at 17:44
• @fred. Yep, seems reasonable. Off the top of my head, I can't see a way of generating some of the overlapping next moves only once, so little bit of post-processing seems to be in order. Sorting and deleting duplicates would be the way to go. I'll add those in. Dec 22 '16 at 17:45