# Replacing a term according to a given criterion in an expression with non-commutative multiplication (for any sign and location)

There is the following expression:

expr = a^3 ** x + x ** (a^3 ** 1) + y ** x ** 1 -
x ** x ** y ** (-P ** a^3) + y ** (P ** (-a^3 ** M)) -
x ** (-M ** (P ** (M ** a^3))) + x ** y ** z

expr /. x_NonCommutativeMultiply?(MemberQ[#, a^3] &) :> Transpose[x]

expr /. NonCommutativeMultiply[x___, a^3, y___] :> Transpose[NonCommutativeMultiply[x, a^3, y]]


It is necessary to apply the Transpose[] to all terms in which include variable a^3.

This issue has been discussed in this thread: Terms of expressions with non-commutative multiplication that meet the given criteria

The problem is complicated by the number of levels of occurrence of a^3 more and the code from the previous topic does not work for all terms. It transposes only those parts of the terms that are delimited by brackets from the rest of the term, i.e.:

Desired output:

out = Transpose[a^3 ** x] + Transpose[x ** (a^3 ** 1)] + y ** x ** 1 -
Transpose[x ** x ** y ** (-P ** a^3)] +
Transpose[y ** (P ** (-a^3 ** M))] -
Transpose[x ** (-M ** (P ** (M ** a^3)))] + x ** y ** z

• expr /. Longest[x_NonCommutativeMultiply]/;!FreeQ[x,a^3]:> Transpose[x] is this your desired one? Sep 10, 2022 at 8:07
• @lilyric I'm going to try now
– dtn
Sep 10, 2022 at 10:07
• @lilyric Yes it works! Only a little tweak is needed. Is it possible to make it so that only those terms are transposed, where $a ^ 3$ is NOT transposed...
– dtn
Sep 10, 2022 at 13:51
• Could you give an example? You mean escaping the terms like b**Transpose[a^3], like b**a^3+b**Transpose[a^3]/. Longest[x_NonCommutativeMultiply]/;!FreeQ[x,a^3]&&FreeQ[x,Transpose[a^3]]:> Transpose[x] returns b**Transpose[a^3]+Transpose[b**a^3]? Sep 10, 2022 at 20:59
• @lilyric Example 1: b ** (-P ** a^3) + b ** Transpose[-P ** a^3]. Desired output: Transpose[b ** (-P ** a^3)] + b ** Transpose[-P ** a^3]
– dtn
Sep 11, 2022 at 5:32

For the examples

b ** (-P ** a^3) + b ** Transpose[-P ** a^3]
b ** (-P ** J ** a^3) + b ** Transpose[-P ** (-J) ** a^3]


you can try

rule1=
Longest[expr_NonCommutativeMultiply]/;
!FreeQ[expr,a^3]:>If[
Cases[expr,subexpr_Transpose/;!FreeQ[subexpr,a^3],{0,Infinity}]==={},
Transpose@expr,
expr
];


and the results are

b ** (-P ** a^3) + b ** Transpose[-P ** a^3]/.rule1
(*b ** Transpose[-P ** a^3] + Transpose[b ** (-P ** a^3)]*)

b ** (-P ** J ** a^3) + b ** Transpose[-P ** (-J) ** a^3]/.rule1
(*b ** Transpose[-P ** (-J) ** a^3] + Transpose[b ** (-P ** J ** a^3)]*)


Longest[expr_NonCommutativeMultiply] searches the longest subexpressions expr with head NonCommutativeMultiply, then !FreeQ[expr,a^3] checks if expr contains a^3.

To escape the exprs in which a^3 has already been wrapped by Transpose, we use Cases to search subexpressions of expr with head Transpose containing a^3, and depending on the result we choose to Transpose or not.

## Update 1

expr={
Transpose[x+y**a]**J**a,
b ** (-P ** a) + b ** Transpose[-P ** a],
b ** (-P ** J ** a) + b ** Transpose[-P ** (-J) ** a]
};
rule1=
Longest[expr_NonCommutativeMultiply]:>If[
!FreeQ[expr/.{_Transpose:>Null},a],
Transpose@expr,
expr
];

expr//Column
expr/.rule1//Column


Why use If here?

The first rule that applies to a particular part is used; no further rules are tried on that part or on any of its subparts.

After finding the longest expr_NonCommutativeMultiply, we don't want the subparts of which to be matched again.

/.{_Transpose:>Null} is to hide the subexprs with head Transpose, and then we search if there are a or a^3 left.

## Update 2

expr={
b ** a + Transpose[J ** a],
b ** a + Transpose[J]**a,
Transpose[x+y**a]**J**a,
b ** (-P ** a) + b ** Transpose[-P ** a],
b ** (-P ** J ** a) + b ** Transpose[-P ** (-J) ** a]
};
rule1={
expr_Transpose/;!FreeQ[expr,a]:>expr,
Longest[expr_NonCommutativeMultiply]:>If[
!FreeQ[expr/.{_Transpose:>Null},a],
Transpose@expr,
expr]
};

expr//Column
expr/.rule1//Column


The first rule expr_Transpose/;!FreeQ[expr,a]:>expr, is to shade the terms like +Transpose[...,[...,a]]+.

• Your code seems to work. I modified it a little so that we can work with constants (for example, with 1), including negative ones. rule = Longest[expr_Dot] /; ! FreeQ[expr, 1] || ! FreeQ[expr, -1] :> If[Cases[expr, subexpr_Transpose /; ! FreeQ[subexpr, 1] || ! FreeQ[expr, -1], {0, Infinity}] === {}, Transpose@expr, expr]; I will test your version! Thank you It seems to be a very good solution.
– dtn
Sep 11, 2022 at 10:13
• @dtn where is the a^3? Sep 11, 2022 at 14:51
• Yes, there myst be a^3, Transpose[x+y**a^3]**J**(a^3)
– dtn
Sep 11, 2022 at 14:56
• @dtn the new rules behave differently away from your previous question. And if this is your true question, then I personally recommend a more systematic way of doing noncommutative algebras: Virasoro.nb Sep 13, 2022 at 1:02
• @dtn I learnt building noncommutative algebra package from this notebook. Headrick uses SetDelayed and it's easy to change to RuleDelayed. Sep 13, 2022 at 1:05