Anonymous user
Stable marriage problem: Difference between revisions
→{{header|Haskell}}: replaced with more verbose and corrected version
m (→{{header|Python}}: spacing) |
(→{{header|Haskell}}: replaced with more verbose and corrected version) |
||
Line 199:
Marriages are unstable</pre>
=={{header|Haskell}}==
<lang haskell>import Data.List
import Control.Monad
import Control.Arrow
import Data.Maybe
mp = map ((head &&& tail). splitNames)
Line 232 ⟶ 230:
splitNames = map (takeWhile(`notElem`",:")). words
pref x y xs = fromJust (elemIndex x xs) < fromJust (elemIndex y xs)
task ms fs = do
let
jos = fst $ unzip ms
runGS es js ms = do
let (m:js') = js
(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
putStrLn ""
putStrLn "=== Couples ==="
return es
else if null m2 then
do putStrLn $ v ++ " with " ++ m
runGS ( insert (v,m) es ) js' ms1
else if pref m m2 vv then
do putStrLn $ v ++ " dumped " ++ m2 ++ " for " ++ m
runGS ( insert (v,m) $ delete (v,m2) es ) (if not $ null vm' then js'++[m2] else js') ms1
else runGS es (if not $ null js' then js'++[m] else js') ms1
cs <- runGS [] jos ms
mapM_ (\(f,m) -> putStrLn $ f ++ " with " ++ m ) cs
putStrLn ""
checkStab cs
putStrLn ""
putStrLn "Introducing error: "
let [r1@(a,b), r2@(p,q)] = take 2 cs
r3 = (a,q)
r4 = (p,b)
errcs = insert r4. insert r3. delete r2 $ delete r1 cs
putStrLn $ "\tSwapping partners of " ++ a ++ " and " ++ p
putStrLn
putStrLn ""
checkStab errcs
checkStab es = do
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>
abi with abe
hope dumped col for ian
abi dumped abe for jon
ivy dumped dan for abe
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.:
bea and fred like each other better than their current partners abi and jon</lang>
=={{header|Java}}==
| |||