Re: pairs and subsets challenge
- To: mathgroup at smc.vnet.net
- Subject: [mg59383] Re: pairs and subsets challenge
- From: Maxim <ab_def at prontomail.com>
- Date: Sun, 7 Aug 2005 03:47:30 -0400 (EDT)
- References: <dchnkq$7pe$1@smc.vnet.net> <dcuv93$e2f$1@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
On Fri, 5 Aug 2005 06:00:03 +0000 (UTC), Carl K. Woll
<carlw at u.washington.edu> wrote:
> "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
>
>
Here's an optimized version. We can check that a given set is a solution
by verifying that there isn't a vertex adjacent to all the vertices in the
set.
<<discretemath`
cliques[P_] := Module[
{G, LLadj, stack, cur, sol, qp, sp, ans = {}},
G = FromUnorderedPairs[P];
LLadj = ToAdjacencyLists[G];
stack = Table[{}, {V[G] + 1}];
sol = qp = Table[0, {V[G] + 1}];
stack[[sp = 1]] = Range[V[G]]; qp[[sp]] = 1;
While[True,
If[qp[[sp]] > Length@ stack[[sp]],
If[sp-- == 1,
Break[],
qp[[sp]]++; Continue[]
]];
sol[[sp]] = stack[[sp, qp[[sp]]]];
cur = Take[sol, sp++];
stack[[sp]] = Intersection @@ LLadj[[cur]];
qp[[sp]] = 1;
If[stack[[sp]] === {}, AppendTo[ans, cur]];
stack[[sp]] = Select[stack[[sp]], # > Max@ cur&]
];
ans
]
In[8]:=
SeedRandom[1]
P = DeleteCases[
Union[Sort /@ Array[Random[Integer, {1, 40}]&, {900, 2}]],
{i_, i_}];
(ans = maximalsubs[P];) // Timing
(ans2 = cliques[P];) // Timing
Sort@ans === Sort@ans2
Out[10]=
{16.609 Second, Null}
Out[11]=
{1.86 Second, Null}
Out[12]=
True
Maxim Rytin
m.r at inbox.ru