Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2006
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2006

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

Search the Archive

Re: efficient term collection algorithm

  • To: mathgroup at smc.vnet.net
  • Subject: [mg69183] Re: [mg69155] efficient term collection algorithm
  • From: János <janos.lobb at yale.edu>
  • Date: Fri, 1 Sep 2006 06:41:09 -0400 (EDT)
  • References: <200608310839.EAA19589@smc.vnet.net>
  • Sender: owner-wri-mathgroup at wolfram.com

On Aug 31, 2006, at 4:39 AM, Blake Laing wrote:

> Dear Math Group
>
> I wish to combine terms in a expression which share a denominator,  
> such
> as in the following simple case:
>
> In[1]:=
> a/i+b/j+c/i//.Plus[Times[A_.,Power[denom_,-1]],Times[B_.,Power 
> [denom_,-1]]]:>
>       Factor[Plus[A,B]Power[denom,-1]]//InputForm
> Out[1]//InputForm=
> (a + c)/i + b/j
>
> The actual expression I am working with contains thousands of  
> terms, and
> a pairwise algorithm such as this is wholly inadequate. Will one of  
> you
> please suggest a more efficient way to combine each additive term in a
> large expression with a shared denominator?
>
> Thanks,
>
> Blake Laing
> physics grad student
> University of Oklahoma
>

My newbie approach to it would be:

First create an alphabet and a random expression of rationales for  
illustration:

In[1]:=
abc = {a, b, c, d, e, f, g,
     h, i, j, k, l, m, n, o,
     p, q, r, s, t, u, v, w,
     x, y, z};

In[2]:=
eex = Total[Table[
     abc[[Random[Integer,
        {1, Length[abc]}]]]/
      abc[[Random[Integer,
        {1, Length[abc]}]]],
     {ii, 1, 100}]]
Out[2]=
2 + b/c + (2*f)/e + b/g +
   c/g + g/b + g/f + c/h +
   h/c + a/i + e/i + i/a +
   i/f + (2*h)/j + j/i + e/k +
   k/j + (2*e)/l + (2*l)/b +
   a/n + e/n + n/h + m/o +
   o/e + o/j + o/n + g/p +
   p/i + p/j + p/k + b/q +
   k/q + q/b + q/g + q/i +
   c/r + f/r + i/r + r/k +
   r/l + s/b + (2*s)/d + s/f +
   a/t + d/t + j/t + n/t +
   r/t + t/c + (2*t)/j + t/o +
   c/u + g/u + k/u + n/u +
   u/d + u/h + u/k + u/q +
   o/v + v/b + v/e + v/j +
   v/q + h/w + l/w + w/d +
   w/s + w/t + k/x + n/x +
   t/x + x/b + x/d + x/e +
   x/v + e/y + j/y + m/y +
   o/y + (2*y)/c + y/h + y/k +
   y/v + b/z + c/z + t/z +
   z/a + z/l + z/t + z/v + z/w

Lets drop the integer and break the expression into a List:

In[3]:=
lsteex = DeleteCases[
    Table[eex[[ii]],
     {ii, 1, Length[eex]}],
    _Integer]
Out[3]=
{b/c, (2*f)/e, b/g, c/g, g/b,
   g/f, c/h, h/c, a/i, e/i,
   i/a, i/f, (2*h)/j, j/i,
   e/k, k/j, (2*e)/l, (2*l)/b,
   a/n, e/n, n/h, m/o, o/e,
   o/j, o/n, g/p, p/i, p/j,
   p/k, b/q, k/q, q/b, q/g,
   q/i, c/r, f/r, i/r, r/k,
   r/l, s/b, (2*s)/d, s/f,
   a/t, d/t, j/t, n/t, r/t,
   t/c, (2*t)/j, t/o, c/u,
   g/u, k/u, n/u, u/d, u/h,
   u/k, u/q, o/v, v/b, v/e,
   v/j, v/q, h/w, l/w, w/d,
   w/s, w/t, k/x, n/x, t/x,
   x/b, x/d, x/e, x/v, e/y,
   j/y, m/y, o/y, (2*y)/c,
   y/h, y/k, y/v, b/z, c/z,
   t/z, z/a, z/l, z/t, z/v,
   z/w}

Lets Sort it based upon where the denominator Position is in the  
alphabet and after the Sort Split it based upon the equivalence of  
the Denominators:

In[4]:=
sseex = Split[Sort[lsteex,
     Position[abc, Denominator[
          #1]][[1,1]] <
       Position[abc,
         Denominator[#2]][[1,
        1]] & ],
    Denominator[#1] ===
      Denominator[#2] & ]
Out[4]=
{{z/a, i/a}, {x/b, v/b, s/b,
    q/b, (2*l)/b, g/b},
   {(2*y)/c, t/c, h/c, b/c},
   {x/d, w/d, u/d, (2*s)/d},
   {x/e, v/e, o/e, (2*f)/e},
   {s/f, i/f, g/f},
   {q/g, c/g, b/g},
   {y/h, u/h, n/h, c/h},
   {q/i, p/i, j/i, e/i, a/i},
   {v/j, (2*t)/j, p/j, o/j,
    k/j, (2*h)/j}, {y/k, u/k,
    r/k, p/k, e/k},
   {z/l, r/l, (2*e)/l},
   {o/n, e/n, a/n},
   {t/o, m/o}, {g/p},
   {v/q, u/q, k/q, b/q},
   {i/r, f/r, c/r}, {w/s},
   {z/t, w/t, r/t, n/t, j/t,
    d/t, a/t}, {n/u, k/u, g/u,
    c/u}, {z/v, y/v, x/v,
    o/v}, {z/w, l/w, h/w},
   {t/x, n/x, k/x},
   {o/y, m/y, j/y, e/y},
   {t/z, c/z, b/z}}

 From here on lets Total and Factor all the sublists and Total again  
the results:

In[27]:=
Total[(Factor[Total[
       #1]] & ) /@ sseex]
Out[27]=
(a + e + o)/n + g/p +
   (b + c + q)/g +
   (a + e + j + p + q)/i +
   (c + f + i)/r + (g + i + s)/
    f + (m + t)/o +
   (c + g + k + n)/u +
   (2*h + k + o + p + 2*t + v)/
    j + (b + k + u + v)/q +
   w/s + (k + n + t)/x +
   (2*f + o + v + x)/e +
   (g + 2*l + q + s + v + x)/
    b + (2*s + u + w + x)/d +
   (e + j + m + o)/y +
   (c + n + u + y)/h +
   (e + p + r + u + y)/k +
   (b + h + t + 2*y)/c +
   (b + c + t)/z + (i + z)/a +
   (h + l + z)/w +
   (2*e + r + z)/l +
   (a + d + j + n + r + w + z)/
    t + (o + x + y + z)/v

Now, your abc probably should be a Union-ed list of all denominators.
With the best,

János



  • Prev by Date: Re: Re: a curious answer
  • Next by Date: Re: RE: "Anti-Comments"?
  • Previous by thread: Re: efficient term collection algorithm
  • Next by thread: Re: efficient term collection algorithm