Mathcamp Day 2

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

Pensieve Header: Generating the equations for Mathcamp Day 2.

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]]
);

Equations

m=3;
diags=Diagrams[m ar];
rels=R /@ Join[Diagrams[R6T+(m-2)ar], Diagrams[TC+(m-2)ar]];
eqns = rels /. Thread[diags -> Table[x[i], {i, Length[diags]}]]

Length[eqns]