/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Gale-Shapley Algorithm for a STABLE MATCHING, implemented in Prolog This task is also known as determining a STABLE MARRIAGE. Written Jan. 17th 2007 by Markus Triska (triska@metalevel.at) Public domain code. Tested with Scryer Prolog. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ :- use_module(library(clpz)). :- use_module(library(dcgs)). :- use_module(library(lists)). :- use_module(library(assoc)). :- use_module(library(pairs)). man_preferences(a, "cbda"). man_preferences(b, "bacd"). man_preferences(c, "bdac"). man_preferences(d, "cadb"). woman_preferences(a, "abdc"). woman_preferences(b, "cadb"). woman_preferences(c, "cbda"). woman_preferences(d, "bacd"). %?- stable_marriage(M). %@ M = [a-d,b-a,c-b,d-c]. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Structures used: MPs is an association list associating men with their remaining preference lists. WPs is an association list with keys wm(Woman,Man) associated to values -- lower value means higher preference of Woman for Man. A (tentative) marriage is represented as a list of pairs Man-Woman. Initially, all women are married to the "omega" man, who is worse than anyone on their preference lists. Men from the instance are wrapped with "user(_)" to also allow the atom "omega" in instances. DCGs are used to implicitly pass states through. See the DCG Primer for more information: https://www.metalevel.at/prolog/dcg =================================== - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ stable_marriage(Ms) :- initial_marriage(Ms0), findall(M-P, man_preferences(M,P), MPs0), list_to_assoc(MPs0, MPs), pairs_keys_values(MPs0, Men, _), findall(W-P, woman_preferences(W,P), WPs0), empty_assoc(E), phrase(women_preferences(WPs0), [E], [WPs]), phrase(marry_men(Men), [s(WPs,MPs,Ms0)], [s(_,_,Ms1)]), maplist(without_wrapper, Ms1, Ms2), keysort(Ms2, Ms). without_wrapper(user(M)-W, M-W). initial_marriage(Ms) :- findall(omega-W, woman_preferences(W,_), Ms). women_preferences([]) --> []. women_preferences([W-Ps|WPs]) --> preferences_woman(Ps, W, 0), women_preferences(WPs). preferences_woman([], _, _) --> []. preferences_woman([M|Ms], W, N0) --> state0_state(WPs0, WPs1), { put_assoc(wm(W,M), WPs0, N0, WPs1), N1 #= N0 + 1 }, preferences_woman(Ms, W, N1). marry_men([]) --> []. marry_men([M|Ms]) --> marry_man(user(M)), marry_men(Ms). state0_state(S0, S), [S] --> [S0]. marry_man(omega) --> []. marry_man(user(Man)) --> state0_state(s(WPs,MPs0,Ms0), s(WPs,MPs1,Ms2)), { get_assoc(Man, MPs0, [BestWoman|_]), memberchk(CurrentMan-BestWoman, Ms0), ( CurrentMan = user(Current) -> get_assoc(wm(BestWoman,Current), WPs, CurrentPref), get_assoc(wm(BestWoman,Man), WPs, NewPref) ; true ), ( ( CurrentMan == omega ; NewPref #< CurrentPref ) -> once(select(CurrentMan-BestWoman, Ms0, Ms1)), Ms2 = [user(Man)-BestWoman|Ms1], X = CurrentMan ; Ms2 = Ms0, X = user(Man) ), ( X = user(R) -> % man R was rejected, delete the woman from his preference list get_assoc(R, MPs0, RPs0), once(select(BestWoman, RPs0, RPs)), put_assoc(R, MPs0, RPs, MPs1) ; MPs1 = MPs0 ) }, marry_man(X).