Pensieve header: The full $\Gamma$-Calculus, derived from pensieve://Projects/MetaCalculi/.

<< KnotTheory`

Γ-Calculus

ΓSimp=Factor; SetAttributes[ΓCollect, Listable];
ΓCollect[Γ[ω_,σ_,λ_]] := ΓCollect[ΓSimp][Γ[ω,σ,λ]];
ΓCollect[simp_][Γ[ω_,σ_,λ_]] := Γ[simp[ω], simp[σ],
Collect[λ, (Subscript[h, _]), Collect[#,(Subscript[t, _]), simp]&]];
dL[Γ[_,_,λ_]] := Union[Cases[λ, (Subscript[(h|t), a_]) :> a, Infinity]];
Γ[ω1_,_, _][ω] := ω1;
Γ[ω_,σ_,λ_][Σ] := ((∂_(Subscript[h, #]))σ)& /@ dL[Γ[ω,σ,λ]];
Γ[ω_,σ_,λ_][A] := Module[{S=dL[Γ[ω,σ,λ]]}, Outer[ΓSimp[((∂_((Subscript[t, #1]),(Subscript[h, #2])))λ)]&, S, S]];
ΓForm[Γ[ω_,σ_,λ_]] := Module[{S, M},
S = dL[Γ[ω,σ,λ]];
M = Γ[ω,σ,λ][A] // Transpose;
PrependTo[M, (Subscript[s, #])& /@ S];
M = Join[
{Prepend[(Subscript[s, #])& /@ S, ω]},
Transpose[M],
{Prepend[Γ[ω,σ,λ][Σ], "Γ"]}
];
MatrixForm[M]
];
ΓForm[else_] := else /. Γ[ω_,σ_,λ_] :> ΓForm[Γ[ω,σ,λ]];
Format[Γ[ω_,σ_,λ_], StandardForm] := ΓForm[Γ[ω,σ,λ]];

Γ /: Γ[ω1_,σ1_, μ1_] == Γ[ω2_,σ2_, μ2_] := Module[
{S},
S=dL[Γ[ω1,σ1, μ1]]⋃dL[Γ[ω2,σ2, μ2]];
(ω1 == ω2) && (And @@ (((∂_(Subscript[h, #]))σ1 == (∂_(Subscript[h, #]))σ2)& /@ S)) && (
And @@ Flatten[Outer[
((∂_((Subscript[t, #1]),(Subscript[h, #2])))μ1== (∂_((Subscript[t, #1]),(Subscript[h, #2])))μ2)&,
S,S
]]
)
]

Γ /: Γ[ω1_,σ1_,λ1_]Γ[ω2_,σ2_,λ2_] := Γ[ω1*ω2, σ1+σ2, λ1+λ2];
(Subscript[dm, i_,j_->k_])[Γ[ω_,σ_,λ_]] := Module[{α,β,γ,δ,θ,ϵ,ϕ,ψ,Ξ,μ},
(({{α, β, θ}, {γ, δ, ϵ}, {ϕ, ψ, Ξ}}))=(({{(∂_((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[Γ[(μ=1-β)ω,
(Subscript[h, k])((∂_(Subscript[h, i]))σ)((∂_(Subscript[h, j]))σ)+(σ /. (Subscript[h, i|j])->0),
{(Subscript[t, k]),1}.(({{γ+α δ/μ, ϵ+δ θ/μ}, {ϕ+α ψ/μ, Ξ+θ ψ/μ}})).{(Subscript[h, k]),1}
]] /. {(Subscript[T, i])->(Subscript[T, k]), (Subscript[T, j])->(Subscript[T, k]),(Subscript[b, i])->(Subscript[b, k]), (Subscript[b, j])->(Subscript[b, k])} // ΓCollect
];
dm[a_,b_,c_][Γ[ω_,σ_,λ_]]  := (Subscript[dm, a,b->c])[Γ[ω,σ,λ]];
dη[a_][γ_Γ] := γ /. {(Subscript[(h|t), a]) -> 0, (Subscript[T, a])->1};

tr[a_][Γ[ω_,σ_, λ_]] := Module[{α,θ,ψ,Ξ},
(({{α, θ}, {ψ, Ξ}}))=(({{(∂_((Subscript[t, a]),(Subscript[h, a])))λ, (∂_(Subscript[t, a]))λ}, {(∂_(Subscript[h, a]))λ, λ}}))/.(Subscript[(t|h), a])->0;
Γ[ω(1-α),σ /. (Subscript[h, a])->0,Ξ+ψ*θ/(1-α)]// ΓCollect];

FullStitch[γ1_Γ,γ2_Γ] := Module[{S1,S2,S, γ,τ},
S=(S1=dL[γ1])⋃(S2=dL[γ2]);
γ=γ1(Times@@(Γ/@ϵ/@Complement[S,S1]));
γ*=(γ2 /. {(Subscript[h, a_]):>(Subscript[h, τ[a]]), (Subscript[t, a_]):>(Subscript[t, τ[a]]), (Subscript[T, a_]):>(Subscript[T, τ[a]])})(Times@@(Γ/@ϵ/@τ/@Complement[S,S2]));
Do[
γ=γ//dm[s,τ[s],s],
{s,S}
];
γ
];
Γ /: γ1_Γ**γ2_Γ := Module[{S1,S2,S, γ1p,γ2p},
S=(S1=dL[γ1])⋃(S2=dL[γ2]);
γ1p=γ1(Times@@(Γ/@ϵ/@Complement[S,S1]));
γ2p=γ2(Times@@(Γ/@ϵ/@Complement[S,S2]));
Γ[
γ1p[ω]*γ2p[ω],
(γ1p[Σ]γ2p[Σ]).((Subscript[h, #])& /@ S),
((Subscript[t, #])& /@ S).(γ2p[A].γ1p[A]).((Subscript[h, #])& /@ S)
]
];

Γ /: ((Γ[ω_,σ_,λ_])^(-1)) := Module[{S=dL[Γ[ω,σ,λ]]},
Γ[
(ω^(-1)), Collect[σ, (Subscript[h, _]), (1/#)&],
((Subscript[t, #])& /@ S).Inverse[ Outer[ΓSimp[((∂_((Subscript[t, #1]),(Subscript[h, #2])))λ)]&, S, S]].((Subscript[h, #])& /@ S)
]
];

dA[a_][Γ[ω_,σ_,λ_]] := Module[
{α, θ, ϕ, Ξ, σa},
(({{α, θ}, {ϕ, Ξ}}))=(({{(∂_((Subscript[t, a]),(Subscript[h, a])))λ, (∂_(Subscript[t, a]))λ}, {(∂_(Subscript[h, a]))λ, λ}})) /. (Subscript[(h|t), a])->0;
σa=(∂_(Subscript[h, a]))σ;
ΓCollect[Γ[
α ω/σa,
((σ/.(Subscript[h, a])->0)+(Subscript[h, a])/σa),
{(Subscript[t, a]), 1}.(({{1, θ}, {-ϕ, α Ξ-ϕ θ}})).{(Subscript[h, a]),1}/α
]]
];
dS[a_][γ_Γ] := ΓCollect[dA[a][γ] /. {(Subscript[T, a])->1/(Subscript[T, a]), (Subscript[b, a])->-(Subscript[b, a])}];

qΔ[a_,x_,y_][Γ[ω_,σ_,λ_]] := Module[
{α, θ, ϕ, Ξ, σa, Ta, M},
(({{α, θ}, {ϕ, Ξ}}))=(({{(∂_((Subscript[t, a]),(Subscript[h, a])))λ, (∂_(Subscript[t, a]))λ}, {(∂_(Subscript[h, a]))λ, λ}})) /. (Subscript[(h|t), a])->0 /. (Subscript[T, a])->Ta;
σa=(∂_(Subscript[h, a]))σ/. (Subscript[T, a])->Ta;
M=(({{((-σa+α Ta+(-α+σa) (Subscript[T, y]))/(-1+Ta)), (((-1+(Subscript[T, x])) (Subscript[T, y]) (α-σa))/(-1+Ta)), ((θ (-1+(Subscript[T, x])) (Subscript[T, y]))/(-1+Ta))}, {(((-1+(Subscript[T, y])) (α-σa))/(-1+Ta)), ((-α+σa Ta+(α-σa) (Subscript[T, y]))/(-1+Ta)), ((θ (-1+(Subscript[T, y])))/(-1+Ta))}, {ϕ, ϕ, Ξ}}));
ΓCollect[Γ[
ω /. (Subscript[T, a])->(Subscript[T, x])(Subscript[T, y]),
((σ/.(Subscript[h, a])->0)+((Subscript[h, x])+(Subscript[h, y]))σa) /. (Subscript[T, a])|Ta->(Subscript[T, x])(Subscript[T, y]),
{(Subscript[t, x]), (Subscript[t, y]), 1}.M.{(Subscript[h, x]), (Subscript[h, y]), 1} /. Ta->(Subscript[T, x])(Subscript[T, y])
]]
];

Mirror[γ_Γ] := Module[{γ1},
γ1 = γ // (dS@@dL[γ]);
γ1[[3]] = γ1[[3]] /. {(Subscript[t, a_]):>(Subscript[h, a]), (Subscript[h, a_]):>(Subscript[t, a])};
γ1];

tσ[rules___Rule][γ_Γ] := ΓCollect[
γ /. {(Subscript[t, u_]) :> (Subscript[t, u /. {rules}]), (Subscript[T, u_]) :> (Subscript[T, u /. {rules}]), (Subscript[b, u_]) :> (Subscript[b, u /. {rules}])}
];
hσ[rules___Rule][γ_Γ] := ΓCollect[γ /. (Subscript[h, x_]) :> (Subscript[h, x /. {rules}])];

SetAttributes[Γ, Listable];
Γ[p_Times|p_NonCommutativeMultiply]:= Γ /@ p;
Γ[ϵ[a_]] := Γ[1,(Subscript[h, a]), (Subscript[h, a])(Subscript[t, a])];
Γ[Xp[a_,b_]] :=Γ[1, (Subscript[h, a])+(Subscript[h, b])(Subscript[T, a]), {(Subscript[t, a]),(Subscript[t, b])}.(({{1, 1-(Subscript[T, a])}, {0, (Subscript[T, a])}})).{(Subscript[h, a]),(Subscript[h, b])}];
Γ[Xm[a_,b_]] := Γ[Xp[a,b]] /. (Subscript[T, a])->1/(Subscript[T, a]);

MVA[Γ, L_Link] := Module[{Hs,ω,σ,μ,A},
{ω,σ,μ} = List @@ Z[Γ, L];
Hs = Rest[(Subscript[h, #])& /@ (First /@ Skeleton[L])];
A=Outer[Coefficient[μ, #1*#2]&,Hs, Hs /. (Subscript[h, a_]) :> (Subscript[t, a])];
Factor[((ω Det[A-IdentityMatrix@Length@Hs])/(1-(Subscript[T, Skeleton[L][[1,1]]])))]
]

Testing

(Subscript[Xp, a_,b_]):= Xp[a,b]; (Subscript[Xm, a_,b_]):=Xm[a,b];

{(Subscript[Xp, a,b]), (Subscript[Xm, a,b])} // Γ

Meta-Associativity

n=4; γ0=Γ[ω, (∑_(a=1)^n)(Subscript[h, a])(Subscript[σ, a]), (∑_(a=1)^n)(∑_(b=1)^n)(Subscript[t, a])(Subscript[h, b])(Subscript[α, 10a+b])]

γ0 // dm[1,2,1]//dm[1,3,1]

γ0 // dm[2,3,2]//dm[1,2,1]

(γ0 // dm[1,2,1]//dm[1,3,1])==(γ0 // dm[2,3,2]//dm[1,2,1])

Cyclicity of tr

n=3; γ0=Γ[ω, (∑_(a=0)^n)(Subscript[h, a])(Subscript[σ, a]), (∑_(a=1)^n)(∑_(b=1)^n)(Subscript[t, a])(Subscript[h, b])(Subscript[α, 10a+b])]

{γ0 // dm[1,2,1], γ0 // dm[1,2,1] // tr[1]}

{γ0 // dm[2,1,1], γ0 // dm[2,1,1] // tr[1]}

(γ0 // dm[1,2,1] // tr[1])== (γ0 // dm[2,1,1] // tr[1])

Testing the MVA

SXForm[L_] := SXForm[
Skeleton[L],
Times@@PD[L] /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]],Xp[l,i], Xm[j,i]]
];
Z[L_] := Z[Identity, L];
Z[χ_, L_] := Module[{s, z},
{s, z} = List @@ SXForm[L];
z=χ[z];
Do[z = z // dm[s[[c,1]],s[[c,k]] ,s[[c,1]]], {c, Length[s]},{k, 2, Length[s[[c]]]}];
z
];

Z[Γ, Link["L6a4"]]

trZ[L_] := Module[{γ},
γ=Z[Γ, L];
Do[
γ=γ//tr[k],
{k, Most[γ // dL]}];
γ[ω]/((Subscript[T, Last[γ//dL]])-1)]

trZ[Link["L10a4"]]

MultivariableAlexander[Link["L10a4"]][T]

Factor[(((MultivariableAlexander[#][T] /. T[i_] :> (Subscript[T, Skeleton[#][[i,1]]])))/(trZ[#]))]&  /@ AllLinks[{2,7}]