Pensieve header: A talk and a program about Archibald- ($\mathcal A$-) and $\Gamma$-calculus and the Halacheva map between them; the $\Gamma$ part. Continues pensieve://2021-03/

Γ-Calculus

\begin{frame}{\LARGE 6. An Implementation of $\Gamma$.}
If I didn’t implement I wouldn’t believe myself.
\vskip 2mm
Written in Mathematica~\cite{Wolfram:Mathematica}, available as the notebook {\tt Gamma.nb} at \url{http://drorbn.net/mo21/ap}. Code lines are highlighted in grey, demo lines are plain.
We start with canonical forms for quadratics with rational function coefficients:

CCF[ℰ_] := Factor[ℰ]; 
CF[ℰ_] := Module[{vs=Union@Cases[ℰ,(Subscript[(ξ|x), _]),∞]},
Total[(CCF[#[[2]]](Times@@(vs^(#[[1]]))))& /@ CoefficientRules[ℰ, vs]]];

\end{frame}
\begin{frame}\null
Multiplying and comparing $\Gamma$ objects:

Γ/:Γ[is1_,os1_,cs1_,ω1_,λ1_]Γ[is2_,os2_,cs2_,ω2_,λ2_]:=Γ[is1⋃is2,os1⋃os2,Join[cs1,cs2],ω1 ω2,λ1+λ2]
Γ/:Γ[is1_,os1_,_,ω1_,λ1_]≡Γ[is2_,os2_,_,ω2_,λ2_]:=TrueQ[(Sort@is1===Sort@is2)∧(Sort@os1===Sort@os2)∧Simplify[ω1==ω2]∧CF@λ1==CF@λ2]

No rules for linear operations!
\end{frame}
\begin{frame}\null
Contractions:

(Subscript[c, h_,t_])@Γ[is_,os_,cs_,ω_,λ_]:=Module[{α,η,y,μ},
α=(∂_((Subscript[ξ, t]),(Subscript[x, h])))λ; μ=λ/.(Subscript[ξ, t])|(Subscript[x, h])->0;
η=(∂_(Subscript[x, h]))λ/.(Subscript[ξ, t])->0; y=(∂_(Subscript[ξ, t]))λ/.(Subscript[x, h])->0;
 Γ[
DeleteCases[is,t],DeleteCases[os,h],KeyDrop[cs,{(Subscript[x, h]),(Subscript[ξ, t])}],
CCF[(1-α)ω],CF[μ+η y/(1-α)]
] /. If[MatchQ[cs[(Subscript[ξ, t])],(Subscript[τ, _])], cs[(Subscript[ξ, t])]->cs[(Subscript[x, h])],cs[(Subscript[x, h])]-> cs[(Subscript[ξ, t])]]];
c@Γ[is_,os_,cs_,ω_,λ_]:=Fold[(Subscript[c, #2,#2])[#1]&,Γ[is,os,cs,ω,λ],is⋂os]

\end{frame}
\begin{frame}\null
The crossings and the point:

Γ[(Subscript[X, i_,j_,k_,l_])[S_,T_]]:=Γ[{l,i},{j,k},\[LeftAssociation](Subscript[ξ, i])->S,(Subscript[x, j])->T,(Subscript[x, k])->S,(Subscript[ξ, l])->T\[RightAssociation],(T^(-1/2)),CF[{(Subscript[ξ, l]),(Subscript[ξ, i])}.(({{1, 1-T}, {0, T}})).{(Subscript[x, j]),(Subscript[x, k])}]];
Γ[(Subscript[(OverBar[X]), i_,j_,k_,l_])[S_,T_]]:=Γ[{i,j},{k,l},\[LeftAssociation](Subscript[ξ, i])->S,(Subscript[ξ, j])->T,(Subscript[x, k])->S,(Subscript[x, l])->T\[RightAssociation],(T^(1/2)),CF[{(Subscript[ξ, i]),(Subscript[ξ, j])}.(({{(T^(-1)), 0}, {1-(T^(-1)), 1}})).{(Subscript[x, k]),(Subscript[x, l])}]];
Γ[(Subscript[X, i_,j_,k_,l_])]:=Γ[(Subscript[X, i,j,k,l])[(Subscript[τ, i]),(Subscript[τ, l])]];
Γ[(Subscript[(OverBar[X]), i_,j_,k_,l_])]:=Γ[(Subscript[(OverBar[X]), i,j,k,l])[(Subscript[τ, i]),(Subscript[τ, j])]];

Γ[(Subscript[P, i_,j_])[T_]]:=Γ[{i},{j},\[LeftAssociation](Subscript[ξ, i])->T,(Subscript[x, j])->T\[RightAssociation],1,(Subscript[ξ, i])(Subscript[x, j])];
Γ[(Subscript[P, i_,j_])]:=Γ[(Subscript[P, i,j])[(Subscript[τ, i])]];

\end{frame}
\begin{frame}\null
Automatic intelligent contractions:

Γ[{γ_Γ}]:=c[γ];
Γ[{γ1_Γ,γs__Γ}]:=Module[{γ2},
γ2=First@MaximalBy[{γs},Length[γ1[[1]]⋂#[[2]]]+Length[γ1[[2]]⋂#[[1]]]&];
Γ[Join[{c[γ1 γ2]}, DeleteCases[{γs},γ2]]] ]
Γ[𝒪s_List]:=Γ[Γ/@𝒪s]

\end{frame}
\begin{frame}\null
Conversions $\calA\leftrightarrow\Gamma$:

Γ@𝒜[is_,os_,cs_,w_]:=Module[{i,j,ω=Coefficient[w,Wedge[]]},
Γ[is,os,cs,ω,Sum[Cancel[-Coefficient[w,(Subscript[x, j])⋀(Subscript[ξ, i])](Subscript[ξ, i])(Subscript[x, j])/ω], {i,is},{j,os}]]
];
𝒜@Γ[is_,os_,cs_,ω_,λ_]:=𝒜[is,os,cs,Expand[ω WExp[Expand[λ]/.(Subscript[ξ, a_])(Subscript[x, b_]):>(Subscript[ξ, a])⋀(Subscript[x, b])]]];

The conversions are inverses of each other:

γ=Γ[{1,2,3},{1,2,3},{(Subscript[x, 1])->(Subscript[τ, 1]),(Subscript[x, 2])->(Subscript[τ, 2]),(Subscript[x, 3])->(Subscript[τ, 3]),(Subscript[ξ, 1])->(Subscript[τ, 1]),(Subscript[ξ, 2])->(Subscript[τ, 2]),(Subscript[ξ, 3])->(Subscript[τ, 3])},ω,(Subscript[a, 11]) (Subscript[x, 1]) (Subscript[ξ, 1])+(Subscript[a, 12]) (Subscript[x, 2]) (Subscript[ξ, 1])+(Subscript[a, 13]) (Subscript[x, 3]) (Subscript[ξ, 1])+(Subscript[a, 21]) (Subscript[x, 1]) (Subscript[ξ, 2])+(Subscript[a, 22]) (Subscript[x, 2]) (Subscript[ξ, 2])+(Subscript[a, 23]) (Subscript[x, 3]) (Subscript[ξ, 2])+(Subscript[a, 31]) (Subscript[x, 1]) (Subscript[ξ, 3])+(Subscript[a, 32]) (Subscript[x, 2]) (Subscript[ξ, 3])+(Subscript[a, 33]) (Subscript[x, 3]) (Subscript[ξ, 3])];
Γ@𝒜@γ==γ

The conversions commute with contractions:

Γ@(Subscript[c, 3,3])@𝒜@γ≡(Subscript[c, 3,3])@γ

\end{frame}

The Naik-Stanford Double Delta Move (again)

\begin{frame} {\large The Naik-Stanford Double Delta Move (again)}
\[ \scalebox{0.8}{\input{figs/NaikStanford.pdf_t}} \]

=

Timing[Γ@{(Subscript[X, 6,10,28,24])[w,v],(Subscript[(OverBar[X]), 28,3,29,19])[w,v],(Subscript[X, 26,20,27,19])[w,v],(Subscript[(OverBar[X]), 27,23,11,24])[w,v],
(Subscript[X, 1,12,13,30])[u,w],(Subscript[(OverBar[X]), 13,5,14,25])[u,w],(Subscript[X, 17,26,18,25])[u,w],(Subscript[(OverBar[X]), 18,29,8,30])[u,w],
(Subscript[X, 4,7,22,15])[v,u],(Subscript[(OverBar[X]), 22,2,23,16])[v,u],(Subscript[X, 20,17,21,16])[v,u],(Subscript[(OverBar[X]), 21,14,9,15])[v,u]}≡Γ@{(Subscript[X, 5,9,25,21])[w,v],(Subscript[(OverBar[X]), 25,4,26,22])[w,v],(Subscript[X, 29,23,30,22])[w,v],(Subscript[(OverBar[X]), 30,20,12,21])[w,v],
(Subscript[X, 2,11,16,27])[u,w],(Subscript[(OverBar[X]), 16,6,17,28])[u,w],(Subscript[X, 14,29,15,28])[u,w],(Subscript[(OverBar[X]), 15,26,7,27])[u,w],
(Subscript[X, 3,8,19,18])[v,u],(Subscript[(OverBar[X]), 19,1,20,13])[v,u],(Subscript[X, 23,14,24,13])[v,u],(Subscript[(OverBar[X]), 24,17,10,18])[v,u]}]

\end{frame}

Aside added pot-mortem:

Timing[𝒜@Γ@{(Subscript[X, 6,10,28,24])[w,v],(Subscript[(OverBar[X]), 28,3,29,19])[w,v],(Subscript[X, 26,20,27,19])[w,v],(Subscript[(OverBar[X]), 27,23,11,24])[w,v],
(Subscript[X, 1,12,13,30])[u,w],(Subscript[(OverBar[X]), 13,5,14,25])[u,w],(Subscript[X, 17,26,18,25])[u,w],(Subscript[(OverBar[X]), 18,29,8,30])[u,w],
(Subscript[X, 4,7,22,15])[v,u],(Subscript[(OverBar[X]), 22,2,23,16])[v,u],(Subscript[X, 20,17,21,16])[v,u],(Subscript[(OverBar[X]), 21,14,9,15])[v,u]}≡𝒜@Γ@{(Subscript[X, 5,9,25,21])[w,v],(Subscript[(OverBar[X]), 25,4,26,22])[w,v],(Subscript[X, 29,23,30,22])[w,v],(Subscript[(OverBar[X]), 30,20,12,21])[w,v],
(Subscript[X, 2,11,16,27])[u,w],(Subscript[(OverBar[X]), 16,6,17,28])[u,w],(Subscript[X, 14,29,15,28])[u,w],(Subscript[(OverBar[X]), 15,26,7,27])[u,w],
(Subscript[X, 3,8,19,18])[v,u],(Subscript[(OverBar[X]), 19,1,20,13])[v,u],(Subscript[X, 23,14,24,13])[v,u],(Subscript[(OverBar[X]), 24,17,10,18])[v,u]}]

Conway’s Third Identity (again)

\begin{frame}{\large Conway’s Third Identity}
\[ \input{figs/C3.pdf_t} \]

Sorry, $\Gamma$ has nothing to say about that...’
\end{frame}

Post-Mortem Additions

Yet,

Timing[𝒜@{(Subscript[X, 6,4,9,1]),(Subscript[(OverBar[X]), 4,5,7,8]),(Subscript[(OverBar[X]), 2,3,5,6])} + 𝒜@{(Subscript[X, 2,4,5,1]),(Subscript[(OverBar[X]), 4,3,7,6]),(Subscript[X, 6,8,9,5])}≡𝒜@{(Subscript[(OverBar[X]), 1,6,4,9]),(Subscript[X, 5,7,8,4]),(Subscript[X, 3,5,6,2])} + 𝒜@{(Subscript[(OverBar[X]), 1,2,4,5]),(Subscript[X, 3,7,6,4]),(Subscript[(OverBar[X]), 5,6,8,9])}]

Timing[𝒜@Γ@{(Subscript[X, 6,4,9,1]),(Subscript[(OverBar[X]), 4,5,7,8]),(Subscript[(OverBar[X]), 2,3,5,6])} + 𝒜@Γ@{(Subscript[X, 2,4,5,1]),(Subscript[(OverBar[X]), 4,3,7,6]),(Subscript[X, 6,8,9,5])}≡𝒜@Γ@{(Subscript[(OverBar[X]), 1,6,4,9]),(Subscript[X, 5,7,8,4]),(Subscript[X, 3,5,6,2])} + 𝒜@Γ@{(Subscript[(OverBar[X]), 1,2,4,5]),(Subscript[X, 3,7,6,4]),(Subscript[(OverBar[X]), 5,6,8,9])}]

Likewise,

Timing[𝒜@{(Subscript[X, 2,3,4,1])[T,T]} - 𝒜@{(Subscript[(OverBar[X]), 1,2,3,4])[T,T]}≡((T^(-1/2))-(T^(1/2)))𝒜@{(Subscript[P, 1,4])[T],(Subscript[P, 2,3])[T]}]

Timing[𝒜@Γ@{(Subscript[X, 2,3,4,1])[T,T]} - 𝒜@Γ@{(Subscript[(OverBar[X]), 1,2,3,4])[T,T]}≡((T^(-1/2))-(T^(1/2)))𝒜@Γ@{(Subscript[P, 1,4])[T],(Subscript[P, 2,3])[T]}]

Timing[{
𝒜@{(Subscript[X, 2,4,3,1])[v,u],(Subscript[X, 4,6,5,3])} + 𝒜@{(Subscript[(OverBar[X]), 1,2,4,3])[u,v],(Subscript[(OverBar[X]), 3,4,6,5])}≡((u^(1/2))(v^(1/2))+(u^(-1/2))(v^(-1/2)))𝒜@{(Subscript[P, 1,5])[u],(Subscript[P, 2,6])[v]},
𝒜@{(Subscript[(OverBar[X]), 4,1,6,3])[v,u],(Subscript[(OverBar[X]), 3,2,5,4])} + 𝒜@{(Subscript[X, 1,6,3,4])[u,v],(Subscript[X, 2,5,4,3])}≡((u^(1/2))(v^(-1/2))+(u^(-1/2))(v^(1/2)))𝒜@{(Subscript[P, 1,5])[u],(Subscript[P, 2,6])[v]}}]

Timing[{
𝒜@Γ@{(Subscript[X, 2,4,3,1])[v,u],(Subscript[X, 4,6,5,3])} + 𝒜@Γ@{(Subscript[(OverBar[X]), 1,2,4,3])[u,v],(Subscript[(OverBar[X]), 3,4,6,5])}≡((u^(1/2))(v^(1/2))+(u^(-1/2))(v^(-1/2)))𝒜@Γ@{(Subscript[P, 1,5])[u],(Subscript[P, 2,6])[v]},
𝒜@Γ@{(Subscript[(OverBar[X]), 4,1,6,3])[v,u],(Subscript[(OverBar[X]), 3,2,5,4])} + 𝒜@Γ@{(Subscript[X, 1,6,3,4])[u,v],(Subscript[X, 2,5,4,3])}≡((u^(1/2))(v^(-1/2))+(u^(-1/2))(v^(1/2)))𝒜@Γ@{(Subscript[P, 1,5])[u],(Subscript[P, 2,6])[v]}}]

Timing[
(Subscript[𝒜, 2112])=𝒜@{(Subscript[X, 3,8,7,2]),(Subscript[X, 7,10,9,1]),(Subscript[X, 10,11,4,9]),(Subscript[X, 8,6,5,11])};
(Subscript[𝒜, 1221])=𝒜@{(Subscript[X, 2,8,7,1]),(Subscript[X, 3,10,9,8]),(Subscript[X, 10,6,11,9]),(Subscript[X, 11,5,4,7])};
(Subscript[𝒜, 2211])=𝒜@{(Subscript[X, 3,8,7,2]),(Subscript[X, 8,6,9,7]),(Subscript[X, 9,11,10,1]),(Subscript[X, 11,5,4,10])};
(Subscript[𝒜, 1122])=𝒜@{(Subscript[X, 2,8,7,1]),(Subscript[X, 8,9,4,7]),(Subscript[X, 3,11,10,9]),(Subscript[X, 11,6,5,10])};
(Subscript[𝒜, 11])=𝒜@{(Subscript[X, 2,8,7,1]),(Subscript[X, 8,5,4,7]),(Subscript[P, 3,6])};  (Subscript[𝒜, 22])=𝒜@{(Subscript[X, 3,8,7,2]),(Subscript[X, 8,6,5,7]),(Subscript[P, 1,4])};
(Subscript[𝒜, ∅])=𝒜@{(Subscript[P, 1,4]),(Subscript[P, 2,5]),(Subscript[P, 3,6])};
(SubPlus[g])[z_]:=(z^(1/2))+(z^(-1/2)); (SubMinus[g])[z_]:=(z^(1/2))-(z^(-1/2));
(SubPlus[g])[(Subscript[τ, 1])](SubMinus[g])[(Subscript[τ, 2])](Subscript[𝒜, 2112])-(SubMinus[g])[(Subscript[τ, 2])](SubPlus[g])[(Subscript[τ, 3])](Subscript[𝒜, 1221])-(SubMinus[g])[(Subscript[τ, 3])/(Subscript[τ, 1])]((Subscript[𝒜, 2211])+(Subscript[𝒜, 1122]))+(SubMinus[g])[(Subscript[τ, 2])(Subscript[τ, 3])/(Subscript[τ, 1])](SubPlus[g])[(Subscript[τ, 3])](Subscript[𝒜, 11])-(SubPlus[g])[(Subscript[τ, 1])](SubMinus[g])[(Subscript[τ, 1])(Subscript[τ, 2])/(Subscript[τ, 3])](Subscript[𝒜, 22])≡(SubMinus[g])[(Subscript[τ, 3]^2)/(Subscript[τ, 1]^2)](Subscript[𝒜, ∅])
]

Timing[
(Subscript[𝒜, 2112])=𝒜@Γ@{(Subscript[X, 3,8,7,2]),(Subscript[X, 7,10,9,1]),(Subscript[X, 10,11,4,9]),(Subscript[X, 8,6,5,11])};
(Subscript[𝒜, 1221])=𝒜@Γ@{(Subscript[X, 2,8,7,1]),(Subscript[X, 3,10,9,8]),(Subscript[X, 10,6,11,9]),(Subscript[X, 11,5,4,7])};
(Subscript[𝒜, 2211])=𝒜@Γ@{(Subscript[X, 3,8,7,2]),(Subscript[X, 8,6,9,7]),(Subscript[X, 9,11,10,1]),(Subscript[X, 11,5,4,10])};
(Subscript[𝒜, 1122])=𝒜@Γ@{(Subscript[X, 2,8,7,1]),(Subscript[X, 8,9,4,7]),(Subscript[X, 3,11,10,9]),(Subscript[X, 11,6,5,10])};
(Subscript[𝒜, 11])=𝒜@Γ@{(Subscript[X, 2,8,7,1]),(Subscript[X, 8,5,4,7]),(Subscript[P, 3,6])};  (Subscript[𝒜, 22])=𝒜@Γ@{(Subscript[X, 3,8,7,2]),(Subscript[X, 8,6,5,7]),(Subscript[P, 1,4])};
(Subscript[𝒜, ∅])=𝒜@Γ@{(Subscript[P, 1,4]),(Subscript[P, 2,5]),(Subscript[P, 3,6])};
(SubPlus[g])[z_]:=(z^(1/2))+(z^(-1/2)); (SubMinus[g])[z_]:=(z^(1/2))-(z^(-1/2));
(SubPlus[g])[(Subscript[τ, 1])](SubMinus[g])[(Subscript[τ, 2])](Subscript[𝒜, 2112])-(SubMinus[g])[(Subscript[τ, 2])](SubPlus[g])[(Subscript[τ, 3])](Subscript[𝒜, 1221])-(SubMinus[g])[(Subscript[τ, 3])/(Subscript[τ, 1])]((Subscript[𝒜, 2211])+(Subscript[𝒜, 1122]))+(SubMinus[g])[(Subscript[τ, 2])(Subscript[τ, 3])/(Subscript[τ, 1])](SubPlus[g])[(Subscript[τ, 3])](Subscript[𝒜, 11])-(SubPlus[g])[(Subscript[τ, 1])](SubMinus[g])[(Subscript[τ, 1])(Subscript[τ, 2])/(Subscript[τ, 3])](Subscript[𝒜, 22])≡(SubMinus[g])[(Subscript[τ, 3]^2)/(Subscript[τ, 1]^2)](Subscript[𝒜, ∅])
]