matrix* Weyl_orbit(entry* v, matrix** orbit_graph)
{ lie_Index i,j,k,r=Lierank(grp),s=Ssrank(grp);
matrix* result; entry** m;
lie_Index level_start=0, level_end=1, cur=1;
{ entry* lambda=mkintarray(r);
copyrow(v,lambda,r); make_dominant(lambda);
result=mkmatrix(bigint2entry(Orbitsize(lambda)),r);
copyrow(lambda,result->elm[0],r); freearr(lambda);
if (orbit_graph!=NULL) *orbit_graph=mkmatrix(result->nrows,s);
}
m=result->elm;
while (level_start<level_end)
{
for (k=level_start; k<level_end; ++k)
for (i=0; i<s; ++i)
if (m[k][i]>0) /* only strictly cross walls, and from dominant side */
{ w_refl(m[k],i);
for (j=level_end; j<cur; ++j)
if (eqrow(m[k],m[j],s)) break;
if (orbit_graph!=NULL)
{ (*orbit_graph)->elm[k][i]=j; (*orbit_graph)->elm[j][i]=k; }
if (j==cur)
{ assert(cur<result->nrows);
copyrow(m[k],m[cur++],r);
}
w_refl(m[k],i);
}
else if (m[k][i]==0 && orbit_graph!=NULL) (*orbit_graph)->elm[k][i]=k;
level_start=level_end; level_end=cur;
}
return result;
}
matrix* Weyl_rt_mat(vector* word)
{ lie_Index i,j,r=Ssrank(grp); matrix* res=mkmatrix(r,r); entry** m=res->elm;
for (i=0; i<r; ++i)
{ for (j=0; j<r; ++j) m[i][j]= i==j;
Wrtaction(m[i],word);
}
return res;
}
bigint* Orbitsize(entry* w)
{ lie_Index i,d,s=Ssrank(grp); entry* x=mkintarray(s),* y=x; bigint* result=one;
copyrow(w,x,s); make_dominant(x);
if (type_of(grp)==SIMPGRP) return simp_worbitsize(x,&grp->s);
for (i=0; i<grp->g.ncomp; ++i,y+=d)
{ simpgrp* g=Liecomp(grp,i); d=g->lierank;
result=mult(result,simp_worbitsize(y,g));
}
freearr(x); return result;
}
bigint* sub_Worder(vector* v)
{ lie_Index i,j,s=Ssrank(grp), n=v->ncomp; matrix* roots=mkmatrix(n,s);
entry** m=roots->elm; group* h; bigint* result;
if (n==0) { freemem(roots); return one; }
for (i=0; i<n; ++i) /* select rows od an identity matrix */
{ entry* mij= *m++,vi=v->compon[i]-1;
for (j=0; j<s; ++j) *(mij++)= (j==vi);
}
h=Carttype(roots); freemem(roots);
result= Worder((object)h); freemem(h); return(result);
}
matrix* Resmat(matrix* roots)
{ lie_Index i,j,k,r=Lierank(grp),s=Ssrank(grp), n=roots->nrows;
vector* root_norms=Simproot_norms(grp);
entry* norms=root_norms->compon;
/* needed to compute $\<\lambda,\alpha[i]>$ */
matrix* root_images=Matmult(roots,Cartan()),* result=mkmatrix(r,r);
entry** alpha=roots->elm,** img=root_images->elm,** res=result->elm;
for (i=0; i<r; i++) for (j=0; j<r; j++) res[i][j]= i==j;
/* initialise |res| to identity */
for (j=0; j<n; j++) /* traverse the given roots */
{ entry* v=img[j], norm=(checkroot(alpha[j]),Norm(alpha[j]));
for (k=s-1; v[k]==0; k--) {}
if (k<j)
error("Given set of roots is not independent; apply closure first.\n");
if (v[k]<0)
{ for (i=j; i<n; i++) img[i][k]= -img[i][k];
for (i=k-j; i<s; i++) res[i][k]= -res[i][k];
}
while(--k>=j)
/* clear |v[k+1]| by unimodular column operations with column~|j| */
{
entry u[3][2]; lie_Index l=0;
u[0][1]=u[1][0]=1; u[0][0]=u[1][1]=0;
u[2][1]=v[k]; u[2][0]=v[k+1];
if (v[k]<0) u[2][1]= -v[k], u[0][1]= -1; /* make |u[2][1]| non-negative */
do /* subtract column |l| some times into column |1-l| */
{ entry q=u[2][1-l]/u[2][l]; for (i=0; i<3; i++) u[i][1-l]-=q*u[i][l];
} while (u[2][l=1-l]!=0);
if (l==0) for (i=0; i<2; i++) swap(&u[i][0],&u[i][1]);
{ for (i=j; i<n; i++) /* combine columns |k| and |k+1| */
{ entry img_i_k=img[i][k];
img[i][k] =img_i_k*u[0][0]+img[i][k+1]*u[1][0];
img[i][k+1]=img_i_k*u[0][1]+img[i][k+1]*u[1][1];
}
for (i=k-j; i<s; i++)
{ entry res_i_k=res[i][k];
res[i][k]=res_i_k*u[0][0]+res[i][k+1]*u[1][0];
res[i][k+1]=res_i_k*u[0][1]+res[i][k+1]*u[1][1];
}
}
}
for (i=0; i<s; i++)
{ lie_Index inpr= norms[i]*alpha[j][i]; /* this is $(\omega_i,\alpha[j])$ */
if (inpr%norm!=0) error("Supposed root has non-integer Cartan product.\n");
res[i][j]=inpr/norm; /* this is $\<\omega_i,\alpha[j]>$ */
}
}
freemem(root_norms); freemem(root_images); return result;
}
matrix* Weyl_root_orbit(entry* v)
{ lie_Index i,j,r=Lierank(grp),s=Ssrank(grp);
entry* x=mkintarray(r); matrix* orbit, *result; entry** m;
lie_Index dc=Detcartan();
mulvecmatelm(v,Cartan()->elm,x,s,r);
orbit=Weyl_orbit(x,NULL);
result=mkmatrix(orbit->nrows,s); m=result->elm;
mulmatmatelm(orbit->elm,Icartan()->elm,m,orbit->nrows,s,s);
freemem(orbit);
for (i=0; i<result->nrows; ++i)
for (j=0; j<s; ++j) m[i][j]/=dc;
return result;
}
vector* Simproot_norms(object grp)
{ if (type_of(grp)==SIMPGRP)
{ simp_proots(&grp->s); return grp->s.root_norm; }
{ _index i; for (i=0; i<grp->g.ncomp; ++i) simp_proots(Liecomp(grp,i)); }
if (grp->g.ncomp==1) return Liecomp(grp,0)->root_norm;
{ _index i,t=0; vector* result=mkvector(Ssrank(grp));
for (i=0; i<grp->g.ncomp; ++i)
{ simpgrp* g=Liecomp(grp,i); _index r=g->lierank;
copyrow(g->root_norm->compon,&result->compon[t],r); t+=r;
}
return result;
}
}
matrix* Cartan(void)
{ if (type_of(grp)==SIMPGRP) return simp_Cartan(&grp->s);
if (simpgroup(grp)) return simp_Cartan(Liecomp(grp,0));
{ _index i,j, t=0;
matrix* cartan=mat_null(Ssrank(grp),Lierank(grp));
for (i=0; i<grp->g.ncomp; ++i)
{ _index r=Liecomp(grp,i)->lierank;
entry** c=simp_Cartan(Liecomp(grp,i))->elm;
for (j=0; j<r; ++j) copyrow(c[j],&cartan->elm[t+j][t],r);
t+=r;
}
return cartan;
}
}
matrix* Posroots(object grp)
{ if (type_of(grp)==SIMPGRP) return simp_proots(&grp->s);
if (simpgroup(grp)) return simp_proots(Liecomp(grp,0));
{ _index i,j,t1=0,t2=0;
matrix* result=mat_null(Numproots(grp),Ssrank(grp));
entry** m=result->elm;
for (i=0; i<grp->g.ncomp; ++i)
{ matrix* posr=simp_proots(Liecomp(grp,i));
_index r=Liecomp(grp,i)->lierank;
for (j=0; j<posr->nrows; ++j) copyrow(posr->elm[j],&m[t1+j][t2],r);
t1+=posr->nrows; t2+=r;
}
return result;
}
}
matrix* Icartan(void)
{ if (simpgroup(grp)) return simp_icart(Liecomp(grp,0));
{ matrix* result=mat_null(Lierank(grp),Ssrank(grp)); entry** m=result->elm;
_index k,t=0;
entry det=Detcartan(); /* product of determinants of simple factors */
for (k=0; k<grp->g.ncomp; ++k)
{ simpgrp* g=Liecomp(grp,k);
_index i,j,r=g->lierank;
entry** a=simp_icart(g)->elm;
entry f=det/simp_detcart(g); /* multiplication factor */
for (i=0; i<r; ++i) for (j=0; j<r; ++j) m[t+i][t+j]=f*a[i][j];
t+=r;
}
return result;
}
}
matrix* Closure(matrix* m, boolean close, group* lie_type)
{ matrix* result; lie_Index i,j;
group* tp=(s=Ssrank(grp), lie_type==NULL ? mkgroup(s) : lie_type);
tp->toraldim=Lierank(grp); tp->ncomp=0; /* start with maximal torus */
m=copymatrix(m);
if (close)
if (type_of(grp)==SIMPGRP) close = two_lengths(grp->s.lietype);
else
{ for (i=0; i<grp->g.ncomp; i++)
if (two_lengths(Liecomp(grp,i)->lietype)) break;
close= i<grp->g.ncomp;
}
{ entry* t;
for (i=0; i<m->nrows; i++)
if (!isroot(t=m->elm[i]))
error("Set of root vectors contains a non-root\n");
else if (!isposroot(t=m->elm[i]))
for (j=0; j<m->ncols; j++) t[j]= -t[j]; /* make positive root */
Unique(m,cmpfn);
}
{ lie_Index next;
for (i=0; i<m->nrows; i=next)
{ lie_Index d,n=0; simpgrp* c;
next=isolcomp(m,i);
fundam(m,i,&next);
if (close) long_close(m,i,next),fundam(m,i,&next);
c=simp_type(&m->elm[i],d=next-i);
{ j=tp->ncomp++;
while(--j>=0 && grp_less(tp->liecomp[j],c))
n += (tp->liecomp[j+1]=tp->liecomp[j])->lierank;
tp->liecomp[++j]=c; tp->toraldim -= d;
/* insert component and remove rank from torus */
cycle_block(m,i-n,next,n);
/* move the |d| rows down across |n| previous rows */
}
}
}
if (lie_type==NULL)
return result=copymatrix(m),freemem(m),freemem(tp),result;
else return freemem(m),(matrix*)NULL; /* |Cartan_type| doesn't need |m| */
}
local poly* vdecomp_irr(entry* lambda)
{ if (type_of(grp)==SIMPGRP) return simp_vdecomp_irr(lambda,&grp->s);
if (simpgroup(grp)) return simp_vdecomp_irr(lambda,Liecomp(grp,0));
{ poly* result;
lie_Index i;
{ lie_Index td=grp->g.toraldim;
lambda+=Ssrank(grp);
result=mkpoly(1,td);
copyrow(lambda,*result->elm,td);
*result->coef=one;
}
for (i=grp->g.ncomp-1; i>=0; --i)
/* traverse simple components in reverse order */
{ simpgrp* g=Liecomp(grp,i);
lambda-=g->lierank;
result= Disjunct_mul_pol_pol(simp_vdecomp_irr(lambda,g),result);
}
return result;
}
}
boolean isposroot(entry* alpha)
{ _index i,s=Ssrank(grp);
for (i=0; i<s; ++i) if (alpha[i]!=0) return alpha[i]>0;
assert(false); return false; /* to avoid compiler warnings */
}
void checkroot(entry* alpha)
{ if (!isroot(alpha))
{ printarr(alpha,Ssrank(grp)); error (" is not a root.\n"); }
}
void testdom(entry* v, object grp)
{ _index j, s=Ssrank(grp);
for(j=0; j<s; j++) if (*v++<0) error ("Weight is not dominant\n");
}
group* Carttype(matrix* m)
{ group* type=mkgroup(s=Ssrank(grp)); /* rank bounds number of components */
Closure(m,false,type); return type;
}
