Pensieve header: Palindromicity by flipping and manipulating, in Gaussian integration language.

Programs

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\APAI"];
Once[
<<KnotTheory`;
<< Rot.m
];
CF[ℰ_]:=Sum[Factor[(∂_((Subscript[x, i]),(Subscript[p, j])))ℰ](Subscript[x, i])(Subscript[p, j]),{i,0,2n+2},{j,0,2n+2}]

K=Mirror@Knot[3,1];
{Cs,ρ}=Rot[K]
 n=Length[Cs];
ν={lν=0};
For[k=1,k<=2n,++k,Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}];ν
Q0=CF@Total[Cs/.{s_Integer,j_,i_}:>(Subscript[x, i])((Subscript[p, i])-(T^s)(Subscript[p, i+1])+((T^s)-1)(Subscript[p, j+1]))+(Subscript[x, j])((Subscript[p, j])-(Subscript[p, j+1]))]-(Subscript[x, 2n+1])(Subscript[p, 2n+1])
CF[Q0/.Join@@(Cs/.{s_Integer,j_,i_}:>{(Subscript[x, i])->(T^(-s))(Subscript[x, i]),(Subscript[x, j])->(Subscript[x, j])+(1-(T^(-s)))(Subscript[x, i])})]==(Q1=CF[Total[Cs/.{s_Integer,j_,i_}:>(T^(-s)) (Subscript[p, i]) (Subscript[x, i])+(Subscript[p, j]) (Subscript[x, i])-(T^(-s)) (Subscript[p, j]) (Subscript[x, i])+(Subscript[p, j]) (Subscript[x, j])]-Sum[(Subscript[x, k])(Subscript[p, k+1]),{k,1,2n}]-(Subscript[x, 2n+1])(Subscript[p, 2n+1])])
(Q1/.{p->x,x->p})==(Q2=CF[Total[Cs/.{s_Integer,j_,i_}:>(T^(-s)) (Subscript[x, i]) (Subscript[p, i])+(Subscript[x, j]) (Subscript[p, i])-(T^(-s)) (Subscript[x, j]) (Subscript[p, i])+(Subscript[x, j]) (Subscript[p, j])]-Sum[(Subscript[p, k])(Subscript[x, k+1]),{k,1,2n}]-(Subscript[p, 2n+1])(Subscript[x, 2n+1])])==CF[Total[Cs/.{s_Integer,j_,i_}:>(T^(-s)) (Subscript[x, i]) (Subscript[p, i])+(Subscript[x, j]) (Subscript[p, i])-(T^(-s)) (Subscript[x, j]) (Subscript[p, i])+(Subscript[x, j]) (Subscript[p, j])]-Sum[(Subscript[p, k-1])(Subscript[x, k]),{k,1,2n}]+(Subscript[p, 0])(Subscript[x, 1])-(Subscript[p, 2n])(Subscript[x, 2n+1])-(Subscript[p, 2n+1])(Subscript[x, 2n+1])]
(Q2/.{(Subscript[p, 2n+1])->(Subscript[p, 1]),(Subscript[p, i_]):>(Subscript[p, i+1])})==(Q3=CF[Total[Cs/.{s_Integer,j_,i_}:>(T^(-s)) (Subscript[x, i]) (Subscript[p, i+1])+(Subscript[x, j]) (Subscript[p, i+1])-(T^(-s)) (Subscript[x, j]) (Subscript[p, i+1])+(Subscript[x, j]) (Subscript[p, j+1])]-Sum[(Subscript[p, k])(Subscript[x, k]),{k,1,2n}]+(Subscript[p, 1])(Subscript[x, 1])-(Subscript[p, 2n+1])(Subscript[x, 2n+1])-(Subscript[p, 1])(Subscript[x, 2n+1])])==CF[Total[Cs/.{s_Integer,j_,i_}:>(T^(-s)) (Subscript[x, i]) (Subscript[p, i+1])+(1-(T^(-s)) )(Subscript[x, j]) (Subscript[p, i+1])+(Subscript[x, j]) (Subscript[p, j+1])-(Subscript[x, i])(Subscript[p, i])-(Subscript[x, j])(Subscript[p, j])]+(Subscript[p, 1])(Subscript[x, 1])-(Subscript[p, 2n+1])(Subscript[x, 2n+1])-(Subscript[p, 1])(Subscript[x, 2n+1])]
CF[Q4=Q3/.{(Subscript[p, i_]):>(T^(-ν[[i]]))(Subscript[p, i]),(Subscript[x, i_]):>-(T^(ν[[i]]))(Subscript[x, i])}]==CF[Total[Cs/.{s_Integer,i_,j_}:>(Subscript[x, i])((Subscript[p, i])-(T^(-s))(Subscript[p, i+1])+((T^(-s))-1)(Subscript[p, j+1]))+(Subscript[x, j])((Subscript[p, j])-(Subscript[p, j+1]))]-(Subscript[p, 1])(Subscript[x, 1])+(Subscript[p, 2n+1])(Subscript[x, 2n+1])+(Subscript[p, 1])(Subscript[x, 2n+1])]
CF[Q4/.(Subscript[p, k_])/;k>1:>(Subscript[p, k])-(Subscript[p, 1])]==CF[Total[Cs/.{s_Integer,i_,j_}:>(Subscript[x, i])((Subscript[p, i])-(T^(-s))(Subscript[p, i+1])+((T^(-s))-1)(Subscript[p, j+1]))+(Subscript[x, j])((Subscript[p, j])-(Subscript[p, j+1]))]+(Subscript[p, 2n+1])(Subscript[x, 2n+1])]

%//Simplify

AlexanderMatrices[K_]:=Module[{},
{Cs,ρ}=Rot[K]; n=Length[Cs];
 ν={lν=0};
For[k=1,k<=2n,++k,Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}];
ν=DiagonalMatrix[(T^ν)]; νi=Inverse@ν;
A0=Table[0,2n+1,2n+1]; A0[[2n+1,2n+1]]=1;
C2=C1=Aπ=A1=A2=A3=A4=A0;
P1=RotateLeft[IdentityMatrix[2n+1]];
(*P1=Table[0,2n+1,2n+1]; Do[P1[[i,i+1]]=1,{i,2n}];*)
P2=IdentityMatrix[2n+1]; Do[P2[[i,1]]=-1,{i,2,2n+1}];
(Subscript[E, i_,j_]):=ReplacePart[Table[0,2n+1,2n+1],{i,j}->1];
Cases[Cs,{s_Integer,i_,j_}:>(Aπ[[{i,j},{i,j,i+1,j+1}]]=(({{1, 0, -1, 0}, {0, 1, (T^s)-1, -(T^s)}}));A0[[{i,j},{i,j,i+1,j+1}]]=(({{1, 0, -(T^s), (T^s)-1}, {0, 1, 0, -1}}));
C1[[{i,j},{i,j}]]=(({{-(T^(-s)), (T^(-s))-1}, {0, -1}})); C2[[{i,j},{i,j}]]=(({{-(T^(-s)), 0}, {(T^(-s))-1, -1}}));
A1[[{i,j},{i,j,i+1,j+1}]]=(({{-(T^(-s)), (T^(-s))-1, 1, 0}, {0, -1, 0, 1}})); A2[[{i,j,i+1,j+1},{i,j}]]=(({{-(T^(-s)), 0}, {(T^(-s))-1, -1}, {1, 0}, {0, 1}}));
A3[[{i,j},{i,j,i+1,j+1}]]=(({{1, 0, -(T^(-s)), 0}, {0, 1, (T^(-s))-1, -1}})); A4[[{i,j},{i,j,i+1,j+1}]]=(({{1, 0, -1, 0}, {0, 1, (T^(-s))-1, -(T^(-s))}}));)]; ]
AlexanderMatrices[Knot[10,165]]
Det/@{Aπ,A0,A1,A2,A3,A4}
Simplify[{C1.A0==A1,(C1.A0)\[Transpose]==A2, A0\[Transpose].C2.P1+(Subscript[E, 1,1])==A3, νi.A0\[Transpose].C2.P1.ν+(Subscript[E, 1,1])==A4,νi.A0\[Transpose].C2.P1.ν.P2==(Aπ/.T->(T^(-1)))}]

Total@Table[AlexanderMatrices[K]; Simplify[νi.A0\[Transpose].C2.P1.ν.P2==(Aπ/.T->(T^(-1)))∧(C2/.T->(T^(-1)))==Inverse[C2]],{K,AllKnots[{3,10}]}]

AlexanderMatrices[Knot[3,1]];
{lhs,rhs}=Simplify@{νi.A0\[Transpose].C2.P1.ν.P2, Aπ/.T->(T^(-1))};
MatrixForm/@{C2,C2.P1,P1.ν.P2,Inverse[P1.ν.P2],ν,lhs,rhs}
Det/@{lhs,rhs}
Simplify[lhs==rhs]

AlexanderMatrices[Knot[5,2]];
{lhs,rhs}=Simplify@{νi.A0\[Transpose].C2.P1.ν.P2, Aπ/.T->(T^(-1))};
MatrixForm/@{C2,Inverse[C2],ν, P1, P2, A0, Aπ}
Simplify[(C2/.T->(T^(-1)))==Inverse[C2]]
lhs==rhs