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

Paper : galeshapley.pdf at

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

The important bit here is:

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 
                (m', w) remain engaged
            end if
        end if

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
			   (loop for pref in pref-set1
				(let* ((pref-set2 (elt prefs1 (position pref set2)))
				       (current-pos (position s1 pref-set2)))
				  (if (null (gethash pref pairs2))
					(setf (gethash s1 pairs1) pref)
					(setf (gethash pref pairs2) s1)  
					(return-from main_loop))
					(let ((previous-pos (position (gethash pref pairs2) pref-set2)))
					  (if (> previous-pos current-pos)
						(remhash (gethash pref pairs2) pairs1)
						(remhash pref pairs2)
						(setf (gethash s1 pairs1) pref)
						(setf (gethash pref pairs2) s1)
						(return-from main_loop))
			  (;;; paired
			    ;;;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))))

(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))
		 (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:

Gist here.