/************************************************************
  Generating preference relations
  program: gprf06.pl
  language: prolog (SWI-prolog 5.0.9 & after)
  date: 2006.12.14-21,24-26; 2007.1.7
  revised: 30 Oct 2007 (init_domain)
  revised: 2 May 2008 (update_domain)
  revised: 7-11 May 2008 (consistency & dp_mode added)
  creator: Kenryo INDO
************************************************************/
init_alt:- (clause(alternatives(_),_)->abolish(alternatives/1);true).
init_dpm:- (clause(dp_mode(_),_)->abolish(dp_mode/1);true).
:- init_alt,init_dpm.  % to avoide multiplication on reload after model update.

% the axioms for preferences
% revised: 7 May 2008. Added consistency by Bossert and Suzumura (2008).

r_type(T:M):- member(T:M,[
  l: linear, % (i.e., transitive and asymmetric)
  t: transitive,
  q: quasi-transitive,
  ct: consistent,
  ct1: a_skewed_consistent,
  a: acyclic,
  o: complete,
  c: cyclic,
  nt: intransitive,
  u(_): 'user specified'
]).

axiom_r(o,_,_).
axiom_r(c,_,B):- cycle(B).
axiom_r(a,_,B):- acyclic(B).
axiom_r(ct,_,B):- consistent(B).
axiom_r(ct1,_,B):- consistent_1(B).
axiom_r(t,_,B):- trans(B).
axiom_r(l,R,B):- \+ member(0,R),trans(B).
axiom_r(q,_,B):- q_trans(B).
axiom_r(nt,_,B):- \+ trans(B).
axiom_r(u(S),R,_):- \+ var(S),name_domain(S,L),member(R,L).

cycle(C):- cycle(_,C).
cycle(1,[X>Y,Y>Z,Z>X]).
cycle(2,[X>Y,Z>X,Y>Z]).
acyclic(R):- \+ cycle(R).
intrans([X,Y,Z],R):- member(X>Y,R),member(Y>Z,R),X\=Z,\+ member(X>Z,R).
trans(R):- \+ intrans(_,R).
p_part(P,R):- findall(W>Z,(member(W>Z,R),\+ member(Z>W,R)),P).
q_trans(R):- p_part(P,R),trans(P).
inconsistent(C,R):- % include cyclical relations with at least a strict one.
   cycle(1,C),subrel(C,R),\+ \+ (member(A>B,C),\+ member(B>A,R)).
consistent(R):- \+ inconsistent(_,R).
% ct1: being incidentally found. 
inconsistent_1(C,R):- cycle(C),subset(C,R),\+ \+ (member(A>B,C),\+ member(B>A,R)).
consistent_1(R):- \+ inconsistent_1(_,R).

% subsumption of binary relations: standard subset/2 does not work properly.
subrel([],_).
subrel([X|C],R):- member(X,R),subrel(C,R).

%--------
% alternatives and its combinatorics

:- dynamic alternatives/1.
alternatives([a,b,c]).
x(W):- alternatives(A),member(W,A).

% pair and distinct pair of alternatives  
b((X,Y)):- x(X),x(Y).
d_pair(XY):- dp_mode(K),d_pair(K,XY).
% (1) by lexicographical order and (2) by a cyclic ordered pairs. 
d_pair(1,(X,Y)):- b((X,Y)),X@B):- rule_update(dp_mode,A->B,d_pair/2),init_r,init_domain.

% distinct ordered pair
dop((X,Y)):- d_pair((X,Y));d_pair((Y,X)).

% triple and distinct triple of alternatives
xyz((X,Y,Z)):- x(X),x(Y),x(Z).
d_triple((X,Y,Z)):- xyz((X,Y,Z)),L=[X,Y,Z],sort(L,L).

% distinct ordered triple 
% revised: 7 Jan 2007
dot((X,Y,Z)):- xyz((X,Y,Z)),sort([X,Y,Z],[_,_,_]).

% list-based modeling for the linear orderings. (obsolate)
ly(Q):- d_triple(Q).
lx(Q):- alternatives(A),permutation(Q,A).
lx((X,Y),Q):- p(Q),append(_,[X|B],Q),member(Y,B).

% see Sterling and Shapiro (1994).
permutation([],[]).
permutation(Q,[A|R]):-select(A,Q,Q1),permutation(Q1,R).

%--------
% making preference relations

:- dynamic r/1.

r(Q):- r(Q,_,_).  % to be override by domain manager

rb(S,XY,R):- r(R,A,_),member(XY:S,A).     % binary in the sign-notation
r((X,Y),R):- r(R,_,B),member((X>Y),B).    % binary relation
r((X,X),R):- r(R,_,_),x(X).            % reflexivity
p((X,Y),R):- r((X,Y),R),\+ r((Y,X),R). % strict relation
i((X,Y),R):- r((X,Y),R),r((Y,X),R).    % indifference

