Pensieve header: Unitarity for Γ-calculus - finding the ${\mathcal L}_0$ for which $\bar{A}={\mathcal L}_0A$.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\MetaCalculi"];
Once[<< KnotTheory`]

(Subscript[R, a_,b_]) :=Γ@<|ς->{(Subscript[t, a]),(Subscript[t, b]),(Subscript[h, a]),(Subscript[h, b])},ω->1,σ->(Subscript[h, a])+(Subscript[h, b])(Subscript[T, a]),λ->{(Subscript[t, a]),(Subscript[t, b])}.(({{(Subscript[T, a]), 1-(Subscript[T, a])}, {0, 1}})).{(Subscript[h, a]),(Subscript[h, b])}|>;
(Subscript[(OverBar[R]), a_,b_]):= Γ@<|ς->{(Subscript[t, b]),(Subscript[t, a]),(Subscript[h, b]),(Subscript[h, a])},ω->1,σ->(Subscript[h, a])+(Subscript[h, b])(Subscript[T, a]^(-1)),λ->{(Subscript[t, a]),(Subscript[t, b])}.(({{(Subscript[T, a]^(-1)), 1-(Subscript[T, a]^(-1))}, {0, 1}})).{(Subscript[h, a]),(Subscript[h, b])}|>;

(Subscript[(OverBar[R]), 1,2])

Γ[α_][κ_]:=α[κ];
Γ[α_][S]:=Union@Cases[α[ς],(Subscript[t, a_]):>a,∞];
Γ[α_][n]:=Length[Γ[α][S]];
Γ[α_][Σ] := ((∂_(Subscript[h, #]))α[σ])& /@ Γ[α][S];
Γ[α_][A] := Outer[Factor[(∂_(#1,#2))Γ[α][λ]]&, Cases[α[ς],(Subscript[t, _])], Cases[α[ς],(Subscript[h, _])]];

Table[{γ@ς,γ@ω,γ@σ,γ@λ,γ@S,γ@Σ,γ@A//MatrixForm},{γ,{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2])}}]//Transpose//MatrixForm

ΓCollect[γ_Γ]:=Γ[<|ς->γ@ς,ω->Factor@γ@ω,σ->Expand@γ@σ,
λ->Total[CoefficientRules[γ@λ,γ@ς]/.(ps_->c_):>Factor[c]Times@@((((γ@ς))^ps))]|>]

ΓCollect[(Subscript[(OverBar[R]), 1,2])]

ConservativeQ[γ_Γ]:=Simplify[Expand[γ@λ/.(Subscript[h, _])->1]==Sum[(Subscript[t, a]),{a,γ@S}]]

ConservativeQ[(Subscript[R, 1,2])]

T\[Conjugate]^:=(T^(-1));
(Subscript[⟨c_,d_⟩, ς_]):=Expand@Module[{e,f},
Expand[c(d/.{T->T\[Conjugate],(Subscript[t, i_]):>(Subscript[t, i])\[Conjugate],(Subscript[h, i_]):>(Subscript[h, i])\[Conjugate]})]/.{(Subscript[t, i_])\[Conjugate](Subscript[t, i_])->0, (Subscript[h, i_])\[Conjugate](Subscript[h, i_])->T-T\[Conjugate],(Subscript[(f:t|h), j_])\[Conjugate](Subscript[(e:t|h), i_]):>If[Position[ς,(Subscript[e, i])][[1,1]]<Position[ς,(Subscript[f, j])][[1,1]],T-1,1-T\[Conjugate]]}
];
UnitaryQ[γ_Γ]:=Module[{vs},
vs=Table[-(Subscript[t, i])+(∂_(Subscript[t, i]))γ@λ/.(Subscript[T, _])->T,{i,γ@S}];
And@@Flatten@Table[Simplify[(Subscript[⟨vs[[i]],vs[[j]]⟩, γ@ς])==0],{i,γ@n},{j,γ@n}]
];

UnitaryQ/@{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2])}

ΓForm[γ_Γ] := Module[{M},
M = γ[A] // Transpose;
PrependTo[M, (Subscript[t, #])& /@ γ[S]];
M = Join[
{Prepend[(Subscript[h, #])& /@ γ[S], γ[ω]]},
Transpose[M],
{Prepend[γ[Σ],If[TrueQ[ConservativeQ@γ∧UnitaryQ@γ],,]]}
];
Column[{γ[ς],MatrixForm[M]}]
];
ΓForm[else_] := else /. γ_Γ :> ΓForm[γ];
Format[γ_Γ, StandardForm] := ΓForm[γ];

{(Subscript[R, 1,2]),(Subscript[(OverBar[R]), 1,2])}

(Subscript[dm, i_,j_->k_])[γ_Γ] := Module[{a,b,c,d,θ,ϵ,ϕ,ψ,Ξ,μ},
(({{a, b, θ}, {c, d, ϵ}, {ϕ, ψ, Ξ}}))=(({{(∂_((Subscript[t, i]),(Subscript[h, i])))γ@λ, (∂_((Subscript[t, i]),(Subscript[h, j])))γ@λ, (∂_(Subscript[t, i]))γ@λ}, {(∂_((Subscript[t, j]),(Subscript[h, i])))γ@λ, (∂_((Subscript[t, j]),(Subscript[h, j])))γ@λ, (∂_(Subscript[t, j]))γ@λ}, {(∂_(Subscript[h, i]))γ@λ, (∂_(Subscript[h, j]))γ@λ, γ@λ}}))/.(Subscript[(t|h), i|j])->0;
ΓCollect[Γ[<|
ς->DeleteCases[γ@ς,(Subscript[h, i])|(Subscript[t, j])]/.{(Subscript[t, i])->(Subscript[t, k]),(Subscript[h, j])->(Subscript[h, k])},
ω->(μ=1-c)γ@ω,
σ->(Subscript[h, k])((∂_(Subscript[h, i]))σ)((∂_(Subscript[h, j]))σ)+(σ /. (Subscript[h, i|j])->0),
λ->{(Subscript[t, k]),1}.(({{b+a d/μ, θ+a ϵ/μ}, {ψ+d ϕ/μ, Ξ+ϵ ϕ/μ}})).{(Subscript[h, k]),1}
|>] /. {(Subscript[T, i])->(Subscript[T, k]), (Subscript[T, j])->(Subscript[T, k])}]
];

Γ/:RotateLeft[Γ[α_],n___]:=Γ@ReplacePart[α,Key@ς->RotateLeft[α@ς,n]]

{Table[RotateLeft[(Subscript[R, 1,2]),k], {k,0,3}], Table[RotateLeft[(Subscript[(OverBar[R]), 1,2]),k], {k,0,3}]}

Γ/:Insert[γ1_Γ,γ2_Γ,k_]:=Γ@<|
ς->Flatten[Insert[γ1@ς,γ2@ς,k]],
ω->γ1@ω γ2@ω,
σ->γ1@σ+γ2@σ,
λ->γ1@λ+γ2@λ
|>
Γ/:Insert[γ2_Γ,k_][γ1_Γ]:=Insert[γ1,γ2,k]

ComposeList[{Insert[(Subscript[R, 3,4]),5],Insert[(Subscript[R, 5,6]),9],(Subscript[dm, 2,3->2]),(Subscript[dm, 1,4->1]),(Subscript[dm, 1,5->1]),(Subscript[dm, 2,6->2]),(Subscript[dm, 2,1->2])},
(Subscript[R, 1,2])]

ς0={(Subscript[t, 2]),(Subscript[h, 2]),(Subscript[t, 6]),(Subscript[h, 6])};
S0=Cases[ς0,(Subscript[t, i_]):>i]

Table[-(Subscript[t, i])+Sum[(Subscript[a, i,k])(Subscript[h, k]),{k,S0}],{i,S0}]

us=Flatten@Table[(Subscript[u, i,j]),{i,S0},{j,S0}]

eqns=Flatten@Table[(Subscript[⟨-(Subscript[t, i])+Sum[(Subscript[a, i,k])(Subscript[h, k]),{k,S0}],-(Subscript[t, j])+Sum[(Subscript[u, j,k])(Subscript[h, k]),{k,S0}]⟩, ς0])==0,{i,S0},{j,S0}]

{sol}=Solve[eqns,us]

Flatten@Table[(Subscript[u, i,j])->Factor[(Subscript[u, i,j])/.sol],{i,S},{j,S}]

Sum[Factor[(Subscript[u, i,j])/.sol](Subscript[t, i])(Subscript[h, j]),{i,S},{j,S}]//Together

ℒ0[ς_]:=Module[{S,us,eqns,sol},
S=Cases[ς,(Subscript[t, i_]):>i];
us=Flatten@Table[(Subscript[u, i,j]),{i,S},{j,S}];
eqns=Flatten@Table[(Subscript[⟨-(Subscript[t, i])+Sum[(Subscript[a, i,k])(Subscript[h, k]),{k,S}],-(Subscript[t, j])+Sum[(Subscript[u, j,k])(Subscript[h, k]),{k,S}]⟩, ς])==0,{i,S},{j,S}];
{sol}=Solve[eqns,us];
Sum[Factor[(Subscript[u, i,j])/.sol](Subscript[t, i])(Subscript[h, j]),{i,S},{j,S}]
]

ℒ0[{(Subscript[t, 2]),(Subscript[h, 2]),(Subscript[t, 6]),(Subscript[h, 6])}]

ℒ0[{(Subscript[t, 2]),(Subscript[t, 6]),(Subscript[h, 2]),(Subscript[h, 6])}]

(Subscript[ℒ0, ς_])[λ_]:=Factor[ℒ0[ς]/.(Subscript[a, i_,j_]):>(∂_((Subscript[t, i]),(Subscript[h, j])))λ]

γ0=(Subscript[(OverBar[R]), 12,1])//Insert[RotateLeft[(Subscript[(OverBar[R]), 2,7]),1],4]//(Subscript[dm, 1,2->1])//Insert[RotateLeft[(Subscript[R, 6,13]),1],7]//(Subscript[dm, 12,13->12])//(Subscript[dm, 6,7->6])//Insert[(Subscript[(OverBar[R]), 8,3]),5]//(Subscript[dm, 1,3->1])//(Subscript[dm, 6,8->6])//Insert[(Subscript[R, 14,9]),6]//(Subscript[dm, 12,14->12])//(Subscript[dm, 6,9->6])//Insert[RotateLeft[(Subscript[(OverBar[R]), 4,11]),1],4]//(Subscript[dm, 1,4->1])//(Subscript[dm, 11,12->11])

lhs=(Subscript[ℒ0, γ0[ς]])[γ0[λ]/.(Subscript[T, _])->T]

rhs=Factor[γ0[λ]/.(Subscript[T, _])->(T^(-1))]

lhs==rhs

Together[ℒ0@{(Subscript[t, 1]),(Subscript[h, 1]),(Subscript[t, 11]),(Subscript[h, 11]),(Subscript[h, 6]),(Subscript[t, 6])}]