Services & ResourcesWolfram ForumsMathGroup Archive

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

Re: combinations problem

• To: mathgroup at smc.vnet.net
• Subject: [mg58579] Re: [mg58563] combinations problem
• From: Daniel Lichtblau <danl at wolfram.com>
• Date: Fri, 8 Jul 2005 00:46:10 -0400 (EDT)
• References: <200507070935.FAA29425@smc.vnet.net>
• Sender: owner-wri-mathgroup at wolfram.com

hrocht at mail15.com wrote:
> hi
> at first here is my program
> << DiscreteMath`Combinatorica`
> lst1 = Table[i, {i, 100}]
> Do[
>   lst2 = Table[Random[Integer, {1, 300}], {i, 100}];
>   lst3 = Transpose[{lst1, lst2}];
>   a = KSubsets[lst3, 2];
>   num = 0; Do[
>        If[
>       Abs(a[[i]][[1]][[2]] - a[[i]][[1]][[1]]) == 
>           Abs(a[[i]][[2]][[2]] - a[[i]][[2]][[1]]) || (a[[i]][[1]]
> [[2]] + 
>               a[[i]][[1]][[1]]) == (a[[i]][[2]][[2]] + a[[i]][[2]]
> [[1]]), 
>       num++;]
>       , {i, 1, 4950}];
>   If[num > 40, Print[num]; Print[lst2]];
>   , {j, 1, 2000}]
> 
> lst3 will have each element in lst2 together with its ordering
> such as :
> Take[lst3, {1, 3}]
> {{1, 48}, {2, 295}, {3, 74}}
> if we take all the possible combinations in lst3 taken in pairs as in
> a = KSubsets[lst3, 2]   
> one sublist may be for a[[1]]
> {{1, 6}, {29, 34}}
> the length of "a" will be 4950 which is number of possible 
> combinations for 100 elements taken in pairs.
> the mission is to count the sublists such as
> {{1, 6}, {29, 34}}  in which  abs[1-6]=abs[29-34]
> or the sublists such as 
> {{1, 206}, {35, 172}}
> in wich 1+206=35+172
> and what is the biggest possible number for such sublists when we 
> supply our random or carefully designed lst2 ?
> in the program above we want to display only the lst2 wich will give 
> num>40
> how  could i make my program more speedy and more efficient?
> thanks
> Anton


First version:

<<DiscreteMath`Combinatorica`

findlists[n_, max_, len_, threshhold_] :=
   Module[
   {lst, aaa, num},
   Rest[Reap[Do[
     lst = Table[{j,Random[Integer,{1,max}]}, {j,len}];
     aaa = KSubsets[lst, 2];
     num = 0;
     Map[If[Apply[Plus,#[[1]]]==Apply[Plus,#[[2]]] ||
         Abs[#[[1,1]]-#[[1,2]]]==Abs[#[[2,1]]-#[[2,2]]], num++] &, aaa];
     If[num > 40, Sow[lst[[All,2]]]];
	, {n}
     ];]][[1,1]]
   ]

In[14]:= Timing[fl1 = findlists[20,300,100,40];]
Out[14]= {3.25551 Second, Null}

So this would take around 5 minutes to do 2000 trials.

Second version uses Compile. This took a bit of work to satisfy the 
petty whims of the Compile deities.

findlistsC = Compile[{{n,_Integer},{max,_Integer},{len,_Integer}},
   Module[{lst, aaa, num=0, la=Round[len*(len-1)/2.], incr, j, k, tt},
   aaa = Table[{{0,0},{0,0}}, {la}];
   Table[
     incr = 0;
	lst = Table[{s,Random[Integer,{1,max}]}, {s,len}];
     For [j=1, j<=len-1, j++,
       For [k=j+1, k<=len, k++,
         incr++; aaa[[incr]] = {lst[[j]],lst[[k]]}]];
	num = 0;
	Do [If[aaa[[j,1,1]]+aaa[[j,1,2]]==aaa[[j,2,1]]+aaa[[j,2,2]] ||
	  Abs[aaa[[j,1,1]]-aaa[[j,1,2]]]==Abs[aaa[[j,2,1]]-aaa[[j,2,2]]], num++]
	  , {j,Length[aaa]}
	  ];
	Prepend[lst[[All,2]],num]
	, {n}
     ]
   ]]

findlists2[n_, max_, len_, threshhold_] :=
   Map[Rest,Select[findlistsC[n,max,len], (First[#]>=threshhold)&]]

In[18]:= Timing[fl2 = findlists2[200,300,100,40];]
Out[18]= {3.50047 Second, Null}

So this is about 10 times faster.


Daniel Lichtblau
Wolfram Research

• References:
  • combinations problem
    • From: hrocht@mail15.com