Generating a pattern to be matched

Question

I am dealing with brackets br[arg1, arg2, ...], having a sequence of positive integers (labels) as argument. Brackets are totally antisymmetric, hence it is important - when reordering labels - to keep track of the sign of the permutation.

I want to write a very simple sorting function, such that, given an arbitrary expression involving several brackets, reorders their arguments putting a prescribed subset of labels in front.

I have a first function, sort, that works just fine when the subset of distinguished labels has length 2.

sort[expr_, lab_List] := Block[{},

 expr //. {br[a1___, lab[[1]], a2___, lab[[2]], a3___] :> 
           Signature[{a1, lab[[1]], a2, lab[[2]], a3}]*Signature[Join[{lab[[1]], lab[[2]]}, { a1, a2, a3}]]*
           br @@ Join[{lab[[1]], lab[[2]]}, {a1, a2, a3}]}
]

As an example, consider

ex = br[1, 5, 7, 8, 9] br[3, 1, 5, 7, 8] br[3, 1, 4, 5] + br[2, 3, 4, 1, 6, 5] br[1, 3, 5] br[1, 7, 8, 5, 3]
sort[ex, {1, 5}]

Out[3]= -br[1, 5, 3, 4] br[1, 5, 3, 7, 8] br[1, 5, 7, 8, 9] + br[1, 5, 3] br[1, 5, 7, 8, 3] br[1, 5, 2, 3, 4, 6]

Then I tried to generalize it, to allow subset of arbitrary length to be sorted in front of every argument and this is what I came up with.

genSort[expr_, lab_List] := Block[{otherLabels},

 otherLabels = Table[ToExpression@StringJoin["a", ToString[i]], {i, 1, Length[lab] + 1}];

 expr //. {br @@ Riffle[(Pattern[#, ___] & /@ otherLabels), lab] :> 
           Signature[Riffle[otherLabels, lab]]*Signature[Join[lab, otherLabels]]*
           br @@ Join[lab, otherLabels]}
]

Now when I try to use this more general version of the function on the previous example, I get

ex = br[1, 5, 7, 8, 9] br[3, 1, 5, 7, 8] br[3, 1, 4, 5] + br[2, 3, 4, 1, 6, 5] br[1, 3, 5] br[1, 7, 8, 5, 3]
genSort[ex, {1, 5}]

During evaluation of In[44]:= ReplaceRepeated::rrlim: Exiting after br[3,1,4,5] br[1,5,7,8,9] br[3,1,5,7,8]+br[1,3,5] br[1,7,8,5,3] br[2,3,4,1,6,5] scanned 65536 times.
Out[4]= 2 br[1, 5, a1, a2, a3]^3

