Haskell
安定結婚問題
Gale-Shapley
HaskellDay 6

安定結婚問題を解きながらHaskellプログラミングを紹介しつつ恋愛について学ぶ

More than 1 year has passed since last update.

安定結婚問題

問題

n人の男性とn人の女性がいて,男性も女性もそれぞれ異性に対して明確な順序づけができる好みを持つとする.
nは2以上の有限な自然数.
男性と女性がペアを作る問題を考えるが,このときに安定マッチング(不安定対がないようにマッチング)せよ.

安定マッチングというのは次の条件を満足するもの.

そのマッチングを構成するあるペアとは異なるペアを組んだときに,新しいペアの2人がともに元のペアより好ましい相手を得る場合,もとのペアは安定ではない(不安定対).そのようなペアがないようなマッチングが安定マッチング.

不安定対というのは要は他に好き同士がいるので,今の相手との組(関係)は壊れやすいものだと思えばよさそう.

Gale - Shapley のアルゴリズム

この問題にはGale-Shapleyのアルゴリズムというのが知られている.
Shapley先生というのは2012年にノーベル経済学賞を受賞された先生で,この業績が主な受賞理由だと聞いた.
オイコノミアとか観ててもホント経済学おもしろいなーって思います.

  1. まず男性全員が自分が最も好む女性にペアを申し出る.まったく重複がなければそこでこのプロセスは終了.重複があれば,各女性は申し出を受けた男性の中で最も好む男性と暫定的なペアを作る(キープする).それ以外の男性は断わる.
  2. 申し出た女性に断わられた男性全員がそれぞれの次に好む女性に申し出る.このとき,すでに他の男性とペアになっている女性でもかまわずに申し出る.
  3. 各女性は申し出を受けた男性と,もしいればキープくんの中で最も好む男性をキープする.キープから外された男性も断わられた男性とともに断わられた男性となる.
  4. 断られた男性全員がそれぞれ次に好む女性(暫定的なペアを組んでいる女性も含めて)に申し出る.
  5. 以下同様に2からくりかえし.

ねるとんのチャラ男チャラ女バージョンみたいなものか?
つまり男の方から「おねがいしまーす」って突撃するんだが,断わられても別に退場するわけじゃなくて敗者復活可能で,臆面もなく次の女性に「おねがいしまーす」できる.

また女性は女性で結構尻軽で,「じゃあよろしくお願いします」って言っておきながら,より好みの男性が次に自分のところに「おねがいしまーす」って来たら,さっきはあっちの子の方が好きっていってたくせに!ぷんぷん!みたいなのはなくて,「はーい!待ってましたー!じゃあ今までのキープくんバイバーイ!」って軽く乗り換えちゃいます.

超楽しそう!

Haskellで書いてみよう

今回はこれを題材にしてHaskellプログラミングを紹介します.

型を定義する

まずは,ねるとんを観る視聴者になった気分でこのねるとんの場全体を表現する型を作ることを考えましょう.

このねるとんゲームのありとあらゆる状況(場)を表現できる型があれば,あとは条件にあう値を求めるだけになります.

最初に男と女,それとこの状況を表現できるNerutonという型を定義します.

data
type Name = String
type Ranking a = [a]

data Boy = B Name (Ranking Girl)
data Girl = G Name (Ranking Boy)

type Neruton = ([(Girl, [Boy])], [Boy])

BoyとGirlはいいですね.
名前と異性を好みの順に並べたものとで表現しています.
名前は識別子として使いますので同名は使わない方向でおねがいします.
B String [Girl]とかしてももちろん良いですけど型シノニムは積極的に使っていきましょう.

Nerutonは少し説明が必要です.
まずNerutonは[(Girl, [Boy])]と[Boy]のペアになっています.
後者は現在フリーな男性の居場所です.
ねるとんでも,まだ女性のもとに束縛されていない男性は男性だけでたむろしてましたよね.
あれです.
断られた男性もここに戻ってきますが,最後までここにはいたくないですね.

