You selected marriage0.pl
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
return to front page.