% 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@
return to front page.