How to remove some elements in a list based on a rule?

Question

I want to deal with the following list.

mylist = Table[cof[i] exp[i], {i, 1, n}]; (*n is very larege *)

exp[ ] is a function of {x1, x2, x3, x4, ...} and cof[] doesn't depend on the variables {x1, x2, x3, x4, ...}. exp[ ] has a pattern like this, x_ Exp[_] (see the following example). I want to deal with this list according to some rule.

That is, if exp[k1] can be obtained by exp[k2] under some permutation of the variables {x1, x2, x3, x4, ...}, then I delete the term cof[k2] exp[k2] in mylist and change cof[k1] to (cof[k1] + cof[k2]). It seems I should compare all the exp[] terms. I cannot find a way to that for this problem. Any help?

Here is a simple example,

inputlist = {2 const x1 x2 Exp[2 x1 x1 + 3 x2 x2 + 2 x3 x3 - x1 x2 + x2 + cf1], 
             2 x1 x3 Exp[2 x1 x1 + 2 x2 x2 + 4 x3 x3 - x1 x2  ],
             -x1 x3 Exp[2 x1 x1 + 3 x3 x3 + 2 x2 x2 - x1 x3 + x3 ],
             3 Exp[2 x1 x1 + 3 x2 x2 + 4 x3 x3 ],
             -2 Exp[4 x1 x1 + 2 x2 x2 + 3 x3 x3 ]};

The corresponding exp[] can be written as,

exp[1] = x1 x2 Exp[2 x1 x1 + 3 x2 x2 + 2 x3 x3 - x1 x2 + x2];
exp[2] = x1 x3 Exp[2 x1 x1 + 2 x2 x2 + 4 x3 x3 - x1 x2  ];
exp[3] = x1 x3 Exp[2 x1 x1 + 3 x3 x3 + 2 x2 x2 - x1 x3 + x3 ];
exp[4] = Exp[2 x1 x1 + 3 x2 x2 + 4 x3 x3 ];
exp[5] = Exp[4 x1 x1 + 2 x2 x2 + 3 x3 x3 ];

Based on the rule, we notice that

exp[1] /. {x1 -> x1, x2 -> x3, x3 -> x2} == exp[3]; 
exp[4] /. {x1 -> x2, x2 -> x3, x3 -> x1} == exp[5];

so the output list should be

outputlist = {
  (2 const Exp[cf1]-1) x1 x2 Exp[2 x1 x1 + 3 x2 x2 + 2 x3 x3-x1 x2 + x2], 
  2 x1 x3 Exp[2 x1 x1 + 2 x2 x2 + 4 x3 x3 - x1 x2 ],
  Exp[2 x1 x1 + 3 x2 x2 + 4 x3 x3]
}

Answer 1

It seems to me that the key challenge is to identify when two expressions are equivalent with a suitable permutation of variables. In this answer I'll address that part first, with a full solution to the problem afterwards.

The variable permutation part

Here is an idea to find the variable permutations using the pattern matcher. The basic concept is to create a pattern from expr1, essentially by replacing the variables with Blank[]s. That pattern is used to define a temporary function f which returns the list of symbols matching the Blank[]s. The function f is then applied to expr2. If expr2 has the same structure as expr1, the pattern will match and f will return a list of the symbols in expr2 which correspond to the variables in expr1.

varPattern = _Symbol?(! NumericQ[#] &);

variableMapping[expr1_, expr2_] := Module[{f},
  With[{vars = Union@Cases[{expr1}, varPattern, -1]},
   f[_] = {};
   f[expr1 /. (# -> Pattern[#, varPattern] & /@ vars)] := vars;
   f[expr2] /. v : {__} :> Thread[v -> vars]]]

The function variableMapping[expr1,expr2] returns a rule list that transforms expr2 to expr1. For example:

variableMapping[a + 2 b, 2 c + d]
(*  {d -> a, c -> b}  *)

Using the examples in the question:

variableMapping[exp[1], exp[3]]
(*  {x1 -> x1, x3 -> x2, x2 -> x3}  *)

variableMapping[exp[4], exp[5]]
(*  {x2 -> x1, x3 -> x2, x1 -> x3}  *)

If there is no match an empty list is returned:

variableMapping[exp[1], exp[2]]
(*  {}  *)

The full answer

I'll step through this using global variables for easier reading, but of course you would want to put it all into a Module eventually.

First we need to separate the inputlist into cof and exp terms. There is probably a much smarter way to do this, but this works:

vars = x1 | x2 | x3;
a = inputlist /. {Exp[_] -> 1, vars -> 1}
b = inputlist /. ___ Exp[x_] :> x /. vars -> 0
cof = a Exp[b];
exp = inputlist/cof;

Now use the variableMapping function on each pair of elements in exp to find the list of replacements. For this problem the actual variable permutation is not required, we just need to know if one exists, so the check is simply whether variableMapping returns an empty list or not:

reps = #2 -> #1 & @@@ 
  Select[Subsets[Range@Length@exp, {2}], 
   variableMapping @@ exp[[#]] != {} &]
(*  {3 -> 1, 5 -> 4}  *)

There may be cases where three or more exp terms are considered interchangeable, so we need to prune the replacement list:

reps = GatherBy[reps, First][[All, 1]];

Now all that's required is to modify the cof list according to the rules set out in the question:

(cof[[#2]] += cof[[#1]]; cof[[#1]] = 0) & @@@ reps;
cof
(*  {-1 + 2 const E^cf1, 2, 0, 1, 0}  *)

outputlist = cof exp

(*  {E^(2 x1^2 + x2 - x1 x2 + 3 x2^2 + 2 x3^2) (-1 + 2 const E^cf1) x1 x2,
     2 E^(2 x1^2 - x1 x2 + 2 x2^2 + 4 x3^2) x1 x3,
     0,
     E^(2 x1^2 + 3 x2^2 + 4 x3^2),
     0}  *)