% r/5: the recursive construction for preferences
% except for reflexitivity
r([],[],[],[],_).
r([S|R],[XY:S|A],B,[XY|L],T):- r(R,A,C,L,T),
   d_pair(XY),sign_b(S,XY,W),append(W,C,B).

% r/4: preference relation template
r(R,A,B,T):-r_type(T:_),
   findall(X2,d_pair(X2),L),r(R,A,B,L,T),axiom_r(T,R,B).

% r/3 will be generated and used instead in the analyses.

sign_b(+,(X,Y),[X>Y]).
sign_b(0,(X,Y),[X>Y,Y>X]).
sign_b(-,(X,Y),[Y>X]).


% the symbols/numbers of orderings under current domain.
id_r(S,Q):- id_r(S,Q,_),r(Q).

%--------
% a numbering - symbolic system for the orderings

id_r(N:S,[A,B,C],Rb):- r([A,B,C],_,Rb),
   num_sign(X,A),num_sign(Y,B),num_sign(Z,C),
   N is 3^3 - 3^2* Z - 3*Y - X, alphabetize_r_no(N,S).
%   N is 3^2* Z + 3*Y + X + 1, alphabetize_r_no(N,S).

num_sign(0,-).
num_sign(1,0).
num_sign(2,+).

alphabetize_r_no(N,S):- N<14, M is N +64, name(S,[M]).
alphabetize_r_no(N,S):- N>=14,N<26, M is N +65, name(S,[M]).
alphabetize_r_no(26,S):- name(S,[110]).
alphabetize_r_no(27,'N').


%--------
% naming in symbols, numbering, and displaying the domain 

name_domain(SL,L):- \+ var(L),name_domain_r(2,SL,L).
name_domain(SL,L):- var(L),\+ var(SL),name_domain_r(1,SL,L).

name_domain_r(_,'',[]).
name_domain_r(1,U,[R|L]):-
   id_r(_:S,R,_),concat(S,T,U),name_domain_r(1,T,L).
name_domain_r(2,U,[R|L]):-
   name_domain_r(2,T,L),id_r(_:S,R,_),concat(S,T,U).

numbering_domain(SL,L):-
   \+ (var(SL),var(L)),numbering_domain_r(SL,L).
numbering_domain_r([],[]).
numbering_domain_r([S|T],[R|L]):-
   id_r(S:_,R,_),numbering_domain_r(T,L).

display_domain(L):- var(L),forall(id_r(_:S,_,_),write(S)).
display_domain(L):- \+ var(L),name_domain(S,L),write(S).

display_domain:- 
   all_r(L),nl,write('current domain: '),display_domain(L),
   domain_type(T),nl,write('[base domain='),write(T),write(']').

demo_r:- demo_r(o).
demo_r(T):- r_type(T:_),
   forall((id_r(K:N,A,_),r(A,_,_,T)),(nl,write(K:A:N))).

%--------
% (base) domain management

% based on r/4, generate all the possible types of relations.

:- dynamic r/3, t/1, q/1, a/1, o/1, ct/1.
init_r:- init_r(_),fail.
init_r.
% generate r/3 as all the possible (complete) binary relations
init_r(o):- abolish(r/3),forall(r(Q,A,B,o),assert(r(Q,A,B))).
% generate r/2 as all the types of preference orderings
init_r(T):- r_type(T:_),\+ member(T,[o,u(_)]),abolish(T/1),
   P=..[T,Q],forall(r(Q,_,_,T),assert(P)).
o(Q):- r(Q,_,_).

:- init_r.

:- dynamic domain_type/1.

domain_type(l:linear).  % default 

% override r/1 the current domain
chdom(A->A):- \+ var(A),domain_type(A).
chdom(A->B):- domain_type(A),r_type(B),B\=A,update_domain(B).


% revised: 2008.5.7.
:- dynamic all_r/1.

add_all_r:- \+ \+ clause( all_r(_), _),!.
add_all_r:- assert( (
     all_r(L,T):- r_type(T:_),G=..[T,Q],findall(Q,G,L)
   )),
   assert((
     all_r(L):- findall(Q,r(Q),L)
   )).

:- add_all_r.

% revised: 2008.5.2.
update_domain(T):- r_type(T),retractall(domain_type(_)),
   assert(domain_type(T)),abolish(r/1),T=T0:_,
   forall(r(Q,_,_,T0),assert(r(Q))).
%   forall(r_admit(Q,T0),assert(r(Q))).

% revised: 30 Oct 2007
init_domain:- domain_type(T),update_domain(T).

% user-specified domain using name_domain and so on below.
user_update_domain(L):- \+ var(L),L\=[],
   name_domain(S,L),update_domain(u(S):_).
user_update_domain_s(S):- \+ var(S),
   name_domain(S,_),update_domain(u(S):_).
user_update_domain_n(N):- \+ var(N),N\=[],
   numbering_domain(N,L),user_update_domain(L).

% rule updater (2008.5.9)

rule_update(Mode,Old->New,Rule/N):-
   inspect_current_mode(Mode,Old),
   select_which_rule_to_use(Rule/N,Old,New),
   commit_mode_switching(Mode,New).
