Секретный Санта - создание "правильных" перестановок

Мои друзья пригласили меня домой, чтобы сыграть в игру Secret Santa, где мы должны много нарисовать и сыграть роль "Санта" для друга в группе.

Итак, мы пишем все наши имена и выбираем имя случайным образом. Если у кого-то из нас появляется собственное имя, мы перетасовываем и выбираем имена снова и снова (логическое обоснование заключается в том, что нельзя быть собственным Сантом).

Во время игры нас семь, поэтому я думал о финальном "Santa-distribution" как о перестановке (1: 7) на себя с некоторыми ограничениями.

Я хотел бы предложить различные идеи о том, как мы можем использовать Mathematica в частности или любой язык программирования или даже алгоритм:

Список/распечатать ВСЕ "действительные" Санта-распределения
Является масштабируемым, поскольку растет количество друзей, играющих в "Secret Santa".

Ответ 1

Я предлагаю следующее:

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

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

Это значительно быстрее, чем функция Хайке.

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

{0.483, Null}

{1.482, Null}

Игнорируя прозрачность кода, это можно сделать в несколько раз быстрее:

f2[n_Integer] := With[{s = [email protected]},
    # ~Extract~ 
       SparseArray[[email protected]@BitXor[s, #] & /@ #]["NonzeroPositions"] & @ [email protected]
  ]

f2[9]; //Timing

{0.162, Null}

Ответ 2

То, что вы ищете, называется derangement (другое прекрасное латинское слово, чтобы знать, например, отвращение и отмена).

Доля всех перестановок, которые являются нарушениями, приближается к 1/e = приблизительно 36,8% - поэтому, если вы производите произвольные перестановки, просто продолжайте их генерировать, и существует очень высокая вероятность того, что вы найдете ее в пределах 5 или 10 выбор случайной перестановки. (10,1% вероятность не найти один из 5 случайных перестановок, каждые дополнительные 5 перестановок уменьшают вероятность того, что не найдут расстройство другим фактором 10)

Эта презентация довольно примитивна и дает рекурсивный алгоритм для создания беспорядков напрямую, вместо того, чтобы отказываться от перестановок, t.

Ответ 3

Перестановка, которая не отображает элемент для себя, представляет собой derangement. С ростом n доля нарушений приближается к константе 1/e. Как таковой, требуется (в среднем) e пытается получить расстройство, если выбрать произвольную перестановку.

В статье wikipedia содержатся выражения для вычисления явных значений для малых n.

Ответ 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

Похоже, что пакет Combinatorica в Mathematica фактически имеет функцию Derangements, поэтому вы также можете сделать что-то вроде

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

хотя в моей системе Derangements[Range[n]] примерно на 2-й раз медленнее, чем функция выше.

Ответ 5

Это не отвечает на ваш вопрос о подсчете действительных нарушений, но дает алгоритм для генерации одного (что может быть то, что вы хотите) со следующими свойствами:

он гарантирует, что в отношениях Санта есть один цикл (если вы играете в 4, вы не получите 2 пары Санта → 2 цикла),
он работает эффективно даже при очень большом количестве игроков,
если применить справедливо, никто не знает, чей, кто Санта,
ему не нужен компьютер, только какая-то бумага.

Здесь алгоритм:

Каждый игрок записывает свое имя на конверте и помещает свое имя в сложенную бумагу в конверте.
Один доверенный игрок (для свойства № 3 выше) берет все конверты и перемешивает их, глядя на их заднюю сторону (там, где имя не написано).
Когда конверты перетасовываются достаточно хорошо, всегда глядя на заднюю сторону, доверенный игрок перемещает бумагу в каждом конверте на следующий.
После перетасовки конвертов снова конверты распространяются обратно на игрока, имя которого на них, а каждый игрок - Санта-Клауса человека, имя которого находится в конверте.

Ответ 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. Тем не менее, я слишком пьян в настоящий момент, чтобы попытаться использовать такие махинации. (шучу... Я на самом деле слишком ленив и глуп.)