# Uq(D21) programe Maple pour calcul du fonteur ribbon sur des # diagrammes élémentaires coloriés par l'analogue quantique de la # représentation adjointe. # # Les vecteurs de bases sont numérotés de 1 à 17. Chacun a un poids # appartenant à l'ensemble des racines. Un tenseur de L@n # est représenté par une liste de monomes. Chaque monome est un couple # formé d'un coefficient et de de la liste des vecteurs qui le # compose. # racine:=[[0,0,0], [0,0,0], [0,0,0], [0, 0, 2], [1, -1, 1], [1, 1, 1], [2, 0, 0], [1, -1, -1], [1, 1, -1], [0, 2, 0], [0, 0, -2], [-1,1,-1], [-1, -1, -1], [-2, 0, 0], [-1, 1, 1], [-1, -1, 1], [0, -2, 0]]; racine_set:={[0, 0, 2], [1, -1, 1], [1, 1, 1], [2, 0, 0], [1, -1, -1], [1, 1, -1], [0, 2, 0], [0, 0, -2], [-1,1,-1], [-1, -1, -1], [-2, 0, 0], [-1, 1, 1], [-1, -1, 1], [0, -2, 0]}; racine_set0:={[0,0,0], [0, 0, 2], [1, -1, 1], [1, 1, 1], [2, 0, 0], [1, -1, -1], [1, 1, -1], [0, 2, 0], [0, 0, -2], [-1,1,-1], [-1, -1, -1], [-2, 0, 0], [-1, 1, 1], [-1, -1, 1], [0, -2, 0]}; for i from 4 to 17 do vec[(racine[i])]:=i od: eval(vec): parite:=[0,0,0,0,1,1,0,1,1,0,0,1,1,0,1,1,0]; MJ:=matrix(17,17,0): for i to 17 do MJ[i,i]:=1-2*parite[i] od: for i to 3 do q[i]:=a[i]^2 od: a[1]:=1/a[2]/a[3]; #(*********************************************************************) #(*****************Procédures générales********************************) #(*********************************************************************) listorder:=proc(l,ll) local i,n; if l=ll then false else n:=nops(l); if n>nops(ll) then not(listorder(ll,l)) else for i to n while op(i,l)=op(i,ll) do od; if i=n+1 then true else evalb(op(i,l)0 then [k,op(2,x)] else NULL; fi end; simp:=proc(ll) local i,l,x; l:=array(1..nops(ll),sort(ll,sndlex)); for i to nops(ll)-1 do x:=l[i+1]; if op(2,l[i])=op(2,x) then l[i+1]:=[op(1,l[i])+op(1,x),op(2,x)]; l[i]:=[0,[]] fi od; map(vide,convert(l,list)); end; cl:=proc(ca,cb,la,lb) simp([op(scal(ca,la)),op(scal(cb,lb))]) end; EqM:=proc(M) convert(map(op,convert(evalm(M),listlist)),set) end; EqL:=proc(t) convert(map(y->y[1],t),set) end; ev:=proc(y) map(factor@eval,evalm(y)) end; ttrace:=eval(trace); with(linalg): cr:=proc(A,B) A&*B-B&*A end; qn:=proc(i,j) a[i]^j-1/a[i]^j end; for i to 3 do for j to 4 do Qn[i,j]:=qn(i,j) od od: #(*******************************************************************) #(******************Matrices de la représentation M******************) #(*******************************************************************) for i to 3 do M[i]:=linalg[diag](seq(a[i]^racine[j][i],j=1..17)); M[-i]:=linalg[inverse](M[i]) od; n:=8; M[n]:=matrix(17,17): assign({M[8][17,16] = p1*Qn[2,2]*a[2]^2, M[8][1,15] = 1/gamma*p1, M[8][7,6] = p1*Qn[1,2], M[8][5,4] = -Qn[3,2]*p1, M[8][8,2] = -p1*Qn[2,2], M[8][8,3] = -Qn[3,2]*p1, M[8][11,12] = Qn[3,2]*a[3]^2*p1, M[8][9,10] = -p1*Qn[2,2], M[8][13,14] = p1*Qn[1,2]*a[2]^2*a[3]^2}): for i to 17 do for j to 17 do if M[n][i,j]=evaln(M[n][i,j]) then M[n][i,j]:=0 fi od od: n:=15; M[n]:=matrix(17,17): assign({M[15][1,8] = phi/gamma, M[15][4,5] = 1, M[15][16,17] = 1/(a[2]^2), M[15][15,3] = Qn[3,2]*phi, M[15][12,11] = 1/(a[3]^2), M[15][10,9] = 1, M[15][6,7] = 1, M[15][14,13] = -1/(a[2]^2*a[3]^2), M[15][15,2] = Qn[2,2]*phi}): for i to 17 do for j to 17 do if M[n][i,j]=evaln(M[n][i,j]) then M[n][i,j]:=0 fi od od: n:=4; M[n]:=matrix(17,17): assign({M[4][5,8] = 1, M[4][15,12] = -1, M[4][16,13] = -1, M[4][4,3] = Qn[3,4]/Qn[3,2], M[4][3,11] = -1/(phi*Qn[3,2]*a[3]^2), M[4][4,1] = gamma/phi, M[4][6,9] = 1}): for i to 17 do for j to 17 do if M[n][i,j]=evaln(M[n][i,j]) then M[n][i,j]:=0 fi od od: n:=11; M[n]:=matrix(17,17): assign({M[11][11,1] = -Qn[3,2]*a[3]^2*gamma, M[11][13,16] = -1, M[11][8,5] = 1, M[11][12,15] = -1, M[11][9,6] = 1, M[11][11,3] = -a[3]^2*Qn[3,4]*phi, M[11][3,4] = 1} ): for i to 17 do for j to 17 do if M[n][i,j]=evaln(M[n][i,j]) then M[n][i,j]:=0 fi od od: n:=10; M[n]:=matrix(17,17): assign({M[10][15,16] = -1, M[10][10,1] = gamma/phi, M[10][10,2] = Qn[2,4]/Qn[2,2], M[10][12,13] = -1, M[10][2,17] = -1/(phi*Qn[2,2]*a[2]^2), M[10][6,5] = 1, M[10][9,8] = 1}): for i to 17 do for j to 17 do if M[n][i,j]=evaln(M[n][i,j]) then M[n][i,j]:=0 fi od od: n:=17; M[n]:=matrix(17,17): assign({M[17][2,10] = 1, M[17][17,1] = -gamma*Qn[2,2]*a[2]^2, M[17][17,2] = -a[2]^2*Qn[2,4]*phi, M[17][16,15] = -1, M[17][13,12] = -1, M[17][5,6] = 1, M[17][8,9] = 1}): for i to 17 do for j to 17 do if M[n][i,j]=evaln(M[n][i,j]) then M[n][i,j]:=0 fi od od: M[5]:=ev(M[8]&*M[4]-1/a[3]^2*M[4]&*M[8]): M[9]:=ev(M[10]&*M[8]-1/a[2]^2*M[8]&*M[10]): M[6]:=ev(M[10]&*M[5]-1/a[2]^2*M[5]&*M[10]): M[7]:=ev(M[8]&*M[6]+a[1]^2*M[6]&*M[8]): M[12]:=ev(M[15]&*M[11]-1/a[3]^2*M[11]&*M[15]): M[16]:=ev(M[17]&*M[15]-1/a[2]^2*M[15]&*M[17]): M[13]:=ev(M[17]&*M[12]-1/a[2]^2*M[12]&*M[17]): M[14]:=ev(M[15]&*M[13]+a[1]^2*M[13]&*M[15]): for i to 17 do tM[i]:=ev(linalg[transpose](M[i])) od: rel:=map(factor,[ EqM(M[8]&*M[8]), EqM(M[15]&*M[15]), EqM(cr(M[4],M[17])), EqM(cr(M[4],M[15])), EqM(cr(M[11],M[10])), EqM(cr(M[11],M[8])), EqM(cr(M[15],M[10])), EqM(cr(M[17],M[8])), EqM(cr(M[4],M[10])), EqM(cr(M[11],M[17])), EqM(M[8]&*M[15]+M[15]&*M[8]- (M[1]&*M[-2]&*M[-3]-M[-1]&*M[2]&*M[3]) *p1), EqM(cr(M[4],M[11])-(M[3]^2-M[-3]^2)/(a[3]^2-1/a[3]^2)), EqM(cr(M[10],M[17])-(M[2]^2-M[-2]^2)/(a[2]^2-1/a[2]^2)), EqM(M[4]&*M[4]&*M[8]-(a[3]^2+1/a[3]^2)*M[4]&*M[8]&*M[4]+M[8]&*M[4]&*M[4]), EqM(M[11]&*M[11]&*M[15] -(a[3]^2+1/a[3]^2)*M[11]&*M[15]&*M[11] +M[15]&*M[11]&*M[11]), EqM(M[10]&*M[10]&*M[8] -(a[2]^2+1/a[2]^2)*M[10]&*M[8]&*M[10]+M[8]&*M[10]&*M[10]), EqM(M[17]&*M[17]&*M[15] -(a[2]^2+1/a[2]^2)*M[17]&*M[15]&*M[17]+M[15]&*M[17]&*M[17])]); #(*******************************************************************) #(********************** Calcul de la R-matrice**********************) #(*******************************************************************) #poids de L@L weight:=NULL: for i to 17 do for j to 17 do weight:=weight,convert(ev(racine[i]+racine[j]),list) od od: weight:={weight}; nops(weight); #terme de contribution non nulle dans M(R) Rterme:=NULL: for i1 from 0 to 2 do for i2 from 0 to 1 do for i3 from 0 to 1 do for i4 from 0 to 2 do for i5 from 0 to 1 do for i6 from 0 to 1 do for i7 from 0 to 2 do if member(convert(ev(i1*racine[4]+i2*racine[5] +i3*racine[6]+i4*racine[7] +i5*racine[8]+i6*racine[9] +i7*racine[10]),list),weight) then Rterme:=Rterme,[i1,i2,i3,i4,i5,i6,i7] fi od od od od od od od: Rterme:=[Rterme]; nRterme:=nops(Rterme); f:=proc(l) local ll,i,j; ll:=NULL; for i to 7 do for j to l[i] do ll:=ll,i+3 od od: [ll] end; Rterm:= map(f,Rterme); #Rterm:liste des monomes en les vecteurs de racines de UqD21 contribuant fw:=proc(l) local w,i; w:=[0,0,0]; for i to 7 do w:=ev(w+l[i]*racine[i+3]) od: convert(w,list) end; Rw:=map(fw,Rterme); #Rw: R= sum X@Y avec weight(X)=-weight(Y)=Rw[i] Rcontrib:=proc(i,j) local k,l; l:=NULL; for k to nRterme do if member(convert(ev(racine[i]+Rw[k]),list),racine_set0) and member(convert(ev(racine[j]-Rw[k]),list),racine_set0) then l:=l,k fi od: [l] end; #renvoie les monomes de Rterm contribuant à R(v_i@v_j) epsilon:=p1*a[2]^2*a[3]^2/((a[2]^4+1)*(a[3]^4+1)); Rcoef:=table([ (1, 6) = -a[2]^4*a[3]^2/(epsilon*(a[3]^4+1)*(a[2]^4+1)), (1, 1) = -(a[3]^2+1)*(a[3]+1)*(a[3]-1)/(a[3]^2), (1, 7) = -(a[2]^2+1)*(a[2]+1)*(a[2]-1)/(a[2]^2), (1, 2) = -a[3]^4*a[2]^2/((a[3]^4+1)*(a[2]^4+1)*epsilon), (2, 1) = (a[3]-1)^2*(a[3]+1)^2*(a[3]^2+1)^2/(a[3]^4*(a[3]^4+1)), (1, 3) = a[3]^4*a[2]^4/((a[3]^4+1)*(a[2]^4+1)*epsilon), (1, 4) = -a[3]^10*a[2]^10/((a[3]^4+1)^2*(a[2]^4+1)^2*epsilon^2* (a[2]^2*a[3]^2+1)*(a[2]*a[3]+1) *(a[2]*a[3]-1)), (2, 7) = (a[2]^2+1)^2*(a[2]+1)^2*(a[2]-1)^2/(a[2]^4*(a[2]^4+1)), (1, 5) = a[2]^2*a[3]^2/(epsilon*(a[3]^4+1)*(a[2]^4+1)), (2, 4) = a[2]^24*a[3]^24/(epsilon^4*(a[3]^4+1)^4*(a[2]^4+1)^4* (a[2]^4*a[3]^4+1)*(a[2]^2*a[3]^2+1)^2 *(a[2]*a[3]+1)^2*(a[2]*a[3]-1)^2)]); Coefmo:=proc(t) local i,r,c; c:=1; r:=Rterme[t]; for i to 7 do if r[i]>0 then c:=c*Rcoef[r[i],i] fi od: (-1)^(r[2]*r[3]+r[2]*r[5]+r[2]*r[6]+r[3]*r[5]+r[3]*r[6]+r[5]*r[6])*c end; # coeffs des monomes dans l'expression de la R-matrice universelle f:=proc(l) (-1)^(l[2]+l[6]+l[3]+l[5]) end; Rtpar:=map(f,Rterme): #Rtpar: R= sum X@Y avec parité(X)=parité(Y)=Rtpar[i] Rmm:=proc(i,j) local ri, rj, s, eij, rc, t, mo, p, k; ri:=racine[i]; rj:=racine[j]; s:=matrix(17,17,0); eij:=matrix(17,17,0); eij[i,j]:=1; rc:=Rcontrib(i,j); for t in rc do mo:=Rterm[t]; p:=evalm(Coefmo(t)*eij); for k to nops(mo) do p:=ev(M[mo[-k]]&*p&*tM[7+mo[-k]]) od: if parite[i]=0 then s:=evalm(s+p) else s:=evalm(s+Rtpar[t]*p) fi; od; s:=ev(a[1]^(-(ri[1]*rj[1]))*a[2]^(-(ri[2]*rj[2]))*a[3]^(-(ri[3]*rj[3]))*s); ev(s) end; parite_mat:=matrix(17,17,1): parite_mat:=ev(parite_mat-2*parite&*linalg[transpose](parite)); Br_0:=proc(ii,jj) local m,i,j; m:=Rmm(ii,jj); simp([seq(seq([parite_mat[i,j]*m[i,j],[j,i]],i=1..17),j=1..17)]) end; #Calcul du tressage. Le calcul est long. Brp:=matrix(17,17,0): for i to 17 do print(i); for j to 17 do Brp[i,j]:=Br_0(i,j) od od: nops(map(op,map(op,convert(Brp,listlist)))); # nombre de termes non nuls dans la R-matrices : 1050 save(M,tM,Brp,"UqD21-1.m"); # Sauvegarde du résultat #(*******************************************************************) #(********************Opérateur de Tressage**************************) #(*******************************************************************) read "UqD21-1.m"; BRp_0:=proc(t,i) local ta,tp; tp:=op(2,t); ta:=[op(1..(i-1),tp)]; tp:=[op((i+2)..nops(tp),tp)]; op(scal(op(1,t), map(proc(ti,ta,tp) [op(1,ti),[op(ta),op(op(2,ti)),op(tp)]] end, Brp[op(i,op(2,t)),op(i+1,op(2,t))],ta,tp))) end; # Le calcul de l'inverse Brn de Brp sera fait plus tard BRn_0:=proc(t,i) local ta,tp; tp:=op(2,t); ta:=[op(1..(i-1),tp)]; tp:=[op((i+2)..nops(tp),tp)]; op(scal(op(1,t), map(proc(ti,ta,tp) [op(1,ti),[op(ta),op(op(2,ti)),op(tp)]] end, Brn[op(i,op(2,t)),op(i+1,op(2,t))],ta,tp))) end; Braid:=proc(i,t) if i>0 then simp(map(BRp_0,t,i)) else simp(map(BRn_0,t,-i)) fi end; # Morphisme de tressage Id_L^(i-1)@c_{L,L}@Id_L^? Si i<0 c'est # l'inverse du tressage parite_mat:=matrix(17,17,1): parite_mat:=ev(parite_mat-2*parite&*linalg[transpose](parite)); Swap0:=proc(t,i) local k1,k2,t2; t2:=op(2,t); k1:=op(i,t2); k2:=op(i+1,t2); [parite_mat[k1,k2]*op(1,t),subsop(i=k2,i+1=k1,t2)] end; Swap:=proc(i,t) sort(map(Swap0,t,i),sndlex) end; # La volte "super" #(************Vérification de la relation des tresses***************) # for i to 17 do # for j to 17 do # if (j=9) or (j=1) then print(i,j) fi; # for k to 17 do l:=[i,j,k]; # Braid(1,Braid(2,Braid(1,[[1,l]]))); # Braid(2,Braid(1,Braid(2,[[1,l]]))); # if nops(map(factor,EqL(cl(1,-1,%,%%))))>0 then print(i,j,k) fi; # od od od: #(*******************************************************************) #(************Recherche de la forme bilin invariante*****************) #(*******************************************************************) # B:=matrix(17,17): B[8,15]:=beta: # Bx:=proc() local l,i,j; l:=NULL; # for i to 17 do for j to 17 do # if B[i,j]=evaln(B[i,j]) then l:=l,B[i,j] fi # od # od; {l} end; # for i to 3 do Eq[i]:=EqM(M[i]&*B&*M[i]-B) od: # solve(Eq[1] union Eq[2] union Eq[3] , Bx()); # assign(%); # Eq[4]:=EqM(tM[4]&*B+M[3]^2&*B&*M[4]): # Eq[11]:=EqM(tM[11]&*B&*M[-3]^2+B&*M[11]): # Eq[10]:=EqM(tM[10]&*B+M[2]^2&*B&*M[10]): # Eq[17]:=EqM(tM[17]&*B&*M[-2]^2+B&*M[17]): # solve(Eq[4] union Eq[11] union Eq[10] union Eq[17] , Bx()); # assign(%); # M[18]:=ev(M[1]&*M[-2]&*M[-3]): # M[-18]:=ev(M[-1]&*M[2]&*M[3]): # Eq[8]:=EqM(tM[8]&*B+M[18]&*MJ&*B&*M[8]): # Eq[15]:=EqM(tM[15]&*B&*M[-18]+MJ&*B&*M[15]): # solve(Eq[8] union Eq[15] , Bx()); # assign(%); bilin:=matrix([ [0, beta*(a[2]-1)*(a[2]+1)*(a[2]^2+1)/a[2]^2*gamma, beta*(a[3]-1)*(a[3]+1)*(a[3]^2+1)*gamma/a[3]^2,0,0,0,0, 0,0,0,0,0,0,0,0,0,0], [beta*(a[2]-1)*(a[2]+1)*(a[2]^2+1)/a[2]^2*gamma, beta*(a[2]-1)*(a[2]+1)*(a[2]^2+1)*(a[2]^4+1)*phi/a[2]^4, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], [beta*(a[3]-1)*(a[3]+1)*(a[3]^2+1)*gamma/a[3]^2,0, beta*(a[3]^4+1)*(a[3]-1)*(a[3]+1)*(a[3]^2+1)*phi/a[3]^4, 0,0,0,0,0,0,0,0,0,0,0,0,0,0], [0,0,0,0,0,0,0,0,0,0,beta/a[3]^2,0,0,0,0,0,0], [0,0,0,0,0,0,0,0,0,0,0,beta/a[3]^2,0,0,0,0,0], [0,0,0,0,0,0,0,0,0,0,0,0,beta/a[2]^2/a[3]^2,0,0,0,0], [0,0,0,0,0,0,0,0,0,0,0,0,0,beta/a[2]^2/a[3]^2,0,0,0], [0,0,0,0,0,0,0,0,0,0,0,0,0,0,beta,0,0], [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,beta/a[2]^2,0], [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,beta/a[2]^2], [0,0,0,beta*a[3]^2,0,0,0,0,0,0,0,0,0,0,0,0,0], [0,0,0,0,-beta*a[3]^2,0,0,0,0,0,0,0,0,0,0,0,0], [0,0,0,0,0,-beta*a[2]^2*a[3]^2,0,0,0,0,0,0,0,0,0,0,0], [0,0,0,0,0,0,beta*a[2]^2*a[3]^2,0,0,0,0,0,0,0,0,0,0], [0,0,0,0,0,0,0,-beta,0,0,0,0,0,0,0,0,0], [0,0,0,0,0,0,0,0,-beta*a[2]^2,0,0,0,0,0,0,0,0], [0,0,0,0,0,0,0,0,0,beta*a[2]^2,0,0,0,0,0,0,0]]); Bil0:=proc(t,i) local ta,tp; tp:=op(2,t); if bilin[tp[i],tp[i+1]]=0 then NULL else [t[1]*bilin[tp[i],tp[i+1]],subsop(i+1=NULL,i=NULL,tp)] fi end; Bil:=proc(i,t) simp(map(Bil0,t,i)) end; # Morphisme d'evaluation Id_L^(i-1) @ <.,.> @ Id_L^? Tens:=proc(l1,l2) simp(map(op, map(proc(m1,l2) (map(proc(m2,m1) [op(1,m1)*op(1,m2), [op(op(2,m1)),op(op(2,m2))]] end,l2,m1)) end,l1,l2))) end; # Produit tensoriel #(*******************************************************************) #(************Recherche de la Coevaluation Omega \in L@L*************) #(*******************************************************************) # Omega:=[seq(seq([o[i,j],[i,j]],j=1..3),i=1..3), # seq([o[i],[i,i+7]],i=4..10),seq([o[7+i],[i+7,i]],i=4..10)]; # Eq:={}: # for i to 17 do # Eq:=Eq union EqL(cl(1,-1,Bil(1,Tens([[1,[i]]],Omega)),[[1,[i]]])) od: # solve(Eq,{seq(seq(o[i,j],j=1..3),i=1..3),seq(o[i],i=4..17)}); Omega:=[[1/2*Qn[3,4]*phi*Qn[2,4]/Qn[3,2]/Qn[2,2]/gamma^2/beta/Qn[1,2], [1, 1]], [-1/2*Qn[3,4]/Qn[3,2]/gamma/beta/Qn[1,2], [1, 2]], [-1/2*Qn[2,4]/Qn[2,2]/gamma/beta/Qn[1,2], [1, 3]], [-1/2*Qn[3,4]/Qn[3,2]/gamma/beta/Qn[1,2], [2, 1]], [-1/2*Qn[3,2]/beta/phi/Qn[1,2]/Qn[2,2], [2, 2]], [1/2*1/(Qn[1,2]*beta*phi), [2, 3]], [-1/2*Qn[2,4]/Qn[2,2]/gamma/beta/Qn[1,2], [3, 1]], [1/2*1/(Qn[1,2]*beta*phi), [3, 2]], [-1/2*Qn[2,2]/beta/phi/Qn[1,2]/Qn[3,2], [3, 3]], [1/(beta*a[3]^2), [4, 11]], [-1/(beta*a[3]^2), [5, 12]], [-1/(beta*a[2]^2*a[3]^2), [6, 13]], [1/(beta*a[2]^2*a[3]^2), [7, 14]], [-1/beta, [8, 15]], [-1/(beta*a[2]^2), [9, 16]], [1/(beta*a[2]^2), [10, 17]], [a[3]^2/beta, [11, 4]], [a[3]^2/beta, [12, 5]], [a[2]^2*a[3]^2/beta, [13, 6]], [a[2]^2*a[3]^2/beta, [14, 7]], [1/beta, [15, 8]], [a[2]^2/beta, [16, 9]], [a[2]^2/beta, [17, 10]]]; Brn:=matrix(17,17,0): for i to 17 do print(i); for j to 17 do Brn[i,j]:=factor(Bil(3,Braid(2,Tens(Omega,[[1,[i,j]]])))) od od: #(*******************************************************************) #(*********Recherche d'un vecteur de plus haut poids [2,0,0]*********) #(*******************************************************************) # hv:=NULL: y:='y'; # inco:=0; X:=proc() global inco; inco:=inco+1; y[inco] end; # for i to 17 do # for j to 17 do # if (convert(ev(racine[i]+racine[j]),list)=[2,0,0]) # then hv:=hv,[X(),[i,j]] fi od od: # hv:=[hv]; # Mhv:=matrix(17,17,0): # for m in hv do Mhv[op(m[2])]:=m[1] od: # Eq:='Eq'; y[9]:=-2*delta; # Eq[4]:=EqM(M[4]&*Mhv+M[3]^2&*Mhv&*tM[4]): # Eq[10]:=EqM(M[10]&*Mhv+M[2]^2&*Mhv&*tM[10]): # Eq[8]:=EqM(M[8]&*Mhv+M[18]&*MJ&*Mhv&*tM[8]): # solve(Eq[4] union Eq[10] union Eq[8], {seq(y[i],i=1..8),y[10]}); # assign(%); hv:=[[phi*delta*(a[2]^4*a[3]^4+a[3]^4+a[2]^4+1)/gamma/a[2]^2/a[3]^2, [1, 7]], [-(a[3]^4+1)*delta/a[3]^2, [2, 7]], [-(a[2]^4+1)*delta/a[2]^2, [3, 7]], [2*delta/a[3]^2, [5, 9]], [-2/a[2]^2/a[3]^2*delta, [6, 8]], [-phi*delta*(a[2]^4*a[3]^4+a[3]^4+a[2]^4+1)/gamma/a[2]^2/a[3]^2, [7, 1]], [(a[3]^4+1)*delta/a[3]^2, [7, 2]], [(a[2]^4+1)*delta/a[2]^2, [7, 3]], [-2*delta, [8, 6]], [2*delta/a[2]^2, [9, 5]]]: #(*******************************************************************) #(*********Calcul du morphisme cocr : L->L@L ************************) #(*******************************************************************) CoM[7]:=matrix(17,17,0): for m in hv do CoM[7][op(m[2])]:=m[1] od: CoM[6]:=ev((M[15]&*CoM[7]&*M[-18]+MJ&*CoM[7]&*tM[15])/tM[15][7,6]): CoM[9]:=ev((M[11]&*CoM[6]&*M[-3]^2+CoM[6]&*tM[11])/tM[11][6,9]): CoM[5]:=ev((M[17]&*CoM[6]&*M[-2]^2+CoM[6]&*tM[17])/tM[17][6,5]): CoM[8]:=ev((M[17]&*CoM[9]&*M[-2]^2+CoM[9]&*tM[17])/tM[17][9,8]): CoM[10]:=ev((M[15]&*CoM[9]&*M[-18]+MJ&*CoM[9]&*tM[15])/tM[15][9,10]): CoM[4]:=ev((M[15]&*CoM[5]&*M[-18]+MJ&*CoM[5]&*tM[15])/tM[15][5,4]): CoM[1]:=ev((M[15]&*CoM[8]&*M[-18]+MJ&*CoM[8]&*tM[15])/tM[15][8,1]): CoM[11]:=ev((M[11]&*CoM[1]&*M[-3]^2+CoM[1]&*tM[11])/tM[11][1,11]): CoM[17]:=ev((M[17]&*CoM[1]&*M[-2]^2+CoM[1]&*tM[17])/tM[17][1,17]): CoM[3]:=ev((M[11]&*CoM[4]&*M[-3]^2+CoM[4]&*tM[11])/tM[11][4,3]): CoM[2]:=ev((M[17]&*CoM[10]&*M[-2]^2+CoM[10]&*tM[17])/tM[17][10,2]): CoM[15]:=ev((M[15]&*CoM[2]&*M[-18]+MJ&*CoM[2]&*tM[15])/tM[15][2,15]): CoM[16]:=ev((M[17]&*CoM[15]&*M[-2]^2+CoM[15]&*tM[17])/tM[17][15,16]): CoM[12]:=ev((M[11]&*CoM[15]&*M[-3]^2+CoM[15]&*tM[11])/tM[11][15,12]): CoM[13]:=ev((M[17]&*CoM[12]&*M[-2]^2+CoM[12]&*tM[17])/tM[17][12,13]): CoM[14]:=ev((M[15]&*CoM[13]&*M[-18]+MJ&*CoM[13]&*tM[15])/tM[15][13,14]): cocr:=vector(17,0): for k to 17 do cocr[k]:=simp([seq(seq([CoM[k][i,j],[i,j]],j=1..17),i=1..17)]) od: Cocr0:=proc(t,i) local ta,tp; tp:=op(2,t); ta:=[op(1..(i-1),tp)]; tp:=[op((i+1)..nops(tp),tp)]; op(scal(op(1,t), map(proc(ti,ta,tp) [op(1,ti),[op(ta),op(op(2,ti)),op(tp)]] end, cocr[op(i,op(2,t))],ta,tp))) end; Cocr:=proc(i,t) simp(map(Cocr0,t,i)) end; # Morphisme Id_L^(i-1) @ cocr @ Id_L^? #(*******************************************************************) #(*********Calcul du morphisme crochet : L@L->L *********************) #(*******************************************************************) crochet:=matrix(17,17,0): for i to 17 do for j to 17 do crochet[i,j]:=Bil(1,Tens([[1,[i]]],cocr[j])) od od: Cr0:=proc(t,i) local ta,tp; tp:=op(2,t); ta:=[op(1..(i-1),tp)]; tp:=[op((i+2)..nops(tp),tp)]; op(scal(op(1,t), map(proc(ti,ta,tp) [op(1,ti),[op(ta),op(op(2,ti)),op(tp)]] end, crochet[op(i,op(2,t)),op(i+1,op(2,t))],ta,tp))) end; Cr:=proc(i,t) simp(map(Cr0,t,i)) end; # Morphisme Id_L^(i-1) @ crochet @ Id_L^? save(racine, parite, parite_mat, listorder, sndlex, scal, simp, vide, cl, EqL, EqM, ev, ttrace, qn, M, tM, Brp, Brn, BRp_0, BRn_0, Braid, Swap0, Swap, bilin, Bil0, Bil, Tens, Omega, cocr, Cocr0, Cocr, crochet, Cr, Cr0, "UqD21-2.m"); #(*******************************************************************) #(*******************************************************************) #(*******************************************************************) # Fin des calculs des morphismes de structure #(*******************************************************************) #(*******************************************************************) #(*******************************************************************) read("UqD21-2.m"); # Pour fixer les paramètres : phi:=-Phi/2/beta/delta^2; a[1]:=1/a[2]/a[3]; mono:=proc(i) [[1,[i]]] end; with(linalg): quant:=proc(x) local y; y:=factor(x); y:=factor(subs((a[2]^4*a[3]^4+1)=(a[2]^4*a[3]^4+1)*Q[1,4]/qn(1,4),y)); y:=factor(subs((a[2]^4+1)=(a[2]^4+1)*Q[2,4]/qn(2,4),y)); y:=factor(subs((a[3]^4+1)=(a[3]^4+1)*Q[3,4]/qn(3,4),y)); y:=factor(subs((a[2]^2*a[3]^2+1)=(a[2]^2*a[3]^2+1)*Q[1,2]/qn(1,2),y)); y:=factor(subs((a[2]^2+1)=(a[2]^2+1)*Q[2,2]/qn(2,2),y)); y:=factor(subs((a[3]^2+1)=(a[3]^2+1)*Q[3,2]/qn(3,2),y)); y:=factor(subs((a[2]*a[3]+1)=(a[2]*a[3]+1)*Q[1,1]/qn(1,1),y)); y:=factor(subs((a[2]+1)=(a[2]+1)*Q[2,1]/qn(2,1),y)); y:=factor(subs((a[3]+1)=(a[3]+1)*Q[3,1]/qn(3,1),y)); y end; unprotect(Psi); Psi:=proc(t) Bil(2,Cocr(1,Cocr(2,t))) end; mono:=proc(i) [[1,[i]]] end; rap:=proc(l,ll) local c; global Er; c:=factor(op([1,1],l)/op([1,1],ll)); Er:=cl(1,-c,l,ll); print(Er); c end; # pour comparer deux tenseurs #(*******************************************************************) #(***********************Relations skein*****************************) #(*******************************************************************) rap(Braid(1,Omega),Omega); #-> 1 W:=Cocr(1,Omega): rap(Braid(1,W),W); #-> -1 Cr(1,W); #-> [] O2:=Tens(Omega,Omega): TangBp:=Braid(2,O2): TangBm:=Braid(-2,O2): TangI:=Cocr(2,Cr(2,O2)): TangH:=Cr(2,Cocr(3,O2)): TangXp:=Cr(2,Cocr(3,TangBp)): TangXm:=Cr(2,Cocr(3,TangBm)): rap(cl(1,-1,TangBp,TangBm), cl(1,1/2,cl(1,-1,TangH,TangI), cl(1,1,TangXp,TangXm))); quant(%); # quantum IHX relation #-> -2*a[2]^4*a[3]^4/Phi/(a[3]^4+1)/(a[2]^4+1)/(a[2]^4*a[3]^4+1)= # -2*Q[1,2]*Q[2,2]*Q[3,2]/Q[1,4]/Q[2,4]/Q[3,4]/Phi rap(Cr(2,TangH),W); quant(%); #-> -Q[1,2]*Q[2,2]*Q[3,2]*Phi rap(Cr(1,Braid(2,TangBp)),W); quant(%); #-> 2*Q[1,2]*Q[2,2]*Q[3,2]