74 lines
2.7 KiB
Text
74 lines
2.7 KiB
Text
(lib 'hash)
|
|
;; input data
|
|
(define M-RANKS
|
|
'(( abe abi eve cath ivy jan dee fay bea hope gay)
|
|
( bob cath hope abi dee eve fay bea jan ivy gay)
|
|
( col hope eve abi dee bea fay ivy gay cath jan)
|
|
( dan ivy fay dee gay hope eve jan bea cath abi)
|
|
( ed jan dee bea cath fay eve abi ivy hope gay)
|
|
( fred bea abi dee gay eve ivy cath jan hope fay)
|
|
( gav gay eve ivy bea cath abi dee hope jan fay)
|
|
( hal abi eve hope fay ivy cath jan bea gay dee)
|
|
( ian hope cath dee gay bea abi fay ivy jan eve)
|
|
( jon abi fay jan gay eve bea dee cath ivy hope)))
|
|
|
|
(define W-RANKS
|
|
'(( abi bob fred jon gav ian abe dan ed col hal)
|
|
( bea bob abe col fred gav dan ian ed jon hal)
|
|
( cath fred bob ed gav hal col ian abe dan jon)
|
|
( dee fred jon col abe ian hal gav dan bob ed)
|
|
( eve jon hal fred dan abe gav col ed ian bob)
|
|
( fay bob abe ed ian jon dan fred gav col hal)
|
|
( gay jon gav hal fred bob abe col ed dan ian)
|
|
( hope gav jon bob abe ian dan hal ed col fred)
|
|
( ivy ian col hal gav fred bob abe ed jon dan)
|
|
( jan ed hal gav abe bob jon col ian fred dan)))
|
|
|
|
;; build preferences hash
|
|
(define (set-prefs ranks prefs)
|
|
(for/list ((r ranks))
|
|
(hash-set prefs (first r) (rest r))
|
|
(first r)))
|
|
|
|
(define (engage m w) (hash-set ENGAGED m w) (hash-set ENGAGED w m) (writeln m w '👫 ))
|
|
(define (disengage m w) (hash-remove! ENGAGED m ) (hash-remove! ENGAGED w) (writeln '💔 m w))
|
|
(define (engaged x) (hash-ref ENGAGED x))
|
|
(define (free? x) (not (engaged x)))
|
|
(define (free-man men) (for ((man men)) #:break (free? man) => man #f))
|
|
|
|
|
|
(define (prefers? prefs x a b) (member b (member a (hash-ref prefs x))))
|
|
;; get first choice and remove it from prefs list
|
|
(define (first-choice prefs m)
|
|
(define w (first (hash-ref prefs m)))
|
|
(hash-set prefs m (rest (hash-ref prefs m)))
|
|
w)
|
|
|
|
;; sets ENGAGED couples
|
|
;; https//en.wikipedia.org/wiki/Stable_marriage_problem
|
|
|
|
(define (stableMatching (prefs (make-hash)) (m) (w))
|
|
(define-global 'ENGAGED (make-hash))
|
|
(define men (set-prefs M-RANKS prefs))
|
|
(define women (set-prefs W-RANKS prefs))
|
|
(while (setv! m (free-man men))
|
|
(set! w (first-choice prefs m))
|
|
(if (free? w)
|
|
(engage m w)
|
|
(let [(dumped (engaged w))]
|
|
(when (prefers? prefs w m dumped)
|
|
(disengage w dumped)
|
|
(engage w m)))))
|
|
(hash->list ENGAGED))
|
|
|
|
;; input : ENGAGED couples
|
|
(define (checkStable (prefs (make-hash)))
|
|
(define men (set-prefs M-RANKS prefs))
|
|
(define women (set-prefs W-RANKS prefs))
|
|
(for* [(man men) (woman women)]
|
|
#:continue (equal? woman (engaged man))
|
|
(when (and
|
|
(prefers? prefs man woman (engaged man))
|
|
(prefers? prefs woman man (engaged woman)))
|
|
(error 'not-stable (list man woman)))))
|
|
|