3
$\begingroup$

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.

Improve this question
$\endgroup$
1
  • $\begingroup$ Please include your working procedural function! It could be worth tweaking that one, along with other answers you might get. $\endgroup$
    – march
    Commented Dec 22, 2016 at 17:18

1 Answer 1

Reset to default
4
$\begingroup$

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
 ]
Improve this answer
$\endgroup$
5
  • $\begingroup$ Could you do something like 0->Sequence[] to get rid of the zero elements? Thank you! $\endgroup$
    – fred
    Commented Dec 22, 2016 at 17:36
  • $\begingroup$ Or DeleteCases, which I would prefer. $\endgroup$
    – march
    Commented Dec 22, 2016 at 17:37
  • $\begingroup$ @fred. See edit. $\endgroup$
    – march
    Commented Dec 22, 2016 at 17:39
  • $\begingroup$ 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? $\endgroup$
    – fred
    Commented Dec 22, 2016 at 17:44
  • $\begingroup$ @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. $\endgroup$
    – march
    Commented Dec 22, 2016 at 17:45

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.