(* ::Package:: *)

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



(* ::Input::Initialization:: *)
Once[<<KnotTheory`];
HL[\[ScriptCapitalE]_] := Style[\[ScriptCapitalE], Background -> If[TrueQ@\[ScriptCapitalE],RGBColor[Rational[1, 3], 1, Rational[1, 3]],RGBColor[1, 0.5, 0.5]]];
\[Chi][cond_]:=If[TrueQ[cond],1,0];


(* ::Input::Initialization:: *)
DeclareGroup[Subscript[S, k_]]:=Module[{\[Alpha],\[Beta],e,\[Gamma]s},
Clear[G,n,g,\[Iota],m,inv];
G=PermutationCycles/@(Permutations@Range@k);
n=Length[G];
Do[g[\[Alpha]]=e=G[[\[Alpha]]]; \[Iota][e]=\[Alpha],{\[Alpha],n} ];
m[]=\[Iota][Cycles[{}]];
Do[m[\[Alpha],\[Beta]]=\[Iota][g[\[Alpha]]~PermutationProduct~g[\[Beta]]],{\[Alpha],n},{\[Beta],n} ];
m[\[Alpha]_]:=\[Alpha]; m[\[Alpha]_,\[Beta]_,\[Gamma]s__]:=m[m[\[Alpha],\[Beta]],\[Gamma]s];
Do[inv[\[Alpha]]=\[Iota][InversePermutation[g[\[Alpha]]]],{\[Alpha],n}]
]


(* ::Input::Initialization:: *)
DeclareGroup[Subscript[S, 3]];
Table[m[i,j],{i,n},{j,n}]//MatrixForm


(* ::Input::Initialization:: *)
Basis[]={1};
Basis[i_,is___]:=Flatten@Table[Subscript[W, i][\[Alpha],\[Beta]]Basis[is],{\[Alpha],n},{\[Beta],n}]


(* ::Input::Initialization:: *)
Subscript[m, i_,j_->k_][\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE]]/.Subscript[W, i][\[Alpha]_,\[Beta]_]Subscript[W, j][\[Gamma]_,\[Delta]_]:>\[Chi][m[\[Alpha],\[Beta]]==m[\[Beta],\[Gamma]]]Subscript[W, k][\[Alpha],m[\[Beta],\[Delta]]];
Subscript[\[Eta], i_][\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE] Sum[Subscript[W, i][\[Alpha],m[]], {\[Alpha],n}]];
Subscript[\[CapitalDelta], i_->j_,k_][\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE]/.Subscript[W, i][\[Alpha]_,\[Beta]_]:>Sum[Subscript[W, j][\[Gamma],\[Beta]]Subscript[W, k][m[\[Alpha],inv[\[Gamma]]],\[Beta]],{\[Gamma],n}]];
Subscript[\[Epsilon], i_][\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE]/.Subscript[W, i][\[Alpha]_,\[Beta]_]:>\[Chi][\[Alpha]==m[]]];
Subscript[S, i_][\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE]/.Subscript[W, i][\[Alpha]_,\[Beta]_]:>Subscript[W, i][m[inv[\[Beta]],inv[\[Alpha]],\[Beta]], inv[\[Beta]]]];


(* ::Input::Initialization:: *)
Subscript[R, i_,j_]:=Sum[Subscript[W, i][\[Alpha],1]Subscript[W, j][\[Beta],\[Alpha]], {\[Alpha],n}, {\[Beta],n}];
Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), i_,j_]:=Sum[Subscript[W, i][\[Alpha],1]Subscript[W, j][\[Beta],inv@\[Alpha]], {\[Alpha],n}, {\[Beta],n}];


(* ::Input::Initialization:: *)
Z[K_]:=Module[{z},
z=Expand[Times@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ@x, Subscript[R, l,i],Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), j,i]]];
Do[z=z//Subscript[m, c[[1]],c[[j]]->c[[1]]],{c,Skeleton[K]},{j,2,Length@c}];
z]


(* ::Input::Initialization:: *)
ZF[K_]:=ZF[PD@K];
ZF[pd_PD]:=Module[{z,done,st,c,mn,k},
z=1; done={};st=Range[2Length@pd];
Do[
z*=c/.X[i_,j_,_,l_]:>If[PositiveQ@c,mn={i,l}; Subscript[R, l,i],mn={i,j};Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), j,i]];
Do[
If[MemberQ[done, k+1],z=z//Subscript[m, k,k+1->k]; st=st/.k+1->k];
If[MemberQ[done, k-1],z=z//Subscript[m, st[[k-1]],k->st[[k-1]]]; st=st/.k->st[[k-1]]],
{k,mn}];
done=done\[Union]mn,
{c,List@@pd}];
z ]


(* ::Input::Initialization:: *)
ThinPosition[K_]:=Module[{todo,done,pd,c},
todo=List@@PD@K; done={}; pd=PD[];
While[todo=!={},
AppendTo[pd,c=RandomChoice@MaximalBy[todo, Length[done\[Intersection]List@@#]&]];
todo=DeleteCases[todo, c];
done=done\[Union]List@@c];
pd
]


(* ::Input::Initialization:: *)
ZEF[K_]:=ZF@ThinPosition@K;



