Stable marriage problem

Stable marriage problem
You are encouraged to solve this task according to the task description, using any language you may know.

Solve the Stable marriage problem using the Gale/Shapley algorithm.

Problem description
Given an equal number of men and women to be paired for marriage, each man ranks all the women in order of his preference and each women ranks all the men in order of her preference.

A stable set of engagements for marriage is one where no man prefers a women over the one he is engaged to, where that other woman also prefers that man over the one she is engaged to. I.e. with consulting marriages, there would be no reason for the engagements between the people to change.

Gale and Shipley proved that there is a stable set of engagements for any set of preferences and the first link above gives their algorithm for finding a set of stable engagements.

Task Specifics
Given ten males:

   abe, bob, col, dan, ed, fred, gav, hal, ian, jon

And ten females:

   abi, bea, cath, dee, eve, fay, gay, hope, ivy, jan

And a complete list of ranked preferences, where the most liked is to the left:

  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
   
  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

1. Use the Gale Shapley algorithm to find a stable set of engagements
2. Perturb this set of engagements to form an unstable set of engagements then check this new set for stability.

References

1. The Stable Marriage Problem. (Eloquent description and background information).
2. Gale-Shapley Algorithm Demonstration.

D

D v.2, adapted from the Python and Java versions. <lang d>import std.stdio: writeln, writefln; import std.array: popFront; import std.algorithm: indexOf, swap; import std.string: split, splitlines;

string[string] matchmaker(const string[][string] guyPrefers,

                         const string[][string] girlPrefers) {
   string[string] engagedTo;
   string[] freeGuys = guyPrefers.keys;

   while (freeGuys.length) {
       const auto string thisGuy = freeGuys[0];
       freeGuys.popFront();
       const auto thisGuyPrefers = guyPrefers[thisGuy];
       foreach (girl; thisGuyPrefers) {
           if (girl !in engagedTo) { // girl is free
               engagedTo[girl] = thisGuy;
               break;
           } else {
               string otherGuy = engagedTo[girl];
               const string[] thisGirlPrefers = girlPrefers[girl];
               if (thisGirlPrefers.indexOf(thisGuy) < thisGirlPrefers.indexOf(otherGuy)) {
                   // this girl prefers this guy to the guy she's engagedTo to
                   engagedTo[girl] = thisGuy;
                   freeGuys ~= otherGuy;
                   break;
               }
               // else no change, keep looking for this guy
           }
       }
   }

   return engagedTo;

}

bool check(bool doPrint=false)(const string[string] engagedTo,

                              const string[][string] guyPrefers,
                              const string[][string] galPrefers) {
   enum MSG = "%s likes %s better than %s and %s likes %s better than their current partner";
   string[string] inverseEngaged;
   foreach (k, v; engagedTo)
       inverseEngaged[v] = k;

   foreach (she, he; engagedTo) {
       const auto sheLikes = galPrefers[she];
       const auto sheLikesBetter = sheLikes[0 .. sheLikes.indexOf(he)];
       const auto heLikes = guyPrefers[he];
       const auto heLikesBetter = heLikes[0 .. heLikes.indexOf(she)];
       foreach (guy; sheLikesBetter) {
           const auto guysGirl = inverseEngaged[guy];
           const auto guyLikes = guyPrefers[guy];

           if (guyLikes.indexOf(guysGirl) > guyLikes.indexOf(she)) {
               static if (doPrint)
                   writefln(MSG, she, guy, he, guy, she);
               return false;
           }
       }

       foreach (gal; heLikesBetter) {
           const auto girlsGuy = engagedTo[gal];
           const auto galLikes = galPrefers[gal];

           if (galLikes.indexOf(girlsGuy) > galLikes.indexOf(he)) {
               static if (doPrint)
                   writefln(MSG, he, gal, she, gal, he);
               return false;
           }
       }
   }

   return true;

}

