       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]][][] - a[[i]][][]) ==
>           Abs(a[[i]][][] - a[[i]][][]) || (a[[i]][]
> [] +
>               a[[i]][][]) == (a[[i]][][] + a[[i]][]
> []),
>       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, 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,#[]]==Apply[Plus,#[]] ||
Abs[#[[1,1]]-#[[1,2]]]==Abs[#[[2,1]]-#[[2,2]]], num++] &, aaa];
If[num > 40, Sow[lst[[All,2]]]];
, {n}
];]][[1,1]]
]

In:= Timing[fl1 = findlists[20,300,100,40];]
Out= {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:= Timing[fl2 = findlists2[200,300,100,40];]
Out= {3.50047 Second, Null}

So this is about 10 times faster.

Daniel Lichtblau
Wolfram Research

```

• Prev by Date: GroebnerBasis (was Re: Documentation)
• Next by Date: Re: Can't assign value to symbols
• Previous by thread: combinations problem
• Next by thread: Set of strings reducing problem