How to modify the output result of an evaluation

Question

For ease of notation, I have defined a function, $f$, that defines the permutation of Bosonic particles such that it has the following properties (the form of $f$ is irrelavent for this question):

1. $\textbf{f(a,b,c,d) = f(b,a,c,d) = f(a,b,d,c) = f(b,a,d,c)}$ - i.e. the value of the function remains invariant under the exchange of the first pair of arguments ($a,b$) or the second pair ($c,d$), or both. This is not true for the exchange of arguments belonging to different pairs: $f(a,b,c,d)\ne f(a,c,b,d)$.

2. The ordering of which the pairs appear do not matter: $\textbf{f(a,b,c,d) = f(c,d,a,b) = f(d,c,b,a)}$ - where the latter equality results by exchanging the arguments in pair 1 and pair 2 (property 1).

3. $\textbf{f(a,b,c,c)=f(a,b)}$ and $\textbf{f(a,a,c,d)=f(c,d)}$- i.e. any arguments repeated within a pair have no effect on the value of $f$ and so may be removed.

The number of pairs increases with the number of particles that is considered so in the following I need a generalised approach. So consider the following output in Mathematica which results when the arguments are generated from a Permutation command:

 f[1, 1, 1, 2, 2, 1] + f[1, 1, 2, 3, 3, 2] + f[1, 2, 2, 3, 3, 1] + 
 f[1, 2, 3, 1, 2, 3] + f[1, 3, 2, 1, 3, 2] + f[1, 3, 2, 2, 3, 1] + 
 f[1, 3, 3, 1, 2, 2] ...etc

Due to properties 1 and 2, terms 3, 4 and 5 are the same. Due to properties 2 and 3, terms 6 and 7 are the same and should become $f(1,3,3,1)$.

I want a function (or something similar) which can envoke the above properties to re-write the output as the following:

$f(2,3,3,2) + f(1,2,2,1) + 3f(1,2,2,3,3,1) + 2f(1,3,3,1)$

This is required since for arbitrarily large $N$, the output becomes too large. I am also aware of the Replace command, but using this would be laborious for large $N$.

I am using Mathematica 10 on Mac if this helps. Thank you.

Answer 1

You can play with patterns for f. Here is alternative approach:

Function[expr,
  Block[{g},
   Block[{f, h},

     SetAttributes[h, Orderless];

     f[x___] := (g @@ (h @@ (h @@@ Partition[{x}, 2]))) /. {h[y_, y_] -> Sequence[],
                                                            h -> Sequence};

     expr

     ] /. g -> f
   ]
  ][
 f[1, 1, 1, 2, 2, 1] + f[1, 1, 2, 3, 3, 2] + f[1, 2, 2, 3, 3, 1] + 
  f[1, 2, 3, 1, 2, 3] + f[1, 3, 2, 1, 3, 2] + f[1, 3, 2, 2, 3, 1] + 
  f[1, 3, 3, 1, 2, 2]
 ]

f[1, 2, 1, 2] + 2 f[1, 3, 1, 3] + f[2, 3, 2, 3] + 3 f[1, 2, 1, 3, 2, 3]