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

Question

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

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

我们有七个人在玩，所以我认为最终的“圣诞老人分配”是 (1:7) 自身的排列，有一些限制。

我想就如何使用 Mathematica 或任何编程语言甚至算法来提出各种想法：

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

Answer 1

你要找的东西叫做混乱（另一个可爱的拉丁词，比如放血和出窗外）。

所有排列中属于混乱的排列比例接近 1/e = 大约 36.8%——因此，如果您生成随机排列，只需继续生成它们，您就很有可能在 5 或 10 个选项中找到一个。随机排列。 （在 5 个随机排列中找不到一个的几率为 10.1%，每增加 5 个排列，未发现混乱的几率就会降低 10 倍）

这个演示非常实际，给出了直接生成混乱的递归算法，而不是而不是必须拒绝不是混乱的排列。

Answer 2

我建议：

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 3

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

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

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}}

Edit

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

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

尽管在我的系统上 Derangements[Range[n]] 比上面的函数慢大约 2 倍。

Answer 5

这并没有回答你关于计算有效混乱的问题，但它提供了一种算法来生成具有以下属性的混乱（这可能是你想要的）：

1. 它保证圣诞老人的关系中有一个循环（如果你在 4 玩） ，你最终不会得到 2 对圣诞老人夫妇 --> 2 个周期），
2. 即使有大量玩家，它也能有效地工作，
3. 如果应用得当，没有人知道谁是圣诞老人，
4. 它不需要计算机，只需要一些纸。

这里的算法是：

• 每个玩家将她/他的名字写在信封上，并将她/他的名字放在信封内的折叠纸上。
• 一名值得信赖的玩家（对于上面的属性＃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 的回答一样，我怀疑可以通过 SparseArray 优化 teleSecretSanta 。不过，我现在喝得太醉了，无法尝试这种恶作剧。 （开玩笑……我其实是太懒太笨了。）