|
#############################################################################
##
#W qea.gi QuaGroup Willem de Graaf
##
##
## Constructors for quantized enveloping algebras, and highest
## weight modules.
##
############################################################################
##
## Some functions for dealing with "generalised binomials" as they
## appear in the basis of the Lusztig Z-form of the quea. These functions
## rewrite elements as linear combinations of basis elements.
##
## A binomial as the one below is expressed as [ delta, s ], where
## delta = 0,1 according to whether we multiply by K or not.
## An expression is a linear combination of such things.
##
QGPrivateFunctions.Multiply_Bin_Expr:= function( s, exx )
# expresses
#
# / K \
# | | * exx
# \ s /
#
# as a linear combination of such things...
# The algorithm is simply based on the definition of the binomial,
# and om some relations found in Lusztig, J. Amer math Soc. 1990
# 278.
local add_elm, expr, i, j, newexp, m, n, cf;
add_elm:= function( ee, elm, cf )
local pos;
pos:= Position( ee, elm );
if pos = fail then
Add( ee, elm ); Add( ee, cf );
else
ee[pos+1]:= ee[pos+1]+ cf;
if ee[pos+1]=0*ee[pos+1] then
Unbind( ee[pos] ); Unbind( ee[pos+1] );
ee:= Filtered( ee, x -> IsBound(x) );
fi;
fi;
return ee;
end;
expr:= exx;
for i in [1..s] do
# multiply expr by q^(-i+1)K-q^(i-1)K^-1:
newexp:= [ ];
for j in [1,3..Length(expr)-1] do
m:= expr[j];
if m[1] = 0 then
n:= ShallowCopy( m );
n[1]:= 1;
newexp:= add_elm( newexp, n, expr[j+1]*_q^(-i+1) );
else
n:= ShallowCopy( m );
n[2]:= n[2]+1;
newexp:= add_elm( newexp, n,
expr[j+1]*_q^(-i+1)*_q^m[2]*(_q^n[2]-_q^-n[2]) );
n:= ShallowCopy( m );
n[1]:= 0;
newexp:= add_elm( newexp, n,
expr[j+1]*_q^(-i+1)*_q^(2*m[2]) );
fi;
if m[1]=0 then
n:= ShallowCopy( m );
n[2]:= n[2]+1;
newexp:= add_elm( newexp, n,
expr[j+1]*_q^(i-1)*_q^-m[2]*(_q^n[2]-_q^-n[2]) );
n:= ShallowCopy( m );
n[1]:= 1;
newexp:= add_elm( newexp, n,
-expr[j+1]*_q^(i-1)*_q^(-2*m[2]) );
else
n:= ShallowCopy( m );
n[1]:= 0;
newexp:= add_elm( newexp, n, -expr[j+1]*_q^(i-1) );
fi;
od;
expr:= newexp;
od;
cf:= (_q-_q^-1)^s*GaussianFactorial( s, _q );
for i in [2,4..Length(expr)] do
expr[i]:= expr[i]/cf;
od;
return expr;
end;
QGPrivateFunctions.Multiply_K_Expr:= function( exx )
# multiply exx by K...
local add_elm, expr, i, m;
add_elm:= function( ee, elm, cf )
local pos;
pos:= Position( ee, elm );
if pos = fail then
Add( ee, elm ); Add( ee, cf );
else
ee[pos+1]:= ee[pos+1]+ cf;
if ee[pos+1]=0*ee[pos+1] then
Unbind( ee[pos] ); Unbind( ee[pos+1] );
ee:= Filtered( ee, x -> IsBound(x) );
fi;
fi;
return ee;
end;
expr:= [ ];
for i in [1,3..Length(exx)-1] do
m:= ShallowCopy( exx[i] );
if m[1] = 0 then
m[1]:= 1;
expr:= add_elm( expr, m, exx[i+1] );
else
m[2]:= m[2]+1;
expr:= add_elm( expr, m, exx[i+1]*_q^(m[2]-1)*(_q^m[2]-_q^-m[2]) );
m:= ShallowCopy( exx[i] );
m[1]:= 0;
expr:= add_elm( expr, m, exx[i+1]*_q^(2*m[2]) );
fi;
od;
return expr;
end;
QGPrivateFunctions.Multiply_Exp_Exp:= function( ex1, ex2 )
# multiply the two expressions ex1, ex2.
local add_elm, res, expr, i, j, m;
add_elm:= function( ee, elm, cf )
local pos;
pos:= Position( ee, elm );
if pos = fail then
Add( ee, elm ); Add( ee, cf );
else
ee[pos+1]:= ee[pos+1]+ cf;
if ee[pos+1]=0*ee[pos+1] then
Unbind( ee[pos] ); Unbind( ee[pos+1] );
ee:= Filtered( ee, x -> IsBound(x) );
fi;
fi;
return ee;
end;
res:= [ ];
for i in [ 1, 3 .. Length(ex1)-1] do
expr:= ex2;
m:= ex1[i];
if m[1] <> 0 then
expr:= QGPrivateFunctions.Multiply_K_Expr( expr );
fi;
expr:= QGPrivateFunctions.Multiply_Bin_Expr( m[2], expr );
for j in [1,3..Length(expr)-1] do
res:= add_elm( res, expr[j], expr[j+1]*ex1[i+1] );
od;
od;
return res;
end;
############################################################################
############################################################################
##
#M PrintObj( <wr> )
##
## We need a new PrintObj method for weight rep elements because in the one
## in the library there is a statement e[k+1] > 0, which will fail for
## q-elements.
##
InstallMethod( PrintObj,
"for weight rep element",
true,
[ IsWeightRepElement and IsPackedElementDefaultRep ], 0,
function( v )
local e,k;
e:= v![1];
if e = [] then
Print( "0*v0" );
else
for k in [1,3..Length(e)-1] do
if k>1 and not (IsRat(e[k+1]) and e[k+1]<0) then
Print("+" );
fi;
Print( e[k+1]*e[k][2], "*v0" );
od;
fi;
end );
############################################################################
##
#M ObjByExtRep( <fam>, <list> )
#M ExtRepOfObj( <obj> )
##
InstallMethod( ObjByExtRep,
"for family of QEA elements, and list",
true, [ IsQEAElementFamily, IsList ], 0,
function( fam, list )
#+
return Objectify( fam!.packedQEAElementDefaultType,
[ Immutable(list) ] );
end );
InstallMethod( ExtRepOfObj,
"for an QEA element",
true, [ IsQEAElement ], 0,
function( obj )
#+
return obj![1];
end );
###########################################################################
##
#M PrintObj( <m> ) . . . . . . . . . . . . . . . . for an QEA element
##
InstallMethod( PrintObj,
"for QEA element",
true, [IsQEAElement and IsPackedElementDefaultRep], 0,
function( x )
local lst, k, i, n, rank;
# This function prints an element of a quantized enveloping algebra.
lst:= x![1];
n:= FamilyObj( x )!.noPosRoots;
rank:= FamilyObj( x )!.rank;
if lst=[] then
Print("0");
else
for k in [1,3..Length(lst)-1] do
if k>1 then
Print("+");
fi;
if lst[k+1] <> lst[k+1]^0 then
Print( "(",lst[k+1],")*");
fi;
if lst[k] = [] then
Print("1");
else
for i in [1,3..Length(lst[k])-1] do
if IsList( lst[k][i] ) then
if lst[k][i][2] > 0 then
Print( "K", lst[k][i][1]-n );
fi;
if lst[k][i+1] > 0 then
Print( "[ K",lst[k][i][1]-n," ; ",
lst[k][i+1], " ]");
fi;
elif lst[k][i] <=n then
Print("F",lst[k][i]);
if lst[k][i+1]>1 then
Print("^(",lst[k][i+1],")");
fi;
else
Print("E",lst[k][i]-n-rank);
if lst[k][i+1]>1 then
Print("^(",lst[k][i+1],")");
fi;
fi;
if i <> Length(lst[k])-1 then
Print("*");
fi;
od;
fi;
od;
fi;
end );
#############################################################################
##
#M OneOp( <m> ) . . . . . . . . . . . . . . . . for a QEA element
#M ZeroOp( <m> ) . . . . . . . . . . . . . . . for a QEA element
#M \<( <m1>, <m2> ) . . . . . . . . . . . . . . for two QEA elements
#M \=( <m1>, <m2> ) . . . . . . . . . . . . . . for two QEA elements
#M \+( <m1>, <m2> ) . . . . . . . . . . . . . . for two QEA elements
#M \-( <m> ) . . . . . . . . . . . . . . for a QEA element
#M \in( <U>, <u> ) . . . . . . . . . . . . . . for QEA, and element
##
InstallMethod( OneOp,
"for QEA element",
true, [ IsQEAElement and IsPackedElementDefaultRep ], 0,
function( x )
return ObjByExtRep( FamilyObj( x ), [ [], FamilyObj(x)!.quantumPar^0 ] );
end );
InstallMethod( ZeroOp,
"for QEA element",
true, [ IsQEAElement and IsPackedElementDefaultRep ], 0,
function( x )
return ObjByExtRep( FamilyObj( x ), [ ] );
end );
InstallMethod( \<,
"for two QEA elements",
IsIdenticalObj, [ IsQEAElement and IsPackedElementDefaultRep,
IsQEAElement and IsPackedElementDefaultRep ], 0,
function( x, y )
return x![1]< y![1];
end );
InstallMethod( \=,
"for two QEA elements",
IsIdenticalObj, [ IsQEAElement and IsPackedElementDefaultRep,
IsQEAElement and IsPackedElementDefaultRep ], 0,
function( x, y )
return x![1] = y![1];
end );
InstallMethod( \+,
"for two QEA elements",
true, [ IsQEAElement and IsPackedElementDefaultRep,
IsQEAElement and IsPackedElementDefaultRep], 0,
function( x, y )
local ex, ey, mons, cfs, i, lst, len;
# Insert one sorted list in the second one;
# can be done much more efficiently!
ex:= x![1]; ey:= y![1];
mons:= [ ]; cfs:= [ ];
for i in [1,3..Length(ex)-1] do
Add( mons, ex[i] ); Add( cfs, ex[i+1] );
od;
for i in [1,3..Length(ey)-1] do
Add( mons, ey[i] ); Add( cfs, ey[i+1] );
od;
SortParallel( mons, cfs );
lst:= [ ];
for i in [1..Length( mons )] do
len:= Length(lst);
if len > 0 and lst[len-1] = mons[i] then
lst[len]:= lst[len]+cfs[i];
if lst[len] = 0*lst[len] then
Unbind( lst[len-1] ); Unbind( lst[len] );
lst:= Filtered( lst, x -> IsBound(x) );
fi;
else
Add( lst, mons[i] ); Add( lst, cfs[i] );
fi;
od;
return ObjByExtRep( FamilyObj(x), lst );
end );
InstallMethod( AdditiveInverseSameMutability,
"for QEA element",
true, [ IsQEAElement and IsPackedElementDefaultRep ], 0,
function( x )
local ex, i;
ex:= ShallowCopy(x![1]);
for i in [2,4..Length(ex)] do
ex[i]:= -ex[i];
od;
return ObjByExtRep( FamilyObj(x), ex );
end );
InstallMethod( AdditiveInverseMutable,
"for QEA element",
true, [ IsQEAElement and IsPackedElementDefaultRep ], 0,
function( x )
local ex, i;
ex:= ShallowCopy(x![1]);
for i in [2,4..Length(ex)] do
ex[i]:= -ex[i];
od;
return ObjByExtRep( FamilyObj(x), ex );
end );
#############################################################################
##
#M \*( <scal>, <m> ) . . . . . . . . .for a scalar and a QEA element
#M \*( <m>, <scal> ) . . . . . . . . .for a scalar and a QEA element
##
InstallMethod( \*,
"for scalar and QEA element",
true, [ IsScalar, IsQEAElement and
IsPackedElementDefaultRep ], 0,
function( scal, x )
local ex, i;
if IsZero( scal ) then return Zero(x); fi;
ex:= ShallowCopy( x![1] );
for i in [2,4..Length(ex)] do
ex[i]:= scal*ex[i];
od;
return ObjByExtRep( FamilyObj(x), ex );
end);
InstallMethod( \*,
"for QEA element and scalar",
true, [ IsQEAElement and IsPackedElementDefaultRep,
IsScalar ], 0,
function( x, scal )
local ex, i;
if IsZero( scal ) then return Zero(x); fi;
ex:= ShallowCopy( x![1] );
for i in [2,4..Length(ex)] do
ex[i]:= scal*ex[i];
od;
return ObjByExtRep( FamilyObj(x), ex );
end);
InstallMethod( \in,
"for QEA element and QEA",
true, [ IsQEAElement, IsQuantumUEA ], 0,
function( u, U )
return IsIdenticalObj( ElementsFamily( FamilyObj(U) ), FamilyObj(u) );
end );
#############################################################################
##
#F IsSpaceOfQEAElements( <V> )
##
## If <V> is a space of elements of a quantized universal enveloping algebra,
## then the `NiceFreeLeftModuleInfo' value of <V> is a record with the
## following components.
## \beginitems
## `family' &
## the elements family of <V>,
##
## `monomials' &
## a list of monomials occurring in the generators of <V>,
##
## `zerocoeff' &
## the zero coefficient of elements in <V>,
##
## `zerovector' &
## the zero row vector in the nice free left module,
##
## \enditems
## The `NiceVector' value of $v \in <V>$ is defined as the row vector of
## coefficients of $v$ w.r.t. the list `monomials'.
##
##
## This code is based on code by Thomas Breuer for the similar case
## of vector spaces spanned by polynomials.
##
DeclareHandlingByNiceBasis( "IsSpaceOfQEAElements",
"for free left modules of elements of a quantized uea" );
#############################################################################
##
#M NiceFreeLeftModuleInfo( <V> )
#M NiceVector( <V>, <v> )
#M UglyVector( <V>, <r> )
##
InstallHandlingByNiceBasis( "IsSpaceOfQEAElements", rec(
detect := function( F, gens, V, zero )
return IsQEAElementCollection( V );
end,
NiceFreeLeftModuleInfo := function( V )
local gens,
monomials,
gen,
list,
zero,
info;
gens:= GeneratorsOfLeftModule( V );
monomials:= [];
for gen in gens do
list:= ExtRepOfObj( gen );
UniteSet( monomials, list{ [ 1, 3 .. Length( list ) - 1 ] } );
od;
zero:= Zero( LeftActingDomain( V ) );
info:= rec( monomials := monomials,
zerocoeff := zero,
family := ElementsFamily( FamilyObj( V ) ) );
# For the zero row vector, catch the case of empty `monomials' list.
if IsEmpty( monomials ) then
info.zerovector := [ zero ];
else
info.zerovector := ListWithIdenticalEntries(
Length( monomials ), zero );
fi;
return info;
end,
NiceVector := function( V, v )
local info, c, monomials, i, pos;
info:= NiceFreeLeftModuleInfo( V );
c:= ShallowCopy( info.zerovector );
v:= ExtRepOfObj( v );
monomials:= info.monomials;
for i in [ 2, 4 .. Length( v ) ] do
pos:= Position( monomials, v[ i-1 ] );
if pos = fail then
return fail;
fi;
c[ pos ]:= v[i];
od;
return c;
end,
UglyVector := function( V, r )
local info, list, i;
info:= NiceFreeLeftModuleInfo( V );
if Length( r ) <> Length( info.zerovector ) then
return fail;
elif IsEmpty( info.monomials ) then
if IsZero( r ) then
return Zero( V );
else
return fail;
fi;
fi;
list:= [];
for i in [ 1 .. Length( r ) ] do
if r[i] <> info.zerocoeff then
Add( list, info.monomials[i] );
Add( list, r[i] );
fi;
od;
return ObjByExtRep( info.family, list );
end ) );
#############################################################################
##
#F CollectQEAElement( <sim>, <rts>, <B>, <s>, <rank>, <Mtab>, <expr> )
##
##
InstallGlobalFunction( CollectQEAElement,
function( fam, expr )
# `sim' are the simple roots.
# `rts' are the roots in convex order.
# `B' is the matrix of the bilinear form.
# `s' is the number of positive roots.
# `rank' is the rank of the root system.
# `Mtab' is the multiplication table.
# `qpar' is the quantum parameter.
# `expr' is the thing that needs to be collected.
local comm_rule, todo, res, m, cf, k, found, pos, k1,
k2, r, rel, start, tail, i, mn, m1, j, qp, coef,
list1, list2, binomial_with_cst, kbit, k_normal, ee, store,
R, sim, rts, B, s, rank, Mtab, qpar, isgeneric;
comm_rule:= function( rel, j, i, m, n, r )
# commutation rule for x_j^mx_i^n, where x_jx_i=qpar^rx_ix_j+rel
# We use the following formula (easily proved by induction):
#
# x_j^mx_i^n = q^{nmr}x_i^nx_j^m + \sum_{l=0}^{n-1} \sum_{k=0}^{m-1}
# q^{(lm+k)r} xi^l xj^{m-1-k}Rx_j^kx_i^{n-1-l}, where R = rel.
local rule, l, k, cf, u, mn, start, tail, qi, qj, den, t;
if j > s + rank then
qj:= _q^( rts[j-s-rank]*( B*rts[j-s-rank] )/2 );
else
qj:= _q^( rts[j]*( B*rts[j] )/2 );
fi;
if i > s +rank then
qi:= _q^( rts[i-s-rank]*( B*rts[i-s-rank] )/2 );
else
qi:= _q^( rts[i]*( B*rts[i] )/2 );
fi;
den:= GaussianFactorial( m, qj )*GaussianFactorial( n, qi );
rule:= [ [ i, n, j, m], qpar^(n*m*r) ];
for l in [0..n-1] do
for k in [0..m-1] do
cf:= _q^((l*m+k)*r)/den;
start:= [ ];
if l <> 0 then
Add( start, i ); Add( start, l );
cf:= cf*GaussianFactorial( l, qi );
fi;
if m-1-k <> 0 then
Add( start, j ); Add( start, m-1-k );
cf:= cf*GaussianFactorial( m-1-k, qj );
fi;
tail:= [];
if k <> 0 then
Add( tail, j ); Add( tail, k );
cf:= cf*GaussianFactorial( k, qj );
fi;
if n-1-l <> 0 then
Add( tail, i ); Add( tail, n-1-l );
cf:= cf*GaussianFactorial( n-1-l, qi );
fi;
for u in [1,3..Length(rel)-1] do
mn:= ShallowCopy( start );
Append( mn, rel[u] );
Append( mn, tail );
Add( rule, mn ); Add( rule, cf*rel[u+1] );
od;
od;
od;
return rule;
end;
binomial_with_cst:= function( c, t )
# The binomial
#
# / K; c \
# | |
# \ t /
#
# expressed in the integral basis. We use relations from Lusztig's
# paper.
local add_elm, i, j, res, Kmin, expr;
add_elm:= function( ee, elm, cf )
local pos;
if cf = 0*cf then return ee; fi;
pos:= Position( ee, elm );
if pos = fail then
Add( ee, elm ); Add( ee, cf );
else
ee[pos+1]:= ee[pos+1]+ cf;
if ee[pos+1]=0*ee[pos+1] then
Unbind( ee[pos] ); Unbind( ee[pos+1] );
ee:= Filtered( ee, x -> IsBound(x) );
fi;
fi;
return ee;
end;
res:= [ ];
if c <= -1 then
c:= -c;
for j in [0..t] do
expr:= [ [ 0, t-j ], (-1)^j*_q^( c*(t-j) )*
GaussianBinomial( c+j-1, j, _q ) ];
for i in [1..j] do
expr:= QGPrivateFunctions.Multiply_K_Expr( expr );
od;
for i in [1,3..Length(expr)-1] do
res:= add_elm( res, expr[i], expr[i+1] );
od;
od;
else
Kmin:= [ [ 1, 0 ], _q^0, [ 0, 1], _q^-1-_q ];
for j in [0..t] do
expr:= [ [ 0, t-j ], _q^( c*(t-j) )*
GaussianBinomial( c, j, _q ) ];
for i in [1..j] do
expr:= QGPrivateFunctions.Multiply_Exp_Exp( Kmin, expr );
od;
for i in [1,3..Length(expr)-1] do
res:= add_elm( res, expr[i], expr[i+1] );
od;
od;
fi;
return res;
end;
R:= fam!.rootSystem;
sim:= SimpleSystemNF(R);
rts:= fam!.convexRoots;
B:= BilinearFormMatNF(R);
s:= fam!.noPosRoots;
rank:= fam!.rank;
Mtab:= fam!.multTab;
qpar:= fam!.quantumPar;
if qpar = _q then
isgeneric:= true;
else
isgeneric:= false;
fi;
# In the program we use ... [ i, d, a ], s ... for
#
# / Ki; a \
# Ki^d | |
# \ s /
#
todo:= expr;
for k in [1,3..Length(todo)-1] do
for i in [1,3..Length(todo[k])-1] do
if IsList( todo[k][i] ) and Length( todo[k][i] ) = 2 then
todo[k][i]:= ShallowCopy( todo[k][i] );
Add( todo[k][i], 0 );
fi;
od;
od;
res:= [ ];
while todo <> [] do
m:= todo[1];
cf:= todo[2];
for i in [1,3..Length(m)-1] do
if IsList( m[i] ) and Length( m[i] ) = 2 then
m[i]:= ShallowCopy( m[i] );
Add( m[i], 0 );
fi;
od;
# We try to find indices in the `wrong' order.
k:= 1; found:= false;
while k < Length(m)-2 do
if IsList( m[k] ) then
k1:= m[k][1];
list1:= true;
else
k1:= m[k];
list1:= false;
fi;
if IsList( m[k+2] ) then
k2:= m[k+2][1];
list2:= true;
else
k2:= m[k+2];
list2:= false;
fi;
if k1 > k2 then
found:= true;
break;
elif k1 = k2 then
if not list1 then
if m[k] <= s then
qp:= qpar^( rts[m[k]]*(B*rts[m[k]])/2 );
cf:= cf*GaussianBinomial( m[k+1]+m[k+3], m[k+1], qp );
fi;
if m[k] > s + rank then
qp:= qpar^( rts[m[k]-s-rank]*(B*rts[m[k]-s-rank])/2 );
cf:= cf*GaussianBinomial( m[k+1]+m[k+3], m[k+1], qp );
fi;
m[k+1]:= m[k+1]+m[k+3];
if m[k+1] = 0*m[k+1] then
Unbind( m[k] ); Unbind( m[k+1] );
Unbind( m[k+2] ); Unbind( m[k+3] );
m:= Filtered( m, x -> IsBound(x) );
if k > 1 then
# there is a new elt on pos k, we have to check
# whether it is in the correct order with
# the previous element.
k:= k-2;
fi;
else
Unbind( m[k+2] ); Unbind( m[k+3] );
m:= Filtered( m, x -> IsBound(x) );
fi;
else
# both are K-elements, coming from the same K_{\alpha}
# we do nothing (for the moment).
k:= k+2;
fi;
else
k:= k+2;
fi;
od;
if not found then
# We add the monomial to `res'. However, we must still
# normalise the K-part...
start:= [ ];
k:= 1;
while k < Length( m ) and not IsList( m[k] ) do
Add( start, m[k] );
Add( start, m[k+1] );
k:= k+2;
od;
kbit:= [ ];
while k < Length( m ) and IsList( m[k] ) do
Add( kbit, m[k] );
Add( kbit, m[k+1] );
k:= k+2;
od;
tail:= [ ];
while k < Length( m ) do
Add( tail, m[k] );
Add( tail, m[k+1] );
k:= k+2;
od;
k_normal:= [ [], qpar^0];
ee:= [ ];
k:= 1;
while k < Length( kbit ) do
rel:= binomial_with_cst( kbit[k][3], kbit[k+1] );
if kbit[k][2] > 0 then
rel:= QGPrivateFunctions.Multiply_K_Expr( rel );
fi;
if ee <> [ ] then
ee:= QGPrivateFunctions.Multiply_Exp_Exp( ee, rel );
else
ee:= rel;
fi;
if k = Length(kbit)-1 or kbit[k][1] <> kbit[k+2][1] then
# add everything in `ee' to `k_normal',
# and start a new `ee':
qp:= qpar^( B[kbit[k][1]-s][kbit[k][1]-s]/2 );
store:= [ ];
for i in [1,3..Length(k_normal)-1] do
for j in [1,3..Length(ee)-1] do
mn:= ShallowCopy( k_normal[i] );
if ee[j] <> [ 0, 0 ] then
# Otherwise we multiply by one....
Add( mn, [ kbit[k][1], ee[j][1] ] );
Add( mn, ee[j][2] );
fi;
Add( store, mn );
Add( store, k_normal[i+1]*Value( ee[j+1], qp ) );
od;
od;
k_normal:= store;
ee:= [ ];
fi;
k:= k+2;
od;
for k in [1,3..Length(k_normal)-1] do
m:= ShallowCopy( start );
Append( m, k_normal[k] );
Append( m, tail );
coef:= cf*k_normal[k+1];
pos:= Position( res, m );
if pos <> fail then
res[pos+1]:= res[pos+1]+coef;
if res[pos+1] = 0*coef then
Unbind( res[pos] ); Unbind( res[pos+1] );
res:= Filtered( res, x -> IsBound(x) );
fi;
else
Add( res, m );
Add( res, coef );
fi;
od;
Unbind( todo[1] );
Unbind( todo[2] );
todo:= Filtered( todo, x -> IsBound(x) );
else
# we know k1 > k2...
if k1 > s+rank then
# i.e., k1 is an E
if k2 > s+rank then
# i.e., k2 is also an E, commutation from Mtab
if isgeneric then
r:= rts[k1-s-rank]*( B*rts[k2-s-rank]);
rel:= comm_rule( Mtab[k1][k2], m[k], m[k+2],
m[k+1], m[k+3], -r );
else
rel:= CollectQEAElement( ElementsFamily(
FamilyObj( fam!.genericQUEA ) ),
[ m{[k..k+3]}, _q^0 ] );
for i in [2,4..Length(rel)] do
rel[i]:= Value( rel[i], qpar );
od;
fi;
start:= m{[1..k-1]};
tail:= m{[k+4..Length(m)]};
for i in [1,3..Length(rel)-1] do
mn:= ShallowCopy( start );
Append( mn, rel[i] ); Append( mn, tail );
if i = 1 then
todo[1]:= mn;
todo[2]:= cf*rel[i+1];
else
Add( todo, mn ); Add( todo, cf*rel[i+1] );
fi;
od;
elif k2 > s then
# i.e., k2 is a K:
r:= -2*rts[k1-s-rank]*( B*sim[k2-s] )/B[k2-s][k2-s];
r:= r*m[k+1];
qp:= qpar^(B[k2-s][k2-s]/2);
coef:= qp^(r*m[k+2][2]);
mn:= m{[1..k-1]};
Add( mn, ShallowCopy(m[k+2]) );
mn[k][3]:= mn[k][3] + r;
Add( mn, m[k+3] );
Add( mn, m[k] ); Add( mn, m[k+1] );
Append( mn,m{[k+4..Length(m)]} );
todo[1]:= mn;
todo[2]:= cf*coef;
else
# k2 is an F, commutation from Mtab
if isgeneric then
rel:= comm_rule( Mtab[k1][k2], m[k], m[k+2],
m[k+1], m[k+3], 0 );
else
rel:= CollectQEAElement( ElementsFamily(
FamilyObj( fam!.genericQUEA ) ),
[ m{[k..k+3]}, _q^0 ] );
for i in [2,4..Length(rel)] do
rel[i]:= Value( rel[i], qpar );
od;
# change the K-elements back to slightly strange form...
for j in [1,3..Length(rel)-1] do
for i in [1,3..Length(rel[j])-1] do
if IsList( rel[j][i] ) and Length( rel[j][i] ) = 2 then
Add( rel[j][i], 0 );
fi;
od;
od;
fi;
start:= m{[1..k-1]};
tail:= m{[k+4..Length(m)]};
for i in [1,3..Length(rel)-1] do
mn:= ShallowCopy( start );
Append( mn, rel[i] ); Append( mn, tail );
if i = 1 then
todo[1]:= mn;
todo[2]:= cf;
else
Add( todo, mn ); Add( todo, cf*rel[i+1] );
fi;
od;
fi;
elif k1 > s then
# i.e., k1 is a K,
if k2 > s then
# i.e., k2 is also a K; they commute
mn:= m{[1..k-1]};
Add( mn, m[k+2] ); Add( mn, m[k+3] );
Add( mn, m[k] ); Add( mn, m[k+1] );
Append( mn,m{[k+4..Length(m)]} );
todo[1]:= mn;
todo[2]:= cf;
else
# i.e., k2 is an F:
r:= -2*rts[k2]*( B*sim[k1-s] )/B[k1-s][k1-s];
r:= r*m[k+3];
qp:= qpar^(B[k1-s][k1-s]/2);
coef:= qp^(r*m[k][2]);
mn:= m{[1..k-1]};
Add( mn, m[k+2] );
Add( mn, m[k+3] );
Add( mn, ShallowCopy(m[k]) );
mn[k+2][3]:= mn[k+2][3] + r;
Add( mn, m[k+1] );
Append( mn,m{[k+4..Length(m)]} );
todo[1]:= mn;
todo[2]:= cf*coef;
fi;
else
# i.e., k1, k2 are both F's.
# commutation from Mtab
if isgeneric then
r:= rts[k1]*( B*rts[k2]);
rel:= comm_rule( Mtab[k1][k2], m[k], m[k+2],
m[k+1], m[k+3], -r );
else
rel:= CollectQEAElement( ElementsFamily(
FamilyObj( fam!.genericQUEA ) ),
[ m{[k..k+3]}, _q^0 ] );
for i in [2,4..Length(rel)] do
rel[i]:= Value( rel[i], qpar );
od;
fi;
start:= m{[1..k-1]};
tail:= m{[k+4..Length(m)]};
for i in [1,3..Length(rel)-1] do
mn:= ShallowCopy( start );
Append( mn, rel[i] ); Append( mn, tail );
if i = 1 then
todo[1]:= mn; todo[2]:= cf*rel[i+1];
else
Add( todo, mn ); Add( todo, cf*rel[i+1] );
fi;
od;
fi;
fi;
od;
return res;
end);
#############################################################################
##
#M \*( <x>, <y> ) . . . . . . . . . . . . . . for two QEA elements
##
##
InstallMethod( \*,
"for two QEA elements",
IsIdenticalObj, [ IsQEAElement and IsPackedElementDefaultRep,
IsQEAElement and IsPackedElementDefaultRep ], 0,
function( x, y )
local ex, ey, expr, i, j, m, mons, cfs, len;
ex:= ExtRepOfObj(x);
ey:= ExtRepOfObj(y);
# We build the expression that needs to be collected.
expr:= [ ];
for i in [1,3..Length(ex)-1] do
for j in [1,3..Length(ey)-1] do
m:= ShallowCopy( ex[i] );
Append( m, ey[j] );
Add( expr, m );
Add( expr, ex[i+1]*ey[j+1] );
od;
od;
# We collect it.
expr:= CollectQEAElement( FamilyObj( x ), expr );
mons:= [ ]; cfs:= [ ];
for i in [1,3..Length(expr)-1] do
if not IsZero( expr[i+1] ) then
Add( mons, expr[i] ); Add( cfs, expr[i+1] );
fi;
od;
# Sort everything, take equal things together, wrap it up and return.
SortParallel( mons, cfs );
expr:= [ ];
len:= 0;
for i in [1..Length( mons )] do
if len > 0 and expr[len-1] = mons[i] then
expr[len]:= expr[len]+cfs[i];
if expr[len] = 0*expr[len] then
Unbind( expr[len-1] ); Unbind( expr[len] );
expr:= Filtered( expr, x -> IsBound(x) );
len:= len-2;
fi;
else
Add( expr, mons[i] ); Add( expr, cfs[i] );
len:= len+2;
fi;
od;
return ObjByExtRep( FamilyObj(x), expr );
end );
#########################################################################
##
#M QuantizedUEA( <R> )
##
InstallMethod( QuantizedUEA,
"for a root system",
true, [ IsRootSystem ], 0,
function( R )
local n, rank, B, fam, mm, Ftab, FEtab, tt, k, rel, i,
j, qp, ii, gens, A, normalise_rel;
# This function returns the quantized uea with respect to the root
# system R. This algebra is generated by F1...Fn, K1, K1^-1,
# ... Kr, Kr^-1, E1...En, where
# Fk = T_{i_1}...T_{i_{k-1}}(F_{\alpha_{ik}})
# Ek = T_{i_1}...T_{i_{k-1}}(E_{\alpha_{ik}}),
# where [ i_1,....,i_n ] is a redcued expression for the longest element
# in the Weyl group.
# The elements are represented as elements of the Lusztig
# Z-form of the quantized uea. The elements of this basis have the form
#
# F1^(k1)...Fn^(kn) K1^d1 [K1;m1] ... Kr^dr [Kr;mr] E1^(p1)..En^(pn)
#
# where di=0,1 and [Ki;mi] is the "binomial"
#
# / Ki; 0 \
# | |
# \ mi /
#
# Internally, such a monomial is represented as a list of indices
# and exponents: the F-s have indices 1,..,n and the E-s have indices
# n+r+1...2*n+r. Furthermore, an element Ki^di [Ki;mi] is represented as
# .... , [ i, di ], mi .... So, for example the monomial
# F2^(3) K2 [ K2;4 ] E6^(8) (in type G2) is represented as
# [ 2, 3, [ 2, 1 ], 4, 14, 8 ].
# Finally, a general element is represented as a list of monomials
# and coefficients.
normalise_rel:= function( s, rank, B, rel )
# writes the relation rel using the generalised binomials in Lusztig's
# Z-form of the quea.
local add_elm, i, j, k, l, res, m, mon, e, f, ks, k_piece,
new_piece, elm, ee, qp;
add_elm:= function( ee, elm, cf )
local pos;
pos:= Position( ee, elm );
if pos = fail then
Add( ee, elm ); Add( ee, cf );
else
ee[pos+1]:= ee[pos+1]+ cf;
if ee[pos+1]=0*ee[pos+1] then
Unbind( ee[pos] ); Unbind( ee[pos+1] );
ee:= Filtered( ee, x -> IsBound(x) );
fi;
fi;
return ee;
end;
res:= [ ];
for i in [1,3..Length(rel)-1] do
m:= rel[i];
k:= 1;
f:= [ ];
while k <= Length( m ) and m[k] <= s do
Add( f, m[k] );
Add( f, m[k+1] );
k:= k+2;
od;
ks:= [ ];
while k <= Length( m ) and m[k] <= s+rank do
Add( ks, m[k] );
Add( ks, m[k+1] );
k:= k+2;
od;
e:= [ ];
while k <= Length( m ) do
Add( e, m[k] );
Add( e, m[k+1] );
k:= k+2;
od;
k_piece:= [ [], _q^0 ];
for j in [1,3..Length(ks)-1] do
if ks[j+1] > 0 then
elm:= [ [1,0], _q^0 ];
ee:= elm;
for k in [2..ks[j+1]] do
ee:= QGPrivateFunctions.Multiply_Exp_Exp( ee, elm );
od;
else
elm:= [ [1,0], _q^0, [0,1], _q^-1-_q ];
ee:= elm;
for k in [2..-ks[j+1]] do
ee:= QGPrivateFunctions.Multiply_Exp_Exp( ee, elm );
od;
fi;
qp:= _q^( B[ks[j]-s][ks[j]-s]/2 );
for k in [2,4..Length(ee)] do
ee[k]:= Value( ee[k], qp );
od;
new_piece:= [ ];
for k in [1,3..Length(ee)-1] do
if ee[k] <> [ 0, 0 ] then
m:= [ ks[j], ee[k][1] ];
for l in [1,3..Length(k_piece)-1] do
mon:= ShallowCopy( k_piece[l] );
Add( mon, m );
Add( mon, ee[k][2] );
Add( new_piece, mon );
Add( new_piece, ee[k+1]*k_piece[l+1] );
od;
else
# we multiply by a scalar, effectively
for l in [1,3..Length(k_piece)-1] do
mon:= ShallowCopy( k_piece[l] );
Add( new_piece, mon );
Add( new_piece, ee[k+1]*k_piece[l+1] );
od;
fi;
od;
k_piece:= new_piece;
od;
for j in [1,3..Length(k_piece)-1] do
m:= ShallowCopy( f );
Append( m, k_piece[j] );
Append( m, e );
res:= add_elm( res, m, k_piece[j+1]*rel[i+1] );
od;
od;
return res;
end;
# First we produce the PBW generators of the quantized enveloping
# algebra corresponding to R. It mainly boils down to installing a
# lot of data in the family.
n:= Length(PositiveRoots(R));
rank:= Length( CartanMatrix(R) );
B:= BilinearFormMatNF( R );
fam:= NewFamily( "QEAEltFam", IsQEAElement );
fam!.packedQEAElementDefaultType:=
NewType( fam, IsPackedElementDefaultRep );
fam!.noPosRoots:= Length( PositiveRoots(R) );
fam!.rank:= Length( CartanMatrix(R) );
fam!.rootSystem:= R;
mm:= QGPrivateFunctions.E_Tab( R );
fam!.convexRoots:= mm[1]; # i.e., pos roots in convex order...
Ftab:= QGPrivateFunctions.F_tab( R, mm[2], mm[1] );
FEtab:= QGPrivateFunctions.FE_table( R, mm[2], Ftab, mm[1] );
# `tt' will contain all commutation relations (Etab, Ftab, FEtab)
tt:= List([1..n], x -> [] );
for k in [1..n] do
tt[k+rank+n]:= [];
od;
# We normalise the relations in the tables (by using
# E_a^{(k)} = E_a^n/[k]_a!
for k in [1..Length(mm[2])] do
rel:= List( mm[2][k][2], ShallowCopy );
for i in [1,3..Length(rel)-1] do
for j in [1,3..Length(rel[i])-1] do
qp:= _q^( mm[1][ rel[i][j] ]*(B*mm[1][rel[i][j]])/2);
rel[i][j]:= rel[i][j] + n + rank;
rel[i+1]:= rel[i+1]*
GaussianFactorial(rel[i][j+1],qp);
od;
od;
ii:= mm[2][k][1];
tt[ii[1]+rank+n][ii[2]+rank+n]:= rel;
od;
for k in [1..Length(Ftab)] do
rel:= List( Ftab[k][2], ShallowCopy );
for i in [1,3..Length(rel)-1] do
for j in [1,3..Length(rel[i])-1] do
qp:= _q^( mm[1][ rel[i][j] ]*(B*mm[1][rel[i][j]])/2);
rel[i+1]:= rel[i+1]*
GaussianFactorial(rel[i][j+1],qp);
od;
od;
tt[Ftab[k][1][1]][Ftab[k][1][2]]:= rel;
od;
for k in [1..Length(FEtab)] do
rel:= List( FEtab[k][2], ShallowCopy );
for i in [1,3..Length(rel)-1] do
for j in [1,3..Length(rel[i])-1] do
if rel[i][j] <= n then
qp:= _q^( mm[1][ rel[i][j] ]*
(B*mm[1][rel[i][j]])/2);
rel[i+1]:= rel[i+1]*
GaussianFactorial(rel[i][j+1],qp);
fi;
if rel[i][j] > n+rank then
qp:= _q^( mm[1][ rel[i][j]-n-rank ]*
(B*mm[1][rel[i][j]-n-rank])/2);
rel[i+1]:= rel[i+1]*
GaussianFactorial(rel[i][j+1],qp);
fi;
od;
od;
tt[FEtab[k][1][1]][FEtab[k][1][2]]:=
normalise_rel( n, rank, B, rel );
od;
fam!.multTab:= tt;
fam!.quantumPar:= _q;
# Finally construct the generators.
gens:= [ ];
for i in [1..n] do
gens[i]:= ObjByExtRep( fam, [ [ i, 1 ], _q^0 ] );
od;
for i in [1..Length( CartanMatrix(R) )] do
Add( gens, ObjByExtRep( fam, [ [ [ n+i, 1 ], 0 ], _q^0 ] ) );
qp:= _q^(B[i][i]/2);
# we need to sort the monomials in K^-1, to accomodate
# for changes in the sorting algorithm, which may lead to
# surprises otherwise...
if [ [n+i,1], 0 ] < [ [ n+i, 0 ], 1 ] then
Add( gens, ObjByExtRep( fam, [ [ [ n+i, 1 ], 0 ], _q^0,
[ [ n+i, 0 ], 1 ], qp^-1-qp ] ) );
else
Add( gens, ObjByExtRep( fam, [ [ [ n+i, 0 ], 1 ], qp^-1-qp,
[ [ n+i, 1 ], 0 ], _q^0 ] ) );
fi;
od;
for i in [1..n] do
Add( gens, ObjByExtRep( fam,
[ [ n+Length(CartanMatrix(R)) +i, 1 ], _q^0 ] ) );
od;
A:= Objectify( NewType( CollectionsFamily( FamilyObj( gens[1] ) ),
IsMagmaRingModuloRelations
and IsQuantumUEA
and IsGenericQUEA
and IsAttributeStoringRep ),
rec() );
SetIsAssociative( A, true );
SetLeftActingDomain( A, QuantumField );
SetGeneratorsOfLeftOperatorRing( A, gens );
SetGeneratorsOfLeftOperatorRingWithOne( A, gens );
SetOne( A, gens[1]^0 );
SetRootSystem( A, R );
SetQuantumParameter( A, _q );
# add a pointer to `A' to the family of the generators:
fam!.qAlgebra:= A;
return A;
end);
#########################################################################
##
#M QuantizedUEA( <R> )
##
InstallOtherMethod( QuantizedUEA,
"for a root system a ring, and a parameter",
true, [ IsRootSystem, IsField, IsObject ], 0,
function( R, F, v )
local n, rank, B, fam, tt, tt_new, k, rel, i,
j, qp, gens, A, uu;
n:= Length(PositiveRoots(R));
rank:= Length( CartanMatrix(R) );
B:= BilinearFormMatNF( R );
fam:= NewFamily( "QEAEltFam", IsQEAElement );
fam!.packedQEAElementDefaultType:=
NewType( fam, IsPackedElementDefaultRep );
fam!.noPosRoots:= Length( PositiveRoots(R) );
fam!.rank:= Length( CartanMatrix(R) );
fam!.rootSystem:= R;
uu:= QuantizedUEA( R );
fam!.genericQUEA:= uu;
tt:= ElementsFamily( FamilyObj( uu ) )!.multTab;
# copy tt and substitute v for q:
tt_new:= List([1..n], x -> [] );
for k in [1..n] do
tt_new[k+rank+n]:= [];
od;
for i in [1..Length(tt)] do
if IsBound( tt[i] ) then
for j in [1..Length(tt[i]) ] do
if IsBound( tt[i][j] ) then
rel:= List( tt[i][j], ShallowCopy );
for k in [2,4..Length(rel)] do
rel[k]:= Value( rel[k], v );
od;
tt_new[i][j]:= rel;
fi;
od;
fi;
od;
fam!.multTab:= tt_new;
# some more data:
fam!.convexRoots:= ElementsFamily( FamilyObj( uu ) )!.convexRoots;
fam!.quantumPar:= v;
# Finally construct the generators.
gens:= [ ];
for i in [1..n] do
gens[i]:= ObjByExtRep( fam, [ [ i, 1 ], v^0 ] );
od;
for i in [1..Length( CartanMatrix(R) )] do
Add( gens, ObjByExtRep( fam, [ [ [ n+i, 1 ], 0 ], v^0 ] ) );
qp:= v^(B[i][i]/2);
if IsZero( qp^-1-qp ) then
Add( gens, ObjByExtRep( fam, [ [ [ n+i, 1 ], 0 ], qp^0 ] ) );
else
# we need to sort the monomials in K^-1, to accomodate
# for changes in the sorting algorithm, which may lead to
# surprises otherwise...
if [ [n+i,1], 0 ] < [ [ n+i, 0 ], 1 ] then
Add( gens, ObjByExtRep( fam, [ [ [ n+i, 1 ], 0 ], qp^0,
[ [ n+i, 0 ], 1 ], qp^-1-qp ] ) );
else
Add( gens, ObjByExtRep( fam, [ [ [ n+i, 0 ], 1 ], qp^-1-qp,
[ [ n+i, 1 ], 0 ], qp^0 ] ) );
fi;
fi;
od;
for i in [1..n] do
Add( gens, ObjByExtRep( fam,
[ [ n+Length(CartanMatrix(R)) +i, 1 ], v^0 ] ) );
od;
A:= Objectify( NewType( CollectionsFamily( FamilyObj( gens[1] ) ),
IsMagmaRingModuloRelations
and IsQuantumUEA
and IsAttributeStoringRep ),
rec() );
SetIsAssociative( A, true );
SetLeftActingDomain( A, F );
SetGeneratorsOfLeftOperatorRing( A, gens );
SetGeneratorsOfLeftOperatorRingWithOne( A, gens );
SetOne( A, gens[1]^0 );
SetRootSystem( A, R );
SetQuantumParameter( A, v );
# add a pointer to `A' to the family of the generators:
fam!.qAlgebra:= A;
return A;
end);
#########################################################################
##
#M QuantizedUEA( <L> )
##
InstallOtherMethod( QuantizedUEA,
"for a semisimple Lie algebra",
true, [ IsLieAlgebra ], 0,
function( L )
return QuantizedUEA( RootSystem(L) );
end );
#########################################################################
##
#M QuantizedUEA( <L> )
##
InstallOtherMethod( QuantizedUEA,
"for a semisimple Lie algebra, a ring and a parameter",
true, [ IsLieAlgebra, IsField, IsObject ], 0,
function( L, F, qp )
return QuantizedUEA( RootSystem(L), F, qp );
end );
############################################################################
##
#M PrintObj( <QA> )
#M ViewObj( <QA> )
##
InstallMethod( PrintObj,
"for a QuantumUEA",
true, [ IsQuantumUEA ], 0,
function( A )
Print("QuantumUEA( ",RootSystem(A),", Qpar = ",QuantumParameter(A)," )" );
end );
InstallMethod( ViewObj,
"for a QuantumUEA",
true, [ IsQuantumUEA ], 0,
function( A )
PrintObj( A );
end );
#############################################################################
##
#M LeadingUEALatticeMonomial( <novar>, <f> )
##
##
InstallMethod( LeadingQEAMonomial,
"for an integer and a QEA element",
true, [ IS_INT, IsQEAElement ], 0,
function ( novar, p )
local e,max,cf,m,n,j,k,o,pos,deg,ind, degn;
# Reverse lexicographical ordering...
e:= p![1];
max:= e[1];
ind:= 1;
cf:= e[2];
m:= ListWithIdenticalEntries( novar, 0 );
for k in [1,3..Length(max)-1] do
m[max[k]]:= max[k+1];
od;
for k in [3,5..Length(e)-1] do
n:= ListWithIdenticalEntries( novar, 0 );
for j in [1,3..Length(e[k])-1] do
n[e[k][j]]:= e[k][j+1];
od;
o:= n-m;
# pos will be the last nonzero position
pos:= PositionProperty( Reversed(o), x -> x <> 0 );
pos:= novar-pos+1;
if o[pos] > 0 then
max:= e[k];
ind := k;
cf:= e[k+1];
m:= n;
fi;
od;
return [max, m, cf, ind];
end );
#############################################################################
##
#F LeftReduceQEEALatticeElement( <novar>, <G>, <lms>, <lmtab>, <p> )
##
##
##
InstallGlobalFunction( LeftReduceQEAElement,
function( novar, G, lms, lmtab, p )
local fam, reduced, rem, res, m1, k, g, diff, cme, mon,
cflmg, j, fac, fac1, cf, lm;
# We left-reduce the QUEA element `p' modulo the elements in `G'.
# Here `lms' is a list of leading monomial-indices; if the index `k'
# occurs somewhere in `lms', then g![1][k] is the leading monomial
# of `g', where `g' is the corresponding element of `G'. `novar'
# is the number of variables.
fam:= FamilyObj( p );
reduced:= false;
rem:= p;
res:= 0*p;
while rem <> 0*rem do
m1:= LeadingQEAMonomial( novar, rem );
k:= 1;
k:= Search( lmtab, m1[2] );
if k <> fail then
g:= G[k];
diff:= ShallowCopy( m1[2] );
cme:= g![1];
mon:= cme[ lms[k] ];
cflmg:= cme[ lms[k]+1 ];
for j in [1,3..Length(mon)-1] do
diff[mon[j]]:= diff[mon[j]] - mon[j+1];
od;
fac:= [ ];
for j in [1..novar] do
if diff[j] <> 0 then
Add( fac, j ); Add( fac, diff[j] );
fi;
od;
fac1:= ObjByExtRep( fam, [ fac, _q^0 ] )*g;
cf:= LeadingQEAMonomial( novar, fac1 )[3];
rem:= rem - (m1[3]/cf)*fac1;
else
lm:= ObjByExtRep( fam, [ m1[1], m1[3] ] );
res:= res + lm;
rem:= rem-lm;
fi;
od;
return res;
end );
QGPrivateFunctions.ActionCollect:=
function( sim, rts, B, s, rank, Mtab, qpar, expr )
# `sim' are the simple roots.
# `rts' are the roots in convex order.
# `B' is the matrix of the bilinear form.
# `s' is the number of positive roots.
# `rank' is the rank of the root system.
# `Mtab' is the multiplication table.
# `qpar' is the quantum parameter.
# `expr' is the thing that needs to be collected.
# Does the same as normal collection, except that monomials
# ending on an E are immediately discarded, and K-elements are
# not normalised...
local comm_rule, todo, res, m, cf, k, found, pos, k1,
k2, r, rel, start, tail, i, mn, m1, j, qp, coef,
list1, list2;
comm_rule:= function( rel, j, i, m, n, r )
# commutation rule for x_j^mx_i^n, where x_jx_i=qpar^rx_ix_j+rel
local rule, l, k, cf, u, mn, start, tail, qi, qj, den, t;
if j > s + rank then
qj:= qpar^( rts[j-s-rank]*( B*rts[j-s-rank] )/2 );
else
qj:= qpar^( rts[j]*( B*rts[j] )/2 );
fi;
if i > s +rank then
qi:= qpar^( rts[i-s-rank]*( B*rts[i-s-rank] )/2 );
else
qi:= qpar^( rts[i]*( B*rts[i] )/2 );
fi;
den:= GaussianFactorial( m, qj )*GaussianFactorial( n, qi );
rule:= [ [ i, n, j, m], qpar^(n*m*r) ];
for l in [0..n-1] do
for k in [0..m-1] do
cf:= qpar^((l*m+k)*r)/den;
start:= [ ];
if l <> 0 then
Add( start, i ); Add( start, l );
cf:= cf*GaussianFactorial( l, qi );
fi;
if m-1-k <> 0 then
Add( start, j ); Add( start, m-1-k );
cf:= cf*GaussianFactorial( m-1-k, qj );
fi;
tail:= [];
if k <> 0 then
Add( tail, j ); Add( tail, k );
cf:= cf*GaussianFactorial( k, qj );
fi;
if n-1-l <> 0 then
Add( tail, i ); Add( tail, n-1-l );
cf:= cf*GaussianFactorial( n-1-l, qi );
fi;
for u in [1,3..Length(rel)-1] do
mn:= ShallowCopy( start );
Append( mn, rel[u] );
Append( mn, tail );
Add( rule, mn ); Add( rule, cf*rel[u+1] );
od;
od;
od;
return rule;
end;
# In the program we use ... [ i, d, a ], s ... for
#
# / Ki; a \
# Ki^d | |
# \ s /
#
todo:= expr;
for k in [1,3..Length(todo)-1] do
for i in [1,3..Length(todo[k])-1] do
if IsList( todo[k][i] ) and Length( todo[k][i] ) = 2 then
todo[k][i]:= ShallowCopy( todo[k][i] );
Add( todo[k][i], 0 );
fi;
od;
od;
res:= [ ];
while todo <> [] do
found:= false;
while todo <> [] and not found do
m:= todo[1];
cf:= todo[2];
if m = [ ] then
found:= true;
break;
fi;
k:= m[Length(m)-1];
if IsList( k ) or k <= s then
# m ends with K or F:
found:= true;
else
Unbind( todo[1] ); Unbind( todo[2] );
todo:= Filtered( todo, x -> IsBound(x) );
fi;
od;
if todo = [ ] then break; fi;
for i in [1,3..Length(m)-1] do
if IsList( m[i] ) and Length( m[i] ) = 2 then
m[i]:= ShallowCopy( m[i] );
Add( m[i], 0 );
fi;
od;
# We try to find indices in the `wrong' order.
k:= 1; found:= false;
while k < Length(m)-2 do
if IsList( m[k] ) then
k1:= m[k][1];
list1:= true;
else
k1:= m[k];
list1:= false;
fi;
if IsList( m[k+2] ) then
k2:= m[k+2][1];
list2:= true;
else
k2:= m[k+2];
list2:= false;
fi;
if k1 > k2 then
found:= true;
break;
elif k1 = k2 then
if not list1 then
if m[k] <= s then
qp:= qpar^( rts[m[k]]*(B*rts[m[k]])/2 );
cf:= cf*GaussianBinomial( m[k+1]+m[k+3], m[k+1], qp );
fi;
if m[k] > s + rank then
qp:= qpar^( rts[m[k]-s-rank]*(B*rts[m[k]-s-rank])/2 );
cf:= cf*GaussianBinomial( m[k+1]+m[k+3], m[k+1], qp );
fi;
m[k+1]:= m[k+1]+m[k+3];
if m[k+1] = 0*m[k+1] then
Unbind( m[k] ); Unbind( m[k+1] );
Unbind( m[k+2] ); Unbind( m[k+3] );
m:= Filtered( m, x -> IsBound(x) );
if k > 1 then
# there is a new elt on pos k, we have to check
# whether it is in the correct order with
# the previous element.
k:= k-2;
fi;
else
Unbind( m[k+2] ); Unbind( m[k+3] );
m:= Filtered( m, x -> IsBound(x) );
fi;
else
# both are K-elements, coming from the same K_{\alpha}
# we do nothing (for the moment).
k:= k+2;
fi;
else
k:= k+2;
fi;
od;
if not found then
# We add the monomial to `res'.
pos:= Position( res, m );
if pos <> fail then
res[pos+1]:= res[pos+1]+cf;
if res[pos+1] = 0*cf then
Unbind( res[pos] ); Unbind( res[pos+1] );
res:= Filtered( res, x -> IsBound(x) );
fi;
else
Add( res, m );
Add( res, cf );
fi;
Unbind( todo[1] );
Unbind( todo[2] );
todo:= Filtered( todo, x -> IsBound(x) );
else
# we know k1 > k2...
if k1 > s+rank then
# i.e., k1 is an E
if k2 > s+rank then
# i.e., k2 is also an E, commutation from Mtab
r:= rts[k1-s-rank]*( B*rts[k2-s-rank]);
rel:= comm_rule( Mtab[k1][k2], m[k], m[k+2],
m[k+1], m[k+3], -r );
start:= m{[1..k-1]};
tail:= m{[k+4..Length(m)]};
for i in [1,3..Length(rel)-1] do
mn:= ShallowCopy( start );
Append( mn, rel[i] ); Append( mn, tail );
if i = 1 then
todo[1]:= mn;
todo[2]:= cf*rel[i+1];
else
Add( todo, mn ); Add( todo, cf*rel[i+1] );
fi;
od;
elif k2 > s then
# i.e., k2 is a K:
r:= -2*rts[k1-s-rank]*( B*sim[k2-s] )/B[k2-s][k2-s];
r:= r*m[k+1];
qp:= qpar^(B[k2-s][k2-s]/2);
coef:= qp^(r*m[k+2][2]);
mn:= m{[1..k-1]};
Add( mn, ShallowCopy(m[k+2]) );
mn[k][3]:= mn[k][3] + r;
Add( mn, m[k+3] );
Add( mn, m[k] ); Add( mn, m[k+1] );
Append( mn,m{[k+4..Length(m)]} );
todo[1]:= mn;
todo[2]:= cf*coef;
else
# k2 is an F, commutation from Mtab
rel:= comm_rule( Mtab[k1][k2], m[k], m[k+2],
m[k+1], m[k+3], 0 );
start:= m{[1..k-1]};
tail:= m{[k+4..Length(m)]};
for i in [1,3..Length(rel)-1] do
mn:= ShallowCopy( start );
Append( mn, rel[i] ); Append( mn, tail );
if i = 1 then
todo[1]:= mn;
todo[2]:= cf;
else
Add( todo, mn ); Add( todo, cf*rel[i+1] );
fi;
od;
fi;
elif k1 > s then
# i.e., k1 is a K,
if k2 > s then
# i.e., k2 is also a K; they commute
mn:= m{[1..k-1]};
Add( mn, m[k+2] ); Add( mn, m[k+3] );
Add( mn, m[k] ); Add( mn, m[k+1] );
Append( mn,m{[k+4..Length(m)]} );
todo[1]:= mn;
todo[2]:= cf;
else
# i.e., k2 is an F:
r:= -2*rts[k2]*( B*sim[k1-s] )/B[k1-s][k1-s];
r:= r*m[k+3];
qp:= qpar^(B[k1-s][k1-s]/2);
coef:= qp^(r*m[k][2]);
mn:= m{[1..k-1]};
Add( mn, m[k+2] );
Add( mn, m[k+3] );
Add( mn, ShallowCopy(m[k]) );
mn[k+2][3]:= mn[k+2][3] + r;
Add( mn, m[k+1] );
Append( mn,m{[k+4..Length(m)]} );
todo[1]:= mn;
todo[2]:= cf*coef;
fi;
else
# i.e., k1, k2 are both F's.
# commutation from Mtab
r:= rts[k1]*( B*rts[k2]);
rel:= comm_rule( Mtab[k1][k2], m[k], m[k+2],
m[k+1], m[k+3], -r );
start:= m{[1..k-1]};
tail:= m{[k+4..Length(m)]};
for i in [1,3..Length(rel)-1] do
mn:= ShallowCopy( start );
Append( mn, rel[i] ); Append( mn, tail );
if i = 1 then
todo[1]:= mn; todo[2]:= cf*rel[i+1];
else
Add( todo, mn ); Add( todo, cf*rel[i+1] );
fi;
od;
fi;
fi;
od;
return res;
end;
QGPrivateFunctions.Calc_Image:= function( qpar, x, v )
# a function for calculating the image of v under x. This is used
# at the end for calculating a list of images of the generators,
# if the dimension of the module is not too big.
# If the dimension is higher,
# then this function is also called from the method for \^.
local rank, s, hw, ev, qelm, ee, eres, k, i, cf, pos,
gb, p, wvecs, mons, cfts, ep, im, B, ind, qp,
ex, fam, R, m, j;
if IsZero( v ) then return v; fi;
rank:= FamilyObj( x )!.rank;
s:= FamilyObj( x )!.noPosRoots;
hw:= FamilyObj( v )!.highestWeight;
B:= BilinearFormMatNF( FamilyObj( x )!.rootSystem );
# qelm will be x*v1, where v1 is the corresponding element in U^-
# (corresponding to v). We reduce this element modulo the Groebner
# basis.
ev:= ExtRepOfObj( v );
qelm:= Sum( [1,3..Length(ev)-1], ii -> ev[ii+1]*ev[ii][2] );
qelm:= ExtRepOfObj( qelm );
ex:= ExtRepOfObj( x );
# We build the expression that needs to be collected.
ee:= [ ];
for i in [1,3..Length(ex)-1] do
for j in [1,3..Length(qelm)-1] do
m:= ShallowCopy( ex[i] );
Append( m, qelm[j] );
Add( ee, m );
Add( ee, ex[i+1]*qelm[j+1] );
od;
od;
fam:= FamilyObj(x);
R:= fam!.rootSystem;
# We collect it.
ee:= QGPrivateFunctions.ActionCollect(SimpleSystemNF(R),
fam!.convexRoots,
BilinearFormMatNF(R), fam!.noPosRoots, fam!.rank,
fam!.multTab, fam!.quantumPar, ee );
eres:= [ ];
for k in [1,3..Length(ee)-1] do
if ee[k] = [] then
# i.e., the monomial is 1, can go straight to eres
pos:= Position( eres, ee[k] );
if pos = fail then
Add( eres, ee[k] ); Add( eres, ee[k+1] );
else
eres[pos+1]:= eres[pos+1]+ee[k+1];
--> --------------------
--> maximum size reached
--> --------------------
[ Dauer der Verarbeitung: 0.91 Sekunden
(vorverarbeitet)
]
|
