Graded commutativity

Question

As we all know, Mathematica has extensive built-in support for computations in free commutative algebras, AKA polynomials algebras. It's also not that hard to make computations in exterior algebras with a fixed set of generators. One possibility is to use NonCommutativeMultiply, follow the documentation to make it into a bilinear operation, and explicitly stating that the generators anti-commute:

ncm[(h : NonCommutativeMultiply)[a___, b_Plus, c___]] := 
 Distribute[h[a, b, c], Plus, h, Plus, ncm[h[##1]] &]
ncm[a_Plus] := ncm /@ a
ncm[(h : NonCommutativeMultiply)[a___, b_Times, c___]] := 
 Most[b]  ncm[h[a, Last[b], c]]
(* Skew-symmetry )
generators = Array[e, 5];
(ncm[a___ * # ** #2 ** b___] := -ncm[a ** #2 ** # ** b]) & @@@ 
  Subsets[generators, {2}];
(ncm[___ ** # ** # ** ___] = 0) & /@ generators;
ncm[a_] := ExpandAll[a]
(* Examples )
ncm[e[1] * e[2] + e[2] ** e[1]]
(* 0 )
ncm[e[3] * e[2] ** e[3]]
(* 0 *)

This is cumbersome but it kind of works. A somewhat simpler possibility is to use the facilities for tensor computations, like here: Computations in the exterior algebra

Now, I'd like to have a graded commutative algebra: generators have a certain degree, and homogeneous elements satisfy $$xy = (-1)^{|x| \, |y|}yx.$$

It's also possible to massage the ncm function into making this work. For example, if I have three generators $x,y,z$ of respective degrees $1,2,3$, I can replace the section "Skew-symmetry" of the code with:

ncm[a___ ** x ** x ** b___] := 0
ncm[a___ ** z ** z ** b___] := 0
ncm[a___ ** y ** x ** b___] := ncm[a ** x ** y ** b]
ncm[a___ ** z ** x ** b___] := -ncm[a ** x ** z ** b]
ncm[a___ ** z ** y ** b___] := ncm[a ** y ** z ** b]

And this kind of works:

ncm[x ** z ** y + y ** z ** x]
(* 0 *)
ncm[y ** z ** y ** x]
(* 0 *)

But this is very cumbersome: I'm doing everything by hand in the definition. It feels like there must be a better way... Sure, I could automatize a little by defining the degrees somewhere and then iterating over pairs to create definitions, but that's not great. Basically, I'm working in the tensor algebra and explicitly adding relation for the graded commutativity of variables - but that's a very inefficient way of making computations. Gröbner bases and so on are much smaller when taking the commutativity right into the structure.

I also tried to do something analogous to Computations in the exterior algebra but I was unable to.

Is there a nice way to handle graded commutativity in Mathematica?

Answer 1

I'll use CircleDot for multiplication:

Unprotect[CircleDot];
CircleDot[a___, 0, c___] := 0;
CircleDot[a___, q_?NumberQ b_, c___] := q CircleDot[a, b, c];
CircleDot[a___, b_Plus, c___] := CircleDot[a, #, c] & /@ b;
CircleDot[a_] := a;

Three generators of degrees 1, 2 and 3.

n = 3;
deg = {1, 2, 3};

I'll represent monomials $e_1^{i_1}\dots e_n^{i_n}$ as expressions of the form t[i1, …, in]. In particular, the generators are:

e[i_] := t @@ SparseArray[i -> 1, {n}];

Commutation coefficients and the multiplication rule

twists = SparseArray[{{i_, j_} /; i > j :> deg[[i]] deg[[j]]}, {n, n}];
t /: CircleDot[l___, a_t, b_t, r___] := (-1)^(
  List @@ a . twists . List @@ b)
   CircleDot[l, Inner[Plus, a, b, t], r]

Compute something:

In[656]:= e[1]\[CircleDot]e[3] + e[3]\[CircleDot]e[1]
Out[656]= 0
In[658]:= Fold[CircleDot, Table[e[1]+e[2]+e[3], {4}]] // Collect[#, _t]&
Out[658]= t[0,0,4]+4 t[0,1,3]+6 t[0,2,2]+4 t[0,3,1]+t[0,4,0]
          +4 t[1,1,2]+4 t[1,3,0]+2 t[2,0,2]+4 t[2,1,1]+6 t[2,2,0]
          +4 t[3,1,0]+t[4,0,0]

In this way you can work with any algebra for which you have some sort of PBW bases for which you have nice and simple product rules for monomials. For example, Weyl algebras of arbitrary rank work nicely, because there are not too terrible formulas, involving Stirling numbers, for the product of two monomials. Using rewriting rules coming out of a nc Groebner bases for such an algebra tends to be horribly inefficient in comparison, even if the algebra is Koszul quadratic, so "easy".

You can define an output format for the t[…] thingies using powers of generators, for readability.

Answer 2

You can define for each generator its degree and its position in the ordering of generators. Then a couple of rules suffice for the reversing of variables.

deg[x] = 1;
deg[y] = 2;
deg[z] = 3;
posn[x] = 1;
posn[y] = 2;
posn[z] = 3;
(* Handle distributing and ordinary `Times` *)
ncm[(h : NonCommutativeMultiply)[a___, b_Plus, c___]] := 
 Distribute[h[a, b, c], Plus, h, Plus, ncm[h[##1]] &]
ncm[a_Plus] := ncm /@ a
ncm[(h : NonCommutativeMultiply)[a___, b_Times, c___]] := 
 Most[b] ncm[h[a, Last[b], c]]
(* Impose the variable-swapping rules *)
ncm[a___ ** xx_ ** xx_ ** b___] /; OddQ[deg[xx]] := 0
ncm[a___ ** yy_ ** xx_ ** b___] /; 
  posn[yy] > posn[xx] := (-1)^(deg[xx]*deg[yy])*
  ncm[a ** xx ** yy ** b]

Examples:

ncm[x ** z ** y + y ** z ** x]
ncm[y ** z ** y ** x]
(* Out[987]= 0
Out[988]= -ncm[x ** y ** y ** z] *)

Unless there is another rule I think that second result is correct, by the way.