Pensieve Header: An implementation of the Free Associative Algebra (FAA) universe of operations.

We want to implement: (Subscript[σ, i->j]), (Subscript[m, i,j->k]), ∂(Subscript[[v], i->j,k]), (Subscript[S, i->j]), (Subscript[Δ, i->j,k]), (Subscript[tr, i->j]), maybe ϵ and η,  ⊗.

Data format: (Subscript[AW, i])[x,y,x](Subscript[AW, j])[y,x,y](Subscript[CW, k])[x,x,x,y]... (denotes an element of overall degree 10.

<< C:\drorbn\AcademicPensieve\People\Kuno\Profile.m

(* (Subscript[PP, _])=Identity *)

Cyclic Words and the Trace

RotateToMinimal[aw_]:=Module[
{best=aw,rotated=RotateLeft[aw]},
While[rotated=!=aw,
best=First[Sort[{best,rotated}]];
rotated=RotateLeft[rotated]
];
best
];

CF[(Subscript[CW, i_])[iw___]]:=RotateToMinimal@(Subscript[CW, i])[iw];
(Subscript[tr, i_->j_])[ℰ_]:=ℰ/.(Subscript[AW, i])[iw___]:>CF@(Subscript[CW, j])[iw]

Bases

(Subscript[Basis, d_,ps_])[(Subscript[AW, i_])]:=(Subscript[AW, i])@@@Tuples[ps,d]
(Subscript[Basis, d_,ps_])[(Subscript[AW, i_])more_]:=Flatten@Table[Outer[Times,(Subscript[Basis, d1,ps])[(Subscript[AW, i])],(Subscript[Basis, d-d1,ps])[more]],{d1,0,d}];
(Subscript[Basis, d_,ps_])[(Subscript[CW, i_])]:=Union[(Subscript[tr, i->i])/@(Subscript[Basis, d,ps])[(Subscript[AW, i])]];
(Subscript[Basis, d_,ps_])[(Subscript[CW, i_])more_]:=Flatten@Table[Outer[Times,(Subscript[Basis, d1,ps])[(Subscript[CW, i])],(Subscript[Basis, d-d1,ps])[more]],{d1,0,d}]

Factor Renaming

(Subscript[σ, i_->j_])[ℰ_]:=(Subscript[PP, FAAσ])[ℰ/.{(Subscript[AW, i])[iw___]:>(Subscript[AW, j])[iw],(Subscript[CW, i])[iw___]:>(Subscript[CW, j])[iw]}]

Multiplication

(Subscript[m, i_,j_->k_])[ℰ_]:=(Subscript[PP, FAAm])[ℰ/.(Subscript[AW, i])[iw___](Subscript[AW, j])[jw___]:>(Subscript[AW, k])[iw,jw]]

Word “Cutting”

(Subscript[𝔻[v_], i_->j_,k_])[ℰ_]:=(Subscript[PP, FA𝔻])@Expand[ℰ/.{
(Subscript[AW, i])[]->0,
(Subscript[AW, i])[iw__]:>Sum[If[{iw}[[α]]===v,Take[(Subscript[AW, j])[iw],α-1]Drop[(Subscript[AW, k])[iw],α],0],{α,Length@{iw}}]
}];
(Subscript[𝔻[v_], i_->j_])[ℰ_]:=(Subscript[PP, FA𝔻])@Expand[ℰ/.{
(Subscript[CW, i])[]->0,
(Subscript[CW, i])[iw__]:>Sum[If[{iw}[[α]]===v,Most@RotateLeft[(Subscript[AW, j])[iw],α],0],{α,Length@{iw}}]
}]

The Co-Product

(Subscript[Δ, i_->j_,k_])[ℰ_]:=(Subscript[PP, FAΔ])@Expand@Module[{αs,all},
ℰ/.{
(Subscript[AW, i])[iw___]:>(
all=Range@Length@{iw};
Sum[
(Subscript[AW, j])[iw][[αs]](Subscript[AW, k])[iw][[Complement[all,αs]]],
{αs,Subsets@all}
]),
(Subscript[CW, i])[iw___]:>(
all=Range@Length@{iw};
Sum[
CF[(Subscript[CW, j])[iw][[αs]]]CF[(Subscript[CW, k])[iw][[Complement[all,αs]]]],
{αs,Subsets@all}
])
}
]

The Antipode

(Subscript[S, i_->j_])[ℰ_]:=(Subscript[PP, FAS])@Expand[
ℰ/.{
(Subscript[AW, i])[iw___]:>(((-1))^(Length@{iw}))Reverse[(Subscript[AW, j])[iw]],
(Subscript[CW, i])[iw___]:>(((-1))^(Length@{iw}))CF@Reverse[(Subscript[CW, j])[iw]]
}
]

The Unit

(Subscript[η, i_])[ℰ_]:=Expand[ℰ (Subscript[AW, i])[]]

Substitutions

Currently limited to sending variables to sums of others, with no coefficients.

FA[rs___Rule][ℰ_]:=(Subscript[PP, FAFA])@Expand[ℰ/.(Subscript[AW, i_])[iw___]:>Distribute[(Subscript[AW, i])[iw]/.{rs}/.(Subscript[AW, i])[___,0,___]->0]]

Exterior Multiplication

The built in Series method was very slow:

(*(Subscript[EM, d_])[ℰ1_,ℰ2_]:=(Subscript[PP, FAEM])@Expand[Normal[Times[
(Subscript[PP, Cropping])[(Subscript[PP, CompDeg])@(ℰ1/.{(Subscript[AW, i_])[iw__]:>(ℏ^(Length@{iw}))(Subscript[AW, i])[iw],(Subscript[CW, i_])[iw__]:>(ℏ^(Length@{iw}))(Subscript[CW, i])[iw]})+((O[ℏ])^(d+1))],
(Subscript[PP, Cropping])[(Subscript[PP, CompDeg])@(ℰ2/.{(Subscript[AW, i_])[iw__]:>(ℏ^(Length@{iw}))(Subscript[AW, i])[iw],(Subscript[CW, i_])[iw__]:>(ℏ^(Length@{iw}))(Subscript[CW, i])[iw]})+((O[ℏ])^(d+1))]
]+((O[ℏ])^(d+1))]/.ℏ->1]*)

(Subscript[EM, d_])[ℰ1_,ℰ2_]:=(Subscript[PP, FAEM])@Module[{E1,E2,j,j1},
E1=CoefficientList[ℰ1/.{(Subscript[AW, i_])[iw__]:>(ℏ^(Length@{iw}))(Subscript[AW, i])[iw],(Subscript[CW, i_])[iw__]:>(ℏ^(Length@{iw}))(Subscript[CW, i])[iw]},ℏ];
E2=CoefficientList[ℰ2/.{(Subscript[AW, i_])[iw__]:>(ℏ^(Length@{iw}))(Subscript[AW, i])[iw],(Subscript[CW, i_])[iw__]:>(ℏ^(Length@{iw}))(Subscript[CW, i])[iw]},ℏ];
Sum[
Expand[E1[[j1+1]]E2[[j-j1+1]]],
{j,0,d},{j1,0,j}]
]

?CoefficientList

CoefficientList[2ℏ+3(ℏ^2),ℏ]