16

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?

QuantumDot
  • 19,601
  • 7
  • 45
  • 121

4 Answers4

16

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.

Mr.Wizard
  • 271,378
  • 34
  • 587
  • 1,371
jose
  • 6,328
  • 1
  • 14
  • 24
  • Nice answer! and kudos to you for making the RHS consistent. I like especially how it generates the necessary definitions. – QuantumDot Sep 03 '14 at 18:57
  • A really nice solution! Congratulations, bounty hunter. :-) – Mr.Wizard Sep 05 '14 at 10:47
  • I edited your code to make it a bit shorter. I also changed the formatting with hope of making it easier to copy and paste the code sections. I hope you don't mind. – Mr.Wizard Sep 05 '14 at 10:51
  • Thank you QuantumDot! And thank you Mr.Wizard for improving the answer. – jose Sep 05 '14 at 14:43
  • Thanks for this! I actually have an application where a function I'm interested in is only partly symmetric. I think I'll use this instead of what I have now. – J. M.'s missing motivation Aug 02 '16 at 06:27
13

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]
Mr.Wizard
  • 271,378
  • 34
  • 587
  • 1,371
  • 2
    This is better, but the invariance of the function $f$ isn't for permutations of first three arguments $a,b,c$ independent of the second three $x,y,z$. They are tied together. But no problem; your answer and @BobHanlon's answer pointed me in the right direction: I could declare SetAttributes[f1, Orderless] but with the arguments arranged f1[{a_,x_},{b_,y_},{c_,z_}], and make the library of special cases for f1. Then finally, I put f[a_,b_,c_,d_,e_,f_] = f1[{a,x},{b,y},{c,z}]. I tried a few cases and it seems to work. What do you think? – QuantumDot Jul 24 '14 at 08:31
  • Sorry, you're right, I wasn't thinking clearly. Hopefully thinking better now, and your solution sounds just fine. Why don't you self-answer so I can vote for it? – Mr.Wizard Jul 24 '14 at 09:25
  • @QuantumDot This question just got bumped by Community♦ because it has no positively voted answer. Please post the method in your comment above as a self-answer. If you don't I shall edit my answer to include it. – Mr.Wizard Aug 23 '14 at 08:19
  • Thanks for the notification; you can go ahead and include the solution your answer. Then I'll mark it as accepted. – QuantumDot Aug 23 '14 at 14:39
  • It appears that I have certain cases where an explicit form is not known and thus no pattern matches. In that case, the function call to f[a,b,c,x,y,z] would return f1[{a,x},{b,y},{c,z}]. I'd like it to return f instead of f1 which is supposed to be an internal function. Do you know how this can be accomplished without resulting in an infinite loop? – QuantumDot Sep 01 '14 at 17:37
  • @Quantum I keep forgetting about this. Once again I don't have (or want to take) time for this right now. (It's Labor Day here and fine weather too.) What you want should certainly be possible. – Mr.Wizard Sep 01 '14 at 20:39
  • 1
    Might this be a good way to enable definitions through f instead of f1?: f /: SetDelayed[f[a_, b_, c_, d_, e_, f_], expr_] := (f1[{a, d}, {b, e}, {c, f}] := expr). Ditto for set. Sometimes I overlook pitfalls with such workarounds. – Michael E2 Sep 01 '14 at 21:22
  • @MichaelE2 thanks for the response, I'm not entirely sure how this works and how to use it. Exactly where do I insert this line? Maybe you can explain in an answer? – QuantumDot Sep 01 '14 at 21:29
  • @QuantumDot Example: f[a_, 0, c_, d_, 0, f_] := (a + c)/(d - f) should define value for f1, so that if any corresponding pair are both zero, then the value is given by the formula. The code overrides :=, so that a value for f1 is set instead of one for f. – Michael E2 Sep 01 '14 at 22:08
  • @Mr.Wizard Your corrected answer is working very nicely. I will wait for further answers/comments. – QuantumDot Sep 01 '14 at 22:50
5

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.

evanb
  • 6,026
  • 18
  • 30
1

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))}

Bob Hanlon
  • 157,611
  • 7
  • 77
  • 198