A Determinant for W_alex?

By Dror Bar-Natan; with some code borrowed from a joint project with Louis Leung, Arrow_Diagrams_and_gl (N).

Pensieve Header: Testing if the determinant formula for the w-Alexander weight system satisfies TC, 6T and Slide.

Program

Diagrams

SetAttributes[Diag, Orderless];
Place[{ar},{i_, j_}] := {Diag[ar[i,j]], Diag[ar[j,i]]};
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]  := Place[Table[ar, {k}], Range[2k]];

Relators

Place[{r:(TC|R6T|Slide), objs__}, {i_, rest__}] := Flatten[Table[
Outer[Join,
Place[{r}, {i, {rest}[[j]], {rest}[[k]]}],
Place[{objs}, Delete[{rest}, {{j}, {k}}]]
],
{k, 2, Length[{rest}]}, {j,1, k-1}
]];

Place[{R6T},{i_, j_, k_}] := Permutations[{i,j,k}] /. {i1_,j1_,k1_} :> Diag[R6T[i1,j1,k1]];
Diagrams[R6T] := Place[{R6T}, {1,2,3}];
Diagrams[R6T+k_.*ar] /; k>0 := Flatten[
Place[#, Range[2k+3]]& /@ Permutations[Table[ar, {k}]~Append~R6T]
];
Diagrams[R6T+k_.*ar] /; k<0 := {};

Place[{TC},{i_, j_, k_}] := Diag /@ {TC[i,j,k], TC[j,k,i], TC[k,i,j]};
Diagrams[TC] := Place[{TC}, {1,2,3}];
Diagrams[TC+k_.*ar] /; k>0 := Flatten[
Place[#, Range[2k+3]]& /@ Permutations[Table[ar, {k}]~Append~TC]
];
Diagrams[TC+k_.*ar] /; k<0 := {};

Place[{Slide},{i_, j_, k_}] := Diag /@ {Slide[i,j,k], Slide[j,k,i], Slide[k,i,j]};
Diagrams[Slide] := Place[{Slide}, {1,2,3}];
Diagrams[Slide+k_.*ar] /; k>0 := Flatten[
Place[#, Range[2k+3]]& /@ Permutations[Table[ar, {k}]~Append~Slide]
];
Diagrams[Slide+k_.*ar] /; k<0 := {};

Relations

NormalizeDiag[diag_Diag] := Module[
{indices = Union@@ (List @@ diag /. ar -> List)},
diag /. Thread[indices -> Range[Length[indices]]]
];
R[Diag[lft___, R6T[i_,j_,k_], rgt___]] := (
+NormalizeDiag[Diag[lft, ar[i,j], ar[i+0.5, k], rgt]]
+NormalizeDiag[Diag[lft, ar[i,j], ar[j+0.5, k], rgt]]
+NormalizeDiag[Diag[lft, ar[i,k], ar[j, k+0.5], rgt]]
-NormalizeDiag[Diag[lft, ar[i,k], ar[i+0.5, j], rgt]]
-NormalizeDiag[Diag[lft, ar[i,j+0.5], ar[j, k], rgt]]
-NormalizeDiag[Diag[lft, ar[i,k+0.5], ar[j, k], rgt]]
);
R[Diag[lft___, TC[i_,j_,k_], rgt___]] := (
+NormalizeDiag[Diag[lft, ar[i, j], ar[i+0.5, k], rgt]]
-NormalizeDiag[Diag[lft, ar[i+0.5, j], ar[i, k], rgt]]
);
R[Diag[lft___, Slide[i_,j_,k_], rgt___]] := (
+NormalizeDiag[Diag[lft, ar[i, j-0.5], ar[j, k], rgt]]
-NormalizeDiag[Diag[lft, ar[i, k+0.5], ar[j, k], rgt]]
);

Dimensions

DimAwLong[m_] /; m<2 := Length[Diagrams[m ar]];
DimAwLong[m_] /; m≥2 := Module[
{diags, rels, mat, rel, i},
diags=Diagrams[m ar];
rels=R /@ Join[Diagrams[R6T+(m-2)ar], Diagrams[TC+(m-2)ar]];
mat = SparseArray[
Join @@ Table[
rel=rels[[i]];
{i,Position[diags, #][[1,1]]} -> Coefficient[rel, #]& /@ Cases[{rel}, diag_Diag, Infinity],
{i,Length[rels]}
],
{Length[rels], Length[diags]}
];
Length[diags]-MatrixRank[mat]
];

DimAwLong[3]

The T Matrix

Tij[ar[ti_,hi_], ar[tj_,hj_]] := If[
ti<hj< hi || hi< hj<ti,
Sign[hj-tj],0
];
T[d_Diag] := Outer[Tij,List@@d, List@@d]

T[Diagrams[4ar] // Last] // MatrixForm

Wa

Wa[d_Diag] := Det[T[d]];
Wa[expr_] := expr /. d_Diag :> Wa[d]

Wa[Diagrams[3ar]]

R /@ Diagrams[TC]

Wa[R /@ Diagrams[TC]]

Wa[R /@ Diagrams[TC+1ar]]

Union[Wa[R /@ Diagrams[TC+2ar]]]

Wa[R /@ Diagrams[R6T]]

Wa[R /@ Diagrams[R6T+1ar]] // Union

Wa[R /@ Diagrams[R6T+2ar]] // Union

R /@ Diagrams[Slide]

Wa[R /@ Diagrams[Slide]]

Wa[R /@ Diagrams[Slide+1ar]]

(Diagrams[Slide+1ar])[[8]]

R[Diag[ar[1,3],Slide[4,5,2]]]

Wa[Diag[ar[1,3],ar[4,5],ar[6,2]]-Diag[ar[1,4],ar[5,3],ar[6,2]]]

Immanants

Cycles[p_List] := Cycles[p] = Module[
{q=p, c},
FixedPoint[
(c=MapThread[Min, {#, #[[q]]}]; q=q[[q]]; c)&,
Range[Length[p]]
];
Reverse[Sort[Last /@ Tally[c]]]
];
Immanant[M_?MatrixQ] := Module[
{n=Length[M],ps, p},
ps=Permutations[Range[n]];
Sum[
p=ps[[i]];
(YT@@Cycles[p]) * (Times @@ (M[[#, p[[#]]]]& /@ p)),
{i,n!}
] /; Dimensions[M] == {n,n}
]

Wimm[d_Diag] := Immanant[T[d]];
Wimm[expr_] := expr /. d_Diag :> Wimm[d]

Wimm[Diagrams[3ar]]

Wimm[R /@ Diagrams[TC]]

Wimm[R /@ Diagrams[TC+1ar]]

Union[Wimm[R /@ Diagrams[TC+2ar]]]

Wimm[R /@ Diagrams[R6T]]

Wimm[R /@ Diagrams[R6T+1ar]]

Union[Wimm[R /@ Diagrams[R6T+2ar]]]

Wimm[(R /@ Diagrams[R6T+1ar]) /. Plus -> plus]

Union[Wimm[(R /@ Diagrams[R6T+2ar]) /. Plus -> plus]]