Banana Seifert

SetDirectory["C:\\Users\\T15Roland\\Wiskunde\\Bn\\Seifert"]
Once[<<KnotTheory`]

SetAttributes[P,Orderless]
ProcessSigns[pd_]:=pd/.X[a_,b_,c_,d_]:>If[PositiveQ[X[a,b,c,d]],Xp[a,b,c,d],Xm[a,b,c,d]]
SeifertCycles[pd_]:=(Times@@pd)/.{Xp[a_,b_,c_,d_]:>P[a,b]P[c,d],Xm[a_,b_,c_,d_]:>P[a,d]P[c,b]}//.{P[a___,b_]P[b_,c___]:>P[a,b,c],((x_)^2)->x}
SeifertBycles[pd_]:=(Times@@pd)/.{Xp[a_,b_,c_,d_]:>Q[a]Q[b]Q[d,c],Xm[a_,b_,c_,d_]:>Q[a,d]Q[c]Q[b]}//.{Q[a___,b_]Q[b_,c___]:>Q[a,b,c]}
CutList[pd_]:=First /@List@@(SeifertCycles[pd])
(Subscript[IsIncoming, z_])[XX_]:=If[(z==1)||(Head[XX]===Xp&&(z==4))||(Head[XX]===Xm&&(z==2)),True,False]
CutPD[pd_]:=Module[{pd2=pd,pos},
Do[
pos=Position[pd,c];
If[(Subscript[IsIncoming, pos[[1,2]]])[pd[[pos[[1,1]]]]],
Part[pd2,Sequence@@pos[[1]]]=$[c];Part[pd2,Sequence@@pos[[2]]]=$$[c],
Part[pd2,Sequence@@pos[[2]]]=$[c];Part[pd2,Sequence@@pos[[1]]]=$$[c]];

,{c,CutList[pd]}];
pd2]
SeifertBGraph[K_]:=Module[{pd2=CutPD[ProcessSigns@PD[K]],Edges,Signs=<||>,XV,OV,V},
XV=(List@@pd2)/.{Xp[a_,b_,c_,d_]:>{-a,b,-d},Xm[a_,b_,c_,d_]:>{-a,-b,c}};
Edges=XV//Flatten;
(List@@pd2)/.{Xp[a_,b_,c_,d_]:>(Signs=Append[Signs,{-a->-1,b->1,-d->-1}]),Xm[a_,b_,c_,d_]:>(Signs=Append[Signs,{-a->1,c->1,-b->-1}])};
OV=If[Length[#]==1,Switch[Head[#[[1]]],Integer,{-#[[1]],#[[1]]},$,-#,$$,#],
Join[If[IntegerQ[#[[1]]],{#[[1]]},{}],
-Most[#],
If[IntegerQ[#[[-1]]],{-#[[-1]]},{}]
]

]&/@(List@@(SeifertBycles[pd2]/.((x_)^2)->x)/.Q->List);
{V=Join[OV,XV],Signs}
]

(*Warning! misrepresents the labels of multi-edges*)
DrawGraph[sb_]:=
PlanarGraph[Table[Labeled[UndirectedEdge@@(First/@Position[sb[[1]],e]),sb[[2]][e]],{e,sb[[2]]//Keys}]
]

DrawGraph[SeifertBGraph[#]]&/@AllKnots[{3,8}]

(*Get rid of leaves and degree 2 vertices*)
Prune[sb_]:=Module[{sbnew=sb,Leaves=Flatten@Select[sb[[1]],Length[#]==1&]},
Do[
sbnew[[1]]=DeleteCases[sbnew[[1]],lv,{2}];
sbnew[[2]] = Delete[sbnew[[2]],Key[lv]]
,{lv,Leaves}];
sbnew/.{{}->Nothing}]
Contract[sb_]:=
Module[{sbnew=sb,SmallV=First@Select[sb[[1]],Length[#]==2&],asso},
asso=sbnew[[2]];
asso [First@SmallV]=asso[First@SmallV]+asso[Last@SmallV];
sbnew[[2]] = Delete[asso,Key[Last@SmallV]];

sbnew[[1]]=DeleteCases[sbnew[[1]],SmallV];
sbnew[[1]]=sbnew[[1]]/.{Last@SmallV->First@SmallV};
sbnew]

(*Not correct!*)
DrawGraph@{{{6,-$[2],-4},{-$[2],6,-4}},\[LeftAssociation]-4->-3,6->1,-$[2]->1\[RightAssociation]}

Seifert surfaces for the Rolfsen table (warning twists on multi-edges are displayed incorrectly!)

{#,(DrawGraph@Quiet@FixedPoint[Contract,Prune[SeifertBGraph[#]]])}&/@AllKnots[{3,10}]//Column