Secret Santa - 生成“有效”的排列

Question

我的朋友邀请我去玩“暗恋者”游戏，我们需要抽签并扮演一个朋友的“圣诞老人”的角色。我们把我们所有人的名字写下来，然后随机抽取一个名字，如果有人抽到自己的名字，我们就要重新洗牌再次抽签。我们有七个人参加，我认为最终的“圣诞老人分配”是将(1:7)的排列映射到自身的某些限制条件下。我希望能够提出各种想法，看如何使用Mathematica或任何编程语言或甚至算法来：列出/打印出所有“有效”的“圣诞老人分配”，并且随着参与“暗恋者”游戏的朋友数量增加而具有可伸缩性。

- fritz

---

请原谅我的无知，但这不仅仅是解决7！的问题吗？指的是可能性的数量，而不是具体内容。 - Sheriff

不，它不是。他正在寻找不留任何元素在原位的排列方式。对于三个元素，(123)、(132)、(321)和(213)被拒绝，(231)和(312)是可以的。 - Szabolcs

@警长，确实是的。 n!将是全排列的总数，但其中一些将是“无效”的，需要考虑。 简单的规则是，如果人“i”选择了“i”，那么这个“排列”就是无效的。 如果1,2,3...n是人，P(1)，P(2)...P(n)是他们选择的位置，则对于每个1<=i<=n，i不应等于P(i)。我知道这是一个相当简单的条件，但我很想学习可以在Mathematica中“编程”它的各种“成语”，看看是否可以找到一些有趣的简化/模式... - fritz

@Szabolcs -- 是的，你是正确的！ - fritz

给那些投票关闭的人：这就是为什么Mathematica用户想要自己的Stack Exchange网站。 - Verbeia

Answer 1

你需要的是一种叫做derangement的排列（这是另一个很好的拉丁词汇，类似于exsanguination和defenestration）。

所有排列中的derangement的比例趋近于1/e = 约36.8% - 因此，如果你正在生成随机排列，只需不断生成它们，就有很高的概率在5或10个随机排列中找到一个derangement（每增加5个排列，未找到derangement的几率降低10倍）。 这个演示相当简单易懂，并提供了一种递归算法，可以直接生成derangements，而无需拒绝不是derangements的排列。

- Jason S

---

确实，这对我来说是一个愉快的介绍，让我认识了Stack Overflow社区！我从未想过有一个特殊的术语来描述我一直追逐的“疯狂和愚蠢”（也许是我的朋友们这样认为？！）的想法...非常感谢您的及时帮助..！ - fritz

@fritz 欢迎来到StackOverflow，别忘了接受问题的答案（如果有合适的答案！） :-) - Szabolcs

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, 空值}

{1.482, 空值}

忽略代码的透明度，这可以使其运行速度再次提高几倍：

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

f2[9]; //Timing

{0.162, Null}

- Mr.Wizard

---

(1) 我有一种直觉，稀疏数组可以用来加速这个过程。干得好。 (2) 就算不值钱，似乎有一个内置函数可以自动地给出“错排”的数量，但不能给出实际的“错排”。请参见 Subfactorial 函数。 - telefunkenvf14

感谢@Mr.Wizard提供这两个“宝石”，我也很喜欢你对SparseArray的运用 - 我真的学到了很多，感谢这个游戏！ :) 祝大家节日快乐，新年充满奇妙！ - fritz

Answer 3

将没有元素映射到其自身的排列称为derangement。随着n的增加，无序排列的比例趋近于常数1/e。因此，如果随机选择排列，则平均需要e次尝试才能获得一个无序排列。

维基百科文章包括计算小n的明确值的表达式。

- wnoise

---

非常感谢这些信息！虽然它看起来只是从总n!排列中过滤出一些排列的琐碎操作，但我有一些直觉认为这应该有某种“模式”...！我将尝试在Mathematica中实现一些列举错排的方法并进行探索..！再次感谢！ - fritz

@wnoise - 你指出随着n的增加，“错排的比例趋近于常数1/e。”这让我想起了一类称为“秘书问题”的最优停止/搜索问题，其中相同的1/e结果也会出现。如果您熟悉此类问题，请评论一下错排和“秘书问题”之间的关系。（我认为这将是一个很好的问题，在堆栈宇宙的某个地方正式提出，但可能不适合在SO上提问。如果有价值并且在此回答是浪费时间的话，请随意采纳这个问题的想法。） - telefunkenvf14

@telefunkenvf14：我从未听说过“秘书问题”，所以无法发表评论。 - wnoise

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倍。

- Heike

---

你的函数可以更简洁地写成：secretSanta[n_] := Cases[Permutations@Range@n, a_ /; FreeQ[a - Range[n], 0]]。 - Mr.Wizard

Answer 5

这并没有回答你关于计算有效错排的问题，但是它提供了一种生成算法（也许这正是你想要的），具有以下特点：

1.保证圣诞老人的关系中只有一个循环（如果你玩四个人，你不会得到两对圣诞老人——>2个循环）；

2.即使有很多玩家，它也可以高效地工作；

3.如果公平地应用，没有人知道谁是圣诞老人；

4.它不需要计算机，只需要一些纸。

这里是算法：

1.每个玩家在信封上写下自己的名字，并将名字放在信封内的折叠纸中。

2.一个可信的玩家（为了满足上述第3个属性）拿走所有的信封，并从背面（没有写名字的一面）看着它们洗牌。

3.一旦信封洗牌得足够好，始终从背面看着，可信任的玩家将每个信封中的纸移到下一个信封中。

4.再次洗牌后，将信封分发给其上的人，每个玩家都是其信封中名字所对应的人的圣诞老人。

- jfg956

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。然而，我现在太醉了，无法尝试这种花招。（开玩笑...实际上我太懒和太蠢了。）

- telefunkenvf14