Stable marriage problem: Difference between revisions

Content added Content deleted

Inline

@@ Line 199: / Line 199: @@
 Marriages are unstable</pre>
 =={{header|Haskell}}==
-{{incorrect|Haskell|Stability check should check <guy> prefers <gal> over <guys partner> AND (same) <gal> also prefers <guy> over her present partner.}}
 <lang haskell>import Data.List
 import Control.Monad
 import Control.Arrow
 import Data.Maybe
-import Data.Ord
 mp = map ((head &&& tail). splitNames)
@@ Line 232: / Line 230: @@
 splitNames = map (takeWhile(`notElem`",:")). words
+pref x y xs = fromJust (elemIndex x xs) < fromJust (elemIndex y xs)
-indexList :: (Ord a) => [a] -> [(a,Int)]
-indexList = sort. flip zip [100,99..]
+task ms fs = do
+ let
+  jos = fst $ unzip ms
+  runGS  es js ms = do
-update k rc@(v,_) = insert (v,k). delete rc
+    let (m:js') = js
-prefers a b ps     = lookup a ps > lookup b ps
+	(v:vm') = case lookup m ms of
+		    Just xs -> xs
+		    _ -> []
+	vv = fromJust $ lookup v fs
+	m2 = case lookup v es of
+		Just e -> e
+		_ -> ""
+	ms1 = insert (m,vm') $ delete (m,v:vm') ms
+    if null js then do
-stableMarr xs ys = until(all (not.isSingle).fst) updState (ims,ifs)  where
+	putStrLn ""
-  ims = map (second((,)"". indexList)) xs
+	putStrLn "=== Couples ==="
-  ifs = map (second((,)"". indexList)) ys
+	return es
-  isSingle        = null.fst.snd
-  updState (ms,fs)
+      else if null m2 then
-    | null p         = (update (v, update (-r) pc vm) mr ms, update (m,av) (v,vr) fs)
+	do putStrLn $ v ++ " with " ++ m
-    | prefers m p av = (update (v, update (-r) pc vm) mr $ update ("",pv) (p,pr) ms, update (m,av) (v,vr) fs)
+	   runGS ( insert (v,m) es ) js' ms1
-    | otherwise      = (update ("",update (-r) pc vm) mr ms, fs)
-   where
+      else if pref m m2 vv then
-    mr@(m,(_,vm)) = head $ dropWhile (not.isSingle) ms
+	do putStrLn $ v ++ " dumped " ++ m2 ++ " for " ++ m
-    pc@(v,r)      = maximumBy (comparing snd) vm
+	   runGS ( insert (v,m) $ delete (v,m2) es ) (if not $ null vm' then js'++[m2] else js') ms1
-    vr@(p,av)     = fromJust $ lookup v fs
-    pr@(_,pv)     = fromJust $ lookup p ms
+      else runGS es (if not $ null js' then js'++[m] else js') ms1
-performTask = do
-  let (ms,fs) = stableMarr mp fp
+ cs <- runGS [] jos ms
-      m1 = "fred"
-      m2 = "ian"
+ mapM_ (\(f,m) ->  putStrLn $ f ++ " with " ++ m ) cs
-      r1@(v1,vk1) = fromJust $ lookup m1 ms
+ putStrLn ""
-      r2@(v2,vk2) = fromJust $ lookup m2 ms
+ checkStab cs
-      ms' = map (second $ second(map (second abs))) $ update (v1,vk2) (m2,r2) $ update (v2,vk1) (m1,r1) ms
-      check xs ys = do
+ putStrLn ""
-	let marr = filter (\(_,_,_,b) -> b) $
+ putStrLn "Introducing error: "
-	      map (\(f, (m,_)) -> (\(p1,pm) -> (m, f, p1, prefers f p1 pm )) $ fromJust $ lookup m xs) ys
+ let [r1@(a,b), r2@(p,q)] = take 2 cs
-	if not $ null marr then do
+     r3 = (a,q)
-	    putStrLn "===> Marriages are unstable"
+     r4 = (p,b)
-	    putStrLn $ intercalate " and " $ map (\(m,f1,f2,_) -> m ++ " likes " ++ f1 ++ " better than " ++ f2) marr
+     errcs =  insert r4. insert r3. delete r2 $ delete r1 cs
-	  else putStrLn "===> Marriages are stable"
+ putStrLn $ "\tSwapping partners of " ++ a ++ " and " ++ p
-  putStrLn "1. Engagements:"
-  mapM_ (\(a,(b,_)) -> putStrLn $ "  " ++ a ++ " with " ++ b) ms
+ putStrLn $ (\((a,b),(p,q)) -> "\t" ++ a ++ " is now with " ++ b ++ " and " ++ p ++ " with " ++ q) (r3,r4)
+ putStrLn ""
-  check ms fs
+ checkStab errcs
-  putStrLn ""
-  putStrLn $ "2. Swapping partners " ++ v1 ++ " and " ++ v2 ++ " of " ++ m1 ++ " and " ++ m2
+checkStab es = do
-  check ms' fs</lang>
+  let
+    fmt (a,b,c,d) =  a ++ " and " ++ b ++ " like each other better than their current partners " ++ c ++ " and " ++ d
+    ies = uncurry(flip zip) $ unzip es  -- es = [(fem,m)]  & ies = [(m,fem)]
+    slb = map (\(f,m)-> (f,m, map (id &&& fromJust. flip lookup ies). fst.break(==m). fromJust $ lookup f fp) ) es
+    hlb = map (\(f,m)-> (m,f, map (id &&& fromJust. flip lookup es ). fst.break(==f). fromJust $ lookup m mp) ) es
+    tslb = concatMap (filter snd. (\(f,m,ls) ->
+				map (\(m2,f2) ->
+				      ((f,m2,f2,m), pref f f2 $ fromJust $ lookup m2 mp)) ls)) slb
+    thlb = concatMap (filter snd. (\(m,f,ls) ->
+				map (\(f2,m2) ->
+				      ((m,f2,m2,f), pref m m2 $ fromJust $ lookup f2 fp)) ls)) hlb
+    res = tslb ++ thlb
+  if not $ null res then do
+    putStrLn "Marriages are unstable, e.g.:"
+    putStrLn.fmt.fst $ head res
+   else putStrLn "Marriages are stable"</lang>
 Task:
-<lang haskell>*Main> performTask
+<lang haskell>*Main> task mp fp
+abi with abe
-. Engagements:
-  abe with ivy
+cath with bob
-  bob with cath
+hope with col
-  col with dee
+ivy with dan
-  dan with fay
+jan with ed
-  ed with jan
+bea with fred
-  fred with bea
+gay with gav
+hope dumped col for ian
-  gav with gay
+abi dumped abe for jon
-  hal with eve
-  ian with hope
+eve with hal
-  jon with abi
+dee with col
+ivy dumped dan for abe
-===> Marriages are stable
+fay with dan
+=== Couples ===
+abi with jon
+bea with fred
+cath with bob
+dee with col
+eve with hal
+fay with dan
+gay with gav
+hope with ian
+ivy with abe
+jan with ed
+Marriages are stable
+Introducing error:
+        Swapping partners of abi and bea
+        abi is now with fred and bea with jon
+Marriages are unstable, e.g.:
-. Swapping partners bea and hope of fred and ian
+bea and fred like each other better than their current partners abi and jon</lang>
-===> Marriages are unstable
-fred likes bea better than hope and ian likes hope better than bea</lang>
 =={{header|Java}}==