MathGroup Archive 2005

[Date Index] [Thread Index] [Author Index]

Search the Archive

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


  • Prev by Date: Re: Pure Function within a pure function
  • Next by Date: Re: Default defaults?
  • Previous by thread: Re: pairs and subsets challenge
  • Next by thread: Re: pairs and subsets challenge