void main() {

   auto guyData = "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";

   auto galData = "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";

   string[][string] guyPrefers, galPrefers;
   foreach (line; guyData.splitlines())
       guyPrefers[split(line)[0]] = split(line)[1..$];
   foreach (line; galData.splitlines())
       galPrefers[split(line)[0]] = split(line)[1..$];

   writeln("Engagements:");
   auto engagedTo = matchmaker(guyPrefers, galPrefers);

   writeln("\nCouples:");
   string[] parts;
   foreach (k; engagedTo.keys.sort)
       writefln("%s is engagedTo to %s", k, engagedTo[k]);
   writeln();

   bool c = check!(true)(engagedTo, guyPrefers, galPrefers);
   writeln("Marriages are ", c ? "stable" : "unstable");

   writeln("\n\nSwapping two fiances to introduce an error");
   auto gals = galPrefers.keys.sort;
   swap(engagedTo[gals[0]], engagedTo[gals[1]]);
   foreach (gal; gals[0 .. 2])
       writefln("  %s is now engagedTo to %s", gal, engagedTo[gal]);
   writeln();

   c = check!(true)(engagedTo, guyPrefers, galPrefers);
   writeln("Marriages are ", c ? "stable" : "unstable");

}</lang> Output:

Engagements:

Couples:
abi is engagedTo to jon
bea is engagedTo to fred
cath is engagedTo to bob
dee is engagedTo to col
eve is engagedTo to hal
fay is engagedTo to dan
gay is engagedTo to gav
hope is engagedTo to ian
ivy is engagedTo to abe
jan is engagedTo to ed

Marriages are stable


Swapping two fiances to introduce an error
  abi is now engagedTo to fred
  bea is now engagedTo to jon

fred likes bea better than abi and bea likes fred better than their current partner
Marriages are unstable

Haskell

<lang haskell>import Data.List import Control.Monad import Control.Arrow import Data.Maybe

mp = map ((head &&& tail). splitNames)

  ["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"]
  

fp = map ((head &&& tail). splitNames)

   ["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"]

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 $ (\((a,b),(p,q)) -> "\t" ++ a ++ " is now with " ++ b ++ " and " ++ p ++ " with " ++ q) (r3,r4)
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> task mp fp abi with abe cath with bob hope with col ivy with dan jan with ed bea with fred gay with gav hope dumped col for ian abi dumped abe for jon eve with hal dee with col 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>

Java

This is not a direct translation of Python, but it's fairly close (especially the stability check). <lang java5>import java.util.*;

public class Stable {

   static List<String> guys = Arrays.asList(
           new String[]{
       "abe", "bob", "col", "dan", "ed", "fred", "gav", "hal", "ian", "jon"});
   static List<String> girls = Arrays.asList(
           new String[]{
       "abi", "bea", "cath", "dee", "eve", "fay", "gay", "hope", "ivy", "jan"});
   static Map<String, List<String>> guyPrefers =
           new HashMap<String, List<String>>(){{
       put("abe",
           Arrays.asList("abi", "eve", "cath", "ivy", "jan", "dee", "fay",
           "bea", "hope", "gay"));
       put("bob",
           Arrays.asList("cath", "hope", "abi", "dee", "eve", "fay", "bea",
           "jan", "ivy", "gay"));
       put("col",
           Arrays.asList("hope", "eve", "abi", "dee", "bea", "fay", "ivy",
           "gay", "cath", "jan"));
       put("dan",
           Arrays.asList("ivy", "fay", "dee", "gay", "hope", "eve", "jan",
           "bea", "cath", "abi"));
       put("ed",
           Arrays.asList("jan", "dee", "bea", "cath", "fay", "eve", "abi",
           "ivy", "hope", "gay"));
       put("fred",
           Arrays.asList("bea", "abi", "dee", "gay", "eve", "ivy", "cath",
           "jan", "hope", "fay"));
       put("gav",
           Arrays.asList("gay", "eve", "ivy", "bea", "cath", "abi", "dee",
           "hope", "jan", "fay"));
       put("hal",
           Arrays.asList("abi", "eve", "hope", "fay", "ivy", "cath", "jan",
           "bea", "gay", "dee"));
       put("ian",
           Arrays.asList("hope", "cath", "dee", "gay", "bea", "abi", "fay",
           "ivy", "jan", "eve"));
       put("jon",
           Arrays.asList("abi", "fay", "jan", "gay", "eve", "bea", "dee",
           "cath", "ivy", "hope"));
   }};
   static Map<String, List<String>> girlPrefers =
           new HashMap<String, List<String>>(){{
       put("abi",
           Arrays.asList("bob", "fred", "jon", "gav", "ian", "abe", "dan",
           "ed", "col", "hal"));
       put("bea",
           Arrays.asList("bob", "abe", "col", "fred", "gav", "dan", "ian",
           "ed", "jon", "hal"));
       put("cath",
           Arrays.asList("fred", "bob", "ed", "gav", "hal", "col", "ian",
           "abe", "dan", "jon"));
       put("dee",
           Arrays.asList("fred", "jon", "col", "abe", "ian", "hal", "gav",
           "dan", "bob", "ed"));
       put("eve",
           Arrays.asList("jon", "hal", "fred", "dan", "abe", "gav", "col",
           "ed", "ian", "bob"));
       put("fay",
           Arrays.asList("bob", "abe", "ed", "ian", "jon", "dan", "fred",
           "gav", "col", "hal"));
       put("gay",
           Arrays.asList("jon", "gav", "hal", "fred", "bob", "abe", "col",
           "ed", "dan", "ian"));
       put("hope",
           Arrays.asList("gav", "jon", "bob", "abe", "ian", "dan", "hal",
           "ed", "col", "fred"));
       put("ivy",
           Arrays.asList("ian", "col", "hal", "gav", "fred", "bob", "abe",
           "ed", "jon", "dan"));
       put("jan",
           Arrays.asList("ed", "hal", "gav", "abe", "bob", "jon", "col",
           "ian", "fred", "dan"));
   }};
   public static void main(String[] args){
       Map<String, String> matches = match(guys, guyPrefers, girlPrefers);
       for(Map.Entry<String, String> couple:matches.entrySet()){
           System.out.println(
                   couple.getKey() + " is engaged to " + couple.getValue());
       }
       if(checkMatches(guys, girls, matches, guyPrefers, girlPrefers)){
           System.out.println("Marriages are stable");
       }else{
           System.out.println("Marriages are unstable");
       }
       String tmp = matches.get(girls.get(0));
       matches.put(girls.get(0), matches.get(girls.get(1)));
       matches.put(girls.get(1), tmp);
       System.out.println(
               girls.get(0) +" and " + girls.get(1) + " have switched partners");
       if(checkMatches(guys, girls, matches, guyPrefers, girlPrefers)){
           System.out.println("Marriages are stable");
       }else{
           System.out.println("Marriages are unstable");
       }
   }

