2
$\begingroup$

Consider the following two codes. The first one

Table[Total[DeleteDuplicates[{p[i1], p[i2]}]], {i1, 2}, {i2, 2}]

works:

{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}

but the second one

Table @@ {Total[DeleteDuplicates[{p[i1], p[i2]}]], {i1, 2}, {i2, 2}}

does not:

{{2 p[1], p[1] + p[2]}, {p[1] + p[2], 2 p[2]}}

However, I want to construct this table in $m$-dimensional case, which means

t[n_, m_] := Table @@ {Total[DeleteDuplicates[Table[p[i[j]], {j, m}]]], Sequence @@ Table[{i[j], n}, {j, m}]}

and then it outputs the incorrect result as the second one above. I cannot use

t[n_, m_] := Table[Total[DeleteDuplicates[Table[p[i[j]], {j, m}]]], Sequence @@ Table[{i[j], n}, {j, m}]]

because it will cause a compile error:

t[4, 3]

Table: Iterator {Sequence[{i[1],4},{i[2],4},{i[3],4}]} does not have appropriate bounds.

How could I deal with it?

$\endgroup$
  • $\begingroup$ For the second one, it doesn't work, because the DeleteDuplicates isn't carried over (i.e. {Total[DeleteDuplicates[{p[i1], p[i2]}]], {i1, 2}, {i2, 2}} evaluates first to {p[i1] + p[i2], {i1, 2}, {i2, 2}} before Table acts. To get the last version to work, do Sequence @@ Table[{i[j], n}, {j, m}] // Evaluate instead of just Sequence @@ Table[{i[j], n}, {j, m}]. $\endgroup$ – march Jun 22 '17 at 23:23
3
$\begingroup$

Is this what you're after?

n = 5
ps = Array[p, n]
Total /@ DeleteDuplicates /@ Tuples[ps, n]
$\endgroup$
2
$\begingroup$

Alan already gave a nice alternative using Tuples, but perhaps closer to the original formulation:

Array[Total[DeleteDuplicates[p /@ {##}]] &, {2, 2}]
{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}
$\endgroup$
1
$\begingroup$

Re: t[n_, m_] := Table @@ {...} outputs the incorrect result:

You need to pass the first element in your list {Total[...], Sequence@@...} to Table as Unevaluated so that DeleteDuplicates gets to work after iterator values are injected:

ClearAll[t]
t[n_, m_] := Table @@ {Unevaluated@Total[DeleteDuplicates[Table[p[i[j]], {j, m}]]], 
      Sequence @@ Table[{i[j], n}, {j, m}]}

t[2, 2]

{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}

t[3, 2]

{{p[1], p[1] + p[2], p[1] + p[3]}, {p[1] + p[2], p[2], p[2] + p[3]},
{p[1] + p[3], p[2] + p[3], p[3]}}

t[2, 3]

{{{p[1], p[1] + p[2]}, {p[1] + p[2], p[1] + p[2]}},
{{p[1] + p[2], p[1] + p[2]}, {p[1] + p[2], p[2]}}}

Re: I cannot use t[n_, m_] := Table[..] because it will cause a compile error

You can wrap Sequence@@... with Evaluate:

ClearAll[t2]
t2[n_, m_] := Table[Total[DeleteDuplicates[Table[p[i[j]], {j, m}]]], 
  Evaluate[Sequence @@ Table[{i[j], n}, {j, m}]]      ]
t2[2, 2]

{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}

Note: Cleanest way is defining your t[n_,m_] using Array as in Mr.Wizard and Alan's answers:

ClearAll[t0]
t0[n_, m_] := Array[Total[DeleteDuplicates[p /@ {##}]] &, ConstantArray[n, m]]

t0[3, 2]

{{p[1], p[1] + p[2], p[1] + p[3]}, {p[1] + p[2], p[2], p[2] + p[3]},
{p[1] + p[3], p[2] + p[3], p[3]}}

$\endgroup$
  • $\begingroup$ Forgive me but I think this unnecessarily baroque, and I updated my answer with a competing recommendation if this sort of thing is desired. $\endgroup$ – Mr.Wizard Jul 23 '17 at 9:50
  • $\begingroup$ @Mr.Wizard, somehow I could not get the version with Unevaluated work when I first tried. Thank you. $\endgroup$ – kglr Jul 23 '17 at 10:03
1
$\begingroup$

Updated for higher dimensions.

You may use Outer.

It seems that you just want to do an outer-product but with a special function instead of Times. This function should have the characteristics of f defined below.

With

ClearAll[f]
f[s : Repeated[a_, ∞]] := a
f[OrderlessPatternSequence[a_, a_, b__]] := f[a, b]
f[b__] := Total[{b}]

f is overloaded with three signatures. Note that f takes an arbitrary number of parameters.

  1. The first is when all parameters are equal then return the parameter.
  2. The second removes duplicates from the parameters. Here, f @@ DeleteDuplicates[{a, b}] could be used instead of f[a, b] to short-circuit recursive calls.
  3. The third gives the sum of the terms; which will all be unique after passing through the definition above.

Actually, f can be simplified to,

ClearAll[f]
f[b__] := Total@DeleteDuplicates@{b}

Which makes t below noticeably faster. Perhaps the fastest posted thus far.


And

ClearAll[t, p];
t[dims__Integer?Positive] := Outer[f, Sequence @@ Map[p, Range /@ {dims}, {2}]]

t performs a generalised outer-product over the dimensions using f instead of Times; an outer-f. Note that t also takes an arbitrary number of parameters.

Then

t[2, 2]
% // MatrixForm
{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}

Mathematica graphics

t[2, 3]
% // MatrixForm
{{p[1], p[1] + p[2], p[1] + p[3]}, {p[1] + p[2], p[2], p[2] + p[3]}}

Mathematica graphics

And higher dimensions

t[3, 3, 3];
% // MatrixForm

Mathematica graphics

t[2, 3, 2, 4];
% // MatrixForm

Mathematica graphics

And so on.

Hope this helps.

$\endgroup$
  • $\begingroup$ How would you generalize this to larger examples? I mean like Array[Total[DeleteDuplicates[p /@ {##}]] &, {2, 3, 2, 4}] $\endgroup$ – Mr.Wizard Jul 23 '17 at 13:49
  • 1
    $\begingroup$ @Mr.Wizard See update $\endgroup$ – Edmund Jul 23 '17 at 19:47
  • $\begingroup$ Actually, I could speed things up by changing f to ClearAll[f]; f[b__] := Total@DeleteDuplicates@{b}. Then I think this would be a contender to be one of the fastest here. $\endgroup$ – Edmund Jul 24 '17 at 1:34

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.