Re: pairs and subsets challenge
- To: mathgroup at smc.vnet.net
- Subject: [mg59327] Re: pairs and subsets challenge
- From: Maxim <ab_def at prontomail.com>
- Date: Fri, 5 Aug 2005 01:23:15 -0400 (EDT)
- References: <dchnkq$7pe$1@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
On Sun, 31 Jul 2005 05:30:02 +0000 (UTC), Daniel Reeves
<dreeves at umich.edu> 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!)
>
Basically what we're looking for is a (maximal) clique, and the problem is
how to obtain all of them. MaximumClique from the Combinatorica package
uses Backtrack, which has an undocumented option All. So we can modify the
definition of MaximumClique[g, k] to return all complete subgraphs of the
given order:
In[1]:=
<<discretemath`
Unprotect[MaximumClique];
DownValues[MaximumClique] = DownValues[MaximumClique] /.
HoldPattern@ Flatten@ Position[Backtrack[s__, First], elem_] :>
(Flatten@Position[#, elem]& /@ Backtrack[s, All]);
And then remove those that are not maximal:
In[4]:=
P = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}, {3, 5}, {4, 5}};
G = FromUnorderedPairs[P];
mcl = If[Depth@# == 3, #, {#}]&@ MaximumClique[G];
Join @@ Array[MaximumClique[G, #]&, Length@ mcl[[1]]] //
Fold[
If[MemberQ[#, x_ /; Complement[#2, x] === {}], #, Append[##]]&,
{}, Reverse@ Sort@ #]&
Out[7]=
{{1, 2, 3, 4}, {3, 4, 5}}
In a similar way we can generate all complete subgraphs directly:
In[8]:=
Madj = ToAdjacencyMatrix[FromUnorderedPairs[P]];
Backtrack[Table[{1, 0}, {Length@ Madj}],
Compile[{{L, _Integer, 1}},
Module[{Lind, len},
Total[L] == 0 ||
(Lind = Flatten@ Position[L, 1];
len = Length@ Lind;
Total[Madj[[Lind, Lind]], 2] == len^2 - len)
],
{{Madj, _Integer, 2}, {_Total, _Integer}}
],
True&,
All] //
Flatten@Position[#, 1]& /@ #& //
Fold[
If[MemberQ[#, x_ /; Complement[#2, x] === {}], #, Append[##]]&,
{}, Reverse@ Sort@ #]&
Out[9]=
{{1, 2, 3, 4}, {3, 4, 5}}
This appears to be several times faster.
Maxim Rytin
m.r at inbox.ru