Pensieve header: The main program and demo. Continues pensieve://Talks/ICERM-2305.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\Budapest-2311"];

{\bf\red Implementation} (sources: \url{http://drorbn.net/bu23/ap}). I like it most when the implementation matches the math perfectly. We failed here.

Once[<< KnotTheory`];

\par{\bf\red Utilities.} The step function, algebraic numbers, canonical forms.

θ[x_]/;NumericQ[x]:=UnitStep[x]

ω2[v_][p_]:=Module[{q=Expand[p],n,c},
If[q===0,0,c=Coefficient[q,ω,n=Exponent[q,ω]];c (v^n)+ω2[v][q-c(((ω+(ω^(-1))))^n)]]];

sign[ℰ_]:=Module[{n,d,v,p,rs,e,k},
{n,d}=NumeratorDenominator[ℰ];
{n,d}/=(ω^(Exponent[n,ω]/2+Exponent[n,ω,Min]/2));
p=Factor[ω2[v]@n*ω2[v]@d/.v->4(u^2)-2];
rs=Solve[p==0,u,Reals];
If[rs==={}, Sign[p/.u->0],
rs=Union@(u/.rs);
Sign[(((-1))^(e=Exponent[p,u]))Coefficient[p,u,e]]+Sum[
k=0;While[(d=RootReduce[(∂_({u,++k}))p/.u->r])==0];
If[EvenQ[k],0,2Sign[d]]*θ[u-r],
{r,rs}]
]
]

SetAttributes[B, Orderless];
CF[b_B]:=RotateLeft[#,First@Ordering[#]-1]&/@DeleteCases[b,{}]

CF[ℰ_]:=Module[{γs=Union@Cases[ℰ,(Subscript[γ, _])|(Subscript[(OverBar[γ]), _]),∞]},
Total[CoefficientRules[ℰ,γs]/.(ps_->c_):>Factor[c]Times@@((γs)^ps)] ]

CF[{}]={};
CF[𝒞_List]:=Module[{γs=Union@Cases[𝒞,(Subscript[γ, _]),∞],γ},
CF/@DeleteCases[0][
RowReduce[Table[(∂_γ)r,{r,𝒞},{γ,γs}]].γs]  ]

(SuperStar[(ℰ_)]):=ℰ/.{(OverBar[γ])->γ,γ->(OverBar[γ]),ω->(ω^(-1)),c_Complex:>c\[Conjugate]};
(SuperPlus[r_Rule]):={r,(SuperStar[r])}

RulesOf[(Subscript[γ, i_])+rest_.]:=(SuperPlus[((Subscript[γ, i])->-rest)]);
CF[PQ[𝒞_,q_]]:=Module[{n𝒞=CF[𝒞]},
PQ[n𝒞,CF[q/.Union@@RulesOf/@n𝒞]]  ]

CF[(Subscript[Σ, b_])[σ_,pq_]]:=(Subscript[Σ, CF[b]])[σ,CF[pq]]

\needspace{32mm}
\par{\bf\red Pretty-Printing.}

Format[(Subscript[Σ, b_B])[σ_,PQ[𝒞_,q_]]]:=Module[{γs},
γs=(Subscript[γ, #])&/@Join@@b;
Column[{TraditionalForm@σ,
TableForm[Join[
Prepend[""]/@Table[TraditionalForm[(∂_c)r],{r,𝒞},{c,γs}],
{Prepend[""][
Join@@(b/.{l_,m___,r_}:>{DisplayForm@RowBox[{"(",l}],m,DisplayForm@RowBox[{r,")"}]})/.i_Integer:>(Subscript[γ, i]) ]},
MapThread[Prepend,{Table[TraditionalForm[(∂_(r,c))q],{r,(SuperStar[γs])},{c,γs}],(SuperStar[γs])}]
],TableAlignments->Center]
}, Center] ];

\par{\bf\red The Face-Centric Core.}

(Subscript[Σ, b1_])[σ1_,PQ[𝒞1_,q1_]]⊕(Subscript[Σ, b2_])[σ2_,PQ[𝒞2_,q2_]]^:=CF@(Subscript[Σ, Join[b1,b2]])[σ1+σ2,PQ[𝒞1⋃𝒞2,q1+q2]];

\par GT for Gap Touch: \hfill \import{../ICERM-2305}{figs/GT.pdf_t}

(Subscript[GT, i_,j_])@(Subscript[Σ, B[{li___,i_,ri___},{lj___,j_,rj___},bs___]])[σ_,PQ[𝒞_,q_]]:=CF@(Subscript[Σ, B[{ri,li,j,rj,lj,i},bs]])[σ,PQ[𝒞⋃{(Subscript[γ, i])-(Subscript[γ, j])},q]]

\par\vskip 1mm\par\Cordon

(Subscript[Cordon, i_])@(Subscript[Σ, B[{li___,i_,ri___},bs___]])[σ_,PQ[𝒞_,q_]]:=Module[{ϕ=(∂_(Subscript[γ, i]))𝒞,λ=(∂_((Subscript[(OverBar[γ]), i]),(Subscript[γ, i])))q,nσ=σ,n𝒞,nq,p},
{p}=FirstPosition[(#=!=0)&/@ϕ,True,{0}];
{n𝒞,nq}=Which[
p>0, {𝒞,q}/.(SuperPlus[((Subscript[γ, i])->-𝒞[[p]]/ϕ[[p]])])/.(SuperPlus[((Subscript[γ, i])->0)]),
λ=!=0,(nσ+=sign[λ];{𝒞,q/.(SuperPlus[((Subscript[γ, i])->-((∂_(Subscript[(OverBar[γ]), i]))q)/λ)])/.(SuperPlus[((Subscript[γ, i])->0)])}),
λ===0,{𝒞⋃{(∂_(Subscript[(OverBar[γ]), i]))q},q/.(SuperPlus[((Subscript[γ, i])->0)])}];
CF@(Subscript[Σ, B[Most@{ri,li},bs]])[nσ,PQ[n𝒞,nq]/.(SuperPlus[((Subscript[γ, Last@{ri,li}])->(Subscript[γ, First@{ri,li}]))])]  ]

\par\needspace{20mm}
{\bf\red Strand Operations.} c for contract, mc for magnetic contract:

(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{li___,i_,ri___},{___,j_,___},___]])[__]:=t//(Subscript[GT, j,First@{ri,li}])//(Subscript[Cordon, j])

(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{___,i_,j_,___},___]])[__]:=(Subscript[Cordon, j])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{j_,___,i_},___]])[__]:=(Subscript[Cordon, j])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{___,j_,i_,___},___]])[__]:=(Subscript[Cordon, i])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{i_,___,j_},___]])[__]:=(Subscript[Cordon, i])@t

mc[ℰ_]:=ℰ//.
t:(Subscript[Σ, B[{___,i_,___},{___,j_,___},___]])[__]|(Subscript[Σ, B[{___,i_,j_,___},___]])[__]|(Subscript[Σ, B[{j_,___,i_},___]])[__]/;i+j==0:>(Subscript[c, i,j])@t

\par{\bf\red The Crossings} (and empty strands).

TL@(Subscript[P, i_,j_]):=CF@(Subscript[Σ, B[{i,j}]])[0,PQ[{},0]]

TL[x:X[i_,j_,k_,l_]]:=TL@If[PositiveQ[x],(Subscript[X, -i,j,k,-l]),(Subscript[(OverBar[X]), -j,k,l,-i])];
TL[(Subscript[(x:X|(OverBar[X])), fs__])]:=Module[{t=1-ω,r,γs,m},
r=t+(SuperStar[t]);γs=(Subscript[γ, #])&/@{fs};
m=If[x===X,
(({{-r, -t, 2t, (SuperStar[t])}, {-(SuperStar[t]), 0, (SuperStar[t]), 0}, {2(SuperStar[t]), t, -r, -(SuperStar[t])}, {t, 0, -t, 0}})),(({{r, -t, -2(SuperStar[t]), (SuperStar[t])}, {-(SuperStar[t]), 0, (SuperStar[t]), 0}, {-2t, t, r, -(SuperStar[t])}, {t, 0, -t, 0}}))];
CF@(Subscript[Σ, B[{fs}]])[0,PQ[{},(SuperStar[γs]).m.γs]]]

\par{\bf\red Evaluation on Tangles and Knots.}

TL[K_]:=Fold[mc[#1⊕#2]&,(Subscript[Σ, B[]])[0,PQ[{},0]],List@@(TL/@PD@K)]/.θ[c_+u]/;Abs[c]>=1:>θ[c];
TLSig[K_]:=TL[K][[1]]

Reidemeister 3

\par\needspace{20mm}
\parpic[r]{\import{../ICERM-2305}{figs/R3.pdf_t}}
{\bf\red Reidemeister 3.}

R3L=PD[(Subscript[X, -2,5,4,-1]),(Subscript[X, -3,7,6,-5]),
(Subscript[X, -6,9,8,-4])];
R3R=PD[(Subscript[X, -3,5,4,-2]),(Subscript[X, -4,6,8,-1]),
(Subscript[X, -5,7,9,-6])];
TL@R3L==TL@R3R

\needspace{15mm}

TL@R3L

Reidemeister 2

\par
\needspace{20mm}
\parpic[r]{\import{../ICERM-2305}{figs/R2.pdf_t}}
{\bf\red Reidemeister 2.}

TL@PD[(Subscript[X, -2,4,3,-1]),(Subscript[(OverBar[X]), -4,6,5,-3])]

TL@PD[(Subscript[X, -2,4,3,-1]),(Subscript[(OverBar[X]), -4,6,5,-3])]==(Subscript[GT, 5,-2])@TL@PD[(Subscript[P, -1,5]),(Subscript[P, -2,6])]

Reidemeister 1

\par
\parpic[r]{\import{../ICERM-2305}{figs/R1.pdf_t}}
{\bf\red Reidemeister 1.}

TL@PD[(Subscript[X, -3,3,2,-1])]==TL@(Subscript[P, -1,2])

A Knot

\par
\parpic[r]{\includegraphics[width=1in]{../ICERM-2305/8_5.png}}
{\bf\red A Knot.}

f=TLSig[Knot[8,5]]

\par\picskip{0}{
  \def\nbpdfInput#1{\vskip 1mm\par\noindent\includegraphics{#1}}
  \def\nbpdfOutput#1{\hfill\includegraphics[width=0.4\linewidth,valign=t]{#1}}

Plot[f,{u,-1,1}]

}

Some Tangles

\needspace{30mm}
\par\parpic[r]{\includegraphics[width=1.88in]{../ICERM-2305/figs/CKT.pdf}}
{\bf\red The  Conway-Kinoshita-Terasaka Tangles.}

T1=PD[(Subscript[(OverBar[X]), -6,2,7,-1]),(Subscript[(OverBar[X]), -2,8,3,-7]),
(Subscript[(OverBar[X]), -8,4,9,-3]),(Subscript[X, -11,6,12,-5]),
(Subscript[X, -4,11,5,-10])];
T2=PD[(Subscript[X, -6,2,7,-1]),(Subscript[X, -2,8,3,-7]),
(Subscript[X, -8,4,9,-3]),(Subscript[(OverBar[X]), -12,6,13,-5]),
(Subscript[(OverBar[X]), -4,12,5,-11]),(Subscript[(OverBar[X]), -10,15,11,-14]),(Subscript[(OverBar[X]), -15,10,16,-9])];

\par\needspace{10mm}

TL[T1]

TL[T2]

Some Braids

\parpic[r]{\includegraphics[width=1.88in]{../ICERM-2305/figs/B1B2.pdf}}
{\bf\red Examples with non-trivial codimension.}

PD[X[5,2,6,1],X[2,9,3,10],X[10,7,11,6],X[3,12,4,13],X[13,8,14,7]]/.x:X[i_,j_,k_,l_]:>If[PositiveQ@x, (Subscript[X, -i,j,k,-l]),(Subscript[(OverBar[X]), -j,k,l,-i])]

B1=PD[(Subscript[X, -5,2,6,-1]),(Subscript[(OverBar[X]), -8,3,9,-2]),
(Subscript[X, -11,4,12,-3]),(Subscript[X, -12,10,13,-9]),
(Subscript[(OverBar[X]), -13,7,14,-6])];
B2=PD[(Subscript[X, -5,2,6,-1]),(Subscript[(OverBar[X]), -9,3,10,-2]),
(Subscript[X, -10,7,11,-6]),(Subscript[(OverBar[X]), -12,4,13,-3]),(Subscript[X, -13,8,14,-7])];

TL[B1]

\par\needspace{10mm}

TL[B2]