[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
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**
| |