title:- A=['% Computing Stable Marriage' ,'% created: 26-27 Jun 2004. (marriage.pl for SWI-Prolog 5.0.9)' ,'% modified: 2 Jul 2004.' ,'% modified: 13,14 Jul 2004. (position of dynamic and set_model/1 for SWI-Prolog 5.2.13. )' ,'% modified: 18 Aug 2004. (added assert for current_model/1 in set_model/1. )' ,'% author: Kenyo Indo (Kanto Gakuen University)' ,'% --------main model predicate ---------' ,'% preference/3, marriages/1, unstable_marriages/3. ' ,'% stable_marriages/1. ' ,'% --------Gale-Shapley algorithm--------- ' ,'% matching/0. ' ,'% --------command interfaces--------- ' ,'% set_model(example(N)),member(N,[1,2,3]).' ,'% display_data/0, current_matching/3, consistency_checking/3. ' ,'% figure1,figure2,reference.' ], forall(member(L,A),(nl,write(L))),nl. reference:- A=['% reference:' ,'% [1] D. Gale and L.S. Shapley (1962). College admissions and stability of marriage.' ,'% The American Mathematical Monthly 69:9-15.' ,'% [2] Y.S. Chow, S.Moriguti, H.Robins, and S.M. Samuels (1964). Optimal selection based on relative rank (the "secretary problem"). Israel Journal of Mathematics 2:81-90.' ], forall(member(L,A),(nl,write(L))). figure1:- Figure=[ '% w o m e n ', '% | x | y | z ', '% +-----+--------+--------+--------+ ', '% a | 1, 3 | 2, 2 | 3, 1 ', '% m | | | ', '% e b | 3, 1 | 1, 3 | 2, 2 ', '% n | | | ', '% c | 2, 2 | 3, 1 | 1, 3 ', '% +-----+--------+--------+--------+ ', '% Fig. ranking matrix of Example 1 in Gale and Shapley(1962). ', '' ], forall(member(L,Figure),(nl,write(L))). %===================================== % Society Members and the Preferences %===================================== :- dynamic preference/3. :- dynamic prefer_to_0/4. :- dynamic state/1. :- dynamic men/1,women/1. :- dynamic figure. :- dynamic current_model/1. man(A):-men(M),member(A,M). woman(A):-women(W),member(A,W). % same as example 1 in model_base/1. men([a,b,c]). women([x,y,z]). state(s1). % preference(Agent,State,Preference). :- dynamic preference/3. % a list represents strong preference order of agent. preference(a,s1,[x,y,z]). preference(b,s1,[y,z,x]). preference(c,s1,[z,x,y]). preference(x,s1,[b,c,a]). preference(y,s1,[c,a,b]). preference(z,s1,[a,b,c]). % binary comparison. prefer_to(Agent,State,O1,O2):- preference(Agent,State,Order), append(_,[O1|Y],Order), member(O2,Y). % avoidance for solitude. prefer_to(Agent,State,O,non):- preference(Agent,State,R), member(O,R). % preparing for weak order. prefer_to(Agent,State,O,P):- prefer_to_0(Agent,State,O,P). more_preferable_set(Y,S,X,Members,UB):- findall(U, ( member(U,Members), prefer_to(Y,S,U,X) ), UB). less_preferable_set(Y,S,X,Members,LB):- findall(L, ( member(L,Members), prefer_to(Y,S,X,L) ), LB). equally_preferable_set(Y,S,X,Members,EB):- findall(L, ( member(L,Members), prefer_to(Y,S,X,L), prefer_to(Y,S,L,X) ), EB). %===================================== % Generating Assignments (Marriage patterns) %===================================== an_order_of([],[],0). an_order_of([A|B],Set,N):- length(Set,N), N1 is N - 1, member(A,Set), subtract(Set,[A],S1), an_order_of(B,S1,N1). marriages(X):- men(M), length(M,N), women(W), an_order_of(Q,W,N), findall(A-B,(nth1(K,M,A),nth1(K,Q,B)),X). /* ?- findall(X,(marriages(X),write(X)),Q),length(Q,N). [a-x, b-y, c-z][a-x, b-z, c-y][a-y, b-x, c-z][a-y, b-z, c-x][a-z, b-x, c-y][a-z, b-y, c-x] X = _G160 Q = [[a-x, b-y, c-z], [a-x, b-z, c-y], [a-y, b-x, c-z], [a-y, b-z, c-x], [a-z, b-x, c-y], [a-z, b-y, ... -...]] N = 6 Yes ?- */ %===================================== % Stability of marriages %===================================== unstable_marriages(A-B,C-D,X):- (var(X)->marriages(X);true), member(A-B,X), member(C-D,X),C\=A, prefer_to(A,_,D,B), % There exisits a mutually preferable pair to the current partner. prefer_to(D,_,A,C). stable_marriages(X):- marriages(X), \+ unstable_marriages(_,_,X). /* ?- unstable_marriages(A-B,C-D,X). A = c B = y C = a D = x X = [a-x, b-z, c-y] ; A = b B = x C = c D = z X = [a-y, b-x, c-z] ; A = a B = z C = b D = y X = [a-z, b-y, c-x] ; No ?- stable_marriages(X). X = [a-x, b-y, c-z] ; X = [a-y, b-z, c-x] ; X = [a-z, b-x, c-y] ; No */ %===================================== % Model Base %===================================== model_base(example(1),[ (men([a,b,c])), (women([x,y,z])), (state(s1)), (preference(a,s1,[x,y,z])), (preference(b,s1,[y,z,x])), (preference(c,s1,[z,x,y])), (preference(x,s1,[b,c,a])), (preference(y,s1,[c,a,b])), (preference(z,s1,[a,b,c])), (figure:- Figure=[ '% w o m e n ', '% | x | y | z ', '% +-----+--------+--------+--------+ ', '% a | 1, 3 | 2, 2 | 3, 1 ', '% m | | | ', '% e b | 3, 1 | 1, 3 | 2, 2 ', '% n | | | ', '% c | 2, 2 | 3, 1 | 1, 3 ', '% +-----+--------+--------+--------+ ', '% Fig. ranking matrix of Example 1 in Gale and Shapley(1962). ', '' ], forall(member(L,Figure),(nl,write(L)))) ]). model_base(example(2),[ (men([a,b,c,d])), (women([x,y,z,w])), (state(s1)), (preference(a,s1,[x,y,z,w])), (preference(b,s1,[x,w,z,y])), (preference(c,s1,[y,x,z,w])), (preference(d,s1,[w,y,z,x])), (preference(x,s1,[d,c,a,b])), (preference(y,s1,[b,d,a,c])), (preference(z,s1,[d,a,b,c])), (preference(w,s1,[c,b,a,d])), (figure:- Figure=[ '% w o m e n ', '% | x | y | z | w', '% +-----+--------+--------+--------+-------+ ', '% a | 1, 3 | 2, 3 |* 3, 2 | 4, 3', '% m | | | | ', '% e b | 1, 4 | 4, 1 | 3, 3 |* 2, 2', '% n | | | | ', '% c |* 2, 2 | 1, 4 | 3, 4 | 4, 1', '% | | | | ', '% d | 4, 1 |* 2, 2 | 3, 1 | 1, 4', '% +-----+--------+--------+--------+-------+ ', '% Fig. ranking matrix of Example 2 in Gale and Shapley(1962). ', '' ], forall(member(L,Figure),(nl,write(L)))) ]). model_base(example(3),[ (men([a,b,c,d])), (women([x,y,z,w])), (state(s1)), (preference(a,s1,[x,y,z,w])), (preference(b,s1,[x,y,z,w])), (preference(c,s1,[y,z,x,w])), (preference(d,s1,[z,x,y,w])), (preference(x,s1,[c,d,a,b])), (preference(y,s1,[d,a,b,c])), (preference(z,s1,[a,b,c,d])), (preference(w,s1,[d,c,b,a])), (prefer_to_0(d,s1,w,z)), (prefer_to_0(z,s1,a,d)), (figure:- Figure=[ '% w o m e n ', '% | x | y | z | w', '% +-----+--------+--------+--------+-------+ ', '% a | 1, 3 | 2, 2 | 3, 1 | 4, 3', '% m | | | | ', '% e b | 1, 4 | 2, 3 | 3, 2 | 4, 4', '% n | | | | ', '% c | 3, 1 | 1, 4 | 2, 3 | 4, 2', '% | | | | ', '% d | 2, 2 | 3, 1 | 4, 1 | 4, 1', '% +-----+--------+--------+--------+-------+ ', '% Fig. ranking matrix of the third example in Gale and Shapley(1962). ', '' ], forall(member(L,Figure),(nl,write(L)))) ]). %===================================== % Model Management System %===================================== % modified: 13 Jul 2004. the position of `dynamic's have moved into the correct position. %:- dynamic preference/3. %:- dynamic prefer_to_0/4. %:- dynamic state/1. %:- dynamic men/1,women/1. %:- dynamic figure. %:- dynamic current_model/1. model_predicates([ preference/3, prefer_to_0/4, state/1, men/1, women/1, figure/0 ]). :- dynamic current_model/1. predicate_exists(Pred/Arity):- length(Body,Arity), C=..[Pred|Body], clause(C,_). % modified: 13 Jul 2004. modified for SWI-Prolog 5.2.13. % modified: 18 Aug 2004. separated initialize_model_space/0 from set_mode/1, and an assertion had been missed for current_model/1. initialize_model_space:- user_conform_about_swi_version(Z), initialize_model_space(Z). % use this instead if you use 5.0.10 or 5.0.9. initialize_model_space(1):- model_predicates(MP), forall((member(X,MP),predicate_exists(X)),abolish(X)). % for a recent version (5.2.13) initialize_model_space(2):- model_predicates(MP), forall((member(X/N,MP),predicate_exists(X/N)),(length(B,N),PM=..[X|B],retract(PM))). user_conform_about_swi_version(Z):- nl, write('The version of your SWI-prolog is 5.0.10 or 5.0.9 ? (y/n):'), nl, (read(y)->Z= 1;Z=2). set_model(A):- abolish(current_model/1), (model_base(A,M)->true;(write('no such model.'),!,fail)), initialize_model_space, write(set_model:A), write('(y/n)>'), read(y), forall(member(Y,M),assert(Y)), assert(current_model(A)), figure. /* % example 2: ?- stable_marriages(X). X = [a-z, b-w, c-x, d-y] ; No ?- setof(A:B,unstable_marriages(A,B,X),W), nl,write(X),write(unstable:W),fail. [a-x, b-y, c-z, d-w]unstable:[b-y:c-z, b-y:d-w, c-z:a-x] [a-x, b-y, c-w, d-z]unstable:[c-w:a-x] [a-x, b-z, c-y, d-w]unstable:[b-z:d-w] [a-x, b-z, c-w, d-y]unstable:[c-w:a-x] [a-x, b-w, c-y, d-z]unstable:[d-z:c-y] [a-x, b-w, c-z, d-y]unstable:[c-z:a-x] [a-y, b-x, c-z, d-w]unstable:[a-y:b-x, c-z:b-x] [a-y, b-x, c-w, d-z]unstable:[a-y:b-x, c-w:b-x, d-z:a-y] [a-y, b-z, c-x, d-w]unstable:[b-z:d-w] [a-y, b-z, c-w, d-x]unstable:[d-x:a-y, d-x:b-z] [a-y, b-w, c-x, d-z]unstable:[d-z:a-y] [a-y, b-w, c-z, d-x]unstable:[d-x:a-y, d-x:c-z] [a-z, b-x, c-y, d-w]unstable:[a-z:b-x, a-z:c-y] [a-z, b-x, c-w, d-y]unstable:[a-z:b-x, c-w:b-x] [a-z, b-y, c-x, d-w]unstable:[b-y:d-w] [a-z, b-y, c-w, d-x]unstable:[d-x:a-z] [a-z, b-w, c-y, d-x]unstable:[a-z:c-y, d-x:a-z, d-x:c-y] [a-w, b-x, c-y, d-z]unstable:[a-w:b-x, a-w:c-y, d-z:c-y] [a-w, b-x, c-z, d-y]unstable:[a-w:b-x, a-w:c-z, c-z:b-x] [a-w, b-y, c-x, d-z]unstable:[b-y:a-w] [a-w, b-y, c-z, d-x]unstable:[a-w:c-z, b-y:a-w, b-y:c-z, d-x:c-z] [a-w, b-z, c-x, d-y]unstable:[a-w:b-z, b-z:a-w] [a-w, b-z, c-y, d-x]unstable:[a-w:b-z, a-w:c-y, b-z:a-w, d-x:b-z, d-x:c-y] No ?- % example 3: ?- stable_marriages(X). X = [a-z, b-w, c-x, d-y] ; No ?- setof(A:B,unstable_marriages(A,B,X),W), nl,write(X),write(unstable:W),fail. [a-x, b-y, c-z, d-w]unstable:[d-w:a-x, d-w:b-y] [a-x, b-y, c-w, d-z]unstable:[c-w:a-x, c-w:d-z] [a-x, b-z, c-y, d-w]unstable:[b-z:c-y, d-w:a-x, d-w:c-y] [a-x, b-z, c-w, d-y]unstable:[c-w:a-x, d-y:a-x] [a-x, b-w, c-y, d-z]unstable:[b-w:c-y, b-w:d-z] [a-x, b-w, c-z, d-y]unstable:[b-w:c-z, d-y:a-x] [a-y, b-x, c-z, d-w]unstable:[a-y:b-x, d-w:a-y, d-w:b-x] [a-y, b-x, c-w, d-z]unstable:[a-y:b-x, c-w:b-x, c-w:d-z] [a-y, b-z, c-x, d-w]unstable:[d-w:a-y] [a-y, b-z, c-w, d-x]unstable:[c-w:d-x] [a-y, b-w, c-x, d-z]unstable:[b-w:d-z, c-x:d-z] [a-y, b-w, c-z, d-x]unstable:[b-w:c-z] [a-z, b-x, c-y, d-w]unstable:[a-z:b-x, a-z:c-y, d-w:b-x, d-w:c-y] [a-z, b-x, c-w, d-y]unstable:[a-z:b-x, c-w:b-x, d-y:b-x] [a-z, b-y, c-x, d-w]unstable:[a-z:b-y, d-w:b-y] [a-z, b-y, c-w, d-x]unstable:[a-z:b-y, c-w:d-x] [a-z, b-w, c-y, d-x]unstable:[a-z:c-y, b-w:c-y] [a-w, b-x, c-y, d-z]unstable:[a-w:b-x, a-w:c-y, a-w:d-z] [a-w, b-x, c-z, d-y]unstable:[a-w:b-x, a-w:c-z, d-y:b-x] [a-w, b-y, c-x, d-z]unstable:[a-w:b-y, a-w:d-z, c-x:d-z] [a-w, b-y, c-z, d-x]unstable:[a-w:b-y, a-w:c-z] [a-w, b-z, c-x, d-y]unstable:[a-w:b-z] [a-w, b-z, c-y, d-x]unstable:[a-w:b-z, a-w:c-y, b-z:c-y] No ?- */ %===================================== % Classical Algorithm by Gale and Shapley %===================================== :- dynamic count_round/1. :- dynamic proposal/2. :- dynamic acceptance/2. init_proposals_and_acceptances(S):- abolish(current_round/1), assert(current_round(0)), abolish(proposal/2), abolish(acceptance/2), A=proposal(boy(I),D1), B=acceptance(girl(I),D2), D1=[ranking:R,remains:R,proposed:[],status:not_yet_accepted], D2=[ranking:R,accepted:[],rejected:[],new_offer:[]], forall( preference(I,S,R), man(I)->assert(A);assert(B) ). matching:- state(S), init_proposals_and_acceptances(S), !, matching_0, write('complete the matching process.'). matching_0:- enter_new_stage(N), generate_and_test_matching(N), matching_0. matching_0:- current_round(N), nl, write(round:N), tab(2), write('booked up. '). generate_and_test_matching(N):- nl,write('go?(y/n)'),read(y), !, apply_from_boys, choice_by_girls, display_data, analysis_and_ending_stage(N). % some subprograms %------------------------ at_most_stages(N):- women(W), length(W,L), N is (L-1)^2+1. enter_new_stage(N):- at_most_stages(Limit), current_round(N0), (N0 < Limit -> N is N0 + 1; !,nl,write('the time.'),fail), write(start_round:[N]), retract(current_round(N0)), assert(current_round(N)). display_data:- current_round(N), listing(proposal), listing(acceptance), nl,tab(1),write(' complete round '),write([N]). %------------------------ % decision rules of agents %------------------------ apply_from_boys:- apply_if_rejected(_X,_Y), fail. apply_from_boys. choice_by_girls:- accept_if_better(_Y,_X), fail. choice_by_girls. % decision rule of boys %------------------------ apply_if_rejected(X,Y):- retract(proposal(boy(X),[R,A:[Y|Girls],B:Tried,C:not_yet_accepted])), assert(proposal(boy(X),[R,A:Girls,B:[Y|Tried],C:bid])). % decision rule of girls %------------------------ accept_if_better(Y,X):- (var(S)->state(S);true), (var(Y)->woman(Y);true), most_preferable_proposers_among_current_offers(Y,S,X,Offer,NG), new_offer_ranked_in_previous_offers(Y,S,X,[UB,EB,LB]), (UB = [] ->(NEW=X,union(NG,LB,BYE),union(X,EB,Boys1)) ; (NEW=[],BYE=X,Boys1=Boys) ), % update_keep_list: retract(acceptance(girl(Y),[R,A:Boys,B:Rejected,C:_LastOffer])), assert(acceptance(girl(Y),[R,A:Boys1,B:[BYE|Rejected],C:Offer])), send_messages_to_boys(Y,[NEW,BYE,NG]). send_messages_to_boys(Y,[NEW,BYE,NG]):- send_accept_message(Y,NEW), send_reject_message(Y,BYE), send_reject_message(Y,NG). a_most_preferable_boy(Y,S,A,Offer):- (var(S)->state(S);true), (var(Y)->woman(Y);true), (var(Offer)->findall(X,proposal(boy(X),[_,_,_:[Y|_],_:bid]),Offer);true), member(A,Offer), \+ ( member(B,Offer), prefer_to(Y,S,B,A) ). most_preferable_proposers_among_current_offers(Y,S,X,Offer,NG):- (var(S)->state(S);true), (var(Y)->woman(Y);true), (var(Offer)->findall(X,proposal(boy(X),[_,_,_:[Y|_],_:bid]),Offer);true), findall(A, a_most_preferable_boy(Y,S,A,Offer), X), subtract(Offer,X,NG). new_offer_ranked_in_previous_offers(Y,S,X,[UB,EB,LB]):- (var(S)->state(S);true), acceptance(girl(Y),[_,_:Boys,_,_]), X=[X1|_], more_preferable_set(Y,S,X1,Boys,UB), less_preferable_set(Y,S,X1,Boys,LB), equally_preferable_set(Y,S,X1,Boys,EB). % message process %------------------------ send_accept_message(Y,G):- member(X,G), send_message(accept(Y,X)), retract(proposal(boy(X),[R,A:Girls,B:[Y|Tried],C:bid])), assert(proposal(boy(X),[R,A:Girls,B:[Y|Tried],C:accepted])), fail. send_accept_message(_,_). send_reject_message(Y,NG):- member(X,NG), send_message(reject(Y,X)), G1=proposal(boy(X),[R,A:Girls,B:[Y|Tried],C:bid]), G2=proposal(boy(X),[R,A:Girls,B:[Y|Tried],C:accepted]), member(G,[G1,G2]), retract(G), assert(proposal(boy(X),[R,A:Girls,B:[Y|Tried],C:not_yet_accepted])), fail. send_reject_message(_,_). send_message(accept(Y,X)):- nl,tab(1),write(title:' your proposal has accepted. '), tab(2),write(to:boy(X)), tab(2),write(from:girl(Y)). send_message(reject(Y,X)):- nl,tab(1),write(title:' your proposal has rejected. '), tab(2),write(to:boy(X)), tab(2),write(from:girl(Y)). % expost analyses %------------------------ current_matching(C,X):- member(C,[boys,girls]), findall(A-B, state_of_matching(C,A,B), X). current_matching(boys:X,girls:Y,all:Z):- (var(X)->current_matching(boys,X);true), (var(Y)->current_matching(girls,Y);true), union(X,Y,Z). current_matching(Z):- current_matching(boys:_,girls:_,all:Z). consistency_checking(boys:X,girls:Y,Z):- (var(X)->current_matching(_:X,_:Y,_);true), setof(P,B^(member(P,X),P \= B-non),X1), setof(Q,G^(member(Q,Y),Q \= non-G),Y1), (X1==Y1 -> (Z=yes,nl,write('the matching is consistent. ')) ; (Z=no,nl,write('WARNING! inconsistent matching.')) ). state_of_matching(boys,A,B):- proposal(boy(A), [_,_, proposed:[B|_], status:accepted]). state_of_matching(boys,A,non):- proposal(boy(A), [_,_, _, status:G]),G\=accepted. state_of_matching(girls,A,Y):- acceptance(girl(Y), [_,accepted:[A|_], _,_]). state_of_matching(girls,non,Y):- acceptance(girl(Y), [_,accepted:[], _,_]). analysis_and_ending_stage(N):- current_round(N), nl,write('---- verifying the matching ----'), current_matching(boys:_XB,girls:_XG,all:X), nl,write(X), consistency_checking(boys:_XB,girls:_XG,_), findall([A-B,C-D],unstable_marriages(A-B,C-D,X),Unstables), display_diagnosis_message(Unstables). display_diagnosis_message([]):- nl, write('the marriages are stable.'), nl, !. display_diagnosis_message(Unstables):- nl, write('the marriages are not stable.'), nl,write('---- unsatable pairs (i.e., profitable by mutually exchange of the parteners.) ----'), nl,tab(1),write(Unstables). %forall(member(E,Unstables),(nl,tab(1),E)) ) %------------------------ % demos %------------------------ /* % example 1. %------------ ?- matching. :- dynamic proposal/2. proposal(boy(a), [remains:[y, z], proposed:[x], status:bid]). proposal(boy(b), [remains:[z, x], proposed:[y], status:bid]). proposal(boy(c), [remains:[x, y], proposed:[z], status:bid]). :- dynamic acceptance/2. acceptance(girl(x), [accepted:[a], rejected:[[]], new_offer:[a]]). acceptance(girl(y), [accepted:[b], rejected:[[]], new_offer:[b]]). acceptance(girl(z), [accepted:[c], rejected:[[]], new_offer:[c]]). complete round [1] ---- marriages ---- [a-x, b-y, c-z] the marriages are stable. Yes ?- current_matching(X). X = [a-x, b-y, c-z] ; No ?- current_matching(X),unstable_marriages(A-B,C-D,X). No */ :- title. :- set_model(example(2)). % end