   private static Map<String, String> match(List<String> guys,
           Map<String, List<String>> guyPrefers,
           Map<String, List<String>> girlPrefers){
       Map<String, String> engagedTo = new TreeMap<String, String>();
       List<String> freeGuys = new LinkedList<String>();
       freeGuys.addAll(guys);
       while(!freeGuys.isEmpty()){
           String thisGuy = freeGuys.remove(0); //get a load of THIS guy
           List<String> thisGuyPrefers = guyPrefers.get(thisGuy);
           for(String girl:thisGuyPrefers){
               if(engagedTo.get(girl) == null){//girl is free
                   engagedTo.put(girl, thisGuy); //awww
                   break;
               }else{
                   String otherGuy = engagedTo.get(girl);
                   List<String> thisGirlPrefers = girlPrefers.get(girl);
                   if(thisGirlPrefers.indexOf(thisGuy) <
                           thisGirlPrefers.indexOf(otherGuy)){
                       //this girl prefers this guy to the guy she's engaged to
                       engagedTo.put(girl, thisGuy);
                       freeGuys.add(otherGuy);
                       break;
                   }//else no change...keep looking for this guy
               }
           }
       }
       return engagedTo;
   }

   private static boolean checkMatches(List<String> guys, List<String> girls,
           Map<String, String> matches, Map<String, List<String>> guyPrefers,
           Map<String, List<String>> girlPrefers) {
       if(!matches.keySet().containsAll(girls)){
           return false;
       }

       if(!matches.values().containsAll(guys)){
           return false;
       }

       Map<String, String> invertedMatches = new TreeMap<String, String>();
       for(Map.Entry<String, String> couple:matches.entrySet()){
           invertedMatches.put(couple.getValue(), couple.getKey());
       }

       for(Map.Entry<String, String> couple:matches.entrySet()){
           List<String> shePrefers = girlPrefers.get(couple.getKey());
           List<String> sheLikesBetter = new LinkedList<String>();
           for(int i = 0; i < shePrefers.indexOf(couple.getValue());i++){
               sheLikesBetter.add(shePrefers.get(i));
           }
           List<String> hePrefers = guyPrefers.get(couple.getValue());
           List<String> heLikesBetter = new LinkedList<String>();
           for(int i = 0; i < hePrefers.indexOf(couple.getKey());i++){
               heLikesBetter.add(hePrefers.get(i));
           }

           for(String guy : sheLikesBetter){
               String guysFinace = invertedMatches.get(guy);
               List<String> thisGuyPrefers = guyPrefers.get(guy);
               if(thisGuyPrefers.indexOf(guysFinace) >
                       thisGuyPrefers.indexOf(couple.getKey())){
                   System.out.printf("%s likes %s better than %s and %s"
                           + " likes %s better than their current partner\n",
                      couple.getKey(), guy, couple.getValue(),
                      guy, couple.getKey());
                   return false;
               }
           }

           for(String girl : heLikesBetter){
               String girlsFinace = matches.get(girl);
               List<String> thisGirlPrefers = girlPrefers.get(girl);
               if(thisGirlPrefers.indexOf(girlsFinace) >
                       thisGirlPrefers.indexOf(couple.getValue())){
                   System.out.printf("%s likes %s better than %s and %s"
                           + " likes %s better than their current partner\n",
                      couple.getValue(), girl, couple.getKey(),
                      girl, couple.getValue());
                   return false;
               }
           }
       }
       return true;
   }

}</lang> Output:

