Pensieve header: A Demo for Gauss Diagram fromulas and Gauss-Gassner-Alexander computations.. More at http://www.math.toronto.edu/~drorbn/Talks/NCSA-1604/

The Gauss-Gassner-Alexander Demo

<< KnotTheory`

GD[g_GD] := g;
GD[L_] := GD@@PD[L] /.
X[i_,j_,k_,l_]:>If[PositiveQ@X[i,j,k,l],(Subscript[Ap, l,i]),(Subscript[Am, j,i])];
Draw[g_GD] := Module[{n=2Length@g},Graphics[{
Line[{{0,0}, {n+1,0}}],
List@@g /. (Subscript[(ah_), i_,j_]) :> {
Arrow[BezierCurve[{{i,0},{i+j,Abs[j-i]}/2,{j,0}}]],
Text[ah /. {Ap->"+", Am->"-"},{i,0.3}]},
Table[Text[i, {i,-0.5}], {i,n}]}]]

Draw /@ GD /@ AllKnots@{3,5}

GD /@ AllKnots@{3,5}

CF[g_GD]:= Sort[
g /. Thread[Sort@Cases[g,_Integer,∞]->Range[2Length[g]]]];
GPV[F_GD,g_GD] /; Length[F]>Length[g] := 0;
GPV[F_GD,g_GD] /; Length[F]<Length[g] := Sum[
GPV[F,y], {y, Subsets[g,{Length[F]}]}];
GPV[F_GD,g_GD] /; Length[F]==Length[g] := If[
CF[F]===CF[g /. Ap|Am -> A], (((-1))^(Count[g, (Subscript[Am, __])])), 0];
(Subscript[V, 2])[g_] := (Subscript[V, 2])[g] = GPV[GD[(Subscript[A, 3,1]),(Subscript[A, 2,4])], GD[g]];

Format[Knot[n_,k_]]:= (Subscript[n, k]);
Table[K->(Subscript[V, 2])[K], {K, AllKnots@{3,7}}]

GPV[F1_+F2_, g_] := GPV[F1,g]+GPV[F2,g];
GPV[c_*F_GD, g_] := c GPV[F,g];
(Subscript[ρ, k_])[g_]:=g/.i_Integer:>Mod[i-k,2Length@g,1];
(Subscript[F, 3])=(∑_(k=0)^5)(3(Subscript[ρ, k])@GD[(Subscript[A, 1,5]),(Subscript[A, 4,2]),(Subscript[A, 6,3])]+2(Subscript[ρ, k])@GD[(Subscript[A, 1,4]),(Subscript[A, 5,2]),(Subscript[A, 3,6])]);
(Subscript[V, 3])[K_] := (Subscript[V, 3])[K] = GPV[(Subscript[F, 3]), GD@K]/6;

Table[K->(Subscript[V, 3])[K], {K,AllKnots@{3,7}}]

SetOptions[Histogram3D, 
ImageSize -> 4 72/0.65,
ViewPoint->{0.67099,-2.74409,1.86273},
ChartElements->Graphics3D[Cylinder[]]
];

Histogram3D[
Table[{(Subscript[V, 2])[K],(Subscript[V, 3])[K]}, {K,AllKnots@{3,10}}],{1}]

/.-(a_Plus)b_:>(-a)b

(Subscript[G[λ_], a_,b_]):=(∂_((Subscript[t, a]),(Subscript[h, b])))λ;
G/:Factor[G[λ_]]:=G[Collect[λ,(Subscript[h, _]),Collect[#,(Subscript[t, _]),Factor]&]];
Format@γ_G:=Module[{S=Union@Cases[γ,(Subscript[(h|t), a_]):>a,∞]},
Table[(Subscript[γ, a,b]), {a,S}, {b,S}]// MatrixForm] ;

G/:G[λ1_]G[λ2_] := G[λ1+λ2];
(Subscript[m, a_,b_->c_])[G[λ_]] := Module[{α,β,γ,δ,θ,ϵ,ϕ,ψ,Ξ,μ},
(({{α, β, θ}, {γ, δ, ϵ}, {ϕ, ψ, Ξ}}))=(({{(∂_((Subscript[t, a]),(Subscript[h, a])))λ, (∂_((Subscript[t, a]),(Subscript[h, b])))λ, (∂_(Subscript[t, a]))λ}, {(∂_((Subscript[t, b]),(Subscript[h, a])))λ, (∂_((Subscript[t, b]),(Subscript[h, b])))λ, (∂_(Subscript[t, b]))λ}, {(∂_(Subscript[h, a]))λ, (∂_(Subscript[h, b]))λ, λ}}))/.(Subscript[(t|h), a|b])->0; μ=1-β;
G[Tr[(({{(Subscript[t, c])}, {1}}))\[Transpose].(({{γ+α δ/μ, ϵ+δ θ/μ}, {ϕ+α ψ/μ, Ξ+ψ θ/μ}})).(({{(Subscript[h, c])}, {1}}))]] /. (Subscript[T, a|b])->(Subscript[T, c]) // Factor];
(Subscript[Rp, a_,b_]) := G[Tr[(({{(Subscript[t, a])}, {(Subscript[t, b])}}))\[Transpose].(({{1, 1-(Subscript[T, a])}, {0, (Subscript[T, a])}})).(({{(Subscript[h, a])}, {(Subscript[h, b])}}))]];
(Subscript[Rm, a_,b_]) := (Subscript[Rp, a,b]) /. (Subscript[T, a])->1/(Subscript[T, a]);

GG[g_GD, k_, F_] := Module[{n=2Length@g,y,cuts,rr,γ},
Sum[
cuts=Cases[y,_Integer,∞]⋃{n+1};
rr=Thread[cuts->Range[Length@cuts]];
γ=G[(Subscript[t, n+1])(Subscript[h, n+1])]Times@@g /. {Ap->Rp, Am->Rm};
Do[If[!MemberQ[cuts, j], γ=γ//(Subscript[m, j,j+1->j+1])],{j,n}];
F[y /. rr, γ /. (Subscript[(v_), a_]):>(Subscript[v, a/.rr])],
(*over*) {y,Subsets[List@@g,k]}]];
GG[K_,k_,F_] := GG[GD[K],k,F];

(*F[as_,γ_] := Column[{as,γ},Center, ItemStyle -> {FontSize->14,FontSize->8}];
GG[Knot[4,1],{1},F]*)

GG[Knot[4,1],{1},F]

FA[{x_}, γ_] := Simplify[
Switch[x, (Subscript[Ap, __]),1,(Subscript[Am, __]),-1]*Switch[x,(Subscript[_, 1,2]),(((Subscript[γ, 2,2]) (Subscript[γ, 3,3])-(Subscript[γ, 2,3]) (Subscript[γ, 3,2]))/((Subscript[γ, 3,3])+(Subscript[γ, 1,3]) (Subscript[γ, 3,2])-(Subscript[γ, 1,2]) (Subscript[γ, 3,3]))),
(Subscript[_, 2,1]),(((Subscript[γ, 1,3]) (Subscript[γ, 3,2])-(Subscript[γ, 1,2]) (Subscript[γ, 3,3]))/((Subscript[γ, 3,2])-(Subscript[γ, 2,3])(Subscript[γ, 3,2])+(Subscript[γ, 2,2])(Subscript[γ, 3,3])))]/. (Subscript[T, _])->T];
GGA[K_] := GG[K,{1},FA];

Simplify@With[{K=Knot[4,1]},
{GGA[K], Alexander[K][T], T(∂_T)Log[Alexander[K][T]]}]

Table[
K->Simplify[GGA[K]-T(∂_T)Log[Alexander[K][T]]],
{K, AllKnots@{3,8}}]

GG[Knot[4,1],{1,2},F] /. F[y_List, γ_G] :> F[Column@y, γ]

Exporting the above as PDF files

The below is adapted from pensieve://Projects/WKO4/CellExport.nb.

SetDirectory["C:/drorbn/AcademicPensieve/Talks/NCSU-1604/"];

ConditionalExport[fname_String, rest___] := Module[{temp, exists},
temp="ConditionalExportTemporary"<>"."<>FileExtension[fname];
exists=FileExistsQ[fname];
Export[temp, rest];
If[exists && FileByteCount[fname]===FileByteCount[temp],
DeleteFile[temp],
(* else *) Print["Exporting "<>fname<>"..."];
If[exists, DeleteFile[fname]];
RenameFile[temp, fname]
];
fname
]

Button["Export",
SetOptions[$FrontEndSession,PrintingStyleEnvironment->"Working"];
TagProperties[_] := {};
TagProperties["GG441"] = {PageWidth -> 8/0.65};
TagProperties["OneCo441"] = {PageWidth -> 10/0.65};
Options[CellExport] = {
PageWidth -> 4/0.65, CellFilter -> Identity, ExportBaseFilename -> Automatic, ExportFormat -> ".pdf", ExportOptions -> {}, Split -> False
};
CellExport[tag_String, opts___Rule] := CellExport[
NotebookGet[EvaluationNotebook[]],
tag, opts
];
CellExport[nb_Notebook, tag_String] := CellExport[nb, tag, TagProperties[tag]];
CellExport[nb_Notebook, tag_String, OptionsPattern[]] := Module[
{cells, cell, filename, format},
filename = OptionValue[ExportBaseFilename] /. Automatic -> tag;
format=OptionValue[ExportFormat];
cells=OptionValue[CellFilter][Cases[
nb, c_Cell /; FreeQ[List@@c, Cell] && !FreeQ[c, CellTags->tag],
Infinity
]];
If[!OptionValue[Split],
If[Length[cells]≥1,
If[Length[cells]==1,
cells=Append[First[cells], PageWidth ->1.2 72OptionValue[PageWidth]],
cells=Cell[CellGroup[cells], PageWidth -> 72OptionValue[PageWidth]]
];
ConditionalExport[
filename<>format,cells,
ImageResolution -> 300,
OptionValue[ExportOptions]
]
],
k=0;
Table[
++k;
ConditionalExport[
filename<>"-"<>ToString[k]<>format,
Append[cell, PageWidth -> 72OptionValue[PageWidth]],
ImageResolution -> 300,
OptionValue[ExportOptions]
],
{cell, cells}
]
]
];
nb=NotebookGet[EvaluationNotebook[]];
tags=Cases[nb, (CellTags->tag_) :> tag, Infinity ] // Union;
CellExport /@ tags;
Print["Done."]
]