Replacement rules implementing a noncommutative algebra, and functions to show how expressions are written in terms of nested commutators

distribute.m

<< MaTeX`

distribute[args_] := (args //. {
    HoldPattern[nc[l___, Plus[m__], r___]] :> Total[nc[l, #, r] & /@ {m}],
    nc[l___, c_*nc[m__], r___] :> c nc[l, m, r],
    nc[l___, nc[m__], r___] :> nc[l, m, r],
    nc[-a_, b_] :> -nc[a, b],
    nc[a_, -b_] :> -nc[a, b],
    nc[nc[l : __], r_] :> nc[l, r], nc[l_, nc[r : __]] :> nc[l, r],
    nc[a_] :> a
});

comm[a_, b_] := nc[a, b] - nc[b, a];

groupPowers[args_] := args //. {
    nc[l___, a_, a_, r___] :> nc[l, a^2, r],
    nc[l___, Power[a_, n_], a_, r___] :> nc[l, a^(n + 1), r],
    nc[l___, a_, Power[a_, n_], r___] :> nc[l, a^(n + 1), r]
};

comm[a_, b_] := nc[a, b] - nc[b, a];

makeCsToBrackets[expr_] := expr //. {
    c[a_, b_] :> "[" <> ToString @ makeCsToBrackets @ a <> "," <> ToString @ makeCsToBrackets @ b <> "]",
    Power[a_, n_] :> ToString @ makeCsToBrackets @ a <> "^" <> ToString @ n
};

beautify[expr_] := makeCsToBrackets@expr //. {
    nc[args__] :> MaTeX[StringJoin @@ (ToString /@ {args}), Magnification -> 1.5],
    s_String :> MaTeX[s, Magnification -> 1.5]
};

singleStepExpand[expr_] := expr /. {
     nc[l___, a, b, r___] :> {nc[l, b, a, r], nc[l, c[a, b], r]},
     nc[l___, a, m : c[__], r___] :> {nc[l, m, a, r], nc[l, c[a, m], r]},
     nc[l___, m : c[__], b, r___] :> {nc[l, b, m, r], nc[l, c[m, b], r]}
 } // Map@distribute;
 
stepExpand[expr_] := singleStepExpand@expr // If[Length@# > 1, stepExpand /@ #, #] &;

stepExpandFullStory[expr_] := singleStepExpand@expr // (
    If[Head @ # === List,
        Append[{expr}, stepExpandFullStory /@ #],
        #
    ] &
);

firstIfList[expr_] := If[Head @ expr === List, First @ expr, expr];

nestedListToListOfEdges[expr_] := Cases[expr,
    RuleDelayed[
        {l : nc[__], {first_, second_}},
        Sequence @@ {
            DirectedEdge[l, firstIfList@first],
            DirectedEdge[l, firstIfList@second]
        }
    ],
    All
];

edgesToGraphWithNiceLabels[edges_] := Graph[edges,
    VertexLabels -> Map[
        # -> beautify @ groupPowers @ # &,
        DeleteDuplicates @ Flatten[edges, Infinity, DirectedEdge]
    ],
    GraphLayout -> "LayeredDigraphEmbedding"
];

(* usage example, should generate graph *)
nc[a, b, b, b] // stepExpandFullStory // nestedListToListOfEdges // edgesToGraphWithNiceLabels