inspect_current_mode(Mode,Old):-
   S=..[Mode,Old],clause(S,true).
select_which_rule_to_use(Rule/N,Old,New):-
   length([New|B],N),G=..[Rule,New|B],clause(G,_),Old\=New.
commit_mode_switching(Mode,New):-
   T=..[Mode,New],abolish(Mode/1),assert(T).

:- init_domain.

%--------
% demo

/*
?- display_domain.

current domain: ACITZN
[base domain=l:linear]

Yes
?- display_domain.

current domain: ABCFIJOSTWZnN
[base domain=t:transitive]

Yes
?- name_domain('ACIN',L).

L = [[+, +, +], [-, +, +], [-, -, +], [-, -, -]] 

Yes
?- L = [[+, +, +], [-, +, +], [-, -, +], [-, -, -]] ,
name_domain(S,L).

L = [[+, +, +], [-, +, +], [-, -, +], [-, -, -]]
S = 'ACIN' 

Yes
?- demo_r(t).

1:[+, +, +]:A
2:[0, +, +]:B
3:[-, +, +]:C
6:[-, 0, +]:F
9:[-, -, +]:I
10:[+, +, 0]:J
14:[0, 0, 0]:O
18:[-, -, 0]:S
19:[+, +, -]:T
22:[+, 0, -]:W
25:[+, -, -]:Z
26:[0, -, -]:n
27:[-, -, -]:N

Yes
?-

*/


show_inconsistent_relations:- r(A,_,B,o),
   \+ \+ ( 
     inconsistent(C,B),subtract(B,C,D),subtract(B,D,E),
     nl,write(A:C:E:D)
   ),
   fail.

/*

% demo (2008.5.7-9) 

?- chdpm(A).

A = 1->2 

Yes
?- show_inconsistent_relations.

[+, +, +]:[a>b, b>c, c>a]:[a>b, b>c, c>a]:[]
[0, +, +]:[a>b, b>c, c>a]:[a>b, b>c, c>a]:[b>a]
[+, 0, +]:[a>b, b>c, c>a]:[a>b, b>c, c>a]:[c>b]
[0, 0, +]:[a>b, b>c, c>a]:[a>b, b>c, c>a]:[b>a, c>b]
[+, +, 0]:[a>b, b>c, c>a]:[a>b, b>c, c>a]:[a>c]
[0, +, 0]:[a>b, b>c, c>a]:[a>b, b>c, c>a]:[b>a, a>c]
[+, 0, 0]:[a>b, b>c, c>a]:[a>b, b>c, c>a]:[c>b, a>c]
[-, 0, 0]:[b>a, a>c, c>b]:[b>a, c>b, a>c]:[b>c, c>a]
[0, -, 0]:[b>a, a>c, c>b]:[b>a, c>b, a>c]:[a>b, c>a]
[-, -, 0]:[b>a, a>c, c>b]:[b>a, c>b, a>c]:[c>a]
[0, 0, -]:[b>a, a>c, c>b]:[b>a, c>b, a>c]:[a>b, b>c]
[-, 0, -]:[b>a, a>c, c>b]:[b>a, c>b, a>c]:[b>c]
[0, -, -]:[b>a, a>c, c>b]:[b>a, c>b, a>c]:[a>b]
[-, -, -]:[b>a, a>c, c>b]:[b>a, c>b, a>c]:[]

No
?- chdom(A->ct:B).
A = l:linear
B = consistent 

Yes
?- display_domain.

current domain: CFGHILOQTUVWZ
[base domain=ct:consistent]

Yes
?- chdom(A->q:B),display_domain.

current domain: CEFGHIKLMOPQRTUVWXZ
[base domain=q:quasi-transitive]

A = ct:consistent
B = quasi-transitive 

Yes
?- all_r(R,q),all_r(Q,ct),subtract(R,Q,D),subtract(Q,R,E).

R = [[-, +, +], [0, 0, +], [-, 0, +], [+, -, +], [0, -, +], [-, -, +], [0, +|...], [-|...], [...|...]|...]
Q = [[-, +, +], [-, 0, +], [+, -, +], [0, -, +], [-, -, +], [-, +, 0], [0, 0|...], [+|...], [...|...]|...]
D = [[0, 0, +], [0, +, 0], [+, 0, 0], [-, 0, 0], [0, -, 0], [0, 0, -]]
E = [] 

Yes
?- r(A,B,C,ct),\+ r(A,_,_,q),nl,write(A),fail.
No
?- r(A,B,C,q),\+ r(A,_,_,ct),nl,write(A),fail.

[0, 0, +]
[0, +, 0]
[+, 0, 0]
[-, 0, 0]
[0, -, 0]
[0, 0, -]

No
?- r(A,B,C,ct),\+ r(A,_,_,t),nl,write(A),fail.

No
?- r(A,B,C,t),\+ r(A,_,_,ct),nl,write(A),fail.

No
?- 

*/

%-------- end

return to front page.