Sum over all permutations

Question

I have n variables and a function that has all of them as variables. n-3 of them in terms of the entries of two lists. The possible entries in the lists $\alpha$ and $\beta$ range from {2,...n-2}. Now I want to sum over all possible permutations of these n-3 elements (aka $P_{n-3})$, i.e.

$$f=\sum_{\alpha,\beta \in P_{n-3}}A[1,\alpha,n-1,n]S[\beta,\alpha]A[n,\beta,n-1,1]$$

with A and S some other functions. How do I program this into mathematica.

I thought about writing f as a pure function. But then how to implement this sum over permutations?

Thanks for any advice!

Answer 1

I'm going to show solution similar to one I have shown here.

n=5;
A[1, Sequence@@#1,n-1,n] S[Sequence@@#2, Sequence@@#1] B[1,Sequence@@#2, n-1,n] & @@@ (
Tuples[#, 2] &@Permutations[Range[2, n - 2]]) // Total

A[1, 2, 3, 4, 5] B[1, 2, 3, 4, 5] S[2, 3, 2, 3] + A[1, 3, 2, 4, 5] B[1, 2, 3, 4, 5] S[2, 3, 3, 2] + A[1, 2, 3, 4, 5] B[1, 3, 2, 4, 5] S[3, 2, 2, 3] + A[1, 3, 2, 4, 5] B[1, 3, 2, 4, 5] S[3, 2, 3, 2]

---

In this case a straightforward solution looks clearer:

Sum[
    A[1, Sequence@@a, n-1, n] S[Sequence@@b, Sequence@@a] B[1, Sequence@@b, n-1, n]
    , {a, #}, {b, #}] &@ Permutations[Range[2, n - 2]];

and is faster.

---

Edit

another variation to makes things clearer:

(A[1, #1, n - 1, n] S[#2, #1] B[1, #2, n - 1, n]
) & @@@ Apply[Hold@Sequence, Tuples[Permutations[Range[2, n - 2]], 2], {2}] 
// ReleaseHold // Total

which is the same as:

Composition[
  Total,
  ReleaseHold,
  Apply[A[1, #1, n - 1, n] S[#2, #1] B[1, #2, n - 1, n] &, #, {1}] &,
  Apply[Hold@Sequence, #, {2}] &,
  #~Tuples~{2} &,
  Permutations,
  2~Range~(# - 2) &
][n]

Answer 2

Here's a way, assuming $S[\beta,\alpha]$ means that the function has two arguments, each of which is a List.

ClearAll[a, s];
SetAttributes[a, Listable];
f[n_] := Module[{perm, alpha, beta},
  perm = Permutations[Range[2, n - 2]];
  alpha = Transpose @ ArrayPad[perm, {0, {1, 2}}, PadRight[{n - 1, n, 1}, n]];
  beta  = Transpose @ ArrayPad[perm, {0, {1, 2}}, PadRight[{n - 1, 1, n}, n]];
  Outer[s, perm, perm, 1] . a @@ alpha . a @@ beta
  ]

f[5] // Expand
 (* a[1, 2, 3, 4, 5] a[5, 2, 3, 4, 1] s[{2, 3}, {2, 3}] + 
    a[1, 3, 2, 4, 5] a[5, 2, 3, 4, 1] s[{2, 3}, {3, 2}] + 
    a[1, 2, 3, 4, 5] a[5, 3, 2, 4, 1] s[{3, 2}, {2, 3}] + 
    a[1, 3, 2, 4, 5] a[5, 3, 2, 4, 1] s[{3, 2}, {3, 2}]  *)

If you would rather have s[2, 3, 3, 2] instead of s[{2, 3}, {3, 2}], then you can use this:

ClearAll[a, s];
SetAttributes[a, Listable];
f[n_] := Module[{perm, alpha, beta},
  perm = Permutations[Range[2, n - 2]];
  alpha = Transpose @ ArrayPad[perm, {0, {1, 2}}, PadRight[{n - 1, n, 1}, n]];
  beta  = Transpose @ ArrayPad[perm, {0, {1, 2}}, PadRight[{n - 1, 1, n}, n]];
  Apply[s, Flatten[Outer[List, perm, perm, 1], {{1}, {2}, {3, 4}}], {2}] .
    a @@ alpha . a @@ beta
  ]

f[5] // Expand
 (* a[1, 2, 3, 4, 5] a[5, 2, 3, 4, 1] s[2, 3, 2, 3] + 
    a[1, 3, 2, 4, 5] a[5, 2, 3, 4, 1] s[2, 3, 3, 2] + 
    a[1, 2, 3, 4, 5] a[5, 3, 2, 4, 1] s[3, 2, 2, 3] + 
    a[1, 3, 2, 4, 5] a[5, 3, 2, 4, 1] s[3, 2, 3, 2] *)

Remark: If more was known about the functions $A$ and $S$, then perhaps more could be said about an efficient way to compute the sum. As it is, once you get above n == 9, the computation takes a lot of memory and time.