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;
}
poly* SAtensor(boolean alt,_index m,poly* p)
{ _index n,r=Lierank(grp); poly** adams,** q,* result;
if (m==0) return poly_one(r); else if (m==1) return p;
adams=alloc_array(poly*,m+1);
for (n=1; n<=m; ++n) adams[n]=Adams(n,p);
q=alloc_array(poly*,m+1);
q[0]=poly_one(r);
for (n=1; n<=m; ++n)
{
{ _index i; q[n]=Tensor(p,q[n-1]); /* the initial term of the summation */
for (i=2; i<=n; ++i) q[n] =
Add_pol_pol(q[n],Tensor(adams[i],q[n-i]),alt&&i%2==0);
}
{ _index i; bigint* big_n=entry2bigint(n); setshared(big_n);
for (i=0; i<q[n]->nrows; ++i)
{ bigint** cc= &q[n]->coef[i]
,* c= (clrshared(*cc),isshared(*cc)) ? copybigint(*cc,NULL) : *cc;
*cc=divq(c,big_n); setshared(*cc);
{ if (c->size != 0)
error("Internal error (SAtensor): remainder from %ld.\n" ,(long)n);
freemem(c);
}
}
clrshared(big_n); freemem(big_n);
}
}
result=q[m];
{ for (n=1; n<=m; ++n) freepol(adams[n]); } freearr(adams);
{ for (n=0; n<m; ++n) freepol(q[n]); } freearr(q);
return result;
}
cmp_tp height_decr(entry* v,entry * w, lie_Index len)
{ lie_Index i; entry delta=0;
assert(level_vec!=NULL && Lierank(level_vec_group)==len);
for (i=0; i<len; ++i) delta += (v[i]-w[i])*level_vec[i];
if (delta) return delta>0 ? 1 : -1;
return lex_decr(v,w,len); /* for equal level, revert to lexicographic */
}
poly* Plethysm(entry* lambda,_index l,_index n,poly* p)
{ if (n==0) return poly_one(Lierank(grp)); else if (n==1) return p;
{ _index i,j;
poly* sum= poly_null(Lierank(grp)),**adams=alloc_array(poly*,n+1);
poly* chi_lambda=MN_char(lambda,l);
for (i=1; i<=n; ++i) { adams[i]=Adams(i,p); setshared(adams[i]); }
for (i=0;i<chi_lambda->nrows;i++)
{ entry* mu=chi_lambda->elm[i]; poly* prod=adams[mu[0]],*t;
for (j=1; j<n && mu[j]>0; ++j)
{ t=prod; prod=Tensor(t,adams[mu[j]]); freepol(t); }
sum= Addmul_pol_pol_bin(sum,prod,mult(chi_lambda->coef[i],Classord(mu,n)));
}
freemem(chi_lambda);
setshared(p); /* protect |p|; it coincides with |adams[1]| */
for (i=1; i<=n; ++i)
{ clrshared(adams[i]); freepol(adams[i]); } freearr(adams);
clrshared(p);
{ bigint* fac_n=fac(n); setshared(fac_n); /* used repeatedly */
for (i=0; i<sum->nrows; ++i)
{ bigint** cc= &sum->coef[i]
,* c= (clrshared(*cc),isshared(*cc)) ? copybigint(*cc,NULL) : *cc;
*cc=divq(c,fac_n); setshared(*cc);
if (c->size!=0) error("Internal error (plethysm).\n"); else freemem(c);
}
clrshared(fac_n); freemem(fac_n);
}
return sum;
}
}
poly* Adams(_index n,poly* p)
{ if (n==1) return p; /* avoid work in this trivial case */
{ _index i,j, r=Lierank(grp); poly* dom_ch=Domchar_p(p);
for (i=0; i<dom_ch->nrows; ++i)
for (j=0; j<r; j++) dom_ch->elm[i][j] *= n;
{ poly* result=Vdecomp(dom_ch); freepol(dom_ch); return result; }
}
}
matrix* Weyl_mat(vector* word)
{ lie_Index i,j,r=Lierank(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;
Waction(m[i],word);
}
return res;
}
poly* Vdecomp(poly* p)
{ lie_Index i,r=Lierank(grp);
poly* result=poly_null(r);
cur_expon=mkintarray(r); /* large enough */
for (i=0; i<p->nrows; ++i)
result=Addmul_pol_pol_bin(result,vdecomp_irr(p->elm[i]),p->coef[i]);
freearr(cur_expon);
return result;
}
cmpfn_tp set_ordering (cmpfn_tp criterion, lie_Index n, object g)
{ if (criterion!=height_decr && criterion!=height_incr) return criterion;
if (g==NULL || n!=Lierank(g))
return criterion==height_decr ? deg_decr : deg_incr; /* substitute */
if (level_vec==NULL
|| int_eq_grp_grp(g,level_vec_group)==(object)bool_false)
{ if (level_vec!=NULL) freearr(level_vec);
level_vec=Lv(g); level_vec_group=g;
}
return criterion;
}
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;
}
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;
}
}
vector* Exponents(object grp)
{ if (type_of(grp)==SIMPGRP)
{ simp_exponents(&grp->s); return grp->s.exponents; }
if (simpgroup(grp))
{ simp_exponents(Liecomp(grp,0)); return Liecomp(grp,0)->exponents; }
{ _index i,t=0; vector* v=mkvector(Lierank(grp)); entry* e=v->compon;
{ for (i=0; i<grp->g.ncomp; ++i)
{ simpgrp* g=Liecomp(grp,i); _index r=g->lierank;
copyrow(simp_exponents(g),&e[t],r); t+=r;
}
for (i=0; i<grp->g.toraldim; ++i) e[t+i]=0;
}
return v;
}
}
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| */
}
poly* Adjoint(object grp)
{ _index i,j,r=Lierank(grp)
,n=type_of(grp)==SIMPGRP ? 1: grp->g.ncomp+(grp->g.toraldim!=0);
poly* adj= mkpoly(n,r);
for (i=0; i<n; ++i)
{ adj->coef[i]=one; for (j=0; j<r; ++j) adj->elm[i][j]=0; }
if (type_of(grp)==SIMPGRP) set_simp_adjoint(adj->elm[0],&grp->s);
else
{ _index offs=0; simpgrp* g;
for (i=0; i<grp->g.ncomp; offs+=g->lierank,++i)
set_simp_adjoint(&adj->elm[i][offs],g=Liecomp(grp,i));
if (grp->g.toraldim!=0)
{ adj->coef[i]=entry2bigint(grp->g.toraldim);
setshared(adj->coef[i]);
}
}
return adj;
}
matrix* Center(object grp)
{ _index i,j,R=Lierank(grp),n_gen;
for (n_gen=grp->g.toraldim,i=0; i<grp->g.ncomp; ++i)
{ simpgrp* g=Liecomp(grp,i);
if (simp_detcart(g)>1) n_gen+=1+(g->lietype=='D' && g->lierank%2==0);
}
{ matrix* res=mat_null(n_gen,R+1); entry** m=res->elm; _index k=0,s=0;
for (j=0; j<grp->g.ncomp; ++j)
{ simpgrp* g=Liecomp(grp,j); _index n=g->lierank; entry d=simp_detcart(g);
if (d>1)
{
switch (g->lietype)
{ case 'A': for (i=0; i<n; ++i) m[k][s+i]=i+1;
/* $[1,2,3,\ldots,n]$; $d=n+1$ */
break; case 'B': m[k][s+n-1]=1; /* $[0,0,\ldots,0,1]$; $d=2$ */
break; case 'C': for (i=0; i<n; i+=2) m[k][s+i]=1;
/* $[1,0,1,0,\ldots]$; $d=2$ */
break; case 'D':
{ m[k][s+n-2]=m[k][s+n-1]=1;
if (n%2==1) for (i=0; i<n; i+=2) m[k][s+i]+=2;
/* $[2,0,2,\ldots,2,1,3]$; $d=4$ */
else
{ d=2; m[k++][R]=d; /* $[0,0,\ldots,0,1,1]$; $d=2$ */
for (i=0; i<n; i+=2) m[k][s+i]=1; /* $[1,0,1,\ldots,1,0]$; $d=2$ */
}
}
break; case 'E':
if (n==7)
{ m[k][s+1]=m[k][s+4]=m[k][s+6]=1; } /* $[0,1,0,0,1,0,1]$; $d=2$ */
else { m[k][s]=m[k][s+4]=1; m[k][s+2]=m[k][s+5]=2; }
/* $[1,0,2,0,1,2]$; $d=3$ */
}
m[k++][R]=d; /* insert denominator for last generator, and advance */
}
s+=n; /* advance offset into semisimple elements */
}
for (i=0; i<grp->g.toraldim; ++i) m[k++][s+i]=1;
assert(k==n_gen); return res;
}
}
void char_init(object g) {
set_weight_sorting(g);
wt_init(Lierank(g));
}
entry Dimgrp(object grp)
{ return Lierank(grp) + 2*Numproots(grp); }
