Re: pairs and subsets challenge
- To: mathgroup at smc.vnet.net
- Subject: [mg59313] Re: pairs and subsets challenge
- From: "Carl K. Woll" <carlw at u.washington.edu>
- Date: Fri, 5 Aug 2005 01:22:10 -0400 (EDT)
- Organization: University of Washington
- References: <dchnkq$7pe$1@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
"Daniel Reeves" wrote:
> Here's an interesting problem:
>
> Given a set N = {1,...,n}.
> And given a set P of pairs from N, ie, a subset of KSubsets[N,2].
> List each _maximal_ subset X of N such that KSubsets[X,2] is a
> subset of P.
> Maximal means if X is listed, don't list any subsets of X.
>
> Brute force solutions are not hard to write. This should work for n up to
> 40 and |P| around 500.
>
> Simple example:
>
> N = {1,2,3,4,5};
> P = {{1,2},{1,3},{1,4},{2,3},{2,4},{3,4},{3,5},{4,5}};
>
> output:
>
> {{1,2},{1,3},{1,4},{2,3},{2,4},{3,4},{3,5},{4,5},
> {3,4,5}, {1,2,3,4}}
>
>
> (no prize this time but I think it'll be fun!)
>
Here's one attempt. Basically, I start with the first element, and get a
list of the elements it is paired with. Then, I take the first element of
this list and see what elements it is paired with and form a new list of
common elements. Proceed recursively until there are no more common
elements. Store the subset of elements chosen, and backtrack. This algorithm
produces a list of all of the maximal subsets, but it also produces a bunch
(but not all) of nonmaximal subsets. I use another function (prune) to prune
the nonmaximal subsets from the list.
I store the pairs information in a nonsymmetric sparse array. Here is the
code:
maximalsubs[pairs_] := Module[{},
len = Max[pairs];
mat = SparseArray[Thread[Sort /@ pairs -> 1], {len, len}];
rng = Range[len];
cur = Table[0, {len}];
subs = Reap[Do[
index = 1;
cur[[index++]] = i;
getsubs[Pick[rng, mat[[i]], 1]], {i, len}]][[2, 1]];
prune[subs]
]
getsubs[common_] := Module[{},
Do[
cur[[index++]] = common[[i]];
getsubs[Intersection[Pick[rng, mat[[common[[i]]]], 1], common]];
index--;, {i, Length[common]}]]
getsubs[{}] := Module[{},
Sow[Take[cur, index - 1]]]
prune[n_] := Module[{}, p = Reverse@Union[Plus @@@ (2^(n - 1))];
ans = Fold[addmem, {First@p}, Rest@p];
Flatten@Position[Reverse@IntegerDigits[#, 2], 1] & /@ ans]
addmem[x_, a_] := If[Min@BitAnd[a, BitNot[x]] == 0, x, Append[x, a]]
For your example, we have:
In[10]:=
maximalsubs[{{1,2},{1,3},{1,4},{2,3},{2,4},{3,4},{3,5},{4,5}}]
Out[10]=
{{3,4,5},{1,2,3,4}}
For a list of ~500 pairs with indices ranging to 40, it took ~3 seconds to
generate the list of nonmaximal subsets, and another ~40 seconds to prune
this list. Pruning the nonmaximal subsets takes most of the time.
Here is a test case for ~500 pairs:
SeedRandom[1];
pairs = DeleteCases[
Union@Table[
Sort[{Random[Integer, {1, 40}], Random[Integer, {1, 40}]}], {900}], {i_,
i_}];
In[15]:=
Length[pairs]
Out[15]=
518
Applying maximalsubs to the above pairs:
In[25]:=
ans=maximalsubs[pairs];//Timing
Out[25]=
{45.454 Second,Null}
The number of maximal subsets:
In[26]:=
Length[ans]
Out[26]=
1115
The number of nonmaximal subsets generated:
In[27]:=
Length[subs]
Out[27]=
20258
It would be nice to avoid generating these nonmaximal subsets, but I
couldn't think of a good algorithm for that. Pruning nonmaximal subsets from
a list of substs is also a nice exercise. I thought I had posted the above
code for prune to mathgroup before, but apparently it never made it. Perhaps
we should revisit the pruning exercise to see if a better prune function can
be found.
> --
> http://ai.eecs.umich.edu/people/dreeves - - google://"Daniel Reeves"
>
> Optimist: The glass is half full.
> Pessimist: The glass is half empty.
> Engineer: The glass is too big.
>
Carl Woll
Wolfram Research