プレゼント交換の手伝い

Mathematicaで冬休みのプレゼント交換を手伝う。実質は10行ぐらい。

あなたならどうお書きになります1.0で提示された問題：

クリスマスパーティーでプレゼント交換を行う。

• 全員、誰かにプレゼントを一つあげ、誰かからプレゼントを一つもらう。
• 参加者は、自分と同じグループに属している人にはプレゼントをあげない。
• どのグループにも属さない人や、複数のグループに属する人はいない。

この条件を満たすようなプレゼント交換が等確率で出るような、プレゼント交換方法生成プログラムを実装せよ

準備

members = {{私, 杏子, A子}, {穴田, 出部, KZ}, {B子, D子}};
pos = Position[members, _, {2}, Heads -> False];

単純探索のテンプレートを利用します。

search[x_] := Or[ goal@x, deepen@x]
mapOr[f_, x_] := Or @@ Map[f, x] 
goal[x_] := And[Length@x == Length@pos, report@x]
report[x_] := (AppendTo[result, x]; True)
test[x_] := And @@ MapThread[#1 != #2 &, {First /@ x, First /@ Take[pos, Length@x]}]
deepen[x_] := mapOr[search, Select[Append[x, #] & /@ Complement[pos, x], test]]

実行（解はresultに格納）

result = {};
search@{}

True

解の数

Length@result

1728

解の中からランダムに一つ取り出す。

MapThread[#1 -> #2 &,
 {Flatten@members,
  members[[#[[1]], #[[2]]]] & /@ result[[Random[Integer, {1, Length@result}]]]}]

{私 -> 穴田, 杏子 -> KZ, A子 -> 出部, 穴田 -> D子, 出部 -> 杏子, KZ -> B子, B子 -> 私, D子 -> A子}

追記：解がなければsearchはFalseになります。事前にチェックしてもよいですが、その条件をわざわざ考えるのも面倒ですし。

Perlでの実装