Anonymous user
Stable marriage problem: Difference between revisions
Added EchoLisp
(→{{header|REXX}}: flagged as being in need of improvement.) |
(Added EchoLisp) |
||
Line 1,840:
gay prefers jon over gav and jon prefers gay over bea
eve prefers jon over hal and jon prefers eve over bea</pre>
=={{header|EchoLisp}}==
<lang scheme>
(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)))))
</lang>
{{out}}
<pre>
(stableMatching)
👫 abe abi
👫 bob cath
👫 col hope
👫 dan ivy
👫 ed jan
👫 fred bea
👫 gav gay
👫 hal eve
💔 hope col
👫 hope ian
👫 col dee
💔 abi abe
👫 abi jon
💔 ivy dan
👫 ivy abe
👫 dan fay
((abe . ivy) (abi . jon) (bob . cath) (cath . bob) (col . dee) (hope . ian) (dan . fay) (ivy . abe) (ed . jan)
(jan . ed) (fred . bea) (bea . fred) (gav . gay) (gay . gav) (hal . eve) (eve . hal) (ian . hope) (dee . col) (jon . abi) (fay . dan))
(disengage 'abe 'ivy)
(disengage 'hope 'ian)
(engage 'abe 'hope)
(engage 'ivy 'ian)
(checkStable)
💔 abe ivy
💔 hope ian
abe hope 👫
ivy ian 👫
😡 error: not-stable (abe bea)
</pre>
=={{header|F_Sharp|F#}}==
| |||