q-6j symbols for su(2)_k

E. Ardonne & J.K. Slingerland
Based on:
A.N.Kirillov, N.Y.Reshetikhin,
Representations of the algebra Uq (sl (2)), q - orthogonal polynomials and invariants of links,
in V.G. Kac, ed., Infinite dimensional Lie algebras and groups,
Proceedings of the conference held at CIRM, Luminy, Marseille, p.285,
World Scientific, Singapore (1988).

Display of q-6j symbols of su(2)_k

Manipulate[If[a>k2/2,a=k2/2];If[b>k2/2,b=k2/2];If[c>k2/2,c=k2/2];If[Not[MemberQ[dvalues[a,b,c,k2],d]],d=dvalues[a,b,c,k2][[1]]];If[Not[MemberQ[Prepend[Cases[Table[i,{i,1,(k2+2)/2}],x_/;GCD[x,k2+2]==1],0],p2]],p2=1];Column[{Row[{Style[Subsuperscript[F,d,{a,b,c}]],Text[" = "],Table[Chop[q6j[a,b,c,d,e,f,If[p2==0,1,Exp[2. p2 Pi I/(k2+2)]]]],{e,evalues[a,b,c,d,k2]},{f,fvalues[a,b,c,d,k2]}]//MatrixForm}],Row[{Text["e = "],evalues[a,b,c,d,k2]}],Row[{Text["f = "],fvalues[a,b,c,d,k2]}]}],{{k2,8,"k"},1,12,1,SetterBar},{{a,2},values[k2]},{{b,2},values[k2]},{{c,2},values[k2]},{{d,2},dvalues[a,b,c,k2]},{{p2,1,"q"},Table[j->Exp[2 j I Pi/(k2+2)],{j,Prepend[Cases[Table[i,{i,1,(k2+2)/2}],x_/;GCD[x,k2+2]==1],0]}]},ControlType->SetterBar,SaveDefinitions->True]

Initialization

qn[n_,q_]:=Sum[q^(((n+1)/2-i)),{i,1,n}]
qnf[n_,q_]:=Product[qn[i,q],{i,1,n}]
fusion[i_,j_,k_]:=Table[l,{l,Abs[i-j],Min[i+j,k-i-j]}]
delta[a_,b_,c_,q_]:=If[Abs[a-b]≤c≤a+b&&Mod[a+b+c,1]==0,Sqrt[qnf[a+b-c,q]qnf[a-b+c,q]qnf[-a+b+c,q]/qnf[a+b+c+1,q]],0]
qcg[a_,j_,b_,k_,c_,m_,q_]:=q^(((a+b-c)(a+b+c+1)+2(a k-b j))/4)delta[a,b,c,q]Sqrt[qnf[a-j,q]qnf[a+j,q]qnf[b-k,q]qnf[b+k,q]qnf[c-m,q]qnf[c+m,q]qn[2c+1,q]]Sum[(-1)^n q^(-n(a+b+c+1)/2)1/(qnf[n,q]qnf[a+b-c-n,q]qnf[a-j-n,q]qnf[b+k-n,q]qnf[c-b+j+n,q]qnf[c-a-k+n,q]),{n,Max[0,-(c-b+j),-(c-a-k)],Min[a+b-c,a-j,b+k]}]
qrw[i_,j_,l_,m_,k_,n_,q_]:=delta[i,j,k,q]delta[i,m,n,q]delta[j,l,n,q]delta[k,l,m,q]Sum[(-1)^z qnf[z+1,q]/(qnf[z-i-j-k,q]qnf[z-i-m-n,q]qnf[z-j-l-n,q]qnf[z-k-l-m,q]qnf[i+j+l+m-z,q]qnf[i+k+l+n-z,q]qnf[j+k+m+n-z,q]),{z,Max[i+j+k,i+m+n,j+l+n,k+l+m],Min[i+j+l+m,i+k+l+n,j+k+m+n]}]
q6j[i_,j_,l_,m_,k_,n_,q_]:=qrw[i,j,l,m,k,n,q]Sqrt[qn[2k+1,q]]Sqrt[qn[2n+1,q]]Exp[Pi I(i+j+l+m)]
values[k_]:=Table[i,{i,0,k/2,1/2}]
dvalues[a_,b_,c_,k_]:=Union[Flatten[Table[fusion[c,i,k],{i,fusion[a,b,k]}]]]
evalues[a_,b_,c_,d_,k_]:=Cases[fusion[a,b,k],x_/;MemberQ[fusion[x,c,k],d]]
fvalues[a_,b_,c_,d_,k_]:=Cases[fusion[b,c,k],x_/;MemberQ[fusion[a,x,k],d]]