<<Combinatorica`

Clear[Arc,JW,qI,R,a,b,c,d,e,f,g,h,i,j,k,l,m,n]
SetAttributes[Arc,Orderless]
Arc/:Arc[a_,b_]Arc[b_,c_]:=Arc[a,c]
Arc/:((Arc[a_,b_])^2):=-qI[2]
Rvrse[Arc]:=Arc
Rvrse[R]:=R
Arc[a_,a_]:=-qI[2]
qI[1]=1;
JW/:JW[1][a_,b_]:=Arc[a,b]
JW[n_][pp__]:=(JW[n]@@(z$/@Range[2 n]))/.{z$[i_]:>{pp}[[i]]}
JW[n_][pp__z$]:=JW[n][pp]=Module[{p={pp},b,i},Collect[Sum[b=Drop[p,{2 n-i,2 n-i+1}];(qI[i]/qI[n]) Expand[(JW[n-1]@@b) Arc[p[[2 n-i]],p[[2 n-i+1]]]],{i,1,n}],_P,Together]]
R/:R[a_,b_,c_,d_,e_,f_,g_,h_]R[h_,g_,f_,e_,d_,c_,b_,a_]:=qI[5];
R/:R[g_,h_,a_,b_,c_,d_,e_,f_]R[h_,g_,f_,e_,d_,c_,b_,a_]:=qI[5];
R/:R[e_,f_,g_,h_,a_,b_,c_,d_]R[h_,g_,f_,e_,d_,c_,b_,a_]:=qI[5];
R/:R[c_,d_,e_,f_,g_,h_,a_,b_]R[h_,g_,f_,e_,d_,c_,b_,a_]:=qI[5];
(* R/:R[a_,b_,c_,d_,e_,f_,g_,h_]R[h_,g_,f_,e_,i_,j_,k_,l_]:=JW[4][a,b,c,d,i,j,k,l]/; ; *)
R/:R[a_,a_,c_,d_,e_,f_,g_,h_]:=0;
R/:R[a_,b_,b_,d_,e_,f_,g_,h_]:=0;
R/:R[a_,b_,c_,c_,e_,f_,g_,h_]:=0;
R/:R[a_,b_,c_,d_,d_,f_,g_,h_]:=0;
R/:R[a_,b_,c_,d_,e_,e_,g_,h_]:=0;
R/:R[a_,b_,c_,d_,e_,f_,f_,h_]:=0;
R/:R[a_,b_,c_,d_,e_,f_,g_,g_]:=0;
R/:R[h_,b_,c_,d_,e_,f_,g_,h_]:=0;
Arc/:Arc[a_,b_] R[c___,a_,d___]:=R[c,b,d];

Table[R/:RotateLeft[R[a1_,a2_,a3_,a4_,a5_,a6_,a7_,a8_],2i] RotateLeft[R[a2_,a9_,a10_,a11_,a12_,a5_,a4_,a3_],2j] RotateLeft[R[a9_,a1_,a8_,a7_,a6_,a12_,a11_,a10_],2k]= (-1)^(i+j+k)I Sqrt[8(3+Sqrt[13])/3] ,{i,0,3},{j,0,3},{k,0,3}]
Table[R/:RotateLeft[R[a1_,a2_,a3_,a4_,a5_,a6_,a7_,a8_],2i] RotateLeft[R[a9_,a10_,a11_,a12_,a4_,a3_,a2_,a1_],2j] RotateLeft[R[a8_,a7_,a6_,a5_,a12_,a11_,a10_,a9_],2k]= 0 ,{i,0,3},{j,0,3},{k,0,3}]
Table[R/:RotateLeft[R[a1_,a2_,a3_,a4_,a5_,a6_,a7_,a8_],2i] RotateLeft[R[a9_,a10_,a11_,a12_,a4_,a3_,a2_,a1_],2j] RotateLeft[R[a9_,a13_,a14_,a15_,a16_,a12_,a11_,a10_],2k]RotateLeft[R[a13_,a1_,a8_,a7_,a6_,a16_,a15_,a14_],2l]= (-1)^(i+j+k)(17 + 3 Sqrt[13])/3 ,{i,0,3},{j,0,3},{k,0,3},{l,0,3}]

Clear[Involute,InnerProduct]
Involute[Times[S_,T_]]:=Times[Involute[S],Involute[T]];
Involute[S_]:=Rvrse[Head[S]]@@(Reverse[List@@(S)]);
Involute[S_Plus]:=Involute/@S
Involute[α_ S_]/;NumericQ[α/.qI[n_]:>n]:=α Involute[S]
InnerProduct[S_,T_]:=InnerProduct[S,T]=Expand[S*Involute[T]];

The annular consequences function, AC, takes three arguments:  a list of where caps begin, the element you want annular consequences of, and names of the incoming strings

capform[S_][a__]:=Module[{numcaps,numstrings,capend, hill,i,j,k},
numcaps=Length[S];
numstrings=Length[{a}];
hill[k_,0]:=1;
hill[k_,i_]:=If[MemberQ[S,Mod[k+i-1,numstrings]+1],hill[k,i-1]+1,hill[k,i-1]-1];
capend[k_]:=
Catch[
Do[
If[hill[k,j]==0,
Throw[Mod[k+j-1,numstrings]+1]
],
{j,numstrings}
]
];
Product[Arc[{a}[[S[[k]]]],{a}[[capend[  S[[k]]  ]   ]]   ],{k,numcaps}]]

AC[{},R_][a__]:=R[a];
AC[L_,R_][a__]:=Module[{looseends,tiedends,first},
tiedends=Flatten[(List@@capform[L][a])/.Arc[x_,y_]:>{x,y}];
looseends=Select[{a},MemberQ[tiedends,#]==False&];
first=
If[Length[looseends]>0,
Catch[
Do[
If[{a}[[i]]==looseends[[1]],
Throw[i]],{i,Length[{a}]}
]
],
-1
];
capform[L][a]*R@@
If[
EvenQ[first],
Append[Drop[looseends,1], looseends[[1]]] ,
looseends
]
]

capform[{1,3,5,7}][a,b,c,d,e,f,g,h]

AC[{},R][a,b,c,d,e,f,g,h]

AC[{3},R][a,b,c,d,e,f,g,h,i,j]

AC[{3,4},R][a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12]

AC[{8},R][a1,a2,a3,a4,a5,a6,a7,a8]

AC[{7,8},R][a1,a2,a3,a4,a5,a6,a7,a8]

AC[{2,3,8},R][a1,a2,a3,a4,a5,a6,a7,a8]

AC[{1},R][a1,a2,a3,a4,a5,a6,a7,a8,a9,a10]

AnnularConsequences[T_,n_,m_]:=(AC[#,T]@@Table[a[i],{i,1,m}])&/@KSubsets[Range[m],(m-n)/2]

AnnularConsequences[R,8,10]

AnnularConsequences[R,8,12]

ACInnerProductMatrix[T_,n_,m_]:=Outer[InnerProduct,AnnularConsequences[T,n,m],AnnularConsequences[T,n,m]]
(ACInnerProductMatrix[R,8,10])//MatrixForm

(ACInnerProductMatrix[R,8,12])//MatrixForm

FindCoefficients[vector_,basis_List,innerProduct_]:=Together[LinearSolve[Outer[innerProduct,basis,basis,1],innerProduct[vector,#]&/@basis]]

FindCoefficients[#,AnnularConsequences[R,8,10],InnerProduct]&/@AnnularConsequences[R,8,10]

TemperleyLieb[n_]/;n≥1:=TemperleyLieb[n]=
Union[AnnularConsequences[Arc,2,2n]]

TemperleyLieb[5]//Length

T=Outer[InnerProduct,TemperleyLieb[4]~Join~{R[a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]]},TemperleyLieb[4]~Join~{R[a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]]}]//MatrixForm

b=InnerProduct[R[x,a[2],a[3],a[4],a[5],w,z,y]R[a[1],x,y,z,w,a[6],a[7],a[8]],#]&/@TemperleyLieb[4]~Join~{R[a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]]}

FindCoefficients[R[x,a[2],a[3],a[4],a[5],w,z,y]R[a[1],x,y,z,w,a[6],a[7],a[8]],TemperleyLieb[4]~Join~{R[a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]]},InnerProduct]/.{qI[2]->-(5+(Sqrt[13]))/2,qI[5]-> 3+(Sqrt[13])}

b

LinearSolve[T,b]/.{qI[2]->-(5+(Sqrt[13]))/2,qI[5]-> 3+(Sqrt[13])}

FindCoefficients[R[a[1],a[2],a[3],a[4],a[5],z,y,x]R[x,y,z,a[6],a[7],a[8],a[9],a[10]],AnnularConsequences[R,8,10]~Join~{JW[5][a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],a[10]]},InnerProduct]

N[%]