前者はカップルというよりは,女性(の前)の場所だと思ってください.
女性の場所は彼女の支配の及ぶ男性達の居場所なのです.
男性達が「おねがいしまーす」といって彼女の前にずらりと首を並べます.このとき,男性達に人権はありません(いいすぎ).女性が生殺与奪の権利を握っています(いいすぎ).
これが[Boy]となります.可哀想ですね.
彼女が1人を選ぶと[Boy]は1人のBoyをその場に残して,あとは断られた男性として彼女の支配下から解放されます.
1人でもやっぱり[Boy]です.たまたま1要素なだけです.
そのような女性が複数人並んでいるので[(Girl, [Boy])]という風にリストになっています.
女性の前の場所がいつも[]な女性も結構居たものですが,ああはなりたくないですよね.

Nerutonがこのチャラ男とチャラ女のバトルフィールドを表現できていて,このねるとんゲームのあらゆる状況をこれで表現できるな,と分かってもらえればいいのですがどうでしょうか.
これであらゆる状況が表現できるなーって思えたら,答はこの型のもつ値の中にあるはずなので探せば良いだけです.
探し方はGale-Shapleyのアルゴリズムがそう(ひとつの解)なので考えなくてもいいです.

Gale-Shapleyの全体像を書く

最初にざっくりとGale-Shapleyのアルゴリズムの流れを書きます.
meetsがトップレベルの関数です.
男性たちと女性たちとをもらって最終的に安定マッチングな場にしていきますが,その解答はNeruton型で表現される値のなかのどれかです.
toNerutonはまだ未実装ですが,こいつは男性と女性をねるとんゲームの初期状態にします.
gsはそのNeruton型の値をもらってGale-Shapleyのアルゴリズムにしたがって不安定対のないNerutonの値を求めます.

meets
meets :: [Boy] -> [Girl] -> Neruton
boys `meets` girls = gs (toNeruton boys girls)
    where
      toNeruton = undefined

toNerutonはひとまず放っておきましょう.
次にgs関数はどうなるか.
男性陣がまずは第一希望の女性の前に一斉に「おねがいしまーす」します.
これがpropose関数です.
propose関数にNerutonを渡すと,女性達の前に男性がずらり並んだ状況になるので,次に女性陣にchoiceしてもらいます.
choiceは女性達が一斉に「(とりま)よろしくおねがいしまーす!,あとの人たちごめんなさーい!」します.
choiceされると,断わられた男性達は再びもとの場所にもどっていじいじします.
この状況が終了しているかどうか判断して,もし終わってるならその状況が答えであり,もしまだ終了してないなら,つまりまだ心が折れきってない男達がいるなら,ゲーム(gs)を続行します.
「振られても振られてもいってこいやー」と石橋なんとかが号令を掛ける様子が目に浮びます.

gs
gs :: Neruton -> Neruton
gs nt = let nt' = choice $ propose nt
        in if gameOver nt'
           then nt'
           else gs nt'

gameOver関数はNerutonの状況を終了しているか判断するのでBoolを返す関数です.
実装はとりあえずundefinedしておきます.

gameOver
gameOver :: Neruton -> Bool
gameOver = undefined

proposeとchoiceは女性の前の状況と毒男のたむろしている場所とを更新します.
なので実装はまだundeifnedですが,ひとまず型だけ定義しておきます.

propose
propose :: Neruton -> Neruton
propose (cs, ms) = (cs', ms')
    where
      cs' = undefined
      ms' = undefined
choice
choice :: Neruton -> Neruton
choice (cs, ms) = (cs', ms')
    where
      cs' = undefined
      ms' = undefined

ざっくりとですが大枠はできました.

プロポーズしてみよう

propose関数からやります.
新しい状況のパーツとなるcs'とms'を求めます.
ms'の方が簡単でしょうか.

propose
propose :: Neruton -> Neruton
propose (cs, ms) = (cs', ms')
    where
      cs' = undefined
      ms' = filter despair ms
      despair (B _ gs) = null gs

proposeをした時にまだ毒男のたむろする場所に居るのはもうすべての女性にフラれた望みを絶たれた毒男です.
男性と女性が同数で,しかも女性側がちゃんと男性を余さず順序を付けてくれていればそのような状況はないのですが.
despairはBoyの中の女性に対するランキングが無いときにTrueとなります.
このBoyの中の女性に対する序列ですが,これはもしフラれたらその女性への想いを絶ち切るためにリストから除外してあげることにします.
想いを引きずったままでは次の女性に「おねがいしまーす」なんて臆面もなくやれないからです.
実際の処理はchoiceのところでやることにします.

