An Unexpected Cyclic Symmetry of (Subscript[I𝔲, n]) - Verification Notebook

Pensieve header: Verification notebook for “An Unexpected Cyclic Symmetry of $Iu_n$ by Dror Bar-Natan and Roland van der Veen. Also available at http://drorbn.net/UnexpectedCyclic. Continues pensieve://2020-01/ .

Only Theorem 2 is tested; Theorem 1 is simply the case where ϵ=0, so it does not require independent testing.

Definitions.

General definitions - brackets B and pairings P are bilinear, brackets are anti-symmetric:

B[0,_]=0; B[_,0]=0;
B[c_*x:(Subscript[(x|a|b), __]),y_]:=Expand[c B[x,y]];
B[y_,c_*x:(Subscript[(x|a|b), __])]:=Expand[c B[y,x]];
B[x_Plus,y_] := B[#,y]& /@ x;
B[x_,y_Plus] := B[x,#]& /@ y;

P[0,_]=0; P[_,0]=0;
P[c_*x:(Subscript[(x|a|b), __]),y_]:=Expand[c P[x,y]];
P[y_,c_*x:(Subscript[(x|a|b), __])]:=Expand[c P[y,x]];
P[x_Plus,y_] := P[#,y]& /@ x;
P[x_,y_Plus] := P[x,#]& /@ y;

B[y_,x_] := Expand[-B[x,y]];

The default value of n (can be changed):

n=5;

The “length” λ and the “truth indicator” (Subscript[χ, ϵ]), and the Kronecker δ-function δ:

λ[(Subscript[x, i_,j_])]:=({{\[Piecewise], ({{j-i, i<j}, {n-(i-j), i>j}})}})
(Subscript[χ, ϵ_])[cond_]:= If[TrueQ@cond, 1,ϵ];
(Subscript[δ, i_,j_]):=(Subscript[χ, 0])[i==j];

The bracket:

B[(Subscript[x, i_,j_]),(Subscript[x, k_,l_])] := ({{\[Piecewise], ({{(Subscript[χ, ϵ])[λ[(Subscript[x, i,j])]+λ[(Subscript[x, k,l])]<n]((Subscript[δ, j,k])(Subscript[x, i,l])-(Subscript[δ, l,i])(Subscript[x, k,j])), j≠k∨l≠i}, {(Subscript[b, i])-(Subscript[b, j])+(ϵ/2) (Subscript[a, i])-(ϵ/2)(Subscript[a, j]), j==k∧l==i}})}});
B[(Subscript[a, i_]),(Subscript[x, j_,k_])]:=((Subscript[δ, i,j])-(Subscript[δ, i,k]))(Subscript[x, j,k]);
B[(Subscript[b, i_]),(Subscript[x, j_,k_])]:=(ϵ/2)((Subscript[δ, i,j])-(Subscript[δ, i,k]))(Subscript[x, j,k]);
B[(Subscript[(a|b), _]),(Subscript[(a|b), _])]=0;

The duality pairing:

P[(Subscript[x, i_,j_]), (Subscript[x, k_,l_])] := (Subscript[δ, j,k])(Subscript[δ, l,i]);
P[(Subscript[x, __]),(Subscript[(a|b), _])]=0; P[(Subscript[(a|b), _]),(Subscript[x, __])]=0;
P[(Subscript[a, i_]),(Subscript[b, j_])]:= (Subscript[δ, i,j]); P[(Subscript[b, j_]),(Subscript[a, i_])]:= (Subscript[δ, i,j]);
P[(Subscript[a, _]),(Subscript[a, _])]=0; P[(Subscript[b, _]),(Subscript[b, _])]=0;

The permutation ψ and the automorphism Ψ:

ψ[k_Integer]:=({{\[Piecewise], ({{k+1, k<n}, {1, k==n}})}});
Ψ[ℰ_]:=ℰ/.{(Subscript[x, i_,j_]):>(Subscript[x, ψ@i,ψ@j]), (Subscript[a, i_]):>(Subscript[a, ψ@i]), (Subscript[b, i_]):>(Subscript[b, ψ@i])}

The basis of (Subscript[I𝔲, n]) / (Subscript[gl, n+]^ϵ):

Basis[n_] :=Flatten@{
Table[{(Subscript[x, i,j]),(Subscript[x, j,i])},{i,n-1}, {j,i+1,n}],
Table[{(Subscript[a, i]),(Subscript[b, i])},{i,n}] }

Testing.

Basis[4]

A full bracket-table for n=2:

n=2; MatrixForm[
Table[B[u,v],{u,Basis[n]}, {v,Basis[n]}],
TableHeadings->{Basis[n], Basis[n]}]

The bracket is anti-symmetric at n=4:

n=4; Short@Table[
{u,v}=t; B[u,v]+B[v,u],
{t, Tuples[Basis[n], 2]}]

The bracket satisfies the Jacobi identity:

n=4; DeleteCases[0]@Table[
{u,v,w}=t; B[u,B[v,w]]+B[v,B[w,u]]+B[w,B[u,v]],
{t, Tuples[Basis[n], 3]} ]

The pairing is invariant:

n=4; DeleteCases[0]@Table[
{u,v,w}=t; P[B[u,v],w]+P[v,B[u,w]],
{t, Tuples[Basis[n], 3]} ]

The action of Ψ:

(#->Ψ[#])&/@Basis[4]

Ψ is an automorphism:

n=4; DeleteCases[0]@Table[
{u,v}=t; Ψ[B[u,v]]-B[Ψ[u],Ψ[v]],
{t, Tuples[Basis[n], 2]} ]

Ψ respects the pairing:

n=4; DeleteCases[0]@Table[
{u,v}=t; Ψ[P[u,v]]-P[Ψ[u],Ψ[v]],
{t, Tuples[Basis[n], 2]} ]

Bonus Tests

Acting by arbitrary index-permutations:

(Subscript[Act, σ_List])[ℰ_]:=ℰ/.{(Subscript[x, i_,j_]):>(Subscript[x, σ[[i]],σ[[j]]]), (Subscript[a, i_]):>(Subscript[a, σ[[i]]]), (Subscript[b, i_]):>(Subscript[b, σ[[i]]])}

At n=5, only cyclic permutations induce automorphisms:

n=5;
Select[Permutations[Range[n]],
σ|->And@@Flatten[Table[
(Subscript[Act, σ])[B[u,v]]===B[(Subscript[Act, σ])[u],(Subscript[Act, σ])[v]],
{u,Basis[n]}, {v,Basis[n]}
]]
]

Yet in the case of (Subscript[gl, n]), meaning when ϵ=1, all permutations induce automorphisms:

n=4;
Block[{ϵ=1},Select[Permutations[Range[n]],
σ|->And@@Flatten[Table[
(Subscript[Act, σ])[B[u,v]]===B[(Subscript[Act, σ])[u],(Subscript[Act, σ])[v]],
{u,Basis[n]}, {v,Basis[n]}
]]
]]

If ϵ is invertible, the isomorphism class of (Subscript[gl, n+]^ϵ) is independent of ϵ, using Inonu-Wigner contractions:

(Subscript[IW, λ_])[ℰ_] := ℰ /. {(Subscript[x, i_,j_])/;i>j:>λ (Subscript[x, i,j]), (Subscript[b, i_]):>λ (Subscript[b, i])};

n=4;
Union@Flatten@Table[
(B[u,v]/.ϵ->1)==(Subscript[IW, ϵ])@B[(Subscript[IW, 1/ϵ])@u,(Subscript[IW, 1/ϵ])@v],
{u,Basis[n]},{v,Basis[n]}
]

Even cyclic index permutations become singular at ϵ=0 when conjugated by Inonu-Wigner contractions (so Ψ simply isn’t that):

n=4; Table[u->(Subscript[IW, ϵ])@(Subscript[Act, {2,3,4,1}])@(Subscript[IW, 1/ϵ])@u,{u,Basis[n]} ]

n=4; Table[u->(Subscript[IW, 1/ϵ])@(Subscript[Act, {2,3,4,1}])@(Subscript[IW, ϵ])@u,{u,Basis[n]} ]

The same is true for all other permutations (except the identity):

n=3;MatrixForm[
Table[(Subscript[IW, ϵ])@(Subscript[Act, σ])@(Subscript[IW, 1/ϵ])@u,{σ,rows=Permutations@Range@n},{u,cols=Basis[n]}],
TableHeadings -> {rows,cols} ]

n=3;MatrixForm[
Table[(Subscript[IW, 1/ϵ])@(Subscript[Act, σ])@(Subscript[IW, ϵ])@u,{σ,rows=Permutations@Range@n},{u,cols=Basis[n]}],
TableHeadings -> {rows,cols} ]