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.

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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