How do I reassign canonical ordering of symbols?

Question

I have a big polynomial that evaluates to: $$A^2 e^2 \phi ^- \phi ^++A e \phi ^- \phi ^+ c_{2 w} g_Z+\frac{1}{2} A e g h W^- \phi ^+ +\ll13\gg,$$ which is supposed to represent some terms in the standard model Lagrangian. I need to do the following:

1. Reorganize the factors in each term so that $e$ comes before $A$ and $\phi^+$ before $\phi^-$. So that the first term, for example, would instead read $e^2A^2\phi ^+\phi ^- $.

2. Reorganize the whole polynomial so that terms containing $h$ comes first and those containing $\phi^\pm$ come last so that the above expression would start with the third term displayed above.

I believe this would be done most efficiently by customizing the canonical ordering of each symbol in Mathematica. I'm pretty sure this can't be done — so what can I do to achieve my task?

Answer 1

As you said in your comment that you just want a well displayed formula, I suggest using Row to force specific orders. A rough example will look like following, you might want to adjust the priority level according to your needs:

expr = A^2 e^2 SuperMinus[\[Phi]] SuperPlus[\[Phi]] + 
  A e SuperMinus[\[Phi]] SuperPlus[\[Phi]] Subscript[c, 2 w] Subscript[g, Z] +
  1/2 A e g h SuperMinus[W] SuperPlus[\[Phi]]