abi is engaged to jon
bea is engaged to fred
cath is engaged to bob
dee is engaged to col
eve is engaged to hal
fay is engaged to dan
gay is engaged to gav
hope is engaged to ian
ivy is engaged to abe
jan is engaged to ed
Marriages are stable
abi and bea have switched partners
fred likes bea better than abi and bea likes fred better than their current partner
Marriages are unstable

OCaml

This example is incorrect. Please fix the code and remove this message. Details: No output is shown

<lang ocaml>let 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"];

]

let 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"];

]

type woman_name = string type man_name = string

type man =

 { m_name: man_name;
   free: bool;
   women_rank: woman_name list;
   has_proposed: woman_name list }

type woman =

 { w_name: woman_name;
   men_rank: man_name list;
   engaged: man_name option }

let free_men men =

 List.filter (fun m -> m.free) men

let replace m ms =

 let rec aux acc = function
 | _m::ms ->
     if _m.m_name = m.m_name
     then List.rev_append acc (m::ms)
     else aux (_m::acc) ms
 | [] -> invalid_arg "replace"
 in
 aux [] ms

let becomes_free m_name ms =

 let m = List.find (fun m -> m.m_name = m_name) ms in
 let m = { m with free = true } in
 replace m ms

let rank_of w m =

 let rec aux i = function
 | _m::ms ->
     if _m = m
     then i
     else aux (succ i) ms
 | [] -> invalid_arg "rank_of"
 in
 aux 0 w.men_rank

let get_highest_ranked m =

 (* highest ranked woman who the man has not proposed to yet *)
 let rec aux = function
 | w::ws ->
     if List.mem w m.has_proposed
     then aux ws
     else (w)
 | [] -> invalid_arg "get_highest_ranked"
 in
 aux m.women_rank

let more_ranked_than name rank =

 let rec aux acc = function
 | x::xs ->
     if x = name
     then (List.rev acc)
     else aux (x::acc) xs
 | [] -> (List.rev acc)
 in
 aux [] rank

let build_structs ~men ~women =

 List.map (fun (name, rank) ->
   { m_name = name;
     women_rank = rank;
     free = true;
     has_proposed = [] }
 ) men,
 List.map (fun (name, rank) ->
   { w_name = name;
     men_rank = rank;
     engaged = None }
 ) women

let _stable_matching ms ws =

 let rec aux ms ws =
   match free_men ms with (*TODO free men who still has some w to propose to *)
   | [] -> (ms, ws)
   | m::_ ->
       let w = get_highest_ranked m in
       let m = { m with has_proposed = w :: m.has_proposed } in
       let w, ws = List.partition (fun _w -> _w.w_name = w) ws in
       let w = List.hd w in
       match w.engaged with
       | None -> (* w is free *)
           (* (m, w) become engaged *)
           let w = { w with engaged = Some m.m_name }
           and m = { m with free = false } in
           aux (replace m ms) (w::ws)
       | Some m' -> (* some pair (m', w) already exists *)
           if (rank_of w m.m_name) > (rank_of w m')
           then
             aux (replace m ms) (w::ws)  (* (m', w) remain engaged *)
           else begin (* w prefers m to m' *)
             let w = { w with engaged = Some m.m_name }
             and m = { m with free = false } in
             aux (replace m (becomes_free m' ms)) (w::ws)
           end
 in
 aux ms ws

let stable_matching ~men ~women =

 let ms, ws = build_structs ~men ~women in
 let _, ws = _stable_matching ms ws in
 let some = function Some v -> v | None -> "" in
 let engagements = List.map (fun w -> w.w_name, some w.engaged) ws in
 (engagements)

let is_stable ~men ~women eng =

 let ms, ws = build_structs ~men ~women in
 try
   List.iter (fun (wn, mn) ->
     let m = List.find (fun m -> m.m_name = mn) ms in
     let prefered_women = more_ranked_than wn m.women_rank in
     List.iter (fun pref_w ->
       let w = List.find (fun w -> w.w_name = pref_w) ws in
       let eng_m = List.assoc pref_w eng in
       let prefered_men = more_ranked_than eng_m w.men_rank in
       if List.mem m.m_name prefered_men
       then raise Exit  (* one unstable engagement found *)
     ) prefered_women
   ) eng;
   (true)
 with Exit ->
   (false)

let perturb_engagements eng =

 Random.self_init();
 let eng = Array.of_list eng in
 let len = Array.length eng in
 for n = 1 to 3 do
   let i = Random.int len
   and j = Random.int len in
   let w1, m1 = eng.(i)
   and w2, m2 = eng.(j) in
   eng.(i) <- (w1, m2);
   eng.(j) <- (w2, m1);
 done;
 Array.to_list eng

let print engs =

 List.iter (fun (w,m) ->
   Printf.printf " %4s is engaged with %s\n" w m) engs;
 Printf.printf "# Engagements %s stable\n"
   (if is_stable ~men ~women engs then "are" else "are not")

let () =

 let engagements = stable_matching ~men ~women in
 print engagements;
 print_endline "========================";
 let engagements = perturb_engagements engagements in
 print engagements;

</lang>

PicoLisp

<lang PicoLisp>(setq

  *Boys (list
     (de abe  abi eve cath ivy jan dee fay bea hope gay)
     (de bob  cath hope abi dee eve fay bea jan ivy gay)
     (de col  hope eve abi dee bea fay ivy gay cath jan)
     (de dan  ivy fay dee gay hope eve jan bea cath abi)
     (de ed   jan dee bea cath fay eve abi ivy hope gay)
     (de fred bea abi dee gay eve ivy cath jan hope fay)
     (de gav  gay eve ivy bea cath abi dee hope jan fay)
     (de hal  abi eve hope fay ivy cath jan bea gay dee)
     (de ian  hope cath dee gay bea abi fay ivy jan eve)
     (de jon  abi fay jan gay eve bea dee cath ivy hope) )
  *Girls (list
     (de bi   bob fred jon gav ian abe dan ed col hal)
     (de bea  bob abe col fred gav dan ian ed jon hal)
     (de cath fred bob ed gav hal col ian abe dan jon)
     (de dee  fred jon col abe ian hal gav dan bob ed)
     (de eve  jon hal fred dan abe gav col ed ian bob)
     (de fay  bob abe ed ian jon dan fred gav col hal)
     (de gay  jon gav hal fred bob abe col ed dan ian)
     (de hope gav jon bob abe ian dan hal ed col fred)
     (de ivy  ian col hal gav fred bob abe ed jon dan)
     (de jan  ed hal gav abe bob jon col ian fred dan) )
  *Couples NIL )

(bind *Boys

  (while
     (find
        '((Boy) (and (val Boy) (not (asoq Boy *Couples))))
        *Boys )
     (let (Boy @  Girl (pop Boy)  Pair (find '((P) (== Girl (cdr P))) *Couples))
        (nond
           (Pair (push '*Couples (cons Boy Girl)))   # Girl is free
           ((memq Boy (memq (car Pair) (val Girl)))  # Girl prefers Boy
              (set Pair Boy) ) ) ) ) )

(for Pair *Couples

  (prinl (cdr Pair) " is engaged to " (car Pair)) )

(de checkCouples ()

  (unless
     (filter
        '((Pair)
           (let (Boy (car Pair)  Girl (cdr Pair))
              (find
                 '((B)
                    (and
                       (memq Boy (cdr (memq B (val Girl))))  # Girl prefers B
                       (memq
                          (cdr (asoq B *Couples))            # and B prefers Girl
                          (cdr (memq Girl (val B))) )
                       (prinl
                          Girl " likes " B " better than " Boy " and "
                          B " likes " Girl " better than "
                          (cdr (asoq B *Couples)) ) ) )
                 (val Girl) ) ) )
        *Couples )
     (prinl "All marriages are stable") ) )

(checkCouples) (prinl) (prinl "Engage fred with abi and jon with bea") (con (asoq 'fred *Couples) 'abi) (con (asoq 'jon *Couples) 'bea) (checkCouples)</lang> Output:

dee is engaged to col
fay is engaged to dan
eve is engaged to hal
gay is engaged to gav
bea is engaged to fred
jan is engaged to ed
ivy is engaged to abe
hope is engaged to ian
cath is engaged to bob
abi is engaged to jon
All marriages are stable

Engage fred with abi and jon with bea
fay likes jon better than dan and jon likes fay better than bea
eve likes jon better than hal and jon likes eve better than bea
gay likes jon better than gav and jon likes gay better than bea
bea likes fred better than jon and fred likes bea better than abi

Python

<lang python>import copy

guyprefers = {

'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']}

galprefers = {

'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']}

guys = sorted(guyprefers.keys()) gals = sorted(galprefers.keys())

def check(engaged):

   inverseengaged = dict((v,k) for k,v in engaged.items())
   for she, he in engaged.items():
       shelikes = galprefers[she]
       shelikesbetter = shelikes[:shelikes.index(he)]
       helikes = guyprefers[he]
       helikesbetter = helikes[:helikes.index(she)]
       for guy in shelikesbetter:
           guysgirl = inverseengaged[guy]
           guylikes = guyprefers[guy]
           if guylikes.index(guysgirl) > guylikes.index(she):
               print("%s and %s like each other better than "
                     "their present partners: %s and %s, respectively"
                     % (she, guy, he, guysgirl))
               return False
       for gal in helikesbetter:
           girlsguy = engaged[gal]
           gallikes = galprefers[gal]
           if gallikes.index(girlsguy) > gallikes.index(he):
               print("%s and %s like each other better than "
                     "their present partners: %s and %s, respectively"
                     % (he, gal, she, girlsguy))
               return False
   return True

def matchmaker():

   guysfree = guys[:]
   engaged  = {}
   guyprefers2 = copy.deepcopy(guyprefers)
   galprefers2 = copy.deepcopy(galprefers)
   while guysfree:
       guy = guysfree.pop(0)
       guyslist = guyprefers2[guy]
       gal = guyslist.pop(0)
       fiance = engaged.get(gal)
       if not fiance:
           # She's free
           engaged[gal] = guy
           print("  %s and %s" % (guy, gal))
       else:
           # The bounder proposes to an engaged lass!
           galslist = galprefers2[gal]
           if galslist.index(fiance) > galslist.index(guy):
               # She prefers new guy
               engaged[gal] = guy
               print("  %s dumped %s for %s" % (gal, fiance, guy))
               if guyprefers2[fiance]:
                   # Ex has more girls to try
                   guysfree.append(fiance)
           else:
               # She is faithful to old fiance
               if guyslist:
                   # Look again
                   guysfree.append(guy)
   return engaged

print('\nEngagements:') engaged = matchmaker()

print('\nCouples:') print(' ' + ',\n '.join('%s is engaged to %s' % couple

                         for couple in sorted(engaged.items())))

print() print('Engagement stability check PASSED'

     if check(engaged) else 'Engagement stability check FAILED')

print('\n\nSwapping two fiances to introduce an error') engaged[gals[0]], engaged[gals[1]] = engaged[gals[1]], engaged[gals[0]] for gal in gals[:2]:

   print('  %s is now engaged to %s' % (gal, engaged[gal]))

print() print('Engagement stability check PASSED'

     if check(engaged) else 'Engagement stability check FAILED')</lang>

Sample Output

Engagements:
  abe and abi
  bob and cath
  col and hope
  dan and ivy
  ed and jan
  fred and bea
  gav and gay
  hope dumped col for ian
  abi dumped abe for jon
  hal and eve
  col and dee
  ivy dumped dan for abe
  dan and fay

Couples:
  abi is engaged to jon,
  bea is engaged to fred,
  cath is engaged to bob,
  dee is engaged to col,
  eve is engaged to hal,
  fay is engaged to dan,
  gay is engaged to gav,
  hope is engaged to ian,
  ivy is engaged to abe,
  jan is engaged to ed

Engagement stability check PASSED


Swapping two fiances to introduce an error
  abi is now engaged to fred
  bea is now engaged to jon

fay and jon like each other better than their present partners: dan and bea, respectively
Engagement stability check FAILED

Tcl

Translation of: Python

<lang tcl>package require Tcl 8.5

1. Functions as aliases to standard commands

interp alias {} tcl::mathfunc::pos {} ::lsearch -exact interp alias {} tcl::mathfunc::nonempty {} ::llength

1. The stability check

proc check engaged {

   global preferences
   set inverse [lreverse $engaged]
   dict for {she he} $engaged {

set shelikes [dict get $preferences $she] set shelikesbetter [lrange $shelikes 0 [expr {pos($shelikes,$he)}]] set helikes [dict get $preferences $he] set helikesbetter [lrange $helikes 0 [expr {pos($helikes,$she)}]] foreach guy $shelikesbetter { set guysgirl [dict get $inverse $guy] set guylikes [dict get $preferences $guy] if {pos($guylikes,$guysgirl) > pos($guylikes,$she)} { puts "$she likes $guy better than $he and $he likes $she better\ than their current partner" return 0 } } foreach gal $helikesbetter { set galsguy [dict get $engaged $gal] set gallikes [dict get $preferences $gal] if {pos($gallikes,$galsguy) > pos($gallikes,$he)} { puts "$he likes $gal better than $she and $she likes $he better\ than their current partner" return 0 } }

   }
   return 1

}

1. The match-making algorithm

proc matchmaker {} {

   global guys gals preferences
   set guysfree $guys
   set engaged {}
   array set p $preferences
   while {nonempty($guysfree)} {

set guysfree [lassign $guysfree guy] set p($guy) [set guyslist [lassign $p($guy) gal]] if {![dict exists $engaged $gal]} { # She's free dict set engaged $gal $guy puts " $guy and $gal" continue } # The bounder proposes to an engaged lass! set fiance [dict get $engaged $gal] if {pos($p($gal), $fiance) > pos($p($gal), $guy)} { # She prefers the new guy dict set engaged $gal $guy puts " $gal dumped $fiance for $guy" set guy $fiance } if {nonempty($p($guy))} { lappend guysfree $guy }

   }
   return $engaged

}

1. Problem dataset; preferences unified since all names distinct

set guys {abe bob col dan ed fred gav hal ian jon} set gals {abi bea cath dee eve fay gay hope ivy jan} set preferences {

   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}

   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}

}

1. The demonstration code

puts "Engagements:" set engaged [matchmaker]

puts "\nCouples:" set pfx "" foreach gal $gals {

   puts -nonewline "$pfx  $gal is engaged to [dict get $engaged $gal]"
   set pfx ",\n"

} puts "\n" puts "Engagement stability check [lindex {FAILED PASSED} [check $engaged]]"

puts "\n\nSwapping two fiances to introduce an error" set tmp [dict get $engaged [lindex $gals 0]] dict set engaged [lindex $gals 0] [dict get $engaged [lindex $gals 1]] dict set engaged [lindex $gals 1] $tmp foreach gal [lrange $gals 0 1] {

   puts "  $gal is now engaged to [dict get $engaged $gal]"

} puts "" puts "Engagement stability check [lindex {FAILED PASSED} [check $engaged]]"</lang> Sample output:

Engagements:
  abe and abi
  bob and cath
  col and hope
  dan and ivy
  ed and jan
  fred and bea
  gav and gay
  hope dumped col for ian
  abi dumped abe for jon
  hal and eve
  col and dee
  ivy dumped dan for abe
  dan and fay

Couples:
  abi is engaged to jon,
  bea is engaged to fred,
  cath is engaged to bob,
  dee is engaged to col,
  eve is engaged to hal,
  fay is engaged to dan,
  gay is engaged to gav,
  hope is engaged to ian,
  ivy is engaged to abe,
  jan is engaged to ed

Engagement stability check PASSED


Swapping two fiances to introduce an error
  abi is now engaged to fred
  bea is now engaged to jon

fred likes bea better than abi and abi likes fred better than their current partner
Engagement stability check FAILED