0
$\begingroup$

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.:

enter image description here

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
$\endgroup$
6
  • $\begingroup$ expr /. Longest[x_NonCommutativeMultiply]/;!FreeQ[x,a^3]:> Transpose[x] is this your desired one? $\endgroup$
    – Lacia
    Commented Sep 10, 2022 at 8:07
  • $\begingroup$ @lilyric I'm going to try now $\endgroup$
    – ayr
    Commented Sep 10, 2022 at 10:07
  • $\begingroup$ @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... $\endgroup$
    – ayr
    Commented Sep 10, 2022 at 13:51
  • 1
    $\begingroup$ 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]? $\endgroup$
    – Lacia
    Commented Sep 10, 2022 at 20:59
  • $\begingroup$ @lilyric Example 1: b ** (-P ** a^3) + b ** Transpose[-P ** a^3]. Desired output: Transpose[b ** (-P ** a^3)] + b ** Transpose[-P ** a^3] $\endgroup$
    – ayr
    Commented Sep 11, 2022 at 5:32

1 Answer 1

1
$\begingroup$

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

enter image description here

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

enter image description here

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

$\endgroup$
13
  • $\begingroup$ 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. $\endgroup$
    – ayr
    Commented Sep 11, 2022 at 10:13
  • $\begingroup$ @dtn where is the a^3? $\endgroup$
    – Lacia
    Commented Sep 11, 2022 at 14:51
  • $\begingroup$ Yes, there myst be a^3, Transpose[x+y**a^3]**J**(a^3) $\endgroup$
    – ayr
    Commented Sep 11, 2022 at 14:56
  • 1
    $\begingroup$ @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 $\endgroup$
    – Lacia
    Commented Sep 13, 2022 at 1:02
  • 1
    $\begingroup$ @dtn I learnt building noncommutative algebra package from this notebook. Headrick uses SetDelayed and it's easy to change to RuleDelayed. $\endgroup$
    – Lacia
    Commented Sep 13, 2022 at 1:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.