Clear[prodSort]
prodSort[mono_] :=
If[Head[mono] =!= Times,
 Row[{mono}],
 Module[{termLst, priorityTable},
  termLst = List @@ mono;
  priorityTable = Piecewise[{{0, NumericQ[#]},
       {10, Not@FreeQ[#, e]},
       {11, Not@FreeQ[#, A]},
       {100, Not@FreeQ[#, SuperPlus[\[Phi]]]},
       {101, Not@FreeQ[#, SuperMinus[\[Phi]]]}
       }, 50] & /@ termLst;
  Row@SortBy[{termLst, priorityTable}\[Transpose], Last][[All, 1]]
  ]
 ]

Clear[sumSort]
sumSort[polynom_] :=
 Module[{termLst, priorityTable},
  termLst = List @@ polynom;
  priorityTable = 
   Piecewise[{{0, Not@FreeQ[#, h]},
              {100, Not@FreeQ[#, SuperPlus[\[Phi]]]},
              {100, Not@FreeQ[#, SuperMinus[\[Phi]]]}
             }, 10] & /@ termLst;
  SortBy[{termLst, priorityTable}\[Transpose], Last][[All, 1]] // 
    Riffle[#, "+"] & // Row
  ]

sumSort[prodSort /@ expr] // TraditionalForm

It can be copied as LaTeX code from Copy As menu:

$$\frac{1}{2}eAghW^-\phi ^++e^2A^2\phi ^+\phi ^-+eAc_{2 w}g_Z\phi ^+\phi ^-$$

Edit:

1. For dealing with negative terms, a special abbreviation rule can be introduced:

   negTermQ[mono_] := mono[[1, 1]] == -1 ||
     AtomQ[mono[[1, 1]]] &&
      ! StringFreeQ[ToString[mono[[1, 1]]], "-"]
   
   negTermAbbr[mono_] := If[mono[[1, 1]] == -1,
     ReplacePart[mono, {1, 1} -> "-"],
     mono]
   
   negAbbr[expr_] := expr //.
     Row[{pre__, "+", mono_?negTermQ, post___}] :>
      Row[{pre, negTermAbbr[mono], post}]
   
   (*pardon me for an example that may be physical meaningless*)
   expr = A^2 e^2 SuperMinus[\[Phi]] SuperPlus[\[Phi]] -
     \[Pi] A e SuperMinus[\[Phi]] SuperPlus[\[Phi]] Subscript[c, 2 w] Subscript[g, Z] + 
     1/2 A e g h SuperMinus[W] SuperPlus[\[Phi]] - Sqrt[2] - 2 A
   
   sumSort[prodSort /@ expr] // negAbbr // TraditionalForm
   

   

2. Some explanation about the code.

   In prodSort a monomial which is a product is transformed from a1 * a2 * ... * an to a List structure {a1, a2, ..., an}, then the list is sorted according to the key term ($e$, $A$, $\phi^+$, $\phi^-$) they contain, then the sorted list is wrapped by Row. sumSort is built on a similar concept.

Answer 2

Something like this might be helpful. It replaces the unsorted list of symbols with a sorted list, lets Mathematica rearrange the expression in the normal way, and then applies a HoldForm before replacing the symbols back again.

reorderSymbols[expr_, symbols_List] := With[{s = symbols}, 
  HoldForm[Evaluate[expr /. Thread[s -> Sort@s]]] /. Thread[Sort@s -> s]]

For example:

test = Expand[(a + b + c)^3]

$a^3 + 3 a^2 b + 3 a b^2 + b^3 + 3 a^2 c + 6 a b c + 3 b^2 c + 3 a c^2 + 3 b c^2 + c^3 $

reorderSymbols[test, {b, c, a}]

$b^3 + 3 b^2 c + 3 b c^2 + c^3 + 3 b^2 a + 6 b c a + 3 c^2 a + 3 b a^2 + 3 c a^2 + a^3 $

Answer 3

Here a similar symbol replacement method to the one Simon used, in my own style.

reorder[expr_, pats_List] :=
  Module[{h, rls},
    rls = MapIndexed[x : # :> h[#2, x] &, pats];
    HoldForm @@ {expr /. rls} /. h[_, x_] :> x
  ]

This definition allows you, within the standard limits of pattern matching expressions (e.g. FullForm) of course, to order arbitrary parts of an expression by pattern rather than merely symbols or fixed expressions. Using Silvia's example, suppose you want the term containing $\pi$ to be ordered early and the radical to be ordered late?

expr = A^2 e^2 SuperMinus[ϕ] SuperPlus[ϕ] - π A e \
SuperMinus[ϕ] SuperPlus[ϕ] Subscript[c, 2 w] Subscript[g, 
     Z] + 1/2 A e g h SuperMinus[W] SuperPlus[ϕ] - Sqrt[2] - 2 A

reorder[expr, {π * _, e, A, SuperPlus[ϕ], SuperMinus[ϕ], Sqrt[_]}]

---

Silvia implicitly pointed out that the ordering was not correct within the $\pi$ term in the second example and asked how this might be corrected. I believe that this second definition should work in most cases.

reorder2[expr_, pats_List] :=
  Module[{h, rls},
    rls = MapIndexed[x : # :> h[#2, Replace[x, rls, -1]] &, pats];
    HoldForm @@ {expr /. rls} //. h[_, x_] :> x
  ]

reorder2[expr, {π * _, e, A, SuperPlus[ϕ], SuperMinus[ϕ], Sqrt[_]}]

Answer 4

nice[exp_, varli_List] := Module[{dum}, 
     MakeBoxes[dum[_, y_], fmt_] := ToBoxes[y, fmt]; 
     exp /. Thread[varli -> Reverse /@ MapIndexed[dum, varli]]
]; 

expr = A^2*e^2*SuperMinus[\[Phi]]*SuperPlus[\[Phi]] + 
       A*e*SuperMinus[\[Phi]]*SuperPlus[\[Phi]]*Subscript[c, 2*w]*
       Subscript[g, Z] + (1*A*e*g*h*SuperMinus[W]*SuperPlus[\[Phi]])/2;  

nice[expr, {e, g, h, A, Subscript[c, 2*w], Subscript[g, Z], 
   SuperMinus[W], SuperPlus[\[Phi]], SuperMinus[\[Phi]]}]

Answer 5

This is the type of problem that Mathscape was designed to solve.

Unfortunately it's author (Michael Barnett) recently passed away before updating this ambitious project to work with more recent versions of Mathematica.

Mathscape appears to be relatively unknown among Mathematica users. Perhaps a Windows installer that is compatible with a modern LaTeX IDE (e.g. TeXWorks) would have helped his work reach a wider audience.