Stable Marriage Problem (Gale–Shapley algorithm) in Common Lisp

Paper : galeshapley.pdf at harvard.edu.

For a quick intro, see: Stable Marriage Problem on wikipedia for more details.

The important bit here is:

In the first round, first a) each unengaged man proposes to the woman he prefers most, and then b) each woman replies “maybe” to her suitor she most prefers and “no” to all other suitors. She is then provisionally “engaged” to the suitor she most prefers so far, and that suitor is likewise provisionally engaged to her.
In each subsequent round, first a) each unengaged man proposes to the most-preferred woman to whom he has not yet proposed (regardless of whether the woman is already engaged), and then b) each woman replies “maybe” if she is currently not engaged or if she prefers this man over her current provisional partner (in this case, she rejects her current provisional partner who becomes unengaged). The provisional nature of engagements preserves the right of an already-engaged woman to “trade up” (and, in the process, to “jilt” her until-then partner).
This process is repeated until everyone is engaged.

In pseudo code:

    Initialize all m ∈ M and w ∈ W to free
    while ∃ free man m who still has a woman w to propose to do
        w := first woman on m's list to whom m has not yet proposed
        if w is free then
            (m, w) become engaged
        else some pair (m', w) already exists
            if w prefers m to m' then
                m' becomes free
                (m, w) become engaged 
            else
                (m', w) remain engaged
            end if
        end if
    repeat

In common lisp with sbcl 2.0:

(defun gale-shapley (set1 set2 prefs1 prefs2)
  "Finds a stable matching between 2 sets ordered by preference of each element using the Gale-Shapley algorithm."
  ;;; output to a file
  (with-open-file (str "./output.txt"
		       :direction :output
		       :if-exists :supersede
		       :if-does-not-exist :create)
    (format str "prefs1: ~a~%" prefs1)
    (format str "prefs2: ~a~%" prefs2)
    (let ((pairs1 (make-hash-table :test #'equal))
	  (pairs2 (make-hash-table :test #'equal)))
      (loop while (< (hash-table-count pairs1) (length set1))
	 do (loop for i from 0 to (1- (length set1)) ;;; loop until as many pairs as (length set1)
	       do (let* ((s1 (elt set1 i)) ;;; set1 A of (A B C D)
			 (pref-set1 (elt prefs2 i)))
		    (block main_loop
		      (if (null (gethash s1 pairs1))
			  (;;; not paired
			   progn
			   (loop for pref in pref-set1
			      do
				(let* ((pref-set2 (elt prefs1 (position pref set2)))
				       (current-pos (position s1 pref-set2)))
				  (if (null (gethash pref pairs2))
				      (progn 
					(setf (gethash s1 pairs1) pref)
					(setf (gethash pref pairs2) s1)  
					(return-from main_loop))
				      (progn
					(let ((previous-pos (position (gethash pref pairs2) pref-set2)))
					  (if (> previous-pos current-pos)
					      (progn
						(remhash (gethash pref pairs2) pairs1)
						(remhash pref pairs2)
						(setf (gethash s1 pairs1) pref)
						(setf (gethash pref pairs2) s1)
						(return-from main_loop))
					      )))))))
			  (;;; paired
			   progn
			    ;;;nothing to do
			   )))
		    )))
      (format str "~%===================== RESULT ==============================~%")
      (maphash #'(lambda (k v)
		   (format str "(~S, ~S) " k v)) pairs1))))

This function can be called with:

(gale-shapley '(A B C D E) '(L M N O P) '((A D B C E) (C B D A E) (C A E D B) (B D C E A) (A D E B C)) '((L P O N M) (M N O P L) (L O N M P) (M N P O L) (N P M O L)))

Which gives:

Result: '((A L) (B M) (C O) (E N) (D P))

This is a naive implementation, without any optimization, but pretty fast nonetheless.

Called with 1000 items per set (1 million preferences for each) randomly generated, we get:

  seconds  |     gc     |    consed   | calls |  sec/call  |  name  
---------------------------------------------------------
     0.797 |      0.047 | 128,742,544 |     1 |   0.796999 | GALE-SHAPLEY
---------------------------------------------------------
     0.797 |      0.047 | 128,742,544 |     1 |            | Total

Code to generate random prefs:

(defun rotate (ls)
  "Rotate the elements of a list randomly."
  (loop for i from (length ls) downto 2
       do (rotatef (elt ls (random i))
		   (elt ls (1- i))))
  ls)

(defun random-prefs (set)
  "Generate a random list of preferences based on a set."
  (labels ((random-prefs-tail (set acc)
	     (if (= (length set) (length acc))
		 acc
		 (let ((seed (rotate (loop for x from 1 to (length set) collect (elt set (1- x))))))
		   (random-prefs-tail set (cons seed acc))))))
    (random-prefs-tail set '())))

Then, a test function to generate all that:

(defun test-large (len)
  (let ((set1 (loop for x from 1 to len collect (concatenate 'string "a" (write-to-string x))))
	(set2 (loop for x from 1 to len collect (concatenate 'string "b" (write-to-string x)))))
    (gale-shapley set1 set2 (random-prefs set1) (random-prefs set2))))

And finally:

(test-large 1000)

To do:

Optimize for speed by declaring types.
Rewrite portions of the algorithm to make it faster (when current-pos is 0 for example).
Parallelize the pref loop.

Gist here.