273 lines
7.4 KiB
Prolog
273 lines
7.4 KiB
Prolog
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% 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)).
|