% blocking system % 2007.8.14-15 % language: prolog % program: block.pl % creator: Kenryo Indo % reference: J. Edmonds, and D. R. Fulkerson (1970), % Bottleneck extrema, Journal of Combinatorial Theory, 8: 299-306. % domain %dm([a,b]). % dm([a,b,c]). x(A):- dm(E),member(A,E). % bipartition (a subset-complement pair) bp(P,Q):- dm(E),prjct(E,_,P,Q). % family of subsets (or a set of coalitions) w(R):- findall(P,bp(P,_),L),prjct(L,_,R,_),R\=[]. % projection prjct([],[],[],[]). prjct([X|E],[1|B],[X|A],C):-prjct(E,B,A,C). prjct([X|E],[1|B],A,[X|C]):-prjct(E,B,A,C). /* ?- bp(O,L). O = [a, b, c] L = [] ; O = [a, b] L = [c] Yes ?- w(R). R = [[a, b, c], [a, b], [a, c], [a], [b, c], [b], [c], []] ; R = [[a, b, c], [a, b], [a, c], [a], [b, c], [b], [c]] ; R = [[a, b, c], [a, b], [a, c], [a], [b, c], [b], []] Yes */ % clutter --- a family who has no proper subset relation cl(R):- findall(P,bp(P,_),L),cl_prjct(L,_,R),R\=[]. cl_prjct([],[],[]). cl_prjct([X|E],[1|B],[X|A]):- cl_prjct(E,B,A), \+ is_proper_subset_cumulatively(X,_,A). cl_prjct([_|E],[0|B],A):- cl_prjct(E,B,A). is_proper_subset_cumulatively(X,S,C):- member(S,C),S\=X,(subset(X,S);subset(S,X)). cl_1(R):- w(R), \+ is_proper_subset(_,_,R). is_proper_subset(S,P,R):- member(S,R),member(P,R),P\=S,subset(P,S). /* ?- cl(R),nl,write(R),fail. [[a, b, c]] [[a, b], [a, c], [b, c]] [[a, b], [a, c]] [[a, b], [b, c]] [[a, b], [c]] [[a, b]] [[a, c], [b, c]] [[a, c], [b]] [[a, c]] [[a], [b, c]] [[a], [b], [c]] [[a], [b]] [[a], [c]] [[a]] [[b, c]] [[b], [c]] [[b]] [[c]] [[]] No */ % functions fct([],[],[]). fct([X|A],[R|V],[(X,R)|F]):-rg(R),fct(A,V,F). rg(K):- length(L,1),nth0(K,[_|L],_). f(Fv,F):- dm(E),fct(E,Fv,F). /* ?- f(A,B). A = [0, 0, 0] B = [ (a, 0), (b, 0), (c, 0)] ; A = [0, 0, 1] B = [ (a, 0), (b, 0), (c, 1)] Yes */ % min, max (cited from: math1.pl) 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). % X: the objective variable, % Goal: the objective function and constraints, min(X,Goal):- max(Z,(Goal,Z is -X)). max(X,Goal):- setof((X,Goal),Goal,Z), member((X,Goal),Z), \+ ( member((Y,_),Z), Y > X). % min-max (the LHS of blocking system) is_a_max_in_family(M,S,R,F):- (var(R)->w(R);true), (var(F)->f(_,F);true), (var(S)->member(S,R);true), max(M,( member(X,S),member((X,M),F) )), !. min_max(Min,Maxs,R,F):- w(R), f(_,F), findall(M, ( member(S,R), is_a_max_in_family(M,S,R,F) ), Maxs), min_of(Min,Maxs). /* % demo for a two-element domain ?- is_a_max_in_family(M,S,R,F). M = 0 S = [a, b] R = [[a, b], [a], [b], []] F = [ (a, 0), (b, 0)] ; No ?- min_max(M,Ms,R,F). M = 0 Ms = [0, 0, 0] R = [[a, b], [a], [b], []] F = [ (a, 0), (b, 0)] ; M = 0 Ms = [1, 0, 1] R = [[a, b], [a], [b], []] F = [ (a, 0), (b, 1)] Yes ?- */ % max-min (the RHS of blocking system) is_a_min_in_family(M,S,R,F):- (var(R)->w(R);true), (var(F)->f(_,F);true), (var(S)->member(S,R);true), min(M,( member(X,S),member((X,M),F) )), !. max_min(Max,Mins,R,F):- w(R), f(_,F), findall(M, ( member(S,R), %nl,write(S), is_a_min_in_family(M,S,R,F) %,write('->min':M) ), Mins), max_of(Max,Mins). /* ?- max_min(M,Ms,R,F). [a, b]->min:0 [a]->min:0 [b]->min:0 [] M = 0 Ms = [0, 0, 0] R = [[a, b], [a], [b], []] F = [ (a, 0), (b, 0)] ; [a, b]->min:0 [a]->min:0 [b]->min:1 [] M = 1 Ms = [0, 0, 1] R = [[a, b], [a], [b], []] F = [ (a, 0), (b, 1)] Yes */ % blocking system bs(R,S):- w(R),w(S), \+ gap_in_bs(_,R,S,_,_). abs(R,S):- w(R),w(S), \+ \+ gap_in_bs(_,R,S,_,_). gap_in_bs(M,R,S,F,1):- min_max(M,_,R,F), \+ max_min(M,_,S,F). gap_in_bs(M,R,S,F,2):- max_min(M,_,S,F), \+ min_max(M,_,R,F). % blocker b(R,S):- cl(R),bs(R,S),cl(S). /* % Edmonds and Fulkerson's Theorem for two element set. ?- b(R,S),nl,write(' cl-b':R-S),fail. cl-b:[[a, b]]-[[a], [b]] cl-b:[[a], [b]]-[[a, b]] cl-b:[[a]]-[[a]] cl-b:[[b]]-[[b]] cl-b:[[]]-[[]] No ?- b(R,S),b(S,B),nl,write(' c-b-bb':R-S-B),fail. c-b-bb:[[a, b]]-[[a], [b]]-[[a, b]] c-b-bb:[[a], [b]]-[[a, b]]-[[a], [b]] c-b-bb:[[a]]-[[a]]-[[a]] c-b-bb:[[b]]-[[b]]-[[b]] c-b-bb:[[]]-[[]]-[[]] No % For 3-element set ?- b(R,S),b(S,B),nl,write(' c-b-bb':R-S-B),fail. c-b-bb:[[a, b, c]]-[[a], [b], [c]]-[[a, b, c]] c-b-bb:[[a, b], [a, c], [b, c]]-[[a, b], [a, c], [b, c]]-[[a, b], [a, c], [b, c]] c-b-bb:[[a, b], [a, c]]-[[a], [b, c]]-[[a, b], [a, c]] c-b-bb:[[a, b], [b, c]]-[[a, c], [b]]-[[a, b], [b, c]] c-b-bb:[[a, b], [c]]-[[a, c], [b, c]]-[[a, b], [c]] c-b-bb:[[a, b]]-[[a], [b]]-[[a, b]] c-b-bb:[[a, c], [b, c]]-[[a, b], [c]]-[[a, c], [b, c]] c-b-bb:[[a, c], [b]]-[[a, b], [b, c]]-[[a, c], [b]] c-b-bb:[[a, c]]-[[a], [c]]-[[a, c]] c-b-bb:[[a], [b, c]]-[[a, b], [a, c]]-[[a], [b, c]] c-b-bb:[[a], [b], [c]]-[[a, b, c]]-[[a], [b], [c]] c-b-bb:[[a], [b]]-[[a, b]]-[[a], [b]] c-b-bb:[[a], [c]]-[[a, c]]-[[a], [c]] c-b-bb:[[a]]-[[a]]-[[a]] c-b-bb:[[b, c]]-[[b], [c]]-[[b, c]] c-b-bb:[[b], [c]]-[[b, c]]-[[b], [c]] c-b-bb:[[b]]-[[b]]-[[b]] c-b-bb:[[c]]-[[c]]-[[c]] c-b-bb:[[]]-[[]]-[[]] No */ % other demos for two alternative domain /* ?- bs(R,S),R@