RE: : Re: Help! How to calculate additive partitions?
- To: mathgroup at smc.vnet.net
- Subject: [mg34526] RE: [mg34446] : Re: [mg34432] Help! How to calculate additive partitions?
- From: "Wolf, Hartmut" <Hartmut.Wolf at t-systems.com>
- Date: Mon, 27 May 2002 01:15:55 -0400 (EDT)
- Sender: owner-wri-mathgroup at wolfram.com
Hi Bobby, I'll answer your "serious question" at the bottom > -----Original Message----- > From: DrBob [mailto:majort at cox-internet.com] To: mathgroup at smc.vnet.net > Sent: Friday, May 24, 2002 4:45 AM > 'mathgroup' > Subject: [mg34526] RE: [mg34446] : Re: [mg34432] Help! How to calculate additive > partitions? > > > In addition to the fun, there's A SERIOUS QUESTION at the bottom of > this! > > I duplicated f1, f2, f3 below and added three more versions. > f4 is Bob > Hanlon's simple algorithm: > > Needs["DiscreteMath`Combinatorica`"]; > f4[n_Integer?Positive] := > Flatten[Permutations /@ Partitions[n], 1] > > Next is a version that uses MapThread. It returns the same partitions > in a different order. > > f5[n_Integer] := Block[{f, h}, > h = Function[{x, y}, {x, ##} & @@@ y]; > f[0] = {{}}; > f[m_] := f[m] = > Flatten[MapThread[h, {Reverse[Range[m]], f /@ > Range[0, m - 1]}], > 1]; > f[n] ] > > Finally, here's a version that uses the Inner product, again returning > the same partitions in a different order: > > f6[n_Integer] := Block[{f, h}, > h = Function[{x, y}, {x, ##} & @@@ y]; > f[0] = {{}}; > f[1] = {{1}}; > f[2] = {{1, 1}, {2}}; > f[m_] := f[m] = Inner[h, Reverse[Range[m]], f /@ Range[0, m - 1], > Join]; > f[n] ] > > f1[21] // Length // Timing > f2[21] // Length // Timing > f3[21] // Length // Timing > f4[21] // Length // Timing > f5[21] // Length // Timing > f6[21] // Length // Timing > > {8.094 Second, 1048576} > {56.734 Second, 1048576} > {10.5 Second, 1048576} > {2.266 Second, 1048576} > {7.609 Second, 1048576} > {7.485 Second, 1048576} > > f5 and f6 have a small advantage over f1, probably because they avoid > the needless counting involved in Table. The built-in functions are > faster... largely because they're built-in, I suspect. > > HERE'S MY QUESTION. In the definition of f6 I initialize > f[1] and f[2] > explicitly. This is because the algorithm doesn't work > otherwise! The > recursion works for n>2, but not n=1 and n=2. WHY IS THAT? > > I'm really missing some nuance of the Inner product. > > Bobby Treat > > -----Original Message----- > From: Fred Simons [mailto:f.h.simons at tue.nl] To: mathgroup at smc.vnet.net > Sent: Thursday, May 23, 2002 5:25 AM > Subject: [mg34526] Re: [mg34446] : Re: [mg34432] Help! How to calculate additive > partitions? > > Just for fun, as in Hartmut's mail, some additional remarks. > > The solution given by Bob Hanlon and Murray Eisenberg by > first computing > all > ordered partitions and then the permutations of each of these is no > doubt > the fastest way. So let us go to the immediate constructions. My own > solution was > > In[1]:= > f[0]={{}}; > f[n_Integer] := f[n] = Flatten[Table[{k, ##}& @@@ f[n-k], {k, > 1, n}], 1] > > Indeed I left out the direct assignment in the indirect assignment, > thereby > producing an inefficient function for larger n. I had the > idea that this > function was only to be used for small n. That is not a good argument > and > Bobby Treat is quite right by pointing that out. In the sequel I will > use a > variant to enable comparisons: > > In[3]:= > f1[n_Integer] := Block[{f}, > f[0]={{}}; > f[m_] :=f[m] = Flatten[Table[{k, ##}& @@@ f[m-k], {k, 1, m}], 1]; > f[n] ] > > Rob Pratt mentioned an elegant technique for proving that for > each n the > problem has 2^(n-1) solutions and also implemented it. > Hartmut Wolf gave > another ingenious implementation: > > In[8]:= > f2[n_] := Map[Length, > Split[#, #2\[Equal]0&]& /@ > Table[IntegerDigits[ k, 2, n], {k, 0, 2^(n-1)-1}], {2}] > > Here I give a third implementation of the same idea. We start with the > number 1. Then we have to decide whether we want to place a marker or > not. > When we place a marker, the first number of the solution will be 1 and > the > second at least 1; when we do not place a marker, the first > number is at > least 2. Continuing in this way, we construct the solutions > step by step > by > either increasing the last number or appending a number 1. > > In[12]:= > f3[n_Integer] := Block[{g1, g2},g1[{x___, y_}]:= {x, y+1}; > g2[{x__}]:={x, > 1}; > Nest[ Join[ g1 /@ #, g2 /@ #]&, {{1}}, n-1] ] > > Now we compare these functions: > > In[34]:= > f1[17]// Length // Timing > f2[17]// Length // Timing > f3[17]// Length // Timing > Out[34]= > {1.81 Second,65536} > Out[35]= > {14.01 Second,65536} > Out[36]= > {2.91 Second,65536} > > I think the difference in timing is due to the size of the > intermediate > results. In function f1 these are slightly smaller than in > function f3, > while function f2 start with a huge structure to arrive at the desired > result. When we first compute the ordered partitions and then the > permutations, the intermediate expressions are still considerably > smaller. > > Fred Simons > Eindhoven University of Technology > > > The answer is quite simple: Inner isn't that function you conceive it to be! Terefor you chose it as the *wrong* function for your f6 (essentially a rewrite of Fred's f1). Look up in Help: "Like Dot, Inner effectively contracts the last index of the first tensor with the first index of the second tensor. Applying Inner to a rank r tensor and a rank s tensor gives a rank r + s - 2 tensor." Such observe: In[6]:= Inner[f, {a, b}, {1, 2}, g] Out[6]= g[f[a, 1], f[b, 2]] In[7]:= Inner[f, {{a, b}}, {{1}, {2}}, g] Out[7]= {{g[f[a, 1], f[b, 2]]}} In[8]:= Inner[f, {{a, b}}, {{{1}}, {{2}}}, g] Out[8]= {{{g[f[a, 1], f[b, 2]]}}} In[9]:= Inner[f, {{{a, b}}}, {{{1}}, {{2}}}, g] Out[9]= {{{{g[f[a, 1], f[b, 2]]}}}} or In[10]:= Inner[f, {{a}, {b}}, {{1, 2}}, g] Out[10]= {{g[f[a, 1]], g[f[a, 2]]}, {g[f[b, 1]], g[f[b, 2]]}} In[11]:= Inner[f, {{{a}, {b}}}, {{{1, 2}}}, g] Out[11]= {{{{g[f[a, 1]], g[f[a, 2]]}}, {{g[f[b, 1]], g[f[b, 2]]}}}} consequently In[12]:= Inner[f, {a}, {{}}, g] Out[12]= {} That kills your algorithm. What do you need instead? In[3]:= Inner[f, {a, b}, {1, 2}, g] Out[3]= g[f[a, 1], f[b, 2]] In[4]:= g @@ Thread[f[{a, b}, {1, 2}]] Out[4]= g[f[a, 1], f[b, 2]] In[5]:= g @@ MapThread[f, {{a, b}, {1, 2}}] Out[5]= g[f[a, 1], f[b, 2]] MapThread and Thread don't have that undesired property of Inner: In[23]:= g @@ Thread[f[{a}, {{}}]] Out[23]= g[f[a, {}]] In[24]:= g @@ MapThread[f, {{a}, {{}}}] Out[24]= g[f[a, {}]] Now you can redefine f6; (1) Using Thread: We have to be a little cautious with early evaluation, therefore we temporarily have to hold h, but Thread with evaluated arguments. In[13]:= f6bis[n_Integer] := Block[{f, h}, h = Function[{x, y}, {x, ##} & @@@ y]; f[0] = {{}}; f[m_] := f[m] = With[{arg1 = Reverse[Range[m]], arg2 = f /@ Range[0, m - 1]}, Join @@ Thread[Unevaluated[h[arg1, arg2]]]]; f[n]] In[14]:= f6bis[0] Out[14]= {{}} In[15]:= f6bis[1] Out[15]= {{1}} In[16]:= f6bis[2] Out[16]= {{2}, {1, 1}} In[17]:= f6bis[3] Out[17]= {{3}, {2, 1}, {1, 2}, {1, 1, 1}} (2) MapThread (is somewhat easier): In[18]:= f6bis2[n_Integer] := Block[{f, h}, h = Function[{x, y}, {x, ##} & @@@ y]; f[0] = {{}}; f[m_] := f[m] = Join @@ MapThread[h, {Reverse[Range[m]], f /@ Range[0, m - 1]}]; f[n]] In[19]:= f6bis2[0] Out[19]= {{}} In[20]:= f6bis2[1] Out[20]= {{1}} In[21]:= f6bis2[2] Out[21]= {{2}, {1, 1}} In[22]:= f6bis2[3] Out[22]= {{3}, {2, 1}, {1, 2}, {1, 1, 1}} -- Hartmut