Solve the Stable marriage problem using the Gale/Shapley algorithm.


Problem description

Given an equal number of men and women to be paired for marriage, each man ranks all the women in order of his preference and each woman ranks all the men in order of her preference.

A stable set of engagements for marriage is one where no man prefers a woman over the one he is engaged to, where that other woman also prefers that man over the one she is engaged to. I.e. with consulting marriages, there would be no reason for the engagements between the people to change.

Gale and Shapley proved that there is a stable set of engagements for any set of preferences and the first link above gives their algorithm for finding a set of stable engagements.


Task Specifics

Given ten males:

   abe, bob, col, dan, ed, fred, gav, hal, ian, jon

And ten females:

   abi, bea, cath, dee, eve, fay, gay, hope, ivy, jan

And a complete list of ranked preferences, where the most liked is to the left:

  abe: abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay
  bob: cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay
  col: hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan
  dan: ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi
   ed: jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay
 fred: bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay
  gav: gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay
  hal: abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee
  ian: hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve
  jon: abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope
   
  abi: bob, fred, jon, gav, ian, abe, dan, ed, col, hal
  bea: bob, abe, col, fred, gav, dan, ian, ed, jon, hal
 cath: fred, bob, ed, gav, hal, col, ian, abe, dan, jon
  dee: fred, jon, col, abe, ian, hal, gav, dan, bob, ed
  eve: jon, hal, fred, dan, abe, gav, col, ed, ian, bob
  fay: bob, abe, ed, ian, jon, dan, fred, gav, col, hal
  gay: jon, gav, hal, fred, bob, abe, col, ed, dan, ian
 hope: gav, jon, bob, abe, ian, dan, hal, ed, col, fred
  ivy: ian, col, hal, gav, fred, bob, abe, ed, jon, dan
  jan: ed, hal, gav, abe, bob, jon, col, ian, fred, dan

 Use the Gale Shapley algorithm to find a stable set of engagements
 Perturb this set of engagements to form an unstable set of engagements then check this new set for stability.

References

 The Stable Marriage Problem. (Eloquent description and background information).
 Gale-Shapley Algorithm Demonstration.
 Another Gale-Shapley Algorithm Demonstration.
 Stable Marriage Problem - Numberphile (Video).
 Stable Marriage Problem (the math bit) (Video).
 The Stable Marriage Problem and School Choice. (Excellent exposition)


 
#lang racket
 
(define MEN
  '([abe  abi  eve  cath ivy  jan  dee  fay  bea  hope gay ]
    [bob  cath hope abi  dee  eve  fay  bea  jan  ivy  gay ]
    [col  hope eve  abi  dee  bea  fay  ivy  gay  cath jan ]
    [dan  ivy  fay  dee  gay  hope eve  jan  bea  cath abi ]
    [ed   jan  dee  bea  cath fay  eve  abi  ivy  hope gay ]
    [fred bea  abi  dee  gay  eve  ivy  cath jan  hope fay ]
    [gav  gay  eve  ivy  bea  cath abi  dee  hope jan  fay ]
    [hal  abi  eve  hope fay  ivy  cath jan  bea  gay  dee ]
    [ian  hope cath dee  gay  bea  abi  fay  ivy  jan  eve ]
    [jon  abi  fay  jan  gay  eve  bea  dee  cath ivy  hope]))
(define WOMEN
  '([abi  bob  fred jon  gav  ian  abe  dan  ed   col  hal ]
    [bea  bob  abe  col  fred gav  dan  ian  ed   jon  hal ]
    [cath fred bob  ed   gav  hal  col  ian  abe  dan  jon ]
    [dee  fred jon  col  abe  ian  hal  gav  dan  bob  ed  ]
    [eve  jon  hal  fred dan  abe  gav  col  ed   ian  bob ]
    [fay  bob  abe  ed   ian  jon  dan  fred gav  col  hal ]
    [gay  jon  gav  hal  fred bob  abe  col  ed   dan  ian ]
    [hope gav  jon  bob  abe  ian  dan  hal  ed   col  fred]
    [ivy  ian  col  hal  gav  fred bob  abe  ed   jon  dan ]
    [jan  ed   hal  gav  abe  bob  jon  col  ian  fred dan ]))
 
;; x is better than y according to the l order
(define (better? x y l) (memq y (cdr (memq x l))))
 
(define (stable-matching Mprefs Wprefs)
  (define M (map car Mprefs))
  (define engagements (make-hasheq))
  (define preferences (make-hasheq))
  (define (engage! m w)
    (hash-set! engagements m w)
    (hash-set! engagements w m))
  (for ([m Mprefs]) (hash-set! preferences (car m) (cdr m)))
  (for ([w Wprefs]) (hash-set! preferences (car w) (cdr w)))
  (let loop ()
    (define m+w
      (for/or ([m M])
        (and (not (hash-ref engagements m #f))   ; m is free
             (let ([p (hash-ref preferences m)]) ; can propose
               (and (pair? p)
                    (let ([w (car p)])
                      (hash-set! preferences m (cdr p)) ; drop w from m
                      (cons m w)))))))
    (when m+w
      (define m (car m+w))
      (define w (cdr m+w))
      (define m* (hash-ref engagements w #f))    ; m* is w's prev engagement
      (cond [(not m*) (engage! m w)]             ; w is free
            [(better? m m* (hash-ref preferences w)) ; w prefers m over m*
             (engage! m w)
             (hash-set! engagements m* #f)])     ; m* becomes free
      (loop)))
  engagements)
 
(define (find-unstable Mprefs Wprefs matches)
  (for*/or ([m (map car Mprefs)] [w (map car Wprefs)])
    (define w* (hash-ref matches m))
    (define m* (hash-ref matches w))
    (and (not (eq? m m*))
         (better? w w* (cdr (assq m Mprefs)))
         (better? m m* (cdr (assq w Wprefs)))
         (cons m w))))
 
(define (check-stability)
  (let ([u (find-unstable MEN WOMEN matches)])
    (if u
      (printf "Unstable: ~a and ~a prefer each other over partners.\n"
              (car u) (cdr u))
      (printf "The match is stable.\n"))))
(define matches (stable-matching MEN WOMEN))
(printf "Found matches:\n")
(for ([m (map car MEN)]) (printf "  ~a, ~a\n" m (hash-ref matches m)))
(check-stability)
(let ([M (map car (take (shuffle MEN) 2))])
  (printf "Swapping wives of ~a and ~a\n" (car M) (cadr M))
  (define (swap! x y)
    (define t (hash-ref matches x))
    (hash-set! matches x (hash-ref matches y))
    (hash-set! matches y t))
  (swap! (car M) (cadr M))
  (swap! (hash-ref matches (car M)) (hash-ref matches (cadr M))))
(check-stability)
 