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

Title. I Still don’t Understand the Alexander Polynomial

Abstract. As an algebraic knot theorist, I still don’t understand the Alexander polynomial. There are two conventions as for how to present tangle theory in algebra: one may name the strands of a tangle, or one may name their ends. The distinction might seem too minor to matter, yet it leads to a completely different view of the set of tangles as an algebraic structure. There are lovely formulas for the Alexander polynomial as viewed from either perspective, and they even agree where they meet. But the “strands” formulas know about strand doubling while the “ends” ones don’t, and the “ends” formulas know about skein relations while the “strands” ones don’t. There ought to be a common generalization, but I don’t know what it is.

\def\nbpdfInput#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfPrint#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfEcho#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfOutput#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfText#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfSubsection#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfgraphInput#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfgraphOutput#1{\vskip 1mm\par\noindent\includegraphics[width=1.5in]{#1}}

<< KnotTheory`

𝒜-Calculus

WP[Wedge[u___],Wedge[v___]]:=Signature[{u,v}]*Wedge@@Sort[{u,v}];
WP[0,_]=WP[_,0]=0;
WP[A_,B_]:=Expand[Distribute[A ** B] /. (a_. * u_Wedge) ** (b_. * v_Wedge):>a b WP[u,v]];

WExp[A_]:=Module[{s=Wedge[],t=Wedge[],k=0},
While[t=!=0,s+=(t=Expand[WP[t,A]/(++k)])]; s]

(Subscript[c, x_,y_])[w_Wedge]:=Module[{i,j},
{i}=FirstPosition[w,x,{0}]; {j}=FirstPosition[w,y,{0}];
(Piecewise[{{w, (i==0)∧(j==0)}, {(((-1))^(i+j+If[i>j,1,0]))Delete[w,{{i},{j}}], (i>0)∧(j>0)}}])
];
(Subscript[c, x_,y_])[ℰ_]:=ℰ/.w_Wedge:>(Subscript[c, x,y])[w]

𝒜[Γ[ω_,_,λ_]]:=Expand[ω WExp[Expand[λ]/.(Subscript[t, a_])(Subscript[h, b_]):>(Subscript[ξ, a])⋀(Subscript[x, b])]]

𝒜/:𝒜[is1_,os1_,cs1_,w1_]𝒜[is2_,os2_,cs2_,w2_]:=𝒜[is1⋃is2,os1⋃os2,Join[cs1,cs2],WP[w1,w2]]

(Subscript[c, h_,t_])@𝒜[is_,os_,cs_,w_]:=𝒜[
DeleteCases[is,t],DeleteCases[os,h],KeyDrop[cs,{(Subscript[x, h]),(Subscript[ξ, t])}],(Subscript[c, (Subscript[ξ, t]),(Subscript[x, h])])[w]
] /. If[cs[(Subscript[ξ, t])][[1]]===τ, cs[(Subscript[ξ, t])]->cs[(Subscript[x, h])],cs[(Subscript[x, h])]-> cs[(Subscript[ξ, t])]];
c@𝒜[is_,os_,cs_,w_]:=Fold[(Subscript[c, #2,#2])[#1]&,𝒜[is,os,cs,w],is⋂os]

The 𝒜-invariants of the crossings.

The crossings: \input{figs/R3.pdf_t}

𝒜[(Subscript[X, i_,j_,k_,l_])[Ti_,Tj_]]:=𝒜[{i,j},{k,l},\[LeftAssociation](Subscript[ξ, i])->Ti,(Subscript[ξ, j])->Tj,(Subscript[x, k])->Ti,(Subscript[x, l])->Tj\[RightAssociation],Expand[(Ti^(-1/2))WExp[Expand[{(Subscript[ξ, i]),(Subscript[ξ, j])}.(({{1, 1-Ti}, {0, Ti}})).{(Subscript[x, k]),(Subscript[x, l])}]/.(Subscript[ξ, a_])(Subscript[x, b_]):>(Subscript[ξ, a])⋀(Subscript[x, b])]]];
𝒜[(Subscript[(OverBar[X]), i_,j_,k_,l_])[Ti_,Tj_]]:=𝒜[{i,j},{k,l},\[LeftAssociation](Subscript[ξ, i])->Ti,(Subscript[ξ, j])->Tj,(Subscript[x, k])->Ti,(Subscript[x, l])->Tj\[RightAssociation],Expand[(Tj^(1/2))WExp[Expand[{(Subscript[ξ, i]),(Subscript[ξ, j])}.(({{(Tj^(-1)), 0}, {1-(Tj^(-1)), 1}})).{(Subscript[x, k]),(Subscript[x, l])}]/.(Subscript[ξ, a_])(Subscript[x, b_]):>(Subscript[ξ, a])⋀(Subscript[x, b])]]];
𝒜[(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],WExp[(Subscript[ξ, i])⋀(Subscript[x, j])]];
𝒜[(Subscript[P, i_,j_])]:=𝒜[(Subscript[P, i,j])[(Subscript[τ, i])]];

c[{A_}]:=c[A];
c[{𝒜[is_,os_,cs_,w_],As__}]:=Module[{A},
A=RandomChoice@MaximalBy[{As},Length[is⋂#[[2]]]+Length[os⋂#[[1]]]&];
c[Join[{c[𝒜[is,os,cs,w]A]}, DeleteCases[{As},A]]] ]

mva=MultivariableAlexander[L=PD@Link["L11a401"]][t]
Z=c[List@@𝒜/@(L/.X[i_,j_,k_,l_]:>If[PositiveQ[X[i,j,k,l]], (Subscript[X, l,i,j,k]),(Subscript[(OverBar[X]), i,j,k,l])]/.{(Subscript[x_, i_,j_,k_,1]):>(Subscript[x, i,j,k,0]),(Subscript[x_, i_,j_,1,k_]):>(Subscript[x, i,j,0,k])})];
Factor@Coefficient[Z[[4]]/((Subscript[τ, 1])-1),Wedge[]]

{WP[Wedge[x],Wedge[y]],WP[Wedge[y],Wedge[x]]}

lhs=(Subscript[c, (Subscript[x, 4]),(Subscript[y, 4])])[WExp[Sum[(Subscript[a, i])((Subscript[x, i])⋀(Subscript[y, i])),{i,4}]]]
rhs=Expand[(1-(Subscript[a, 4]))WExp[Sum[(Subscript[a, i])((Subscript[x, i])⋀(Subscript[y, i])),{i,3}]]]
lhs==rhs

lhs=(Subscript[c, (Subscript[x, 3]),(Subscript[y, 3])])[(Subscript[c, (Subscript[x, 4]),(Subscript[y, 4])])[WExp[Sum[(Subscript[a, i])((Subscript[x, i])⋀(Subscript[y, i])),{i,4}]]]]

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 // tr[2]

lhs=c[𝒜[(Subscript[X, 1,2,5,4])[(Subscript[T, 1]),(Subscript[T, 2])]]𝒜[(Subscript[X, 5,3,7,6])[(Subscript[T, 1]),(Subscript[T, 3])]]𝒜[(Subscript[X, 4,6,9,8])]]
rhs=c[𝒜[(Subscript[X, 2,3,5,4])[(Subscript[T, 2]),(Subscript[T, 3])]]𝒜[(Subscript[X, 1,4,6,8])[(Subscript[T, 1]),(Subscript[T, 3])]]𝒜[(Subscript[X, 6,5,7,9])]]
lhs[[4]]==rhs[[4]]

c[𝒜[(Subscript[X, 1,2,4,3])]𝒜[(Subscript[(OverBar[X]), 3,4,6,5])]]

{c[𝒜[(Subscript[X, 1,2,2,3])]], c[𝒜[(Subscript[X, 1,2,3,1])]],c[𝒜[(Subscript[(OverBar[X]), 1,2,2,3])]],c[𝒜[(Subscript[(OverBar[X]), 1,2,3,1])]]}

L=Link["L4a1"]//PD

Skeleton[L]

Crossings[L]

MultivariableAlexander[L=PD@Link["L5a1"]][t]
Z=c[Times@@𝒜/@(L/.X[i_,j_,k_,l_]:>If[PositiveQ[X[i,j,k,l]],(Subscript[X, l,i,j,k]),(Subscript[(OverBar[X]), i,j,k,l])]/.{(Subscript[x_, i_,j_,k_,1]):>(Subscript[x, i,j,k,0]),(Subscript[x_, i_,j_,1,k_]):>(Subscript[x, i,j,0,k])})]
Coefficient[Z[[4]],Wedge[]]

(L/.X[i_,j_,k_,l_]:>If[PositiveQ[X[i,j,k,l]], (Subscript[X, l,i,j,k]),(Subscript[(OverBar[X]), i,j,k,l])]/.{(Subscript[x_, i_,j_,k_,1]):>(Subscript[x, i,j,k,0]),(Subscript[x_, i_,j_,1,k_]):>(Subscript[x, i,j,0,k])})

L

Skeleton[L]

Factor[((-3+(1/(Subscript[τ, 1]))+2 (Subscript[τ, 1])+3 (Subscript[τ, 10])-((2 (Subscript[τ, 10]))/(Subscript[τ, 1]))-(Subscript[τ, 1]) (Subscript[τ, 10]))/((((1-2 t[1]-2 t[2]+t[1] t[2])/((Sqrt[t[1]]) (Sqrt[t[2]])))/.{t[1]->(Subscript[τ, 1]),t[2]->(Subscript[τ, 10])})))]

Z

MultivariableAlexander[L=PD@Link["L5a1"]][t]
Timing[Z1=c[Times@@𝒜/@(L/.X[i_,j_,k_,l_]:>If[PositiveQ[X[i,j,k,l]],(Subscript[X, l,i,j,k]),(Subscript[(OverBar[X]), i,j,k,l])]/.{(Subscript[x_, i_,j_,k_,1]):>(Subscript[x, i,j,k,0]),(Subscript[x_, i_,j_,1,k_]):>(Subscript[x, i,j,0,k])})];]
Coefficient[Z1[[4]],Wedge[]]
Timing[Z2=c[List@@𝒜/@(L/.X[i_,j_,k_,l_]:>If[PositiveQ[X[i,j,k,l]], (Subscript[X, l,i,j,k]),(Subscript[(OverBar[X]), i,j,k,l])]/.{(Subscript[x_, i_,j_,k_,1]):>(Subscript[x, i,j,k,0]),(Subscript[x_, i_,j_,1,k_]):>(Subscript[x, i,j,0,k])})];]
Coefficient[Z2[[4]],Wedge[]]

Factor[((-2 (Sqrt[(Subscript[τ, 6])])+((Sqrt[(Subscript[τ, 6])])/(Subscript[τ, 1]))+(Subscript[τ, 1]) (Sqrt[(Subscript[τ, 6])])+2 (Subscript[τ, 6]^(3/2))-((Subscript[τ, 6]^(3/2))/(Subscript[τ, 1]))-(Subscript[τ, 1]) (Subscript[τ, 6]^(3/2)))/(((Subscript[τ, 1])-1)((Subscript[τ, 6])-1)))]

MultivariableAlexander[L=PD@Link["L4a1"]][t]
Timing[Z1=c[Times@@𝒜/@(L/.X[i_,j_,k_,l_]:>If[PositiveQ[X[i,j,k,l]],(Subscript[X, l,i,j,k]),(Subscript[(OverBar[X]), i,j,k,l])]/.{(Subscript[x_, i_,j_,k_,1]):>(Subscript[x, i,j,k,0]),(Subscript[x_, i_,j_,1,k_]):>(Subscript[x, i,j,0,k])})];]
Coefficient[Z1[[4]],Wedge[]]
Timing[Z2=c[List@@𝒜/@(L/.X[i_,j_,k_,l_]:>If[PositiveQ[X[i,j,k,l]], (Subscript[X, l,i,j,k]),(Subscript[(OverBar[X]), i,j,k,l])]/.{(Subscript[x_, i_,j_,k_,1]):>(Subscript[x, i,j,k,0]),(Subscript[x_, i_,j_,1,k_]):>(Subscript[x, i,j,0,k])})];]
Coefficient[Z2[[4]],Wedge[]]

Factor[((-1+(Subscript[τ, 1])+(Subscript[τ, 8])-((Subscript[τ, 8])/(Subscript[τ, 1])))/(-(Subscript[τ, 1])-(Subscript[τ, 8])))]

𝒜[(Subscript[P, 1,4])]

c[c[𝒜[(Subscript[P, 1,2])]𝒜[(Subscript[P, 2,3])]]𝒜[(Subscript[P, 3,4])]]

c[c[𝒜[(Subscript[P, 2,3])]𝒜[(Subscript[P, 3,4])]]𝒜[(Subscript[P, 1,2])]]

nb2tex

As in http://drorbn.net/AcademicPensieve/Projects/nb2tex/.

SetOptions[$FrontEndSession,PrintingStyleEnvironment->"Working"];
nb2tex[nb_String,opts___Rule]:=nb2tex[nb,nb,opts];

nb2tex[nb_String,tex_String, opts___Rule]:=Module[
{notebook,PDFCounter=0,lines,type,tag,pdfname,cell,c,cl,
PDFFolder=PDFFolder/. {opts}/.PDFFolder->nb
},
nb2tex$PDFWidth = PDFWidth /. {opts} /. PDFWidth->6.5;
notebook=NotebookGet[NotebookOpen@FileNameJoin[{Directory[],nb<>".nb"}]];
If[FileType[PDFFolder]===None, CreateDirectory[PDFFolder]];
DeleteFile/@FileNames["*.pdf",PDFFolder];
lines=Table[
type=cell[[2]];
tag=CellTags /. Cases[cell,_Rule] /. CellTags->"";
Which[
type=="Text"∧tag=="tex", StringReplace[cell[[1]],{"’"->"'", "”"->"\""}],
StringMatchQ[tag,"pdf"~~___], (
pdfname=PDFFolder<>"/"<>ToString[++PDFCounter]<>".pdf";
Export[pdfname, Join[cell, Cell[PageWidth -> 80nb2tex$PDFWidth/0.75]]];
cl="c:\\drorbn\\bin\\cpdf.exe -scale-page \"0.75 0.75\" "<>pdfname<>" -o "<>pdfname;
Close@OpenRead["!"<>cl];
StringReplace[
"\\noindent\\nbpdfXXXType{pdfname}",
{"XXX"->StringDrop[tag,3], "Type"->type, "pdfname"->pdfname}
]
),
type=="Text"∧tag=="exec", ToExpression[cell[[1]]]; "",
True, ""
],
{cell,Cases[notebook,c_Cell /; Length[c]≥2(*∧FreeQ[c, _Cell, {1,∞}]*),∞]}
];
lines=StringJoin@@Riffle[DeleteCases[lines, ""], "\n\n"];
WriteString[tex<>".tex",lines]; Close[tex<>".tex"]; ]

Run

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\MoscowByWeb-2104"];
nb2tex["AnG-Programs", PDFFolder->"Snips", PDFWidth->154.3/10/2.54];
Run@"\"C:\\Program Files\\MiKTeX 2.9\\miktex\\bin\\x64\\pdflatex.exe\" AnG.tex"