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 */
00043
00044 /* Performing the four variations of consensus-adjunction: */
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],
00054   if C2 # C then return(C2),
00056   if C2 # C then return(C2),
00058   if C2 # C then return(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.
00068    adding it to the list.
00069 */
00070 con_ext_gl_bc(B1,B2,C,G) :=  block([C2 : C],
00072   if C2 # C then return(C2),
00074   if C2 # C then return(C2),
00076   if C2 # C then return(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(
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
```