; XEmacs: This file contains -*-Scheme-*- source code.

;;; stable-marriage: pair off the members of two sets of equal size,
;;; stably accommodating their expressed preferences

;;; John David Stone
;;; Department of Mathematics and Computer Science
;;; Grinnell College
;;; stone@cs.grinnell.edu

;;; created June 13, 1999
;;; last revised December 4, 2000

;;; Given two tables (SUITOR-PREFERENCES and CONSENTER-PREFERENCES) of
;;; equal size, each of which has as data permutations of the keys of the
;;; other, STABLE-MARRIAGE returns a table (RESULT) with the keys of
;;; SUITOR-PREFERENCES as keys and the keys of CONSENTER-PREFERENCES as
;;; data.  RESULT is stable, in the sense that for any distinct keys S0 and
;;; S1, either the datum associated with S1 precedes the datum associated
;;; with S0 in the list that SUITOR-PREFERENCES associates with S1, or S0
;;; precedes S1 in the list that CONSENTER-PREFERENCES associates with the
;;; datum that RESULT associates with S0.

;;; The guiding metaphor is that the keys of SUITOR-PREFERENCES are persons
;;; seeking to marry the keys of CONSENTER-PREFERENCES.  RESULT records the
;;; engagement of each suitor to a different consenter.  ``Instability''
;;; would be the unwanted situation in which some suitor and some consenter
;;; preferred each other to the persons to whom they are actually paired.
;;; RESULT is guaranteed to be stable, so this situation is avoided.

(define (stable-marriage suitor-preferences consenter-preferences)
  ((until (apply-to-next null-set?) (make-engager consenter-preferences))
   (null-table)
   (table-keys suitor-preferences)
   (null-set)
   suitor-preferences))

;;; MAKE-ENGAGER takes the CONSENTER-PREFERENCES table, which is constant
;;; throughout the run of the STABLE-MARRIAGE algorithm, as its argument
;;; and returns a customized procedure for advancing one step towards a
;;; stable result.  This procedure takes four arguments and returns four
;;; results; in each case, the four items are, respectively, the record of
;;; all current engagements, the set of currently unengaged suitors (i.e,,
;;; the keys of SUITOR-PREFERENCES that are not also keys of ENGAGEMENTS),
;;; the set of currently engaged suitors, and a version of the
;;; SUITOR-PREFERENCES table that omits, from each suitor's preference
;;; list, the consenters who have already turned down a proposal from that
;;; suitor.

;;; A procedure returned by MAKE-ENGAGER begins by (arbitrarily) selecting
;;; an unengaged suitor and choosing the first consenter from that suitor's
;;; preference list.  We imagine, then, that the suitor proposes to the
;;; consenter.  A consenter who is not yet engaged always agrees,
;;; tentatively, to the engagement.  For a consulter who is engaged, the
;;; preference list (as recorded in CONSENTER-PREFERENCES) is examined; if
;;; the suitor outranks the one to whom the consulter is currently engaged,
;;; the consulter breaks the engagement (returning the erstwhile fiance to
;;; the pool of unengaged suitors) and tentatively accepts the new suitor;
;;; otherwise, the consenter turns down the new engagement and is dropped
;;; from the suitor's preference list.

(define (make-engager consenter-preferences)
  (lambda (engagements unengaged engaged suitor-preferences)
    (receive (suitor other-suitors) (deset unengaged)
      (let ((suitor-list (table-get suitor-preferences suitor)))
        (let ((consenter (first suitor-list))
              (other-preferences (table-put suitor-preferences
                                            suitor
                                            (rest suitor-list))))
          (handle-exceptions signal-value
                             (values (table-put engagements suitor
                                                consenter)
                                     other-suitors
                                     (adjoin-to-set suitor engaged)
                                     other-preferences)
            (let ((fiance (find-fiance consenter engaged engagements)))
              (if (preferred? fiance
                              suitor
                              (table-get consenter-preferences consenter)) 
                  (values engagements unengaged engaged other-preferences)
                  (values (table-put (table-delete engagements fiance)
                                     suitor
                                     consenter)
                          (adjoin-to-set fiance other-suitors)
                          (adjoin-to-set suitor
                                         (disjoin-from-set fiance engaged)) 
                          other-preferences)))))))))

;;; The FIND-FIANCE procedure searches through the ENGAGEMENTS table,
;;; looking for an entry in which CONSENTER is the datum.  If it finds one,
;;; it returns the corresponding key; otherwise, it raises an exception.
;;; The set of keys of the ENGAGEMENTS is also supplied as an argument, so
;;; that it does not have to be recomputed every time.

(define (find-fiance consenter engaged engagements)
  (letrec ((step (lambda (remaining)
                   (if (null-set? remaining)
                       (signal find-fiance)
                       (receive (chosen others) (deset remaining)
                         (if (identical? (table-get engagements chosen)
                                         consenter)
                             chosen
                             (step others)))))))
    (step engaged)))

;;; The PREFERRED? predicate takes three arguments, of which the third is a
;;; list and the other two are among the elements of the list.  It returns
;;; #T if the first argument is found earlier in the list than the second,
;;; #F if the second argument is found earlier than the first.

(define (preferred? left right ls)
  (or (identical? left (first ls))
      (and (not (identical? right (first ls)))
           (preferred? left right (rest ls)))))