さて,cs'の方はどうでしょうか?
「おねがいしまーす」をするのはmsです.たむろしていた毒男たちですね.
彼らがどの女性の前に行くつもりかをやはり[(Girl, [Boy])]として求めるのが良いでしょう.
そこに現在すでにキープくんが女性と一緒にいるので合流すればよさそうです.

      cs' = join cs (retry ms)
      join :: [(Girl, [Boy])] -> [(Girl, [Boy])] -> [(Girl, [Boy])]
      join = undefined
      retry :: [Boy] -> [(Girl, [Boy])]
      retry = undefined

なにかを書くとどんどん別の関数が必要になって,undefinedが増殖しますが,一歩ずつ前進していますので信じて付いてきてください.

retryの実装はこうです.

      retry :: [Boy] -> [(Girl, [Boy])]
      retry = map retry'
      retry' :: Boy -> (Girl, [Boy])
      retry' b@(B _ (g:gs)) = (g, [b])

retryでは男性が自分で勝手に女性の前に行くというイメージを持ち寄ってくるので,それをちゃんとリアルワールドな女性の前に集合させる必要があります.

ここではjoinはcsとmsを繋げて,女性で並び換えてから,女性でグループ化をし,それを纏めあげるようにしました.

      join :: [(Girl, [Boy])] -> [(Girl, [Boy])] -> [(Girl, [Boy])]
      join cs ms = gather $ groupBy ((==) `on` fst) $ sortOn fst $ cs ++ ms
      gather :: [[(Girl, [Boy])]] -> [(Girl, [Boy])]
      gather = concatMap gather'
      gather' :: [(Girl, [Boy])] -> [(Girl, [Boy])]
      gather' xs@((g,_):_) = [(g, concatMap snd xs)]

ただしsortOnを使うにはData.Listをimportするとともに,GirlをOrdのインスタンスにする必要があります.
このOrdは男性の好みとは別で,単にgroupByするための前処理として必要なだけなので名前でソートすることにします.
同名の人とかがある場合には使えませんが,今回はこれで.

instance Eq Girl where
  G n1 _ == G n2 _ = n1 == n2
instance Ord Girl where
  G n1 _ <= G n2 _ = n1 <= n2

好みのオトコをキープする

次は女性のターンです.
今女性達の支配下にはそれぞれにプロポーズをした男性陣と現在の彼氏というかキープくんが女性からの審判を待っています.
choiceしたらcs'にはあらたなキープくんとのカップルたちが,ms'には現在の毒男たちと,あらたに断わられた男性が合流することになります.
一度キープくんの座に居ても毒男に落ちぶれることもあります.
ただし合流する前に断わられた男性はちゃんとフラれた記憶を消去してあげましょう.
最初にchoiceを書いた時にはついcs'とms'を別に書きましたが,考えたら女性がキープする男性を選んだ時点で断わられた男性も決まるので,そこは同時に貰った方が経済的です.
そのあたりもふまえて,choiceの実装を書きます.

choice :: Neruton -> Neruton
choice (cs, ms) = (cs', ms'')
    where
      (cs', ms') = undefined
      ms'' = ms ++ map heartbreak ms'
      heartbreak (B n (g:gs)) = B n gs

heartbreakはフラれた男性の女性の好みから自分をフった女性を除去します.
これでこころおきなく男性は次の女性にプロポーズできるようになるわけです.

女性が自分の前に居る男性の中から最も好みの男性を選びましょう.
judgeがそうです.

      (cs', ms') = (map fst &&& concatMap snd) $ map judge cs
      judge :: (Girl, [Boy]) -> ((Girl, [Boy]), [Boy])
      judge = undefined

女性たちが一斉に「(とりま)よろしくおねがいしまーす」すると,(Girl, [Boy])というニューカップルと,同時に「ごめんなさい」した男性たち[Boy]とが対となって返ります.
それがリストでやってくるので,map fst &&& concatMap sndでNeruton型にはまるようにまとめてあげます.
(&&&)を使うにはControl.Arrowをimportしておく必要があります.
この部分は分からなければ普通にリスト操作しても別にいいと思います.
本質じゃないのでそういう関数もあるんだね,ふーん.で良いと思います.

judgeは次のようになります.

      judge :: (Girl, [Boy]) -> ((Girl, [Boy]), [Boy])
      judge (g@(G _ bs), ms) = let (b, rs) = sub bs ms
                               in ((g, b), rs)
      sub :: Ranking Boy -> [Boy] -> ([Boy], [Boy])
      sub []     yys   = ([], yys)
      sub (x:xs) yys | x `elem` yys = ([x], delete x yys)
                     | otherwise = sub xs yys

elemを使うにはBoyをEqのインスタンスにする必要がありますがGirlでやったのと同じで良いでしょう.

終了判定

毒男全員の希望が無くなったらゲームは終了です.
あるいは男性n人と女性n人でどの女性も高々1人の男性のみを選択するのであればどの女性もキープが出来た時が終了と判定してもいいです.

gameOver :: Neruton -> Bool
gameOver (_, ms) = all norank ms
    where
      norank :: Boy -> Bool
      norank (B _ gs) = null gs

初期化

最後は男性たちと女性たちをあつめてNerutonの初期状態を作るところを実装します.

      toNeruton boys girls = (zip girls (repeat []), boys)

これでundefinedが無くなったので実装が完了しました.

コード全体はこんな感じです.
動作確認したのでBoy,GirlをShowのインスタンスにしたりしています.

GS.hs
module GS where

import Control.Arrow ((&&&))
import Data.List (sortOn, groupBy, delete)
import Data.Function (on)

type Name = String
type Ranking a = [a]

data Boy = B Name (Ranking Girl)
data Girl = G Name (Ranking Boy)

instance Show Boy where
  show (B n _) = n
instance Eq Boy where
  B n1 _ == B n2 _ = n1 == n2

instance Show Girl where
  show (G n _) = n
instance Eq Girl where
  G n1 _ == G n2 _ = n1 == n2
instance Ord Girl where
  G n1 _ <= G n2 _ = n1 <= n2

type Neruton = ([(Girl, [Boy])], [Boy])

meets :: [Boy] -> [Girl] -> Neruton
boys `meets` girls = gs (toNeruton boys girls)
    where
      toNeruton boys girls = (zip girls (repeat []), boys)

gs :: Neruton -> Neruton
gs nt = let nt' = choice $ propose nt
        in if gameOver nt'
           then nt'
           else gs nt'

propose :: Neruton -> Neruton
propose (cs, ms) = (cs', ms')
    where
      cs' = join cs (retry ms)
      ms' = filter despair ms
      despair (B _ gs) = null gs
      join :: [(Girl, [Boy])] -> [(Girl, [Boy])] -> [(Girl, [Boy])]
      join cs ms = gather $ groupBy ((==) `on` fst) $ sortOn fst $ cs ++ ms
      retry :: [Boy] -> [(Girl, [Boy])]
      retry = map retry'
      retry' :: Boy -> (Girl, [Boy])
      retry' b@(B _ (g:_)) = (g, [b])
      gather :: [[(Girl, [Boy])]] -> [(Girl, [Boy])]
      gather = concatMap gather'
      gather' :: [(Girl, [Boy])] -> [(Girl, [Boy])]
      gather' xs@((g,_):_) = [(g, concatMap snd xs)]

type Dumped = [Boy]

choice :: Neruton -> Neruton
choice (cs, ms) = (cs', ms'')
    where
      (cs', ms') = (map fst &&& concatMap snd) $ map judge cs
      ms'' = ms ++ map heartbreak ms'
      heartbreak (B n (g:gs)) = B n gs
      judge :: (Girl, [Boy]) -> ((Girl, [Boy]), [Boy])
      judge (g@(G _ bs), ms) = let (b, rs) = sub bs ms
                               in ((g, b), rs)
      sub :: Ranking Boy -> [Boy] -> ([Boy], [Boy])
      sub []     yys   = ([], yys)
      sub (x:xs) yys | x `elem` yys = ([x], delete x yys)
                     | otherwise = sub xs yys

gameOver :: Neruton -> Bool
gameOver (_, ms) = all norank ms
    where
      norank :: Boy -> Bool
      norank (B _ gs) = null gs

bA,bB,bC,bD :: Boy
bA = B "A" [ga,gb,gc,gd]
bB = B "B" [ga,gd,gc,gb]
bC = B "C" [gb,gc,ga,gd]
bD = B "D" [gb,gc,ga,gd]
boys = [bA,bB,bC,bD]

ga, gb, gc, gd :: Girl
ga = G "a" [bC,bD,bB,bA]
gb = G "b" [bD,bC,bA,bB]
gc = G "c" [bD,bA,bB,bC]
gd = G "d" [bC,bA,bB,bD]
girls = [ga,gb,gc,gd]

男性最良マッチング

このアルゴリズムでは男性は第1希望から順にプロポーズしていけるので自分にとって最良の相手(最良というか最善?)とめぐりあえます.
これを男性最良マッチングと呼ぶらしいです.
一方で女性にとっては必ずしもそうはなりません.
立場を入れ換えて,女性からプロポーズするようにすると異なる安定マッチングが得られることがあります.
つまりおなじねるとん(メンツ)でも複数の安定マッチングがありえます.
Gale-Shapleyのアルゴリズムで求まるのはそのうちのひとつの解ということになります.

この複数の安定状態を比較すると,人によってはより望ましい状態が得られることがあります.
つまり別のアルゴリズムでやれば個人にとっての結果は変わって,より望ましい相手を得る可能性がありますが,それでも男性にとっては男性最良マッチングで得た結果よりも望ましい結果はないそうです.
直感的には,男性の方が能動的に自分から狩りに行くのに対して,女性は受動的な待ち戦略なので来た中から選ぶことになるのでその分不利なのかなーとか思いますが,他の人との関係もあるのでめぐりあわせのようなものが働くのでしょう.
(世間で言うジェンダーの話ではなくあくまで今回の場合アルゴリズム上の立場を差して男性女性と言っています,念の為)

例えばAくんBくん,Xさん,Yさんの2x2の場合を考えます.

  • AくんはX->Yの順に好き
  • BくんはY->Xの順に好き
  • XさんはB->Aの順に好き
  • YさんはA->Bの順に好き

この状況で男性からプロポーズするとA-X,B-Yで安定します.女性はどちらも不満が残りますが男性はどちらも満足します.
女性からプロポーズするとA-Y,B-Xで安定してしまいます.男性はどちらも不満が残りますが女性はどちらも満足でしょう.

このケースでは第1希望同士の相思相愛がいないのでこれらの安定状態を壊せない,というかアルゴリズム的に言えば相思相愛がいればこの状態にはそもそも落ちつきません.

待ちの場合には上流から自分のより好みの相手が落ちてくるのを待つしかないので,もし上流で安定してしまっていたらめぐりあうチャンスは奪われるってことでしょうか.
自分から仕掛けられれば,その安定状態に落ち付く前に別のパスに誘導して別の安定状態(あればですが)に持っていける,と.

このねるとんゲームの進行につれて,男性の状況はどんどん悪くなっていってくのに対して女性の状況はどんどん良くなっていくのも面白い.
そうしながら安定点を探しているんでしょうね.

また男性と女性の人数が異なる場合において,余ってしまう残念な人は変わらないそうです.
つまりある安定マッチングで誰ともカップルになれない人はどんな安定マッチング解でも結局余りものになります.
これを絶望の定理というらしいですが,ちょっと不思議じゃないですか?
最良マッチングであぶれた場合には他の安定マッチング解でもあぶれるというのなら分かりますけど.
いずれにせよ,このねるとんゲームでは,「私この前あまりものになっちゃってさー,ムカツクー,でもあれ女からプロポーズしてたら結果は違ったと思うんだー」みたいな負け犬のなんとかは通じません.
「いやいや,どうやってもあなた余りますから」とトドメを刺してあげましょう.

独身の方々につきましては,どうすればいいかわかりましたよねー.

まとめ

Haskellプログラミングのチュートリアル的なものを書いてみました.
Gale-Shapleyのロジックも難解なところはないので良い題材だなーと思って採用してみましたが,我ながらとてもフツーでHaskell的には教訓らしいものがないのが困りもの.
あとこれは束(lattice)になってる?のかなーと漠然と思っているんですが,どうなんでしょう?

さいごに

このGale-Shapleyのアルゴリズムを実装したライブラリstable-marriageをhackageに最近登録しました.
1対多(一妻多夫)に対応していて,順序付けについても半順序を許容します.
よさげなら使ってみてください.