Bulk-stitching the simplified 1co invariant (tangle version).

Data-structure of the tangle invariant: {ω,Q,Z0,Z2,Z4,n}, where ω is a Laurent polynomial in t, Q is a quadratic in (Subscript[ξ, i])(Subscript[υ, j]) and Z0,Z2,Z4 are
the constant, quadratic and quartic parts of the perturbation. Finally, n is the number of strands in the tangle.
The tangle is assumed to have has components labeled 1,..,n, where n is the size of the matrix Q. P is a list of disjoint subsets (Subscript[P, i]) of {1,..n}.
After stitching all components in (Subscript[P, i]) are renamed i.

Input: {ω,Q,Z0,Z2,Z4,n} and an ordered partition P  of the strand labels, assumed to be {1,..n}.
Output: The 1co-invariant of the tangle in the same format.

Pol2Mat[P_,n_]:=Table[Coefficient[P,(Subscript[ξ, i])(Subscript[υ, j])],{i,1,n},{j,1,n}](*Convert a 2n-multivariate quadratic to its coefficient matrix*)
Mat2Pol[M_]:=({Table[(Subscript[ξ, i]),{i,1,Length[M]}]}.M.Transpose[{Table[(Subscript[υ, i]),{i,1,Length[M]}]}])[[1,1]](*Convert back*)
(Subscript[m, P_])[{ω_,Q_,Z0_,Z2_,Z4_,n_}]:=Block[{W,M,SwapPoly,A,B,H,G,newω,newQ,newZ0,newZ2,newZ4},W=Sum[If[Position[P,i][[1,1]]==Position[P,j][[1,1]]&&Position[P,i][[1,2]]<Position[P,j][[1,2]],(Subscript[ξ, i])(Subscript[υ, j]),0],{i,1,n},{j,1,n}];
(*Instances of the Weyl commutation relation are collected in W, derived from P.*)
A=Mat2Pol[Inverse[IdentityMatrix[n]-Pol2Mat[W,n].Pol2Mat[Q,n]]];
B=Mat2Pol[Inverse[IdentityMatrix[n]-Pol2Mat[Q,n].Pol2Mat[W,n]]];
G=Mat2Pol[Inverse[IdentityMatrix[n]-Pol2Mat[Q,n].Pol2Mat[W,n]].Pol2Mat[Q,n]];
H=Mat2Pol[Pol2Mat[W,n].Inverse[IdentityMatrix[n]-Pol2Mat[Q,n].Pol2Mat[W,n]]];
newω = ω Det[IdentityMatrix[n]-Pol2Mat[Q,n].Pol2Mat[W,n]];(*The Alexander tangle invt, const*)
newQ=Mat2Pol[Inverse[IdentityMatrix[n]-Pol2Mat[Q,n].Pol2Mat[W,n]].Pol2Mat[Q,n]]//Together;(*The Alexander tangle invt, quadratic*)
SwapPoly=((t+1)/(t-1))Expand[Sum[
Sum[Sum[(Subscript[y, i]),{i,Take[P[[k]],Position[P[[k]],j][[1,1]]-1]}](Subscript[x, j])(Sum[(1/2)(Subscript[y, i]),{i,Take[P[[k]],Position[P[[k]],j][[1,1]]-1]}]+(Subscript[EE, j]))((1/2)(Subscript[x, j])+
Sum[(Subscript[x, i]),{i,Take[P[[k]],{Position[P[[k]],j][[1,1]]+1,Length[P[[k]]]}]  }]+(Subscript[FF, j])),{j,P[[k]]}]
,{k,1,Length[P]}]];(*What comes out of changing order of exponentials, ϵ-part.*)

R40[i_,j_,k_,l_]:=Coefficient[H,(Subscript[ξ, l])(Subscript[υ, i])]Coefficient[H,(Subscript[ξ, j])(Subscript[υ, k])]+Coefficient[H,(Subscript[ξ, l])(Subscript[υ, k])]Coefficient[H,(Subscript[ξ, j])(Subscript[υ, i])];(*Contribution of Z4 to newZ0*)
R42[i_,j_,k_,l_]:=Coefficient[H,(Subscript[ξ, l])(Subscript[υ, i])]Coefficient[B,(Subscript[υ, k])]Coefficient[A,(Subscript[ξ, j])]+Coefficient[H,(Subscript[ξ, j])(Subscript[υ, i])]Coefficient[B,(Subscript[υ, k])]Coefficient[A,(Subscript[ξ, l])]+Coefficient[H,(Subscript[ξ, l])(Subscript[υ, k])]Coefficient[B,(Subscript[υ, i])]Coefficient[A,(Subscript[ξ, j])]+Coefficient[H,(Subscript[ξ, j])(Subscript[υ, k])]Coefficient[B,(Subscript[υ, i])]Coefficient[A,(Subscript[ξ, l])];(*Contribution of Z4 to newZ2*)
Swap2[i_,j_,k_,l_]:=Coefficient[G,(Subscript[υ, i])(Subscript[ξ, j])]Coefficient[G,(Subscript[υ, k])]Coefficient[G,(Subscript[ξ, l])]+Coefficient[G,(Subscript[υ, k])(Subscript[ξ, j])]Coefficient[G,(Subscript[υ, i])]Coefficient[G,(Subscript[ξ, l])]
+Coefficient[G,(Subscript[υ, i])(Subscript[ξ, l])]Coefficient[G,(Subscript[υ, k])]Coefficient[G,(Subscript[ξ, j])]+Coefficient[G,(Subscript[υ, k])(Subscript[ξ, l])]Coefficient[G,(Subscript[υ, i])]Coefficient[G,(Subscript[ξ, j])];(*Contribution of SwapPoly to newZ2*)
Swap0[i_,j_,k_,l_]:=Coefficient[G,(Subscript[υ, i])(Subscript[ξ, j])]Coefficient[G,(Subscript[υ, k])(Subscript[ξ, l])]+Coefficient[G,(Subscript[υ, k])(Subscript[ξ, j])]Coefficient[G,(Subscript[υ, i])(Subscript[ξ, l])];(*Contribution of SwapPoly to newZ2*)

newZ0=Z0+((Z2//Expand)/.{(Subscript[ξ, i_])(Subscript[υ, j_]):>Coefficient[H,(Subscript[ξ, j])(Subscript[υ, i])]})+(*Note these rules only work on polynomials, so need to apply Expand*)
((Z4//Expand)/.{(Subscript[ξ, i_])(Subscript[ξ, k_])(Subscript[υ, j_])(Subscript[υ, l_]):>R40[i,j,k,l],((Subscript[ξ, i_])^2)(Subscript[υ, j_])(Subscript[υ, l_]):>R40[i,j,i,l],(Subscript[ξ, i_])(Subscript[ξ, k_])((Subscript[υ, j_])^2):>R40[i,j,k,j],((Subscript[ξ, i_])^2)((Subscript[υ, j_])^2):>R40[i,j,i,j]})+
+(SwapPoly/.{(Subscript[EE, i_])->0,(Subscript[FF, i_])->0,(Subscript[y, i_])(Subscript[y, k_])(Subscript[x, j_])(Subscript[x, l_]):>Swap0[i,j,k,l],((Subscript[y, i_])^2)(Subscript[x, j_])(Subscript[x, l_]):>Swap0[i,j,i,l],(Subscript[y, i_])(Subscript[y, k_])((Subscript[x, j_])^2):>Swap0[i,j,k,j],((Subscript[y, i_])^2)((Subscript[x, j_])^2):>Swap0[i,j,i,j]});

newZ2=((Z2//Expand)/.{(Subscript[ξ, i_]):> Coefficient[B,(Subscript[υ, i])],(Subscript[υ, i_]):> Coefficient[A,(Subscript[ξ, i])]})+
((Z4//Expand)/.{(Subscript[ξ, i_])(Subscript[ξ, k_])(Subscript[υ, j_])(Subscript[υ, l_]):>R42[i,j,k,l],((Subscript[ξ, i_])^2)(Subscript[υ, j_])(Subscript[υ, l_]):> R42[i,j,i,l],(Subscript[ξ, i_])(Subscript[ξ, k_])((Subscript[υ, j_])^2):> R42[i,j,k,j],((Subscript[ξ, i_])^2)((Subscript[υ, j_])^2):> R42[i,j,i,j]})+
(SwapPoly/.{(Subscript[y, i_])(Subscript[y, k_])(Subscript[x, j_])(Subscript[x, l_]):>Swap2[i,j,k,l],((Subscript[y, i_])^2)(Subscript[x, j_])(Subscript[x, l_]):>Swap2[i,j,i,l],
(Subscript[y, i_])(Subscript[y, k_])((Subscript[x, j_])^2):>Swap2[i,j,k,j],((Subscript[y, i_])^2)((Subscript[x, j_])^2):>Swap2[i,j,i,j],
(Subscript[y, i_])(Subscript[y, k_])(Subscript[x, j_])(Subscript[FF, l_]):>(Coefficient[G,(Subscript[υ, i])(Subscript[ξ, j])]Coefficient[G,(Subscript[υ, k])]+Coefficient[G,(Subscript[υ, k])(Subscript[ξ, j])]Coefficient[G,(Subscript[υ, i])])(Subscript[υ, l]),((Subscript[y, i_])^2)(Subscript[x, j_])(Subscript[FF, l_]):> 2Coefficient[G,(Subscript[υ, i])(Subscript[ξ, j])]Coefficient[G,(Subscript[υ, i])](Subscript[υ, l]),
(Subscript[y, i_])(Subscript[EE, k_])(Subscript[x, j_])(Subscript[x, l_]):>(Coefficient[G,(Subscript[υ, i])(Subscript[ξ, j])]Coefficient[G,(Subscript[ξ, l])]+Coefficient[G,(Subscript[υ, i])(Subscript[ξ, l])]Coefficient[G,(Subscript[ξ, j])])(Subscript[ξ, k]),(Subscript[y, i_])((Subscript[x, j_])^2)(Subscript[EE, l_]):> 2Coefficient[G,(Subscript[υ, i])(Subscript[ξ, j])]Coefficient[G,(Subscript[ξ, j])](Subscript[ξ, l]),
(Subscript[y, i_])(Subscript[x, j_])(Subscript[EE, a_])(Subscript[FF, b_]):> Coefficient[G,(Subscript[υ, i])(Subscript[ξ, j])](Subscript[ξ, a])(Subscript[υ, b])});

newZ4=(Z4/.{(Subscript[ξ, i_]):> Coefficient[B,(Subscript[υ, i])],(Subscript[υ, i_]):> Coefficient[A,(Subscript[ξ, i])],(Subscript[EE, i_])->(Subscript[ξ, i]),(Subscript[FF, i_])->(Subscript[υ, i])})
+(SwapPoly/.{(Subscript[x, i_]):> Coefficient[G,(Subscript[ξ, i])],(Subscript[y, i_]):> Coefficient[G,(Subscript[υ, i])],(Subscript[EE, i_])->(Subscript[ξ, i]),(Subscript[FF, i_])->(Subscript[υ, i])})//Together;

({newω,newQ,newZ0,newZ2,newZ4,Length[P]}/.{(Subscript[ξ, i_]):> (Subscript[ξ, Position[P,i][[1,1]]]),(Subscript[υ, i_]):> (Subscript[υ, Position[P,i][[1,1]]])})//Together
]

(*Bulk meta-associativity*)
({1,Sum[(Subscript[a, i,j])(Subscript[ξ, i])(Subscript[υ, j]),{i,1,4},{j,1,4}],0,0,0,4}//(Subscript[m, {{1},{2},{3,4}}])//(Subscript[m, {{1,2},{3}}]))-({1,Sum[(Subscript[a, i,j])(Subscript[ξ, i])(Subscript[υ, j]),{i,1,4},{j,1,4}],0,0,0,4}//(Subscript[m, {{1,2},{3,4}}]))//Together
({1,Sum[(Subscript[a, i,j])(Subscript[ξ, i])(Subscript[υ, j]),{i,1,3},{j,1,3}],0,0,0,3}//(Subscript[m, {{1,2},{3}}])//(Subscript[m, {{1,2}}]))-({1,Sum[(Subscript[a, i,j])(Subscript[ξ, i])(Subscript[υ, j]),{i,1,3},{j,1,3}],0,0,0,3}//(Subscript[m, {{1,2,3}}]))//Together
({1,Sum[(Subscript[a, i,j])(Subscript[ξ, i])(Subscript[υ, j]),{i,1,3},{j,1,3}],0,0,0,3}//(Subscript[m, {{1},{2,3}}])//(Subscript[m, {{1,2}}]))-({1,Sum[(Subscript[a, i,j])(Subscript[ξ, i])(Subscript[υ, j]),{i,1,3},{j,1,3}],0,0,0,3}//(Subscript[m, {{1,2,3}}]))//Together

(*Disjoint union of a list L of tangles. Each tangle is supposed to be labelled with 1,2,3,...
DU renames the components 1,2,3.. in order of appearance*)
DU[L_]:=Block[{OutTangle,NextTangle},
OutTangle = L[[1]];
Do[
NextTangle=L[[k]]/.{(Subscript[ξ, i_])->(Subscript[ξ, i+OutTangle[[6]]]),(Subscript[υ, i_])->(Subscript[υ, i+OutTangle[[6]]])};
OutTangle[[1]] *= NextTangle[[1]];  
OutTangle[[2]] += NextTangle[[2]];
OutTangle[[3]] += NextTangle[[3]];
OutTangle[[4]] += NextTangle[[4]];
OutTangle[[5]] += NextTangle[[5]];
OutTangle[[6]] += NextTangle[[6]];
,{k,2,Length[L]}];
OutTangle
]

R-matrices and cuaps

(*(t^(-(1/2)))*)(SuperPlus[R])={1,(1-t)((Subscript[ξ, 1]) -(Subscript[ξ, 2]) )(Subscript[υ, 2]),0,0,((((1-t) (((Subscript[ξ, 1]) (Subscript[υ, 2]))/2)))^2)-((((1+t) (((Subscript[ξ, 2]) (Subscript[υ, 2]))/2)))^2)+ t (Subscript[ξ, 1]) (Subscript[ξ, 2]) (Subscript[υ, 2])((Subscript[υ, 1])+ (1-t) (Subscript[υ, 2])),2}; 
(*(t^(1/2))*)(SuperMinus[R])={1,(1-(t^(-1)))((Subscript[ξ, 1]) -(Subscript[ξ, 2]) )(Subscript[υ, 2]),0,0,-((((1-(t^(-1))) (((Subscript[ξ, 1]) (Subscript[υ, 2]))/2)))^2)+((((1+(t^(-1))) (((Subscript[ξ, 2]) (Subscript[υ, 2]))/2)))^2)+(t^(-1)) (Subscript[ξ, 1])  (Subscript[υ, 1]) (Subscript[υ, 2])(-(Subscript[ξ, 2])+(1-t)(Subscript[ξ, 1])),2};
(*(t^(1/2))*) n={1,0,0,-(Subscript[ξ, 1])(Subscript[υ, 1]),0,1};
(*(t^(-(1/2)))*)     u={1,0,0,(Subscript[ξ, 1])(Subscript[υ, 1]),0,1};

Reidemeister moves:

(*Rotated crossing*)
{(DU[{u,u,(SuperPlus[R]),n,n}]//(Subscript[m, {{1,3,5},{2,4,6}}]))-(SuperPlus[R]),(DU[{u,u,(SuperMinus[R]),n,n}]//(Subscript[m, {{1,3,5},{2,4,6}}]))-(SuperMinus[R]),
(DU[{n,n,(SuperPlus[R]),u,u}]//(Subscript[m, {{1,3,5},{2,4,6}}]))-(SuperPlus[R]),(DU[{n,n,(SuperMinus[R]),u,u}]//(Subscript[m, {{1,3,5},{2,4,6}}]))-(SuperMinus[R])}//Expand

(*Reidemeister 1, note the t-correction is still necessary*)
{DU[{(SuperPlus[R]),n}]//(Subscript[m, {{1,3,2}}]),DU[{(SuperPlus[R]),u}]//(Subscript[m, {{2,3,1}}]),DU[{(SuperMinus[R]),u}]//(Subscript[m, {{1,3,2}}]),DU[{(SuperMinus[R]),n}]//(Subscript[m, {{2,3,1}}])}

(*Reidemeister 2 (braid-like)*)
{DU[{(SuperPlus[R]),(SuperMinus[R])}]//(Subscript[m, {{1,3},{2,4}}]),DU[{(SuperMinus[R]),(SuperPlus[R])}]//(Subscript[m, {{1,3},{2,4}}])}

(*Reidemeister 2 (opposites)*)
{DU[{(SuperMinus[R]),(SuperPlus[R]),u,n}]//(Subscript[m, {{1,3},{4,5,2,6}}]),DU[{(SuperPlus[R]),(SuperMinus[R]),u,n}]//(Subscript[m, {{5,1,6,3},{4,2}}])}

(*Reidemeister 3*)
{(DU[{(SuperPlus[R]),(SuperPlus[R]),(SuperPlus[R])}]//(Subscript[m, {{1,3},{2,5},{4,6}}]))-(DU[{(SuperPlus[R]),(SuperPlus[R]),(SuperPlus[R])}]//(Subscript[m, {{3,5},{1,6},{2,4}}])),(DU[{(SuperMinus[R]),(SuperMinus[R]),(SuperMinus[R])}]//(Subscript[m, {{1,3},{2,5},{4,6}}]))-(DU[{(SuperMinus[R]),(SuperMinus[R]),(SuperMinus[R])}]//(Subscript[m, {{3,5},{1,6},{2,4}}]))}//Expand

Some knots:

(*Trefoil*)
DU[{(SuperPlus[R]),(SuperPlus[R]),(SuperPlus[R]),n}]//(Subscript[m, {{1,4,5,7,2,3,6}}])

(*Figure-eight*)
DU[{(SuperPlus[R]),(SuperPlus[R]),(SuperMinus[R]),(SuperMinus[R]),n,u}]//(Subscript[m, {{2,3,8,9,5,4,10,1,6,7}}])