Gale-Shaply Algorithm in Common Lisp

Description of the problem

Assume we have two disjoint finite sets. Let us call them L and R. We want to pair each element in L with a unique element in R. However, we also have some constraints: we also assume that each element in L declared a list of preferences of vertices they want to be matched, and vice versa. A one-to-one matching M between L and R is called stable if any subset of M is altered to obtain another matching M’ then there is at least one matching $(x,y)$ in M’ where both $x$ and $y$ are matched with their lesser choices than their original match M.

The problem of finding such stable matchings is called the Stable Matching Problem, and you can find a detailed description of the problem here.

Gale-Shaply Algorithm

Gale and Shaply came up with a deferred acceptence algorithm that produces a stable match, however, it is not symmetric in L and R. The algorithm favors the proposing party rather than the proposees. Here is the pseudo-code

Algorithm Gale-Shaply:
Input: Two disjoint finite sets L and R
       A list of permutations PR of L indexed by R
       A list of permutations PL of R indexed by L
Output: A one-to-one stable matching between L and R
Begin
  For each y in R set Prop(y) to the empty set
  For each x in L
      Let m be the top choice of x in PL(x)
      Add (x,m) to Prop(m)
  End
  If Prop is a one-to-one matching
     Return Prop
  Else
     For each y in R
        Let n be the top choice of y in L
            such that (n,y) is in Prop(y)
        For each x in Prop(y) \ { (n,y) }
            Remove (x,y) from PL(x)
        End
     End
  End
  Call Gale-Shaply with L, R, PR and the new PL
End

Here is a more intuitive natural language description:

Every element in L proposes to its top choice on the list of preferences. Every element in R conditionally accepts the proposal from its top choice among those who proposed, and rejects the other proposals. We continue the process: Every element in L send in a new proposal with its top choice out of those who have not yet rejected it. Every element in R conditionally accepts the proposal from its top choice among those who proposed, and rejects the other proposals. This process continues until we achieve a one-to-one match.

An implementation in Common Lisp

Before implementing the algorithm above, I am going to need a utility function called assoc-merge. I need this to merge association lists in a particular way.

(defun merge-assoc (xs)
  (let (res)
    (dolist (x xs res)
      (let* ((k (car x))
             (r (cdr (assoc k res :test #'equal))))
        (if r
            (rplacd (assoc k res :test #'equal) (push (cadr x) r))
            (push x res))))))

MERGE-ASSOC

Let me show you how this works:

(merge-assoc '((:a 1) (:b 2) (:c 3) (:a 10) (:b 20)))

((C 3) (B 20 2) (A 10 1))

And here is my implementation of Gale-Shaply:

(defun gale-shaply (left right &optional (n 0))
  (labels ((maximal (unordered ordered)
             (car (remove-if-not (lambda (x) (member x unordered)) ordered))))
    (let* (;; this round of proposals
           (pro (mapcar (lambda (xs) (list (car xs) (cadr xs))) left)) 
           ;; now count on the RHS how many offers each candidate received
           (img (remove-duplicates (mapcar #'cdr pro) :test #'equal))) 
      (if (= (length left) (length img))
          ;; if each candidate on the RHS received one proposal STOP
          (list :numsteps n :solution pro)
          (let* (;; otherwise, first calculate what are the top choices of the candidates
                 (acc (mapcar (lambda (x)   
                                (list (maximal (cdr x) (cdr (assoc (car x) right :test #'equal)))
                                      (car x)))
                              (merge-assoc (mapcar #'reverse pro))))
                 ;; next reject the rest
                 (rej (remove-if (lambda (x) (member x acc :test #'equal)) pro)))
            ;; do another round with the updated list of preferences
            (gale-shaply (mapcar (lambda (x)
                                    (let ((v (cadr (assoc (car x) rej :test #'equal))))
                                      (cons (car x) (remove v (cdr x) :test #'equal))))
                                  left)
                          right
                          (1+ n)))))))

GALE-SHAPLY

In order to test this, I am going to need random permutations:

(defun random-permutation (xs)
  (let* ((n (length xs))
         (ys (mapcar #'cons (copy-list xs) (loop for i from 1 to n collect (random n)))))
    (mapcar #'car (sort ys #'< :key #'cdr))))

RANDOM-PERMUTATION

Let us test this:

(random-permutation '(:a :b :c :d))

(C D A B)

And finally our test function for the algorithm:

 (let* ((N 8)
    (A (loop for i from 0 below N collect (format nil "y~d" i)))
    (B (loop for i from 0 below N collect (format nil "x~d" i)))
    (left (mapcar #'cons A (loop repeat N collect (random-permutation B))))
    (right (mapcar #'cons B (loop repeat N collect (random-permutation A)))))
   (append (list :left left :right right) (gale-shaply left right)))

(LEFT
 ((y0 x4 x3 x6 x7 x5 x1 x0 x2) (y1 x0 x4 x1 x3 x2 x5 x7 x6)
  (y2 x1 x4 x7 x5 x3 x0 x6 x2) (y3 x2 x6 x5 x0 x3 x7 x1 x4)
  (y4 x3 x5 x7 x0 x2 x6 x1 x4) (y5 x4 x5 x3 x1 x0 x2 x6 x7)
  (y6 x6 x0 x4 x7 x2 x3 x1 x5) (y7 x4 x5 x3 x1 x7 x0 x2 x6))
 RIGHT
 ((x0 y7 y5 y0 y1 y4 y6 y2 y3) (x1 y2 y4 y7 y6 y1 y0 y3 y5)
  (x2 y2 y6 y4 y5 y7 y1 y3 y0) (x3 y1 y2 y6 y0 y4 y3 y5 y7)
  (x4 y5 y2 y6 y1 y3 y0 y4 y7) (x5 y0 y4 y5 y6 y1 y3 y7 y2)
  (x6 y2 y3 y1 y5 y7 y0 y4 y6) (x7 y1 y0 y3 y7 y2 y4 y5 y6))
 NUMSTEPS 5 SOLUTION
 ((y0 x3) (y1 x0) (y2 x1) (y3 x2) (y4 x5) (y5 x4) (y6 x6) (y7 x7)))