Question

我的朋友邀请我回家玩秘密圣诞老人的游戏，我们应该在那里画很多东西。为小组中的朋友扮演'圣诞老人'的角色。

因此，我们写下所有名字并随机选择一个名字。如果我们中的任何一个人最终选择了自己的名字，那么我们会重新洗牌并重新挑选名字（理由是一个人不能成为自己的圣诞老人）。

我们有七个人在玩耍时所以我认为最后的“圣诞老人分配”是（1：7）对自身的排列，有一些限制。

我想邀请各种关于如何使用Mathematica特定或任何编程语言甚至算法的想法：

列出/打印所有'有效'圣诞老人分配
随着“秘密圣诞老人”成长的朋友数量的增加，可扩展性

Answer 1

你正在寻找的东西被称为derangement（另一个可爱的拉丁语词汇，如exsanguination和defenestration）。

紊乱的所有排列的比例接近1 / e =约36.8％ - 因此，如果您生成随机排列，只需继续生成它们，并且您很有可能在5或10之内找到一个排列选择随机排列。（在5个随机排列中找不到一个的几率为10.1％，每增加5个排列就会降低未发现另一个因子10的紊乱的几率）

This presentation非常实用，并提供了一种直接生成紊乱的递归算法，而不必拒绝不是紊乱的排列。

Answer 2

不将元素映射到自身的排列是derangement。随着n增加，紊乱的分数接近常数1 / e。因此，如果随机选择排列，则需要（平均）尝试获得紊乱。

维基百科文章包含用于计算小n的显式值的表达式。

Answer 3

我建议：

f[s_List] := Pick[#, Inner[SameQ, #, s, Nor]] & @ Permutations@s

f @ Range @ 4

{{2, 1, 4, 3}, {2, 3, 4, 1}, {2, 4, 1, 3}, {3, 1, 4, 2}, {3, 4, 1, 2},
 {3, 4, 2, 1}, {4, 1, 2, 3}, {4, 3, 1, 2}, {4, 3, 2, 1}}

这明显快于Heike的功能。

f @ Range @ 9; //Timing
secretSanta[9]; //Timing

{0.483, Null}

{1.482, Null}

忽略代码的透明度，这仍然可以快几倍：

f2[n_Integer] := With[{s = Range@n},
    # ~Extract~ 
       SparseArray[Times@@BitXor[s, #] & /@ #]["NonzeroPositions"] & @ Permutations@s
  ]

f2[9]; //Timing

{0.162, Null}

Answer 4

在Mathematica中，您可以执行类似

的操作

secretSanta[n_] := 
  DeleteCases[Permutations[Range[n]], a_ /; Count[a - Range[n], 0] > 0]

其中n是池中的人数。然后例如secretSanta[4]返回

{{2, 1, 4, 3}, {2, 3, 4, 1}, {2, 4, 1, 3}, {3, 1, 4, 2}, {3, 4, 1, 2}, 
  {3, 4, 2, 1}, {4, 1, 2, 3}, {4, 3, 1, 2}, {4, 3, 2, 1}}

修改

看起来Mathematica中的Combinatorica包实际上有一个Derangements函数，所以你也可以这样做

Needs["Combinatorica`"] Derangements[Range[n]]

虽然我的系统Derangements[Range[n]]比上面的函数慢了2倍。

Answer 5

这不能解答有关计算有效紊乱的问题，但它提供了一个算法来生成一个（可能是您想要的）具有以下属性：

它保证在圣诞老人的关系中有一个单一周期（如果你在4岁时玩，你最终不会有2对圣诞老人 - > 2个周期），
即使玩家人数很多，它也能有效运作，
如果公平地应用，没人知道谁是圣诞老人，
它不需要电脑，只需要一些纸张。

这里算法：

每个玩家在信封上写下自己的名字，并将她/他的名字放在信封里的折叠纸上。
一个受信任的玩家（对于上面的属性＃3）获取所有信封，然后将他们看到背面（没有写出姓名）。
一旦信封足够好，一直看着背面，可信赖的玩家将每个信封中的纸张移动到下一个信封。
再次洗完信封后，信封会分发给名字在他们身上的玩家，每个玩家都是名字在信封里的人的圣诞老人。

Answer 6

我在文档中遇到了内置的Subfactorial函数，并修改了其中一个示例：

Remove[teleSecretSanta];
teleSecretSanta[dims_Integer] :=
 With[{spec = Range[dims]},
  With[{
    perms = Permutations[spec],
    casesToDelete = DiagonalMatrix[spec] /. {0 -> _}},
   DeleteCases[perms, Alternatives @@ casesToDelete]
   ]
  ]

可以使用Subfactorial来检查功能。

Length[teleSecretSanta[4]] == Subfactorial[4]

在Mr.Wizard的回答中，我怀疑teleSecretSanta可以通过SparseArray进行优化。但是，我现在太醉了，试图尝试这样的恶作剧。（开玩笑......我实际上太懒惰和愚蠢。）

秘密圣诞老人 - 生成“有效”排列

6 个答案: