How to resolve the algorithm Stable marriage problem step by step in the Prolog programming language

Problem Statement
Step by Step Solution
Sourcecode

Problem Statement

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 woman ranks all the men in order of her preference. A stable set of engagements for marriage is one where no man prefers a woman 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 Shapley 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: And ten females: And a complete list of ranked preferences, where the most liked is to the left:

References

Let's start with the solution:

Step by Step solution about How to resolve the algorithm Stable marriage problem step by step in the Prolog programming language

Source code in the prolog programming language

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% facts
prefere(abe,[ abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay]).
prefere(  bob,[ cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay]).
prefere(  col,[ hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan]).
prefere(  dan,[ ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi]).
prefere(   ed,[ jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay]).
prefere( fred,[ bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay]).
prefere(  gav,[ gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay]).
prefere(  hal,[ abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee]).
prefere(  ian,[ hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve]).
prefere(  jon,[ abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope]).

prefere(  abi,[ bob, fred, jon, gav, ian, abe, dan, ed, col, hal]).
prefere(  bea,[ bob, abe, col, fred, gav, dan, ian, ed, jon, hal]).
prefere( cath,[ fred, bob, ed, gav, hal, col, ian, abe, dan, jon]).
prefere(  dee,[ fred, jon, col, abe, ian, hal, gav, dan, bob, ed]).
prefere(  eve,[ jon, hal, fred, dan, abe, gav, col, ed, ian, bob]).
prefere(  fay,[ bob, abe, ed, ian, jon, dan, fred, gav, col, hal]).
prefere(  gay,[ jon, gav, hal, fred, bob, abe, col, ed, dan, ian]).
prefere( hope,[ gav, jon, bob, abe, ian, dan, hal, ed, col, fred]).
prefere(  ivy,[ ian, col, hal, gav, fred, bob, abe, ed, jon, dan]).
prefere(  jan,[ ed, hal, gav, abe, bob, jon, col, ian, fred, dan]).


man(abe).
man(bob).
man(col).
man(dan).
man(ed).
man(fred).
man(gav).
man(hal).
man(ian).
man(jon).

woman(abi).
woman(bea).
woman(cath).
woman(dee).
woman(eve).
woman(fay).
woman(gay).
woman(hope).
woman(ivy).
woman(jan).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% rules

stable_mariage :-
	new(LstMan, chain),
	forall(man(X),
	       (   prefere(X, Lst),
		   new(P, man(X, Lst)),
		   send(LstMan, append, P))),

	new(LstWoman, chain),
	forall(woman(X),
	       (   prefere(X, Lst),
		   new(P, woman(X, Lst)),
		   send(LstWoman, append, P))),
	send(LstMan, for_all, message(@arg1, init_liste, LstWoman)),
	send(LstWoman, for_all, message(@arg1, init_liste, LstMan)),

	round(LstMan, LstWoman),
	new(LstCouple, chain),
	% creation of the couple.
	send(LstWoman, for_all, and(message(@prolog, create_couple, @arg1, LstCouple),
				   message(@pce, write_ln, @arg1?name, with, @arg1?elu?name))),

	nl,
	
	% test of the stability of couples
	stability(LstCouple),
	nl,

	% Perturbation of couples
	get(LstCouple, size, Len),
	get_two_random_couples(Len, V1, V2),

	get(LstCouple, nth0, V1, C1),
	get(LstCouple, nth0, V2, C2),
	new(NC1, tuple(C1?first, C2?second)),
	new(NC2, tuple(C2?first, C1?second)),
	send(LstCouple, nth0, V1, NC1),
	send(LstCouple, nth0, V2, NC2),

	send(@pce, write_ln, 'perturbation of couples'),
	send(@pce, write_ln, NC1?second, with, NC1?first),
	send(@pce, write_ln, NC2?second, with, NC2?first),
	nl,
	
	stability(LstCouple).

get_two_random_couples(Len, C1, C2) :-
	C1 is random(Len),
	repeat,
	C2 is random(Len),
	C1 \= C2.

create_couple(Woman, LstCouple ) :-
	send(LstCouple, append, new(_, tuple(Woman?elu?name, Woman?name))).

% iterations of the algorithm
round(LstMan, LstWoman) :-
	send(LstMan, for_some, message(@arg1, propose)),
	send(LstWoman, for_some, message(@arg1, dispose)),
	(   \+send(LstWoman, for_all, @arg1?status == maybe)
	->
	    round(LstMan, LstWoman)
	;
	    true
	).

:-pce_begin_class(person, object, "description of a person").
variable(name, object, both, "name of the person").
variable(preference, chain, both, "list of priority").
variable(status, object, both, "statut of engagement : maybe / free").

initialise(P, Name, Pref) :->
	send(P, send_super, initialise),
	send(P, slot, name, Name),
	send(P, slot, preference, Pref),
	send(P, slot, status, free).

% reception of the list of partners
init_liste(P, Lst) :->
	% we replace the list of name of partners
	% with the list of persons partners.
	new(NLP, chain),
	get(P, slot, preference, LP),
	send(LP, for_all, message(@prolog, find_person,@arg1, Lst, NLP)),
	send(P, slot, preference, NLP).

:- pce_end_class(person).



find_person(Name, LstPerson, LstPref) :-
	get(LstPerson, find, @arg1?name == Name, Elem),
	send(LstPref, append, Elem).

:-pce_begin_class(man, person, "description of a man").

initialise(P, Name, Pref) :->
	send(P, send_super, initialise, Name, Pref).

% a man propose "la botte" to a woman
propose(P) :->
	get(P, slot, status, free),
	get(P, slot, preference, XPref),
	get(XPref, delete_head, Pref),
	send(P, slot, preference, XPref),
	send(Pref, proposition, P).

refuse(P) :->
	send(P, slot, status, free).

accept(P) :->
	send(P, slot, status, maybe).

:- pce_end_class(man).

:-pce_begin_class(woman, person, "description of a woman").
variable(elu, object, both, "name of the elu").
variable(contact, chain, both, "men that have contact this woman").

initialise(P, Name, Pref) :->
	send(P, send_super, initialise, Name, Pref),
	send(P, slot, contact, new(_, chain)),
	send(P, slot, elu, @nil).

% a woman decide Maybe/No
dispose(P) :->
	get(P, slot, contact, Contact),
	get(P, slot, elu, Elu),

	(   Elu \= @nil
	->
	    send(Contact, append, Elu)
	;
	    true),

	new(R, chain),
	send(Contact, for_all, message(P, fetch, @arg1, R)),
	send(R, sort, ?(@arg1?first, compare, @arg2?first)),
	get(R, delete_head, Tete),
	send(Tete?second, accept),
	send(P, slot, status, maybe),
	send(P, slot, elu, Tete?second),
	send(R, for_some, message(@arg1?second, refuse)),
	send(P, slot, contact, new(_, chain)) .


% looking for the person of the given name  Contact
% Adding it in the chain Chain
fetch(P, Contact, Chain) :->
	get(P, slot, preference, Lst),
	get(Lst, find, @arg1?name == Contact?name, Elem),
	get(Lst, index, Elem, Ind),
	send(Chain, append, new(_, tuple(Ind, Contact))).

% a woman receive a proposition from a man
proposition(P, Name) :->
	get(P, slot, contact, C),
	send(C, append, Name),
	send(P, slot, contact, C).

:- pce_end_class(woman).

% computation of the stability od couple
stability(LstCouple) :-
	chain_list(LstCouple, LstPceCouple),
	maplist(transform, LstPceCouple, PrologLstCouple),
	study_couples(PrologLstCouple, [], UnstableCouple),
	(   UnstableCouple = []
	->
	    writeln('Couples are stable')
	;
	    sort(UnstableCouple, SortUnstableCouple),
	    writeln('Unstable couples are'),
	    maplist(print_unstable_couple, SortUnstableCouple),
	    nl
	).


print_unstable_couple((C1, C2)) :-
	format('~w and ~w~n', [C1, C2]).

transform(PceCouple, couple(First, Second)):-
	get(PceCouple?first, value, First),
	get(PceCouple?second, value, Second).

study_couples([], UnstableCouple, UnstableCouple).

study_couples([H | T], CurrentUnstableCouple, UnstableCouple):-
	include(unstable_couple(H), T, Lst),
	(   Lst \= []
	->
	    maplist(build_one_couple(H), Lst, Lst1),
	    append(CurrentUnstableCouple, Lst1,CurrentUnstableCouple1)
	;
	    CurrentUnstableCouple1 = CurrentUnstableCouple
	),
	study_couples(T, CurrentUnstableCouple1, UnstableCouple).


build_one_couple(C1, C2, (C1, C2)).

unstable_couple(couple(X1, Y1), couple(X2, Y2)) :-
	prefere(X1, PX1),
	prefere(X2, PX2),
	prefere(Y1, PY1),
	prefere(Y2, PY2),

	% index of women for X1
	nth0(IY12, PX1, Y2),
	nth0(IY11, PX1, Y1),
	% index of men for Y2
	nth0(IX21, PY2, X1),
	nth0(IX22, PY2, X2),

	% index of women for X2
	nth0(IY21, PX2, Y1),
	nth0(IY22, PX2, Y2),
	% index of men for Y1
	nth0(IX11, PY1, X1),
	nth0(IX12, PY1, X2),

	% A couple is unstable
	( (IY12 < IY11 , IX21 < IX22);
	  (IY21 < IY22 , IX12 < IX11)).


:- dynamic person/4, prop/2.
% person(Name, Preference, Status, Candidate)
% prop(Name, List_of_Candidates) (for a woman)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% facts
prefere(abe,[ abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay]).
prefere(  bob,[ cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay]).
prefere(  col,[ hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan]).
prefere(  dan,[ ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi]).
prefere(   ed,[ jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay]).
prefere( fred,[ bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay]).
prefere(  gav,[ gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay]).
prefere(  hal,[ abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee]).
prefere(  ian,[ hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve]).
prefere(  jon,[ abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope]).

prefere(  abi,[ bob, fred, jon, gav, ian, abe, dan, ed, col, hal]).
prefere(  bea,[ bob, abe, col, fred, gav, dan, ian, ed, jon, hal]).
prefere( cath,[ fred, bob, ed, gav, hal, col, ian, abe, dan, jon]).
prefere(  dee,[ fred, jon, col, abe, ian, hal, gav, dan, bob, ed]).
prefere(  eve,[ jon, hal, fred, dan, abe, gav, col, ed, ian, bob]).
prefere(  fay,[ bob, abe, ed, ian, jon, dan, fred, gav, col, hal]).
prefere(  gay,[ jon, gav, hal, fred, bob, abe, col, ed, dan, ian]).
prefere( hope,[ gav, jon, bob, abe, ian, dan, hal, ed, col, fred]).
prefere(  ivy,[ ian, col, hal, gav, fred, bob, abe, ed, jon, dan]).
prefere(  jan,[ ed, hal, gav, abe, bob, jon, col, ian, fred, dan]).


man(abe).
man(bob).
man(col).
man(dan).
man(ed).
man(fred).
man(gav).
man(hal).
man(ian).
man(jon).

woman(abi).
woman(bea).
woman(cath).
woman(dee).
woman(eve).
woman(fay).
woman(gay).
woman(hope).
woman(ivy).
woman(jan).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% rules
stable_mariage :-
	%initialization
	retractall(person(_,_,_,_)),
	retractall(prop(_,_)),
	forall(prefere(P, Pref), assert(person(P, Pref, free, none))),
	bagof(X, man(X), LstMen),
	bagof(Y, woman(Y), LstWomen),
	forall(member(Z, LstWomen), assert(prop(Z, []))),

	% compute the mariages
	iteration(LstMen, LstWomen, LstCouple),
	maplist(print_couple,LstCouple),
	nl,

	% test of the stability of couples
	stability(LstCouple),
	nl,

	% Perturbation of couples
	length(LstCouple, Len),
	get_two_random_couples(Len, V1, V2),

	nth0(V1, LstCouple, C1),
	select(C1, LstCouple, Lst1),
	(   V2 > 0 -> V22 is V2 - 1; V22 = V2),
	nth0(V22, Lst1, C2),
	select(C2, Lst1, Lst2),
	C1 = couple(M1, W1),
	C2 = couple(M2, W2),

	writeln('perturbation of couples'),
	format('~w with ~w~n', [W1, M2]),
	format('~w with ~w~n', [W2, M1]),
	nl,
	stability([couple(M1, W2), couple(M2, W1)| Lst2]).


% the algorithm
iteration(Men, Women, LstCouples) :-
	% Men propose
	bagof(M,  X^Y^(member(M, Men),person(M, X, free, Y)), LM),
	forall(member(X, LM),
	       (   retract(person(X, [W|Pref], free, Elu)),
		   assert(person(X, Pref, free, Elu)),
		   retract(prop(W, Prop)),
		   assert(prop(W, [X| Prop])))),
	
	% women dispose
	bagof(W, L^(prop(W, L), L \= []), LW),
	forall(member(W, LW),
	       (   retract(prop(W, Prop)),
	           retract(person(W, Pref, _, Elu)),
		   (   Elu = none -> Prop1 = Prop; Prop1 = [Elu|Prop]),
	           order_prop(Pref, Prop1, [M | Prop2]),
		   retract(person(M, PrefM, _, _)),
		   assert(person(M, PrefM, maybe, W)),
		   forall(member(Y, Prop2),
			  (   retract(person(Y, Pref1, _, _TE)),
			      assert(person(Y, Pref1, free, none)))),
		   assert(prop(W, [])),
		   assert(person(W, Pref, maybe, M))
	       )),
	
	% finished ?
	(   bagof(X, T^Z^(member(X, Women), person(X, T, free, Z)), _LW1) ->
	    iteration(Men, Women, LstCouples)
	;
	    make_couple(Women, LstCouples)
	).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% compute order preference of candidates.
order_prop(Pref, Prop, Res) :-
	maplist(index(Pref), Prop, Rtemp),
	sort(Rtemp, Rtemp1),
	maplist(simplifie,Rtemp1, Res).

index(Lst, Value, [Ind, Value]) :-
	nth0(Ind, Lst, Value).

simplifie([_, V], V).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
print_couple(couple(M, W)) :-
	format('~w with ~w~n', [W, M]).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% creation of couples
make_couple([], []).

make_couple([W | LW], [couple(M, W) | LC]) :-
	make_couple(LW, LC),
	person(W, _, _, M).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% miscellaneous
get_two_random_couples(Len, C1, C2) :-
	C1 is random(Len),
	repeat,
	C2 is random(Len),
	C1 \= C2.

print_unstable_couple((C1, C2)) :-
	format('~w and ~w~n', [C1, C2]).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% test the stability of couples
stability(LstCouple) :-
	study_couples(LstCouple, [], CoupleInstable),
	(   CoupleInstable = []
	->
	    writeln('Couples are stable')
	;
	    sort(CoupleInstable, SortCoupleInstable),
	    writeln('Unstable couples are'),
	    maplist(print_unstable_couple, SortCoupleInstable),
	    nl
	).


% compute the stability od couple
study_couples([], UnstableCouple, UnstableCouple).

study_couples([H | T], CurrentUnstableCouple, UnstableCouple):-
	include(unstable_couple(H), T, Lst),
	(   Lst \= []
	->
	    maplist(build_one_couple(H), Lst, Lst1),
	   append(CurrentUnstableCouple, Lst1,CurrentUnstableCouple1)
	;
	   CurrentUnstableCouple1 = CurrentUnstableCouple
	),
	study_couples(T, CurrentUnstableCouple1, UnstableCouple).


build_one_couple(C1, C2, (C1, C2)).

unstable_couple(couple(X1, Y1), couple(X2, Y2)) :-
	prefere(X1, PX1),
	prefere(X2, PX2),
	prefere(Y1, PY1),
	prefere(Y2, PY2),

	% index of women for X1
	nth0(IY12, PX1, Y2),
	nth0(IY11, PX1, Y1),
	% index of men for Y2
	nth0(IX21, PY2, X1),
	nth0(IX22, PY2, X2),

	% index of women for X2
	nth0(IY21, PX2, Y1),
	nth0(IY22, PX2, Y2),
	% index of men for Y1
	nth0(IX11, PY1, X1),
	nth0(IX12, PY1, X2),

	% A couple is unstable
	( (IY12 < IY11 , IX21 < IX22);
	  (IY21 < IY22 , IX12 < IX11)).

You may also check:How to resolve the algorithm Scope modifiers step by step in the ALGOL W programming language
You may also check:How to resolve the algorithm Formal power series step by step in the J programming language
You may also check:How to resolve the algorithm Empty program step by step in the Gecho programming language
You may also check:How to resolve the algorithm Count the coins step by step in the JavaScript programming language
You may also check:How to resolve the algorithm Singleton step by step in the ooRexx programming language

How to resolve the algorithm Stable marriage problem step by step in the Prolog programming language

Table of Contents

Problem Statement

Step by Step solution about How to resolve the algorithm Stable marriage problem step by step in the Prolog programming language

Source code in the prolog programming language