Data commit

Task/Stable-marriage-problem/Racket/stable-marriage-problem.rkt

@@ -0,0 +1,85 @@
+#lang racket
+
+(define MEN
+  '([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 WOMEN
+  '([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 ]))
+
+;; x is better than y according to the l order
+(define (better? x y l) (memq y (cdr (memq x l))))
+
+(define (stable-matching Mprefs Wprefs)
+  (define M (map car Mprefs))
+  (define engagements (make-hasheq))
+  (define preferences (make-hasheq))
+  (define (engage! m w)
+    (hash-set! engagements m w)
+    (hash-set! engagements w m))
+  (for ([m Mprefs]) (hash-set! preferences (car m) (cdr m)))
+  (for ([w Wprefs]) (hash-set! preferences (car w) (cdr w)))
+  (let loop ()
+    (define m+w
+      (for/or ([m M])
+        (and (not (hash-ref engagements m #f))   ; m is free
+             (let ([p (hash-ref preferences m)]) ; can propose
+               (and (pair? p)
+                    (let ([w (car p)])
+                      (hash-set! preferences m (cdr p)) ; drop w from m
+                      (cons m w)))))))
+    (when m+w
+      (define m (car m+w))
+      (define w (cdr m+w))
+      (define m* (hash-ref engagements w #f))    ; m* is w's prev engagement
+      (cond [(not m*) (engage! m w)]             ; w is free
+            [(better? m m* (hash-ref preferences w)) ; w prefers m over m*
+             (engage! m w)
+             (hash-set! engagements m* #f)])     ; m* becomes free
+      (loop)))
+  engagements)
+
+(define (find-unstable Mprefs Wprefs matches)
+  (for*/or ([m (map car Mprefs)] [w (map car Wprefs)])
+    (define w* (hash-ref matches m))
+    (define m* (hash-ref matches w))
+    (and (not (eq? m m*))
+         (better? w w* (cdr (assq m Mprefs)))
+         (better? m m* (cdr (assq w Wprefs)))
+         (cons m w))))
+
+(define (check-stability)
+  (let ([u (find-unstable MEN WOMEN matches)])
+    (if u
+      (printf "Unstable: ~a and ~a prefer each other over partners.\n"
+              (car u) (cdr u))
+      (printf "The match is stable.\n"))))
+(define matches (stable-matching MEN WOMEN))
+(printf "Found matches:\n")
+(for ([m (map car MEN)]) (printf "  ~a, ~a\n" m (hash-ref matches m)))
+(check-stability)
+(let ([M (map car (take (shuffle MEN) 2))])
+  (printf "Swapping wives of ~a and ~a\n" (car M) (cadr M))
+  (define (swap! x y)
+    (define t (hash-ref matches x))
+    (hash-set! matches x (hash-ref matches y))
+    (hash-set! matches y t))
+  (swap! (car M) (cadr M))
+  (swap! (hash-ref matches (car M)) (hash-ref matches (cadr M))))
+(check-stability)