Now, beside the warning about the ReplaceRepeated, obviously the problem is that I am not able to convince Mathematica to identify the a1,a2,... with appropriate (possibly empty) sequences of labels, as it was seamlessly doing with the more specific function above.
I understand that Mathematica is just using the labels a1, a2, ... ignoring the pattern matching construct, but I still believe that the implementation is correct in spirit. Is there a way to save it, or is it doomed? (I also tried to use some Evaluate command here and there, it doesn't seem to change anything.)

On a separate note, I created the list of a-indices with a rather cumbersome construct. However, this was the only one I could think of which could allow to create an a priori unspecified number of objects and to append some blanks to them to define a pattern (neither a[i], nor Subscript[a,i] would do, of course). Is there a better way out?

Thanks for your help!

Answer 1

About the issue in the code

RuleDelayed evaluates its left-hand side but not its right-hand side. In the expression

br @@ Riffle[(Pattern[#, ___] & /@ otherLabels), lab] :> 
    Signature[Riffle[otherLabels, lab]] *
    Signature[Join[lab, otherLabels]] *
    br @@ Join[lab, otherLabels]

the pattern is correctly constructed in the left-hand side and will be of the form

br[a1___, lab[[1]], a2___, lab[[2]], ..., lab[[n - 1]], an___]

with the lab[[i]] replaced by their corresponding values.

The right-hand side, since not evaluated, does not contain the symbols a1, a2, ..., an at the time of the construction of the rule; it contains instead the unevaluated symbol otherLabels. This means that the ai hidden in otherLabels are not bound to their pattern counterpart on the left-hand side.

Specifically, when an expression matches the pattern given in the left-hand side, the subexpressions constructed from the ai___ won't be passed to the right-hand side, since there are no ai to pass them to. At the time when otherLabels is evaluated, this information is lost and only the symbols ai are returned.

A simple example of this issue is

labels = {a1, a2, a3};
rule = f[a1___, 1, a2___, 3, a3___] :> labels
(* f[a1___, 1, a2___, 3, a3___] :> labels *)

f[1, 2, 3, 4, 5, 6] /. rule
(* {a1, a2, a3} *)

Solution

A possible solution is to use With to make in the RuleDelayed a "literal" replacement of the symbol otherLabels with its value. For the example above, doing so, we have a renaming of the patterns:

rule2 = With[{temp = labels}, f[a1___, 1, a2___, 3, a3___] :> temp]
(* f[a1$___, 1, a2$___, 3, a3$___] :> {a1, a2, a3} *)

so it returns the same result:

f[1, 2, 3, 4, 5, 6] /. rule2
(* {a1, a2, a3} *)

Here are two possible work-arounds to get the renaming on the right-hand side as well:

1) Using the With-symbol to construct the pattern on the left-hand side:

rule2 = With[{temp = labels}, f @@ Riffle[(Pattern[#, ___] & /@ temp), {1, 3}] :> temp]
(* f[a1$___, 1, a2$___, 3, a3$___] :> {a1$, a2$, a3$} *)

f[1, 2, 3, 4, 5, 6] /. rule2
(* {2, 4, 5, 6} *)

2) Constructing the pattern in a Module and giving it to RuleDelayed:

rule2 = Module[{patt}, 
    patt = {a1___, 1, a2___, 3, a3___}; 
    With[{temp = labels}, f @@ patt :> temp]
]
(* f[a1$___, 1, a2$___, 3, a3$___] :> {a1$, a2$, a3$} *)

f[1, 2, 3, 4, 5, 6] /. rule2
(* {2, 4, 5, 6} *)

Improving the code

Since you do not need a Block or Module, we can use the first approach above, which gives for your code (ReplaceRepeated is replaced by ReplaceAll and I use Unique to create the symbols):

genSort2[expr_, lab_List] := expr /. 
   With[{temp = Table[Unique["a"], Length[lab] + 1]}, 

        {br @@ Riffle[Pattern[#, ___] & /@ temp, lab] :> 
           Signature[Riffle[temp, lab]] * Signature[Join[lab, temp]] * br @@ Join[lab, temp]
        }
   ];

Taking your example we get:

ex = br[1, 5, 7, 8, 9] br[3, 1, 5, 7, 8] br[3, 1, 4, 5] + 
     br[2, 3, 4, 1, 6, 5] br[1, 3, 5] br[1, 7, 8, 5, 3];

genSort2[ex, {1, 5}]
(* -br[1, 5, 3, 4] br[1, 5, 3, 7, 8] br[1, 5, 7, 8, 9] *)

We are missing the subexpression br[1, 5, 3] br[1, 5, 7, 8, 3] br[1, 5, 2, 3, 4, 6] in the result because the right-hand side is not yet correctly constructed. The last term of it gave 0 after applying the rule,

genSort2[br[1, 5, 2, 3, 4, 6], {1, 5}]
(* 0 *)

because Riffle[{2, 3, 4, 6}, {1, 5}] gave {2, 1, 3, 5, 4, 1, 6} (the elements of the second list are used cyclically), and its Signature gave in turn 0.

This will happen whenever the number of arguments of br is greater than 2 Length[lab] + 1:

genSort2[br[2, 5, 1, 3], {1}]
(* 0 *)

Since Signature works on expression with heads different from List, you can simply take the expression that was matched by the pattern and passed it to the right-hand side of the rule.

Final version

Here is the final version of the code that keeps your initial idea:

genSort2[expr_, lab_List] := expr /. 
     With[{temp = Table[Unique["a"], Length[lab] + 1]}, 

          {lhs: br @@ Riffle[Pattern[#, ___] & /@ temp, lab] :> 
              Signature[lhs] * Signature[Join[lab, temp]] * br @@ Join[lab, temp]
          }
     ];

We get

genSort2[ex, {1, 5}]
(* -br[1, 5, 3, 4] br[1, 5, 3, 7, 8] br[1, 5, 7, 8, 9] + 
    br[1, 5, 3] br[1, 5, 7, 8, 3] br[1, 5, 2, 3, 4, 6] *)

which agrees with your sort function:

% === sort[ex, {1, 5}]
(* True *)

Answer 2

This may or may not help. I would keep the arguments of br in canonical order, rather than trying to change the order manually.

This might be done by

unorderedq[_] := True
unorderedq[_?OrderedQ] := False

unorderedq[{1, 2}]
(* False *)

unorderedq[{2, 1}]
(* True *)

br[u__] /; unorderedq[{u}] := br @@ Sort[{u}] Signature[{u}]