Skip to content

Instantly share code, notes, and snippets.

@lucainnocenti
Last active May 17, 2020 20:18
Show Gist options
  • Save lucainnocenti/e04cf3470c1f85893d2772c59940a9ca to your computer and use it in GitHub Desktop.
Save lucainnocenti/e04cf3470c1f85893d2772c59940a9ca to your computer and use it in GitHub Desktop.
Replacement rules implementing a noncommutative algebra, and functions to show how expressions are written in terms of nested commutators
<< 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment