stable-matching.lisp

(defpackage #:snippets/stable-matching
  (:use #:cl)
  (:shadowing-import-from
   #:fset #:empty-map #:reduce #:with #:set #:union #:image #:empty-set
   #:lookup #:includef #:excludef #:find-if #:notevery))

(in-package #:snippets/stable-matching)

(defstruct (person (:constructor make-person (name preference-list)))
  name
  preference-list)

(defparameter *men*
  (set (make-person 'bob '(alice carol eve))
       (make-person 'dave '(carol alice eve))
       (make-person 'frank '(alice eve carol))))

(defparameter *women*
  (set (make-person 'alice '(bob dave frank))
       (make-person 'carol '(bob dave frank))
       (make-person 'eve '(bob frank dave))))

;; Find a matching such that for each pair, both the man and the woman
;; stick together because there's no better option available.  In this
;; algorithm, the men (proposers) are at an advantage.
;;
;; For the example inputs, the stable matching found by the algorithm
;; is: ((bob alice) (eve frank) (dave carol)).  Both alice and bob
;; prefer each other to every other alternative.  Frank can't go with
;; alice, so sticks with eve, which can't go with bob. Dave prefers
;; carol, and carol can't go with bob so sticks with him.

(defun find-stable-matching (&optional (men *men*) (women *women*))
  (let ((persons (reduce (lambda (map person)
                           (with map (person-name person) person))
                         (union men women)
                         :initial-value (empty-map)))
        (free-men (image #'person-name men))
        (free-women (image #'person-name women))
        (women (image #'person-name women))
        (proposals (empty-set))
        (engagements (empty-set)))
    (labels ((preference-list (x)
               (person-preference-list (lookup persons x)))
             (prefers? (chooser choice1 choice2)
               (< (position choice1 (preference-list chooser))
                  (position choice2 (preference-list chooser))))
             (propose (m w)
               (includef proposals (cons m w)))
             (proposed? (m w)
               (lookup proposals (cons m w)))
             (engage (m w)
               (excludef free-men m)
               (excludef free-women w)
               (includef engagements (set m w)))
             (release (m w)
               (excludef engagements (set m w))
               (includef free-men m)
               (includef free-women w))
             (fiance (w)
               (find-if (lambda (x) (not (eq x w)))
                        (find-if (lambda (e) (lookup e w)) engagements))))
      (loop for m = (find-if (lambda (m) (notevery (lambda (w) (proposed? m w)) women)) free-men)
            while m
            do (let ((w (find-if (lambda (w) (not (proposed? m w))) (preference-list m))))
                 (propose m w)
                 (cond ((lookup free-women w)
                        (engage m w))
                       ((prefers? w m (fiance w))
                        (release (fiance w) w)
                        (engage m w)))))
      engagements)))