Pensieve Header: The "Cut and Cap" part of the GPV algorithm; continued in Pensieve/Projects/GPV.

<< KnotTheory`

gc=GC[Ar[4,1,1],Ar[2,5,1],Ar[6,8,1],Ar[3,7,-1]]

Place[{Ar},{i_, j_}] := {GC[Ar[i,j,1]], GC[Ar[j,i,1]], GC[Ar[i,j,-1]], GC[Ar[j,i,-1]]};
Place[{Ar, objs__}, {i_, rest__}] := Flatten[Table[
Outer[Join,
Place[{Ar}, {i, {rest}[[k]]}],
Place[{objs}, Delete[{rest}, k]]
],
{k, Length[{rest}]}
]];
Diagrams[k_.*Ar]  := NormalForm[
Place[Table[Ar, {k}], Range[2k]]
];
NormalForm[gc_GC] := Module[{l,r,a,b},
Sort[
l=Length[r=Sort[Flatten[Cases[gc, Ar[a_,b_,_] :> {a,b}]]]];
r=Thread[r->Range[l]];
gc /. Ar[a_,b_,s_] :> Ar[a/.r, b/.r,s], (Min[#1[[1]], #1[[2]]]<Min[#2[[1]], #2[[2]]])&
]
];
NormalForm[expr_] := expr /. gc_GC :> NormalForm[gc];
S[gc_GC] := NormalForm[Total[Subsets[gc]]];
S[expr_] := Expand[expr /. gc_GC :> S[gc]];
Sinv[gc_GC] := Module[
{s=(-1)^Length[gc]},
S[gc] /. g_GC :> (-1)^Length[g]*s*g
];
Sinv[expr_] := Expand[expr /. gc_GC :> Sinv[gc]];
PD[gc_GC]:= Module[
{g},
g=FixedPoint[
NormalForm[DeleteCases[#, Ar[a_,b_,_] /; Abs[a-b]==1]]&,
gc
];
If[g===GC[], PD[Loop[1]],
PD@@g /. Ar[a_, b_, s_] :> If[s>0,
X[b-1,a,b,a-1],
X[b-1,a-1,b,a]
] /. 0 -> 2Length[g]
]
];
Periphery[Ar[i_,j_,s_]] := Module[
{f=Min[i,j], p={-i,-j*s,i,j*s}},
While[First[p]≠ -f, p=RotateLeft[p]];
p
];
CC[g_GC] := Module[
{n, gc,BlueLine,p,OtherEnds,a,i,j,i1,i2,j1,j2,a1,a2,b1,b2,t1,t2,ti,tj,s},
n=Length[gc=NormalForm[g]];
BlueLine={ -2n-1,0};
Scan[
(
p=Periphery[#];
BlueLine = Flatten[BlueLine /. -First[p]-1 -> Rest[p]]
)&,
gc
];
OtherEnds=Table[0, {2n+2}];
Do[
If[(a=BlueLine[[i]])>0,
j=Position[BlueLine, -a-1][[1,1]];
OtherEnds[[OtherEnds[[i]]=j]]=i
],
{i,2n+2}
];
Do[
If[(i2=OtherEnds[[i1]])>i1,
{a1,a2}=BlueLine[[{i1,i2}]];
Do[
If[(j2=OtherEnds[[j1]]) >j1,
{b1,b2}=BlueLine[[{j1,j2}]];
If[j1<i2<j2,
ti=If[a1>0, a1+0.5+0.01*j1, a2+0.5-0.01*j1];
tj=If[b1>0, b1+0.01i2, b2+1-0.01i2];
{t1,t2}=Sort[{ti,tj}];
s=Sign[ti-tj]Sign[a1]Sign[b1];
AppendTo[gc,Ar[t1,t2,s]]
]
],
{j1,i1+1,2n+2}]
],
{i1,2n+1}
];
NormalForm[gc]
];
omega[nu_][gc_GC] := Expand[Sinv[gc] /. g_GC :> nu[PD[CC[g]]]];

t=omega[Vassiliev[2]][gc]

CC[gc]

S[gc]

Sinv[gc]

{gc, Sinv[S[gc]], S[Sinv[gc]]}

DrawMorseLink[PD[CC[gc]]]

Sinv[gc] /. gc_GC :> PD[gc]

Thread[
Diagrams[2Ar] -> (omega[Vassiliev[2]][#]& /@ Diagrams[2Ar])
]

t=Thread[
Diagrams[3Ar] -> (omega[Vassiliev[2]][#]& /@ Diagrams[3Ar])
]

t1=Select[t, Last[#] ≠ 0&]

t2=Sinv[GC[Ar[1,3,1],Ar[2,5,1],Ar[6,4,1]]]

t3 = t2 /. gc_GC :> CC[gc]

t4 = t3/. gc_GC :> PD[gc]

t4 /. pd_PD:> DrawMorseLink[pd]