Père Noël Secret-générer des permutations "valides"

Mes amis m'ont invité à la maison pour jouer le jeu de Secret Santa, où nous sommes censés dessiner beaucoup et jouer le rôle de 'Santa' pour un ami dans le groupe.

Donc, nous écrivons tous nos noms et choisissons un nom au hasard. Si l'un d'entre nous finit par avoir son propre nom choisi, alors nous remanions et choisissons des noms à nouveau (la raison d'être étant que l'on ne peut pas être son propre Père Noël).

Nous sommes sept à jouer, alors j'ai pensé à la dernière "allocation de Père Noël" comme une permutation de (1: 7) sur lui-même, avec quelques restrictions.

Je voudrais inviter diverses idées sur la façon dont nous pourrions utiliser Mathematica en particulier ou tout langage de programmation ou même un algorithme pour:

  • liste / affiche toutes les allocations de Père Noël 'valides'
  • est évolutif au fur et à mesure que le nombre d'amis jouant à 'Secret Santa' augmente
28
demandé sur smci 2011-12-23 00:58:15

6 réponses

Je propose ceci:

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

C'est nettement plus rapide que la fonction de Heike.

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

{0.483, Null}
{1.482, Null}

En ignorant la transparence du code, cela peut être rendu plusieurs fois plus rapide encore: 

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

f2[9]; //Timing

{0.162, Null}
15
répondu Mr.Wizard 2011-12-24 08:39:24

Ce que vous cherchez s'appelle un dérangement (un autre joli mot latinisé à savoir, comme l'exsanguination et la défénestration).

La fraction de toutes les permutations qui sont des dérangements approche 1 / e = environ 36,8% - donc si vous générez des permutations aléatoires, continuez simplement à les générer, et il y a une très forte probabilité que vous en trouviez une dans 5 ou 10 sélections d'une permutation aléatoire. (10,1% de chances de ne pas en trouver une dans les 5 permutations aléatoires, chaque 5 permutations supplémentaires abaissent la chance de ne pas trouver un dérangement par un autre facteur de 10)

Cette présentation est assez terre-à-terre et donne un algorithme récursif pour générer des dérangements directement, plutôt que d'avoir à rejeter des permutations qui ne sont pas des dérangements.

29
répondu Jason S 2014-06-29 12:21:33

Une permutation qui mappe aucun élément à lui-même est un dérangement. À mesure que n augmente, la fraction de dérangements se rapproche de la constante 1/e. En tant que tel, il faut (en moyenne) e essaie d'obtenir un dérangement, si on choisit une permutation au hasard.

L'article wikipedia inclut des expressions pour calculer des valeurs explicites pour les petits n.

15
répondu wnoise 2011-12-22 21:10:37

Dans Mathematica, vous pouvez faire quelque chose comme 

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

Où n est le nombre de personnes dans la piscine. Ensuite, par exemple secretSanta[4] renvoie 

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

Modifier

Il semble que le paquet Combinatorica dans Mathematica ait en fait une fonction Derangements, donc vous pouvez aussi faire quelque chose comme 

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

Bien que sur mon système Derangements[Range[n]] soit à peu près un facteur 2 plus lent que la fonction ci-dessus.

13
répondu Heike 2011-12-22 21:27:39

Cela ne répond pas à votre question sur le comptage des dérangements valides, mais il donne un algorithme pour en générer un (qui pourrait être ce que vous voulez) avec les propriétés suivantes:

  1. il garantit qu'il y a un seul cycle dans la relation du Père Noël (si vous jouez à 4, vous ne vous retrouvez pas avec 2 couples de Père Noël -- > 2 cycles),
  2. Il fonctionne efficacement même avec un très grand nombre de joueurs,
  3. si appliqué équitablement, personne ne sait à qui le Père Noël,
  4. ce n'est pas le cas besoin d'un ordinateur, seulement du papier.

Voici l'algorithme:

  • , Chaque joueur écrit son nom sur une enveloppe et met son/son nom dans un papier plié dans l'enveloppe.
  • Un joueur de confiance (pour la propriété # 3 ci-dessus) prend toutes les enveloppes et les mélange en regardant leur face arrière (où aucun nom n'est écrit).
  • Une fois que les enveloppes sont mélangées assez bien, en regardant toujours à l'arrière, Le joueur de confiance déplace le papier dans chaque enveloppe vers le suivante.
  • Après avoir mélangé les enveloppes à nouveau, les enveloppes sont distribuées au joueur dont le nom est sur eux, et chaque joueur est le Père Noël de la personne dont le nom est dans l'enveloppe.
2
répondu jfg956 2011-12-31 17:12:24

Je suis tombé sur la fonction Subfactorial intégrée dans la documentation et j'ai modifié l'un des exemples à produire: 

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

On peut utiliser Subfactorial pour vérifier la fonction.

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

Comme dans la réponse de M. Wizard, je soupçonne que teleSecretSanta peut être optimisé via SparseArray. Cependant, je suis trop ivre en ce moment pour tenter de telles manigances. (blague... En fait, je suis trop paresseux et stupide.)

1
répondu telefunkenvf14 2011-12-26 05:30:03