Recognizing special cases of a defined function for permuted arguments

Question

I have a number of ugly ways to implement the following pattern recognition task, but I'm looking for something elegant to keep my notebook tidy.

I need to define a function of six variables $f(a,b,c;A,B,C)$ which is known to be unchanged under the simultaneous interchange of any two of $a,b,c$ and of the corresponding $A,B,C$:

$$\begin{align}&f(a,b,c;A,B,C) = f(a,c,b;A,C,B) = f(b,a,c;B,A,C) \\ =&f(b,c,a;B,C,A) = f(c,a,b;C,A,B) = f(c,b,a;C,B,A)\end{align}$$

EDIT for clarity: Given one definition, how do I get Mathematica to try all possibilities within the restricted set of permutations shown above for pattern matching? I need to mimic the effect of SetAttributes[f,Orderless].

More concretely, if I define the special case:

f[a_, 0, b_, A_, 0, C_] := (a+b)/(A-C)

a function call f[x, y, 0, m, n, 0] should match, and return (x+y)/(m-n). But f[x, y, 0, m, 0, n] should not match, and thus return it must be returned unevaluated.

Added question: Instead of finding a way to get Mathematica to try all the possibilities when pattern matching, would it be easier to write code such that when a representative definition for f is made, the kernel automatically adds further definitions of f for the remaining permutations of the arguments?

Answer 1

I think Bob Hanlon had the right idea in using Orderless but his suggestion is overly naive.
Instead we must treat only the triplets as orderless so we will need an additional head.

Edit: my answer was also wrong, but I am updating it with the correction from your comment below.

SetAttributes[f1, Orderless]

f[a_, b_, c_, A_, B_, C_] := 
 With[{body = f1[{a, A}, {b, B}, {c, C}]}, body /; Head[body] =!= f1]

f1[{a_, A_}, {0, 0}, {c_, C_}] := (a + c)/(A - C)

Now:

f[x, y, 0, m, n, 0]

f[x, y, 0, m, 0, n]

(x + y)/(m - n)

f[x, y, 0, m, 0, n]

Answer 2

I think you need to use a group-theoretical construction. In this way you will have full freedom in specifying any group of permutations you need. In your case the group is

G = PermutationGroup[{Cycles[{{1, 2}, {4, 5}}], Cycles[{{1, 2, 3}, {4, 5, 6}}]}];

This generates a symmetric group on {1, 2, 3}, which also forces the same permutations on {4, 5, 6}. These are the group elements, as permutation lists:

PermutationList[#, 6] & /@ GroupElements[G]

{{1, 2, 3, 4, 5, 6}, {1, 3, 2, 4, 6, 5}, {2, 1, 3, 5, 4, 6}, {2, 3, 1, 5, 6, 4}, {3, 1, 2, 6, 4, 5}, {3, 2, 1, 6, 5, 4}}

There are six permutations, corresponding to those of the symmetric group on {1, 2, 3}.

Now construct the following function:

SetAttributes[SetDelayedPermuted, {HoldAll, SequenceHold}];

SetDelayedPermuted[f_[args___], rhs_, group_] := ((f[##] := rhs) & @@@ Permute[{args}, group];)

Let us try your definition, though I'm changing the - sign in the denominator to a + sign, because otherwise I think there is some inconsistency:

SetDelayedPermuted[f[a_, 0, b_, A_, 0, C_], (a + b)/(A + C), G]

Now we check your two cases (remember I changed a sign):

f[x, y, 0, m, n, 0]

(x + y) / (m + n)

f[x, y, 0, m, 0, n]

f[x, y, 0, m, 0, n]

We can see how many definitions were actually needed:

??f

Global`f

f[b_,0,a_,C_,0,A_]:=(a+b)/(A+C)
f[b_,a_,0,C_,A_,0]:=(a+b)/(A+C)
f[0,b_,a_,0,C_,A_]:=(a+b)/(A+C)

Note how symmetry in both a<->b and A<->C was implemented simultaneously (hence we ended up with 3 definitions, instead of 6). That's why I think a consistent definition was having (a+b)/(A+C) or (a-b)/(A-C) but not (a+b)/(A-C) on the right hand side.

Answer 3

I would do this by defining a preferred ordering to sort the first three arguments. In this example I will use canonical Mathematica Ordering but in principle you could use anything.

I would define

f[a_, b_, c_, A_, B_, C_] := With[
   {order = Ordering[{a, b, c}]}, (* Get ordering of first three arguments *)
   f @@ {
     Sequence @@ ({a, b, c}[[order]]), (* Sort first three arguments *)
     Sequence @@ ({A, B, C}[[order]])  (* Reorder second three similarly *)
     }
   ] /; Not[OrderedQ[{a, b, c}]] (* Avoid infinite loop. *)

Then

f[c, b, a, C, B, A]
(* = f[a, b, c, A, B, C] *)
f[3, 0, -3, foo, bar, baz]
(* = f[-3, 0, 3, baz, bar, foo] *)

etc.

Answer 4

Give f the attribute Orderless

SetAttributes[f, Orderless];

f[0, 0, 0, 0, z_, z_] = -(1/z);
f[0, 0, 0, 0, y_, z_] = -(1/(y - z)) Log[y/z];

f @@@ Permutations[{0, 0, 0, 0, z, z}] // Union

{-(1/z)}

f @@@ Permutations[{0, 0, 0, 0, y, z}] // Union

{-(Log[y/z]/(y - z))}