You selected beleq03.pl
headline:-
wn('% ----------------------------------------------------------- %'),
wn('% game theory under ambiguous beliefs : normal form games %'),
wn('% ----------------------------------------------------------- %'),
h0.
contents:-
M=['% The Contents of Source Code :'
,'% 1. headlines: lines about 1--105.'
,'% 2. modelbase and model setting: 105--1580'
,'% 3. decision under ambiguous beliefs: 1580--2670.'
,'% 4. Nash equilibria under uncertainty(NEUU): 2670--3605.'
,'% 5. generation and test for beliefs and equilibria: 3605--5125.'
,'% 6. belief functions: 5125--6555.'
,'% 7. library of the common programs: 6555--7155.'
,'% 8. references: 7155--7235. '
,'% 9. starting programs: 7235--7255.'
,'% 10. appendices 1--3: 7255--7825.'
],
display_all_lines(M).
me:-
M=['% file: beleq03.pl'
,'% previous version: belief01.pl(29 Jun 2003)'
,'% modified: 14--23 Jan 2004. (belief02.pl)'
,'% modified: 1--3 Feb 2004. (belief03.pl) model base selection and bugfix.'
,'% modified: 4--6 Feb 2004. (belief03a.pl) generating beliefs and its equilibrium.'
,'% modified: 11--14 Feb 2004. (beleq01.pl) equilibrium corrected and further analysis.'
,'% modified: 14--17 Feb 2004. (beleq02.pl) extended interface and filter and some debugs.'
,'% modified: 19--22 Feb 2004. (beleq03.pl) added N=3 cases and modified equilibrium conditions.'
,'% modified: 23--24 Feb 2004. (beleq03.pl) wrapped equilibria generation by using setof. '
,'% modified: 27--28 Feb 2004. (beleq03.pl) bugfix of intervals_decomposition, added rectangles_decomposition. '
,'% modified: 28--29 Feb 2004. (beleq03.pl) a faster test_range_of_beleq. '
,'% modified: 1--3 Mar 2004. (beleq03.pl) some inductive algorithms for event interval in appendix. '
,'% modified: 4--5 Mar 2004. (beleq03.pl) bugfix display_range_of_beleq and save_data_of_beleq. '
,'% modified: 6--7 Mar 2004. (beleq03.pl) completed the wrapped equilibria version. '
,'% modified: 8--9 Mar 2004. (beleq03.pl) improved apology/0 with estimate_complexity_and_advise/2. '
,'% modified: 10--11 Mar 2004. (beleq03.pl) improved bpa/2, mass/3 and so bel/3. renewed set_model/0 and /1. '
,'% modified: 12a Mar 2004. (beleq03.pl) minor bugfix for display/save command in display_ranges_of_beleq/0. '
,'% modified: 12b Mar 2004. (beleq03.pl) modified conservative extension of payoff/3, and added contents/0. '
,'% modified: 12c Mar 2004. (beleq03.pl) modified modularity/1 and its related predicates. '
,'% modified: 13 Mar 2004. (beleq03.pl) extended modularity/1 with the sampling test of complexity. '
,'% modified: 17 Mar 2004. (beleq03.pl) bugfix. the payoffs of lo32 and equilibrium_in_beliefs_ramified/4.'
,'% modified: 22 Jan 2005. (beleq03.pl) spell checked for several comment parts. '
,'% author: Kenryo INDO (Kanto Gakuen University)'
,'% url: http://www.us.kanto-gakuen.ac.jp/indo)'
],
display_all_lines(M).
h0:-
WL=['% main predicates in this program: '
,'% ------------ game theory under uncertain beliefs ------------ '
,'% set_model/0,1: select current model (model base interface). '
,'% gen_beleq/0 (generate_equilibrium_in_beliefs/3): generating equilibria.'
,'% equilibria_in_beliefs/3: packaged equilibria by acts profile. '
,'% equilibria_in_beliefs_extended/5: augmented with belief indices. '
,'% equilibrium_in_beliefs/3: equilibrium according to the definition. '
,'% ------------ other models or cui ------------------------- '
,'% model_base/3: the stock of examples to be analysed. '
,'% menu_for_gen_beleq/0: a multiple choice menu. '
,'% equilibrium_in_symmetric_beliefs/3: old version specified for ipd2. '
,'% cmc/0: model compiler for current model base. '
,'% h(bel): ambiguous beliefs or belief functions .'
,'% h(ceu): Choquet rational decision making.'
,'% h(geb): game theory under uncertainty.'
,'% --------------- references ---------------------------------- '
,'% references/1: 1:belief and decision, 2:game theory.'
,'% me/0: edit history and about the author.'
,'% contents/0: contents of the source code file.'
,'% h0/0: show this command help again.'
],
display_all_lines(WL),nl.
h(bel):-
WL=['% --------------- belief functions ---------------------------- '
,'% states/1,state/1,event/1,sevent/1: basic models of probability space. '
,'% sbel/3,spos/3,bpa/3,mass/3: belief/possibility functions and b.p.a. '
,'% bel0/2,bpa0/2: beliefs modeled by focusing relatively small events. '
,'% modularity/1: check for modularity (convexity) of beliefs. '
,'% update_mass/3,update_sbel/3,update_spos/3: Dempster-Shafer rule. '
,'% update_bel_ul/3,update_pos_ul/3: Upper-lower rule. '
],
display_all_lines(WL),nl.
h(ceu):-
WL=['% -------------- Choquet rational decision making ------------ '
,'% test_ceu/3: Choquet expected utility (CEU) with belief function.'
,'% payoff(choquet(A),B,C): another CEU construction '
,'% payoff(expected_conservative(A),B,C): additive decomposition.'
],
display_all_lines(WL),nl.
h(geb):-
WL=['% --------------- game theory under Knightian uncertainty -------------- '
,'% game/4,payoff0/3: to define normal form games in the model base. '
,'% mixed_nash_equilibrium/3: to compute the mixed strategy nash equilibrium.
,'% support/1: Dow-Werlang support of current belief model bel/3. '
,'% best_response/2: nash strategy analog under ambiguous beliefs. '
,'% confidence/1, ambiguity/1: indices of beliefs to be used as filters for beleq. '
,'% gen_ceu_max_play/4: regenerate beliefs and test both best responses and supports.'
,'% test_gen_bpa/5: for generation and test players beliefs for the current game model. '
,'% test_range_of_beleq: ex post analysis of the equilibria in beliefs.'
,'% temp_found_beleq/1: equilibria in beliefs with indices. '
,'% temp_range_of_beleq/1: equilibria in beliefs aggregated by indices. '
,'% apology/0: mixed initiative interface attached for gen_beleq/0. '
],
display_all_lines(WL),nl.
% references moved to the last part.
%---------------------------------------------------
% User Interface : Model Setting
%---------------------------------------------------
% stored models:
%----------------
% example 1. (balls) Ellsberg 3 color problem in Gilboa and Schmeidler(1993).
% example 2. (trade1) Trader with uncetain belief Dow and Werlang(1992).
% example 3. (sales) TV set sales in Jaffray and Wakker(1994).
% example 4. (trade2) contingency trade in Mukerji(1997).
% example 5. (ipd2) two-stage prisoners dilemma in Dow and Werlang(1994).
% example 6. (battle) battle of the sexes game in Eichberger and Kelsey(2000).
% example 7. (hunt) stag hunt game in Marinacci(2000).
% example 8. (prudence) fragile rationalizability in Dow and Werlang(1994).
% example 9. (klibanoff) example 3.6 in Eichberger and Kelsey(2000).
% example 10. (lo32) a 3 persons game : example 2 in Lo(1996).
models(
[
balls,
trade1,
sales,
trade2,
ipd2,
battle,
hunt,
prudence,
klibanoff
,lo32
]
).
game_model(M):-
member(M,[ipd2,battle,hunt,prudence,klibanoff,lo32]).
% default
default_model(battle).
%current_model(EX):-default_model(EX).
% modified: 10 Mar 2004.
init_or_inherit:-
\+ clause(current_model(_),true).
/*
assert(
(
current_model(EX):-default_model(EX)
)
).
*/
init_or_inherit.
%init_or_inherit/0 to be done in the last part of the program.
% set current model from model-base.
%------------------------------------------------
% modified: 13 Feb 2004.
% modified: 10 Mar 2004. separated ask_user_if_model_unspecified/2 and so on.
set_model:-
set_model(_),
fail.
set_model:-
current_model(M),
nl,
write('%--------------'),
nl,tab(2),write(model:M),
nl,write('%--------------').
set_model(EX):-
models(M),
ask_user_if_model_unspecified(EX,M),
rule_for_set_model_conforming_user(EX,M),
update_current_model(EX).
ask_user_if_model_unspecified(EX,_M):-
\+ var(EX).
ask_user_if_model_unspecified(EX,M):-
var(EX),
nl,write('models:'),
nl,tab(1),write(M),
nl,write('please specify the model or n. >'),
read(EX).
rule_for_set_model_conforming_user(EX,_):-
EX == n,
!,
fail.
rule_for_set_model_conforming_user(EX,M):-
\+ member(EX,M),
write('no such model. please enter the model correctly. '),
!,
fail.
rule_for_set_model_conforming_user(EX,_):-
\+ var(EX),
conform_to_user(EX,
' Would you like to set this as current model ? (y.) >'
),
nl.
conform_to_user(EX,MSG):-
nl,
write((model:EX)),
nl,write(MSG),
read(y).
update_current_model(EX):-
models(M),
member(EX,M),
initialize_model(EX),
assert_model(EX),
cmc(directive).
initialize_model(C):-
initialize_model,
model_base(C,Preds,_),
forall(member(F/Arity,Preds), abolish(F/Arity)).
% modified: 5 Feb 2004.
initialize_model:-
(clause(current_model(C),_)->true;default_model(C)),
model_base(C,Preds,_),
forall(member(F/Arity,Preds), abolish(F/Arity)),
forall(basic_model_predicate(_,F/Arity), abolish(F/Arity)).
assert_model(EX):-
model_base(EX,Preds,Model),
make_model_predicates_dynamic(Preds),
assert_model_predicates(Preds,Model),
abolish(current_model/1),
assert(current_model(EX)).
make_model_predicates_dynamic(Preds):-
forall(
(
member(F/N,Preds),
C=(:- dynamic F/N)
),
(assert(C))
).
assert_model_predicates(Preds,Model):-
forall(
(
member(F/N,Preds),length(Body,N),P=..[F|Body]
,member(C,Model)
,(P=C;C=..[':-',P|_])
),
(assert(C))
).
%------------------------------------------------------------
% Displaying the Models
%------------------------------------------------------------
display_model(EX):-
model_base(EX,_,Model),
forall(member(P,Model),(nl,write(P))).
display_current_model(EX):-
\+ conform_to_user(EX,'display the model ? (y) >').
display_current_model(_):-
display_current_model.
display_current_model:-
current_model(EX),
(nl,write(('model':EX))),
forall(
(model_predicate(EX,P/_N,Arg,_Body),G=..[P|Arg],G),
(nl,write(G))
).
display_basic_part_of_current_model(Part,EX):-
member(Part,[belief,decision]),
current_model(EX),
forall(
(
model_predicate(EX,P/N,Arguments,Body),
basic_model_predicate(Part,P/N)
),
(nl,write((EX:P/N:Arguments:Body)))
).
% display figures (game trees)
% ----------------------------------------------------------- %
figure(K/G):-
game(G,figure,K,Figure),
forall(member(L,Figure),(nl,write(L))).
% list of model predicates
% ----------------------------------------------------------- %
model_predicate(EX,P/N,Arguments,Body):-
model_base(EX,Predicates,Models),
member(P/N,Predicates),
length(Arguments,N),
G=..[P|Arguments],
member(C,Models),
(G=C;C=..[':-',G|Body]).
% basic predicates which model belief, decision, and game systems.
basic_model_predicate(belief,states/1).
basic_model_predicate(belief,bpa0/2).
basic_model_predicate(belief,bel0/2).
basic_model_predicate(belief,pos0/2).
basic_model_predicate(belief,bpa_precision0/1).
basic_model_predicate(decision,payoff0/3).
basic_model_predicate(decision,act/1).
basic_model_predicate(decision,game/4).
basic_model_predicate(decision,restriction_for_generating_beliefs0/1).
% Up to now, the following is not in the common model,
% which is specified for example ipd2.
%basic_model_predicate(belief,event0/1).
%------------------------------------------------------------
% Model Compiler
%------------------------------------------------------------
% current_model_compiler
% all unified goals --> facts.
:- dynamic temp_model/1.
cmc(conform):-
current_model(EX),
conform_to_user(EX,
'replace all model predicates with the unified goals? (y.)>'
),
cmc.
cmc(conform).
cmc(directive):- cmc.
cmc:-
current_model(EX),
abolish(temp_model/1),
(nl,write(('start model compiling..':EX))),
forall(
(model_predicate(EX,F/_N,A,_),G=..[F|A],G),
(assert(temp_model(G)))
),
initialize_model,
forall(
(temp_model(G)),
(assert(G))
).
%------------------------------------------------------------
% Apology and Caveat :
% A Mixed Initiative Type User Interface
%----------------------------------------------------
% added: 13--14 Feb 2004.
% modified: 15 Feb 2004.
% modified: 23 Feb 2004.
% modified: 8 Mar 2004.
apology:-
current_model(M),
apology_rule(M,MA),
!,
do_apology_or_pass_by(MA).
do_apology_or_pass_by([]):-!.
do_apology_or_pass_by(MA):-
MA \= [],
nl,
forall(member(X,MA),(nl,write(X))),
nl,
write(' If you like, go ahead (type y) . Or type n.'),
nl,
(read(y)->true; !,fail).
apology_rule(lo32,
[' The 3-player version has become available recently, 7 Mar 2004. ']
).
apology_rule(ipd2, Predict ):-
estimate_complexity_and_advise(Predict,_).
apology_rule(M,
[
' Sorry, this example is not game theoretical.',
' Please try model such that battle, hunt, or prudence.'
]
):-
% \+ member(M,[ipd2,battle,hunt,prudence,klibanoff]),!.
\+ game_model(M),
!.
apology_rule(_,[]).
estimate_complexity_and_advise(Predict,[L,N,M,K,E,O,AT,TT]):-
nl,write(' I will do a preliminary test for this model...'),
nl,write(' go ahead (y) > '),
read(y),
Predict =
[
StartingMessage
,'****** The basic statisitics ******'
, ('% players':N,' states':L,'events (sorted)':M)
, ('% intervals of belief(bpa)s':K)
, ('% event to which positive-valued bpas has commited ':E)
, ('% possible beliefs to be generated per player':O)
,'****** Estimated time consumption ****** '
, ('% average time per gen_ceu_max_play sampled':AT)
, ('% total time (minutes) estimated ':TT)
,'****** Recommendation ****** '
,' I would like to recommend you to commit bpa to smaller events '
,' or decrease bpa intervals. '
],
current_model(Model),
(game(Model, payoff, Acts, _)->true; fail),
length(Acts,N),
states(S),
length(S,L),
M is 2^L,
bpa_precision(K),
restriction_for_generating_beliefs0(E),
length(E,L1),
M1 is 2^L1 - 1, % bpa([],0) to be enforced.
evaluate_complexity_of_allocation_process(M1,K,O),
get_average_time_by_sampling(gen_ceu_max_play/4,_Trials,_=AT),
TT is N * O * AT /60,
select_starting_message(TT,StartingMessage).
select_starting_message(TT,StartingMessage):-
TT > 5,
!,
StartingMessage = ' Sorry, this model is highly demanding and even may not halt. '.
select_starting_message(_,StartingMessage):-
StartingMessage = ' OK, it seems not so demanding.'.
evaluate_complexity_of_allocation_process(N,K,P):-
C is K + N - 1,
D is N - 1,
combination(C,D,P),
!.
% test programs for validating the combinatorial law
% which is used in evaluate_complexity_of_allocation_process/3.
%----------------------------------------------------------------
simulate_allocation_process(ME,K,O):-
integer(ME),
integer(K),
findall(a,allocation(ME,K,_),W),
length(W,O).
a_test_of_complexity_0([X,Y],[A,B,O,c(B+A-1,A-1)=N,difference:Q]):-
integer(X),
integer(Y),
integer_between(A,[0,X]),
integer_between(B,[0,Y]),
simulate_distribution_process_of_bpa(A,B,O),
C is A + B - 1,
D is A - 1,
combination(C,D,N),
Q is N - O.
a_test_of_complexity(W,T):-
a_test_of_complexity([3,5],W,T).
a_test_of_complexity([UA,UB],W,T):-
findall([Y,A,B,O,C=N],
(
a_test_of_complexity_0([UA,UB],[A,B,O,C=N,difference:Q]),
(0 is Q-> Y = ok; Y = ng)
),
W),
message_for_complexity_test,
(member([ng|P],W)->T = false(case(P)); T = true),
write(result:T ),
nl,
write( ' display data? (y) > '),
(read(y)-> forall(member(X,W),(nl,write(X))); true).
message_for_complexity_test:-
nl,
write(' This is the partial test of the law that '),nl,
write(' the number of patterns of distributing M individible goods '),nl,
write(' for N persons equals c(M+N-1,N-1). '),nl.
%------------------------------------------------------------
% Examples : The Model Base of Beliefs and Decisions
%------------------------------------------------------------
%
:- dynamic current_model/1.
:- dynamic states/1.
:- dynamic bpa0/2.
:- dynamic bel0/2.
:- dynamic pos0/2.
:- dynamic payoff0/3.
:- dynamic act/1.
%:- dynamic bpa_precision0/1. % to be declared later.
% example 1. Ellsberg 3 color problem
% (Gilboa and Schmeidler, 1993, p.36)
%---------------------------------------------------
% cf., update_sbel(A/[b,y],_,B) for example 1.
model_base(balls, [states/1,bpa0/2],[
states([r,b,y])
% Basic probability assignment of the example
,bpa0([],0)
,bpa0([r],1/3)
,bpa0([b,y],2/3)
%,bpa0([r,b,y],1/3) % violate to normalization.
/*
,bel0([],0)
,bel0(E,1/3):- member(E,[[r],[b,r],[r,y]])
,bel0([b,y],2/3)
,bel0([b,r,y],1)
*/
]).
% example 2. Dow and Werlang(1992)'s trader
%---------------------------------------------------
model_base(trade1,
[states/1,asset/1,time/1,return/3,partition/2
,know/3,belief/3,bel0/3,bel0/2],
[
states([1,2,3])
,asset(stock)
,asset(cash)
,(time(T):-member(T,[0,1,2])
)
,return(cash,0)
,return(stock,state(1),1)
,return(stock,state(2),1/2)
,return(stock,state(3),0)
,partition(h1,[1])
,partition(h2,[2,3])
,(know(S,H,E):-
partition(_,H),
member(S,H),
sevent(E),
subset_of(H,_,E)
)
%
,belief(time(0),[],0)
,belief(time(0),X,1/4):- member(X,[[1],[2],[3]])
,belief(time(0),X,1/2):- member(X,[[1,2],[2,3],[1,3]])
,belief(time(0),[1,2,3],1)
%
% belief function for example 3.
,(bel0(F,Yq,Y):-
sevent(F),
sort(F,F1),
belief(time(0),F1,Yq),
Y is Yq
)
,(bel0(F,Y):-
bel0(F,_,Y)
)
]).
% note: the core of v(.)=bel(.) in example 2 is
% the convex hull of additive measures.
% Core(v(.))=[p | p(.)>=ｖ(.)].
%
% p*([1])=1/2, p*([2])=1/4, p*([3])=1/4,
% p*([1])=1/4, p*([2])=1/2, p*([3])=1/4,
% p*([1])=1/4, p*([2])=1/4, p*([3])=1/2.
%
% example 3. TV set sales
% in Jaffray and Wakker(1994), example 2.1.
%---------------------------------------------------
model_base(sales, [states/1,bpa0/2],[
states([qL,qM,qH])
,bpa0([],0)
,bpa0([qL],0)
,bpa0([qM],0)
,bpa0([qH],0.1)
,bpa0([qL,qM],0.6)
,bpa0([qL,qH],0)
,bpa0([qM,qH],0.3)
,bpa0([qL,qM,qH],0)
/*
,bel0([],0)
,bel0([qL],0)
,bel0([qM],0)
,bel0([qH],0.1)
,bel0([qL,qM],0.6)
,bel0([qL,qH],0.1)
,bel0([qM,qH],0.4)
,bel0([qL,qM,qH],1)
*/
/*
,pos0([],0)
,pos0([qL],0.6)
,pos0([qM],0.9)
,pos0([qH],0.4)
,pos0([qL,qM],0.9)
,pos0([qL,qH],1)
,pos0([qM,qH],1)
,pos0([qL,qM,qH],1)
*/
]).
/*
Table 1. Beliefs in the TV sales example.
[] [L] [M] [H] [L,M] [L,H] [M,H] S
------------------------------------------------------------
Bel(=v) 0 0.0 0.0 0.1 0.6 0.1 0.4 1
Pl (=v~) 0 0.6 0.9 0.4 0.9 1.0 1.0 1
m 0 0.0 0.0 0.1 0.6 0.0 0.3 0
------------------------------------------------------------
(Cited from Jaffray and Wakker(1994), Table 3.1).
% mass and belief of example 2,
% the TV set sales problem (Jaffray and Wakker, 1994)
(a) S=[L,M,H]
m([])=0.
m([L])=v([L])=0.
m([M])=v([M])=0.
m([H])=v([H])=0.1.
m([L,M])=-v([L])-v([M])+v([L,M])=0.6.
m([L,H])=-v([L])-v([H])+v([L,H]) =-0.1+0.1=0.
m([M,H])=-v([M])-v([H])+v([M,H])=-0.1+0.4=0.3.
m(S)=v([L])+v([M])+v([H])-v([L,M])-v([L,H])-v([M,H])+v([S])
=0.1-1.1+1=1-(0.1+0.6+0.3)=0.
(b) bpa->bel
v([])= m([])=0.
v([L])= m([])+m([L])=0.
v([M])= m([])+m([M])=0.
v([H])= m([])+m([H])=0.1.
v([L,M])
= m([])+m([L])+m([M])+m([L,M])=0.6.
v([L,H])
= m([])+m([L])+m([H])+m([L,H])=0.1.
v([M,H])
= m([])+m([M])+m([H])+m([M,H])=0.4.
v(S)
= m([])+m([L])+m([M])+m([H])
+m([L,M])+m([L,H])+m([M,H])
+m([L,M,H])=1.
(c) bpa->pos
v~([])=0.
v~([L])
= m([L])+m([L,M])+m([L,H])+m(S)=0.6.
v~([M])
= m([M])+m([L,M])+m([M,H])+m(S)=0.9.
v~([H])
= m([H])+m([L,H])+m([M,H])+m(S)=0.4.
v~([L,M])
= m([L])+m([M])+m([L,M])
+m([L,H])+m([M,H])+m(S)=0.9.
v~([L,H])
= m([L])+m([H])+m([L,H])
+m([L,M])+m([M,H])+m(S)=1.0.
v~([M,H])
= m([M])+m([H])+m([M,H])
+m([L,M])+m([L,H])+m(S)=1.0.
v~(S)
= m([])+m([L])+m([M])+m([H])
+m([L,M])+m([L,H])+m([M,H])
+m([L,M,H])=1=v(S).
*/
% a brief explanation for TV set example.
% ---------------------------------------------------
/*
A story: Suppose you are the sales person of a TV set.
This product has the possible quality classes, qH, qM, or qL,
each of which brings about earning size in accordance with this
order of quality.
You may use the following uncertain evidences of eight types
listed below in order to predict the purchase behavior of
customer you now supposed to faced.
% Although it will not be used hereafter in this version, ...
% available evidences and law of movement.
% (E1) share w.r.t. quality:
current_share_by_quality(qH, 0.1).
current_share_by_quality(qM, 0.3).
current_share_by_quality(qL, 0.6).
% (E2) possible behavior conditionalized on current state.
possible_purchase_of_customer(qH / [qH ]).
possible_purchase_of_customer(qM / [qL, qM]).
possible_purchase_of_customer(qL / [qL]).
% (E3)--(E8) boundary conditions of possible sales.
possible_sales_share([qH], lower(0.1), upper(0.4)).
possible_sales_share([qM], lower(0), upper(0.9)).
possible_sales_share([qL], lower(0),upper(0.6)).
possible_sales_share([qM,qH], lower(0.4),upper(1)).
possible_sales_share([qL,qM], lower(0.6),upper(0.9)).
possible_sales_share([qL,qH], lower(0.1),upper(1)).
possible_sales_share(E, upper(Ub), lower(Lb)):-
sevent(E),
findall((Uq,Lq),
(
member(Q,E),
maximum_sales_share_of(Q,Uq),
minimum_sales_share_of(Q,Lq)
),
D),
findall(Uq,member((Uq,_),D),Us),
sum(Us,Ub),
findall(Lq,member((_,Lq),D),Ls),
sum(Ls,Lb).
maximum_sales_share_of(Q,Y):-
state(Q),
findall(B,
(
possible_purchase_of_customer(Q/C),
member(X,C),
current_share_by_quality(X,B)
),
A),
sum(A,Y).
minimum_sales_share_of(qL,0).
minimum_sales_share_of(qM,0).
minimum_sales_share_of(qH,B):-current_share_by_quality(qH,B).
*/
% example 4. contingency trade (Mukerji,1997)
%---------------------------------------------------
model_base(trade2,
[states/1,primitive_states/1,prior/2,know/3,bpa0/2,
implicate/2,inverse_implication/2,act/1,payoff0/3],
[
% the default mode: states/1, bpa0/2, payoff0/3, act/1.
states([s1,s2,s3,s4])
,primitive_states([w1,w2,w3,w4,w5])
,prior(w1,0.1)
,prior(w2,0.2)
,prior(w3,0.3)
,prior(w4,0.1)
,prior(w5,0.3)
%
,(know(at(W),map(H),E):-implicate(W,H),sevent(E),subset_of(H,_,E))
%
,(bpa0(S,P):-sevent(S),implicate(W,S),prior(W,P))
,(bpa0(S,0):-sevent(S),\+ implicate(_W,S))
/*
% table 2 of Mukerji(1997, p.29)
% to verify bel/3 and sbel/3.
,bel0([],0)
,bel0([s1],0.1)
,bel0([s2],0)
,bel0([s3],0.1)
,bel0([s4],0.3)
,bel0([s1,s2],0.1)
,bel0([s1,s3],0.2)
,bel0([s1,s4],0.4)
,bel0([s2,s3],0.3)
,bel0([s2,s4],0.3)
,bel0([s3,s4],0.4)
,bel0([s1,s2,s3],0.4)
,bel0([s1,s2,s4],0.4)
,bel0([s2,s3,s4],0.6)
,bel0([s1,s3,s4],0.5)
,bel0([s1,s2,s3,s4],1)
*/
% the implication mapping.
,implicate(w1,[s1])
,implicate(w2,[s2,s3])
,implicate(w3,[s4])
,implicate(w4,[s3])
,implicate(w5,[s1,s2,s3,s4])
% inverse implication.
,(inverse_implication(X,Y):-
event(X),
findall(W,
(
implicate(W,S),%wn(implicate(W,S)),
subset(S,X)
),
Ws),
flatten(Ws,Ws1),
sort(Ws1,Y)
)
/*
% sample execution.
?- inverse_implication([s1,s2,s4],B).
implicate(w1, [s1])
implicate(w2, [s2, s3])
implicate(w3, [s4])
implicate(w4, [s3])
implicate(w5, [s1, s2, s3, s4])
B = [w1, w3] ;
No
?-
*/
% decision part of Mukerji's example
%------------------------------------
% modified: 10 Mar 2004. bugfix. eliminated redundant codes.
,act(f)
,payoff0(f,s1,10)
,payoff0(f,s2,7)
,payoff0(f,s3,4)
,payoff0(f,s4,15)
]).
%%%%%% demo %%%%%%%%%%
%-----------------------------------------
% sample executions for Mukerji's example.
%-----------------------------------------
/*
?- payoff(expected_conservative(F),P,Q).
w1, 0.1, 10
w2, 0.2, 4
w3, 0.3, 15
w4, 0.1, 4
w5, 0.3, 4
F = f
P = [0.1*10, 0.2*4, 0.3*15, 0.1*4, 0.3*4]
Q = 7.9
Yes
?- payoff(choquet(A),B,C).
A = [s1, s2, s3, s4]
B1 = []
B2 = [0]
B3 = [0]
C = 0 ;
A = [s1, s2, s4]
B1 = [s3]
B2 = [4, 0]
B3 = [ (4-0)*1, 0]
C = 4 ;
A = [s1, s4]
B1 = [s2, s3]
B2 = [7, 4, 0]
B3 = [ (7-4)*0.4, (4-0)*1, 0]
C = 5.2 ;
A = [s4]
B1 = [s1, s2, s3]
B2 = [10, 7, 4, 0]
B3 = [ (10-7)*0.4, (7-4)*0.4, (4-0)*1, 0]
C = 6.4 ;
A = []
B1 = [s4, s1, s2, s3]
B2 = [15, 10, 7, 4, 0]
B3 = [ (15-10)*0.3, (10-7)*0.4, (7-4)*0.4, (4-0)*1, 0]
C = 7.9 ;
No
?- payoff(choquet1(f),[A,B1,B2,B3],C).
A = [s1, s2, s3, s4]
B1 = []
B2 = [0]
B3 = [0]
C = 0 ;
A = [s1, s2, s3]
B1 = [s4]
B2 = [15, 0]
B3 = [15* (0.3-0), 0]
C = 4.5 ;
A = [s2, s3]
B1 = [s4, s1]
B2 = [10, 15, 0]
B3 = [10* (0.4-0.3), 15* (0.3-0), 0]
C = 5.5 ;
A = [s3]
B1 = [s4, s1, s2]
B2 = [7, 10, 15, 0]
B3 = [7* (0.4-0.4), 10* (0.4-0.3), 15* (0.3-0), 0]
C = 5.5 ;
A = []
B1 = [s4, s1, s2, s3]
B2 = [4, 7, 10, 15, 0]
B3 = [4* (1-0.4), 7* (0.4-0.4), 10* (0.4-0.3), 15* (0.3-0), 0]
C = 7.9 ;
No
?-
*/
%---------------------------------------------------
% model base of normal form game theory under uncertainty
% and Nash equilibrium in beliefs (Ref. 9-13).
%---------------------------------------------------
% example 5. A symmetric two-stage prisoners dilemma
% (Dow and Werlang,1994) Ref. 10.
%---------------------------------------------------
% added: Jan 2004.
% modified: 6 Feb 2004. added event0/1 to compile the model.
% modified: 13 Feb 2004. to abolish event0/1.
% modified: 21 Feb 2004. added bpa_precison0/1 to the model.
% modified: 7 Mar 2004. added restriction_for_generating_beliefs/1.
model_base(ipd2,
[states/1,event0/1,bel_ipd2/2,bel0/2
,bel_ipd2_pattern/2,bpa_precision0/1
,act/1,payoff0/3,strategy/3,game/4
,restriction_for_generating_beliefs0/1],
[
% the belief system of ipd2: a conxex capacity
%----------------------------------------------------
% states/1,(event0/1,)bel_ipd2/2,bel0/2,bel_ipd2_pattern/2.
states([ff,fc,cf,cc,w,x,y,z])
,bpa_precision0(2) % added: 21 Feb 2004.
% note: the following restriction will be applied only when
% the experimentations with gen_beleq ( gen_ceu_max_play ),
% and it does not work for the format of the states in this pre-stored model.
,restriction_for_generating_beliefs0([[ff],[cf],[cc],[w]]) % added: 7 Mar 2004.
%,(event0(E):-
% states(S),
% list_projection(_,S,E)
%)
,(bel0(B,P):-
sevent(B),
intersection(B,[ff,cf,cc,w],C),
bel_ipd2_pattern(C,P)
)
,(bel_ipd2_pattern(C,P):-
bel_ipd2(C1,P),
seteq(C,C1),
!
)
,(bel_ipd2_pattern(C,0):-
bel_ipd2(D,0),
subset(C,D),
!
)
%
,bel_ipd2([],0)
,bel_ipd2([cf],0.4)
,(bel_ipd2(E,0):-
member(E,[[w],[cc],[ff],[ff,cc],[cc,w],[ff,cc,w]])
)
,(bel_ipd2(E,0.4):-
member(E,[[ff,cf],[cf,w],[cf,cc]])
)
,(bel_ipd2(E,0.4):-
member(E,[[ff,cf,w],[ff,cf,cc]])
)
,bel_ipd2([cc,cf,w],0.8)
,bel_ipd2([ff,cf,cc,w],1)
,(bel_ipd2(S,1):-
states(S)
)
% the game part of ipd2: two-stage prisoners dilemma
%---------------------------------------------------
% act/1,payoff0/3,strategy/3,game/4.
% modified: 6 Feb 2004. to pass payoff0/3 a background parameter of the current player.
,(act(F):-
strategy(ipd2,F,_)
)
,(payoff0(F,S,P):-
act(F),
game(ipd2,parameter,current_player,J),
game(ipd2,payoff(J), [F, S], P)
)
% the meaning of the states:
% strategies in two step prisoners dilemma game.
% four unconditional strategies.
,strategy(ipd2,ff,[(1,f),(2,f->f),(2,c->f)])
,strategy(ipd2,fc,[(1,f),(2,f->c),(2,c->c)])
,strategy(ipd2,cf,[(1,c),(2,f->f),(2,c->f)])
,strategy(ipd2,cc,[(1,c),(2,f->c),(2,c->c)])
% four conditional strategies.
,strategy(ipd2,w,[(1,f),(2,f->f),(2,c->c)])
,strategy(ipd2,x,[(1,f),(2,f->c),(2,c->f)])
,strategy(ipd2,y,[(1,c),(2,f->f),(2,c->c)]) % Tit For Tat.
,strategy(ipd2,z,[(1,c),(2,f->c),(2,c->f)])
,(game(pd,parameter,payoff(a),A):- A is 1.25) % A >1.
,(game(pd,parameter,payoff(b),B):- B is -0.5) % B <0.
,game(pd,payoff, [f, f], [0, 0])
,game(pd,payoff, [c, c], [1, 1])
,(game(pd,payoff, [f, c], [A, B]):-
game(pd,parameter,payoff(a),A),
game(pd,parameter,payoff(b),B)
)
,(game(pd,payoff, [c, f], [B, A]):-
game(pd,parameter,payoff(a),A),
game(pd,parameter,payoff(b),B)
)
%
,(game(pd,figure,1,Figure):-
Figure=[
'% f c ',
'% +-------+-------+ ',
'% | 0 | a | a=1.25 ',
'% f | 0 | b l b=-0.5 ',
'% +-------+-------+ ',
'% | b | 1 | ',
'% c | a | 1 l ',
'% +-------+-------+ ',
'% Fig. one-shot game of prisoners dilemma.'
],
forall(member(L,Figure),(nl,write(L)))
)
% payoffs in two step prisoners dilemma game without discount.
,(game(ipd2,payoff(J), [A, B], PJ):-
game(ipd2,payoff, [A, B], PAI),
nth1(J,PAI,PJ)
)
,(game(ipd2,payoff, [A, B], [P1, P2]):-
strategy(ipd2,A,ASP),
strategy(ipd2,B,BSP),
ASP=[(1,A1),(2,f->_A2F),(2,c->_A2C)],
BSP=[(1,B1),(2,f->_B2F),(2,c->_B2C)],
game(pd,payoff, [A1, B1], [X1, Y1]),
member((2,B1->A2),ASP),
member((2,A1->B2),BSP),
game(pd,payoff, [A2, B2], [X2, Y2]),
P1 is X1 + X2,
P2 is Y1 + Y2
)
,game(ipd2,parameter,current_player,1)
]).
%%%%%% demo %%%%%%%%%%
/*
?- game(ipd2,payoff,A,P).
A = [ff, ff]
P = [0, 0] ;
A = [ff, fc]
P = [1.25, -0.5] ;
A = [ff, cf]
P = [1.25, -0.5] ;
A = [ff, cc]
P = [2.5, -1] ;
A = [ff, w]
P = [0, 0] ;
A = [ff, x]
P = [1.25, -0.5] ;
A = [ff, y]
P = [1.25, -0.5] ;
A = [ff, z]
P = [2.5, -1] ;
A = [fc, ff]
P = [-0.5, 1.25]
(...)
*/
% sample executions of Dow and Werlang's IPD game.
%---------------------------------------------------------
/*
?- bel0([A],P),P>0.
A = cf
P = 0.4 ;
No
?- mass(A,_,C),C>0.
A = [cf]
C = 0.4 ;
A = [cf, cc, w]
C = 0.4 ;
A = [ff, cf, cc, w]
C = 0.2 ;
No
?- length(A,8),bel0(A,P),P>0.
A = [ff, fc, cf, cc, w, x, y, z]
P = 1 ;
No
?- findall((A,C),payoff(choquet(A),B,C),W).
A = _G160
C = _G161
B = _G166
W = [ (ff, 0.5), (fc, 5.55112e-017), (cf, 0.6), (cc, 0.2),
(w, 0.3), (x, 0.2), (y, 0.3), (z, 0.4)]
Yes
?-
*/
% example 6. Battle of the sexes : example 3.5 in Ref. 12 .
% This game has two pure strategy NE, (c,f) and (f,c).
% (c,c) is not NE in the standard sense under EU-maximization.
%---------------------------------------------------
% added: 6 Feb 2004.
model_base(battle, [states/1,bel0/2,act/1,payoff0/3,game/4],
[
states([f,c])
,bel0([],0)
,bel0([f],0.5)
,bel0([c],0.5)
,bel0([f,c],1)
,act(f)
,act(c)
,(payoff0(F,S,P):-
act(F),
game(battle,payoff, [F, S], [P, _])
)
,(game(battle,parameter,payoff(a),A):- A is 2)
,(game(battle,parameter,payoff(b),B):- B is 1)
,game(battle,payoff, [f, f], [0, 0])
,game(battle,payoff, [c, c], [1, 1])
,(game(battle,payoff, [f, c], [A, B]):-
game(battle,parameter,payoff(a),A),
game(battle,parameter,payoff(b),B)
)
,(game(battle,payoff, [c, f], [B, A]):-
game(battle,parameter,payoff(a),A),
game(battle,parameter,payoff(b),B)
)
%
,(game(battle,figure,1,Figure):-
Figure=[
'% f c ',
'% +-------+-------+ ',
'% | 0 | a=2 | ',
'% f | 0 | b=1 l ',
'% +-------+-------+ ',
'% | b= 1 | 1 | ',
'% c | a= 2 | 1 l ',
'% +-------+-------+ ',
'% Fig. battle of the sexes game.'
],
forall(member(L,Figure),(nl,write(L)))
)
]).
% example 7. Stag hunt game : the example cited in Ref. 13.
% (c,c) is the Pareto superior NE, but a sligtht doubts
% about the rationality of each opponent player resp. may
% lead to, (d, d), another safety NE.
%---------------------------------------------------
% added: 6 Feb 2004.
model_base(hunt, [states/1,bel0/2,act/1,payoff0/3,game/4],
[
states([f,c])
,bel0([],0)
,bel0([f],0.3)
,bel0([c],0.7)
,bel0([f,c],1)
,act(f)
,act(c)
,(payoff0(F,S,P):-
act(F),
game(hunt,payoff, [F, S], [P, _])
)
,(game(hunt,parameter,payoff(a),A):- A is 8)
,(game(hunt,parameter,payoff(b),B):- B is 0)
,game(hunt,payoff, [f, f], [7, 7])
,game(hunt,payoff, [c, c], [9, 9])
,(game(hunt,payoff, [f, c], [A, B]):-
game(hunt,parameter,payoff(a),A),
game(hunt,parameter,payoff(b),B)
)
,(game(hunt,payoff, [c, f], [B, A]):-
game(hunt,parameter,payoff(a),A),
game(hunt,parameter,payoff(b),B)
)
%
,(game(hunt,figure,1,Figure):-
Figure=[
'% f c ',
'% +-------+-------+ ',
'% | 7 | a=8 | ',
'% f | 7 | b=0 l ',
'% +-------+-------+ ',
'% | b= 0 | 9 | ',
'% c | a= 8 | 9 l ',
'% +-------+-------+ ',
'% Fig. stag hunt game.'
],
forall(member(L,Figure),(nl,write(L)))
)
]).
% example 8. The game cited from Ref. 9, figure 1.
% c is dominant strategy for player 2 (column). Then (c,c)
% is rationalizable NE (with 1-step iteration of dominated strategy).
% Nevertheless, a sligtht doubt by player 1 (row) about the
% rationality of player 1 may lead to do f, more safty option
% even if the parameter, e, of positive valued is very small.
%---------------------------------------------------
% added: 11 Feb 2004.
model_base(prudence, [states/1,bel0/2,act/1,payoff0/3,game/4],
[
states([f,c])
,bel0([],0)
,bel0([f],0.3)
,bel0([c],0.7)
,bel0([f,c],1)
,act(f)
,act(c)
,(payoff0(F,S,P):-
act(F),
game(prudence,payoff, [F, S], [P, _])
)
,(game(prudence,parameter,payoff(a),A):- A is 1)
,(game(prudence,parameter,payoff(e),E):- E is 2)
,game(prudence,payoff, [c, c], [10, 10])
,(game(prudence,payoff, [f, f], [X, Y]):-
game(prudence,parameter,payoff(a),A),
game(prudence,parameter,payoff(e),E),
X is 10 - E,
Y is 10 - A
)
,(game(prudence,payoff, [c, f], [-10, Y]):-
game(prudence,parameter,payoff(a),A),
Y is 10 - A
)
,(game(prudence,payoff, [f, c], [X, 10]):-
game(prudence,parameter,payoff(e),E),
X is 10 - E
)
%
,(game(prudence,figure,1,Figure):-
Figure=[
'% f c ',
'% +-------+-------+ ',
'% | 10-e | 10-e | ',
'% f | 10-a | 10 l ',
'% +-------+-------+ ',
'% | -10 | 10 | ',
'% c | 10-a | 10 l ',
'% +-------+-------+ ',
'% Fig. prudence game.'
],
forall(member(L,Figure),(nl,write(L)))
)
]).
% example 9. Klibanoff's coordination game (example 3.6 in Ref. 12).
% This game has two pure strategy NE, (c,f) and (f,c).
% (f,f) is risk dominant and is the only BE if the confidence index
% is lower than 1/4 at least for beliefs of one player.
%---------------------------------------------------
% added: 15 Feb 2004.
model_base(klibanoff, [states/1,bel0/2,act/1,payoff0/3,game/4],
[
states([f,c])
,bel0([],0)
,bel0([f],0.6)
,bel0([c],0.4)
,bel0([f,c],1)
,act(f)
,act(c)
,(payoff0(F,S,P):-
act(F),
game(klibanoff,payoff, [F, S], [P, _])
)
,(game(klibanoff,parameter,payoff(a),A):- A is 1/2)
,(game(klibanoff,parameter,payoff(b),B):- B is 0)
,game(klibanoff,payoff, [f, f], [1, 1])
,game(klibanoff,payoff, [c, c], [2, 2])
,(game(klibanoff,payoff, [f, c], [A, B]):-
game(klibanoff,parameter,payoff(a),A),
game(klibanoff,parameter,payoff(b),B)
)
,(game(klibanoff,payoff, [c, f], [B, A]):-
game(klibanoff,parameter,payoff(a),A),
game(klibanoff,parameter,payoff(b),B)
)
%
,(game(klibanoff,figure,1,Figure):-
Figure=[
'% f c ',
'% +-------+-------+ ',
'% | 1 | a=1/2 | ',
'% f | 1 | b=0 l ',
'% +-------+-------+ ',
'% | b= 0 | 2 | ',
'% c | a=1/2 | 2 l ',
'% +-------+-------+ ',
'% Fig. klibanoff`s coordination game.'
],
forall(member(L,Figure),(nl,write(L)))
)
]).
%-------------------
% demo for example 9
%-------------------
/*
% THis game has a mixed Nash equilibrium (2/5,3/5).
%------------------------------------
% see also the modeling mixed_nash_equilibrium/3.
?- listing(bel0).
:- dynamic bel0/2.
bel0([], 0).
bel0([f], 0.6).
bel0([c], 0.4).
bel0([f, c], 1).
Yes
?- modularity_1(A).
A = modular
Yes
?- listing(payoff0).
:- dynamic payoff0/3.
payoff0(f, f, 1).
payoff0(f, c, 0.5).
payoff0(c, c, 2).
payoff0(c, f, 0).
Yes
?- equilibrium_in_symmetric_beliefs(A,B,C).
A = support:[f, c]
B = best_response:[c, f]
C = out_of_equilibrium_beliefs:[] ;
No
?-
*/
% example 10. Coordinating in beliefs (example 2 of Lo(1996)).
%---------------------------------------------------
% added: 19 Feb 2004.
% modified: 21 Feb 2004. added bpa_precision/1 to the model.
model_base(lo32, [states/1,bel0/2,act/1,payoff0/3,game/4,bpa_precision0/1],
[
states([ul,ur,dl,dr])
,bpa_precision0(2) % drive safty
,(bel0(B,P):-
sevent(B),
(member(ur,B)->P1 is 0.5;P1 is 0),
(member(dl,B)->P2 is 0.5;P2 is 0),
P is P1 + P2
)
%,bel0([],0)
%,bel0([ur],0.5)
%,bel0([dl],0.5)
%,bel0([ur,dl],1)
%,(bel_ipd2(S,1):-
% states(S)
%)
,act(t)
,act(b)
,(payoff0(F,S,P):-
act(F),
game(lo32,payoff, [F,G,H], [P,_Q,_R]),
concat(G,H,S)
)
%,game(lo32,payoff, [t, u, l], [1, 1, 1])
%,game(lo32,payoff, [t, u, r], [2, 1, 1])
% bugfix: 17 Mar 2003. correction of payoffs of lo32.
,game(lo32,payoff, [t, u, l], [-10, 1, 1])
,game(lo32,payoff, [t, u, r], [3, 1, 1])
,game(lo32,payoff, [t, d, l], [4, 1, 1])
,game(lo32,payoff, [t, d, r], [-10, 1, 1])
,game(lo32,payoff, [b, u, l], [0, 1, 1])
,game(lo32,payoff, [b, u, r], [0, 1, 1])
,game(lo32,payoff, [b, d, l], [0, 1, 1])
,game(lo32,payoff, [b, d, r], [0, 1, 1])
%
,(game(lo32,figure,1,Figure):-
Figure=[
'% ul ur dl dr ',
'% +-------+-------+-------+-------+ ',
'% t | -10 | 3 | 4 | -10 l ',
'% b | 0 | 0 l 0 | 0 l ',
'% +-------+-------+-------+-------+ ',
'% Fig. The payoffs for player 1. Other two both have constant payoffs.',
'% Note: This corrsponds to the player 3 in the original(Lo, 1996).'
],
forall(member(L,Figure),(nl,write(L)))
)
]).
%%%%%% demo %%%%%%
/*
?- equilibria_in_beliefs(P,B,[[t],[d,u],[l,r]]),P=[P1|_],member(Q,P1),
Q=(X,Y,Z),X=[[X1,Q1],[X2,Q2]],X2=[[d,l]],X1=[[u,r]].
P = [[ ([[[[d, l]], 0.5], [[[d, l], [u|...]], 0.5]], [[[d, l]]], [[d, l]]), ([[[[d, l]], 0.5], [[[d|...], [...|...]|...], 0.5]], [[[d, l]]], [[d, l]]), ([[[[d|...]], 0.5], [[[...|...]|...], 0.5]], [[[d|...]]], [[d, l]]), ([[[[...|...]], 1]], [[[...|...]]], [[d|...]]), ([[[...|...]|...], [...|...]], [[...]|...], [[...|...]]), ([[...|...]|...], [...|...], [...]), ([...], ..., ...), (..., ...)|...], [ ([[[[b, l], [b|...], [...|...]], 0.5], [[[b|...], [...|...]|...], 0.5]], [[[b, l]], [[b|...]], [[...|...]]], [[t, l]]), ([[[[b|...], [...|...]|...], 1]], [[[b|...]], [[...|...]], [...]], [[t, l]]), ([[[[...|...]|...], 1]], [[[...|...]], [...]|...], [[t|...]]), ([[[...|...]|...]], [[...]|...], [[...|...]]), ([[...|...]|...], [...|...], [...|...]), ([...|...], ..., ...), (..., ...)|...], [ ([[[[b|...], [...|...]|...], 0.5], [[[...|...]|...], 0.5]], [[[b|...]], [[...|...]], [...]], [[t, d]]), ([[[[...|...]|...], 1]], [[[...|...]], [...]|...], [[t|...]]), ([[[...|...]|...]], [[...]|...], [[...|...]]), ([[...|...]], [...|...], [...]), ([...|...], ..., ...), (..., ...)|...]]
B = [[[[d, l]], [[d, l], [u, l]], [[d, l], [u, r]], [[u, l]], [[u, l], [u|...]], [[u|...]]], [[[t, l]], [[t, l], [t, r]], [[t, r]]], [[[t, d]], [[t, d], [t, u]], [[t, u]]]]
P1 = [ ([[[[d, l]], 0.5], [[[d, l], [u, l]], 0.5]], [[[d, l]]], [[d, l]]), ([[[[d, l]], 0.5], [[[d, l], [u|...], [...|...]], 0.5]], [[[d, l]]], [[d, l]]), ([[[[d, l]], 0.5], [[[d|...], [...|...]], 0.5]], [[[d, l]]], [[d, l]]), ([[[[d|...]], 1]], [[[d|...]]], [[d, l]]), ([[[[...|...]|...], 0.5], [[...|...]|...]], [[[...|...]], [...]], [[d|...]]), ([[[...|...]|...], [...|...]], [[...]|...], [[...|...]]), ([[...|...]], [...|...], [...]), ([...], ..., ...), (..., ...)|...]
Q = [[[[u, r]], 0.5], [[[d, l]], 0.5]], [[[d, l], [u, r]]], [[d, l], [u, r]]
X = [[[[u, r]], 0.5], [[[d, l]], 0.5]]
Y = [[[d, l], [u, r]]]
Z = [[d, l], [u, r]]
X1 = [[u, r]]
Q1 = 0.5
X2 = [[d, l]]
Q2 = 0.5
Yes
?-
*/
/********** end of model data base *************/
% ----------------------------------------------------------- %
% Choquet integral (CEU) under belief functions
% ----------------------------------------------------------- %
% privious version: belief01.pl(29 Jun 2003)
% modified: 20 Jan 2004.
% a specified model: the ranking of the outcomes of ipd2.
ranked_states_in_ipd2(strategy(A),replies(BL),payoffs(P1L)):-
strategy(ipd2,A,_),
findall((P1,B),game(ipd2,payoff, [A, B], [P1, _]),R),
sort(R,R1),
reverse(R1,Q),
findall(B,member((P1,B),Q),BL),
findall(P1,member((P1,B),Q),P1L).
%%%%%% demo %%%%%%%%%%
% sample execution
%---------------------------------------------------------
/*
?- ranked_states_in_ipd2(strategy(A),replies(BL),payoffs(P1L)).
A = ff
BL = [z, cc, y, x, fc, cf, w, ff]
P1L = [2.5, 2.5, 1.25, 1.25, 1.25, 1.25, 0, 0] ;
A = fc
BL = [z, cc, x, fc, y, cf, w, ff]
P1L = [2.25, 2.25, 1, 1, 0.75, 0.75, -0.5, -0.5] ;
A = cf
BL = [y, cc, z, cf, w, fc, x, ff]
P1L = [2.25, 2.25, 1, 1, 0.75, 0.75, -0.5, -0.5] ;
A = cc
BL = [y, cc, z, w, fc, cf, x, ff]
P1L = [2, 2, 0.5, 0.5, 0.5, 0.5, -1, -1] ;
A = w
BL = [z, cc, x, fc, y, cf, w, ff]
P1L = [2.25, 2.25, 1.25, 1.25, 0.75, 0.75, 0, 0] ;
A = x
BL = [z, cc, y, cf, x, fc, w, ff]
P1L = [2.5, 2.5, 1.25, 1.25, 1, 1, -0.5, -0.5] ;
A = y
BL = [y, cc, w, fc, z, cf, x, ff]
P1L = [2, 2, 0.75, 0.75, 0.5, 0.5, -0.5, -0.5]
A = z
BL = [y, cc, z, cf, w, fc, x, ff]
P1L = [2.25, 2.25, 1, 1, 0.5, 0.5, -1, -1] ;
No
*/
/*********************************/
/* model 1 : */
/* ranking and cumulating */
/* by states */
/*********************************/
% outcomes ranked by states
%-----------------------------------------------------
% The following programs cause multiple cumulative path.
payoff(ranked(F),SS,[]):-
act(F),
states(SS).
payoff(ranked(F),Remains,[(X,S)|Z]):-
act(F),
payoff(ranked(F),R1,Z),
(R1=[]->!,fail;true),
state(S),
payoff0(F,S,X),
member(S,R1),
\+ (
member(S1,R1),
payoff0(F,S1,X1),
X1 < X
),
subtract(R1,[S],Remains).
% CEU : Choquet integral representation of EU under uncertainty.
%-------------------------------------------------------------
payoff(choquet(F),[Y,Z,W],E1):-
act(F),
payoff(choquet_1(F),[[],Y,Z,W],E1).
payoff(choquet_1(F),[SS,[],[0],[0]],0):-
act(F),
states(SS).
payoff(choquet_1(F),[Remains,Y1,[X|Z],[V|W]],E):-
act(F),
payoff(choquet_1(F),[R1,Y,Z,W],E1),
(R1=[]->!,fail;true),
findall(S,
max(X,
(
state(S),
member(S,R1),
payoff0(F,S,X)
)
),
A),
subtract(R1,A,Remains),
A=[T|_],
payoff0(F,T,X),
bel(Y,_,B0),
append(Y,A,Y1),
bel(Y1,_,B1),
V = X * (B1-B0),
%nl,write(X*(bel(Y1)-bel(Y))),write('='),write(V),
E is E1 + V.
% CEU : an equivalent formalization.
%---------------------------------
payoff(choquet0(F),[Y,Z,W],E1):-
act(F),
payoff(choquet_2(F),[[],Y,Z,W],E1).
payoff(choquet_2(F),[SS,[],[0],[0]],0):-
act(F),
states(SS).
payoff(choquet_2(F),[Remains,[S|Y],[X|Z],[V|W]],E):-
act(F),
payoff(choquet_2(F),[R1,Y,Z,W],E1),
(R1=[]->!,fail;true),
state(S),
payoff0(F,S,X),
member(S,R1),
\+ (
member(S1,R1),
payoff0(F,S1,X1),
X1 < X
),
subtract(R1,[S],Remains),
bel(R1,_,B),
Z = [Z1|_],
V = (X-Z1) * B,
%nl,write('dX*_bel'(R1)=(X-Z1)*B),write('='(V)),
E is E1 + V.
% Cautious decision making modeled by conservative extension
% under implication mapping (cf., Mukerji(1997), p.41).
%-----------------------------------------------------
% Note: I think that the implication mapping and its prior corresponds an event with positive-valued bpa.
% modified: 12,13 Mar 2004. extended for the cases of no implicate/2 or prior/2.
payoff(conservative(F),W,X):-
act(F),
(clause(implicate(_,_),_)
-> FocalSet = implicate(W,H)
; FocalSet = (bpa(H,B),B>0,W=H)
),
FocalSet,
findall(Y,
(
member(S,H),
payoff0(F,S,Y)
),
Z),
min_of(X,Z).
payoff(expected_conservative(F),Es,X):-
act(F),
(clause(prior(_,_),_)
-> Prior = prior(W,Q)
; Prior = (bpa(W,Q),Q>0)
),
findall((W,Q,Z),
(
Prior,
payoff(conservative(F),W,Z) %,wn((W,Q,Z))
),
D),
findall(E,
(
member((W,Q,Z),D),
E = Q * Z
),
Es),
sum(Es,X).
%%%%%% demo %%%%%%%%%%
/*
% trade2 (Mukerji)
%---------------------------------------------------------
?- payoff(choquet(F),A,C).
F = f
A = [[s4, s1, s2, s3], [4, 7, 10, 15, 0], [4* (1-0.4), 7* (0.4-0.4), 10* (0.4-0.3), 15* (0.3-0), 0]]
C = 7.9 ;
No
?- payoff(expected_conservative(S),A,B).
S = f
A = [0.1*10, 0.2*4, 0.3*15, 0.1*4, 0.3*4]
B = 7.9 ;
No
?- test_ceu(F,A,C).
F = f
A = [4, [[s3], [s2], [s1], [s4]], [4, 7, 10, 15], [1, 0.4, 0.4, 0.3], [4* (1-0.4), 7* (0.4-0.4), 10* (... -...), ... *...]]
C = 7.9
Yes
?-
% ipd2 (Dow and Werlang)
%---------------------------------------------------------
?- payoff(choquet(A),B,C).
A = ff
B = [[cc, z, cf, fc, x, y, ff, w], [0, 1.25, 2.5, 0], [0* (1-0.4), 1.25* (0.4-0), 2.5* (0-0), 0]]
C = 0.5 ;
A = fc
B = [[cc, z, fc, x, cf, y, ff, w], [-0.5, 0.75, 1, 2.25, 0], [-0.5* (1-0.4), 0.75* (0.4-0), 1* (0-0), 2.25* (0-0), 0]]
C = 5.55112e-017 ;
A = cf
B = [[cc, y, cf, z, fc, w, ff, x], [-0.5, 0.75, 1, 2.25, 0], [-0.5* (1-0.8), 0.75* (0.8-0.4), 1* (0.4-0), 2.25* (0-0), 0]]
C = 0.6 ;
A = cc
B = [[cc, y, cf, fc, w, z, ff, x], [-1, 0.5, 2, 0], [-1* (1-0.8), 0.5* (0.8-0), 2* (0-0), 0]]
C = 0.2 ;
A = w
B = [[cc, z, fc, x, cf, y, ff, w], [0, 0.75, 1.25, 2.25, 0], [0* (1-0.4), 0.75* (0.4-0), 1.25* (0-0), 2.25* (0-0), 0]]
C = 0.3 ;
A = x
B = [[cc, z, cf, y, fc, x, ff, w], [-0.5, 1, 1.25, 2.5, 0], [-0.5* (1-0.4), 1* (0.4-0.4), 1.25* (0.4-0), 2.5* (0-0), 0]]
C = 0.2 ;
A = y
B = [[cc, y, fc, w, cf, z, ff, x], [-0.5, 0.5, 0.75, 2, 0], [-0.5* (1-0.8), 0.5* (0.8-0), 0.75* (0-0), 2* (0-0), 0]]
C = 0.3 ;
A = z
B = [[cc, y, cf, z, fc, w, ff, x], [-1, 0.5, 1, 2.25, 0], [-1* (1-0.8), 0.5* (0.8-0.4), 1* (0.4-0), 2.25* (0-0), 0]]
C = 0.4 ;
No
?-
*/
/*********************************/
/* model 2 : */
/* ranking and cumulating */
/* by events */
/*********************************/
ranked_states(act(A),states(SL),payoffs(PL)):-
act(A),
setof((P,S),P^S^payoff0(A,S,P),R),
reverse(R,R1),
findall(S,member((P,S),R1),SL),
findall(P,member((P,S),R1),PL).
leveled_event(act(A),event(E),payoff(P),rank(K/N)):-
act(A),
setof(P,S^payoff0(A,S,P),R),
length(R,N),
reverse(R,R1),
nth1(K,R1,P),
findall(S,payoff0(A,S,P),E).
%%%%%% demo %%%%%%%%%%
% sample execution for ipd2
%---------------------------------------------------------
/*
?- ranked_states(A,B,C).
A = act(ff)
B = states([z, cc, y, x, fc, cf, w, ff])
C = payoffs([2.5, 2.5, 1.25, 1.25, 1.25, 1.25, 0, 0]) ;
A = act(fc)
B = states([z, cc, x, fc, y, cf, w, ff])
C = payoffs([2.25, 2.25, 1, 1, 0.75, 0.75, -0.5, -0.5]) ;
A = act(cf)
B = states([y, cc, z, cf, w, fc, x, ff])
C = payoffs([2.25, 2.25, 1, 1, 0.75, 0.75, -0.5, -0.5]) ;
A = act(cc)
B = states([y, cc, z, w, fc, cf, x, ff])
C = payoffs([2, 2, 0.5, 0.5, 0.5, 0.5, -1, -1]) ;
A = act(w)
B = states([z, cc, x, fc, y, cf, w, ff])
C = payoffs([2.25, 2.25, 1.25, 1.25, 0.75, 0.75, 0, 0]) ;
A = act(x)
B = states([z, cc, y, cf, x, fc, w, ff])
C = payoffs([2.5, 2.5, 1.25, 1.25, 1, 1, -0.5, -0.5]) ;
A = act(y)
B = states([y, cc, w, fc, z, cf, x, ff])
C = payoffs([2, 2, 0.75, 0.75, 0.5, 0.5, -0.5, -0.5]) ;
A = act(z)
B = states([y, cc, z, cf, w, fc, x, ff])
C = payoffs([2.25, 2.25, 1, 1, 0.5, 0.5, -1, -1]) ;
No
?- leveled_event(A,B,C,D).
A = act(ff)
B = event([cc, z])
C = payoff(2.5)
D = rank(1/3) ;
A = act(ff)
B = event([fc, cf, x, y])
C = payoff(1.25)
D = rank(2/3) ;
A = act(ff)
B = event([ff, w])
C = payoff(0)
D = rank(3/3) ;
A = act(fc)
B = event([cc, z])
C = payoff(2.25)
D = rank(1/4)
Yes
?-
*/
%---------------------------------------------------------
% The Choquet Integral Representation
%---------------------------------------------------------
% pessimistic agent.
ceu_payoff(act(F),rank(1/N),[A,[A],[X],[B],[X*B]],V):-
act(F),
% the best outcome.
leveled_event(act(F),event(A),payoff(X),rank(1/N)),
bel(A,_,B),
V is X * B.
ceu_payoff(act(F),rank(K/N),[Y,[A|O],[X|Z],[B|C],[V|U]],E):-
act(F),
% the k-th best outcome.
ceu_payoff(act(F),rank(K0/N),[W,O,Z,C,U],E0),
(K0=N->!,fail;K is K0 + 1),
leveled_event(act(F),event(A),payoff(X),rank(K/N)),
C=[B0|_],
append(A,W,Y),
bel(Y,_,B),
V = X * (B-B0),
E is E0 + V.
test_ceu(Act,[Levels,Events,Payoffs,Beliefs,Terms_of_CEU],CEU_Value):-
act(Act),
ceu_payoff(
act(Act),
rank(Levels/Levels),
[_,Events,Payoffs,Beliefs,Terms_of_CEU],
CEU_Value
).
%test_ceu(end,nodata,null).
% optimistic agent.
dceu_payoff(act(F),rank(N/N),[A,[A],[X],[B],[X*B]],V):-
act(F),
% the worst outcome.
leveled_event(act(F),event(A),payoff(X),rank(N/N)),
bel(A,_,B),
V is X * B.
dceu_payoff(act(F),rank(K/N),[Y,[A|O],[X|Z],[B|C],[V|U]],E):-
act(F),
% the k-th worst outcome.
dceu_payoff(act(F),rank(K0/N),[W,O,Z,C,U],E0),
(K0=1->!,fail;K is K0 - 1),
leveled_event(act(F),event(A),payoff(X),rank(K/N)),
C=[B0|_],
append(A,W,Y),
bel(Y,_,B),
V = X * (B-B0),
E is E0 + V.
test_dceu(Act,[Levels,Events,Payoffs,Beliefs,Terms_of_CEU],CEU_Value):-
act(Act),
dceu_payoff(
act(Act),
rank(1/Levels),
[_,Events,Payoffs,Beliefs,Terms_of_CEU],
CEU_Value
).
%---------------------------------------------------
% test run: computing CEU for examples
%---------------------------------------------------
% note:
% It may be better for you to use cmc/1 before do the followings.
%%%%%% demo %%%%%%%%%%
/*
% trade2 (Mukerji)
%---------------------------------------------------
?- test_ceu(Act,[Levels,Events,Payoffs,Beliefs,Terms_of_CEU],CEU_Value).
Act = f
Levels = 4
Events = [[s3], [s2], [s1], [s4]]
Payoffs = [4, 7, 10, 15]
Beliefs = [1, 0.4, 0.4, 0.3]
Terms_of_CEU = [4* (1-0.4), 7* (0.4-0.4), 10* (0.4-0.3), 15*0.3]
CEU_Value = 7.9
Yes
% ipd2 (Dow and Werlang)
%---------------------------------------------------
% See remarks for the proposition 5.1 in Groes et al.(1998, p.56).
?- test_ceu(Act,[Levels,Events,Payoffs,Beliefs,Terms_of_CEU],CEU_Value).
Act = ff
Levels = 3
Events = [[ff, w], [fc, cf, x, y], [cc, z]]
Payoffs = [0, 1.25, 2.5]
Beliefs = [1, 0.4, 0]
Terms_of_CEU = [0* (1-0.4), 1.25* (0.4-0), 2.5*0]
CEU_Value = 0.5 ;
Act = fc
Levels = 4
Events = [[ff, w], [cf, y], [fc, x], [cc, z]]
Payoffs = [-0.5, 0.75, 1, 2.25]
Beliefs = [1, 0.4, 0, 0]
Terms_of_CEU = [-0.5* (1-0.4), 0.75* (0.4-0), 1* (0-0), 2.25*0]
CEU_Value = 5.55112e-017 ;
Act = cf
Levels = 4
Events = [[ff, x], [fc, w], [cf, z], [cc, y]]
Payoffs = [-0.5, 0.75, 1, 2.25]
Beliefs = [1, 0.8, 0.4, 0]
Terms_of_CEU = [-0.5* (1-0.8), 0.75* (0.8-0.4), 1* (0.4-0), 2.25*0]
CEU_Value = 0.6 ;
Act = cc
Levels = 3
Events = [[ff, x], [fc, cf, w, z], [cc, y]]
Payoffs = [-1, 0.5, 2]
Beliefs = [1, 0.8, 0]
Terms_of_CEU = [-1* (1-0.8), 0.5* (0.8-0), 2*0]
CEU_Value = 0.2 ;
Act = w
Levels = 4
Events = [[ff, w], [cf, y], [fc, x], [cc, z]]
Payoffs = [0, 0.75, 1.25, 2.25]
Beliefs = [1, 0.4, 0, 0]
Terms_of_CEU = [0* (1-0.4), 0.75* (0.4-0), 1.25* (0-0), 2.25*0]
CEU_Value = 0.3 ;
Act = x
Levels = 4
Events = [[ff, w], [fc, x], [cf, y], [cc, z]]
Payoffs = [-0.5, 1, 1.25, 2.5]
Beliefs = [1, 0.4, 0.4, 0]
Terms_of_CEU = [-0.5* (1-0.4), 1* (0.4-0.4), 1.25* (0.4-0), 2.5*0]
CEU_Value = 0.2 ;
Act = y
Levels = 4
Events = [[ff, x], [cf, z], [fc, w], [cc, y]]
Payoffs = [-0.5, 0.5, 0.75, 2]
Beliefs = [1, 0.8, 0, 0]
Terms_of_CEU = [-0.5* (1-0.8), 0.5* (0.8-0), 0.75* (0-0), 2*0]
CEU_Value = 0.3 ;
Act = z
Levels = 4
Events = [[ff, x], [fc, w], [cf, z], [cc, y]]
Payoffs = [-1, 0.5, 1, 2.25]
Beliefs = [1, 0.8, 0.4, 0]
Terms_of_CEU = [-1* (1-0.8), 0.5* (0.8-0.4), 1* (0.4-0), 2.25*0]
CEU_Value = 0.4 ;
No
?-
*/
%---------------------------------------------------
% as if EU : assuming the additivity erroneously.
%---------------------------------------------------
as_if_eu_payoff(act(F),rank(1/N),[A,[A],[X],[B],[X*B]],V):-
act(F),
% the best outcome.
leveled_event(act(F),event(A),payoff(X),rank(1/N)),
bel(A,_,B),
V is X * B.
as_if_eu_payoff(act(F),rank(K/N),[Y,[A|O],[X|Z],[B|C],[V|U]],E):-
act(F),
% the k-th best outcome.
as_if_eu_payoff(act(F),rank(K0/N),[W,O,Z,C,U],E0),
(K0=N->!,fail;K is K0 + 1),
leveled_event(act(F),event(A),payoff(X),rank(K/N)),
append(A,W,Y),
bel(A,_,B),
V = X * B,
E is E0 + V.
test_as_if_eu(Act,[Levels,Events,Payoffs,Beliefs,Terms_of_CEU],CEU_Value):-
act(Act),
as_if_eu_payoff(
act(Act),
rank(Levels/Levels),
[_,Events,Payoffs,Beliefs,Terms_of_CEU],
CEU_Value
).
%%%%%% demo %%%%%%%%
/*
% trade2 (Mukerji)
%-----------------------------
?- test_as_if_eu(F,A,C).
F = f
A = [4, [[s3], [s2], [s1], [s4]], [4, 7, 10, 15], [0.1, 0, 0.1, 0.3], [4*0.1, 7*0, 10*0.1, ... *...]]
C = 5.9
Yes
?- test_m2eu(F,A,C).
F = f
A = [4, [[s3], [s2], [s1], [s4]], [4, 7, 10, 15], [0.1, 0, 0.1, 0.3], [4*0.1, 7*0, 10*0.1, ... *...]]
C = 5.9 ;
No
?-
% ipd2 (Dow and Werlang)
%------------------------
?- test_as_if_eu(Act,[Levels,Events,Payoffs,Beliefs,Terms_of_CEU],CEU_Value).
Act = ff
Levels = 3
Events = [[ff, w], [fc, cf, x, y], [cc, z]]
Payoffs = [0, 1.25, 2.5]
Beliefs = [0, 0.4, 0]
Terms_of_CEU = [0*0, 1.25*0.4, 2.5*0]
CEU_Value = 0.5
Yes
?- findall((F,C),test_as_if_eu(F,_,C),W).
F = _G160
C = _G161
W = [ (ff, 0.5), (fc, 0.3), (cf, 0.4), (cc, 0.2),
(w, 0.3), (x, 0.5), (y, 0.2), (z, 0.4)]
X = _G171
Yes
?-
*/
%---------------------------------------------------
% Max-Min Expected Utility for Multiple-Prior
%---------------------------------------------------
% added: 10 Mar 2004.
m2eu_payoff(act(F),rank(1/N),[A,[A],[X],[B],[X*B]],V):-
act(F),
% the best outcome.
leveled_event(act(F),event(A),payoff(X),rank(1/N)),
bpa(A,B),
V is X * B.
m2eu_payoff(act(F),rank(K/N),[Y,[A|O],[X|Z],[B|C],[V|U]],E):-
% (clause(bpa0(_,_),_)->true;fail),
act(F),
% the k-th best outcome.
m2eu_payoff(act(F),rank(K0/N),[W,O,Z,C,U],E0),
(K0=N->!,fail;K is K0 + 1),
leveled_event(act(F),event(A),payoff(X),rank(K/N)),
append(A,W,Y),
bpa(A,B),
V = X * B,
E is E0 + V.
test_m2eu(Act,[Levels,Events,Payoffs,Beliefs,Terms_of_M2EU],M2EU_Value):-
act(Act),
m2eu_payoff(
act(Act),
rank(Levels/Levels),
[_,Events,Payoffs,Beliefs,Terms_of_M2EU],
M2EU_Value
).
%%%%%% demo %%%%%%%%%%
/*
% test run for ipd2.
% ----------------------------------------------------------- %
?- test_m2eu(Act,[Levels,Events,Payoffs,Beliefs,Terms],Value).
*/
%----------------------------------------------------
% Equilibrium in Beliefs:
% The Choquet/Multi-Prior rational analog of Nash equilibrium under Uncertainty
%----------------------------------------------------
% Ref. 9, 12, 13, and 14. Cf., Ref.11 and also 12 as for multiple prior models.
% added: 23 Jan 2004.
% modified: 5--6 Feb 2004.
% modified: 11--21 Feb 2004.
% best_response/1: nash strategy under ambiguous beliefs.
% caution:
% Whenever you execute this program a background assumption must holds
% that the (current) belief system represents the opponent(s)'s
% conjection about the (current) player who supposed
% to do Choquet-integral maximization conditionalized on the
% belief system.
best_response(BR):-
findall(A,
max(U,test_ceu(A,_,U)),
BR).
% bliefs_equilibrium/2: equilibrium of the game in beliefs.
% >definition< (Equilibrium in Beliefs) see Ref.9 and Ref.12.
% support(B) is a subset of intersection of best responses.
% caution:
% The modeling below is not valid in that it assumes that
% the above mentioned assumption holds for every player
% symmetricaly (i.e., identical beliefs, as example ipd2) .
equilibrium_in_symmetric_beliefs(
support:Sup,
best_response:BR,
out_of_equilibrium_beliefs:Out
):-
support(Sup),
best_response(BR),
subtract(Sup,BR,Out),
(Out\=[]->(nl,write(disequilibrium));true).
/* problematic modeling with side-effects */
% added: 20 Feb 2004.
%equilibrium_in_beliefs([P1,P2],[Supp1,Supp2],[R1,R2]):-
% gen_ceu_max_play(1,P1,S1,R1), % P1: 1's beliefs about 2's act.
% gen_ceu_max_play(2,P2,S2,R2), % P2: 2's beliefs about 1's act.
% member(Supp1,S1),
% subset(Supp1,R2),
% member(Supp2,S2),
% subset(Supp2,R1).
%%%%%% demo %%%%%%%%%%
/*
% ipd2:
%-------
?- equilibrium_in_symmetric_beliefs(A,B,C).
A = support:[cf]
B = best_response:[cf]
C = out_of_equilibrium_beliefs:[] ;
No
?-
% battle:
%---------
?- equilibrium_in_symmetric_beliefs(A,B,C).
A = support:[f, c]
B = best_response:[c, f]
C = out_of_equilibrium_beliefs:[] ;
No
?- listing(bel0).
:- dynamic bel0/2.
bel0([], 0).
bel0([f], 0.1).
bel0([c], 0.5).
bel0([f, c], 1).
Yes
?- mass(A,B,C).
A = []
B = 0
C = 0 ;
A = [c]
B = -1^0*0.5+ -1^1*0
C = 0.5 ;
A = [f]
B = -1^0*0.1+ -1^1*0
C = 0.1 ;
A = [f, c]
B = -1^0*1+ -1^1*0.1+ -1^1*0.5+ -1^2*0
C = 0.4 ;
No
?-
*/
%--------------------------------------------------
% Support of Nonadditive Probability Measure
%--------------------------------------------------
% added: 20-22 Jan 2004.
% definition of support by Dow and Werlang(1994) and
% also in Eichberger and Kelsey(1999).
% supp(P):=A s.t. P(A*)=0 and for all subset B of A, P(B*)>0.
% where C* denotes complement of event C. i.e.,
% the minimal event event whose complement is measure zero.
% modified: 6 Feb 2004. proper_subset_of/2. (Y \= S --> \+ seteq(Y,S).
proper_subset_of(S,Y):-
var(Y),
sevent(Y),
subset_of(S,_,Y),
\+ seteq(Y,S).
proper_subset_of(S,Y):-
\+ var(Y),
subset_of(S,_,Y),
\+ seteq(Y,S).
support0(S):-
findall(X,
(
sbel([X],_,B),
B>0
),
S).
% modified: 17 Feb 2004.
% note: 0 \= 0.0, but 0 is 0.0 in Prolog.
event_whose_complements_is_measure_zero(S):-
states(W),
sbel(Y,_,Zero),
0 is Zero,
subtract(W,Y,S).
support1(S):-
states(W),
event_whose_complements_is_measure_zero(S),
forall(
proper_subset_of(Y,S),
(
subtract(W,Y,X),
bel(X,_,B),
B>0
)
).
support(S):-
states(W),
event_whose_complements_is_measure_zero(S),
\+ (
proper_subset_of(Y,S),
subtract(W,Y,X), % complementary event of Y
bel(X,_,Z),
Z is 0%,write((S,Y,Z)) % for debug
).
all_supports(AS):-
findall(S,support(S),AS).
%%%%%% demo %%%%%%%%%%
/*
?- support(S).
S = [cf] ;
No
?- best_response(A).
A = [cf] ;
No
?-
*/
%--------------------------------------------------
% Indices of Non-Additive Propabilities :
% Confidence and Ambiguity
%--------------------------------------------------
% cf., Ref.12.
% added: 3 Feb 2004.
% confidence = max{ belief(E)+belief(S-E) }
% ambiguity = 1-min{ belief(E)+belief(S-E) }
% = max{1- belief(E)- belief(S-E)}
% modified: 15 Feb 2004. alias added.
confidence(Index):-
degree_of_confidence(Index).
ambiguity(Index):-
degree_of_ambiguity(Index).
degree_of_confidence_about_event(A,Index):-
sbel(A,_,B),
c_event(A,C),
bel(C,_,B1),
Index is B + B1.
degree_of_confidence(A,Index):-
states(S),
max(Index,
(
degree_of_confidence_about_event(A,Index)
,A \= [], A \= S % this condition was needed.
)
).
degree_of_confidence(Index):-
degree_of_confidence(_,Index),
!.
degree_of_ambiguity_about_event(A,Index):-
sbel(A,_,B),
c_event(A,C),
bel(C,_,B1),
Index is 1 - B - B1.
degree_of_ambiguity(A,Index):-
states(S),
max(Index,
(
degree_of_ambiguity_about_event(A,Index)
,A \= [], A \= S % this condition was needed.
)
).
degree_of_ambiguity(Index):-
degree_of_ambiguity(_,Index),
!.
% test program for unit condition for the sum of indices.
test_sum_of_degrees(A,B,C,D):-
degree_of_confidence_about_event(A,B),
degree_of_ambiguity_about_event(A,C),
D is B + C.
%%%%%% demo %%%%%%%%%%
/*
?- set_model(balls).
model:balls, Would you like to set this as current model ? (y.) >y.
Yes
?- degree_of_confidence(A,B).
A = [b, y]
B = 1 ;
A = [r]
B = 1 ;
No
?- degree_of_ambiguity(A,B).
A = [b]
B = 0.666667 ;
A = [r, b]
B = 0.666667 ;
A = [r, y]
B = 0.666667 ;
A = [y]
B = 0.666667 ;
No
?- test_sum_of_degrees(A,B,C,D), D\=1.
No
?- set_model(ipd2).
model:ipd2, Would you like to set this as current model ? (y.) >y.
start model compiling.. :ipd2
% f c
% +-------+-------+
% | 0 | a |
% f | 0 | b l
% +-------+-------+
% | b | 1 |
% c | a | 1 l
% +-------+-------+
% Fig. one-shot game of prisoners dilemma.
Yes
?- degree_of_confidence(A,B).
A = [fc]
B = 1 ;
A = [fc, x]
B = 1 ;
A = [fc, x, y]
B = 1 ;
A = [fc, x, y, z]
B = 1 ;
Yes
?- degree_of_ambiguity(A,B).
A = [cc]
B = 0.6 ;
A = [cc, w]
B = 0.6 ;
A = [cc, w, x]
B = 0.6 ;
Yes
?- test_sum_of_degrees(A,B,C,D), D\=1.
No
?-
*/
% Comparison:
% Mixed Nash Equilibrium for 2x2 nornal form games.
%--------------------------------------------------------
% added and modified: 16 Feb 2004.
mixed_nash_equilibrium(G,[(1,R1,P),(1,S1,1-P)],[(2,R2,Q),(2,S2,1-Q)]):-
game(G,payoff,[R1,R2], [A11,B11]),
game(G,payoff,[S1,R2], [A21,B21]),
S1 @> R1,
game(G,payoff,[R1,S2], [A12,B12]),
S2 @> R2,
game(G,payoff,[S1,S2], [A22,B22]),
P is (B22-B21) /(B22-B21+B11-B12),
Q is (A22-A12) /(A22-A12+A11-A21).
set_mixed_nash_strategy_as_current_beliefs(G):-
mixed_nash_equilibrium(G,_,[(2,R2,Q),(2,S2,1-Q)]),
set_payoffs_of_game(1,_,[W,_]),
abolish(bel0/2),
assert(bel0([],0)),
assert(bel0([[R2]],Q)),
assert(bel0([[S2]],1-Q)),
assert(bel0(W,1)).
%%%%%% demo %%%%%%%%%%
/*
?- mixed_nash_equilibrium(Act,[R1,R2],[P,Q]).
Act = klibanoff
R1 = c
R2 = c
P = 0.4
Q = 0.4 ;
No
?-
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Nash Equilibrium under Uncertainty (NEUU)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% added and modified: 11--13 Feb 2004. for N=2 (2x2) games.
% modified: 15--20 Feb 2004. extended tests with the indices and simplified.
% modified: 21 Feb 2004. rewrited equilibrium conditions (to be generalized to N=3).
% modified: 22 Feb--3 Mar 2004. improved equilibria generation as the set function.
%%%%% meta calls %%%%%%
% Conditions of Nash equilibrium under uncertanty
% : equilibrium in beliefs
%------------------------------------------------
% The condition for N=2, see Dow and Werlang(1994).
% As for N >=3, see Eichberger and Kelsey(2000).
% note: equilibrium in beliefs coincides with NE if additive.
% modified: 20--21 Feb 2004.
% modified: 22 Feb 2004. renamed temp_equilibrium_in_beliefs-->equilibrium_in_beliefs.
% modified: 28 Feb--3 Mar 2004. the set function versions.
% modified: 12 Mar 2004. added the ramified version.
% The bundle of equilibria :
% set function versions of wrapped belief systems.
%------------------------------------------------------
% added: 1 Mar 2004.
% modified: 8 Mar 2004.
% the wrapped equilibria (collected both beliefs and supports)
equilibria_in_beliefs([P1,P2],[SP1,SP2],R):-
length(R,2),
equilibria_in_beliefs_2([P1,P2],R,[yes,yes]),
setof(S,B^SS^member((B,SS,S),P1),SP1),
setof(S,B^SS^member((B,SS,S),P2),SP2).
equilibria_in_beliefs([P1,P2,P3],[SP1,SP2,SP3],R):-
length(R,3),
equilibria_in_beliefs_3([P1,P2,P3],R,[yes,yes,yes]),
setof(S,B^SS^member((B,SS,S),P1),SP1),
setof(S,B^SS^member((B,SS,S),P2),SP2),
setof(S,B^SS^member((B,SS,S),P3),SP3).
% ramification of each equilibrium
%-----------------------------------
% modified: 17 Mar 2004. bugfix.
% choose a triplet by product_of_lists/2.
% The code is simple. However, this cannot be used to seek a specified beliefs.
equilibrium_in_beliefs_ramified(Bpa,Ssup,Asup,A):-
equilibria_in_beliefs(PL,_,A),
product_of_lists(PL,L),
findall(B,member((B,SS,AS),L),Bpa),
findall(SS,member((B,SS,AS),L),Ssup),
findall(AS,member((B,SS,AS),L),Asup).
test_ramify_for_lo32_0(B,SS,AS,A):-
equilibrium_in_beliefs_ramified(B,SS,AS,A),
B=[B1,B2,B3],
B1=[[[[d,l]],0.5],[[[u,r]],0.5]],
B2=[[[[t,l]],0.5],[[[t,r]],0.5]],
B3=[[[[t,d]],0.5],[[[t,u]],0.5]].
test_ramify_for_lo32([B1,B2,B3],SS,AS,A):-
equilibria_in_beliefs([L1,L2,L3],_,A),
SS=[SS1,SS2,SS3],
AS=[AS1,AS2,AS3],
member((B1,SS1,AS1),L1),
X1=[[[d,l]],0.5],Y1=[[[u,r]],0.5],
member(X1,B1),
member(Y1,B1),
member((B2,SS2,AS2),L2),
%X2=[[[b,l]],0.5],Y2=[[[t,r]],0.5],
X2=[[[t,l]],0.5],Y2=[[[t,r]],0.5],
member(X2,B2),
member(Y2,B2),
member((B3,SS3,AS3),L3),
%X3=[[[b,d]],0.5],Y3=[[[t,u]],0.5],
X3=[[[t,d]],0.5],Y3=[[[t,u]],0.5],
member(X3,B3),
member(Y3,B3).
%%%%%% demo %%%%%%%
/*
% lo32 : this additive case consists a Nash equilibrium.
%--------------------------------------------------------
?- test_ramify_for_lo32([B1,B2,B3],SS,AS,A),
equilibrium_in_beliefs([B1,B2,B3],AS,A1).
B1 = [[[[u, r]], 0.5], [[[d, l]], 0.5]]
B2 = [[[[t, r]], 0.5], [[[t, l]], 0.5]]
B3 = [[[[t, u]], 0.5], [[[t, d]], 0.5]]
SS = [[[[d, l], [u, r]]], [[[t, l], [t, r]]], [[[t, d], [t, u]]]]
AS = [[[d, l], [u, r]], [[t, l], [t, r]], [[t, d], [t, u]]]
A = [[t], [d, u], [l, r]]
A1 = [[t], [d, u], [l, r]]
Yes
?-
*/
% cf., the first order wrapping (collected bpas only).
equilibria_in_beliefs_level_1([P1,P2],R):-
length(R,2),
equilibria_in_beliefs_2_level_1([P1,P2],R,[yes,yes]).
equilibria_in_beliefs_level_1([P1,P2,P3],R):-
length(R,3),
equilibria_in_beliefs_3_level_1([P1,P2,P3],R,[yes,yes,yes]).
% naive equilibrium without packing (i.e., no wrapping).
%---------------------------------------------------------------
% This program does not used in gen_beleq/0. And in order for the ex post
% analysis of the gen_beleq/0, you`d be better using,
% equilibrium_in_beliefs_ramified/4,
% the ramified version.
equilibrium_in_beliefs([P1,P2],SP,R):-
length(SP,2),
length(R,2),
equilibrium_in_beliefs_2([P1,P2],_,SP,R,[yes,yes]).
equilibrium_in_beliefs([P1,P2,P3],SP,R):-
length(SP,3),
length(R,3),
equilibrium_in_beliefs_3([P1,P2,P3],_,SP,R,[yes,yes,yes]).
%%%%% the conditions %%%%%
%%%%%%%%%%%
% N=2 %
%%%%%%%%%%%
% Nash equilibrium under uncertainty for two players games.
% no wrapping version.
%--------------------------------------
% The straightforward modeling according to the definition.
% It seems easy to extend model to N>=3 cases.
% modified: 28 Feb 2004.
equilibrium_in_beliefs_2([P1,P2],[S1,S2],[SP1,SP2],[R1,R2],[Y1,Y2]):-
temp_ceu_max_play(1,P1,S1,R1), % P1: 1's beliefs about 2's act.
temp_ceu_max_play(2,P2,S2,R2), % P2: 2's beliefs about 1's act.
condition_of_equilibrium_in_beliefs_2(1,S1,SP1,R2,Y1),
condition_of_equilibrium_in_beliefs_2(2,S2,SP2,R1,Y2).
% intermediary generalized model for N=2:
condition_of_equilibrium_in_beliefs_2(1,S1,SP1,R2,yes):-
member(SP1,S1), % SP1: the set of supports of player 1.
forall(
member(X,SP1),
product_of_lists([R2],X)
).
condition_of_equilibrium_in_beliefs_2(2,S2,SP2,R1,yes):-
member(SP2,S2),
forall(
member(X,SP2),
product_of_lists([R1],X)
).
condition_of_equilibrium_in_beliefs_2(_,_,_,_,no).
% relaxation:
%------------------------------------------------------
% equilibrium in beliefs is Nash equilibrium
% if the beliefs are additive.
% the model is trivial.
% the set function (marginal) versions.
% equilibria in beliefs: collected a set of bpas, Pk, for each pair
% of profiles, SP, of the supports and, R, of the best response
% correspondences.
%--------------------------------------
% modified: 24 Feb 2004. categorized max ceu plays by using setof/3.
% improved time consumption 1.7 -->0.1 (sec) to enumerate equilibria for battle.
% modified: 28 Feb 2004. extended test for the range of beliefs indices.
% the first order wrapping solely on beliefs:
equilibria_in_beliefs_2_level_1([P1,P2],[S1,S2],[SP1,SP2],[R1,R2],[Y1,Y2]):-
setof(BP1,temp_ceu_max_play(1,BP1,S1,R1),P1),
setof(BP2,temp_ceu_max_play(2,BP2,S2,R2),P2),
condition_of_equilibrium_in_beliefs_2(1,S1,SP1,R2,Y1),
condition_of_equilibrium_in_beliefs_2(2,S2,SP2,R1,Y2).
% the second order packing both on beliefs and supports:
equilibria_in_beliefs_2([P1,P2],R,Y):-
R=[R1,R2],
Y=[yes,yes],
setof((BP1,SB1),temp_ceu_max_play(1,BP1,SB1,R1),Q1),
setof((BP2,SB2),temp_ceu_max_play(2,BP2,SB2,R2),Q2),
setof((BP1,S1,SP1),
(
member((BP1,S1),Q1),
condition_of_equilibrium_in_beliefs_2(1,S1,SP1,R2,yes)
),
P1),
setof((BP2,S2,SP2),
(
member((BP2,S2),Q2),
condition_of_equilibrium_in_beliefs_2(2,S2,SP2,R1,yes)
),
P2).
% museum:
% a previous naive version in the developmental stage.
%---------------------------------------------
% N=2: the old version in beleq02.pl.
equilibrium_in_beliefs_2_0([P1,P2],[Supp1,Supp2],[R1,R2]):-
temp_ceu_max_play(1,P1,S1,R1), % P1: 1's beliefs about 2's act.
temp_ceu_max_play(2,P2,S2,R2), % P2: 2's beliefs about 1's act.
translate_action_profile_into_events([R1,R2],[XR1,XR2]),
member(Supp1,S1),
subset(Supp1,XR2),
member(Supp2,S2),
subset(Supp2,XR1).
translate_action_profile_into_events([R1,R2],[XR1,XR2]):-
product_of_two_lists(R1,R2,XR),
projection_of_profiles([1,0],XR,XR1),
projection_of_profiles([0,1],XR,XR2).
%%%%% demo %%%%%
/*
?- condition_of_equilibrium_in_beliefs_2_0([[a,b],[c,d]],SPJ,[a,c]).
SPJ = [a, c] ;
SPJ = [a, d] ;
SPJ = [b, c] ;
SPJ = [b, d] ;
No
?- condition_of_equilibrium_in_beliefs_2_0([[[[c]],[[f]]],[[[c]],[[f]]]],SPJ,[[c],[c]]).
SPJ = [[[c]], [[c]]]
Yes
?-
*/
%%%%%%%%%%%
% N=3 %
%%%%%%%%%%%
% Nash equilibrium under uncertainty for three players games.
% no warripng version
%---------------------------------------------
% a developmental version. 23--24 Feb 2004.
equilibrium_in_beliefs_3([P1,P2,P3],S,SP,R,Y):-
R=[R1,R2,R3],
Y=[Y1,Y2,Y3],
temp_ceu_max_play(1,P1,S1,R1),
temp_ceu_max_play(2,P2,S2,R2),
temp_ceu_max_play(3,P3,S3,R3),
S=[S1,S2,S3],
%Y=[yes,yes,yes],
%condition_of_equilibrium_in_beliefs_3_0(S,SP,R).
SP=[SP1,SP2,SP3],
condition_of_equilibrium_in_beliefs_3(1,S1,SP1,R,Y1),
condition_of_equilibrium_in_beliefs_3(2,S2,SP2,R,Y2),
condition_of_equilibrium_in_beliefs_3(3,S3,SP3,R,Y3).
% museum for the developmental stages inductively.
% prototyping for the equilibrium condition.
condition_of_equilibrium_in_beliefs_3_0([S1,S2,S3],[SP1,SP2,SP3],[R1,R2,R3]):-
member(SP1,S1),
forall(
member(X,SP1),
product_of_lists([R2,R3],X)
),
member(SP2,S2),
forall(
member(X,SP2),
product_of_lists([R1,R3],X)
),
member(SP3,S3),
forall(
member(X,SP3),
product_of_lists([R1,R2],X)
).
% induced version.
condition_of_equilibrium_in_beliefs_3(J,SJ,SPJ,R,Y):-
list_projection(PJT,[1,2,3],[J]),
c_list_projection(PJT,R,R_other_than_J),
member(SPJ,SJ), % SPJ, a support of player J.
condition_of_equilibrium_in_beliefs_3_rule(SPJ,R_other_than_J,Y).
condition_of_equilibrium_in_beliefs_3_rule(SPJ,R_other_than_J,yes):-
forall(
member(X,SPJ),
product_of_lists(R_other_than_J,X)
),
!.
condition_of_equilibrium_in_beliefs_3_rule(_,_,no).
% (set function based) wrapped versions.
%------------------------------------------------
% added: 1 Mar 2004.
% first level wrapping.
equilibria_in_beliefs_3_level_1([P1,P2,P3],S,SP,R,Y):-
R=[R1,R2,R3],
Y=[Y1,Y2,Y3],
setof(BP1,temp_ceu_max_play(1,BP1,S1,R1),P1),
setof(BP2,temp_ceu_max_play(2,BP2,S2,R2),P2),
setof(BP3,temp_ceu_max_play(3,BP3,S3,R3),P3),
S=[S1,S2,S3],
%Y=[yes,yes,yes],
%condition_of_equilibrium_in_beliefs_3_0(S,SP,R).
SP=[SP1,SP2,SP3],
condition_of_equilibrium_in_beliefs_3(1,S1,SP1,R,Y1),
condition_of_equilibrium_in_beliefs_3(2,S2,SP2,R,Y2),
condition_of_equilibrium_in_beliefs_3(3,S3,SP3,R,Y3).
% second level wrapping.
equilibria_in_beliefs_3([P1,P2,P3],R,Y):-
R=[R1,R2,R3],
Y=[yes,yes,yes],
setof((BP1,SB1),temp_ceu_max_play(1,BP1,SB1,R1),Q1),
setof((BP2,SB2),temp_ceu_max_play(2,BP2,SB2,R2),Q2),
setof((BP3,SB3),temp_ceu_max_play(3,BP3,SB3,R3),Q3),
%S=[S1,S2,S3],
%condition_of_equilibrium_in_beliefs_3_0(S,SP,R).
%SP=[SP1,SP2,SP3],
setof((BP1,S1,SP1),
(
member((BP1,S1),Q1),
condition_of_equilibrium_in_beliefs_3(1,S1,SP1,R,yes)
),
P1),
setof((BP2,S2,SP2),
(
member((BP2,S2),Q2),
condition_of_equilibrium_in_beliefs_3(2,S2,SP2,R,yes)
),
P2),
setof((BP3,S3,SP3),
(
member((BP3,S3),Q3),
condition_of_equilibrium_in_beliefs_3(3,S3,SP3,R,yes)
),
P3).
/*
% added: 24 Feb 2004. test programs.
tell_goal(
'beleq_test_supp.txt',
forall,
test_lo32_beleq([Q1,Q2,Q3],R)
).
test_lo32_beleq([Q1,Q2,Q3],R):-
equilibria_in_beliefs_3([P1,P2,P3],R,[yes,yes,yes]),
findall(S1,member((_,_,S1),P1),Q01),sort(Q01,Q1),
findall(S1,member((_,_,S1),P2),Q02),sort(Q02,Q2),
findall(S1,member((_,_,S1),P3),Q03),sort(Q03,Q3).
watch_beleq_3:-
Goal=equilibria_in_beliefs_3(_,_,_,_,[yes,yes,yes]),
stopwatch_of_iterated_goals(Goal,100,yes).
*/
%%%%%% demo %%%%%%%%%%
% N=2 cases.
/*
% battle
%---------
?- generate_equilibrium_in_beliefs([P2,P1],[Supp2,Supp1],[R1,R2]).
P2 = [[[[c], [f]], 1]]
P1 = [[[[c], [f]], 1]]
Supp2 = [[c]]
Supp1 = [[c]]
R1 = [c]
R2 = [c]
Yes
?- equilibrium_in_beliefs([P2,P1],[Supp2,Supp1],[[f],[f]]).
No
?- equilibrium_in_beliefs([P2,P1],[Supp2,Supp1],[[c],[f]]).
P2 = [[[[c], [f]], 1]]
P1 = [[[[c]], 0.55], [[[c], [f]], 0.45]]
Supp2 = [[f]]
Supp1 = [[c]]
Yes
?- equilibrium_in_beliefs([P2,P1],[Supp2,Supp1],[[f],[c]]).
P2 = [[[[c]], 0.55], [[[c], [f]], 0.45]]
P1 = [[[[c], [f]], 1]]
Supp2 = [[c]]
Supp1 = [[f]]
Yes
?- equilibrium_in_beliefs([P2,P1],[Supp2,Supp1],[[c,f],[c,f]]).
P2 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
P1 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
Supp2 = [[c]]
Supp1 = [[c]] ;
P2 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
P1 = [[[[f]], 0.05], [[[c]], 0.5], [[[c], [f]], 0.45]]
Supp2 = [[c]]
Supp1 = [[c], [f]]
Yes
?- equilibrium_in_beliefs([P1,P2],[Supp1,Supp2],[[c,f],[c,f]]),
\+ member([[[c]],0.5],P1).
No
?- equilibrium_in_beliefs([P1,P2],[Supp1,Supp2],[[c,f],[c,f]]),
\+ member([[[c]],0.5],P2).
No
?- equilibrium_in_beliefs([P1,P2],[S1,S2],[[c,f],[c,f]]),
\+ (S1=[[c],[f]]), \+ (S2=[[c],[f]]).
P1 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
P2 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
S1 = [[c]]
S2 = [[c]] ;
No
?- equilibrium_in_beliefs([P2,P1],[Supp2,Supp1],[[c,f],[c]]).
P2 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
P1 = [[[[c], [f]], 1]]
Supp2 = [[c]]
Supp1 = [[c]] ;
P2 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
P1 = [[[[c], [f]], 1]]
Supp2 = [[c]]
Supp1 = [[f]] ;
P2 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
P1 = [[[[c]], 0.05], [[[c], [f]], 0.95]]
Supp2 = [[c]]
Supp1 = [[c]]
Yes
?- equilibrium_in_beliefs([P2,P1],[Supp2,Supp1],[[c],[c,f]]).
P2 = [[[[c], [f]], 1]]
P1 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
Supp2 = [[c]]
Supp1 = [[c]] ;
P2 = [[[[c], [f]], 1]]
P1 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
Supp2 = [[f]]
Supp1 = [[c]] ;
P2 = [[[[c]], 0.05], [[[c], [f]], 0.95]]
P1 = [[[[c]], 0.5], [[[c], [f]], 0.5]]
Supp2 = [[c]]
Supp1 = [[c]]
Yes
?- equilibrium_in_beliefs([P2,P1],[Supp2,Supp1],[[f],[c,f]]).
No
?- max(P,
(equilibrium_in_beliefs([P1,P2],[S1,S2],[R,R]),R=[c],member([[[c]],P],P1))
).
P = 0.45
P1 = [[[[c]], 0.45], [[[c], [f]], 0.55]]
P2 = [[[[c]], 0.05], [[[c], [f]], 0.95]]
S1 = [[c]]
S2 = [[c]]
R = [c]
Yes
?- max(P,
(equilibrium_in_beliefs([P1,P2],[S1,S2],[R,R]),R=[c],member([[[c]],Q],P1),
P is -Q)).
P = -0.05
P1 = [[[[c]], 0.05], [[[c], [f]], 0.95]]
P2 = [[[[c]], 0.05], [[[c], [f]], 0.95]]
S1 = [[c]]
S2 = [[c]]
R = [c]
Q = 0.05
Yes
?- findall(S,
| (equilibrium_in_beliefs(P,S,[R,R]),R=[c]),W),sort(W,W1).
S = _G167
P = _G166
R = _G160
W = [[[[c]], [[c]]], [[[c]], [[c]]], [[[c]], [[c]]], [[[c]], [[c]]], [[[c]], [[c]]], [[[c]], [[...]]], [[[...]], [...]], [[...]|...], [...|...]|...]
W1 = [[[[c]], [[c]]]]
Yes
?- findall(S,
(equilibrium_in_beliefs(P,S,[[f],[c]])),W),sort(W,W1).
S = _G173
P = _G172
W = [[[[c]], [[f]]], [[[c]], [[f]]], [[[c]], [[f]]], [[[c]], [[f]]], [[[c]], [[f]]], [[[c]], [[...]]], [[[...]], [...]], [[...]|...], [...|...]|...]
W1 = [[[[c]], [[f]]]]
Yes
?- findall(S,
(equilibrium_in_beliefs(P,S,[[c],[f]])),W),sort(W,W1).
S = _G173
P = _G172
W = [[[[f]], [[c]]], [[[f]], [[c]]], [[[f]], [[c]]], [[[f]], [[c]]], [[[f]], [[c]]], [[[f]], [[...]]], [[[...]], [...]], [[...]|...], [...|...]|...]
W1 = [[[[f]], [[c]]]]
Yes
?- findall(S,
(equilibrium_in_beliefs(P,S,[[c,f],[c,f]])),W),sort(W,W1).
S = _G179
P = _G178
W = [[[[c]], [[c]]], [[[c]], [[c], [f]]], [[[c]], [[c], [f]]], [[[c]], [[c], [f]]], [[[c]], [[c], [...]]], [[[c]], [[...]|...]], [[[...]], [...|...]], [[...]|...], [...|...]|...]
W1 = [[[[c]], [[c]]], [[[c]], [[c], [f]]], [[[c], [f]], [[c]]], [[[c], [f]], [[c], [f]]]]
Yes
?- max(P,
(equilibrium_in_beliefs([P1,P2],[S1,S2],[[c],[f]]),member([[[f]],Q],P2),
P is Q)).
No
?- max(P,
(equilibrium_in_beliefs([P1,P2],[S1,S2],[[c],[f]]),member([[[c]],Q],P2),
P is -Q)).
P = -0.55
P1 = [[[[c], [f]], 1]]
P2 = [[[[c]], 0.55], [[[c], [f]], 0.45]]
S1 = [[f]]
S2 = [[c]]
Q = 0.55
Yes
?- max(P,
(equilibrium_in_beliefs([P1,P2],[S1,S2],[[c],[f]]),member([[[c]],Q],P2),
P is Q)).
P = 1
P1 = [[[[c], [f]], 1]]
P2 = [[[[c]], 1]]
S1 = [[f]]
S2 = [[c]]
Q = 1
Yes
?-
*/
% An extension :
% use confidence / ambiguity indeces as equilibria filters.
%------------------------------------------------------
% modified: 15--16 Feb 2004.
% modified: 21 Feb 2004. renamed temp_equilibrium_in_beliefs->equilibrium_in_beliefs
% modified: 28 Feb-- 3 Mar 2004. set function version.
% modified: 6 Mar N=3 version of equilibria_in_beliefs_extended.
% no wrapping version.
equilibrium_in_beliefs_extended([P1,P2],S,R,DC,DA):-
equilibrium_in_beliefs([P1,P2],S,R),
temp_extended_test_of_beliefs(bpa:P1,[confidence:DC1,ambiguity:DA1]),
temp_extended_test_of_beliefs(bpa:P2,[confidence:DC2,ambiguity:DA2]),
DC = [DC1,DC2],
DA = [DA1,DA2].
equilibrium_in_beliefs_extended([P1,P2,P3],S,R,DC,DA):-
equilibrium_in_beliefs([P1,P2,P3],S,R),
temp_extended_test_of_beliefs(bpa:P1,[confidence:DC1,ambiguity:DA1]),
temp_extended_test_of_beliefs(bpa:P2,[confidence:DC2,ambiguity:DA2]),
temp_extended_test_of_beliefs(bpa:P3,[confidence:DC3,ambiguity:DA3]),
DC = [DC1,DC2,DC3],
DA = [DA1,DA2,DA3].
% first order wrapping.
collect_indices_of_beliefs(P1,DC1,DA1):-
findall((C,A),
(
member(BP1,P1),
temp_extended_test_of_beliefs(bpa:BP1,[confidence:C,ambiguity:A])
),
SCA),
setof(C,A^member((C,A),SCA),DC1),
setof(A,C^member((C,A),SCA),DA1).
%----------------------------------------------------------
% equilibria with aggregated intervals of indices that
% (1) has adapted to the wrapping level 1 or
% (2) has adapted to the wrapping level 2.
%----------------------------------------------------------
% modified: 7 Mar 2004.
equilibria_in_beliefs_extended([P1,P2],[SP1,SP2],R,RC,RA):-
% (1) equilibria_in_beliefs_2([P1,P2],_S,[SP1,SP2],R,[yes,yes]),
% (2)
equilibria_in_beliefs_2([B1,B2],R,[yes,yes]),
setof(P,S^SP^member((P,S,SP),B1),P1),
setof(P,S^SP^member((P,S,SP),B2),P2),
setof(SP,P^S^member((P,S,SP),B1),SP1),
setof(SP,P^S^member((P,S,SP),B2),SP2),
collect_indices_of_beliefs(P1,C1,A1),
collect_indices_of_beliefs(P2,C2,A2),
range_of(RC1,C1),
range_of(RA1,A1),
range_of(RC2,C2),
range_of(RA2,A2),
RC=[RC1,RC2],
RA=[RA1,RA2].
equilibria_in_beliefs_extended([P1,P2,P3],SP,R,RC,RA):-
% (1) equilibria_in_beliefs_3([P1,P2,P3],_S,SP,R,[yes,yes,yes]),
% (2)
equilibria_in_beliefs_3([B1,B2,B3],R,[yes,yes,yes]),
setof(Px,Sx^SPx^member((Px,Sx,SPx),B1),P1),
setof(Px,Sx^SPx^member((Px,Sx,SPx),B2),P2),
setof(Px,Sx^SPx^member((Px,Sx,SPx),B3),P3),
SP=[SP1,SP2,SP3],
setof(SPx,Sx^Px^member((Px,Sx,SPx),B1),SP1),
setof(SPx,Sx^Px^member((Px,Sx,SPx),B2),SP2),
setof(SPx,Sx^Px^member((Px,Sx,SPx),B3),SP3),
collect_indices_of_beliefs(P1,C1,A1),
collect_indices_of_beliefs(P2,C2,A2),
collect_indices_of_beliefs(P3,C3,A3),
range_of(RC1,C1),
range_of(RA1,A1),
range_of(RC2,C2),
range_of(RA2,A2),
range_of(RC3,C3),
range_of(RA3,A3),
RC=[RC1,RC2,RC3],
RA=[RA1,RA2,RA3].
% equilibria in beliefs filtered by the indices
%----------------------------------------------------------
% modified: 2 Feb 2004. set function.
equilibria_in_beliefs_filtered_by_indices(P,S,R,C,A,Y):-
fail_if_no_equilibria_in_beliefs_extended,
temp_filter_for_beleq(confidence,[CL,CU]),
temp_filter_for_beleq(ambiguity,[AL,AU]),
equilibria_in_beliefs_extended(P,S,R,C,A),
decide_to_choice_or_not_1([CL,CU,AL,AU],[C,A],Y).
equilibrium_in_beliefs_filtered_by_indices(P,S,R,C,A,Y):-
fail_if_no_equilibrium_in_beliefs_extended,
temp_filter_for_beleq(confidence,[CL,CU]),
temp_filter_for_beleq(ambiguity,[AL,AU]),
equilibrium_in_beliefs_extended(P,S,R,C,A),
decide_to_choice_or_not_0([CL,CU,AL,AU],[C,A],Y).
decide_to_choice_or_not_1([CL,CU,AL,AU],[C,A],Y):-
forall(
(
member((Index,Ds),[(c,C),(a,A)]), % select a index
member((Index,[FL,FU]),[(c,[CL,CU]),(a,[AL,AU])]), % select a filter
member(D,Ds), % for the interval of the index of each player
D=[L,U]
),
\+ (
U < FL ; L > FU
)
),
!,
Y=yes.
decide_to_choice_or_not_1(_,_,no).
decide_to_choice_or_not_0([CL,CU,AL,AU],[C,A],Y):-
forall(
(
member((Index,Ds),[(c,C),(a,A)]), % select a index
member((Index,H),[(c,[CL,CU]),(a,[AL,AU])]), % select a filter
member(D,Ds) % for the index of each player
),
member_of_interval(D,H)
),
!,
Y=yes.
decide_to_choice_or_not_0(_,_,no).
fail_if_no_equilibria_in_beliefs_extended:-
clause(equilibria_in_beliefs_extended(_,_,_,_,_),_),
!.
fail_if_no_equilibria_in_beliefs_extended:-
nl,
write(' There is no equilibria_in_beliefs_extended.'),
fail.
fail_if_no_equilibrium_in_beliefs_extended:-
clause(equilibrium_in_beliefs_extended(_,_,_,_,_),_),
!.
fail_if_no_equilibrium_in_beliefs_extended:-
nl,
write(' There is no equilibrium_in_beliefs_extended.'),
fail.
member_of_interval(X,[Lower,Upper]):-
number(X),
number(Lower),
number(Upper),
X =< Upper,
X >= Lower.
% set interval of indices as filters for the test.
%------------------------------------------------------
:- dynamic temp_filter_for_beleq/2.
temp_filter_for_beleq(confidence,[0,1]).
temp_filter_for_beleq(ambiguity,[0,1]).
default_filter_beleq(confidence,[0,1]).
default_filter_beleq(ambiguity,[0,1]).
init_filter_for_beleq:-
abolish(temp_filter_for_beleq/2),
default_filter_beleq(ambiguity,X),
default_filter_beleq(confidence,Y),
assert(temp_filter_for_beleq(confidence,X)),
assert(temp_filter_for_beleq(ambiguity,Y)).
update_filter_of_beleq(D,Z):-
%conform_user_about_filter(yes),
member(D,[confidence,ambiguity]),
(
var(Z)
->(nl,write((D,'input the interval as [lower, upper]:')),read(Z))
;true
),
rule_of_update_filter_of_beleq(Z,[X,Y]),
retractall(temp_filter_for_beleq(D,_)),
assert(temp_filter_for_beleq(D,[X,Y])).
rule_of_update_filter_of_beleq(Z,[0,1]):-
var(Z).
rule_of_update_filter_of_beleq(Z,[X,Y]):-
Z = [X,Y],
number(X), X=<1, X >=0,
number(Y), Y=<1, Y >=X.
conform_user_about_filter(_):-
\+ clause(temp_filter_for_beleq(_,_),true),
init_filter_for_beleq,
fail.
conform_user_about_filter(Y):-
clause(temp_filter_for_beleq(_,_),true),
display_filters,
nl,write('Abolish these intervals ? (y) '),
(read(y)->Y=yes ; Y= no).
display_filters:-
nl,write('filters on belief indices:'),
forall(
temp_filter_for_beleq(A,B),
(nl,tab(1),write(A:B))
).
%%%%%% demo %%%%%%%%%%
/*
% klibanoff
%---------
?- equilibrium_in_beliefs_extended(BPA,SUP,BR,Confs,Ambs).
BPA = [[[[[c], [f]], 1]], [[[[c], [f]], 1]]]
SUP = [[[f]], [[f]]]
BR = [[f], [f]]
Confs = [0, 0]
Ambs = [1, 1] ;
BPA = [[[[[c], [f]], 1]], [[[[f]], 0.05], [[[c], [f]], 0.95]]]
SUP = [[[f]], [[f]]]
BR = [[f], [f]]
Confs = [0, 0.05]
Ambs = [1, 0.95]
Yes
?-
*/
%---------------------------------------------------------------
% A developmental test code for 3 players case : example (lo32)
%---------------------------------------------------------------
% added: 20 Feb 2004.
% a test for example 10 (lo32).
% cf., example 2 in Lo(1996), pp.451--452.
test_ex10:-
update_bpa_precision(_,2),
generate_equilibrium_in_beliefs_0,
equilibrium_in_beliefs_3_f_0(P,SP,R,[yes,yes,yes]),
nl,write(beliefs),
forall(member(P1,P),(nl,write(P1))),
nl,write(supports),
forall(member(P1,SP),(nl,write(P1))),
nl,write(acts),
forall(member(P1,R),(nl,write(P1))),
nl,write('next? >'),
(read(y)->fail;true).
filtered_temp_ceu_max_play(1,P1,S,R):-
temp_ceu_max_play(1,P1,S,R),
member([[[u,r]], 0.5],P1),
member([[[d,l]], 0.5],P1).
filtered_temp_ceu_max_play(2,P2,S,R):-
temp_ceu_max_play(2,P2,S,R),
member([[[t,r]], 0.5],P2),
member([[[t,l]], 0.5],P2).
filtered_temp_ceu_max_play(3,P3,S,R):-
temp_ceu_max_play(3,P3,S,R),
member([[[t,u]], 0.5],P3),
member([[[t,d]], 0.5],P3).
equilibrium_in_beliefs_3_f_0([P1,P2,P3],SP,R,Y):-
SP=[SP1,SP2,SP3],
Y=[Y1,Y2,Y3],
filtered_temp_ceu_max_play(1,P1,S1,R1),
filtered_temp_ceu_max_play(2,P2,S2,R2),
filtered_temp_ceu_max_play(3,P3,S3,R3),
R=[R1,R2,R3],
condition_of_equilibrium_in_beliefs_3(1,S1,SP1,R,Y1),
condition_of_equilibrium_in_beliefs_3(2,S2,SP2,R,Y2),
condition_of_equilibrium_in_beliefs_3(3,S3,SP3,R,Y3).
%S=[S1,S2,S3],
%(condition_of_equilibrium_in_beliefs_3_0(S,SP,R)->Y0=yes;Y0=no).
%%%%%% demo %%%%%%%%%%
% demo for example 10.
% note: Since this beliefs are additive, the tuple consistutes
% a Nash equilibrium nevertheless.
/*
?- test_ex10.
beliefs
[[[[u, r]], 0.5], [[[d, l]], 0.5]]
[[[[t, r]], 0.5], [[[t, l]], 0.5]]
[[[[t, u]], 0.5], [[[t, d]], 0.5]]
supports
[[d, l], [u, r]]
[[t, l], [t, r]]
[[t, d], [t, u]]
acts
[t]
[d, u]
[l, r]
next? >y.
No
?- test_ceu(P1,[L,[S1,S2,S3,S4],U,B,CEU],R1).
P1 = t
L = 4
S1 = [[d, r]]
S2 = [[u, l]]
S3 = [[u, r]]
S4 = [[d, l]]
U = [-10, 1, 2, 4]
B = [1, 1, 1, 0]
CEU = [-10* (1-1), 1* (1-1), 2* (1-0), 4*0]
R1 = 2 ;
No
?-
*/
%------------------------------------------------------
% Co-generation of beliefs and Choquet rational plays
%------------------------------------------------------
% modified: 16 Feb 2004.
% added a cut and delegated to display generated beleqs.
% modified: 21 Feb 2004.
% inserted init_gen_bpa/0 in generate_equilibrium_in_beliefs_0/0 and
% replaced test_gen_bpa/5 by test_gen_bpa_1/5 in gen_ceu_max_play/4
% in order to correct the timing of abolishment of players` beliefs.
generate_equilibrium_in_beliefs([P1,P2],[Supp1,Supp2],[R1,R2]):-
generate_equilibrium_in_beliefs_0,
successful_message,
equilibrium_in_beliefs([P1,P2],[Supp1,Supp2],[R1,R2]),
!.
generate_equilibrium_in_beliefs_0:-
apology,
init_gen_bpa,
abolish(temp_ceu_max_play/4),
forall(
gen_ceu_max_play(PLAYER,BPA,SUPPs,BestResponses),
assert(
temp_ceu_max_play(PLAYER,BPA,SUPPs,BestResponses)
)
).
% modified: 7 Mar 2004. added restricted event for bpa generation.
% modified: 12 Mar 2004. used intersection/3 for the restricted event.
gen_ceu_max_play(J,P,A,R):-
set_payoffs(J),
states(S),
restriction_for_generating_beliefs(_Y,S,E),
test_gen_bpa_1(set:E,bpa:P,supp:A,br:R,noconform).
restriction_for_generating_beliefs(yes,S,E):-
clause(restriction_for_generating_beliefs0(X),true),
event(X),
intersection(S,X,E1),
sort_by_list(E1,S,E),
!.
% default rule : no restricted states.
restriction_for_generating_beliefs(no,S,S).
successful_message:-
nl,write('All equilibria in beliefs are generated successfully. '),
nl,write('Now you can use equilibrium_in_beliefs/3 in order '),
nl,write('to display those results other than the following one. ').
%----------------------------------------------
% gen_beleq/0 :
% user interface with multiple choice menu
%----------------------------------------------
% added: 16 Feb 2004.
% modified: 17--20 Feb 2004. modeled N=2 case only.
% modified: 21 Feb 2004. extended for N=3 and
% bugfix regarding test_gen_bpa and suggestion rule.
%
gen_beleq:-
generate_equilibrium_in_beliefs_0,
nl,write('Conguratulation. The set of equilibria in beliefs have generated. '),
menu_for_gen_beleq.
menu_for_gen_beleq:-
nl,write('1: (display_beleq/0), To go through results simply, '),
nl,write('2: (display_beleq_f/0), Using confidence/ambiguity measure as filter, '),
nl,write('3: (test_range_of_beleq/0) possibly afterward filter set by 2 or '),
nl,write('4: (test_range_of_beleq_using_filter/0), '),
nl,write('5: (save_data_of_beleq/0) to save the results to a file, '),
nl,write(' To make equlibria up and do further analysis, if you wish. '),
nl,write('0: to exit. '),
nl,write('select no. > '),
conform_user_selected_service(N,
[
0:true,
1:display_beleq,
2:display_beleq_f,
3:test_range_of_beleq,
4:test_range_of_beleq_using_filter,
5:save_data_of_beleq
]
),
(N=0->true;menu_for_gen_beleq).
% simple display of equilibria
%----------------------------------------------
% modified: 21 Feb 2004.
display_beleq:-
display_beleq_0,
nl,write('Search another equilibrium? (y) '),
(read(y)->fail;true).
display_beleq_0:-
equilibrium_in_beliefs_extended(P,S,R,C,A),
write_format_for_display_beleq(P,S,R,C,A).
display_beleq_0:-
nl,
write('complete'),
nl.
% old version.
write_format_for_display_beleq_2([P1,P2],[S1,S2],[R1,R2],[DC1,DC2],[DA1,DA2]):-
nl,write(('P1: beliefs (bpa) of player 1',P1)),
nl,write(('P2: beliefs (bpa) of player 2',P2)),
nl,write(' confidence/ambiguity of P1':DC1/DA1),
nl,write(' confidence/ambiguity of P2':DC2/DA2),
nl,write(' support of P1':S1),
nl,write(' support of P2':S2),
nl,write((' best responses of player 1 under P1',R1)),
nl,write((' best responses of player 2 under P2',R2)).
% modified: 21 Feb 2004.
write_format_for_display_beleq(P,S,R,DC,DA):-
forall(
format_for_display_beleq(beliefs,[J,P],O),
nl_write_forall_members(O)
),
forall(
format_for_display_beleq(indices,[J,DC,DA],O),
nl_write_forall_members(O)
),
forall(
format_for_display_beleq(supports,[J,S],O),
nl_write_forall_members(O)
),
forall(
format_for_display_beleq(acts,[J,R],O),
nl_write_forall_members(O)
).
format_for_display_beleq(beliefs,[J,P],O):-
nth1(J,P,PJ),
O=['P',J,': beliefs (bpa) of player ',J,PJ].
format_for_display_beleq(indices,[J,DC,DA],O):-
nth1(J,DC,DCJ),
nth1(J,DA,DAJ),
O=[' confidence/ambiguity of P',J,':',(DCJ/DAJ)].
format_for_display_beleq(supports,[J,S],O):-
nth1(J,S,SJ),
O=[' support of P',J,': ',SJ].
format_for_display_beleq(acts,J,[A],O):-
nth1(J,A,AJ),
O=[' best responses of player ',J,' under P',J, ': ',AJ].
nl_write_forall_members(O):-
nl,
forall(member(X,O),write(X)).
% display of equilibria with filter
%----------------------------------------------
% modified: 22 Feb 2004.
% modified: 2 Mar 2004. set function.
display_beleq_f:-
display_beleq_f_0,
nl,write('Search another equilibrium? (y) '),
(read(y)->fail;true).
display_beleq_f_0:-
%nl,write(' set filter ? (y) >'),
%read(y),
update_filter_of_beleq(confidence,H1),
update_filter_of_beleq(ambiguity,H2),
suggest_if_restrictedless([H1,H2],Y),
(Y=y-> fail;display_beleq_f_0).
display_beleq_f_0:-
equilibrium_in_beliefs_filtered_by_indices(P,S,R,C,A,yes),
write_format_for_display_beleq(P,S,R,C,A).
display_beleq_f_0:-
nl,
write('complete'),
nl.
suggest_if_restrictedless([[L1,U1],[L2,U2]],Y):-
1 is U1-L1,
1 is U2-L2,
nl,write(' I worried about that it makes you bored or idle.'),
nl,write(' Are you sure ? (y) ' ),
read(Y).
% bugfix: 21 Feb 2004. inequality.
suggest_if_restrictedless([[L1,U1],[L2,U2]],Y):-
0.25 < (U1-L1)*(U2-L2),
nl,write(' You`d better make the intervals narrower, I think.'),
nl,write(' Are you sure ? (y) ' ),
read(Y).
% multiple choice
%----------------------------------------------
conform_user_selected_service(N,JOBs):-
read(N),
\+ var(N),
member(N:DO,JOBs),
!,
DO.
conform_user_selected_service(_,_):-
nl,
write('it is not a possible choice.').
%--------------------------------------------------------
% Reporting Tools:
% Ex Post Analytical Processes after equilibria in beliefs Generated
%--------------------------------------------------------
% added: 14 Feb 2004.
% modified: 15--16 Feb 2004. ebnabled filter by confidence/ambiguity.
% modified: 24 Feb 2004. faster equilibrium generation by using setof as constraint processing.
% modified: 28 Feb 2004. rectangles decomposition for 2-dimensional bpas.
% modified: 8 Feb 2004. two decomposition programs has moved into the part of mathematical tools.
:- dynamic temp_found_beleq/1.
:- dynamic temp_range_of_beleq/1.
% intervals_decomposition/5: moved into the part of mathematics.
% rectangles_decomposition/: moved into the part of mathematics.
% summarize intervals of beliefs equilibria.
%--------------------------------------------------
% modified: 28 Feb 2004.
% modified: 3 Mar 2004.
test_range_of_beleq_using_filter:-
update_filter_of_beleq(confidence,_),
update_filter_of_beleq(ambiguity,_),
test_range_of_beleq.
test_range_of_beleq_using_filter(D,Z):-
update_filter_of_beleq(D,Z),
test_range_of_beleq.
test_range_of_beleq:-
test_range_of_equilibria_in_beliefs(1),
test_range_of_equilibria_in_beliefs(2),
test_range_of_equilibria_in_beliefs(3).
test_range_of_equilibria_in_beliefs(1):-
abolish(temp_found_beleq/1),
abolish(temp_range_of_beleq/1),
findall([P,S,R,C,A],
(
equilibria_in_beliefs_filtered_by_indices(P,S,R,C,A,yes)
),
W),
sort(W,W1),
forall(member(X,W1),
assert(temp_found_beleq(X))
).
test_range_of_equilibria_in_beliefs(2):-
clause(temp_found_beleq(_),_),
\+ clause(temp_range_of_beleq(_),_),
bpa_precision(FF),
FX is 1/FF,
forall(
collect_eventwise_bpa_from_beleqs(R,S,J,E,Z),
(
intervals_decomposition(FX,H,Z,_,_),
assert(
temp_range_of_beleq([R,S,J,E,H])
)
)
).
% the second level multiple choice to be called from gen_beleq.
test_range_of_equilibria_in_beliefs(3):-
nl,
write(' Done. Do you skim through the results ? '),
nl,write(0:' no display '),
nl,write(1:' glance over simply (display_ranges_of_beleq/0) '),
nl,write(2:' furthur look using filter (display_ranges_of_beleq_with_indices/0) '),
nl,write(3:' save data to file (save_data_of_beleq_ranges/0) '),
nl,
conform_user_selected_service(_N,
[
0:true,
1:display_ranges_of_beleq,
2:display_ranges_of_beleq_with_indices,
3:save_data_of_beleq_ranges
]
).
% bpa intervals given a equilibrium in beliefs.
%------------------------------------------------------
% modified: 28 Feb 2004. modified from collect_eventwise_bpa_from_a_beleq/5.
% modified: 1--3 Mar 2004.
% modified: 5 Mar 2004. bugfix. zero bpa cases.
% modified: 6--7 Mar 2004. packed equilibria version.
collect_eventwise_bpa_from_beleqs(R,S,J,Event,Z):-
sevent(Event),
setof(Q,
C^A^P^PJ^BPA^(
%equilibria_in_beliefs(P,S,R),
temp_found_beleq([P,S,R,C,A]),
nth1(J,P,PJ),
member(BPA,PJ),
(member([Event,Q],BPA)->true;(Q is 0))
),
Z).
% debug: 5 Mar 2004.
/*
?- Bpas=[[[[[c],[f]],1]],[[[[c],[f]],1]]],
equilibrium_in_beliefs(Bpas,S,R),,1]]],
temp_range_of_beleq([R,S,J,E,Values]).
Bpas = [[[[[c], [f]], 1]], [[[[c], [f]], 1]]]
S = [[[c]], [[c]]]
R = [[c], [c]]
J = 1
E = [[c]]
Values = [[0.05, 0.45]] ;
Bpas = [[[[[c], [f]], 1]], [[[[c], [f]], 1]]]
S = [[[c]], [[c]]]
R = [[c], [c]]
J = 2
E = [[c]]
Values = [[0.05, 0.45]] ;
Bpas = [[[[[c], [f]], 1]], [[[[c], [f]], 1]]]
S = [[[c]], [[c]]]
R = [[c], [c]]
J = 1
E = [[c], [f]]
Values = [[0.55, 1]] ;
Bpas = [[[[[c], [f]], 1]], [[[[c], [f]], 1]]]
S = [[[c]], [[c]]]
R = [[c], [c]]
J = 2
E = [[c], [f]]
Values = [[0.55, 1]] ;
No
?-
*/
% bpa intervals given a equilibrium in beliefs.
% : old no wrapping versions
%------------------------------------------------------
% modified: 21 Feb 2004.
% modified: 5 Mar 2004. bugfix. zero bpa cases.
collect_eventwise_bpa_from_a_beleq(R,S,J,Event,Z):-
sevent(Event),
setof(Q,
C^A^P^PJ^(
temp_found_beleq([P,S,R,C,A]),
nth1(J,P,PJ),
%member([Event,Q],PJ)
(member([Event,Q],PJ)->true;(Q is 0))
),
Z).
collect_eventwise_bpa_from_a_beleq_2_0([R1,R2],[S1,S2],J,Event,Z):-
sevent(Event),
setof(Q,
C^A^P1^P2^PJ^(
temp_found_beleq([[P1,P2],[S1,S2],[R1,R2],C,A]),
member([J,PJ],[[1,P1],[2,P2]]),
%member([Event,Q],PJ)
(member([Event,Q],PJ)->true;(Q is 0))
),
Z).
% results viewer.
%------------------------------------------------------
% display results without indices
% modified: 22 Feb 2004. added a display counter.
% display_counter/0 has moved into the utilities part.
% modified: 2 Mar 2004. separated inquire_ranges_of_beleq/3 for the sake of abstraction.
% modified: 7 Mar 2004. adapted for packaged version of equilibria in beliefs.
% modified: 12 Mar 2004. segregated display program both for supports and bpas.
inquire_ranges_of_beleq(A,S,C):-
setof(X,
(
temp_range_of_beleq([A,S|X]) % X=[J,E,RangeBPA]
),
C).
display_ranges_of_beleq:-
display_ranges_of_beleq(_A,_S),
fail.
display_ranges_of_beleq.
display_ranges_of_beleq(_,_):-
init_count_of_display,
fail.
display_ranges_of_beleq(A,S):-
display_ranges_of_beleq(A,S,_C).
display_ranges_of_beleq(A,S,C):-
inquire_ranges_of_beleq(A,S,C),
update_and_display_counter,
nl,write(acts:A),
nl,write('supports:'),
display_all_supports_for_act_profile(A,S),
display_all_bpas_and_their_intervals_for_act_profile(A,C).
display_all_supports_for_act_profile(_,S):-
forall(
(nth1(K,S,SK),member(SKX,SK)),
(nl,write('%'),tab(1),write(player(K):SKX))
).
display_all_bpas_and_their_intervals_for_act_profile(_,C):-
nl,write('equilibrium belief(bpa)s and their intervals:'),
states(W),
forall(
(member(Y,C),Y=[J,E,RB],E\=W,E\=[],RB\=[[0,0]]),
(nl,write('%'),tab(1),write(player(J):E:RB))
).
% display with indices as equilibrium filter
%-------------------------------------------------
% modified: 2 Mar 2004. bugfix.
% modified: 7 Mar 2004. adapted for the packaged version.
display_ranges_of_beleq_with_indices:-
forall(display_ranges_of_beleq_with_indices(_,_),true).
display_ranges_of_beleq_with_indices(_,_):-
init_count_of_display,
fail.
display_ranges_of_beleq_with_indices(A,S):-
%inquire_ranges_of_beleq_with_indices(A,S,RDC,RDA,C),
display_ranges_of_beleq(A,S),
equilibria_in_beliefs_extended(_P,S,A,RDC,RDA),
nl,write('confidences:'),
forall(
(nth1(K,RDC,RDCK)),
(nl,write('%'),tab(1),write(player(K):RDCK))
),
nl,write('ambiguities:'),
forall(
(nth1(K,RDA,RDAK)),
(nl,write('%'),tab(1),write(player(K):RDAK))
).
% verifying equilibria by ranges of the confidence/ambiguity indices.
%----------------------------------------------
% modified: 21 Feb 2004. decomposed from display_ranges_of_beleq_with_indices/2.
% modified: 28 Feb 2004. integrated indices data into temp_range_of_beleq/1.
% modified: 2--3 Mar 2004. continuation of above work and bugfix.
% abolished: 7 Mar 2004.
% this code has become redundant and so abolished because of,
% equilibria_in_beliefs_extended/5, the packaged equilibria version.
inquire_ranges_of_beleq_with_indices(A,S,RDC,RDA,C):-
inquire_ranges_of_beleq(A,S,C),
inquire_beleq_by_indices([A,S],con:RDC,amb:RDA).
inquire_beleq_by_indices([R,SP],con:RC,amb:RA):-
%RC=[rc1:XRC1,rc2:XRC2],
%RA=[ra1:XRA1,ra2:XRA2],
RC=[XRC1,XRC2],
RA=[XRA1,XRA2],
inquire_beleq_by_indices(step(1),[R,SP],RCA),
inquire_beleq_by_indices(step(2),RCA,_,XRC1),
inquire_beleq_by_indices(step(3),RCA,_,XRA1),
inquire_beleq_by_indices(step(4),RCA,_,XRC2),
inquire_beleq_by_indices(step(5),RCA,_,XRA2).
inquire_beleq_by_indices(step(1),[R,SP],RCA):-
setof(
[[RC1,RA1],[RC2,RA2]],
P1^P2^(
equilibria_in_beliefs_extended(
[P1,P2],SP,R,[RC1,RA1],[RC2,RA2]
)
),
RCA).
inquire_beleq_by_indices(step(2),RCA,SRC1,XRC1):-
findall(X,
(
member(X,[L,U]),
member([[[L,U],_RA1],_R2],RCA)
),
SRC1_0),
sort(SRC1_0,SRC1),
range_of(XRC1,SRC1).
inquire_beleq_by_indices(step(3),RCA,SRA1,XRA1):-
findall(X,
(
member(X,[L,U]),
member([[_RC1,[L,U]],_R2],RCA)
),
SRA1_0),
sort(SRA1_0,SRA1),
range_of(XRA1,SRA1).
inquire_beleq_by_indices(step(4),RCA,SRC2,XRC2):-
findall(X,
(
member(X,[L,U]),
member([_R1,[[L,U],_RA2]],RCA)
),
SRC2_0),
sort(SRC2_0,SRC2),
range_of(XRC2,SRC2).
inquire_beleq_by_indices(step(5),RCA,SRA2,XRA2):-
findall(X,
(
member(X,[L,U]),
member([_R1,[_RC2,[L,U]]],RCA)
),
SRA2_0),
sort(SRA2_0,SRA2),
range_of(XRA2,SRA2).
% old version.
inquire_beleq_by_indices_old([A,S],con:RC,amb:RA):-
RC=[[Lc1,Uc1],[Lc2,Uc2]],
RA=[[La1,Ua1],[La2,Ua2]],
inquire_range_of_indices(confidence,[1,A,S],[Lc1,Uc1]),
inquire_range_of_indices(confidence,[2,A,S],[Lc2,Uc2]),
inquire_range_of_indices(ambiguity,[1,A,S],[La1,Ua1]),
inquire_range_of_indices(ambiguity,[2,A,S],[La2,Ua2]).
inquire_range_of_indices_old(confidence,[J,A,S],[Lower,Upper]):-
setof(DC,
P^DCL^DAL^(
equilibrium_in_beliefs_extended(P,S,A,DCL,DAL),
nth1(J,DCL,DC)
),
Z),
length(Z,N),
nth1(1,Z,Lower),
nth1(N,Z,Upper).
inquire_range_of_indices_old(ambiguity,[J,A,S],[Lower,Upper]):-
setof(DA,
P^DCL^DAL^(
equilibrium_in_beliefs_extended(P,S,A,DCL,DAL),
nth1(J,DAL,DA)
),
Z),
length(Z,N),
nth1(1,Z,Lower),
nth1(N,Z,Upper).
%----------------------------------------------
% output equilibria data to a file
%----------------------------------------------
% added: 21 Feb 2004.
% modified: 6 Mar 2004. bugfix. case of new file.
% modified: 7--8 Mar 2004. both wrapped equilibria and temp_ceu_max_plays to be saved.
save_data_of_beleq:-
save_ceu_max_plays,
save_equilibria_analysis.
save_ceu_max_plays:-
File='ceu_max.pl',
nl,write(' saving temp_ceu_max_play/4s,'),
write(' the experimental data, to a file... '), nl,
write(' namely '),write(File),
caution_if_file_exists(File,Backup),
tell_goal(File,forall,
(
temp_ceu_max_play(_,_,_,_)
)
),
ending_message(File,Backup).
save_equilibria_analysis:-
File = 'beleq_1.txt',
nl, write(' Saving equilibria_in_beliefs_filtered_by_indices/6, '),
nl, write(' the analysis of equilibria to another file...'),
write(' namely '),write(File),
caution_if_file_exists(File,Backup),
tell_goal(File,forall,
(
equilibria_in_beliefs_filtered_by_indices(_,_,_,_,_,_)
)
),
ending_message(File,Backup).
/***** demo *****/
/*
?- save_data_of_beleq.
saving temp_ceu_max_play/4s, the experimental data, to a file...
namely ceu_max.pl
The file exsits. Overwrite? >y.
complete. file name: ceu_max.pl
and old_ceu_max.pl as the back-up copy.
Saving equilibria_in_beliefs_filtered_by_indices/6,
the analysis of equilibria to another file... namely beleq_1.txt
The file exsits. Overwrite? >y.
complete. file name: beleq_1.txt
and old_beleq_1.txt as the back-up copy.
Yes
?-
*/
% modified: 12 Mar 2004. minor bugfix of the modification in 7--8 Mar.
save_data_of_beleq_ranges:-
File = 'beleq_ranges_1.txt',
caution_if_file_exists(File,Backup),
nl,write('saving to file...'),
tell_goal(File,
(
write(save_data_of_beleq_ranges),nl,
write(file:File),nl,
current_model(M),write(model:M),nl,
bpa_precision(K),write('number of bpa intervals':K),nl,
restriction_for_generating_beliefs(_,_,C),
(var(C)->C1='non';C1=C),
write('restricted events for generating positive-valued bpas':C1),nl,
display_filters,nl,
%display_ranges_of_beleq
display_ranges_of_beleq_with_indices
)
),
ending_message(File,Backup).
caution_if_file_exists(File,F1):-
expand_file_name(*,FileList),
member(File,FileList),
!,
nl,
write(' The file exsits. Overwrite? >'),
read(y),
backup_outpt_file(File,F1).
caution_if_file_exists(_,_).
backup_outpt_file(F,F1):-
concat('old_',F,F1),
rename_file(F,F1).
ending_message(File,F1):-
nl,nl,write(' complete. file name: '),
write(File),
nl,
write(' and '),
var(F1)->true;
(
write(F1),
write(' as the back-up copy.')
),
nl.
%%%%%% demo %%%%%%%%%%
%----------------------
% demos for examples
%----------------------
% new version of packaged equilibria. (7 Mar 2004)
/*
% battle
%---------------
?- display_ranges_of_beleq_with_indices(A,S).
[1]
acts:[[c], [c]]
supports:
% player(1):[[[c]]]
% player(2):[[[c]], [[f]]]
% player(1):[[[c]]]
% player(2):[[[c]], [[f]]]
equilibrium belief(bpa)s and their intervals:
% player(1):[[c]]:[[0, 0.45]]
% player(2):[[c]]:[[0, 0.45]]
confidences:
% player(1):[0, 0.45]
% player(2):[0, 0.45]
ambiguities:
% player(1):[0.55, 1]
% player(2):[0.55, 1]
A = [[c], [c]]
S = [[[[[c]]], [[[c]], [[f]]]], [[[[c]]], [[[c]], [[f]]]]]
Yes
?-
save_data_of_beleq_ranges
file:beleq_ranges_1.txt
model:battle
filters on belief indices:
confidence:[0, 1]
ambiguity:[0, 1]
[1]
acts:[[c], [c]]
supports:
% player(1):[[[[c]]], [[[c]], [[f]]]]
% player(2):[[[[c]]], [[[c]], [[f]]]]
belief(bpa)s positive-valued and their intervals:
% player(1):[[c]]:[[0, 0.45]]
% player(2):[[c]]:[[0, 0.45]]
[2]
acts:[[c], [c, f]]
supports:
% player(1):[[[[c]]], [[[c]], [[f]]]]
% player(2):[[[[c]]]]
belief(bpa)s positive-valued and their intervals:
% player(1):[[c]]:[[0, 0.45]]
% player(2):[[c]]:[[0.5, 0.5]]
[3]
acts:[[c, f], [c]]
supports:
% player(1):[[[[c]]]]
% player(2):[[[[c]]], [[[c]], [[f]]]]
belief(bpa)s positive-valued and their intervals:
% player(1):[[c]]:[[0.5, 0.5]]
% player(2):[[c]]:[[0, 0.45]]
[4]
acts:[[c, f], [c, f]]
supports:
% player(1):[[[[c]]]]
% player(2):[[[[c]]]]
% player(1):[[[[c], [f]]]]
% player(2):[[[[c], [f]]]]
belief(bpa)s positive-valued and their intervals:
% player(1):[[c]]:[[0.5, 0.5]]
% player(1):[[f]]:[[0, 0.5]]
% player(2):[[c]]:[[0.5, 0.5]]
% player(2):[[f]]:[[0, 0.5]]
% klibanoff
%---------------
?- set_model(klibanoff).
model:klibanoff, Would you like to set this as current model ? (y.) >y.
start model compiling.. :klibanoff
% f c
% +-------+-------+
% | 1 | a=1/2 |
% f | 1 | b=0 l
% +-------+-------+
% | b= 0 | 2 |
% c | a=1/2 | 2 l
% +-------+-------+
% Fig. klibanoff`s coordination game.
Yes
?- gen_beleq.
Conguratulation. The set of equilibria in beliefs have generated.
1: (display_beleq/0), To go through results simply,
2: (display_beleq_f/0), Using confidence/ambiguity measure as filter,
3: (test_range_of_beleq/0) possibly afterward filter set by 2 or
4: (test_range_of_beleq_using_filter/0),
5: (save_data_of_beleq/0) to save the results to a file,
To make equlibria up and do further analysis, if you wish.
0: to exit.
select no. > 1.
P1: beliefs (bpa) of player 1[[[[c], [f]], 1]]
P2: beliefs (bpa) of player 2[[[[c], [f]], 1]]
confidence/ambiguity of P1:0/1
confidence/ambiguity of P2:0/1
support of P1: [[f]]
support of P2: [[f]]
Search another equilibrium? (y)
1: (display_beleq/0), To go through results simply,
2: (display_beleq_f/0), Using confidence/ambiguity measure as filter,
3: (test_range_of_beleq/0) possibly afterward filter set by 2 or
4: (test_range_of_beleq_using_filter/0),
5: (save_data_of_beleq/0) to save the results to a file,
To make equlibria up and do further analysis, if you wish.
0: to exit.
select no. > 3.
Done. Do you skim through the results ?
0: no display
1: glance over simply (display_ranges_of_beleq/0)
2: furthur look using filter (display_ranges_of_beleq_with_indices/0)
3: save data to file (save_data_of_beleq_ranges/0)
| 1.
filters on belief indices:
confidence:[0, 1]
ambiguity:[0, 1]
[1]
acts:[[c, f], [c, f]]
supports:
% player(1):[[[c]]]
% player(1):[[[c]]]
equilibrium belief(bpa)s and their intervals:
% player(1):[[c]]:[[0.25, 0.25]]
% player(2):[[c]]:[[0.25, 0.25]]
[2]
acts:[[c, f], [c]]
supports:
% player(1):[[[c]]]
% player(1):[[[c]]]
equilibrium belief(bpa)s and their intervals:
% player(1):[[c]]:[[0.25, 0.25]]
% player(2):[[c]]:[[0.3, 1]]
[3]
acts:[[c], [c, f]]
supports:
% player(1):[[[c]]]
% player(1):[[[c]]]
equilibrium belief(bpa)s and their intervals:
% player(1):[[c]]:[[0.3, 1]]
% player(2):[[c]]:[[0.25, 0.25]]
[4]
acts:[[c], [c]]
supports:
% player(1):[[[c]]]
% player(1):[[[c]]]
equilibrium belief(bpa)s and their intervals:
% player(1):[[c]]:[[0.3, 1]]
% player(2):[[c]]:[[0.3, 1]]
[5]
acts:[[f], [f]]
supports:
% player(1):[[[c]], [[f]]]
% player(2):[[[f]]]
% player(1):[[[c]], [[f]]]
% player(2):[[[f]]]
equilibrium belief(bpa)s and their intervals:
% player(1):[[f]]:[[0, 1]]
% player(2):[[f]]:[[0, 1]]
[6]
acts:[[c, f], [c, f]]
supports:
% player(1):[[[c], [f]]]
% player(1):[[[c], [f]]]
equilibrium belief(bpa)s and their intervals:
% player(1):[[c]]:[[0.35, 0.4]]
% player(1):[[f]]:[[0.4, 0.4], [0.6, 0.6]]
% player(2):[[c]]:[[0.35, 0.4]]
% player(2):[[f]]:[[0.4, 0.4], [0.6, 0.6]]
1: (display_beleq/0), To go through results simply,
2: (display_beleq_f/0), Using confidence/ambiguity measure as filter,
3: (test_range_of_beleq/0) possibly afterward filter set by 2 or
4: (test_range_of_beleq_using_filter/0),
5: (save_data_of_beleq/0) to save the results to a file,
To make equlibria up and do further analysis, if you wish.
0: to exit.
select no. > 4.
confidence, input the interval as [lower, upper]:[0,0.1].
ambiguity, input the interval as [lower, upper]:[0,1].
Done. Do you skim through the results ?
0: no display
1: glance over simply (display_ranges_of_beleq/0)
2: furthur look using filter (display_ranges_of_beleq_with_indices/0)
3: save data to file (save_data_of_beleq_ranges/0)
select no. > 1.
[1]
acts:[[f], [f]]
supports:
% player(1):[[[c]], [[f]]]
% player(2):[[[f]]]
% player(1):[[[c]], [[f]]]
% player(2):[[[f]]]
equilibrium belief(bpa)s and their intervals:
% player(1):[[f]]:[[0, 1]]
% player(2):[[f]]:[[0, 1]]
1: (display_beleq/0), To go through results simply,
2: (display_beleq_f/0), Using confidence/ambiguity measure as filter,
3: (test_range_of_beleq/0) possibly afterward filter set by 2 or
4: (test_range_of_beleq_using_filter/0),
5: (save_data_of_beleq/0) to save the results to a file,
To make equlibria up and do further analysis, if you wish.
0: to exit.
select no. > 0.
Yes
?-
% demonstrations of an old (non-wrapped) version.
%--------------------------------------------------
% The followings are not of recent (wrapped-equilibria) version,
% but the usages of commands are almost same.
% hunt
%---------------
?- set_model(hunt).
model:hunt, Would you like to set this as current model ? (y.) >y.
start model compiling.. :hunt
% f c
% +-------+-------+
% | 7 | a=8 |
% f | 7 | b=0 l
% +-------+-------+
% | b= 0 | 9 |
% c | a= 8 | 9 l
% +-------+-------+
% Fig. stag hunt game.
Yes
?- generate_equilibrium_in_beliefs(A,B,C).
A = [[[[[c], [f]], 1]], [[[[c], [f]], 1]]]
B = [[[f]], [[f]]]
C = [[f], [f]]
Yes
?- test_range_of_beleq.
Done. Display the results? (Using display_ranges_of_beleq/0) (y)
| y.
acts:[[c], [c]]
supports:[[[c]], [[c]]]
[1, [[c]], [[0.9, 1]]]
[2, [[c]], [[0.9, 1]]]
acts:[[f], [f]]
supports:[[[f]], [[f]]]
[1, [[f]], [[0.05, 1]]]
[2, [[f]], [[0.05, 1]]]
Yes
?-
% prudence.
%----------
?- figure(A).
% f c
% +-------+-------+
% | 10-e | 10-e |
% f | 10-a | 10 l
% +-------+-------+
% | -10 | 10 |
% c | 10-a | 10 l
% +-------+-------+
% Fig. prudence game.
A = 1/prudence
Yes
?- display_ranges_of_beleq.
acts:[[c, f], [c]]
supports:[[[c]], [[c]]]
[1, [[c]], [[0.9, 0.9]]]
[2, [[c]], [[0.05, 1]]]
acts:[[c, f], [c]]
supports:[[[c]], [[c], [f]]]
[1, [[c]], [[0.9, 0.9]]]
[2, [[c]], [[0.05, 0.95]]]
[2, [[f]], [[0.05, 0.95]]]
acts:[[c, f], [c]]
supports:[[[c]], [[f]]]
[1, [[c]], [[0.9, 0.9]]]
[2, [[f]], [[0.05, 1]]]
acts:[[c], [c]]
supports:[[[c]], [[c]]]
[1, [[c]], [[0.95, 1]]]
[2, [[c]], [[0.05, 1]]]
acts:[[f], [c]]
supports:[[[c]], [[f]]]
[1, [[c]], [[0.05, 0.85]]]
[2, [[f]], [[0.05, 1]]]
No
?-
% battle.
%----------
?- display_ranges_of_beleq.
[1]
acts:[[c, f], [c, f]]
supports:[[[c]], [[c]]]
% [1, [[c]], [[0.5, 0.5]]]
% [1, [[f]], [[0, 0]]]
% [2, [[c]], [[0.5, 0.5]]]
% [2, [[f]], [[0, 0]]]
[2]
acts:[[c, f], [c]]
supports:[[[c]], [[c]]]
% [1, [[c]], [[0.5, 0.5]]]
% [1, [[f]], [[0, 0]]]
% [2, [[c]], [[0, 0.45]]]
% [2, [[f]], [[0, 0]]]
[3]
acts:[[c, f], [c]]
supports:[[[c]], [[c], [f]]]
% [1, [[c]], [[0.5, 0.5]]]
% [1, [[f]], [[0, 0]]]
% [2, [[c]], [[0.05, 0.45]]]
% [2, [[f]], [[0.05, 0.95]]]
[4]
acts:[[c, f], [c, f]]
supports:[[[c]], [[c], [f]]]
% [1, [[c]], [[0.5, 0.5]]]
% [1, [[f]], [[0, 0]]]
% [2, [[c]], [[0.5, 0.5]]]
% [2, [[f]], [[0.05, 0.5]]]
[5]
acts:[[c, f], [c]]
supports:[[[c]], [[f]]]
% [1, [[c]], [[0.5, 0.5]]]
% [1, [[f]], [[0, 0]]]
% [2, [[c]], [[0, 0]]]
% [2, [[f]], [[0, 1]]]
[6]
acts:[[f], [c]]
supports:[[[c]], [[f]]]
% [1, [[c]], [[0.55, 1]]]
% [1, [[f]], [[0, 0]]]
% [2, [[c]], [[0, 0]]]
% [2, [[f]], [[0, 1]]]
[7]
acts:[[c], [c, f]]
supports:[[[c]], [[c]]]
% [1, [[c]], [[0, 0.45]]]
% [1, [[f]], [[0, 0]]]
% [2, [[c]], [[0.5, 0.5]]]
% [2, [[f]], [[0, 0]]]
[8]
acts:[[c], [c]]
supports:[[[c]], [[c]]]
% [1, [[c]], [[0, 0.45]]]
% [1, [[f]], [[0, 0]]]
% [2, [[c]], [[0, 0.45]]]
% [2, [[f]], [[0, 0]]]
[9]
acts:[[c], [c, f]]
supports:[[[c], [f]], [[c]]]
% [1, [[c]], [[0.05, 0.45]]]
% [1, [[f]], [[0.05, 0.95]]]
% [2, [[c]], [[0.5, 0.5]]]
% [2, [[f]], [[0, 0]]]
[10]
acts:[[c, f], [c, f]]
supports:[[[c], [f]], [[c]]]
% [1, [[c]], [[0.5, 0.5]]]
% [1, [[f]], [[0.05, 0.5]]]
% [2, [[c]], [[0.5, 0.5]]]
% [2, [[f]], [[0, 0]]]
[11]
acts:[[c, f], [c, f]]
supports:[[[c], [f]], [[c], [f]]]
% [1, [[c]], [[0.5, 0.5]]]
% [1, [[f]], [[0.05, 0.5]]]
% [2, [[c]], [[0.5, 0.5]]]
% [2, [[f]], [[0.05, 0.5]]]
[12]
acts:[[c], [c, f]]
supports:[[[f]], [[c]]]
% [1, [[c]], [[0, 0]]]
% [1, [[f]], [[0, 1]]]
% [2, [[c]], [[0.5, 0.5]]]
% [2, [[f]], [[0, 0]]]
[13]
acts:[[c], [f]]
supports:[[[f]], [[c]]]
% [1, [[c]], [[0, 0]]]
% [1, [[f]], [[0, 1]]]
% [2, [[c]], [[0.55, 1]]]
% [2, [[f]], [[0, 0]]]
No
?-
*/
%--------------------------------------------------
% Common Programs for Generating Beliefs and its Equilibrium
%--------------------------------------------------
% added: 4 Feb 2004.
% modified: 5--6 Feb 2004.
% modified: 11--13 Feb 2004.
% modified: 19--21 Feb 2004.
% modified: 7 Mar 2004. bugfix. collect_game_payoffs and so set_payoffs.
% Model translation
% from strategic form game into decision under uncertainty
%----------------------------------------------------
:- dynamic current_player/1.
current_player(1).
set_payoffs(J):-
set_payoffs_of_game(J,_Payoffs,_).
% modified: 19 Feb 2004. added setting for act/1.
set_payoffs_of_game(J,Payoffs,[W,A]):-
set_current_player(J,PJ),
collect_game_payoffs(J,PJ,Payoffs),
set_payoffs_of_player(Payoffs),
set_acts_of_player(A,Payoffs),
set_states(W,Payoffs).
% modified: 8 Mar 2004.
% renamed project_a_player/2 (project_a_player_and_set_current).
project_a_player(J,PJ):-
(game(_,payoff,A,_)->true;fail),
list_projection(PJ,A,[_X]),
nth1(J,PJ,1).
set_current_player(J,PJ):-
project_a_player(J,PJ),
abolish(current_player/1),
assert(current_player(J)).
% bugfix: 7 Mar 2004. specified current model for payoff/3.
collect_game_payoffs(_J,PJ,Payoffs):-
current_model(M),
findall((F,S,V),
(
game(M,payoff,B,U),
list_projection(PJ,B,[F]),
c_list_projection(PJ,B,S),
list_projection(PJ,U,[V])
),
Payoffs).
set_payoffs_of_player(Payoffs):-
abolish(payoff0/3),
forall(
member((F,S,V),Payoffs),
assert(payoff0(F,S,V))
).
set_acts_of_player(Acts,Payoffs):-
abolish(act/1),
findall(F,member((F,_S,_V),Payoffs),Acts0),
sort(Acts0,Acts),
forall(
member(F,Acts),
assert(act(F))
).
set_states(W,Payoffs):-
setof(S,
F^V^member((F,S,V),Payoffs),
W),
abolish(states/1),
assert(states(W)).
%--------------------------------------------------
% generating belief system focusing on a subset
%--------------------------------------------------
% to set granularity of generated bpa0s.
%----------------------------------------
% added: 20 Feb 2004. update_bpa_precision/0,2.
% modified: 21 Feb 2004.
:- dynamic bpa_precision0/1.
default_bpa_precision(20).
bpa_precision(K):-
clause(bpa_precision0(K),_),
!.
bpa_precision(K):-
default_bpa_precision(K).
update_bpa_precision(N,N1):-
retract(bpa_precision0(N)),
assert(bpa_precision0(N1)).
update_bpa_precision:-
nl,
write('input a number of partitions for unit interval> '),
read(N1),
(0 < N1 ->true;(write(invalid),fail)),
(N1 =<20 ->true;(write('too large'),fail)),
update_bpa_precision(_N,N1).
% to generate bpa0s.
%----------------------------------------
% modified: 13 Feb 2004.
generate_bpa((E,N),PBEL):-
bpa_precision(K),
generate_bpa(K,E,N,PBEL).
generate_bpa(K,E,N,PBEL):-
integer(K),
(var(E)->states(E);event(E)),
E\=[],
findall(F,subevent_of(F,E),W),
% all_sevents(W), % not to be used :-)
length(W,N),
nth1(J0,W,[]),
allocate_K_mass_over_events(K,N,J0,Q),
probability_allocation(W,K,Q,PBEL),
update_belief_space_with_bpa0s(PBEL).
allocate_K_mass_over_events(K,N,J0,Q):-
%probabilities(N,P),
%bpa_precision(K),
allocation(N,K,P),
reverse(P,Q),
nth1(J0,Q,Q0),
Q0 is 0.
probability_allocation(W,K,Q,PBEL):-
findall([F,B],
(
nth1(J,Q,QJ),QJ>0,
B is QJ/K,
nth1(J,W,F)
),
PBEL).
update_belief_space_with_bpa0s(PBEL):-
abolish(temp_bpa0s/1),
assert(temp_bpa0s(PBEL)),
abolish(bpa0/2),
abolish(bel0/2),
forall(
(member([F,B],PBEL)),
(assert(bpa0(F,B)))
).
% Compile and futher test for generated belief system:
% support and best response
%--------------------------------------------------
% test_gen_bpa_1/4:
% to be used in gen_ceu_max_play/4 (in generate_equilibrium_in_beliefs_0/0).
% added: 14 Feb 2004.
% modified: 15 Feb 2004. extended test for generated beliefs.
% modified: 21 Feb 2004. test_gen_bpa_1/5 without abolishing temporary data.
% modified: 22 Feb 2004. added update_temp_gen_bpa/4 to check the multiplicity.
:- dynamic temp_gen_bpa/4.
init_gen_bpa:-
abolish(temp_gen_bpa/4),
abolish(temp_extended_test_of_beliefs/2).
test_gen_bpa(A,B,C,D,E):-
init_gen_bpa,
test_gen_bpa_0(A,B,C,D,E).
test_gen_bpa_1(A,B,C,D,E):-
% without initializing experimental results,
test_gen_bpa_0(A,B,C,D,E),
extended_test_of_beliefs(B,_).
% for each experiment of generating beliefs.
test_gen_bpa_0(set:E,bpa:P,supp:A,br:BR,conform):-
nl,write('abolish current beliefs and generate new? >'),
read(y),
generate_bpa((E,_N),P),
nl,write('bpa0 generated. compile bel0 ? >'),read(y),
cmc_bel,
nl,write('bel0 compiled. compute the support ? >'),read(y),
all_supports(A),
best_response(BR),
update_temp_gen_bpa(set:E,bpa:P,supp:A,br:BR).
test_gen_bpa_0(set:E,bpa:P,supp:A,br:BR,noconform):-
generate_bpa((E,_),P),
cmc_bel,
all_supports(A),
best_response(BR),
update_temp_gen_bpa(set:E,bpa:P,supp:A,br:BR).
update_temp_gen_bpa(set:E,bpa:P,supp:A,br:BR):-
clause(temp_gen_bpa(set:E,bpa:P,supp:A,br:BR),_).
update_temp_gen_bpa(set:E,bpa:P,supp:A,br:BR):-
\+ clause(temp_gen_bpa(set:E,bpa:P,supp:A,br:BR),_),
assert(temp_gen_bpa(set:E,bpa:P,supp:A,br:BR)).
cmc_bel:-
abolish(bel0/2),
findall([A,B],sbel(A,_,B), BEL),
forall(member([A,B],BEL), assert(bel0(A,B))).
% a predicate-specific compiling program
:- dynamic temp_bel/2.
cmc_bel_1:-
abolish(bel0/2),
abolish(temp_bel/2),
forall(sbel(A,_,B), assert(temp_bel(A,B))),
forall(temp_bel(A,B), assert(bel0(A,B))).
% extended test for indices of generated beliefs :
% confidence and ambiguity
%----------------------------
:- dynamic temp_extended_test_of_beliefs/2.
reject_if_bpa_is_unspecified(P):-
(\+ var(P)-> true;
(nl,
write(
'invalid request: beliefs unspecified. Type y to continue.'
),
read(y)
)
).
extended_test_of_beliefs(bpa:P,D):-
reject_if_bpa_is_unspecified(P),
% ==> % debug_for_battle(P),
extended_test_of_beliefs_0(bpa:P,D).
% bugfix: 22 Feb 2004. added a cut in the first rule
% of extended_test_of_beliefs_0/2.
extended_test_of_beliefs_0(bpa:P,Indeces):-
clause(
temp_extended_test_of_beliefs(bpa:P,Indeces),
true
),
!.
extended_test_of_beliefs_0(bpa:P,[confidence:A,ambiguity:B]):-
% ==> % debug_for_example_10(P),
confidence(A),
ambiguity(B),
assert(
temp_extended_test_of_beliefs(
bpa:P,
[confidence:A,ambiguity:B]
)
).
% rules for debug.
debug_for_battle(P):-
%to debug for example 10. 21 Feb 23:00
P1 = [[[[d, l], [d, r], [u, l], [u, r]], 1]],
P2 = [[[[b, l], [b, r], [t, l], [t, r]], 1]],
P3 = [[[[b, d], [b, u], [t, d], [t, u]], 1]],
member(P,[P1,P2,P3]),
trace.
debug_for_example_10(P):-
% to debug for battle. 22 Feb 15:40
P1 = [[[[c],[f]],1]],
member(P,[P1]),
trace,
current_player(J),write(player(J)).
%%%%%% demo %%%%%%
% the examples of battle and of hunt.
% test for example battle:
% where bpa_precision/1 was 100.
%----------------------------
/*
?- test_gen_bpa(set:[c,f],bpa:P,supp:A,br:BR,noconform),member(BR,A).
P = [[[f, c], 1]]
A = [[f], [c]]
BR = [c] ;
P = [[[c], 0.01], [[f, c], 0.99]]
A = [[c]]
BR = [c] ;
P = [[[c], 0.02], [[f, c], 0.98]]
A = [[c]]
BR = [c] ;
P = [[[c], 0.03], [[f, c], 0.97]]
A = [[c]]
BR = [c] ;
% ...
P = [[[c], 0.49], [[f, c], 0.51]]
A = [[c]]
BR = [c] ;
No
?-
*/
% test for example hunt:
% where pbpa_recision/1 was 20.
%----------------------------
/*
?- test_gen_bpa(set:[c,f],bpa:P,supp:A,br:BR,noconform),member(BR,A).
P = [[[f, c], 1]]
A = [[f], [c]]
BR = [f] ;
P = [[[f], 0.05], [[f, c], 0.95]]
A = [[f]]
BR = [f] ;
P = [[[f], 0.1], [[f, c], 0.9]]
A = [[f]]
BR = [f] ;
P = [[[f], 0.15], [[f, c], 0.85]]
A = [[f]]
BR = [f]
% ...
P = [[[f], 1]]
A = [[f]]
BR = [f] ;
P = [[[c], 0.9], [[f, c], 0.1]]
A = [[c]]
BR = [c] ;
P = [[[c], 0.95], [[f, c], 0.05]]
A = [[c]]
BR = [c] ;
P = [[[c], 1]]
A = [[c]]
BR = [c] ;
No
*/
%---------------------------------------------------
% Part I. Belief Function
%---------------------------------------------------
% privious version: belief01.pl(29 Jun 2003)
% modified: 19--23 Jan 2004.
% probabilistic state space: state space, event
%---------------------------------------------------
state(S):- states(A),member(S,A).
% modified: 6 Feb 2004. to modify event/1 to adapt event0/1.
event(E):-
(clause(event0(_),_)->true;fail),
(event0(E);(event0(E0),seteq(E0,E),E\=E0)).
event(E):-
(\+ clause(event0(_),_)->true;fail),
states(S),
bag1(E,S,_N).
% old version.
/*
event(E):-
states(A),
bag1(E,A,_N).
*/
% modified: 15 Jan 2004. to use sort_by_list/3 instead of sort/2.
% modified: 5 Feb 2004. to use list_projection/3 instead sort_by_list/3.
% modified: 13 Feb 2004. to use findall/3 instead setof/3.
sevent(X):-
states(S),
list_projection(_,S,X).
all_events(S):-findall(E,event(E),S).
all_sevents(S):-findall(E,sevent(E),S).
% modified: 5 Feb 2004.
% modified: 13 Feb 2004.
subevent_of(F,E):-
var(E),
sevent(E),
sevent(F),
subset(F,E).
%list_projection(_,E,F).
subevent_of(F,E):-
\+ var(E),
event(E),
states(S),
sort_by_list(E,S,ES),
list_projection(_,ES,F).
% old version.
/*
subevent_of(F,E):-
sevent(E),
subset_of(X,_,E),
states(S),
sort_by_list(X,S,F).
*/
c_event(E,X):-
complementary_event(E,X).
% modified: 3,5 Feb 2004.
complementary_event(E,C):-
var(C),
states(A),
(var(E)->sevent(E);event(E)),
subtract(A,E,C),
% subtract(A,E,X),
% (sevent(X)->C=X;sort_by_list(X,A,C)),
!.
complementary_event(E,C):-
\+ var(C),
states(A),
(var(E)->sevent(E);event(E)),
subtract(A,E,X),
seteq(X,C),
!.
% rule for input an event
%-----------------------------------------------------------
% added: 11 Mar 2004.
input_rule_of_event(F,E):-
match_sorted_event(F,E).
match_sorted_event(F,E):-
\+ var(F),
!,
states(S),
sort_by_list(F,S,E).
match_sorted_event(F,E):-
var(F),
sevent(E),
F=E.
% Basic probability assignment (bpa)
% computed from bpa0 where events assigned zero mass are possibly omitted.
%-----------------------------------------------------------
% modified: 1 Feb 2004. bugfix.
% modified: 10--11 Mar 2004. added match_sorted_event
% use mass/3 below if there is bel0/2 but no bpa0/2 in the model.
bpa(E,B):-
(\+ clause(bpa0(_,_),_)->true;fail),
(clause(bel0(_,_),_)->true;fail), % to avoid the circularation of bel/3.
mass(E,_,B).
bpa(F,B):-
(clause(bpa0(_,_),_)->true;fail),
input_rule_of_event(F,E),
(bpa0(E,B)->true;B is 0).
/*
% old version without sort.
bpa(E,B):-
(clause(bpa0(_,_),_)->true;fail),
event(E),
bpa0(E1,B),
seteq(E,E1).
bpa(E,0):-
(clause(bpa0(_,_),_)->true;fail),
event(E),
\+ (
bpa0(E1,_),
seteq(E,E1)
).
*/
% Belief functions
%---------------------------------------------------
% modified: 14 Jan 2004. bugfix. (bel0/3-->bel0/2 and to use event/1.)
% modified: 6 Feb 2004. bugfix. (bel_rule/2. later replaced by match_sorted_event/2)
% modified: 11 Feb 2004. bugfix. (no ! if var(E) and no exceptional rule.)
% modified: 11 Mar 2004. bugfix. attached match_sorted_event/2.
% modified: 29 Jun 2003. bugfix. (setof was used.)
% modified: 5 Feb 2004. (subevent_of/2 be used instead subset/2.)
% modfied: 11 Mar 2004. attached match_sorted_event/2.
bel(E1,Xq,X):-
(\+ clause(bel0(_,_),_)->true;fail),
(clause(bpa0(_,_),_)->true;fail),
match_sorted_event(E1,E),
bagof(B,
F^(
%sevent(F),subset(F,E),
subevent_of(F,E),
bpa(F,B)
%,nl,write(bpa(F,B))
),
G),
sum_eq(G,Xq,X).
% use bel0/2s if exsist.
bel(F,X,X):-
(clause(bel0(_,_),_)->true;fail),
input_rule_of_event(F,E),
(bel0(E,X)->true;X is 0).
/*
% abolished input rule. (11 Mar 2004)
bel_rule(E,X):-
var(E),
bel0(E,Y),
X is Y.
bel_rule(E,X):-
\+ var(E), % apply this rule only when an event is specified.
event(E),
bel0(E0,X),
seteq(E0,E),
!.
% bugfix: 11 Feb 2004.
%bel_rule(_E,0).
*/
% belief function for sorted event.
sbel(E,Xq,X):-
sevent(E),
bel(E,Xq,X).
% Possibility function (conjugate belief function)
%---------------------------------------------------
pos(E,Xq,X):-
(clause(pos0(_,_),_)->fail;true),
(clause(bpa0(_,_),_)->true;fail),
event(E),
findall(B,
(
sevent(F),
intersection(F,E,M),
M \= [],
bpa(F,B)
),
G),
sum_eq(G,Xq,X).
spos(E,Xq,X):-
sevent(E),
pos(E,Xq,X).
% a comparison.
pos_1(E,1-Xq,X):-
event(E),
c_event(C,E),
bel(C,Xq,_),
X is 1 - Xq.
% a verification program as for v(A)=1-v~(-A).
%
% ?- sbel(E,_,B),c_event(F,E),pos_1(F,1-X,_),Y is X.
% b.p.a. via Mevious inversion
%---------------------------------------------------
% mass(B) = sum(for(subset(A,B)), (-1)^|B-A| * v(A)).
% modified: 1 Feb 2004. (using sevent as subset of sevent).
% modified: 11 Mar 2004. added match_sorted_event
mass([],0,0).
mass(E1,Yq,Y):-
%sevent(E),E=F,
match_sorted_event(E1,E),
E \= [],
findall(A,
(
subevent_of(F,E),
bel(F,Bq,_B),
% debug-->% nl,write(bel(F,Bq,_B)),
movius(F,E,K),
%nl,write(movius(F,E,K)),
A = K * Bq
),
G),
sum_eq(G,Yq,Y1),
Y is Y1.
% Coefficients in the Movius inversion formula.
%---------------------------------------------------
movius(X,Y,Z):-
event(X),
event(Y),
subtract(Y,X,W),
length(W,M),
Z = (-1)^M.
/*
% test run for examples.
?- set_model.
models:[balls, trade1, sales, trade2, ipd2]
please specify the model >balls.
balls, Would you like to set this model ? (y) >y.
balls, replace all model predicates with the unified goals? (y)>y.
start model compiling.. :balls
Yes
?- bpa(A,B),mass(A,C,B1).
A = []
B = 0
C = 0
B1 = 0 ;
bel([], 0, 0)
bel([r], 1/3+0, 0.333333)
A = [r]
B = 1/3
C = -1^0* (1/3+0)+ -1^1*0
B1 = 0.333333 ;
bel([], 0, 0)
bel([y], 0+0, 0)
bel([b], 0+0, 0)
bel([b, y], 2/3+0+0+0, 0.666667)
A = [b, y]
B = 2/3
C = -1^0* (2/3+0+0+0)+ -1^1* (0+0)+ -1^1* (0+0)+ -1^2*0
B1 = 0.666667
Yes
?-
% another test run for example ipd2:
% the unique path of positive contributions to the capacity
% is [cf]-->[cc,w]-->[ff].
?- mass(A,B,C),C>0.
A = [cf]
B = -1^0*0.4+ -1^1*0
C = 0.4 ;
A = [cf, cc, w]
B = -1^0*0.8+ -1^1*0.4+ -1^1*0.4+ -1^2*0.4+ -1^1*0+ -1^2*0+ -1^2*0+ -1^3*0
C = 0.4 ;
A = [ff, cf, cc, w]
B = ... +... +... *... +... ^... *0.8+ -1^2*0.4+ -1^2*0.4+ -1^3*0.4+ -1^2*0+ -1^3*0+ -1^3*0+ -1^4*0
C = 0.2 ;
No
?-
*/
%---------------------------------------------------
% Checking the modularity (i.e., 2-monotonicity).
%---------------------------------------------------
% modified: 11 Feb 2004.
% restricted to the sevents (using sort_by_list).
% last revised: 12 Mar 2004. (added a ! and the input rule.)
% some additional modeling for pairwise events
%---------------------------------------------------
incomparable_pairwise_sevents(E,F):-
pairwise_sevents(E,F),
\+ subset(E,F).
pairwise_sevents(E,F):-
states(S),
pairwise_elements_of(_K,S,[E,F]).
pairwise_elements_of([P1,P2],Base,[A1,A2]):-
list_projection(P1,Base,A1),
list_projection(P2,Base,A2),
P1 @=< P2.
% note: the order is not same as pairwise_sevents_0/2.
%%%%% museum %%%%%
% old version.
pairwise_sevents_0(E,F):-
setof(A,sevent(A),B),
pairwise_elements_of_0(_K,B,[E,F]).
%F\=E,
pairwise_elements_of_0([K,K1],B,[A1,A2]):-
nth1(K,B,A1),
nth1(K1,B,A2),
K1 >= K.
% an awful alternative to use the following after generation.
/*
eliminate_upper_diagonals:-
temp_pairwise_sevents(E,F),
temp_pairwise_sevents(F,E),
retractall(temp_pairwise_sevents(F,E)),
fail.
union_and_intersection_of_pairwise_sevents(E,F,G,H):-
union_of_pairwise_sevents(E,F,G),
intersection_of_pairwise_sevents(E,F,H).
union_of_pairwise_sevents(E,F,G):-
union(E,F,G1),
seteq(G1,G),
sevent(G).
intersection_of_pairwise_sevents(E,F,H):-
intersection(E,F,H1),
seteq(H1,H),
sevent(H).
*/
% test of modularity for pairwise events
%----------------------------------------
modularity([E1,F1],[G,H],REL,Z):-
input_rule_of_modularity([E1,F1,REL],[E,F]),
sbel(E,_Yq1,Y1),
sbel(F,_Yq2,Y2),
union(E,F,G),
intersection(E,F,H),
bel(G,_Yq3,Y3),
bel(H,_Yq4,Y4),
case_of_pairwise_modularity([Y1,Y2,Y3,Y4],REL,Z).
case_of_pairwise_modularity([Y1,Y2,Y3,Y4], REL, Z):-
X1 is Y1 + Y2,
X2 is Y3 + Y4,
case_of_pairwise_modularity1(X1,X2, REL0, Z),
REL0 =.. [OP, X1, X2],
REL =.. [OP, Y1 + Y2, Y3 + Y4].
case_of_pairwise_modularity1(X1,X2, REL, modular):-
num_eq(X1,X2),!, REL=(X1 = X2).
case_of_pairwise_modularity1(X1,X2, REL, supermodular):-
\+ num_eq(X1,X2), X1X2,!, REL=(X1 > X2).
num_eq(X,Y):-
Z is (X - Y)^2,
Z < 10^(-10).
input_rule_of_modularity([E,F,REL],[E,F]):-
% (\+ clause(temp_pairwise_sevents(_,_),_)->true;fail),
var(REL),
(var(E) -> pairwise_sevents(E,F); true).
/*
input_rule_of_modularity([E1,F1,REL],[E,F]):-
(clause(temp_pairwise_sevents(_,_),_)->true;fail),
var(REL),
%input_rule_of_event(E1,E),
%input_rule_of_event(F1,F),
[E,F] = [E1,F1],
temp_pairwise_sevents(E,F).
input_rule_of_modularity([E1,F1,REL],[E,F]):-
(\+ clause(temp_pairwise_sevents(_,_),_)->true;fail),
var(REL),
%input_rule_of_event(E1,E),
%input_rule_of_event(F1,F),
[E,F] = [E1,F1],
pairwise_sevents(E,F).
*/
/*
% for ipd2.
?- modularity([E,F],UI,R,Y),Y\=modular.
E = [cc]
F = [cf, w]
UI = [[cf, cc, w], []]
R = 0+0.4<0.8+0
Y = supermodular ;
E = [cc]
F = [cf, w, x]
UI = [[cf, cc, w, x], []]
R = 0+0.4<0.8+0
Y = supermodular ;
E = [cc]
F = [cf, w, x, y]
UI = [[cf, cc, w, x, y], []]
R = 0+0.4<0.8+0
Y = supermodular ;
E = [cc]
F = [cf, w, x, y, z]
UI = [[cf, cc, w, x, y, z], []]
R = 0+0.4<0.8+0
Y = supermodular
Action (h for help)
Yes
*/
%---------------------------------
% total test of modularity
%---------------------------------
% modified: 11 Feb 2004.
% modifeed: 12--13 Mar 2004. bugfix (1. simply added a !.),
% (2. separated create_temp_modularity/0),
% (3. modified to verify only incomparable event pairs),
% (4. added estimatation of exec time and warnings).
% a naive version.
modularity_1(Z):-
warn_user_of_modularity_1,
findall(Y,
(
modularity(_,_,_,Y)
),
W),
sort(W,W1),
case_of_modularity(W1,Z).
case_of_modularity([modular],modular):-!.
case_of_modularity(G,supermodular):- \+ member(submodular,G),!.
case_of_modularity(G,submodular):- \+ member(supermodular,G),!.
case_of_modularity(_G,nonlinear).
warn_user_of_modularity_1:-
nl,write(' !! Warning !! '),
nl,write(' This is a developmental code for modularity. '),
nl,write(' It may waste your time. (y) >'),
read(y).
:- dynamic temp_modularity/4.
modularity(Z):-
generate_all_incomparable_pairwise_sevents,
warn_user_if_higher_complexity(U),
A=modularity_0(Z),
B=(
create_temp_modularity,
modularity_0(Z)
),
(U==y->(stopwatch(A,_));(stopwatch(B,_))),
!.
modularity_0(Z):-
findall(Y,
temp_modularity(_,_,_,Y),
W),
sort(W,W1),
case_of_modularity(W1,Z).
create_temp_modularity:-
abolish(temp_modularity/4),
forall(
temp_pairwise_sevents(E,F),
update_temp_modularity([E,F],_,_,_Y)
).
update_temp_modularity([E,F],UI,R,Y):-
modularity([E,F],UI,R,Y),
%retractall(temp_modularity([E,F],_,_,_)),
assert(temp_modularity([E,F],UI,R,Y)).
warn_user_if_higher_complexity(U):-
findall(a,temp_pairwise_sevents(_,_),W),
length(W,L),
rule_for_warn_complexity_of_modularity(L,U).
rule_for_warn_complexity_of_modularity(L,y):-
L<5000,
!.
rule_for_warn_complexity_of_modularity(L,U):-
N = 500, % fixed an experimentaly good number in ipd2, L = 26630.
% N is integer(L/5000)*5000/50, % an alternative: 2% of the population size.
evaluate_complexity_for_modularity(N,L,[T,AT,ST]),
warn_about_complexity_of_modularity([N,L,T,AT,ST]),
read(U).
evaluate_complexity_for_modularity(N,L,[T,AT,ST]):-
%get_average_time_by_sampling(modularity_x/4,N,_=AT),
guess_average_time_of_modularity(N,ST,AT),
T is AT * L.
guess_average_time_of_modularity(N,ST,AT):-
collect_N_samples(temp_pairwise_sevents(_,_),N),
write('sampling..'),
stopwatch(modularity_y,ST),
AT is ST / N.
warn_about_complexity_of_modularity([N,L,T,AT,ST]):-
nl,nl,write(' %%% warning %%%'),
nl,write(' It can be estimated from the sampling test, of '),
write(N),write(' trials, for '), nl,tab(1),write(L),
write(' event pairs, that the average consumption time is '),
nl,tab(1),write(AT=(ST/N)), write(' seconds per pair.'),
nl,
nl,write(' It would take '),write(T), write(' seconds in total. '),
nl,write(' Use data of the privious test ? (y) '),
nl,write(' Or create new data ? (n) >').
% The followings are to fathom complexity of modularity/1.
% It would not be good guess in naive repetitions because that forall/2 is nonlinear.
modularity_x([E,F],B,C,D):-
temp_pairwise_sevents(E,F),
modularity([E,F],B,C,D).
modularity_y:-
Y=temp_pairwise_sevents(E,F),
abolish(temp_modularity/4),
forall(
temp_sampled(Y,_),
update_temp_modularity([E,F],_,_,_Y)
).
% A sampling tool
%-------------------------------------
% added: 13 Mar 2004.
:- dynamic temp_sampled/2.
:- dynamic temp_sampling_counter/1.
collect_N_samples(Y,UB):-
initialize_sample_space,
findall(a,Y,W),length(W,N),P is 100*UB/N,
forall(
(
Y,
A is random(101),
A < P,
update_sampling_counter(_,K),
K ='),
read(y).
% test run for ipd2.
%--------------------
/*
?- findall(a,sevent(A),M),length(M,L).
A = _G154
M = [a, a, a, a, a, a, a, a, a|...]
L = 256 ;
No
?- modularity(E).
Abolish old data and create new ? (y)>y.
Continue with the test ? It may cost some minutes.(y)>y.
time_elapsed(sec):99.122
E = supermodular
Yes
?- findall(a,temp_modularity(A,B,C,D),W),length(W,L).
A = _G14
B = _G15
C = _G16
D = _G17
W = [a, a, a, a, a, a, a, a, a|...]
L = 32640
Yes
?- modularity1(E).
Abolish old data and create anew ? (y)>y.
Continue with the test ? It may cost some minutes.(y)>y.
time_elapsed(sec):98.261
E = supermodular
Yes
?-
*/
% rephrase into convexity.
%---------------------------------
convexity(E,F,G,H,I):-
modularity(E,F,G,H,J),
A = (concave,submodular),
B = (convex,supermodular),
C = (linear,modular),
C1 = nonlinear,
D = (I,J),
member(D,[A,B,C,C1]).
convexity(concave):- modularity(X),X==submodular.
convexity(convex):- modularity(X),X==supermodular.
convexity(linear):- modularity(X),X==modular.
%---------------------------------
% partial test of modularity
%---------------------------------
modularity(part,W,Z):-
generate_pairwise_sevents_restricted_to_states(W),
findall(Y,
(
temp_pairwise_sevents(E,F),
update_temp_modularity([E,F],_,_,Y)
),
G),
%sort(G,G1),write(G1),
case_of_modularity2(G,Z).
generate_pairwise_sevents_restricted_to_states(W):-
event(W),
confirm_user_2(W),
abolish(temp_pairwise_sevents/2),
pairwise_sevent_restricted_to_states(E,F,W),
assert(temp_pairwise_sevents(E,F)),
fail.
generate_pairwise_sevents_restricted_to_states(_W):-
nl,write('Continue with the run ? It may cost some minutes.(y)>'),
read(y).
confirm_user_2(E):-
nl,
write(
(
'selected states':E,
'ok ? (y) >'
)
),
read(y),
confirm_user_1.
pairwise_sevent_restricted_to_states(E,F,W):-
event(W),
setof(A,
(
sevent(A),
forall(member(X,A),member(X,W))
),
B),
pairwise_element_of(_K,B,[E,F]).
%F\=E,
% test run for ipd2 example.
%---------------------------------
/*
?- set_model(ipd2).
ipd2, Would you like to set this model ? (y) >y.
Yes
?- modularity(part,[ff,cf,cc,w],A).
selected states:[ff, cf, cc, w], ok ? (y) >y.
Abolish old data and create new ? (y)>y.
Now you hold data. Continue run ? It may cost minutes.(y)>y.
A = supermodular ;
No
?-
*/
%---------------------------------------------------
% Checking additivity.
%---------------------------------------------------
additivity(E,F,Yq1 + Yq2,Yq3,Z):-
sevent(E),
sevent(F),
F \= E,
union(E,F,G1),
sevent(G),
seteq(G1,G),
intersection(E,F,[]),
bel(E,Yq1,_Y1),
bel(F,Yq2,_Y2),
bel(G,Yq3,_Y3),
X1 is Yq1 + Yq2,
X2 is Yq3,
(num_eq(X1,X2) -> Z = additive; true),
(X1 > X2 -> Z = subadditive; true),
(X1 < X2 -> Z = superadditive; true).
additivity(Z):-
findall(Y,
(
sevent(E),
sevent(F),
additivity(E,F,_,_,Y)
),
G),%nl,write(G),
(sort(G,[additive])->Z = additive; true),
(sort(G,[additive,superadditive])->Z = superadditive; true),
(sort(G,[additive,subadditive])->Z = subadditive; true),
(Z = nonadditive; true).
% Checking monotonicity in event.
%---------------------------------------------------
% modified: 2 Feb 2004.
monotonicity(E,F,Yq1,Yq2,Z):-
sevent(E),
sevent(F),
F \= E,
subevent_of(E,F),
bel(E,Yq1,Y1),
bel(F,Yq2,Y2),
(Y1 > Y2 -> Z = nonmonotonic; true),
(Y1 =< Y2 -> Z = monotone; true).
monotonicity(Z):-
findall(Y,
(
sevent(E),
sevent(F),
monotonicity(E,F,_,_,Y)
),
G),%nl,write(G),
(
sort(G,[monotone])
-> Z = monotone;
Z = nonmonotonic
).
% definition of capacity.
is_capcity:- monotonicity(monotone).
%%%%%% demo %%%%%%%%%%
/*
% sample executions (example model balls).
?- sevent(A),mass(A,B,C),bpa(A,D).
A = [r]
B = 1/3* -1^0
C = 0.333333
D = 1/3 ;
A = [b]
B = 0* -1^0
C = 0
D = 0 ;
A = [y]
B = 0* -1^0
C = 0
D = 0 ;
A = [b, r]
B = 1/3* -1^1+ (1/3+0)* -1^0+0* -1^1
C = 0
D = 0 ;
A = [r, y]
B = 1/3* -1^1+ (1/3+0)* -1^0+0* -1^1
C = 0
D = 0 ;
A = [b, y]
B = (2/3+0)* -1^0+0* -1^1
C = 0.666667
D = 2/3
A = [b, r, y]
B = 1/3* -1^2+ (2/3+0)* -1^1+ (1/3+0)* -1^1+ (2/3+1/3+0)* -1^0+0* -1^2
C = 0.333333
D = 1/3 ;
No
?- sevent(A),c_event(D,A),pos(A,B,C).
A = [r]
D = [b, y]
B = 1/3+0
C = 0.333333
Yes
?- sevent(A),c_event(D,A),bel(D,E,F),pos(A,B,C).
A = [r]
D = [b, y]
E = 2/3+0
F = 0.666667
B = 1/3+0
C = 0.333333
Yes
?-
*/
%---------------------------------------------------
% Part II. Updating Belief Function
%---------------------------------------------------
% Basic Notions.
%-----------------------------
% (0) Assume a frame of discernment (i.e, a state space with some
% epistemic interpretation of it). Then beliefs of agent about uncertain
% events are represented by belief function stated as follows.
% (1) A belief function is 0-1 normalized totally monotone capacity.
% (2) A belief function is also defined by the bpa (mass) function.
% Belief function of an event E summarizes its evidence in that
% it is the sum of all bpas of its focal set F included in E .
% (3) Conversely, a bpa function can be calculated via inversion
% from belief functions.
% (4) A belief function has its conjugate, a possibility function.
% (5) Updating rule of belief function can be computed by using
% updated bpa function which is the restriction of prior bpa to
% the observed event.
% Formula (Ref.1-3).
%-----------------------------------
/*
(1. n-monotone capacity)
v(union(Ak))
>= sum(subset(J,[1,..,n]),
(-1)^(|J|+1) * v(intersect(for(member(k,J)),Ak))
).
(2. definition via basic probability assignment; bpa)
v(A) = bel(A)
= sum(for(subset(B,A),B\=[]),mass(A)).
(3. Mobius inversion formula)
mass(B) = sum(for(subset(A,B)), (-1)^|B-A| * v(A).
where
mass([]) = 0,
sum(mass(A))=1.
(4. plausibility function (possibility measure))
v~(A) = v(All) - v(All - A) = 1 - v(-A).
= sum(for(intersect(A,B)), mass(B)).
(5. belief updating)
> Dempster's compostion rule:
m_12(A) = sum(for(intersection(X,Y,A)), m_1(X) * m_2(Y)).
> Dempster-Shafer conditioning:
m_ds(A|B)
= sum(for(intersection(E,B,A)), m(E) / (1-Sum) ),
where
Sum = sum(for(intersection(E,B,F),F\=[]), m(E)).
>The objective part of the interpretation:
v(union(A,-B)) - v(-B)
v_ds(A|B) = ------------------------
1 - v(-B)
v~(B) - v~(intersect(-A,B))
= -----------------------------
v~(B)
> conditioning by Upper-Lower envelope of additive measures:
v(intersect(A,B))
v_ul(A|B) = -----------------------------------------
v(intersect(A,B)) + v~(intersect(-A,B))
v~(intersect(A,B))
v~ul(A|B) = -----------------------------------------
v~(intersect(A,B)) + v(difference(B,A))
*/
% Updating bpa by Dempster-Shafer rule
%---------------------------------------------------
mass_of_intersection_with(A,B,C,Yq):-
% mass of A which has intersection C with B.
event(A),
event(B),
intersection(A,B,D),
sort(D,C),
mass(A,Yq,_).
update_mass([]/D,0,0):-event(D).
update_mass(E/D,Yq,Y):-
event(E),
\+ E = [],
event(D),
\+ D = [],
findall((C,M),
(
sevent(B),
mass_of_intersection_with(B,D,C,M),
C \= []
),
X),
%length(X,NX),
%nl,write(find(NX,X)),
findall(Q,
member((_,Q),X),
BX0),
sum(BX0,M0),
sort(E,E1),
findall(Q,
member((E1,Q),X),
BX1),
sum(BX1,M1),
Yq = M1 /M0,
Y is Yq.
% Updating bel by Dempster-Shafer rule
%---------------------------------------------------
update_bel(E/D,Xq,X):-
event(E),
event(D),
% \+ D = [],
findall(Yq,
(
sevent(F),
subset(F,E),
update_mass(F/D,Yq,_Y)
),
G),
sum_of_fractions(G,Xq,X,_).
% sum of fractions switched by case of zero divisor
sum_of_fractions(G,Xq,X,no):-
\+ (member(_/D,G),0 is D),
sum_eq(G,Xq,X1),
X is X1.
sum_of_fractions(G,Xq,X,yes):-
member(_/D,G),
0 is D,
Xq = sum(G),
X = indefinite.
% updating bel only when an event is of sorted states.
update_sbel(E/D,Xq,X):-
sevent(E),
sevent(D),
% \+ D = [],
update_bel(E/D,Xq,X).
% a comparison.
% v(union(A,-B)) - v(-B)
% v_ds(A|B) = ------------------------
% 1 - v(-B)
update_bel_1(E/D,Xq,X):-
event(E),
event(D),
% \+ D = [],
c_event(F,D),
union(E,F,G),
bel(F,XFq,_),
bel(G,XGq,_),
Yq = (XGq - XFq),
Zq = (1 - XFq),
sum_of_fractions([Yq/Zq],Xq,X,_).
% a verification program code like as below may be convenient to you
% in order to verify the equality of three versions of update_bel.
%
% ?- update_sbel(E/D,_,C),(update_bel_2(E/D,_,F)->true;F=non).
% another comparison.
% v~(B) - v~(intersect(-A,B))
% v_ds(A|B) = ----------------------------
% v~(B)
update_bel_2(E/D,Xq,X):-
event(E),
event(D),
% \+ D = [],
c_event(F,E),
intersection(D,F,G),
pos(D,YDq,_),
pos(G,YGq,_),
Yq = (YDq - YGq),
sum_of_fractions([Yq/YDq],Xq,X,_).
% Updating pos by Dempster-Shafer rule
%---------------------------------------------------
update_pos(E/D,Xq,X):-
event(E),
event(D),
\+ D = [],
findall(Yq,
(
sevent(F),
intersection(F,E,M),
M \= [],
update_mass(F/D,Yq,_Y)
),
G),
sum_of_fractions(G,Xq,X,_).
update_spos(E/D,Xq,X):-
sevent(E),
sevent(D),
% \+ D = [],
update_pos(E/D,Xq,X).
% a code for test:
%
% ?- update_sbel(E/D,_,C),_,F),
% c_event(G,E),(update_pos(G/D,_,F)->true;F=non).
% comparison
% v~(intersection(A,B))
% v~ds(A|B) = ------------------------
% v~(B)
update_pos_1(E/D,Xq,X):-
event(E),
event(D),
\+ D = [],
intersection(D,E,G),
pos(G,Yed,_),
pos(D,Yd,_),
sum_of_fractions([Yed/Yd],Xq,X,_).
% a code for test:
%
% ?- update_spos(A,_,C),_,F),
% (update_pos_1(A,_,F)->true;F=non).
update_pos_2(E/D,Xq,X):-
event(E),
event(D),
\+ D = [],
intersection(D,E,G),
pos_1(G,Yed,_),
pos_1(D,Yd,_),
sum_of_fractions([Yed/Yd],Xq,X,_).
%%%%%% demo %%%%%%%%%%
/*
% demo for example model trade1.
?- sevent(A),update_pos_2(A/[2,3],_,B),B>0.
A = [2]
B = 0.666667 ;
A = [3]
B = 0.666667 ;
A = [1, 2]
B = 0.666667 ;
A = [1, 3]
B = 0.666667 ;
A = [2, 3]
B = 1 ;
A = [1, 2, 3]
B = 1 ;
No
*/
% Updating bel by upper-lower probabilities conditioning
%----------------------------------------------------------------
/*
v(intersect(A,B))
v_ul(A|B) = -----------------------------------------
v(intersect(A,B)) + v~(intersect(-A,B))
*/
update_bel_ul(E/D,Xq,X):-
event(E),
event(D),
c_event(F,E),
intersection(E,D,G),
intersection(F,D,H),
bel(G,YGq,_),
pos(H,YHq,_),
Yq = YGq,
Zq = (YGq + YHq),
sum_of_fractions([Yq/Zq],Xq,X,_).
% Updating pos by upper-lower probabilities conditioning
%----------------------------------------------------------------
/*
v~(intersect(A,B))
v~ul(A|B) = -----------------------------------------
v~(intersect(A,B)) + v(intersect(-A,B))
*/
update_pos_ul(E/D,Xq,X):-
event(E),
event(D),
c_event(F,E),
intersection(E,D,G),
intersection(F,D,H),
pos(G,YGq,_),
bel(H,YHq,_),
Yq = YGq,
Zq = (YGq + YHq),
sum_of_fractions([Yq/Zq],Xq,X,_).
%%%%%% demo %%%%%%%%%%
/*
% sample executions of updating for the example 1:
?- update_sbel(A/[b,y],_,B).
A = []
B = 0 ;
A = [r]
B = 0 ;
A = [b]
B = 0 ;
A = [y]
B = 0 ;
A = [b, r]
B = 0 ;
A = [r, y]
B = 0 ;
A = [b, y]
B = 1 ;
A = [b, r, y]
B = 1 ;
No
?- sevent(A),update_bel_ul(A/[b,y],_,B).
A = []
B = 0 ;
A = [r]
B = 0 ;
A = [b]
B = 0 ;
A = [y]
B = 0 ;
A = [b, r]
B = 0 ;
A = [r, y]
B = 0 ;
A = [b, y]
B = 1 ;
A = [b, r, y]
B = 1 ;
No
?-
% Dempster-Shafer rule for the example 2 (Dow and Werlang,1992):
case 1) H=[1]
v([1]|[1])
= [v([1] U [1]c)-v([1]c)]/[1-v([1]c)]
= [v([1] U [2,3])-v([2,3])]/[1-v([2,3])]
= (1-1/2)/(1-1/2)
= 1
v([2]|[1]) = [v([2,3])-v([2,3])]/[1-v([2,3])]
= 0.
v([3]|[1]) = [v([2,3])-v([2,3])]/[1-v([2,3])]
= 0.
v([1,2]|[1]) = [v([1,2,3])-v([2,3])]/[1-v([2,3])]
= 1.
v([1,3]|[1]) = [v([1,2,3])-v([2,3])]/[1-v([2,3])]
= 1.
v([2,3]|[1]) = [v([2,3])-v([2,3])]/[1-v([2,3])]
= 0.
v([1,2,3]|[1]) = [v([1,2,3])-v([2,3])]/[1-v([2,3])]
= 1.
?- sevent(A),update_bel(A/[1],_,B),B>0.
A = [1]
B = 1 ;
A = [1, 2]
B = 1 ;
A = [1, 3]
B = 1 ;
A = [1, 2, 3]
B = 1 ;
No
?-
case 2) H=[2,3]
v([1]|[2,3]) =[v([1] U [2,3]c)-v([2,3]c)] / [1-v([2,3]c)]
= [ v([1] U [1])-v([1])]/[1-v([1])]
=0.
v([2]|[2,3]) = [v([1,2])-v([1])]/[1-v([1])]
= 1/3.
v([3]|[2,3]) = [v([1,3])-v([1])]/[1-v([1])]
= 1/3.
v([1,2]|[2,3]) = [v([1,2])-v([1])]/[1-v([1])]
= 1/3.
v([1,3]|[2,3]) = [v([1,3])-v([1])]/[1-v([1])]
= 1/3.
v([2,3]|[2,3]) = [v([1,2,3])-v([1])]/[1-v([1])]
= 1.
v([1,2,3]|[2,3]) = [v([1,2,3])-v([1])]/[1-v([1])]
= 1.
?- sevent(A),update_bel(A/[2,3],_,B),B>0.
A = [2]
B = 0.333333 ;
A = [3]
B = 0.333333 ;
A = [1, 2]
B = 0.333333 ;
A = [1, 3]
B = 0.333333 ;
A = [2, 3]
B = 1 ;
A = [1, 2, 3]
B = 1 ;
No
?-
*/
%
% ----------------------------------------------------------- %
% Utilities for basic list operations
% ----------------------------------------------------------- %
% edited: 14 Feb 2003. (imported from: set1.pl)
% edited: 19 Feb 2004. bugfix. case of generating equivalent set.
% edited: 28 Feb 2004. added range_of/2.
%
range_of([Min,Max],A):-
\+ var(A),
length(A,_),
sort(A,[Min|R]),
last(Max,[Min|R]).
% equality for pair of sets
% ----------------------------------------------------------- %
seteq(X,Y):-
\+ var(X),
length(X,N),
\+ var(Y),
length(Y,N),
sort(X,Sort),
sort(Y,Sort).
seteq(X,Y):-
\+ var(X),
length(X,N),
var(Y),
bag1(Y,X,N).
%
%
% descending/ascending natural number sequence less than N.
% ----------------------------------------------------------- %
dnum_seq([],N):-N<0,!.
dnum_seq([0],1).
dnum_seq([A|Q],N):-
A is N - 1,
length(Q,A),
dnum_seq(Q,A).
anum_seq(Aseq,N):-dnum_seq(Dseq,N),sort(Dseq,Aseq).
dnum_seq1(Q,N):-
M is N + 1,
dnum_seq(Q0,M),
subtract(Q0,[0],Q).
anum_seq1(Q,N):-
M is N + 1,
anum_seq(Q0,M),
subtract(Q0,[0],Q).
%
% ----------------------------------------------------------- %
bag0([],_A,0).
bag0([C|B],A,N):-
length([C|B],N),
bag0(B,A,_N1),
member(C,A).
zeros(Zero,N):-bag0(Zero,[0],N).
ones(One,N):-bag0(One,[1],N).
%
% bag1/3 : do not allow multiplicity
% ----------------------------------------------------------- %
bag1([],_A,0).
bag1([C|B],A,N1):-
\+var(A),
length(A,L),
anum_seq(Q,L),
member(N,Q),
length(B,N),bag1(B,A,N),N1 is N + 1,
member(C,A),\+member(C,B).
%
% ordering/3
% ----------------------------------------------------------- %
ordering(A,B,C):-bag1(A,B,C).
% a sequence of binary choice for a list:
%--------------------------------------------------
list_projection([],[],[]).
list_projection([X|Y],[_A|B],C):-
X = 0,
list_projection(Y,B,C).
list_projection([X|Y],[A|B],[A|C]):-
X = 1,
list_projection(Y,B,C).
%
% subset_of/3 : subset-enumeration
% ----------------------------------------------------------- %
subset_of(A,N,As):-
length(As,L),
length(D,L),
list_projection(D,As,B),
length(B,N),
sort(B,A).
%
% complementary list projection
%--------------------------------------------------
c_list_projection([],[],[]).
c_list_projection([X|Y],[_A|B],C):-
X = 1,
c_list_projection(Y,B,C).
c_list_projection([X|Y],[A|B],[A|C]):-
X = 0,
c_list_projection(Y,B,C).
c_list_projection_1(X,Y,Z):-
complement(X,XC,_N),
list_projection(XC,Y,Z).
complement(X,XC,N):-
\+ (var(X),var(N)),
bag0(X,[1,0],N),
zeros(Zero,N),
ones(One,N),
replace(X,Zero,One,XC).
%
% sort without removal of duplicates
%--------------------------------------------------
asort(A,B):-
sort(A,C),
bagof(CK,
J^K^(
nth1(J,C,CK),
nth1(K,A,CK)
),
B).
% sort by a list of ordering
%--------------------------------------------------
% added: 14 Jan 2004.
% modified: 16 Jan 2004.
sort_by_list(X,OL,Y):-
(var(X)->bag1(X,OL,_);true),
list_projection(_,OL,Y),
seteq(X,Y).
% ----------------------------------------------------------- %
% Arithmetic
% ----------------------------------------------------------- %
%
% evaluation of a nummerical value
% ----------------------------------------------------------- %
eval_number(X,X1):-
X1 is X,
number(X1).
% maximal solution for given goal clause : a naive solver
%---------------------------------------------------------
max(X,Goal):-
% X: the objective variable,
% Goal: the objective function and constraints,
setof((X,Goal),Goal,Z),
member((X,Goal),Z),
\+ (
member((Y,_),Z),
Y > X
).
%
% max,min
% ----------------------------------------------------------- %
max_of(X,[X]).
max_of(Z,[X|Y]):-
max_of(Z1,Y),
(X > Z1 -> Z=X; Z=Z1).
min_of(X,[X]).
min_of(Z,[X|Y]):-
min_of(Z1,Y),
(X < Z1 -> Z=X; Z=Z1).
% count frequency of occurence of the specified value of variable, M.
% ----------------------------------------------------------- %
% note: Both of M and L have to be specified.
counter(N,M,L):-
length(L,_),
findall(M,member(M,L),Mx),
length(Mx,N).
% sum
% ----------------------------------------------------------- %
sum([],0).
sum([X|Members],Sum):-
sum(Members,Sum1),
Sum is Sum1 + X.
% added: 27 feb 2003.
sum_eq([],0,0).
sum_eq([X],X,X).
sum_eq([X|Members],Eq,Sum):-
Members \= [],
sum_eq(Members,Eq1,Sum1),
Eq = Eq1 + X,
Sum is Sum1 + X.
%
% product
% ----------------------------------------------------------- %
product([],1).
product([X|Members],Z):-
product(Members,Z1),
%number(X),
Z is Z1 * X.
% allocation
% ----------------------------------------------------------- %
allocation(N,A,[X|Y]):-
allocation(N,A,A,[X|Y]).
allocation(0,_,0,[]).
allocation(N,A,B,[X|Y]):-
integer(A),
length([X|Y],N),
allocation(_N1,A,B1,Y),
K is A - B1 + 1,
length(L,K),
nth0(X,L,X),
B is B1 + X.
%
% probability (percentile) by using allocation
% ----------------------------------------------------------- %
probabilities(0,[]).
probabilities(N,[X|Y]):-
integer(N),
length([X|Y],N),
allocation(N,100,[X|Y]).
% combination and factorial with out commitment
% ----------------------------------------------------------- %
% added: 8--9 mar 2004.
combination(N,K,NCK):-
integer(N),
integer(K),
N >= 0,
N >= K,
factorial_1(N,FN),
M is N - K,
factorial_1(M,FM),
subtract(FN,FM,FN_above_K),
factorial_1(K,FK),
findall(A,(member(X,FK),A = 1/X),Denominators),
append(Denominators,FN_above_K,SetForProduct),
product(SetForProduct,NCK).
factorial_1(0,[]).
factorial_1(N,[N|F]):-
integer(N),
N >= 1,
N1 is N - 1,
factorial_1(N1,F).
% cf., combination with factorial with commitment.
combination_0(N,K,NCK):-
integer(N),
integer(K),
N >= 0,
N >= K,
factorial(N,FN),
factorial(K,FK),
M is N - K,
factorial(M,FM),
NCK is FN / FK /FM.
factorial(1,1).
factorial(N,F):-
integer(N),
N > 1,
N1 is N - 1,
factorial(N1,F1),
F is N * F1.
integer_between(K,[L,U]):-
integer(L),
integer(U),
L =< U,
M is U - L,
length(X,M),
nth1(J,[_|X],_),
K is L + J - 1.
%%%%%%%% demo %%%%%%%%%
/*
?- N =4, findall(c(N,K)=B,(integer_between(K,[0,N]),
combination(N,K,B)),W).
N = 4
K = _G167
B = _G170
W = [c(4, 0)=1, c(4, 1)=4, c(4, 2)=6, c(4, 3)=4, c(4, 4)=1]
Yes
?-
*/
% ----------------------------------------------------------- %
% output to file.
% ----------------------------------------------------------- %
tell_test(Goal):-
open('tell.txt',write,S),
tell('tell.txt'),
Goal,
current_stream('tell.txt',write,S),
tell(user),wn(end),
close(S).
%
tell_goal(File,G):-
(current_stream(File,write,S0)->close(S0);true),
open(File,write,S),
tell(File),
nl,
tstamp('% file output start time ',_),
nl,
write('%---------- start from here ------------%'),
nl,
G,
nl,
write('%---------- end of data ------------%'),
nl,
tstamp('% file output end time ',_),
tell(user),
close(S),
% The following is to cope with the duplicated stream problem.
(current_stream(File,write,S1)->close(S1);true).
% 成功するゴールをすべて保存
%--------------------------------
tell_goal(File,forall,G):-
G0 = (nl,write(G),write('.')),
G1 = forall(G,G0),
tell_goal(File,G1).
% 実行時刻の取得
%--------------------------------
tstamp(no,T):-
get_time(U),
convert_time(U,A,B,C,D,E,F,_G),
T = [date(A/B/C), time(D:E:F)],
nl.
tstamp(Word,T):-
\+ var(Word),
Word \= no,
get_time(U),
convert_time(U,A,B,C,D,E,F,_G),
T = [date(A/B/C), time(D:E:F)],
% format('~`.t~t~a~30|~`.t~t~70|~n',[Word]),
write((Word,T)),
nl.
% 実行時刻の取得2
%--------------------------------
% added: 24 Feb 2004.
% modified: 8 Mar 2004.
stopwatch_0(Goal,TD):-
get_time(TS),
Goal,
get_time(TF),
TD is TF - TS.
stopwatch(Goal,TD):-
stopwatch_0(Goal,TD),
nl,
write('% time elapsed (sec): '),
write(TD),
nl.
stopwatch_of_iterated_goals(_Goal,0,0,Display):-
rule_of_display_number_in_stopwatch(Display,JOB),
JOB.
stopwatch_of_iterated_goals(Goal,TD,Iteration,Display):-
number(Iteration),
Iteration > 0,
init_count_of_display,
rule_of_display_number_in_stopwatch(Display,JOB),
stopwatch(
forall(
(
Goal, %write(Goal),
update_count_of_display(K),
(K>Iteration->!,fail;true)
),
JOB
),
TD
).
rule_of_display_number_in_stopwatch(no,true):-
!.
rule_of_display_number_in_stopwatch(yes,display_counter).
% a display of counter for iterated goals.
%---------------------------------------
% added: 22 Feb 2004.
% modified: 8--9 Mar 2004. minor bugfix.
:- dynamic temp_count_of_display/1.
temp_count_of_display(0).
init_count_of_display:-
abolish(temp_count_of_display/1),
assert(temp_count_of_display(0)).
update_count_of_display(K):-
retract(temp_count_of_display(K0)),
K is K0 + 1,
assert(temp_count_of_display(K)).
update_and_display_counter:-
update_count_of_display(_),
display_counter.
display_counter:-
temp_count_of_display(K),
nl,
write([K]).
% a sampling tool for estimating time complexity.
%---------------------------------------
% added: 8--9 Mar 2004.
get_average_time_by_sampling(H/LA,N,((SampleTime + TotalTime) / N)=AverageTime):-
length(A,LA),
Goal=..[H|A],
stopwatch_0(Goal,SampleTime),
rule_for_decide_number_of_trials(Goal,SampleTime,N),
(N = 0 -> !,fail; true),
N1 is N - 1,
length(B,LA),
Goal1=..[H|B],
stopwatch_of_iterated_goals(Goal1,TotalTime,N1,no),
AverageTime is (SampleTime + TotalTime) / N,
!.
rule_for_decide_number_of_trials(_,_,Trials):-
integer(Trials). % conform to user.
rule_for_decide_number_of_trials(_,SampleTime,20):-
SampleTime=<1.
rule_for_decide_number_of_trials(_,SampleTime,10):-
SampleTime>1,
SampleTime=<5.
rule_for_decide_number_of_trials(_,SampleTime,3):-
SampleTime>5,
SampleTime=<10.
rule_for_decide_number_of_trials(_,SampleTime,1):-
SampleTime>10.
% for debug:
%---------------------
check_if_false(_,G):-
G,!.
check_if_false(A,_G):-
nl, write('**** fail ****'),write(A),
nl, write('continue ? > '),read(y).
%------------------------------
% References
%------------------------------
% modified: 16 Feb 2004. formatted as lists.
references1:-
R1=['% References as for belief functions and decison under uncertainty:'
,
[[1],'Shafer,G.',
'Mathematical Theory of Evidence', 'Princeton University Press',1976]
,
[[2], 'Dempster, A.P.',
'Upper and lower probabilities induced by a multivalued mapping',
' Annals of Mathematical Statistics', 38: 325-339, 1967]
,
[[3], 'Moral,S. and De Campos, L.M.',
'Updating uncertain information.',
'In the Proceedings of IPMU90', 'LNCS 521', 'Springer', 'pp.58-67',1991]
,
[[4],'Dow, J. and S. R. da Costa Werlang',
'Excess volatility of stock prices and Knightian uncertainty',
'European Economic Review',36: 631-638, 1992]
,
[[5], 'Jaffray J-.Y. and P. Wakker',
'Decision making with belief functions':
'compatibility and incompatibility with the sure-thing principle',
'Journal of Risk and Uncertainty', 8: 255-271, 1994]
,
[[6], 'Gilboa,I. and D. Schmeidler',
'Updating ambiguous beliefs',
'Journal of Economic Theory', 59: 33-49, 1993]
,
[[7], 'Mukerji, S.',
'Understanding the nonadditive probability decision model',
'Economic Theory', 9: 23-46,1997]
,
[[8], 'Schmeidler, D.',
'Subjective probability and expected utility without additivity',
'Econometrica', 57: 571-587, 1989]
,
[[9], 'Gilboa, I. and D. Schmeidler',
'Maxmin expected utility with non-unique prior',
'Journal of Mathematical Economics', 18: 141-153, 1989]
],
display_all_lines(R1).
references2:-
R2=['% References as for games under uncertainty:'
,
[[10], 'Dow, J. and S.R.C. Werlang',
'Nash equilibrium under Knightian uncertainty':
' breaking down backward induction',
'Journal of Economic Theory', 64: 305-324, 1994]
,
[[11], 'Lo, K.C.',
'Equilibrium in beliefs under uncertainty',
'Journal Economic Theory', 71: 443-484,1996]
,
[[12], 'Eichberger, J. and D. Kelsey',
'Non-additive beliefs and strategic equilibria',
'Games and Economic Behavior', 30: 183-215, 2000]
,
[[13], 'Marinacci, M.',
'Ambiguous games',
'Games and Economic Behavior', 31: 191-219, 2000]
,
[[14], 'Groes, E. et al.',
'Nash equilibrium with lower probabilities',
'Theory and Decision', 44: 37-66, 1998]
],
display_all_lines(R2).
%------------------------------
% Welcome.
%------------------------------
wn(Z):-
write(Z),nl.
display_all_lines(A):-
forall(member(B,A),(nl,write(B))).
:- headline.
%------------------------------
% initial model setting.
%------------------------------
% modified: 13,14 Feb 2004.
% modified: 10 Mar 2004. included the complete messages into set_mode.
:- init_or_inherit, set_model.
/****************************************************
% Appendix 1.
% mini inductive algorithms for computes
% approximately continuous subsets of numbers
****************************************************/
% 14 Feb, 27--28 2004.
% make patitions of intervals with constant difference
%--------------------------------------------------
% added: 14 Feb 2004.
% modified: 28 Feb 2004. bugfix. for repeated leaps.
intervals_decomposition(A, [D|B], C, D, E):-
number(A),
\+ var(C),
intervals_decomposition_1(_, A, B, C, D, E).
% rule for checking the reachablity within given difference.
interval_decomposition_rule(F,L,C,G) :-
\+ var(G),
!,
X is (L - C)^2,
(X =< F^2 + 0.0000001 -> G ==in;G==out).
interval_decomposition_rule(F,L,C,G) :-
var(G),
!,
X is (L - C)^2,
(X =< F^2 + 0.0000001 ->G =in; G=out).
intervals_decomposition_1([1], _F, [], [C], [C,C],in).
intervals_decomposition_1([2], F,B, [C|D], [C,U], in) :-
intervals_decomposition_1(_, F, B, D, [L,U], in),
interval_decomposition_rule(F,L,C,in).
intervals_decomposition_1([3], F,[[L,U]|B], [C|D], [C,C], out) :-
intervals_decomposition_1(_, F, B, D, [L,U], in),
interval_decomposition_rule(F,L,C,out).
intervals_decomposition_1([4], F, B, [C|D], [C,U],in) :-
intervals_decomposition_1(_, F, B, D, [U,U], out),
interval_decomposition_rule(F,U,C,in).
intervals_decomposition_1([5], F, [[U,U]|B], [C|D], [C,C],out) :-
intervals_decomposition_1(_, F, B, D, [U,U], out),
interval_decomposition_rule(F,U,C,out).
%%%%%% demo %%%%%%%%%%
/*
?- intervals_decomposition(1,B,[1,2,4,5,6,9,10,11],G,H).
B = [[1, 2], [4, 6], [9, 11]]
G = [1, 2]
H = in
Yes
*/
% rectangle decomposition which is 2 or more dimensional
% generalization of intervals_decomposition/5.
%--------------------------------------------------
% added: 27--28 Feb 2004.
% [[1,3],[2,1],[2,2],[3,3],[4,3],[5,3],[6,1]]
% => [[[1,1],[3,3]],[[3,5],[3,3]],[[2,2],[1,2]],[[5,5],[2,2]]]
select_interval_for_x_levels(Data,[L,U],Levels):-
findall(X,member([X,_],Data),AllLevels0),
sort(AllLevels0,AllLevels),
member(L,AllLevels),
member(U,AllLevels),
findall(X,(member(X,AllLevels),X>=L,X= F is 1; number(F)),
\+ var(Data),
db_projection(_Pjt,Levels0,Data,Values0),
Levels0 \= [],
sort(Levels0,Levels),
sort(Values0,Values),
intervals_decomposition(F,[[XL,XU]],Levels,_,in),
intervals_decomposition(F,[[YL,YU]],Values,_,in).
rectangles_decomposition_0(F,Data,Levels,Range):-
% select a range of marginals which is singlton.
rectangles_decomposition_by_x(F,Data,Levels,Range),
forall(
product_of_lists([Levels,Range],X),
member(X,Data)
).
% maximal decomposition.
rectangles_decomposition(F,D,[Ll,Lu],[Bl,Bu]):-
rectangles_decomposition_0(F,D,[Ll,Lu],[Bl,Bu]),
\+ (
rectangles_decomposition_0(F,D,[L1l,L1u],[B1l,B1u]),
member([X,Y],[[Ll,L1l],[Bl,B1l],[Lu,L1u],[Bu,B1u]]),
0.00001 < (X - Y)^2,
L1l =< Ll,
B1l =< Bl,
L1u >= Lu,
B1u >= Bu
).
%%%%%% demo %%%%%%%%%%
/*
?- D=[[1,3],[2,1],[2,2],[3,3],[4,3],[5,2],[6,1]],
rectangles_decomposition(1,D,X,Y).
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 2], [6, 1]]
X = [6, 6]
Y = [1, 1] ;
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 2], [6, 1]]
X = [5, 5]
Y = [2, 2] ;
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 2], [6, 1]]
X = [3, 4]
Y = [3, 3] ;
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 2], [6, 1]]
X = [2, 2]
Y = [1, 2] ;
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 2], [6, 1]]
X = [1, 1]
Y = [3, 3] ;
No
?- D=[[1,3],[2,1],[2,2],[3,3],[4,3],[5,3],[6,1]],
rectangles_decomposition(1,D,X,Y).
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 3], [6, 1]]
X = [6, 6]
Y = [1, 1] ;
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 3], [6, 1]]
X = [3, 5]
Y = [3, 3] ;
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 3], [6, 1]]
X = [2, 2]
Y = [1, 2] ;
D = [[1, 3], [2, 1], [2, 2], [3, 3], [4, 3], [5, 3], [6, 1]]
X = [1, 1]
Y = [3, 3] ;
No
?-
*/
/***********************************************
% Appendix 2.
% Some naive inductive algorithms for
% the event intervals decomposition
***********************************************/
% cited from: ul_set.pl (1--4 Mar 2004)
%
%---------------------------------------------
%--- relation of two events -----
event_between((M,P),[L,U]):-
test_event(M,P),
test_event(L,_),
test_event(U,_),
subset(M,U),
subset(L,M).
event_beneath((X,P),(E,Q)):-
test_event(X,P),
test_event(E,Q),
E \= X,
subset(X,E).
event_above((X,P),(E,Q)):-
test_event(X,P),
test_event(E,Q),
E \= X,
subset(E,X).
event_incomparable_with((X,P),(E,Q)):-
test_event(X,P),
test_event(E,Q),
\+ subset(E,X),
\+ subset(X,E).
%--- event incomparabel with a events interval -----
event_incomparable_with_interval((X,P),[L,U]):-
event_between((L,_),[L,U]),
test_event(X,P),
\+ event_between((X,P),[L,U]),
\+ subset(U,X), % not above
\+ subset(X,L). % not bellow
%--- some constrained set of events -----
events_between(Set,P,[L,U]):-
event_between((L,_),[L,U]),
findall(M,
event_between((M,P),[L,U]),
Set).
events_beneath(Set,P,(L,Q)):-
test_event(L,Q),
findall(X,
event_beneath((X,P),(L,Q)),
Set).
events_above(Set,P,(U,Q)):-
test_event(U,Q),
findall(Y,
event_above((Y,P),(U,Q)),
Set).
events_incomparable_with(Set,P,(E,Q)):-
test_event(E,Q),
findall(Z,
event_incomparable_with((Z,P),(E,Q)),
Set).
events_incomparable_with_interval(Set,P,[L,U]):-
event_between((L,_),[L,U]),
findall(Z,
event_incomparable_with_interval((Z,P),[L,U]),
Set).
polarity(P):-
member(P,[in,out]).
%--- collection of the evidences -----
positive_evidences([L,U],[Pos1,Pos2,Pos3,Pos4]):-
events_between(Pos1,in,[L,U]),
events_beneath(Pos2,out,(L,_)),
events_above(Pos3,out,(U,_)),
events_incomparable_with_interval(Pos4,out,[L,U]).
negative_evidences([L,U],[Neg1,Neg2,Neg3,Neg4]):-
events_between(Neg1,out,[L,U]),
events_beneath(Neg2,in,(L,_)),
events_above(Neg3,in,(U,_)),
events_incomparable_with_interval(Neg4,in,[L,U]).
positive_evidences_within(E,[L,U],[Pos1,Pos2,Pos3]):-
test_event(E,_),
positive_evidences_within(E,[L,U],[P1,P2,P3]),
intersection(E,P1,Pos1),
intersection(E,P2,Pos2),
intersection(E,P3,Pos3).
negative_evidences_within(E,[L,U],[Neg1,Neg2,Neg3]):-
test_event(E,_),
negative_evidences_within(E,[L,U],[N1,N2,N3]),
intersection(E,N1,Neg1),
intersection(E,N2,Neg2),
intersection(E,N3,Neg3).
select_marginal_evidences_wrt_event(E,PNset1,PNset2):-
test_event(E,_),
findall(X,
(
member(A,PNset1),
%nl,write(member(A,PNset1)),
intersection(E,A,X)
%,nl,write(intersection(E,A,X))
),
PNset2).
%--- criteria for validating the hypothesis -----
decide_truth_value(_,Negatives,T):-
forall(member(E,Negatives),E==[]),
!,
T=true.
decide_truth_value(_,_,false).
%--- hypotheses -----
hypothesis(total,[L,U],Positives,Negatives,Y):-
test_event(L,in),
test_event(U,in),
Positives = [_Pos1,_Pos2,_Pos3,_Pos4],
Negatives = [_Neg1,_Neg2,_Neg3,_Neg4],
positive_evidences([L,U],Positives),
negative_evidences([L,U],Negatives),
decide_truth_value(Positives,Negatives,Y).
hypothesis(partial,[L,U],Positives,Negatives,true):-
events_between(Pos1,_,[L,U]),
Positives = [Pos1,_Pos2,_Pos3,_Pos4],
Negatives = [[],_Neg2,_Neg3,_Neg4],
positive_evidences([L,U],Positives),
negative_evidences([L,U],Negatives).
hypothesis(marginal(E),[L,U],[P1,P2,P3,P4],[N1,N2,N3,N4],Y):-
hypothesis(total,[L,U],[P01,P02,P03,P04],[N01,N02,N03,N04],_),
test_event(E,in),
findall(G,
(
member(F,[P01,P02,P03,P04,N01,N02,N03,N04]),
select_marginal_evidences_wrt_event(E,F,G)
),
[P1,P2,P3,P4,N1,N2,N3,N4]),
decide_truth_value([P1,P2,P3,P4],[N1,N2,N3,N4],Y).
hypothesis(restricted(E),[L,U],[P1,P2,P3,P4],[N1,N2,N3,N4],Y):-
hypothesis(total,[L,U],[P01,P02,P03,P04],[N01,N02,N03,N04],_),
all_test_events(S),
list_projection(_,S,E),
findall(X,
(
member(F,[P01,P02,P03,P04,N01,N02,N03,N04]),
intersection(E,F,X)
%,nl,write(intersection(E,F,X))
),
[P1,P2,P3,P4,N1,N2,N3,N4]),
decide_truth_value([P1,P2,P3,P4],[N1,N2,N3,N4],Y).
/***********************************************
% Appendix 3.
% Making database that can be used for
% the inputs of other data analysis tools
***********************************************/
% ----------------------------------------------------------- %
% Database-like operations by lists
% ----------------------------------------------------------- %
% added: 12--13 Feb 2004.
% old version : only for pair of lists.
product_of_two_lists(R1,R2,XR):-
\+ var(R1),
\+ var(R2),
findall([L1,L2],
(
member(L1,R1),
member(L2,R2)
),
XR).
% modified: 19 Feb 2004.
product_of_lists(LL,XL):-
\+ var(LL),
length(LL,_N),
forall(member(L,LL),(\+ var(L),length(L,_))),
product_of_lists_0(LL,[],XL).
product_of_lists_0([],_,[]).
product_of_lists_0([L|R],Q,[X|Y]):-
product_of_lists_0(R,[L|Q],Y),
member(X,L).
projection_of_profiles(PJT,XR,PXR1):-
projection_of_profiles_0(PJT,XR,PXR),
sort(PXR,PXR1).
projection_of_profiles_0(PJT,XR,PXR):-
\+ var(XR),
constant_number_of_attributes(N,XR),
length(L,N),
list_projection(PJT,L,_),
findall(R1,
(
member(R,XR),
list_projection(PJT,R,R1)
),
PXR).
constant_number_of_attributes(N,XR):-
setof(N,
L^(
member(L,XR),
length(L,N)
),
[N]).
%%%%%% demo %%%%%%%%%%
/*
?- product_of_lists([a,b,c],[1,2],XR),
projection_of_profiles(PJT,XR,XR1).
XR = [[a, 1], [a, 2], [b, 1], [b, 2], [c, 1], [c, 2]]
PJT = [0, 0]
XR1 = [[]] ;
XR = [[a, 1], [a, 2], [b, 1], [b, 2], [c, 1], [c, 2]]
PJT = [0, 1]
XR1 = [[1], [2]] ;
XR = [[a, 1], [a, 2], [b, 1], [b, 2], [c, 1], [c, 2]]
PJT = [1, 0]
XR1 = [[a], [b], [c]] ;
XR = [[a, 1], [a, 2], [b, 1], [b, 2], [c, 1], [c, 2]]
PJT = [1, 1]
XR1 = [[a, 1], [a, 2], [b, 1], [b, 2], [c, 1], [c, 2]] ;
No
?-
*/
% making database from attribute-value list.
%------------------------------------------------
% added: 13 Feb 2004.
cretab(F,D,T):-
create_table_from_attr_value_list(F,D,T).
collect_fields_of_table_from_data(Label,Data):-
var(Label),
\+ var(Data),
findall(A,(member(R,Data),member([A,_],R)),Attrs),
sort(Attrs,Label).
create_fields_of_table_if_unspecified(Label,Data):-
var(Label),!,
collect_fields_of_table_from_data(Label,Data).
create_fields_of_table_if_unspecified(_Label,_Data).
create_table_from_attr_value_list(Label,Data,Table):-
\+ var(Data),
%var(Table),
create_fields_of_table_if_unspecified(Label,Data),
findall(T,
(
member(Record,Data),
db_projection(_,Label, Record, T)
),
Table).
% db_projection(-P,-A, +B, -C).
% db_projection(-P,-A, +B, -C, -H).
%------------------------------------------------
% added: 13 Feb 2004.
% modified: 14 Feb 2004.
% P: projection operator {0,1}^n
% A: fields projected --- preserve occurred-sequence if unbound.
% B: list of [attribute,vale] data
% C: projected value table
% H: excluded fields
db_projection(A, B, C, D, E):-
var(B),
db_projection_1(A, B, C, D, E).
db_projection(A, B, C, D, E):-
\+ var(B),
db_projection_2(A, B, C, D, E).
db_projection(P,A, B, C):-
db_projection(P,A, B, C, _H).
db_projection_1([], [], [], [],[]).
db_projection_1([A|B], F, [C|D], E, G) :-
var(F),
A=0,
C = [Attr,_Value],
db_projection(B, F, D, E, H),
\+ member(Attr,F), % check once included.
(member(Attr,H)->G=H;G=[Attr|H]).
db_projection_1([A|B], G, [C|D], [Value|E], H) :-
var(G),
A=1,
C = [Attr,Value],
db_projection(B, F, D, E, H),
\+ member(Attr,H), % check once excluded.
(member(Attr,F)->G=F;G=[Attr|F]).
db_projection_2([], _, [], [],[]).
db_projection_2([A|B], F, [C|D], G, H) :-
\+ var(F),
C = [Attr,V],
db_projection_2(B, F, D, E, H),
%nl,write(db_projection_2(B, F, D, E, H)),
(member(Attr,F)->A=1;A=0),
(member(Attr,F)->G=[V|E];G=E).
db_projection_with_missing_values(MV,Attrs,Data,PV):-
\+ var(Attrs),
\+ var(Data),
(var(MV)->MV='-';true),
findall(V,
(
member(A,Attrs),
(member([A,V],Data)->true;V=MV)
),
PV).
%%%%%% demo %%%%%%%%%%
/*
?- db_projection_with_missing_values('-',[a,b,d],[[a,1],[b,2],[c,3]],PV).
PV = [1, 2, -]
Yes
?- db_projection_with_missing_values('-',[a,b,c],[[a,1],[b,2],[c,3]],PV).
PV = [1, 2, 3]
Yes
?- db_projection_with_missing_values('-',[a,b],[[a,1],[b,2],[c,3]],PV).
PV = [1, 2]
Yes
?- db_projection_with_missing_values('-',[c,a,b],[[a,1],[b,2],[c,3]],PV).
PV = [3, 1, 2]
Yes
?-
*/
% format a table data into the text database (.csv) file.
%------------------------------------------------
db_beleq(L):- % label row
db_labels_for_equilibrium_in_beliefs(L).
db_beleq(T):-
db_row_for_equilibrium_in_beliefs(T,_,_).
save_equilibria:-
tell_goal('be.txt', forall, db_beleq(_Z)).
:- dynamic temp_db_beleq/1.
% batch program to create the table of equilibria in beliefs generated.
%-------------------------------------------------------------------
create_db_table_for_equilibria_in_beliefs:-
abolish(temp_db_beleq/1),
fail.
create_db_table_for_equilibria_in_beliefs:-
db_beleq(T),
assert(temp_db_beleq(T)),
fail.
create_db_table_for_equilibria_in_beliefs:-
findall(a,temp_db_beleq(_),W),
length(W,N),
nl,write(N),
write(' cases has created.').
a_header_for_label_row(W,S,K,C,H):-
nth1(K,[W,W,S,S,S,S],C),
nth1(K,[
bpa1:X,bpa2:X,
support1:X,support2:X,
acts1:X,acts2:X
],H),
member(D,C),
flatten(D,E),
string_to_atom(E,X).
db_labels_for_equilibrium_in_beliefs(L):-
all_sevents(W),
states(S),
findall(H,
(
a_header_for_label_row(W,S,_K,_C,H)
),
L).
db_row_for_equilibrium_in_beliefs(T,N,[V1,V2,J1,J2,J3,J4]):-
all_sevents(W),
states(S0),
equilibrium_in_beliefs([P1,P2],[S1,S2],[R1,R2]),
db_projection_with_missing_values(0,W,P1,V1),
db_projection_with_missing_values(0,W,P2,V2),
list_projection(J1,S0,S1),
list_projection(J2,S0,S2),
translate_action_profile_into_events([R1,R2],[XR1,XR2]),
list_projection(J3,S0,XR1),
list_projection(J4,S0,XR2),
findall(D,
(
member(C,[V1,V2,J1,J2,J3,J4]),
member(D,C)
),
T),
length(T,N).
% a light analyzer for the equilibria in beliefs database
%-------------------------------------------------------------------
select_db_beleq((A,OP,V),Data):-
\+ var(A),
(\+ var(OP)-> true; OP='='),
(\+ var(V)-> true; V is 1),
db_labels_for_equilibrium_in_beliefs(Labels),
(
nth1(K,Labels,A)
->
true
;
(
nl,
write('no such field.')
)
),
temp_db_beleq(Data),
nth1(K,Data,D),
G=.. [OP,D,V],
G.
select_db_beleq([],Data):-
temp_db_beleq(Data).
select_db_beleq([(A,OP,V)|Conditions],Data):-
select_db_beleq(Conditions,Data),
\+ var(Conditions),
select_db_beleq((A,OP,V),Data).
% end of the program.
%
return to front page.