Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- (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)))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement