OKlibrary  0.2.1.6
SetSystems.mac
Go to the documentation of this file.
```00001 /* Oliver Kullmann, 29.11.2007 (Swansea) */
00002 /* Copyright 2007, 2008, 2009, 2010, 2011, 2012, 2013 Oliver Kullmann
00003 This file is part of the OKlibrary. OKlibrary is free software; you can redistribute
00004 it and/or modify it under the terms of the GNU General Public License as published by
00005 the Free Software Foundation and included in this library; either version 3 of the
00006 License, or any later version. */
00007
00022 oklib_include("OKlib/ComputerAlgebra/DataStructures/Lisp/Lists.mac")\$
00023 oklib_include("OKlib/ComputerAlgebra/DataStructures/Lisp/HashMaps.mac")\$
00024
00025
00026 /* ***************
00027    * Elementship *
00028    ***************
00029 */
00030
00031 /* Is every element of list X element of the corresponding set in list L: */
00032 gelementp(X,L) := is(length(X) <= length(L)) and
00033  every_s(lambda([i], elementp(X[i], L[i])), create_list(i,i,1,length(X)))\$
00034
00035
00036 /* **************
00037    * Singletons *
00038    **************
00039 */
00040
00041 /* Is set S a singleton set: */
00042 singletonp(S) := is(length(S) = 1)\$
00043 /* Given a singleton set, return its element: */
00044 single_element(S) := first(S)\$
00045
00046 /* Choosing some element from a non-empty set: */
00047 choose_element(S) := listify(S)[1]\$
00048 /* Obtain the first element (in the underlying order): */
00049 first_element(S) := first(S)\$
00050 second_element(S) := second(S)\$
00051 /* Obtain the last element: */
00052 last_element(S) := last(S)\$
00053
00054
00055 /* *********************
00056    * Set constructions *
00057    *********************
00058 */
00059
00060 /* The set {1,...,n}: */
00061 setn(n) := setify(create_list(i,i,1,n))\$
00062 /* The set {m, ..., n}: */
00063 setmn(m,n) := setify(create_list(i,i,m,n))\$
00064
00065 /* The corresponding lists: */
00066 listn(n) := create_list(i,i,1,n)\$
00067 listmn(m,n) := create_list(i,i,m,n)\$
00068
00069 /* A set of singletons from a set: */
00070 singletons(M) := powerset(M,1)\$
00071
00072 /* All unordered pairs (possibly degenerated) from two sets: */
00073 upairs(A,B) := makeset({x,y},[x,y],cartesian_product(A,B))\$
00074
00075
00076 /* **********************************
00077    * Constructions related to union *
00078    **********************************
00079 */
00080
00081 /* The union of a list or of a set of sets: */
00082 lunion(L) := tree_reduce(union,L,{})\$
00083
00084 /* The union of a family of sets, i.e., given is a domain I and a map f(i).
00085    I can be a set or a list. */
00086 /* RENAME: union_fs */
00087 family_sets_union(I, f) := lunion(map(f,I))\$
00088 union_fs(I, f) := lunion(map(f,I))\$
00089
00090 /* The sum of a list of sets: */
00091 set_sum(L) := lunion(
00092   map(cartesian_product, L, create_list({i},i,1,length(L))))\$
00093 /* The n-ary version: */
00094 set_sumn([L]) := set_sum(L)\$
00095
00096 /* Complex-union (pairwise union): */
00097 cunion(A,B) := setify(map(lambda([P],apply(union,P)),cartesian_product_l([listify(A),listify(B)])))\$
00098 /* The special case of adding some set to all elements of
00099    a set system. */
00101 /* Further specialised to adjoining a single element. */
00103 /* The same functionality, but for lists of sets: */
00104 cunion_l(A,B) := map(lambda([P],apply(union,P)),cartesian_product_l([A,B]))\$
00107
00108
00109 /* *****************************************
00110    * Constructions related to intersection *
00111    *****************************************
00112 */
00113
00114 /* The intersection of a non-empty list of sets (or of a set of sets): */
00115 lintersection(L) := tree_reduce(intersection,L)\$
00116
00117
00118 /* ********************************************
00119    * Constructions related to complementation *
00120    ********************************************
00121 */
00122
00123 /* Elementwise complementation of set-system S w.r.t. universe U */
00124 ecomp(S,U) := setify(create_list(setdifference(U,s),s,listify(S)))\$
00125
00126 /* setdifference2(S,b) returns the set system where the elements of b have been
00127    removed from every element of S; S can also be a list. */
00128 setdifference2(S,b) := map(lambda([s], setdifference(s,b)), S)\$
00129 /* The special case where b is a single element (to be removed): */
00130 setdifference2e(S,b) := map(lambda([s], disjoin(b,s)), S)\$
00131
00132
00133 /* **************************************************
00134    * Constructions related to the cartesian product *
00135    **************************************************
00136 */
00137
00138 /* The input is a list of lists, and we obtain the "cartesian
00139    product" as a list (in the natural order): */
00140 cartesian_product_l(S) := if emptyp(S) then [[]]
00141  else block([P : cartesian_product_l(rest(S))],
00142    uaapply(append, create_list(
00143      map(lambda([t],cons(x,t)), P),
00144      x,first(S))))\$
00145
00146 /* For a set X the set of all tuples of length |X| over X: */
00147 all_transformations_l(X) := uaapply(cartesian_product,
00148   create_list(X,i,1,length(X)))\$
00149 /* Now input and output are lists (the output is ordered): */
00150 all_transformations_l_l(X) := cartesian_product_l(
00151   create_list(X,i,1,length(X)))\$
00152
00153 /* More generally, the set of all tuples of length k over set X: */
00154 all_tuples(X,k) := uaapply(cartesian_product,
00155   create_list(X,i,1,k))\$
00156 /* Now input and output are lists, and the output is ordered (lexicographically): */
00157 all_tuples_l(X,k) := cartesian_product_l(create_list(X,i,1,k))\$
00158
00159 /* The set of all ordered tuples of length k over set X: */
00160 all_ord_tuples(X,k) := map(sort, all_tuples(X,k))\$
00161 /* Now input and output are lists, and the output is ordered (lexicographically): */
00162 all_ord_tuples_l(X,k) := listify(setify(map(sort, all_tuples_l(X,k))))\$
00163
00164
00165 /* ************************************
00166    * Constructions related to subsets *
00167    ************************************
00168 */
00169
00170 /* The list of all k-permutations of a set S.
00171    The order is first by range (lexicographically),
00172    then lexicographically.
00173 */
00174 kpermutations(S,k) :=
00175  lappend(create_list(listify(permutations(s)),s,listify(powerset(S,k))))\$
00176 /* Remark: permutations(S) = setify(kpermutations(S,length(S))). */
00177
00178 /* For a list L, the set of k-subsets of the underlying set of
00179    objects, lexicographically sorted, as list of lists:
00180 */
00181 powerset_l(L,k) := map(listify,listify(powerset(setify(L),k)))\$
00182 /* The special case k=2, but now allowing arbitrary lists L (thus
00183    the indices are considered now):
00184 */
00185 powerlist2(L) := if emptyp(L) then []
00186 elseif length(L) <= 200 then block([R : rest(L), res : []],
00187  for x in L unless emptyp(R) do (
00188    res : append(res,create_list([x,y],y,R)), R : rest(R)),
00189  res)
00190 else block([A : l2ary(L)],
00191   create_list([A[first(p)],A[second(p)]],
00192               p,listify(powerset(setn(length(L)),2))))\$
00193
00194
00195 /* *********************************************
00196    * Tests related to unions and intersections *
00197    *********************************************
00198 */
00199
00200 /* Whether set-system S (a set of sets) is stable under binary union: */
00201 bunion_closed_p(S) := block([a : l2array(listify(S)), result : true, A],
00202  for i : 1 thru a[0]-1 while result do (
00203   A : a[i],
00204   for j : i+1 thru a[0] while (result : elementp(union(A,a[j]),S)) do 0
00205  ),
00206  result)\$
00207
00208
00209 /* *******************************
00210    * Tests related to partitions *
00211    *******************************
00212 */
00213
00214 /* has_empty_element(S) is true iff set system S (can also be a list)
00215    contains the empty set: */
00216 /* RENAME: empty_element_p */
00217 has_empty_element(S) := some_s(emptyp, S)\$
00218 empty_element_p(S) := some_s(emptyp, S)\$
00219
00220 /* Given a list of sets, computes the first pair of indices of non-disjoint
00221    elements (and the empty list if there is no such pair): */
00222 non_disjoint_pair(L) := block([a : l2array(L), l : length(L), found : false, res : []],
00223   for i : 1 thru l-1 unless found do block([A : a[i]],
00224     for j : i+1 thru l unless found do
00225       if not disjointp(A, a[j]) then (res : [i,j], found : true)),
00226   return(res))\$
00227 /* Now returning the list of all pairs (in lecicographical order): */
00228 non_disjoint_pairs(L) := block([a : l2array(L), l : length(L), res : []],
00229   for i : 1 thru l-1 do block([A : a[i]],
00230     for j : i+1 thru l do
00231       if not disjointp(A, a[j]) then res : cons([i,j],res)),
00232   return(reverse(res)))\$
00233
00234 /* Whether set-system or list S is a disjoint set-system: */
00235 disjoint_set_system_p(S) :=
00236   is(length(lunion(S)) = sum_l(map(length,listify(S))))\$
00237
00238 /* Checks whether list P is a block-partitioning of set X: */
00239 blockpartitionp(P,X) := disjoint_set_system_p(P) and is(lunion(P) = X)\$
00240 /* Checks whether set-system P is a partitioning of set X: */
00241 partitionp(P,X) := blockpartitionp(P,X) and not empty_element_p(P)\$
00242
00243
00244 /* ********************************
00245    * Tests related to subsumption *
00246    ********************************
00247 */
00248
00249 /* Whether S (set/list of sets) contains no subsumed elements: */
00250 /* RENAME: antichain_p */
00251 is_antichain(S) := block(
00252  [S : sort_length(listify(S)), l : length(S), subsumption : false, A],
00253   for i : 1 thru l-1 unless subsumption do (A : S[i],
00254     for j : i+1 thru l unless subsumption do
00255       if subsetp(A, S[j]) then subsumption : true),
00256   return(not subsumption)
00257 )\$
00258 antichain_p(S) := is_antichain(S)\$
00259
00260 /* Whether S (set of sets) is closed under subsumption: */
00261 subsumption_closed_p(S) := if emptyp(S) then true else
00262  if not elementp({},S) then false else
00263  block([missing : false],
00264   for s in S unless missing do
00265     for x in s unless missing do
00266       missing : not elementp(disjoin(x,s),S),
00267   return(not missing))\$
00268
00269 /* Whether S (set of sets) is "accessible", that is, for every non-empty
00270    element s it is possible to get another element by removing some suitable
00271    element x from s:
00272 */
00273 accessible_ss_p(S) := if emptyp(S) then true else
00274  if not elementp({},S) then false else
00275  block([found : true],
00277     for x in s unless (found : elementp(disjoin(x,s),S)) do 0,
00278   return(found))\$
00279
00280
00281 /* Subset-relations at the "second level": */
00282
00283 /* Whether for all A in S1 there is B in S2 with subsetp(A,B): */
00284 lr_subsetp(S1,S2) := (
00285  if (
00286    for A in S1 do
00287      if (for B in S2 do if subsetp(A,B) then return(true))
00288      = done then return(false)
00289   ) = done then true else false)\$
00290 /* The special case where S1={A}: */
00291 l1r_subsetp(A,S2) :=
00292  if (for B in S2 do if subsetp(A,B) then return(true))
00293  = done then false else true\$
00294
00295 /* Whether for all B in S2 there is A in S1 with subsetp(A,B): */
00296 rl_subsetp(S1,S2) := (
00297  if (
00298    for B in S2 do
00299      if (for A in S1 do if subsetp(A,B) then return(true))
00300      = done then return(false)
00301   ) = done then true else false)\$
00302 /* The special case where S2={B}: */
00303 r1l_subsetp(S1,B) :=
00304  if (for A in S1 do if subsetp(A,B) then return(true))
00305  = done then false else true\$
00306
00307
00308 /* *****************************************
00309    * Constructions related to disjointness *
00310    *****************************************
00311 */
00312
00313 /* remove_with_element(S,a) is the subset of S of all sets not containing
00314    element a: */
00315 remove_with_element(S,a) := subset(S, lambda([s], not elementp(a,s)))\$
00316 /* The same, but for a list L of sets: */
00317 remove_with_element_l(L,a) := sublist(L, lambda([s], not elementp(a,s)))\$
00318
00319 /* More generally, remove_non_disjoint(S,b) is the subset of S of all sets
00320 disjoint to b: */
00321 remove_non_disjoint(S,b) := subset(S, lambda([s], disjointp(s,b)))\$
00322
00323 /* Replaces two elements by their union until the set system is disjoint: */
00324 unify_nondisjoint_elements(S) := block([L : listify(S), p, A, B],
00325   while not (p : non_disjoint_pair(L), emptyp(p)) do (
00326     A : L[p[1]], B : L[p[2]],
00327     L : delete(A,L), L : delete(B,L), L : append(L, [union(A,B)])),
00328   setify(L))\$
00329
00330
00331 /* *****************************************
00332    * Constructions related to subsumption *
00333    *****************************************
00334 */
00335
00336 /* The closure of a set system under subset-formation: */
00337 subset_closure(S) := family_sets_union(S, lambda([M],powerset(M)))\$
00338
00339
00340 /* Eliminating all subsumed elements from a list of sets or set system
00341   (that is,  computes the list/set of all minimal elements w.r.t. the
00342   subset-relation).
00343   Regarding the list-input, in the list-output all the sets are ordered by
00344   increasing length, while otherwise the given order is kept.
00345 */
00346
00347 /* The simplest algorithm: */
00348 min_elements_l_0(S) := block(
00349  [remains : sort_length(S), result : [], A],
00350  while not emptyp(remains) do (
00351   A : first(remains), result : cons(A,result),
00352   remains : sublist(remains, lambda([B], not subsetp(A, B)))
00353  ),
00354  reverse(result))\$
00355
00356 /* The best algorithm: */
00357 min_elements_l(S) := min_elements_unique_fast_l_(stable_unique(S),first)\$
00358
00359 /* Assuming the list S does not contain repeated elements; first a simple
00360    algorithm:
00361 */
00362 min_elements_unique_l(S) := block(
00363  [A : sort_length_part_ary(S), result : [], n],
00364   n : A[0],
00365   for i : 1 thru n do (
00366     result : cons(A[i], result),
00367     for x in A[i] do
00368       for j : i+1 thru n do
00369         A[j] : sublist(A[j], lambda([y], not subsetp(x, y)))
00370   ),
00371   lappend(reverse(result)))\$
00372
00373 /* Now a more intelligent algorithm (while above we remove for a given set
00374    A all subsets B with A <= B, now for a given B we test for A <= B,
00375    considering only relevant A).
00376    choose_element_(x) for a non-emtpy set x chooses some element.
00377 */
00378 min_elements_unique_fast_l_(S, choose_element_) := block(
00379  [l : length(S),
00380   A, number_blocks, current_block : 1,
00381   result, index : 1, old_index,
00382   h],
00383   if l <= 1 then return(S),
00384   A : sort_length_part_ary(S),
00385   if emptyp(first(A[1])) then return([{}]),
00386   h : sm2hm({}),
00387   number_blocks : A[0],
00388   result : okl_make_array(any,l),
00389   old_index : index,
00390   for x in A[current_block] do (result[index] : x, index : index + 1),
00391   while current_block < number_blocks do block([s, L, subsumption],
00392     for i : old_index thru index-1 do (
00393       s : choose_element_(result[i]),
00394       L : ev_hm(h,s),
00395       if L=false then set_hm(h,s,[i])
00396       else set_hm(h,s, cons(i,L))
00397     ),
00398     current_block : current_block + 1,
00399     old_index : index,
00400     for x in A[current_block] do (
00401       subsumption : false,
00402       for s in x unless subsumption do (
00403         L : ev_hm(h,s),
00404         if L#false then
00405           for i in L unless subsumption do
00406             subsumption : subsetp(result[i], x)
00407       ),
00408       if not subsumption then (result[index] : x, index : index+1)
00409     )
00410   ),
00411   create_list(result[i],i,1,index-1))\$
00412
00413 /* Subsumption elimination for a set-system, using the basic algorithm: */
00414 min_elements_0(S) := setify(min_elements_unique_l(listify(S)))\$
00415
00416 /* Using the fastest algorithm: */
00417 min_elements(S) :=
00418   setify(min_elements_unique_fast_l_(listify(S), 'first))\$
00419
00420
00421 /* Eliminates all contained elements from a list / set system (where for
00422    the list the elements are ordered in decreasing length, and otherwise
00423    the given order is maintained): */
00424 max_elements_l(S) := block(
00425  [remains : sort_length_desc(S), result : [], A],
00426  while not emptyp(remains) do (
00427   A : first(remains), result : cons(A,result),
00428   remains : sublist(remains, lambda([B], not subsetp(B, A)))
00429  ),
00430  reverse(result)
00431 )\$
00432
00433 /* Now the list S does not contain repeated elements: */
00434 max_elements_unique_l(S) := block(
00435  [A : sort_length_part_ary(S), result : [], n],
00436   n : A[0],
00437   for i : n thru 1 step -1 do (
00438     result : cons(A[i], result),
00439     for x in A[i] do
00440       for j : i-1 thru 1 step -1 do
00441         A[j] : sublist(A[j], lambda([y], not subsetp(y, x)))
00442   ),
00443   lappend(reverse(result)))\$
00444
00445 /* Computing all maximal elements for a set-system: */
00446 max_elements(S) := setify(max_elements_unique_l(listify(S)))\$
00447
00448
00449 /* Computes a predicate-function ss such that for a set X the value ss(X)
00450    is true iff X is subsumed by some element of S (i.e., there is Y in S
00451    with subsetp(Y,X)=true); S is a set (of sets).
00452    If S may have subsumed elements, then better use min_elements(S) instead
00453    of S (the resulting function ss will be more efficient).
00454 */
00455 check_subsumption_(S, choose_element_) := block(
00456  [l : length(S),
00457   A, B, b, L, H],
00458   if l = 0 then return(lambda([X],false)),
00459   if l = 1 then return(block([Y:single_element(S)],
00460     if emptyp(Y) then lambda([X],true)
00461     else buildq([Y], lambda([X], subsetp(Y,X)))
00462   )),
00463   A : sort_length_part_ary(listify(S)),
00464   if emptyp(first(A[1])) then return(lambda([X],true)),
00465   b : A[0],
00466   B : okl_make_array(any,b), for i : 1 thru b do B[i] : l2ary(A[i]),
00467   L : okl_make_array(fixnum,b), for i : 1 thru b do L[i] : length(B[i][1]),
00468   H : okl_make_array(any,b),
00469   for i : 1 thru b do block([h : sm2hm({}), sl : B[i][0], s,x,T],
00470     for j : 1 thru sl do (
00471       s : B[i][j],
00472       x : choose_element_(s),
00473       T : ev_hm(h,x),
00474       if T=false then set_hm(h,x,[j])
00475       else set_hm(h,x, cons(j,T))
00476     ),
00477     H[i] : h
00478   ),
00479   buildq([B,L,H], lambda([X], block([l : length(X), h, subs : false, T],
00480     if l=0 then return(false),
00481     for i : 1 thru L[0] while L[i] <= l and not subs do (
00482       h : H[i],
00483       for x in X unless subs do (
00484         T : ev_hm(h,x),
00485         if T#false then for y in T unless subs do subs : subsetp(B[i][y], X)
00486       )
00487     ),
00488     return(subs)))))\$
00489 /* Convenience instantiation: */
00490 check_subsumption(S) := check_subsumption_(S, 'first)\$
00491
```