(* ::Package:: *)

(************************************************************************)\012(* This file was generated automatically by the Mathematica front end.  *)\012(* It contains Initialization cells from a Notebook file, which         *)\012(* typically will have the same name as this file except ending in      *)\012(* ".nb" instead of ".m".                                               *)\012(*                                                                      *)\012(* This file is intended to be loaded into the Mathematica kernel using *)\012(* the package loading commands Get or Needs.  Doing so is equivalent   *)\012(* to using the Evaluate Initialization Cells menu command in the front *)\012(* end.                                                                 *)\012(*                                                                      *)\012(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)\012(* automatically each time the parent Notebook file is saved in the     *)\012(* Mathematica front end.  Any changes you make to this file will be    *)\012(* overwritten.                                                         *)\012(************************************************************************)\012\012

(* ::Input::Initialization:: *)
SetDirectory["C:\\drorbn\\AcademicPensieve\\People\\VanDerVeen"]
Once[<<KnotTheory`]


(* ::Input::Initialization:: *)
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}]
]


(* ::Input::Initialization:: *)
(*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]



