プレゼント交換の手伝い

Mathematicaで冬休みのプレゼント交換を手伝う。20行ぐらい。ちょっと汚いけど、書き捨てだし

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

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

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

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

problem={{私,杏子,A子},{穴田,出部,KZ},{B子,D子}}; (*入力形式*)

pos=Position[problem,_,{2},Heads->False];

test[x_]:= (*深さ優先探索のテスト部*)
  And[
    And@@MapThread[#1!=#2&,{First/@x,Take[First/@pos,Length@x]}],
    If[Length@x==Length@pos,
      AppendTo[result,x];True,
      deepen@x]]

deepen[x_]:= (*深さ優先探索の展開部*)
  Or@@(test@{Sequence@@x,#}&/@Complement[pos,x])

result={}; (*実行*)
answer=If[deepen@{},
    problem[[Sequence@@#]]&/@result[[Random[Integer,{1,Length@result}]]]&,
    False&];

answer[] (*解をランダムに提示。この結果の場合、私はKZにプレゼントを贈る*)

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

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

Perlでの実装