OKlibrary  0.2.1.6
Consensus.mac
Go to the documentation of this file.
00001 
00002 /* Matthew Lewsey, 9.2.2009 (Swansea) */
00003 /* Copyright 2009 Oliver Kullmann
00004 This file is part of the OKlibrary. OKlibrary is free software; you can redistribute
00005 it and/or modify it under the terms of the GNU General Public License as published by
00006 the Free Software Foundation and included in this library; either version 3 of the
00007 License, or any later version. */
00008 
00023 oklib_include("OKlib/ComputerAlgebra/Graphs/Lisp/Bicliques/BasicNotions.mac")$
00024 oklib_include("OKlib/ComputerAlgebra/DataStructures/Lisp/Lists.mac")$
00025 oklib_include("OKlib/ComputerAlgebra/Hypergraphs/Lisp/SetSystems.mac")$
00026 
00027 
00028 /* Checking whether B2 is a sub-biclique of B1: */
00029 /* G is not needed, since we must assume that B1,B2 are vertex bicliques. */
00030 bc_absorbs_bc_gl_p(B1,B2) := (subsetp(B2[1],B1[1]) and subsetp(B2[2],B1[2])) or (subsetp(B2[1],B1[2]) and subsetp(B2[2],B1[1]))$
00031 
00032 /* Checking whether one of the four consensus-adjunction possibilities can be 
00033    performed: */
00034 con_adj_gl_b1_1_b2_1_p(B1,B2,C) := (not disjointp(B1[1],B2[1])) and every_s(lambda([c],not bc_absorbs_bc_gl_p(c,[intersect(B1[1],B2[1]),union(B1[2],B2[2])])),C)$
00035 con_adj_gl_b1_1_b2_2_p(B1,B2,C) := (not disjointp(B1[1],B2[2])) and every_s(lambda([c],not bc_absorbs_bc_gl_p(c,[intersect(B1[1],B2[2]),union(B1[2],B2[1])])),C)$
00036 con_adj_gl_b1_2_b2_1_p(B1,B2,C) := (not disjointp(B1[2],B2[1])) and every_s(lambda([c],not bc_absorbs_bc_gl_p(c,[intersect(B1[2],B2[1]),union(B1[1],B2[2])])),C)$
00037 con_adj_gl_b1_2_b2_2_p(B1,B2,C) := (not disjointp(B1[2],B2[2])) and every_s(lambda([c],not bc_absorbs_bc_gl_p(c,[intersect(B1[2],B2[2]),union(B1[1],B2[1])])),C)$
00038 
00039 /* Checking whether the consensus on vertex bicliques B1, B2 can be performed
00040    and whether the obtained new biclique is not contained in one from S:
00041 */
00042 con_adj_gl_p(B1,B2,C) := con_adj_gl_b1_1_b2_1_p(B1,B2,C) or con_adj_gl_b1_1_b2_1_p(B1,B2,C) or con_adj_gl_b1_1_b2_1_p(B1,B2,C) or con_adj_gl_b1_1_b2_1_p(B1,B2,C)$
00043 
00044 /* Performing the four variations of consensus-adjunction: */
00045 con_adj_gl_b1_1_b2_1(B1,B2) := [intersect(B1[1],B2[1]),union(B1[2],B2[2])]$
00046 con_adj_gl_b1_1_b2_2(B1,B2) := [intersect(B1[1],B2[2]),union(B1[2],B2[1])]$
00047 con_adj_gl_b1_2_b2_1(B1,B2) := [intersect(B1[2],B2[1]),union(B1[1],B2[2])]$
00048 con_adj_gl_b1_2_b2_2(B1,B2) := [intersect(B1[2],B2[2]),union(B1[1],B2[1])]$
00049 
00050 /* Add 0-4 consensus adjunctions of bicliques B1,B2 to the list C of
00051    maximal bicliques: */
00052 con_adj_gl_bc(B1,B2,C) := block([C2 : C],
00053   if con_adj_gl_b1_1_b2_1_p(B1,B2,C) = true then C2 : cons(con_adj_gl_b1_1_b2_1(B1,B2),C2),
00054   if C2 # C then return(C2),
00055   if con_adj_gl_b1_1_b2_2_p(B1,B2,C) = true then C2 : cons(con_adj_gl_b1_1_b2_2(B1,B2),C2),
00056   if C2 # C then return(C2),
00057   if con_adj_gl_b1_2_b2_1_p(B1,B2,C) = true then C2 : cons(con_adj_gl_b1_2_b2_1(B1,B2),C2),
00058   if C2 # C then return(C2),
00059   if con_adj_gl_b1_2_b2_2_p(B1,B2,C) = true then C2 : cons(con_adj_gl_b1_2_b2_2(B1,B2),C2),
00060   return(C2))$
00061 
00062 
00063 /* Prerequisites: B1, B2 are bicliques of G, C is a list of maximal bicliques
00064    of G, G is a graph with loops.
00065    Output is C extended by the first consensus adjunction of B1, B2 possible,
00066    maximised w.r.t. G.
00067    Similar to con_adj_gl_bc, but maximises the consensus adjunctions before 
00068    adding it to the list.
00069 */
00070 con_ext_gl_bc(B1,B2,C,G) :=  block([C2 : C],
00071   if con_adj_gl_b1_1_b2_1_p(B1,B2,C) then block([b11 : con_adj_gl_b1_1_b2_1(B1,B2)], C2 : cons(maximal_bc_gl(b11,G),C2)),
00072   if C2 # C then return(C2),
00073   if con_adj_gl_b1_1_b2_2_p(B1,B2,C) then block([b12 : con_adj_gl_b1_1_b2_2(B1,B2)], C2 : cons(maximal_bc_gl(b12,G),C2)),
00074   if C2 # C then return(C2),
00075   if con_adj_gl_b1_2_b2_1_p(B1,B2,C) then block([b21 : con_adj_gl_b1_2_b2_1(B1,B2)], C2 : cons(maximal_bc_gl(b21,G),C2)),
00076   if C2 # C then return(C2),
00077   if con_adj_gl_b1_2_b2_2_p(B1,B2,C) then block([b22 : con_adj_gl_b1_2_b2_2(B1,B2)], C2 : cons(maximal_bc_gl(b22,G),C2)),
00078   return(C2))$
00079 
00080 /* G is a graph with loops, C a list of vertex bicliques, 
00081    removes vertex bicliques which are contained in others:
00082 */
00083 /* Belongs to somewhere else */
00084 aux_con_alg1_abs(C) := block([anyabs : false, absi],
00085   for i : 1 thru length(C) do
00086     for j : 1 thru i-1 do block(
00087       if bc_absorbs_bc_gl_p(C[j],C[i]) then block(anyabs : true, absn : i),
00088       if anyabs then return,
00089       if bc_absorbs_bc_gl_p(C[i],C[j]) then block(anyabs : true, absn : j), 
00090       if anyabs then return),
00091     if anyabs then return(delete(C[absn],C,1)),
00092   return(C))$
00093 
00094 
00095 /* G is a graph with loops, C a list of vertex bicliques,
00096    extends C by one consensus adjunction if possible:
00097 */
00098 aux_con_alg1_con(C) := block([C2 : C, C2eqC : false],
00099   for i : 1 while (i <=  length(C) and C2eqC = false) do 
00100     for j : 1 while (j <= i-1 and C2eqC = false) do block(
00101       C2 : con_adj_gl_bc(C[i],C[j],C),
00102       C2eqC : is(C2 # C)),
00103   return(C2))$
00104 
00105 /* Variation of aux_con_alg1_con XXX */
00106 aux_con_alg2_ext(C,G) := block([C2 : C, C2eqC : false],
00107   for i : 1 while (i <= length(C) and C2eqC = false) do
00108     for j : 1 while (j <= i-1 and C2eqC = false) do block(
00109       C2 : con_ext_gl_bc(C[i],C[j],C,G),
00110       C2eqC : is(C2 # C)),
00111   return(C2))$
00112 
00113 /* G is a graph with loops, C a list of vertex bicliques covering all edges;
00114    returning the list of all maximal vertex bicliques, using "algorithm 1"
00115    from the underlying paper:
00116 */
00117 
00118 con_alg1(G) := block([C, C1, C2, reiterate : true],
00119   C : max_bc_cover_gl(G),
00120   C2 : C,
00121   for i : 1 while (reiterate = true) do block(
00122     reiterate : false,
00123     C1 : C2,
00124     C2 : aux_con_alg1_abs(C1),
00125     if C2 # C1 then reiterate : true else block(
00126       C2 : aux_con_alg1_con(C1),
00127       if C2 # C1 then reiterate : true)
00128   ), 
00129   return(C2))$
00130 
00131 /* G is a graph with loops, C a list of maximal vertex bicliques covering all
00132    edges; returning the list of all maximal vertex bicliques, using
00133    "algorithm 2" from the underlying paper:
00134 */
00135 
00136 con_alg2(G) := block([C, C1, C2, reiterate : true],
00137   C : max_bc_cover_gl(G),
00138   C2 : C,
00139   for i : 1 while reiterate do block(
00140     C1 : C2, 
00141     C2 : aux_con_alg2_ext(C1,G),
00142     reiterate : is(C1 # C2)
00143   ), 
00144   return(C2))$
00145